;;;; files for more information.
(in-package "SB!KERNEL")
+
+(/show0 "code/defstruct.lisp 15")
\f
;;;; getting LAYOUTs
;; 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)
;; 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
;;;; 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
(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)))
,@(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.)
(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)
;(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
(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-<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.
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)
(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
(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)
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)))
+ (declare (notinline find)) ; to avoid bug 117 bogowarnings
(if (and (structure-class-p existing)
(not (eq (sb!xc:class-name existing) (dd-name defstruct)))
(string= (dsd-%name (find accname
(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
(t
(dsd-index slot)))
(cond
- ((eq rtype 't) object)
+ ((eq rtype t) object)
(data)
(t
`(truly-the (simple-array (unsigned-byte 32) (*))
(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
(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
(rest args)))
(inherits (inherits-for-structure defstruct)))
(function-%compiler-only-defstruct defstruct inherits)))
+
+(/show0 "code/defstruct.lisp end of file")