X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=2a7cebe9e1d7238702977d4c2d1669874b41ae08;hb=ec735ab75335c1744b39190314142a7e6f1ecdb3;hp=eece9616ef3f2b700677b98340b8e6e333b2e8fc;hpb=d8346491af87b66677657e4b934ddeae1e749250;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index eece961..2a7cebe 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -106,6 +106,8 @@
   ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
   ;; (including included ones)
   (slots () :type list)
+  ;; a list of (NAME . INDEX) pairs for accessors of included structures
+  (inherited-accessor-alist () :type list)
   ;; number of elements we've allocated (See also RAW-LENGTH.)
   (length 0 :type index)
   ;; General kind of implementation.
@@ -173,7 +175,7 @@
 	     (:copier nil)
 	     #-sb-xc-host (:pure t))
   ;; string name of slot
-  %name	
+  %name
   ;; its position in the implementation sequence
   (index (missing-arg) :type fixnum)
   ;; the name of the accessor function
@@ -185,6 +187,8 @@
   (accessor-name nil)
   default			; default value expression
   (type t)			; declared type specifier
+  (safe-p t :type boolean)      ; whether the slot is known to be
+                                ; always of the specified type
   ;; If this object does not describe a raw slot, this value is T.
   ;;
   ;; If this object describes a raw slot, this value is the type of the
@@ -233,11 +237,11 @@
     ;; What operator is used (on the raw data vector) to access a slot
     ;; of this type?
     (accessor-name (missing-arg) :type symbol :read-only t)
-    ;; How many words are each value of this type? (This is used to 
+    ;; How many words are each value of this type? (This is used to
     ;; rescale the offset into the raw data vector.)
     (n-words (missing-arg) :type (and index (integer 1)) :read-only t))
 
