X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=feec05a3c3b231958cb109e8616483a90a4bc362;hb=ff57884e206ac28660af6af34315bc9b81697f57;hp=8b83b5505cd5afc52cd6ac9f22a49e5aef68dc3f;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 8b83b55..feec05a 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -49,7 +49,7 @@
 	   ;; slow, so if anyone cares about performance of
 	   ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
 	   ;; cleverer. -- WHN 2002-10-23
-	   (sb!c::compiler-note
+	   (sb!c:compiler-notify
 	    "implementation limitation: ~
              Non-toplevel DEFSTRUCT constructors are slow.")
 	   (with-unique-names (layout)
@@ -604,23 +604,27 @@
 							   :index 0
 							   :type t)))
   (multiple-value-bind (name default default-p type type-p read-only ro-p)
-      (cond
-       ((listp spec)
-	(destructuring-bind
-	    (name
-	     &optional (default nil default-p)
-	     &key (type nil type-p) (read-only nil ro-p))
-	    spec
-	  (values name
-		  default default-p
-		  (uncross type) type-p
-		  read-only ro-p)))
-       (t
-	(when (keywordp spec)
-	  (style-warn "Keyword slot name indicates probable syntax ~
-		       error in DEFSTRUCT: ~S."
-		      spec))
-	spec))
+      (typecase spec
+	(symbol
+	 (when (keywordp spec)
+	   (style-warn "Keyword slot name indicates probable syntax ~
+		        error in DEFSTRUCT: ~S."
+		       spec))
+	 spec)
+	(cons
+	 (destructuring-bind
+	       (name
+		&optional (default nil default-p)
+		&key (type nil type-p) (read-only nil ro-p))
+	     spec
+	   (values name
+		   default default-p
+		   (uncross type) type-p
+		   read-only ro-p)))
+	(t (error 'simple-program-error
+		  :format-control "in DEFSTRUCT, ~S is not a legal slot ~
+                                   description."
+		  :format-arguments (list spec))))
 
     (when (find name (dd-slots defstruct)
 		:test #'string=
@@ -681,12 +685,7 @@
 ;;;
 ;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*.
 (defun structure-raw-slot-type-and-size (type)
-  (cond #+nil
-	(;; FIXME: For now we suppress raw slots, since there are various
-	 ;; issues about the way that the cross-compiler handles them.
-	 (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
-	 (values nil nil nil))
-	((and (sb!xc:subtypep type '(unsigned-byte 32))
+  (cond ((and (sb!xc:subtypep type '(unsigned-byte 32))
 	      (multiple-value-bind (fixnum? fixnum-certain?)
 		  (sb!xc:subtypep type 'fixnum)
 		;; (The extra test for FIXNUM-CERTAIN? here is
@@ -885,8 +884,20 @@
 	  (multiple-value-bind (scaled-dsd-index misalignment)
 	      (floor (dsd-index dsd) raw-n-words)
 	    (aver (zerop misalignment))
-	    `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd))
-				 ,scaled-dsd-index))))))
+	    (let* ((raw-vector-bare-form
+		    `(,ref ,instance-name ,(dd-raw-index dd)))
+		   (raw-vector-form
+		    (if (eq raw-type 'unsigned-byte)
+			(progn
+			  (aver (= raw-n-words 1))
+			  (aver (eq raw-slot-accessor 'aref))
+			  ;; FIXME: when the 64-bit world rolls
+			  ;; around, this will need to be reviewed,
+			  ;; along with the whole RAW-SLOT thing.
+			  `(truly-the (simple-array (unsigned-byte 32) (*))
+			              ,raw-vector-bare-form))
+			raw-vector-bare-form)))
+	      `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index)))))))
 
 ;;; Return source transforms for the reader and writer functions of
 ;;; the slot described by DSD. They should be inline expanded, but
@@ -1431,17 +1442,26 @@
     (unless (or defaults boas)
       (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
 
-    (collect ((res))
+    (collect ((res) (names))
       (when defaults
-	(let ((cname (first defaults)))
-	  (setf (dd-default-constructor defstruct) cname)
-	  (res (create-keyword-constructor defstruct creator))
-	  (dolist (other-name (rest defaults))
-	    (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
-	    (res `(declaim (ftype function ',other-name))))))
+        (let ((cname (first defaults)))
+          (setf (dd-default-constructor defstruct) cname)
+          (res (create-keyword-constructor defstruct creator))
+          (names cname)
+          (dolist (other-name (rest defaults))
+            (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+            (names other-name))))
 
       (dolist (boa boas)
-	(res (create-boa-constructor defstruct boa creator)))
+        (res (create-boa-constructor defstruct boa creator))
+        (names (first boa)))
+
+      (res `(declaim (ftype
+                      (sfunction *
+                                 ,(if (eq (dd-type defstruct) 'structure)
+                                      (dd-name defstruct)
+                                      '*))
+                      ,@(names))))
 
       (res))))