rework executing :HOSTATTRS subroutines

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

3 files changed, 46 insertions, 27 deletions

diff --git a/src/host.lisp b/src/host.lisp
index e55f601..1f2c22a 100644
--- a/src/host.lisp
+++ b/src/host.lisp
@@ -19,6 +19,9 @@
 
 ;;;; Hosts
 
+;; note that we expect any host object to be such that the :HOSTATTRS
+;; subroutines of its propspec has already been run.  so, run them when
+;; instantiating a new object, as DEFHOST does.
 (defclass host ()
   ((hostattrs
     :initarg :attrs
@@ -56,21 +59,17 @@ in the order specified here, so later properties implicitly depend on earlier
 ones.  In addition, static informational attributes set by later properties
 are allowed to override any attributes with the same name set by earlier
 entries."
-  (with-gensyms (propspec)
-    (let (hostname-sym attrs)
-      (etypecase hostname
-	(string (setq hostname-sym (intern hostname)))
-	(symbol (setq hostname-sym hostname
-		      hostname (string-downcase (symbol-name hostname)))))
-      (push hostname (getf attrs :hostname))
-      (when (stringp (car properties))
-	(push (pop properties) (getf attrs :desc)))
-      `(progn
-	 (declaim (type host ,hostname-sym))
-	 (defparameter ,hostname-sym
-	   (let* ((,propspec ,(props properties))
-		  (*host*
-		    (make-instance 'host :attrs ',attrs :props ,propspec)))
-	     (eval-propspec-hostattrs ,propspec)
-	     *host*)
-	   ,(car (getf attrs :desc)))))))
+  (let (hostname-sym attrs)
+    (etypecase hostname
+      (string (setq hostname-sym (intern hostname)))
+      (symbol (setq hostname-sym hostname
+		    hostname (string-downcase (symbol-name hostname)))))
+    (push hostname (getf attrs :hostname))
+    (when (stringp (car properties))
+      (push (pop properties) (getf attrs :desc)))
+    `(progn
+       (declaim (type host ,hostname-sym))
+       (defparameter ,hostname-sym
+	 (%replace-propspec-into-host (make-instance 'host :attrs ',attrs)
+				      ,(props properties))
+	 ,(car (getf attrs :desc))))))
diff --git a/src/property.lisp b/src/property.lisp
index aa6082b..ad67eab 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -96,7 +96,7 @@
 (defun propappunapply (propapp)
   (apply #'propunapply propapp))
 
-;;; standard way to write properties is to use one of these two macros
+;;; supported way to write properties is to use one of these two macros
 
 (defmacro defprop (name type args &body forms)
   (let ((slots (list :args (list 'quote args))))
@@ -115,16 +115,16 @@
 		     `(lambda ,args ,@slot))))
     `(setprop ',name ,type ,@slots)))
 
-(defmacro defproplist (name type args &body propspec)
+(defmacro defproplist (name type args &body properties)
   "Define a property which applies a property application specification.
-PROPSPEC is an unevaluated property application specification."
-  (with-gensyms (props)
-    `(let ((,props (props ,propspec)))
+PROPERTIES is an unevaluated property application specification."
+  (with-gensyms (propspec)
+    `(let ((,propspec (props ,properties)))
        (defprop ,name ,type ,args
 	 (:hostattrs
-	  (eval-propspec-hostattrs ,props))
+	  (%eval-propspec-hostattrs *host* ,propspec))
 	 (:apply
-	  (eval-propspec ,props))))))
+	  (eval-propspec ,propspec))))))
 
 
 ;;;; hostattrs in property subroutines
diff --git a/src/propspec.lisp b/src/propspec.lisp
index f63958c..51ab8ca 100644
--- a/src/propspec.lisp
+++ b/src/propspec.lisp
@@ -173,11 +173,31 @@ an atomic property application."
 	for propapp = (compile-propapp form)
 	do (propappapply propapp)))
 
-(defun eval-propspec-hostattrs (propspec)
-  (loop for form in (slot-value propspec 'applications)
+(defmethod %eval-propspec-hostattrs ((host host) (propspec propspec))
+  "Modify HOST in-place according to :HOSTATTRS subroutines."
+  (loop with *host* = host
+	for form in (propspec-props propspec)
 	for propapp = (compile-propapp form)
 	do (propappattrs propapp)))
 
+;; return values of the following two functions share structure, and thus are
+;; not safe to use except on host objects that were just made, or that are
+;; going straight into %CONSFIGURE
+
+(defmethod %union-propspec-into-host ((host host) (propspec propspec))
+  (prog1
+      (setq host (make-instance 'host
+				:attrs (hostattrs host)
+				:props (append-propspecs (host-propspec host)
+							 propspec)))
+    (%eval-propspec-hostattrs host propspec)))
+
+(defmethod %replace-propspec-into-host ((host host) (propspec propspec))
+  (prog1
+      (setq host (make-instance 'host
+				:attrs (hostattrs host) :props propspec))
+    (%eval-propspec-hostattrs host propspec)))
+
 (defun propspec->type (propspec)
   "Return :lisp if any types of the properties to be applied by PROPSPEC is
 :lisp, else return :posix."