commit 373125798010d6f8751a26ce41f314cb7ff6aac3 Spenser Truex <spensertruexonline@gmail.com> 2019-07-02 21:40:25 -0700 Thin layer over sly/slime.
macrolayer.lisp | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ sl.asd | 2 ++ sl.lisp | 64 ++--------------------------------- utils.lisp | 36 ++++++++++++++++++++ 4 files changed, 144 insertions(+), 61 deletions(-)
diff --git a/macrolayer.lisp b/macrolayer.lisp new file mode 100644 index 0000000..c0762bd --- /dev/null +++ b/macrolayer.lisp @@ -0,0 +1,103 @@ +;;; This file is meant to provide a macro layer for Sly and Slime + + +;;; This contains a few things: +;;; - 5AM is used for testing, but only if it is a *features* member. + +;;; The macros get more specific as you go to the end of the file. +(in-package :sl) + +#+5am (defmacro show-bound (unbind predicate thing &body body) + `(progn (,unbind ',thing) + ,@body + (,predicate ',thing))) +#+5am (defmacro show-boundfn (fn &body body) + `(show-bound fmakunbound fboundp ,fn ,@body)) +#+5am (defmacro show-boundvar (var &body body) + `(show-bound makunbound boundp ,var ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *preference-list* '(slynk swank) + "The order in which to choose the IDE for pinging. Use the name of the CL +interface, not the Emacs name (ie sly->slynk, slime->swank).")) + +(defun select-preference (boundp qnames &optional (preflist *preference-list*)) + "Choose the function to use based on user preference." + (when preflist + (let* ((res (select (lambda (x) (string-equal (car x) (symbol-name + (car preflist)))) + qnames)) + (package (car res)) + (symname (cadr res))) + (if (and res (find-package package)) + (values symname package) + (select-preference boundp qnames (cdr preflist)))))) +#+5am (select-preference 'fboundp '(("SLYNK" "OPERATOR-ARGLIST"))) + +(defmacro defweak-strings (namespace boundp sl-name &rest qualified-names) + "Make a weak definition, based on preferences. Probably should use wrapper +functions instead of this one, as it takes string arguments." + `(setf (,namespace (intern ,sl-name)) + (multiple-value-bind (symname package) + (select-preference ',boundp ',(group qualified-names 2)) + (,namespace (intern symname package))))) +#+5am (show-boundfn operator-arglist + (defweak-strings symbol-function fboundp "OPERATOR-ARGLIST" + "SWANK" "OPERATOR-ARGLIST" + "SLYNK" "OPERATOR-ARGLIST")) + +(defmacro defweak (namespace boundp sl-name &rest qualified-names) + "Symbol wrapper for defweak-strings." + `(defweak-strings ,namespace ,boundp ,(symbol-name sl-name) + ,@(loop for q in qualified-names + collect (symbol-name q)))) +#+5am (show-boundfn operator-arglist + (defweak-syms symbol-function fboundp operator-arglist + swank operator-arglist + slynk operator-arglist)) + +(defmacro defequivs (namespace boundp sl-name &rest packages) + "Define a name which is already the same in multiple packages." + `(defweak-syms ,namespace ,boundp ,sl-name + ,@(append (interpol sl-name packages) (list sl-name)))) +#+5am (show-boundfn operator-arglist (defequivs symbol-function fboundp operator-arglist swank slynk)) + +(defmacro andcond (&rest pairs) + "Insert AND into a list in the condition position of a COND." + `(cond ,@(loop for p in pairs + collect (cons (list* 'and (car p)) + (cdr p))))) +#+5am (andcond (((eql t nil) (eql t t)) 'x) + ((t nil) 'y)) + +(defun gen-case (base ex) + (if (symbolp ex) + (list 'eql base ex) + (append ex (list base)))) +#+5am (and (gen-case :fn :fn) + (not (gen-case :fn '(listp)))) + +(defmacro bicase (a b &rest cases) + `(cond ,@(loop for c in cases + collect (list* (and (gen-case a (car c)) + (gen-case b (cadr c))) + (cddr c))))) +#+5am (bicase :a :b + ((eql :a) (eql :b) t) + (:a :b 'h)) +(defmacro defsl (sl-name fn-sym eq-ql &optional (preflist *preference-list*)) + "Magic macro to associate a name with functions in other packages, based on the preferences." + `(bicase + ,fn-sym ,eq-ql + (:fn :eq (defequivs symbol-function fboundp ,sl-name ,@preflist)) + (:fn (not :eq) (defweak symbol-function fboundp ,sl-name ,@eq-ql)) + (:sym :eq (defequivs symbol-name boundp ,sl-name ,@preflist)) + (:sym (not :eq) (defweak symbol-name boundp ,sl-name ,@eq-ql)) + ((listp) :eq (defequivs ,@(pack fn-sym) ,sl-name ,@preflist)) + ((listp) (not :eq) (defweak ,@(pack fn-sym) ,sl-name ,@eq-ql)))) +#+5am (defsl operator-arglist (symbol-function fboundp) :eq) +#+5am (defsl operator-arglist :fn :eq) + ;; (defmacro defmagic (sl-name &key fn var sl-only packages) + ;; "Attempt to magically use the right macro with minimum information." + ;; ()) +;; (defweakequiv defweakfn "operator-arglist") diff --git a/sl.asd b/sl.asd index 50b74eb..882c2e4 100644 --- a/sl.asd +++ b/sl.asd @@ -5,6 +5,8 @@ :serial t :license "GNU GPL v3" :components ((:file "package") + (:file "utils") + (:file "macrolayer") (:file "sl")) :weakly-depends-on (:slynk :swank) :depends-on (:alexandria)) diff --git a/sl.lisp b/sl.lisp index 5760a55..ba080dc 100644 --- a/sl.lisp +++ b/sl.lisp @@ -1,63 +1,5 @@ -(in-package :sl) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun group (source n) - (labels ((rec (source acc) - (let ((rest (nthcdr n source))) - (if (consp rest) - (rec rest (cons - (subseq source 0 n) - acc)) - (nreverse - (cons source acc)))))) - (if source (rec source nil) nil))) - (defvar *preference-list* '("slynk" "swank") - "The order in which to choose the IDE for pinging. Use the name of the CL -interface, not the Emacs name (ie sly->slynk, slime->swank).")) - -(defun select (fn lst) - "Return the first element that matches the function." - (if (null lst) - nil - (let ((val (funcall fn (car lst)))) - (if val - (values (car lst) val) - (select fn (cdr lst)))))) - -(defun select-preference (boundp qnames &optional (preflist *preference-list*)) - (when preflist - (let* ((res (select (lambda (x) (string-equal (car x) (car preflist))) - qnames)) - (package (string-upcase (car res))) - (symname (string-upcase (cadr res)))) - (if (and res (find-package package)) - symname - (select-preference boundp qnames (cdr preflist)))))) - -#+5am (select-preference 'fboundp '(("slynk" "slynk:operator-arglist")) - '("slynk" "swank")) +;;; Provide least common denominator shared functionality between Sly and Slime. -(defmacro defweak (namespace boundp sl-name &rest qualified-names) - "Make a weak definition, based on preferences. Probably should use wrapper -functions instead of this one." - ;; FIXME: Why can't I get the symbol's package without errors? - `(setf (,namespace (intern ,sl-name)) - (select-preference ',boundp ',(group qualified-names 2)))) - -(defmacro defweakfn (sl-name &rest qualified-names) - "Define a weak function, based on preferences." - `(defweak symbol-function fboundp ,sl-name ,@qualified-names)) - -(defmacro defweakvar (sl-name &rest qualified-names) - `(defweak symbol-value boundp ,sl-name ,@qualified-names)) - -(defmacro defweakequiv (defweak sl-name &optional (preflist *preference-list*)) - `(,defweak ,sl-name - ,@(mapcar #'(lambda (x) (list x (concatenate 'string x ":" sl-name))) - preflist))) - -(defweakfn "operator-arglist" - "swank" "swank:operator-arglist" - "slynk" "slynk:operator-arglist") +(in-package :sl) -(defweakequiv defweakfn "operator-arglist") +(defequivsfn operator-arglist) diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..d9c43f9 --- /dev/null +++ b/utils.lisp @@ -0,0 +1,36 @@ +(in-package :sl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; From Graham's OnLisp + (defun pack (obj) + "Ensure obj is a cons." + (if (consp obj) obj (list obj))) + (defun shuffle (x y) + "Interpolate lists x and y with the first item being from x." + (cond ((null x) y) + ((null y) x) + (t (list* (car x) (car y) + (shuffle (cdr x) (cdr y)))))) + (defun interpol (obj lst) + "Intersperse an object in a list." + (shuffle lst (loop for #1=#.(gensym) in (cdr lst) + collect obj))) + (defun group (source n) + (labels ((rec (source acc) + (let ((rest (nthcdr n source))) + (if (consp rest) + (rec rest (cons + (subseq source 0 n) + acc)) + (nreverse + (cons source acc)))))) + (if source (rec source nil) nil)))) + +(defun select (fn lst) + "Return the first element that matches the function." + (if (null lst) + nil + (let ((val (funcall fn (car lst)))) + (if val + (values (car lst) val) + (select fn (cdr lst))))))