macrolayer.lisp (4925 bytes)
1 ;;; This file is meant to provide a macro layer for Sly and Slime 2 3 4 ;;; This contains a few things: 5 ;;; - 5AM is used for testing, but only if it is a *features* member. 6 7 ;;; The abstraction gets more specific as you go to the end of the file. 8 9 (in-package :sl) 10 (eval-when (:compile-toplevel :load-toplevel :execute) 11 (defun gen-case (base ex) 12 (if (symbolp ex) 13 (list 'eql base ex) 14 (append ex (list base)))) 15 (defun select-preference (boundp qnames) 16 "Choose the function to use based on user preference." 17 (labels ((select-preference-aux (boundp qnames preflist) 18 (when preflist 19 (let* ((res (select (lambda (x) 20 (string-equal (car x) (car preflist))) 21 qnames)) 22 (package (car res)) 23 (symname (cadr res))) 24 (if (and res (find-package package)) 25 (values symname package) 26 (select-preference-aux boundp qnames (cdr preflist))))))) 27 (select-preference-aux boundp qnames (mapcar #'car qnames))))) 28 29 #+5am (defmacro show-bound (unbind predicate thing &body body) 30 `(progn (,unbind ',thing) 31 ,@body 32 (,predicate ',thing))) 33 #+5am (defmacro show-boundfn (fn &body body) 34 `(show-bound fmakunbound fboundp ,fn ,@body)) 35 #+5am (defmacro show-boundvar (var &body body) 36 `(show-bound makunbound boundp ,var ,@body)) 37 38 #+5am (select-preference 'fboundp '(("SLYNK" "OPERATOR-ARGLIST"))) 39 40 (defmacro defweak-strings (namespace boundp sl-name &rest qualified-names) 41 "Make a weak definition, based on preferences. Probably should use wrapper 42 functions instead of this one, as it takes string arguments." 43 `(setf (,namespace (intern ,sl-name)) 44 (multiple-value-bind (symname package) 45 (select-preference ',boundp ',(group qualified-names 2)) 46 (,namespace (intern symname package))))) 47 #+5am (show-boundfn operator-arglist 48 (defweak-strings symbol-function fboundp "OPERATOR-ARGLIST" 49 "SWANK" "OPERATOR-ARGLIST" 50 "SLYNK" "OPERATOR-ARGLIST")) 51 52 (defmacro defweak (namespace boundp sl-name &rest qualified-names) 53 "Symbol wrapper for defweak-strings." 54 `(defweak-strings ,namespace ,boundp ,(symbol-name sl-name) 55 ,@(loop for q in qualified-names 56 collect (symbol-name q)))) 57 #+5am (show-boundfn operator-arglist 58 (defweak symbol-function fboundp operator-arglist 59 swank operator-arglist 60 slynk operator-arglist)) 61 62 (defmacro defequivs (namespace boundp sl-name &rest packages) 63 "Define a name which is already the same in multiple packages." 64 `(defweak ,namespace ,boundp ,sl-name 65 ,@(append (interpol sl-name packages) (list sl-name)))) 66 #+5am (show-boundfn operator-arglist (defequivs symbol-function fboundp operator-arglist swank slynk)) 67 68 (defmacro andcond (&rest pairs) 69 "Insert AND into a list in the condition position of a COND." 70 `(cond ,@(loop for p in pairs 71 collect (cons (list* 'and (car p)) 72 (cdr p))))) 73 #+5am (andcond (((eql t nil) (eql t t)) 'x) 74 ((t nil) 'y)) 75 #+5am (and (gen-case :fn :fn) 76 (not (gen-case :fn '(listp)))) 77 78 (defmacro bicase (a b &rest cases) 79 "Cover a CASE with two objects, and insert them into predicates." 80 ;; FIXME: the predicate insertion is fragile: only flat lists allowed 81 ;; FIXME: This should be generatlized for n cases (not just two). 82 `(cond ,@(loop for c in cases 83 collect (list* (and (gen-case a (car c)) 84 (gen-case b (cadr c))) 85 (cddr c))))) 86 #+5am (bicase :a :b 87 ((eql :a) (eql :b) t) 88 (:a :b 'h)) 89 90 (defun neql (a b) 91 "Not eql." 92 ;; KLUDGE: this thing only exists to keep `bicase' flat. 93 (not (eql a b))) 94 (defmacro defsl (sl-name fn-sym eq-ql &rest preflist) 95 "Magic macro to associate a name with functions in other packages, based on the preferences." 96 ;; FIXME: This thing generates invalid--though inaccessible code. This makes 97 ;; those compilation errors. 98 ;; FIXME: This thing is way unhygienic. Once-only, and in-order would be nice. 99 `(bicase 100 ,fn-sym ,eq-ql 101 (:fn :eq (defequivs symbol-function fboundp ,sl-name ,@preflist)) 102 (:fn (neql :eq) (defweak symbol-function fboundp ,sl-name ,@(pack eq-ql))) 103 (:sym :eq (defequivs symbol-value boundp ,sl-name ,@preflist)) 104 (:sym (neql :eq) (defweak symbol-value boundp ,sl-name ,@(pack eq-ql))) 105 ((listp) :eq (defequivs ,@(pack fn-sym) ,sl-name ,@preflist)) 106 ((listp) (neql :eq) (defweak ,@(pack fn-sym) ,sl-name ,@(pack eq-ql))))) 107 #+5am (defsl operator-arglist (symbol-function fboundp) :eq slynk swank) 108 #+5am (defsl operator-arglist :fn :eq slynk swank)