X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=621520ea439fe59ee5d20103afa0844bc4c65d10;hb=0dcc957ae6bf24809fda82fd59c134e70058c42a;hp=384aab06eaf06ca33d93df7cbb2d9eab12a8db8f;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 384aab0..621520ea 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -85,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 @@ -121,8 +121,12 @@ %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 @@ -165,8 +169,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 @@ -199,7 +203,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))) @@ -210,9 +214,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.) @@ -493,7 +495,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 @@ -569,10 +571,7 @@ ;;; 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 @@ -591,10 +590,9 @@ 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) @@ -604,24 +602,30 @@ (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 + "~@" + 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 @@ -1168,7 +1172,7 @@ (t (dsd-index slot))) (cond - ((eq rtype 't) object) + ((eq rtype t) object) (data) (t `(truly-the (simple-array (unsigned-byte 32) (*)) @@ -1269,8 +1273,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