X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=384aab06eaf06ca33d93df7cbb2d9eab12a8db8f;hb=d147d512602d761a2dcdfded506dd1a8f9a140dc;hp=62b9bd278db7424a8444d0d0dec7c68266b21d50;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 62b9bd2..384aab0 100644 --- 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") ;;;; 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)))) ;;;; typed (non-class) structures @@ -249,11 +248,13 @@ (if (class-structure-p dd) (let ((inherits (inherits-for-structure dd))) `(progn + (/noshow0 "doing CLASS-STRUCTURE-P case for DEFSTRUCT " ,name) (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-only-defstruct ',dd ',inherits)) (%defstruct ',dd ',inherits) ,@(when (eq (dd-type dd) 'structure) `((%compiler-defstruct ',dd))) + (/noshow0 "starting not-for-the-xc-host section in DEFSTRUCT") ,@(unless expanding-into-code-for-xc-host-p (append (raw-accessor-definitions dd) (predicate-definitions dd) @@ -263,8 +264,10 @@ ;(copier-definition dd) (constructor-definitions dd) (class-method-definitions dd))) + (/noshow0 "done with DEFSTRUCT " ,name) ',name)) `(progn + (/show0 "doing NOT CLASS-STRUCTURE-P case for DEFSTRUCT " ,name) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (info :typed-structure :info ',name) ',dd)) ,@(unless expanding-into-code-for-xc-host-p @@ -272,13 +275,14 @@ (typed-predicate-definitions dd) (typed-copier-definitions dd) (constructor-definitions dd))) + (/noshow0 "done with DEFSTRUCT " ,name) ',name))))) (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-, which - takes keyword arguments allowing initial slot values to the specified. + Define the structure type Name. Instances are created by MAKE-, + which takes &KEY arguments allowing initial slot values to the specified. A SETF'able function - is defined for each slot to read and write slot values. -p is a type predicate. @@ -459,16 +463,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 +516,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-name-and-options (name-and-options) (destructuring-bind (name &rest options) name-and-options + (aver 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 +598,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))) @@ -1176,14 +1181,15 @@ ;;; type declarations. Values are the values for the slots (in order.) ;;; ;;; This is split four ways because: -;;; 1] list & vector structures need "name" symbols stuck in at various weird -;;; places, whereas STRUCTURE structures have a LAYOUT slot. +;;; 1] list & vector structures need "name" symbols stuck in at +;;; various weird places, whereas STRUCTURE structures have +;;; a LAYOUT slot. ;;; 2] We really want to use LIST to make list structures, instead of ;;; MAKE-LIST/(SETF ELT). -;;; 3] STRUCTURE structures can have raw slots that must also be allocated and -;;; indirectly referenced. We use SLOT-ACCESSOR-FORM to compute how to set -;;; the slots, which deals with raw slots. -;;; 4] funcallable structures are weird. +;;; 3] STRUCTURE structures can have raw slots that must also be +;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM +;;; to compute how to set the slots, which deals with raw slots. +;;; 4] Funcallable structures are weird. (defun create-vector-constructor (defstruct cons-name arglist vars types values) (let ((temp (gensym)) @@ -1230,10 +1236,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)))) @@ -1271,7 +1277,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) @@ -1372,7 +1378,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 @@ -1417,3 +1423,5 @@ (rest args))) (inherits (inherits-for-structure defstruct))) (function-%compiler-only-defstruct defstruct inherits))) + +(/show0 "code/defstruct.lisp end of file")