diff options
| -rw-r--r-- | src/property.lisp | 34 | ||||
| -rw-r--r-- | src/util.lisp | 71 |
2 files changed, 47 insertions, 58 deletions
diff --git a/src/property.lisp b/src/property.lisp index 8fd8436..3ee663e 100644 --- a/src/property.lisp +++ b/src/property.lisp @@ -234,13 +234,7 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV." (when (> (length ,declarations) 1) (error "Multiple DECLARE forms unsupported.")) ,@mforms - (let ((indent (cadr (assoc 'indent (cdar ,declarations)))) - ;; Current implementation can DEFUN the property only when - ;; its :APPLY subroutine has the property's lambda list; - ;; this will fail to hold only for DEFPROPLIST/DEFPROPSPEC. - (can-defun - (and (getf ,slotsv :apply) - (equal (cadr (getf ,slotsv :apply)) ,lambdav)))) + (let ((indent (cadr (assoc 'indent (cdar ,declarations))))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (record-known-property ',,name)) @@ -253,22 +247,20 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV." ;; code than going via DEFPROPSPEC/DEFPROPLIST for simple ;; things like installing packages. ,@(and - can-defun - `((defun-which-calls ,,name (propapply ',,name) ,,lambdav - ;; Have to insert code to check connection type - ;; because %CONSFIGURE won't see a programmatic call - ;; and check this as is does for regular propapps. - ,@(and (eq ,typev :lisp) - '((assert-connection-supports :lisp))) + (getf ,slotsv :apply) + `((defun-with-args ,,name args ,,lambdav ;; Properties with :HOSTATTRS subroutines which set ;; new hostattrs should not be used programmatically - ;; in this way, and using properties with :HOSTATTRS - ;; subroutines which only look at existing hostattrs - ;; has the potential for trouble too, so issue a - ;; warning. - ,@(and - (getf ,slotsv :hostattrs) - '((warn-programmatic-apply-hostattrs)))))))))))))) + ;; in this way, so issue a warning. + ,@(and (getf ,slotsv :hostattrs) + '((warn-programmatic-apply-hostattrs))) + (%consfigure + nil + (make-host + :propspec + (make-propspec + :systems nil + :propspec (cons ',,name args))))))))))))))) (defun warn-programmatic-apply-hostattrs () (warn "Calling property which has :HOSTATTRS subroutine programmatically. diff --git a/src/util.lisp b/src/util.lisp index a607f4d..242fbdb 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -72,43 +72,40 @@ 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 defun-with-args (name argsym lambda-list &body forms &aux remaining) + (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 ((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 ,argsym)) remaining))) + (when rest + (push '&rest normalisedll) + (push rest normalisedll) + (push `(dolist (r ,rest) (push r ,argsym)) 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 ,argsym) + (push ,name ,argsym)) + remaining))) + (when aokeys + (push '&allow-other-keys normalisedll)) + `(defun ,name ,(nreverse normalisedll) + (let ((,argsym (list ,@(reverse required)))) + ,@(nreverse remaining) + (nreversef ,argsym) + ,@forms))))) (defmacro define-simple-error (name &optional docstring) `(progn |