X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=eece9616ef3f2b700677b98340b8e6e333b2e8fc;hb=d8346491af87b66677657e4b934ddeae1e749250;hp=2a81fb3d226b36f4f2c165c3e4d7db10e3297457;hpb=78a057624fecd10d0fb2ead4ef02ffc361b1ee22;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2a81fb3..eece961 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -27,10 +27,36 @@ (t res)))) ;;; Delay looking for compiler-layout until the constructor is being -;;; compiled, since it doesn't exist until after the EVAL-WHEN (COMPILE) -;;; stuff is compiled. +;;; compiled, since it doesn't exist until after the EVAL-WHEN +;;; (COMPILE) stuff is compiled. (Or, in the oddball case when +;;; DEFSTRUCT is executing in a non-toplevel context, the +;;; compiler-layout still doesn't exist at compilation time, and we +;;; delay still further.) (sb!xc:defmacro %delayed-get-compiler-layout (name) - `',(compiler-layout-or-lose name)) + (let ((layout (info :type :compiler-layout name))) + (cond (layout + ;; ordinary case: When the DEFSTRUCT is at top level, + ;; then EVAL-WHEN (COMPILE) stuff will have set up the + ;; layout for us to use. + (unless (typep (layout-info layout) 'defstruct-description) + (error "Class is not a structure class: ~S" name)) + `,layout) + (t + ;; KLUDGE: In the case that DEFSTRUCT is not at top-level + ;; the layout doesn't exist at compile time. In that case + ;; we laboriously look it up at run time. This code will + ;; run on every constructor call and will likely be quite + ;; 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 + "implementation limitation: ~ + Non-toplevel DEFSTRUCT constructors are slow.") + (let ((layout (gensym "LAYOUT"))) + `(let ((,layout (info :type :compiler-layout ',name))) + (unless (typep (layout-info ,layout) 'defstruct-description) + (error "Class is not a structure class: ~S" ',name)) + ,layout)))))) ;;; Get layout right away. (sb!xc:defmacro compile-time-find-layout (name) @@ -315,14 +341,23 @@ (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. + (%defstruct ',dd ',inherits) (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-defstruct ',dd ',inherits)) - (%defstruct ',dd ',inherits) ,@(unless expanding-into-code-for-xc-host-p (append ;; FIXME: We've inherited from CMU CL nonparallel ;; code for creating copiers for typed and untyped ;; structures. This should be fixed. - ;(copier-definition dd) + ;(copier-definition dd) (constructor-definitions dd) (class-method-definitions dd))) ',name)) @@ -890,9 +925,7 @@ (%compiler-set-up-layout dd inherits) - (let* ((dd-name (dd-name dd)) - (dtype (dd-declarable-type dd)) - (class (sb!xc:find-class dd-name))) + (let* ((dtype (dd-declarable-type dd))) (let ((copier-name (dd-copier-name dd))) (when copier-name @@ -999,19 +1032,37 @@ (declare (type sb!xc:class class) (type layout old-layout new-layout)) (let ((name (class-proper-name class))) (restart-case - (error "redefining class ~S incompatibly with the current definition" + (error "~@" + 'structure-object name) (continue () - :report "Invalidate current definition." - (warn "Previously loaded ~S accessors will no longer work." name) - (register-layout new-layout)) + :report (lambda (s) + (format s + "~@" + name)) + (register-layout new-layout)) + (recklessly-continue () + :report (lambda (s) + (format s + "~@" + name)) + ;; classic CMU CL warning: "Any old ~S instances will be in a bad way. + ;; I hope you know what you're doing..." + (register-layout new-layout + :invalidate nil + :destruct-layout old-layout)) (clobber-it () - :report "Smash current layout, preserving old code." - (warn "Any old ~S instances will be in a bad way.~@ - I hope you know what you're doing..." - name) - (register-layout new-layout :invalidate nil - :destruct-layout old-layout)))) + ;; FIXME: deprecated 2002-10-16, and since it's only interactive + ;; hackery instead of a supported feature, can probably be deleted + ;; in early 2003 + :report "(deprecated synonym for RECKLESSLY-CONTINUE)" + (register-layout new-layout + :invalidate nil + :destruct-layout old-layout)))) (values)) ;;; This is called when we are about to define a structure class. It @@ -1178,7 +1229,6 @@ (let ((,instance (truly-the ,(dd-name dd) (%make-instance-with-layout (%delayed-get-compiler-layout ,(dd-name dd)))))) - (declare (optimize (safety 0))) ; Suppress redundant slot type checks. ,@(when raw-index `((setf (%instance-ref ,instance ,raw-index) (make-array ,(dd-raw-length dd) @@ -1212,8 +1262,8 @@ ;;; 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) - (sb!kernel:parse-lambda-list (second boa)) + (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) + (parse-lambda-list (second boa)) (collect ((arglist) (vars) (types)) @@ -1239,9 +1289,16 @@ (dolist (arg opt) (cond ((consp arg) (destructuring-bind - (name &optional (def (nth-value 1 (get-slot name)))) + ;; FIXME: this shares some logic (though not + ;; code) with the &key case below (and it + ;; looks confusing) -- factor out the logic + ;; if possible. - CSR, 2002-04-19 + (name + &optional + (def (nth-value 1 (get-slot name))) + (supplied-test nil supplied-test-p)) arg - (arglist `(,name ,def)) + (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types (get-slot name)))) (t @@ -1256,21 +1313,27 @@ (arglist '&key) (dolist (key keys) (if (consp key) - (destructuring-bind (wot &optional (def nil def-p)) key + (destructuring-bind (wot + &optional + (def nil def-p) + (supplied-test nil supplied-test-p)) + key (let ((name (if (consp wot) (destructuring-bind (key var) wot (declare (ignore key)) var) wot))) - (multiple-value-bind (type slot-def) (get-slot name) - (arglist `(,wot ,(if def-p def slot-def))) + (multiple-value-bind (type slot-def) + (get-slot name) + (arglist `(,wot ,(if def-p def slot-def) + ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types type)))) (do-default key)))) (when allowp (arglist '&allow-other-keys)) - (when aux + (when auxp (arglist '&aux) (dolist (arg aux) (let* ((arg (if (consp arg) arg (list arg))) @@ -1409,7 +1472,6 @@ :metaclass-name metaclass-name :metaclass-constructor metaclass-constructor :dd-type dd-type)) - (conc-name (concatenate 'string (symbol-name class-name) "-")) (dd-slots (dd-slots dd)) (dd-length (1+ (length slot-names))) (object-gensym (gensym "OBJECT")) @@ -1461,8 +1523,12 @@ (let ((dsd (find (symbol-name slot-name) dd-slots :key #'dsd-%name :test #'string=))) + ;; KLUDGE: bug 117 bogowarning. Neither + ;; DECLAREing the type nor TRULY-THE cut + ;; the mustard -- it still gives warnings. + (enforce-type dsd defstruct-slot-description) `(setf (,(dsd-accessor-name dsd) ,object-gensym) - ,slot-name))) + ,slot-name))) slot-names) ,object-gensym))