-  (defvar *raw-slot-data-list* 
+  (defvar *raw-slot-data-list*
     (list
      ;; The compiler thinks that the raw data vector is a vector of
      ;; word-sized unsigned bytes, so if the slot we want to access
@@ -410,6 +414,11 @@
 
 ;;;; functions to generate code for various parts of DEFSTRUCT definitions
 
+;;; First, a helper to determine whether a name names an inherited
+;;; accessor.
+(defun accessor-inherited-data (name defstruct)
+  (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq))
+
 ;;; Return a list of forms which create a predicate function for a
 ;;; typed DEFSTRUCT.
 (defun typed-predicate-definitions (defstruct)
@@ -442,18 +451,26 @@
 	      (index (dsd-index slot))
 	      (slot-type `(and ,(dsd-type slot)
 			       ,(dd-element-type defstruct))))
-	  (stuff `(proclaim '(inline ,name (setf ,name))))
-	  ;; FIXME: The arguments in the next two DEFUNs should be
-	  ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
-	  ;; name of a special variable, things could get weird.)
-	  (stuff `(defun ,name (structure)
-		    (declare (type ,ltype structure))
-		    (the ,slot-type (elt structure ,index))))
-	  (unless (dsd-read-only slot)
-	    (stuff
-	     `(defun (setf ,name) (new-value structure)
-		(declare (type ,ltype structure) (type ,slot-type new-value))
-		(setf (elt structure ,index) new-value)))))))
+	  (let ((inherited (accessor-inherited-data name defstruct)))
+	    (cond
+	      ((not inherited)
+	       (stuff `(proclaim '(inline ,name (setf ,name))))
+	       ;; FIXME: The arguments in the next two DEFUNs should
+	       ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
+	       ;; be the name of a special variable, things could get
+	       ;; weird.)
+	       (stuff `(defun ,name (structure)
+			(declare (type ,ltype structure))
+			(the ,slot-type (elt structure ,index))))
+	       (unless (dsd-read-only slot)
+		 (stuff
+		  `(defun (setf ,name) (new-value structure)
+		    (declare (type ,ltype structure) (type ,slot-type new-value))
+		    (setf (elt structure ,index) new-value)))))
+	      ((not (= (cdr inherited) index))
+	       (style-warn "~@<Non-overwritten accessor ~S does not access ~
+                            slot with name ~S (accessing an inherited slot ~
+                            instead).~:@>" name (dsd-%name slot))))))))
     (stuff)))
 
 ;;;; parsing
@@ -470,7 +487,7 @@
 	(name (dd-name dd)))
     (case (first option)
       (:conc-name
-       (destructuring-bind (conc-name) args
+       (destructuring-bind (&optional conc-name) args
 	 (setf (dd-conc-name dd)
 	       (if (symbolp conc-name)
 		   conc-name
@@ -611,7 +628,9 @@
     (setf (dsd-%name slot) (string name))
     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
 
-    (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
+    (let ((accessor-name (if (dd-conc-name defstruct)
+			     (symbolicate (dd-conc-name defstruct) name)
+			     name))
 	  (predicate-name (dd-predicate-name defstruct)))
       (setf (dsd-accessor-name slot) accessor-name)
       (when (eql accessor-name predicate-name)
@@ -629,7 +648,11 @@
           accessor, but you can't rely on this behavior, so it'd be wise to ~
           remove the ambiguity in your code.~@:>"
 	 accessor-name)
-	(setf (dd-predicate-name defstruct) nil)))
+	(setf (dd-predicate-name defstruct) nil))
+      #-sb-xc-host
+      (when (and (fboundp accessor-name)
+		 (not (accessor-inherited-data accessor-name defstruct)))
+	(style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
 
     (when default-p
       (setf (dsd-default slot) default))
@@ -760,12 +783,26 @@
 	(setf (dd-raw-index dd) (dd-raw-index included-structure))
 	(setf (dd-raw-length dd) (dd-raw-length included-structure)))
 
+      (setf (dd-inherited-accessor-alist dd)
+	    (dd-inherited-accessor-alist included-structure))
       (dolist (included-slot (dd-slots included-structure))
 	(let* ((included-name (dsd-name included-slot))
 	       (modified (or (find included-name modified-slots
 				   :key (lambda (x) (if (atom x) x (car x)))
 				   :test #'string=)
 			     `(,included-name))))
+	  ;; We stash away an alist of accessors to parents' slots
+	  ;; that have already been created to avoid conflicts later
+	  ;; so that structures with :INCLUDE and :CONC-NAME (and
+	  ;; other edge cases) can work as specified.
+	  (when (dsd-accessor-name included-slot)
+	    ;; the "oldest" (i.e. highest up the tree of inheritance)
+	    ;; will prevail, so don't push new ones on if they
+	    ;; conflict.
+	    (pushnew (cons (dsd-accessor-name included-slot)
+			   (dsd-index included-slot))
+		     (dd-inherited-accessor-alist dd)
+		     :test #'eq :key #'car))
 	  (parse-1-dsd dd
 		       modified
 		       (copy-structure included-slot)))))))
