(in-package "SB!KERNEL")
-(file-comment
- "$Header$")
+(/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)
(intern (string (dsd-%name dsd))
(if (dsd-accessor dsd)
(symbol-package (dsd-accessor dsd))
- *package*)))
+ (sane-package))))
\f
;;;; typed (non-class) structures
;;;; 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
,@(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)
(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)))
(if (and (structure-class-p existing)
(not (eq (sb!xc:class-name existing) (dd-name defstruct)))
;;; 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))
(%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))))
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)
(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")
projects / sbcl.git / blobdiff