Re: default-component-class slot normally gets clobbered

Richard M Kreuter <[email protected]> writes:
> Richard M Kreuter <[email protected]> writes:
>
>> The following is a patch that both emits the warning and supplies the
>> initform for systems (and therefore emits the warning for every
>> system).

As it turns out, my previous patches leave one more problem: if
somebody wants to use the slot in an :after method on one of the
standard initializers, they'll see either the initform or
slot-unbound, but not the value of the keyword argument or the value
inherited from the parent, which are assigned in parse-component-form
after the initializers return.

One extension that could take advantage of getting this right is
wild-module.lisp in the asdf CVS module, which does its work mostly in
reinitialize-instance.  At present and under my previous patches it
needs to have its own slot for component class defaulting to DTRT for
both initforms and initargs.

All that's needed is to let CLOS do normal slot initialization for
initforms and initargs, and handle the inherit-from-parent-instance in
an :after method of reinitialize-instance specializing on module.  A
patch to this effect is below.

While I'm at it, I've added a constant variable,
+default-component-class+, since there are now 3 places in the file
that need to agree about what the default class of components is.

This patch also signals the warning about honoring initforms less
frivolously than the last, by ignoring instances of system whose
default-component-class is bound to the initform value rather than
initarg value and eql to the default class used by class-for-type (as
honoring the initform here is equivalent to overwriting it with NIL).

Thanks, 
RmK

diff -u /home/kreuter/lsp/pkg/cclan/asdf/asdf.lisp /home/kreuter/lsp/pkg/cclan/asdf/asdf.lisp.dcc3
--- /home/kreuter/lsp/pkg/cclan/asdf/asdf.lisp	2006-06-15 22:30:13.000000000 -0400
+++ /home/kreuter/lsp/pkg/cclan/asdf/asdf.lisp.dcc3	2006-06-18 14:35:31.000000000 -0400
@@ -242,7 +242,7 @@
 			   :accessor module-if-component-dep-fails
 			   :initarg :if-component-dep-fails)
    (default-component-class :accessor module-default-component-class
-     :initform 'cl-source-file :initarg :default-component-class)))
+     :initarg :default-component-class)))
 
 (defgeneric component-pathname (component)
   (:documentation "Extracts the pathname applicable for a particular component."))
@@ -279,14 +279,63 @@
 	(setf (slot-value c 'properties)
 	      (acons property new-value (slot-value c 'properties))))))
 
+(defconstant +default-component-class+ 'cl-source-file
+  "Name of the default class for components of systems that don't
+specify their default-component-class slot.")
+
 (defclass system (module)
   ((description :accessor system-description :initarg :description)
    (long-description
     :accessor system-long-description :initarg :long-description)
    (author :accessor system-author :initarg :author)
    (maintainer :accessor system-maintainer :initarg :maintainer)
-   (licence :accessor system-licence :initarg :licence)))
+   (licence :accessor system-licence :initarg :licence)
+   (default-component-class :initform +default-component-class+)))
 
+;;; This method is defined here because it references the system
+;;; class.
+(defmethod reinitialize-instance :after 
+    ((m module) &key (default-component-class nil dcc-supplied-p))
+  (declare (ignore default-component-class))
+  ;; asdf prior to 1.98 excludes default-component-class from the list
+  ;; of initargs to reinitialize-instance in parse-component-form, and
+  ;; then unconditionally assigns the slot to the keyword value, the
+  ;; parent's slot, or NIL.  In effect, initforms for this slot are
+  ;; always ignored, and auxiliary methods on initializers don't have
+  ;; access to the proper value of this slot.  However, straightening
+  ;; out the initialization protocol for this slot breaks any system
+  ;; that accidentally depends on the initform being ignored
+  ;; (unlikely, but possible), so we warn that we will be honoring the
+  ;; initform if the slot's value here came from an initform and not
+  ;; an initarg, and if the slot's value produces non-default behavior
+  ;; in the rest of asdf.  That does mean that changes to the rest of
+  ;; asdf may make this warning come out at incorrect times, but it's
+  ;; just a warning.
+  (when (and (slot-boundp m 'default-component-class)
+	     (not dcc-supplied-p)
+	     ;; It just won't do to have asdf warn about every
+	     ;; existing system. RmK 20060618.
+	     (if (and (typep m 'system)
+		      (eql (module-default-component-class m)
+			   +default-component-class+))
+		 nil
+		 t)
+	     ;; A d-c-c of nil leads to the defaulting behavior in
+	     ;; class-for-type, so there's nothing to warn about.
+	     (module-default-component-class m))
+    ;; The #<class "name" {address}> output made the paragraph filling
+    ;; of this warning quite ugly.
+    (warn "~@<Honoring initform ~A for default-component-class ~
+              slot of component ~A, class ~A.  ASDF versions ~
+              prior to 1.98 always overwrote this slot during ~
+              system initialization.~:@>"
+	  (module-default-component-class m) 
+	  (component-name m)
+	  (class-name (class-of m))))
+  ;; Boundedness of component-parent is ensured by parse-component-class.
+  (unless (slot-boundp m 'default-component-class)
+    (setf (module-default-component-class m)
+	  (module-default-component-class (component-parent m)))))
 ;;; version-satisfies
 
 ;;; with apologies to christophe rhodes ...
@@ -915,7 +964,7 @@
     (or class
 	(and (eq type :file)
 	     (or (module-default-component-class parent)
-		 (find-class 'cl-source-file)))
+		 (find-class +default-component-class+)))
 	(sysdef-error "~@<don't recognize component type ~A~@:>" type))))
 
 (defun maybe-add-tree (tree op1 op2 c)
@@ -957,7 +1006,7 @@
 	(type name &rest rest &key
 	      ;; the following list of keywords is reproduced below in the
 	      ;; remove-keys form.  important to keep them in sync
-	      components pathname default-component-class
+	      components pathname
 	      perform explain output-files operation-done-p
 	      weakly-depends-on
 	      depends-on serial in-order-to
@@ -974,7 +1023,7 @@
       (error 'duplicate-names :name name))
     
     (let* ((other-args (remove-keys
-			'(components pathname default-component-class
+			'(components pathname
 			  perform explain output-files operation-done-p
 			  weakly-depends-on
 			  depends-on serial in-order-to)
@@ -994,10 +1043,6 @@
 	     :parent parent
 	     other-args)
       (when (typep ret 'module)
-	(setf (module-default-component-class ret)
-	      (or default-component-class
-		  (and (typep parent 'module)
-		       (module-default-component-class parent))))
 	(let ((*serial-depends-on* nil))
 	  (setf (module-components ret)
 		(loop for c-form in components

Diff finished.  Sun Jun 18 14:36:48 2006