macrolayer.lisp (3152 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 11 #+5am (defmacro show-bound (unbind predicate thing &body body) 12 `(progn (,unbind ',thing) 13 ,@body 14 (,predicate ',thing))) 15 #+5am (defmacro show-boundfn (fn &body body) 16 `(show-bound fmakunbound fboundp ,fn ,@body)) 17 #+5am (defmacro show-boundvar (var &body body) 18 `(show-bound makunbound boundp ,var ,@body)) 19 20 #+5am (select-preference 'fboundp '(("SLYNK" "OPERATOR-ARGLIST"))) 21 22 (defmacro defweak-strings (namespace boundp sl-name &rest qualified-names) 23 "Make a weak definition, based on preferences. Probably should use wrapper 24 functions instead of this one, as it takes string arguments." 25 (with-gensyms (symname package new-namespace) 26 `(let (,new-namespace) 27 (setf (symbol-function ',new-namespace) (symbol-function ',namespace)) 28 (multiple-value-bind (,symname ,package) 29 (select-preference ',boundp ',(group qualified-names 2)) 30 (setf (symbol-function (intern ,symname)) 31 (funcall (symbol-function ',new-namespace) 32 (intern ,symname ,package))))))) 33 34 #+5am (show-boundfn operator-arglist 35 (defweak-strings symbol-function fboundp "OPERATOR-ARGLIST" 36 "SWANK" "OPERATOR-ARGLIST" 37 "SLYNK" "OPERATOR-ARGLIST")) 38 39 (defmacro defweak (namespace boundp sl-name &rest qualified-names) 40 "Symbol wrapper for defweak-strings." 41 `(defweak-strings ,namespace ,boundp ,(symbol-name sl-name) 42 ,@(loop for q in qualified-names 43 collect (symbol-name q)))) 44 45 #+5am (show-boundfn operator-arglist 46 (defweak symbol-function fboundp operator-arglist 47 swank operator-arglist 48 slynk operator-arglist)) 49 50 (defmacro defequivs (namespace boundp sl-name &rest packages) 51 "Define a name which is already the same in multiple packages." 52 `(defweak ,namespace ,boundp ,sl-name ,@packages)) 53 54 #+5am (show-boundfn operator-arglist (defequivs symbol-function fboundp operator-arglist swank slynk)) 55 56 57 (defmacro defsl (sl-name fn eq-ql &rest preflist) 58 (with-gensyms (fs qq) 59 `(let ((,fs (if (functionp ',fn) 60 ',fn 61 (symbol-function ',fn))) 62 (,qq ,eq-ql)) 63 (cond ((eql `(,,fs ,,qq) '(:fn :eq)) 64 (defequivs symbol-function fboundp ,sl-name ,@preflist)) 65 ((eql `(,,fs ,,qq) '(:sym :eq)) 66 (defequivs symbol-value boundp ,sl-name ,@preflist)) 67 ((eql ,fs `(:fn ,,qq)) 68 (defweak symbol-function fboundp ,sl-name ,qq)) 69 ((eql ,fs `(:sym ,,qq)) 70 (defweak symbol-value boundp ,sl-name ,qq)) 71 (t (if (eql ,qq :eq) 72 (defequivs ,fn ,sl-name ,@preflist) 73 (defweak ,fs ,sl-name ,qq))))))) 74 75 #+5am (defsl operator-arglist fboundp :eq slynk swank) 76 #+5am (defsl operator-arglist :fn :eq slynk swank)