From 41952a35618fde1f16518ab9b76e64cd111343e6 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Wed, 2 May 2007 13:33:51 +0000
Subject: [PATCH] Apply fix for default-initargs where initialize-instance and
 shared-initialize were not getting :default-initargs.

Patch from Madhu, Mar 28, 2007, based on fix in sbcl.

pcl/ctor.lisp:
o Pass default-initargs to initialize-instance and shared-initialize.

pcl/rt/ctor.lisp:
o Add test for this case

pcl/rt/system.lisp:
o Use *load-truename* to setup paths, instead of a hard-wired one.
---
 pcl/ctor.lisp      | 71 ++++++++++++++++++++++++++++++----------------
 pcl/rt/ctor.lisp   | 19 ++++++++++++-
 pcl/rt/system.lisp |  9 +++++-
 3 files changed, 72 insertions(+), 27 deletions(-)

diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp
index 270149b24..4bd9528e1 100644
--- a/pcl/ctor.lisp
+++ b/pcl/ctor.lisp
@@ -46,7 +46,7 @@
 ;;; is called.
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.17 2004/08/06 17:21:54 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.18 2007/05/02 13:33:46 rtoy Rel $")
 
 (in-package "PCL")
 
@@ -403,25 +403,35 @@
 	(standard-sort-methods si-methods)
       (declare (ignore si-primary))
       (assert (and (null ii-around) (null si-around)))
