From: William Harold Newman Date: Thu, 1 Nov 2001 20:24:55 +0000 (+0000) Subject: 0.pre7.81: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bed279acc9bd04eb1bbf56acb0dcaa3b1acf04f0;p=sbcl.git 0.pre7.81: DEFSTRUCT cleanups.. ..got rid of old SLOT-ACCESSOR-FORM in favor of %ACCESSOR-PLACE-FORM, so that now information about the different types of raw slots is more nearly centralized in *RAW-SLOT-DATA-LIST* ..moved target-only stuff from near %TARGET-DEFSTRUCT call in %DEFSTRUCT into %TARGET-DEFSTRUCT miscellaneous cleanups.. ..added (SETQ *PRINT-CIRCLE* T) to the before-proper-printing hacks in make-target-2.sh fixed stupid *PRINT-CIRCLE*-related bug in OUTPUT-OBJECT (introduced in the 0.pre7.76 changes) --- diff --git a/TODO b/TODO index 859f907..81096e5 100644 --- a/TODO +++ b/TODO @@ -4,14 +4,6 @@ for 0.7.0: protruding rusty nails and snipped off the trailing razor wire, leaving some filing for later:-) from the monster EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup: - ** substantially rewrote DEFSTRUCT implementation to work - cleanly with EVAL-WHEN, not sleazily use DEFUN for - structure functions, implement out-of-line structure - accessors as closures, reduce or eliminate non-ANSI - magicality of structure functions - *** made structure type tests work again - *** got rid of bogus warnings about "redefinition" of - structure accessors ** made inlining DEFUN inside MACROLET work again ** made %COMPILE set up debugging data more like the way the debugger expects (and maybe even completely @@ -30,7 +22,7 @@ for 0.7.0: ** reserved DO-FOO-style names for iteration macros ** finished s/FUNCTION/FUN/ ** s/VARIABLE/VAR/ - ** s/TOPLEVEL/TOP-LEVEL/ + ** s/TOP-LEVEL/TOPLEVEL/ * global style systematization: ** s/#'(lambda/(lambda/ ** four-space indentation in C diff --git a/make-target-2.sh b/make-target-2.sh index 58bd723..bb0f113 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -42,6 +42,7 @@ echo //doing warm init ;; initialized yet.) (setq *print-length* 10) (setq *print-level* 5) + (setq *print-circle* t) ;; Do warm init. #+sb-show (print "/about to LOAD warm.lisp") @@ -56,6 +57,7 @@ echo //doing warm init ;; control variables to their ANSI defaults. (setq *print-length* nil) (setq *print-level* nil) + (setq *print-circle* nil) ;; FIXME: Why is it that, at least on x86 sbcl-0.6.12.46, ;; GC :FULL T isn't nearly as effective as PURIFY here? diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6ce0948..472e2e4 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -610,6 +610,8 @@ ;;; RAW? is true if TYPE should be stored in a raw slot. ;;; RAW-TYPE is the raw slot type, or NIL if no raw slot. ;;; WORDS is the number of words in the raw slot, or NIL if no raw slot. +;;; +;;; 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 @@ -777,12 +779,7 @@ ;; Various other operations only make sense on the target SBCL. #-sb-xc-host - (progn - (remhash (dd-name dd) *typecheckfuns*) - (%target-defstruct dd layout) - (when (dd-doc dd) - (setf (fdocumentation (dd-name dd) 'type) - (dd-doc dd))))) + (%target-defstruct dd layout)) (values)) @@ -826,6 +823,11 @@ ,instance-type-decl (setf ,accessor-place-form new-value)))))) +;;; Return a LAMBDA form which can be used to set a slot. +(defun slot-setter-lambda-form (dd dsd) + (funcall (nth-value 1 + (slot-accessor-inline-expansion-designators dd dsd)))) + ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities (defun %compiler-set-up-layout (dd @@ -1118,53 +1120,6 @@ (res))) -;;;; slot accessors for raw slots - -;;; Return info about how to read/write a slot in the value stored in -;;; OBJECT. This is also used by constructors (since we can't safely -;;; use the accessor function, since some slots are read-only). If -;;; supplied, DATA is a variable holding the raw-data vector. -;;; -;;; returned values: -;;; 1. accessor function name (SETFable) -;;; 2. index to pass to accessor. -;;; 3. object form to pass to accessor -(defun slot-accessor-form (defstruct slot object &optional data) - (let ((rtype (dsd-raw-type slot))) - (values - (ecase rtype - (single-float '%raw-ref-single) - (double-float '%raw-ref-double) - #!+long-float - (long-float '%raw-ref-long) - (complex-single-float '%raw-ref-complex-single) - (complex-double-float '%raw-ref-complex-double) - #!+long-float - (complex-long-float '%raw-ref-complex-long) - (unsigned-byte 'aref) - ((t) '%instance-ref)) - (case rtype - #!+long-float - (complex-long-float - (truncate (dsd-index slot) #!+x86 6 #!+sparc 8)) - #!+long-float - (long-float - (truncate (dsd-index slot) #!+x86 3 #!+sparc 4)) - (double-float - (ash (dsd-index slot) -1)) - (complex-double-float - (ash (dsd-index slot) -2)) - (complex-single-float - (ash (dsd-index slot) -1)) - (t - (dsd-index slot))) - (cond - ((eq rtype t) object) - (data) - (t - `(truly-the (simple-array (unsigned-byte 32) (*)) - (%instance-ref ,object ,(dd-raw-index defstruct)))))))) - ;;; These functions are called to actually make a constructor after we ;;; have processed the arglist. The correct variant (according to the ;;; DD-TYPE) should be called. The function is defined with the @@ -1176,10 +1131,12 @@ ;;; various weird places, whereas STRUCTURE structures have ;;; a LAYOUT slot. ;;; * We really want to use LIST to make list structures, instead of -;;; MAKE-LIST/(SETF ELT). +;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an +;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed +;;; structures can have arbitrary subtypes of VECTOR, not necessarily +;;; SIMPLE-VECTOR.) ;;; * 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. +;;; allocated and indirectly referenced. (defun create-vector-constructor (dd cons-name arglist vars types values) (let ((temp (gensym)) (etype (dd-element-type dd))) @@ -1224,9 +1181,10 @@ ,@(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 dd dsd temp n-raw-data) - `(setf (,accessor ,data ,index) ,value))) + ;; (Note that we can't in general use the ordinary + ;; slot accessor function here because the slot + ;; might be :READ-ONLY.) + `(,(slot-setter-lambda-form dd dsd) ,value ,temp)) (dd-slots dd) values) ,temp)))) diff --git a/src/code/print.lisp b/src/code/print.lisp index d61a992..205afbe 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -418,7 +418,7 @@ ;; if it is a compound object it might contain a circular ;; reference to itself or multiple shared references. (or *circularity-hash-table* - (compound-object-p x)) + (compound-object-p object)) (check-it stream)) (t (print-it stream))))) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 702abbc..07a3124 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -148,9 +148,7 @@ (/show0 "leaving PROTECT-CL") (values)) -;;; the part of %DEFSTRUCT which sets up out-of-line implementations -;;; of those structure functions which are sufficiently similar -;;; between structures that they can be closures +;;; the part of %DEFSTRUCT which makes sense only on the target SBCL ;;; ;;; (The "static" in the name is because it needs to be done not only ;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as @@ -162,9 +160,11 @@ (/show0 "entering %TARGET-DEFSTRUCT") + (remhash (dd-name dd) *typecheckfuns*) + ;; (Constructors aren't set up here, because constructors are ;; varied enough (possibly parsing any specified argument list) - ;; that we can't reasonably implement them as closures, and so + ;; that we can't reasonably implement them as closures, so we ;; implement them with DEFUN instead.) ;; Set FDEFINITIONs for slot accessors. @@ -222,9 +222,12 @@ (/show0 ":TYPE LIST case") #'listp)))) + (when (dd-doc dd) + (setf (fdocumentation (dd-name dd) 'type) + (dd-doc dd))) + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) - ;;;; generating out-of-line slot accessor functions diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index e0995f3..1015257 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -318,6 +318,11 @@ (manyraw-ee *manyraw*) #c(0.44d0 0.44d0)) (let ((copy (copy-manyraw *manyraw*))) + (assert (eql (manyraw-a copy) (expt 2 30))) + (assert (eql (manyraw-b copy) 0.1)) + (assert (eql (manyraw-c copy) 0.2d0)) + (assert (eql (manyraw-d copy) #c(0.3 0.3))) + (assert (eql (manyraw-e copy) #c(0.4d0 0.4d0))) (assert (eql (manyraw-aa copy) (expt 2 31))) (assert (eql (manyraw-bb copy) 0.11)) (assert (eql (manyraw-cc copy) 0.22d0)) diff --git a/version.lisp-expr b/version.lisp-expr index f648513..dc5e79a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.80" +"0.pre7.81"