From b77c44db6f6322378f8c61e7150e1180e2a7d99b Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Sun, 21 Mar 2021 10:28:35 -0700 Subject: set property function cells using DEFUN-WHICH-CALLS Signed-off-by: Sean Whitton --- src/util.lisp | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) (limited to 'src/util.lisp') diff --git a/src/util.lisp b/src/util.lisp index 3afc228..89c327c 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -72,6 +72,44 @@ supported." unless (char= #\& (char (symbol-name arg*) 0)) collect arg*)) +(defmacro defun-which-calls (name call lambda-list &body forms &aux remaining) + (with-gensyms (result) + (multiple-value-bind (required optional rest kwargs aokeys) + (parse-ordinary-lambda-list lambda-list) + (when (and aokeys (not rest)) + (simple-program-error + "&ALLOW-OTHER-KEYS without &REST in property lambda list not supported.")) + (let ((call* (destructuring-bind (first . rest) (ensure-cons call) + `(#',first ,@rest))) + (normalisedll (reverse required))) + (when optional + (push '&optional normalisedll) + (loop for (name init suppliedp) in optional + for suppliedp* = (or suppliedp (gensym)) + do (push `(,name ,init ,suppliedp*) normalisedll) + do (push `(when ,suppliedp* (push ,name ,result)) remaining))) + (when rest + (push '&rest normalisedll) + (push rest normalisedll) + (push `(dolist (r ,rest) (push r ,result)) remaining)) + (when kwargs + (push '&key normalisedll) + (loop for ((keyword-name name) init suppliedp) in kwargs + for suppliedp* = (if (or rest suppliedp) suppliedp (gensym)) + do (push `((,keyword-name ,name) ,init ,suppliedp*) + normalisedll) + unless rest do (push `(when ,suppliedp* + (push ,keyword-name ,result) + (push ,name ,result)) + remaining))) + (when aokeys + (push '&allow-other-keys normalisedll)) + `(defun ,name ,(nreverse normalisedll) + ,@forms + (apply ,@call* ,@required (let (,result) + ,@(nreverse remaining) + (nreverse ,result)))))))) + (defmacro define-simple-error (name &optional docstring) `(progn (define-condition ,name (simple-error) () -- cgit v1.2.3