set property function cells using DEFUN-WHICH-CALLS

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

2 files changed, 52 insertions, 58 deletions

diff --git a/src/property.lisp b/src/property.lisp
index a2bf2e2..1b55b5e 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -227,41 +227,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))))
-		   ;; Instead of complicating this to support more
-		   ;; declarations, could avoid the need for it by defining a
-		   ;; function which just calls PROPAPPAPPLY.  Note that we
-		   ;; would need to parse the lambda list in order to get all
-		   ;; the variable names, so we don't have to just use (&REST
-		   ;; ARGS) which is worse for the user.
-		   (defun-declarations
-		     (loop
-		       for form in (append (getf ,slotsv :check)
-					   (getf ,slotsv :apply))
-		       when (form-beginning-with declare form)
-			 nconc
-			 (loop
-			   for declaration in (cdr form)
-			   collect
-			   (case (car declaration)
-			     (ignore
-			      (cons 'ignorable (cdr declaration)))
-			     (ignorable
-			      declaration)
-			     (t
-			      (simple-program-error
-			       "Unsupported declaration ~S in property subroutine."
-			       (car declaration)))))))
-		   ;; In the DEFUN below for calling the property
-		   ;; programmatically, we can only call the :CHECK subroutine
-		   ;; if it has the same lambda list as the :APPLY subroutine
-		   ;; (as it will for properties defined with DEFPROP).
-		   (check (and (getf ,slotsv :check)
-			       (equal (cadr (getf ,slotsv :check))
-				      (cadr (getf ,slotsv :apply)))
-			       `(when (progn ,@(strip-declarations
-						(cddr (getf ,slotsv :check))))
-				  (return-from ,,name :no-change)))))
+	     (let ((indent (cadr (assoc 'indent (cdar ,declarations)))))
 	       `(progn
 		  (eval-when (:compile-toplevel :load-toplevel :execute)
 		    (record-known-property ',,name))
@@ -273,29 +239,19 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV."
 		  ;; routines of other properties.  This can lead to clearer
 		  ;; code than going via DEFPROPSPEC/DEFPROPLIST for simple
 		  ;; things like installing packages.
-		  ,@(and
-		     (getf ,slotsv :apply)
-		     (destructuring-bind (sym ll . forms)
-			 (getf ,slotsv :apply)
-		       (declare (ignore sym))
-		       `((defun ,,name ,ll
-			   (declare ,@defun-declarations)
-			   ;; 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)))
-			   ;; 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)))
-			   ,@(and check `(,check))
-			   ,@(strip-declarations forms)))))))))))))
+		  (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)))
+		    ;; 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))))))))))))
 
 (defun warn-programmatic-apply-hostattrs ()
   (warn "Calling property which has :HOSTATTRS subroutine programmatically.
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) ()