-      (let ((initargs (ctor-initargs ctor))
-	    (slot-inits (slot-init-forms ctor (or ii-before si-before))))
-	(flet ((method-calls (methods args)
-		 (loop for method in methods
-		       as fn = (method-function method)
-		       collect `(funcall (truly-the function ,fn) ,args ()))))
-	  (values
-	   `(let (,@(when (or ii-before ii-after)
-		    `((.ii-args.
-		       (list .instance. ,@(quote-plist-keys initargs)))))
-		  ,@(when (or si-before si-after)
-		    `((.si-args.
-		       (list .instance. t ,@(quote-plist-keys initargs))))))
-	      ,@(method-calls ii-before '.ii-args.)
-	      ,@(method-calls si-before '.si-args.)
-	      ,slot-inits
-	      ,@(method-calls si-after '.si-args.)
-	      ,@(method-calls ii-after '.ii-args.))
-	   (or ii-before si-before)))))))
+      (let ((initargs (ctor-initargs ctor)))
+	(multiple-value-bind (slot-inits defaulted-initargs)
+	    (slot-init-forms ctor (or ii-before si-before))
+	  (flet ((method-calls (methods args)
+		   (loop for method in methods
+			 as fn = (method-function method)
+			 collect `(funcall (truly-the function ,fn) ,args ()))))
+	    (let ((let (car slot-inits))
+		  (bindings (cadr slot-inits))
+		  (body (cddr slot-inits)))
+	      (assert (eq let 'let))
+	      (multiple-value-bind (slot-init-forms decls doc-string)
+		  (sys:parse-body body nil nil)
+		(declare (ignore doc-string))
+		(values
+		 `(let* (,@bindings
+			 ,@(when (or ii-before ii-after)
+		            `((.ii-args.
+			       (list .instance. ,@(quote-plist-keys initargs) ,@defaulted-initargs))))
+			 ,@(when (or si-before si-after)
+		            `((.si-args.
+			       (list .instance. t ,@(quote-plist-keys initargs) ,@defaulted-initargs)))))
+		    ,@decls
+		    ,@(method-calls ii-before '.ii-args.)
+		    ,@(method-calls si-before '.si-args.)
+		    ,@slot-init-forms
+		    ,@(method-calls si-after '.si-args.)
+		    ,@(method-calls ii-after '.ii-args.))
+		 (or ii-before si-before))))))))))
 
 ;;;
 ;;; Return four values from APPLICABLE-METHODS: around methods, before
@@ -467,6 +477,8 @@
 ;;; that we have to check if these before-methods have set slots.
 ;;; For structures the consequences are likewise.
 ;;;
+;;; madhu 061211 second return value is a list of default initargs.
+;;;
 (defun slot-init-forms (ctor before-method-p)
   (let* ((class (ctor-class ctor))
 	 (structure-p (structure-class-p class))
@@ -479,6 +491,7 @@
 	 (class-inits ())
 	 (structure-inits ())
 	 (default-inits ())
+	 (defaulted-initargs ())
 	 (default-initargs (class-default-initargs class))
 	 ;;
 	 ;; Note that the locations are actually defstruct slot
@@ -537,7 +550,13 @@
       ;; if not actually used for initializing a slot.
       (loop for (key initfn initform) in default-initargs and i from 0
 	    unless (memq key initkeys) do
-	      (let* ((type (if (constantp initform) 'constant 'var))
+	      (let* ((type (cond ((constantp initform)
+				  (push key defaulted-initargs)
+				  (push initform defaulted-initargs)
+				  'constant)
+				 (t (push key defaulted-initargs)
+				    (push (default-init-variable-name i) defaulted-initargs)
+				    'var)))
 		     (init (if (eq type 'var) initfn initform)))
 		(when (eq type 'var)
 		  (let ((init-var (default-init-variable-name i)))
@@ -610,10 +629,12 @@
 		  collect var into vars
 		  collect `(,var (funcall ,initfn)) into bindings
 		  finally (return (values vars bindings)))
-	  `(let ,bindings
-	     (declare (ignorable ,@vars) (optimize (safety 3)))
-	     ,@instance-init-forms
-	     ,@class-init-forms))))))
+	  (values
+	   `(let ,bindings
+	      (declare (ignorable ,@vars) (optimize (safety 3)))
+	      ,@instance-init-forms
+	      ,@class-init-forms)
+	   (nreverse defaulted-initargs)))))))
 
 ;;;
 ;;; Return an alist of lists (KEY LOCATION ...) telling, for each key
diff --git a/pcl/rt/ctor.lisp b/pcl/rt/ctor.lisp
index 67a709e2d..674ab02e3 100644
--- a/pcl/rt/ctor.lisp
+++ b/pcl/rt/ctor.lisp
@@ -28,7 +28,7 @@
 ;;; DAMAGE.
 
 #+cmu
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/ctor.lisp,v 1.7 2003/10/23 10:29:33 gerd Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/ctor.lisp,v 1.8 2007/05/02 13:33:51 rtoy Exp $")
 
 (in-package "PCL-TEST")
 
@@ -399,3 +399,20 @@
 	      (slot-boundp instance 'b)))
   0 nil)
 
+;; Test for default-initargs bug.
+(defclass g2 ()
+  ((a :initarg :aa)))
+
+(defmethod initialize-instance :after ((f g2) &key aa)
+  (princ aa))
+
+(defclass g3 (g2)
+  ((b :initarg :b))
+  (:default-initargs :aa 5))
+
+(deftest defaulting-initargs.1
+    (with-output-to-string (*standard-output*)
+      (make-instance 'g3))
+  "5")
+
+  
diff --git a/pcl/rt/system.lisp b/pcl/rt/system.lisp
index 0e195d39d..d6c9cd553 100644
--- a/pcl/rt/system.lisp
+++ b/pcl/rt/system.lisp
@@ -28,11 +28,18 @@
 ;;; DAMAGE.
 
 #+cmu
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/system.lisp,v 1.3 2003/06/13 21:08:22 gerd Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/rt/system.lisp,v 1.4 2007/05/02 13:33:51 rtoy Rel $")
 
+#+nil
 (setf (logical-pathname-translations "pcl-test")
       `(("*.*.*" "/home/gerd/cmucl/src/pcl/rt/")))
 
+
+(setf (logical-pathname-translations "pcl-test")
+      (list (list "*.*.*"
+		  (merge-pathnames #p"*.*"
+				   *load-truename*))))
+
 (mk:defsystem :pcl-test
     :initially-do (progn )
     :source-pathname "pcl-test:"
-- 
GitLab