X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=4ac42bc41634969ab75a7675fb90e0573e5b5954;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=5a443c93c284a46ca5308b479f9599f509f1f0f3;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 5a443c9..4ac42bc 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -11,6 +11,8 @@
 ;;;; files for more information.
 
 (in-package "SB!KERNEL")
+
+(/show0 "code/defstruct.lisp 15")
 
 ;;;; getting LAYOUTs
 
@@ -52,15 +54,15 @@
   ;; documentation on the structure
   (doc nil :type (or string null))
   ;; prefix for slot names. If NIL, none.
-  (conc-name (concat-pnames name '-) :type (or symbol null))
+  (conc-name (symbolicate name "-") :type (or symbol null))
   ;; the name of the primary standard keyword constructor, or NIL if none
   (default-constructor nil :type (or symbol null))
   ;; all the explicit :CONSTRUCTOR specs, with name defaulted
   (constructors () :type list)
   ;; name of copying function
-  (copier (concat-pnames 'copy- name) :type (or symbol null))
+  (copier (symbolicate "COPY-" name) :type (or symbol null))
   ;; name of type predicate
-  (predicate (concat-pnames name '-p) :type (or symbol null))
+  (predicate (symbolicate name "-P") :type (or symbol null))
   ;; the arguments to the :INCLUDE option, or NIL if no included
   ;; structure
   (include nil :type list)
@@ -150,7 +152,7 @@
   (intern (string (dsd-%name dsd))
 	  (if (dsd-accessor dsd)
 	      (symbol-package (dsd-accessor dsd))
-	      *package*)))
+	      (sane-package))))
 
 ;;;; typed (non-class) structures
 
@@ -274,8 +276,8 @@
 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
   #!+sb-doc
   "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
-   Define the structure type Name. Instances are created by MAKE-<name>, which
-   takes keyword arguments allowing initial slot values to the specified.
+   Define the structure type Name. Instances are created by MAKE-<name>, 
+   which takes &KEY arguments allowing initial slot values to the specified.
    A SETF'able function <name>-<slot> is defined for each slot to read and
    write slot values. <name>-p is a type predicate.
 
@@ -456,16 +458,16 @@
 		   conc-name
 		   (make-symbol (string conc-name))))))
       (:constructor
-       (destructuring-bind (&optional (cname (concat-pnames 'make- name))
+       (destructuring-bind (&optional (cname (symbolicate "MAKE-" name))
 				      &rest stuff)
 	   args
 	 (push (cons cname stuff) (dd-constructors defstruct))))
       (:copier
-       (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
+       (destructuring-bind (&optional (copier (symbolicate "COPY-" name)))
 	   args
 	 (setf (dd-copier defstruct) copier)))
       (:predicate
-       (destructuring-bind (&optional (pred (concat-pnames name '-p))) args
+       (destructuring-bind (&optional (pred (symbolicate name "-P"))) args
 	 (setf (dd-predicate defstruct) pred)))
       (:include
        (when (dd-include defstruct)
@@ -509,6 +511,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun parse-name-and-options (name-and-options)
   (destructuring-bind (name &rest options) name-and-options
+    (assert name) ; A null name doesn't seem to make sense here.
     (let ((defstruct (make-defstruct-description name)))
       (dolist (option options)
 	(cond ((consp option)
@@ -590,13 +593,13 @@
 	spec))
 
     (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
-      (error 'program-error
+      (error 'simple-program-error
 	     :format-control "duplicate slot name ~S"
 	     :format-arguments (list name)))
     (setf (dsd-%name islot) (string name))
     (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
 
-    (let* ((accname (concat-pnames (dd-conc-name defstruct) name))
+    (let* ((accname (symbolicate (or (dd-conc-name defstruct) "") name))
 	   (existing (info :function :accessor-for accname)))
       (if (and (structure-class-p existing)
 	       (not (eq (sb!xc:class-name existing) (dd-name defstruct)))
@@ -1228,10 +1231,10 @@
 	       (%delayed-get-compiler-layout ,(dd-name defstruct)))
 	 ,@(when n-raw-data
 	     `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
-	 ,@(mapcar #'(lambda (dsd value)
-		       (multiple-value-bind (accessor index data)
-			   (slot-accessor-form defstruct dsd temp n-raw-data)
-			 `(setf (,accessor ,data ,index) ,value)))
+	 ,@(mapcar (lambda (dsd value)
+		     (multiple-value-bind (accessor index data)
+			 (slot-accessor-form defstruct dsd temp n-raw-data)
+		       `(setf (,accessor ,data ,index) ,value)))
 		   (dd-slots defstruct)
 		   values)
 	 ,temp))))
@@ -1269,7 +1272,7 @@
 	     defstruct (dd-default-constructor defstruct)
 	     (arglist) (vals) (types) (vals))))
 
-;;; Given a structure and a BOA constructor spec, call Creator with
+;;; 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)
   (multiple-value-bind (req opt restp rest keyp keys allowp aux)
@@ -1370,7 +1373,7 @@
       (return-from constructor-definitions ()))
 
     (unless (or defaults boas)
-      (push (concat-pnames 'make- (dd-name defstruct)) defaults))
+      (push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
 
     (collect ((res))
       (when defaults
@@ -1415,3 +1418,5 @@
 		     (rest args)))
 	 (inherits (inherits-for-structure defstruct)))
     (function-%compiler-only-defstruct defstruct inherits)))
+
+(/show0 "code/defstruct.lisp end of file")