;; 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
%name
;; its position in the implementation sequence
(index (required-argument) :type fixnum)
- ;; Name of accessor, or NIL if this accessor has the same name as an
- ;; inherited accessor (which we don't want to shadow.)
+ ;; the name of the accessor function
+ ;;
+ ;; (CMU CL had extra complexity here ("..or NIL if this accessor has
+ ;; the same name as an inherited accessor (which we don't want to
+ ;; shadow)") but that behavior doesn't seem to be specified by (or
+ ;; even particularly consistent with) ANSI, so it's gone in SBCL.)
(accessor nil)
default ; default value expression
(type t) ; declared type specifier
;;;; 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.)
(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
;;; Parse a slot description for DEFSTRUCT, add it to the description
;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
;;; modify to get the new slot. This is supplied when handling
-;;; included slots. If the new accessor name is already an accessor
-;;; for same slot in some included structure, then set the
-;;; DSD-ACCESSOR to NIL so that we don't clobber the more general
-;;; accessor.
+;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
(islot (make-defstruct-slot-description :%name ""
:index 0
read-only ro-p)))
(t
(when (keywordp spec)
- ;; FIXME: should be style warning
- (warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT -- ~S."
- spec))
+ (style-warn "Keyword slot name indicates probable syntax ~
+ error in DEFSTRUCT: ~S."
+ spec))
spec))
(when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
(setf (dsd-%name islot) (string name))
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
- (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)))
- (string= (dsd-%name (find accname
- (dd-slots
- (layout-info
- (class-layout existing)))
- :key #'dsd-accessor))
- name))
- (setf (dsd-accessor islot) nil)
- (setf (dsd-accessor islot) accname)))
+ (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
+ (predicate-name (dd-predicate defstruct)))
+ (setf (dsd-accessor islot) accessor-name)
+ (when (eql accessor-name predicate-name)
+ ;; Some adventurous soul has named a slot so that its accessor
+ ;; collides with the structure type predicate. ANSI doesn't
+ ;; specify what to do in this case. As of 2001-09-04, Martin
+ ;; Atzmueller reports that CLISP and Lispworks both give
+ ;; priority to the slot accessor, so that the predicate is
+ ;; overwritten. We might as well do the same (as well as
+ ;; signalling a warning).
+ (style-warn
+ "~@<The structure accessor name ~S is the same as the name of the ~
+ structure type predicate. ANSI doesn't specify what to do in ~
+ this case; this implementation chooses to overwrite the type ~
+ predicate with the slot accessor.~@:>"
+ accessor-name)
+ (setf (dd-predicate defstruct) nil)))
(when default-p
(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
projects / sbcl.git / blobdiff