0.6.11.13:

[sbcl.git] / src / code / defstruct.lisp

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index ca7e467..4ac42bc 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -12,8 +12,7 @@
 
 (in-package "SB!KERNEL")
 
-(file-comment
-  "$Header$")
+(/show0 "code/defstruct.lisp 15")
 \f
 ;;;; getting LAYOUTs
 
@@ -55,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)
@@ -153,7 +152,7 @@
   (intern (string (dsd-%name dsd))
          (if (dsd-accessor dsd)
              (symbol-package (dsd-accessor dsd))
-             *package*)))
+             (sane-package))))
 \f
 ;;;; typed (non-class) structures
 
@@ -277,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.
 
@@ -459,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)
@@ -512,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)
@@ -593,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)))
@@ -1231,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))))
@@ -1272,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)
@@ -1373,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
@@ -1418,3 +1418,5 @@
                     (rest args)))
         (inherits (inherits-for-structure defstruct)))
     (function-%compiler-only-defstruct defstruct inherits)))
+
+(/show0 "code/defstruct.lisp end of file")