add :PREPROCESS property subroutines

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

3 files changed, 42 insertions, 6 deletions

diff --git a/doc/properties.rst b/doc/properties.rst
index 7a1c299..ddae56b 100644
--- a/doc/properties.rst
+++ b/doc/properties.rst
@@ -10,8 +10,19 @@ special meaning in unevaluated property application specifications.
 Property subroutines
 --------------------
 
-A property is composed of four subroutines, which all take the same
-arguments.  At least one of ``:hostattrs`` or ``:apply`` must be present.
+A property is composed of up to five subroutines, which all have the same
+lambda list (take the same arguments).  At least one of ``:hostattrs``,
+``:apply`` or ``:unapply`` must be present.
+
+``:preprocess`` subroutines
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Executed in the root Lisp to modify the arguments that will be passed to the
+other subroutines; should return a fresh list of the new arguments.  This
+subroutine is called on each atomic property application within a property
+application specification before the effects of property combinators have been
+applied.  That is, it is effectively executed on atomic property applications
+in isolation from the property application specifications in which they occur.
 
 ``:hostattrs`` subroutines
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/src/property.lisp b/src/property.lisp
index 2ba108a..aa6082b 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -26,7 +26,7 @@
 ;; make it a bit more difficult for someone who hasn't read that part of the
 ;; docs to accidentally violate immutability.
 
-(defun setprop (sym type &key args desc hostattrs check apply unapply)
+(defun setprop (sym type &key args desc preprocess hostattrs check apply unapply)
   ;; use non-keyword keys to avoid clashes with other packages
   (when type
     (setf (get sym 'type) type))
@@ -34,6 +34,8 @@
     (setf (get sym 'args) args))
   (when desc
     (setf (get sym 'desc) desc))
+  (when preprocess
+    (setf (get sym 'preprocess) preprocess))
   (when hostattrs
     (setf (get sym 'hostattrs) hostattrs))
   (when check
@@ -49,11 +51,18 @@
 	      apply)))
   (when unapply
     (setf (get sym 'unapply) unapply))
+  (setf (get sym 'property) t)
   sym)
 
+(defun isprop (prop)
+  (and (symbolp prop) (get prop 'property nil)))
+
 (defun proptype (prop)
   (get prop 'type))
 
+(defun proppp (prop)
+  (get prop 'preprocess (lambda (&rest args) args)))
+
 (defun propapptype (propapp)
   (get (car propapp) 'type))
 
@@ -96,7 +105,7 @@
     (loop for form in forms
 	  if (keywordp (car form))
 	  do (setf (getf slots (car form)) (cdr form)))
-    (loop for kw in '(:hostattrs :check :apply :unapply)
+    (loop for kw in '(:preprocess :hostattrs :check :apply :unapply)
 	  do (if-let ((slot (getf slots kw)))
 	       (setf (getf slots kw)
 		     ;; inside this lambda we could do some checking of, e.g.,
diff --git a/src/propspec.lisp b/src/propspec.lisp
index 262c147..f63958c 100644
--- a/src/propspec.lisp
+++ b/src/propspec.lisp
@@ -81,6 +81,21 @@ systems, resolve unapply, onchange etc., and then look in the value cell of
 each PROPERTY to find a property, and pass each of ARGS to the function in the
 property's apply slot."))
 
+(defun make-propspec (&key (systems nil systems-supplied-p) props)
+  (setq props (copy-tree props))
+  (labels ((preprocess (item)
+	     (cond
+	       ((and (listp item) (isprop (car item)))
+		(rplacd item (apply (proppp (car item)) (cdr item))))
+	       ((consp item)
+		(mapc #'preprocess item)))))
+    (preprocess props))
+  (if systems-supplied-p
+      (make-instance 'propspec :props props :systems systems)
+      (make-instance 'propspec :props props)))
+
+;; does not use MAKE-PROPSPEC because we do not want the :PREPROCESS
+;; subroutines to be run again when the object is read back in
 (defmethod print-object ((propspec propspec) stream)
   (format stream "~S" `(make-instance
 			'propspec
@@ -193,11 +208,12 @@ specification."
 					:test #'string=)))
 		       `(list ',first ,@rest)
 		       `(list ,@(mapcar #'make-eval-propspec form)))))))
-    `(make-instance
-      'propspec
+    `(make-propspec
       ,@(and systems-supplied-p `(:systems ,systems))
       :props (list ,@(mapcar #'make-eval-propspec forms)))))
 
+;; doesn't use MAKE-PROPSPEC because each of the propspecs will already have
+;; had its :PREPROCESS subroutines run
 (defmethod append-propspecs ((first propspec) (second propspec))
   (make-instance 'propspec
 		 :props (append (slot-value first 'applications)