X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=40f7ba91fdaaf1870f9b8ae582dba45cf5701ac6;hb=204f2fa9771ad9e55718dc76205afec7d11b3011;hp=221cdd6546996719f0b0fe4cb78cc2c9afb21e29;hpb=02ce4b1b927f1312c300047bd5a0db6663a1d2c6;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 221cdd6..40f7ba9 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) @@ -83,7 +85,7 @@ ;; classes, CLASS-STRUCTURE-P = NIL) ;; ;; vector element type - (element-type 't) + (element-type t) ;; T if :NAMED was explicitly specified, NIL otherwise (named nil :type boolean) ;; any INITIAL-OFFSET option on this direct type @@ -163,8 +165,8 @@ ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its ;;;; close personal friend SB!XC:DEFSTRUCT) -;;; Return a list of forms to install print and make-load-form funs, mentioning -;;; them in the expansion so that they can be compiled. +;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs, +;;; mentioning them in the expansion so that they can be compiled. (defun class-method-definitions (defstruct) (let ((name (dd-name defstruct))) `((locally @@ -197,7 +199,7 @@ (funcall #',(farg po) ,x ,s)))) (t nil)))) ,@(let ((pure (dd-pure defstruct))) - (cond ((eq pure 't) + (cond ((eq pure t) `((setf (layout-pure (class-layout (sb!xc:find-class ',name))) t))) @@ -208,9 +210,7 @@ ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) `((setf (structure-class-constructor (sb!xc:find-class ',name)) - #',def-con)))) - ;; FIXME: MAKE-LOAD-FORM is supposed to be handled here, too. - )))) + #',def-con)))))))) ;;; FIXME: I really would like to make structure accessors less special, ;;; just ordinary inline functions. (Or perhaps inline functions with special ;;; compact implementations of their expansions, to avoid bloating the system.) @@ -246,11 +246,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) @@ -260,8 +262,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 @@ -269,13 +273,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. @@ -456,16 +461,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) @@ -486,7 +491,7 @@ (cond ((eq type 'funcallable-structure) (setf (dd-type defstruct) type)) ((member type '(list vector)) - (setf (dd-element-type defstruct) 't) + (setf (dd-element-type defstruct) t) (setf (dd-type defstruct) type)) ((and (consp type) (eq (first type) 'vector)) (destructuring-bind (vector vtype) type @@ -509,6 +514,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) @@ -590,13 +596,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))) @@ -613,7 +619,7 @@ (setf (dsd-default islot) default)) (when type-p (setf (dsd-type islot) - (if (eq (dsd-type islot) 't) + (if (eq (dsd-type islot) t) type `(and ,(dsd-type islot) ,type)))) (when ro-p @@ -1160,7 +1166,7 @@ (t (dsd-index slot))) (cond - ((eq rtype 't) object) + ((eq rtype t) object) (data) (t `(truly-the (simple-array (unsigned-byte 32) (*)) @@ -1261,8 +1267,7 @@ (dolist (slot (dd-slots defstruct)) (let ((dum (gensym)) (name (dsd-name slot))) - (arglist `((,(intern (string name) "KEYWORD") ,dum) - ,(dsd-default slot))) + (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot))) (types (dsd-type slot)) (vals dum))) (funcall creator @@ -1370,7 +1375,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 +1420,5 @@ (rest args))) (inherits (inherits-for-structure defstruct))) (function-%compiler-only-defstruct defstruct inherits))) + +(/show0 "code/defstruct.lisp end of file")