@@ -853,17 +890,16 @@
 ;;; and writer functions of the slot described by DSD.
 (defun slot-accessor-inline-expansion-designators (dd dsd)
   (let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
-	(accessor-place-form (%accessor-place-form dd dsd 'instance))
-	(dsd-type (dsd-type dsd)))
-    (values (lambda ()
-	      `(lambda (instance)
-		 ,instance-type-decl
-		 (truly-the ,dsd-type ,accessor-place-form)))
-	    (lambda ()
-	      `(lambda (new-value instance)
-		 (declare (type ,dsd-type new-value))
-		 ,instance-type-decl
-		 (setf ,accessor-place-form new-value))))))
+        (accessor-place-form (%accessor-place-form dd dsd 'instance))
+        (dsd-type (dsd-type dsd))
+        (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
+    (values (lambda () `(lambda (instance)
+                          ,instance-type-decl
+                          (,value-the ,dsd-type ,accessor-place-form)))
+	    (lambda () `(lambda (new-value instance)
+                          (declare (type ,dsd-type new-value))
+                          ,instance-type-decl
+                          (setf ,accessor-place-form new-value))))))
 
 ;;; Return a LAMBDA form which can be used to set a slot.
 (defun slot-setter-lambda-form (dd dsd)
@@ -959,26 +995,35 @@
       (let* ((accessor-name (dsd-accessor-name dsd))
 	     (dsd-type (dsd-type dsd)))
 	(when accessor-name
-	  (multiple-value-bind (reader-designator writer-designator)
-	      (slot-accessor-inline-expansion-designators dd dsd)
-	    (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
-				    ,accessor-name))
-	    (setf (info :function :inline-expansion-designator accessor-name)
-		  reader-designator
-		  (info :function :inlinep accessor-name)
-		  :inline)
-	    (unless (dsd-read-only dsd)
-	      (let ((setf-accessor-name `(setf ,accessor-name)))
-		(sb!xc:proclaim
-		 `(ftype (function (,dsd-type ,dtype) ,dsd-type)
-			 ,setf-accessor-name))
-		(setf (info :function
-			    :inline-expansion-designator
-			    setf-accessor-name)
-		      writer-designator
-		      (info :function :inlinep setf-accessor-name)
-		      :inline))))))))
-
+	  (let ((inherited (accessor-inherited-data accessor-name dd)))
+	    (cond
+	      ((not inherited)
+	       (multiple-value-bind (reader-designator writer-designator)
+		   (slot-accessor-inline-expansion-designators dd dsd)
+		 (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
+				   ,accessor-name))
+		 (setf (info :function :inline-expansion-designator
+			     accessor-name)
+		       reader-designator
+		       (info :function :inlinep accessor-name)
+		       :inline)
+		 (unless (dsd-read-only dsd)
+		   (let ((setf-accessor-name `(setf ,accessor-name)))
+		     (sb!xc:proclaim
+		      `(ftype (function (,dsd-type ,dtype) ,dsd-type)
+			,setf-accessor-name))
+		     (setf (info :function
+				 :inline-expansion-designator
+				 setf-accessor-name)
+			   writer-designator
+			   (info :function :inlinep setf-accessor-name)
+			   :inline)))))
+	      ((not (= (cdr inherited) (dsd-index dsd)))
+	       (style-warn "~@<Non-overwritten accessor ~S does not access ~
+                            slot with name ~S (accessing an inherited slot ~
+                            instead).~:@>"
+			   accessor-name
+			   (dsd-%name dsd)))))))))
   (values))
 
 ;;;; redefinition stuff
@@ -1148,9 +1193,10 @@
 	(undefine-fun-name (dd-predicate-name info))
 	(dolist (slot (dd-slots info))
 	  (let ((fun (dsd-accessor-name slot)))
-	    (undefine-fun-name fun)
-	    (unless (dsd-read-only slot)
-	      (undefine-fun-name `(setf ,fun))))))
+	    (unless (accessor-inherited-data fun info)
+	      (undefine-fun-name fun)
+	      (unless (dsd-read-only slot)
+		(undefine-fun-name `(setf ,fun)))))))
       ;; Clear out the SPECIFIER-TYPE cache so that subsequent
       ;; references are unknown types.
       (values-specifier-type-cache-clear)))
@@ -1194,7 +1240,7 @@
 ;;;     structures can have arbitrary subtypes of VECTOR, not necessarily
 ;;;     SIMPLE-VECTOR.)
 ;;;   * STRUCTURE structures can have raw slots that must also be
