commit 47e05d4b72582af2969958fbcb83f58cfc3c0bd7 equwal <13551856+equwal@users.noreply.github.com> 2026-10-03 17:33:53 -0700 Add the defsl rewrite that the previous commit describes Commit 28a2c3b holds only the deletion of utils.lisp. A failed git add left the other files unstaged. That commit does not load, because its sl.asd still lists utils. This commit adds the rest of the change: the new macrolayer.lisp, the sl/test system in sl.asd, and test.lisp.
macrolayer.lisp | 128 ++++++++++++++++++++++++-------------------------------- sl.asd | 13 +++++- test.lisp | 93 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 159 insertions(+), 75 deletions(-)
diff --git a/macrolayer.lisp b/macrolayer.lisp index ca5d7c2..879cf32 100644 --- a/macrolayer.lisp +++ b/macrolayer.lisp @@ -1,76 +1,58 @@ -;;; 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 abstraction gets more specific as you go to the end of the file. +;;; DEFSL gives a name to the first available definition among forks. +;;; +;;; The macro only parses its arguments. RESOLVE makes the choice when the +;;; expansion runs, from strings. Thus the reader needs none of the packages. (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)) - -#+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." - (with-gensyms (symname package new-namespace) - `(let (,new-namespace) - (setf (symbol-function ',new-namespace) (symbol-function ',namespace)) - (multiple-value-bind (,symname ,package) - (select-preference ',boundp ',(group qualified-names 2)) - (setf (symbol-function (intern ,symname)) - (funcall (symbol-function ',new-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 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 ,namespace ,boundp ,sl-name ,@packages)) - -#+5am (show-boundfn operator-arglist (defequivs symbol-function fboundp operator-arglist swank slynk)) - - -(defmacro defsl (sl-name fn eq-ql &rest preflist) - (with-gensyms (fs qq) - `(let ((,fs (if (functionp ',fn) - ',fn - (symbol-function ',fn))) - (,qq ,eq-ql)) - (cond ((eql `(,,fs ,,qq) '(:fn :eq)) - (defequivs symbol-function fboundp ,sl-name ,@preflist)) - ((eql `(,,fs ,,qq) '(:sym :eq)) - (defequivs symbol-value boundp ,sl-name ,@preflist)) - ((eql ,fs `(:fn ,,qq)) - (defweak symbol-function fboundp ,sl-name ,qq)) - ((eql ,fs `(:sym ,,qq)) - (defweak symbol-value boundp ,sl-name ,qq)) - (t (if (eql ,qq :eq) - (defequivs ,fn ,sl-name ,@preflist) - (defweak ,fs ,sl-name ,qq))))))) - -#+5am (defsl operator-arglist fboundp :eq slynk swank) -#+5am (defsl operator-arglist :fn :eq slynk swank) +(defun namespace (designator) + "Return the accessor and the bound-predicate that DESIGNATOR names." + (case designator + (:fn '(symbol-function fboundp)) + (:sym '(symbol-value boundp)) + (t designator))) + +(defun candidates (name spec) + "Return the (package-name symbol-name) pairs of SPEC, best first." + (cond ((eq (first spec) :eq) + (loop for package in (rest spec) + collect (list (string package) (string name)))) + ((evenp (length spec)) + (loop for (package symbol) on spec by #'cddr + collect (list (string package) (string symbol)))) + (t (error "DEFSL ~S: a package in ~S has no symbol." name spec)))) + +(defun resolve (name boundp candidates) + "Return the first of CANDIDATES that is a symbol which satisfies BOUNDP." + (loop for (package symbol-name) in candidates + for symbol = (and (find-package package) + (find-symbol symbol-name package)) + when (and symbol (funcall boundp symbol)) + return symbol + finally (error "DEFSL ~S: no definition is available in ~ + ~{~{~A:~A~}~^, ~}." + name candidates))) + +(defmacro defsl (name namespace &rest spec) + "Define NAME as the first available definition that SPEC lists. + +NAMESPACE is :FN for a function, :SYM for a variable, or a list +(ACCESSOR BOUNDP). ACCESSOR is a SETF-able function of a symbol. BOUNDP is a +predicate of a symbol. + +SPEC is :EQ and the packages that share NAME, or pairs of a package and a +symbol. A candidate is available if its package exists, the package has the +symbol, and the symbol satisfies BOUNDP. + + (defsl operator-arglist :fn :eq slynk swank) + (defsl gensymmer (macro-function macro-function) + utils with-unique-names + alexandria with-gensyms) + +The definition exists at compile time, so a file can use an alias of a macro +that it defines." + (destructuring-bind (accessor boundp) (namespace namespace) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (,accessor ',name) + (,accessor (resolve ',name #',boundp ',(candidates name spec)))) + ',name))) diff --git a/sl.asd b/sl.asd index 8992a46..abae834 100644 --- a/sl.asd +++ b/sl.asd @@ -8,8 +8,17 @@ :serial t :license "GNU GPL v3" :components ((:file "package") - (:file "utils") (:file "macrolayer") (:file "sl")) :weakly-depends-on (:slynk :swank) - :depends-on (:alexandria)) + :in-order-to ((test-op (test-op :sl/test)))) + +(defsystem :sl/test + :description "Tests for SL, with fixture forks and with real forks" + :depends-on (:sl :fiveam :slynk :swank :md5 :eos :cl-utilities :alexandria + (:feature :sbcl (:require :sb-md5))) + :components ((:file "test")) + :perform (test-op (o c) + (unless (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :sl :sl-test)) + (error "The SL tests failed.")))) diff --git a/test.lisp b/test.lisp new file mode 100644 index 0000000..34f710e --- /dev/null +++ b/test.lisp @@ -0,0 +1,93 @@ +;;; Tests for DEFSL. Run them with (asdf:test-system :sl). + +(defpackage #:sl-test.a (:use)) +(defpackage #:sl-test.b (:use)) +(defpackage #:sl-test.c (:use)) + +(defpackage #:sl-test + (:use #:cl #:fiveam #:sl)) +(in-package #:sl-test) + +(def-suite sl :description "DEFSL takes the first available definition.") +(in-suite sl) + +;;; Fixture forks. Each test decides which of them define GREET. + +(defparameter *forks* '(sl-test.a sl-test.b sl-test.c) + "The fixture packages, in the order of preference that the tests use.") + +(defun provide-greet (available) + "Define GREET in each AVAILABLE fork, and in no other fork." + (dolist (fork *forks*) + (let ((greet (intern "GREET" fork))) + (if (member fork available) + (setf (symbol-function greet) (constantly fork)) + (fmakunbound greet))))) + +(test first-available-fork-wins + "For each subset of forks that define GREET, DEFSL takes the first one." + (dotimes (mask (expt 2 (length *forks*))) + (let ((available (loop for fork in *forks* + for bit from 0 + when (logbitp bit mask) collect fork))) + (provide-greet available) + (fmakunbound 'greet) + (if available + (progn (defsl greet :fn :eq sl-test.a sl-test.b sl-test.c) + (is (eq (first available) (funcall 'greet)))) + (signals error + (defsl greet :fn :eq sl-test.a sl-test.b sl-test.c)))))) + +(test missing-package-is-skipped + (provide-greet '(sl-test.b)) + (is (eq 'greet (defsl greet :fn :eq sl-test.no-such-fork sl-test.b))) + (is (eq 'sl-test.b (funcall 'greet)))) + +(test qualified-names + "Each fork can use its own name. DEFSL interns no symbol to look one up." + (provide-greet '(sl-test.b)) + (defsl hello :fn sl-test.a salute sl-test.b greet) + (is (eq 'sl-test.b (funcall 'hello))) + (is (null (find-symbol "SALUTE" 'sl-test.a)))) + +(test variables + (setf (symbol-value (intern "*MOTTO*" 'sl-test.b)) "fork b") + (defsl *motto* :sym :eq sl-test.a sl-test.b) + (is (equal "fork b" (symbol-value '*motto*)))) + +(test malformed-spec + "A package without a symbol is an error when the macro expands." + (signals error (macroexpand '(defsl greet :fn sl-test.a greet sl-test.b)))) + +;;; Real forks. The test system loads both sides of each fork, except MICROS, +;;; so the first preference wins. + +(defsl operator-arglist :fn :eq slynk swank micros) + +(test slime-forks + "Sly's SLYNK comes before SLIME's SWANK and Lem's MICROS." + (is (eq #'operator-arglist #'slynk:operator-arglist)) + (is (stringp (operator-arglist "car" "CL")))) + +(defsl md5sum-string :fn :eq sb-md5 md5) + +(test md5-forks + "SB-MD5 is SBCL's fork of MD5. Other implementations fall back to MD5." + (is (equalp #(144 1 80 152 60 210 79 176 214 150 63 125 40 225 127 114) + (md5sum-string "abc")))) + +(defsl check (macro-function macro-function) eos is fiveam is) + +(test fiveam-forks + "Eos is a fork of FiveAM. A list names the namespace of macros." + (is (eq (macro-function 'check) (macro-function 'eos:is)))) + +(defsl gensymmer (macro-function macro-function) + cl-utilities with-unique-names + alexandria with-gensyms) + +(test renamed-macro + "The alias exists at compile time, so this file can use it as a macro." + (is (eq (macro-function 'gensymmer) + (macro-function 'cl-utilities:with-unique-names))) + (is (symbolp (gensymmer (name) name))))