X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=b0f374b0bf7629b017ac196f45b7c792ecafb2cb;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=8b83b5505cd5afc52cd6ac9f22a49e5aef68dc3f;hpb=05525d3a5906d7a89fcb689c26177732493c40ce;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 8b83b55..b0f374b 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -49,7 +49,7 @@ ;; slow, so if anyone cares about performance of ;; non-toplevel DEFSTRUCTs, it should be rewritten to be ;; cleverer. -- WHN 2002-10-23 - (sb!c::compiler-note + (sb!c:compiler-notify "implementation limitation: ~ Non-toplevel DEFSTRUCT constructors are slow.") (with-unique-names (layout) @@ -337,15 +337,18 @@ (if (dd-class-p dd) (let ((inherits (inherits-for-structure dd))) `(progn - ;; Note we intentionally call %DEFSTRUCT first, and - ;; especially before %COMPILER-DEFSTRUCT. %DEFSTRUCT - ;; has the tests (and resulting CERROR) for collisions - ;; with LAYOUTs which already exist in the runtime. If - ;; there are any collisions, we want the user's - ;; response to CERROR to control what happens. - ;; Especially, if the user responds to the collision - ;; with ABORT, we don't want %COMPILER-DEFSTRUCT to - ;; modify the definition of the class. + ;; Note we intentionally enforce package locks and + ;; call %DEFSTRUCT first, and especially before + ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and + ;; resulting CERROR) for collisions with LAYOUTs which + ;; already exist in the runtime. If there are any + ;; collisions, we want the user's response to CERROR + ;; to control what happens. Especially, if the user + ;; responds to the collision with ABORT, we don't want + ;; %COMPILER-DEFSTRUCT to modify the definition of the + ;; class. + (with-single-package-locked-error + (:symbol ',name "defining ~A as a structure")) (%defstruct ',dd ',inherits) (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-defstruct ',dd ',inherits)) @@ -358,6 +361,8 @@ (class-method-definitions dd))) ',name)) `(progn + (with-single-package-locked-error + (:symbol ',name "defining ~A as a structure")) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (info :typed-structure :info ',name) ',dd)) ,@(unless expanding-into-code-for-xc-host-p @@ -424,15 +429,16 @@ (and (typep ,argname ',ltype) ,(cond ((subtypep ltype 'list) - `(consp (nthcdr ,name-index (the ,ltype ,argname)))) + `(do ((head (the ,ltype ,argname) (cdr head)) + (i 0 (1+ i))) + ((or (not (consp head)) (= i ,name-index)) + (and (consp head) (eq ',name (car head)))))) ((subtypep ltype 'vector) - `(= (length (the ,ltype ,argname)) - ,(dd-length defstruct))) + `(and (= (length (the ,ltype ,argname)) + ,(dd-length defstruct)) + (eq ',name (aref (the ,ltype ,argname) ,name-index)))) (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." - ltype))) - (eq (elt (the ,ltype ,argname) - ,name-index) - ',name)))))))) + ltype)))))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. (defun typed-copier-definitions (defstruct) @@ -455,7 +461,7 @@ (let ((inherited (accessor-inherited-data name defstruct))) (cond ((not inherited) - (stuff `(proclaim '(inline ,name (setf ,name)))) + (stuff `(declaim (inline ,name (setf ,name)))) ;; FIXME: The arguments in the next two DEFUNs should ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to ;; be the name of a special variable, things could get @@ -604,23 +610,27 @@ :index 0 :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) - (cond - ((listp spec) - (destructuring-bind - (name - &optional (default nil default-p) - &key (type nil type-p) (read-only nil ro-p)) - spec - (values name - default default-p - (uncross type) type-p - read-only ro-p))) - (t - (when (keywordp spec) - (style-warn "Keyword slot name indicates probable syntax ~ - error in DEFSTRUCT: ~S." - spec)) - spec)) + (typecase spec + (symbol + (when (keywordp spec) + (style-warn "Keyword slot name indicates probable syntax ~ + error in DEFSTRUCT: ~S." + spec)) + spec) + (cons + (destructuring-bind + (name + &optional (default nil default-p) + &key (type nil type-p) (read-only nil ro-p)) + spec + (values name + default default-p + (uncross type) type-p + read-only ro-p))) + (t (error 'simple-program-error + :format-control "in DEFSTRUCT, ~S is not a legal slot ~ + description." + :format-arguments (list spec)))) (when (find name (dd-slots defstruct) :test #'string= @@ -652,11 +662,18 @@ remove the ambiguity in your code.~@:>" accessor-name) (setf (dd-predicate-name defstruct) nil)) - #-sb-xc-host - (when (and (fboundp accessor-name) - (not (accessor-inherited-data accessor-name defstruct))) - (style-warn "redefining ~S in DEFSTRUCT" accessor-name))) - + ;; FIXME: It would be good to check for name collisions here, but + ;; the easy check, + ;;x#-sb-xc-host + ;;x(when (and (fboundp accessor-name) + ;;x (not (accessor-inherited-data accessor-name defstruct))) + ;;x (style-warn "redefining ~S in DEFSTRUCT" accessor-name))) + ;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes + ;; a warning at MACROEXPAND time, when instead the warning should + ;; occur not just because the code was constructed, but because it + ;; is actually compiled or loaded. + ) + (when default-p (setf (dsd-default slot) default)) (when type-p @@ -668,8 +685,8 @@ (if read-only (setf (dsd-read-only slot) t) (when (dsd-read-only slot) - (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S." - name + (error "~@" (dsd-name slot))))) slot)) @@ -681,12 +698,7 @@ ;;; ;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*. (defun structure-raw-slot-type-and-size (type) - (cond #+nil - (;; FIXME: For now we suppress raw slots, since there are various - ;; issues about the way that the cross-compiler handles them. - (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*)) - (values nil nil nil)) - ((and (sb!xc:subtypep type '(unsigned-byte 32)) + (cond ((and (sb!xc:subtypep type '(unsigned-byte 32)) (multiple-value-bind (fixnum? fixnum-certain?) (sb!xc:subtypep type 'fixnum) ;; (The extra test for FIXNUM-CERTAIN? here is @@ -806,9 +818,16 @@ (dsd-index included-slot)) (dd-inherited-accessor-alist dd) :test #'eq :key #'car)) - (parse-1-dsd dd - modified - (copy-structure included-slot))))))) + (let ((new-slot (parse-1-dsd dd + modified + (copy-structure included-slot)))) + (when (and (neq (dsd-type new-slot) (dsd-type included-slot)) + (not (subtypep (dsd-type included-slot) + (dsd-type new-slot))) + (dsd-safe-p included-slot)) + (setf (dsd-safe-p new-slot) nil) + ;; XXX: notify? + ))))))) ;;;; various helper functions for setting up DEFSTRUCTs @@ -885,8 +904,20 @@ (multiple-value-bind (scaled-dsd-index misalignment) (floor (dsd-index dsd) raw-n-words) (aver (zerop misalignment)) - `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd)) - ,scaled-dsd-index)))))) + (let* ((raw-vector-bare-form + `(,ref ,instance-name ,(dd-raw-index dd))) + (raw-vector-form + (if (eq raw-type 'unsigned-byte) + (progn + (aver (= raw-n-words 1)) + (aver (eq raw-slot-accessor 'aref)) + ;; FIXME: when the 64-bit world rolls + ;; around, this will need to be reviewed, + ;; along with the whole RAW-SLOT thing. + `(truly-the (simple-array (unsigned-byte 32) (*)) + ,raw-vector-bare-form)) + raw-vector-bare-form))) + `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index))))))) ;;; Return source transforms for the reader and writer functions of ;;; the slot described by DSD. They should be inline expanded, but @@ -975,7 +1006,7 @@ (let ((predicate-name (dd-predicate-name dd))) (when predicate-name - (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name)) + (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name)) ;; Provide inline expansion (or not). (ecase (dd-type dd) ((structure funcallable-structure) @@ -1431,17 +1462,26 @@ (unless (or defaults boas) (push (symbolicate "MAKE-" (dd-name defstruct)) defaults)) - (collect ((res)) + (collect ((res) (names)) (when defaults - (let ((cname (first defaults))) - (setf (dd-default-constructor defstruct) cname) - (res (create-keyword-constructor defstruct creator)) - (dolist (other-name (rest defaults)) - (res `(setf (fdefinition ',other-name) (fdefinition ',cname))) - (res `(declaim (ftype function ',other-name)))))) + (let ((cname (first defaults))) + (setf (dd-default-constructor defstruct) cname) + (res (create-keyword-constructor defstruct creator)) + (names cname) + (dolist (other-name (rest defaults)) + (res `(setf (fdefinition ',other-name) (fdefinition ',cname))) + (names other-name)))) (dolist (boa boas) - (res (create-boa-constructor defstruct boa creator))) + (res (create-boa-constructor defstruct boa creator)) + (names (first boa))) + + (res `(declaim (ftype + (sfunction * + ,(if (eq (dd-type defstruct) 'structure) + (dd-name defstruct) + '*)) + ,@(names)))) (res))))