-;;;     allocated and indirectly referenced. 
+;;;     allocated and indirectly referenced.
 (defun create-vector-constructor (dd cons-name arglist vars types values)
   (let ((temp (gensym))
 	(etype (dd-element-type dd)))
@@ -1207,7 +1253,8 @@
 		     `(setf (aref ,temp ,(cdr x))  ',(car x)))
 		   (find-name-indices dd))
 	 ,@(mapcar (lambda (dsd value)
-		     `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+		     (unless (eq value '.do-not-initialize-slot.)
+                         `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
 		   (dd-slots dd) values)
 	 ,temp))))
 (defun create-list-constructor (dd cons-name arglist vars types values)
@@ -1215,7 +1262,8 @@
     (dolist (x (find-name-indices dd))
       (setf (elt vals (cdr x)) `',(car x)))
     (loop for dsd in (dd-slots dd) and val in values do
-      (setf (elt vals (dsd-index dsd)) val))
+      (setf (elt vals (dsd-index dsd))
+            (if (eq val '.do-not-initialize-slot.) 0 val)))
 
     `(defun ,cons-name ,arglist
        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
@@ -1239,13 +1287,15 @@
 		     ;; because the slot might be :READ-ONLY, so we
 		     ;; whip up new LAMBDA representations of slot
 		     ;; setters for the occasion.)
-		     `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+                     (unless (eq value '.do-not-initialize-slot.)
+                       `(,(slot-setter-lambda-form dd dsd) ,value ,instance)))
 		   (dd-slots dd)
 		   values)
 	 ,instance))))
 
 ;;; Create a default (non-BOA) keyword constructor.
 (defun create-keyword-constructor (defstruct creator)
+  (declare (type function creator))
   (collect ((arglist (list '&key))
 	    (types)
 	    (vals))
@@ -1262,11 +1312,13 @@
 ;;; Given a structure and a BOA constructor spec, call CREATOR with
 ;;; the appropriate args to make a constructor.
 (defun create-boa-constructor (defstruct boa creator)
+  (declare (type function creator))
   (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
       (parse-lambda-list (second boa))
     (collect ((arglist)
 	      (vars)
-	      (types))
+	      (types)
+              (skipped-vars))
       (labels ((get-slot (name)
 		 (let ((res (find name (dd-slots defstruct)
 				  :test #'string=
@@ -1283,7 +1335,7 @@
 	  (arglist arg)
 	  (vars arg)
 	  (types (get-slot arg)))
-	
+
 	(when opt
 	  (arglist '&optional)
 	  (dolist (arg opt)
@@ -1336,18 +1388,22 @@
 	(when auxp
 	  (arglist '&aux)
 	  (dolist (arg aux)
-	    (let* ((arg (if (consp arg) arg (list arg)))
-		   (var (first arg)))
-	      (arglist arg)
-	      (vars var)
-	      (types (get-slot var))))))
+            (arglist arg)
+            (if (proper-list-of-length-p arg 2)
+              (let ((var (first arg)))
+                (vars var)
+                (types (get-slot var)))
+              (skipped-vars (if (consp arg) (first arg) arg))))))
 
       (funcall creator defstruct (first boa)
 	       (arglist) (vars) (types)
-	       (mapcar (lambda (slot)
-			 (or (find (dsd-name slot) (vars) :test #'string=)
-			     (dsd-default slot)))
-		       (dd-slots defstruct))))))
+               (loop for slot in (dd-slots defstruct)
+                     for name = (dsd-name slot)
+                     collect (cond ((find name (skipped-vars) :test #'string=)
+                                    (setf (dsd-safe-p slot) nil)
+                                    '.do-not-initialize-slot.)
+                                   ((or (find (dsd-name slot) (vars) :test #'string=)
+                                        (dsd-default slot)))))))))
 
 ;;; Grovel the constructor options, and decide what constructors (if
 ;;; any) to create.
@@ -1407,7 +1463,7 @@
 ;;;; main DEFSTRUCT macro. Hopefully it will go away presently
 ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
 ;;;; -- WHN 2001-10-28
-;;;; 
+;;;;
 ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
 ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
 ;;;; instead of just implementing them as primitive objects. (This
@@ -1531,7 +1587,7 @@
 			          ,slot-name)))
 		       slot-names)
 	     ,object-gensym))
-			      
+
 	 ;; predicate
 	 ,@(when predicate
 	     ;; Just delegate to the compiler's type optimization