X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=2a81fb3d226b36f4f2c165c3e4d7db10e3297457;hb=5edd74f6911093805a009a152b32216b3dba59f7;hp=6ce094889b48ba59a3416925482cbf8a0b981d52;hpb=986ce2596822cc0871b609346aaf592348aca596;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6ce0948..2a81fb3 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -50,21 +50,25 @@ (:conc-name dd-) (:make-load-form-fun just-dump-it-normally) #-sb-xc-host (:pure t) - (:constructor make-defstruct-description (name))) + (:constructor make-defstruct-description + (name &aux + (conc-name (symbolicate name "-")) + (copier-name (symbolicate "COPY-" name)) + (predicate-name (symbolicate name "-P"))))) ;; name of the structure - (name (missing-arg) :type symbol) + (name (missing-arg) :type symbol :read-only t) ;; documentation on the structure (doc nil :type (or string null)) ;; prefix for slot names. If NIL, none. - (conc-name (symbolicate name "-") :type (or symbol null)) + (conc-name nil :type (or symbol null)) ;; the name of the primary standard keyword constructor, or NIL if none (default-constructor nil :type (or symbol null)) ;; all the explicit :CONSTRUCTOR specs, with name defaulted (constructors () :type list) ;; name of copying function - (copier-name (symbolicate "COPY-" name) :type (or symbol null)) + (copier-name nil :type (or symbol null)) ;; name of type predicate - (predicate-name (symbolicate name "-P") :type (or symbol null)) + (predicate-name nil :type (or symbol null)) ;; the arguments to the :INCLUDE option, or NIL if no included ;; structure (include nil :type list) @@ -274,7 +278,10 @@ fun-name))) (cond ((not (eql pf 0)) `((def!method print-object ((,x ,name) ,s) - (funcall #',(farg pf) ,x ,s *current-level*)))) + (funcall #',(farg pf) + ,x + ,s + *current-level-in-print*)))) ((not (eql po 0)) `((def!method print-object ((,x ,name) ,s) (funcall #',(farg po) ,x ,s)))) @@ -515,7 +522,7 @@ (when offset (incf (dd-length dd) offset))))) (when (dd-include dd) - (do-dd-inclusion-stuff dd)) + (frob-dd-inclusion-stuff dd)) dd))) @@ -610,6 +617,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 @@ -674,7 +683,7 @@ ;;; Process any included slots pretty much like they were specified. ;;; Also inherit various other attributes. -(defun do-dd-inclusion-stuff (dd) +(defun frob-dd-inclusion-stuff (dd) (destructuring-bind (included-name &rest modified-slots) (dd-include dd) (let* ((type (dd-type dd)) (included-structure @@ -719,7 +728,7 @@ (dolist (included-slot (dd-slots included-structure)) (let* ((included-name (dsd-name included-slot)) (modified (or (find included-name modified-slots - :key #'(lambda (x) (if (atom x) x (car x))) + :key (lambda (x) (if (atom x) x (car x))) :test #'string=) `(,included-name)))) (parse-1-dsd dd @@ -777,12 +786,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 +830,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 +1127,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,23 +1138,25 @@ ;;; 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))) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var)) + (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var)) vars types)) (let ((,temp (make-array ,(dd-length dd) :element-type ',(dd-element-type dd)))) - ,@(mapcar #'(lambda (x) - `(setf (aref ,temp ,(cdr x)) ',(car x))) + ,@(mapcar (lambda (x) + `(setf (aref ,temp ,(cdr x)) ',(car x))) (find-name-indices dd)) - ,@(mapcar #'(lambda (dsd value) - `(setf (aref ,temp ,(dsd-index dsd)) ,value)) + ,@(mapcar (lambda (dsd value) + `(setf (aref ,temp ,(dsd-index dsd)) ,value)) (dd-slots dd) values) ,temp)))) (defun create-list-constructor (dd cons-name arglist vars types values) @@ -1203,33 +1167,32 @@ (setf (elt vals (dsd-index dsd)) val)) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) - vars types)) + (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) (list ,@vals)))) (defun create-structure-constructor (dd cons-name arglist vars types values) - (let* ((temp (gensym)) - (raw-index (dd-raw-index dd)) - (n-raw-data (when raw-index (gensym)))) + (let* ((instance (gensym "INSTANCE")) + (raw-index (dd-raw-index dd))) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) + (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) - (let ((,temp (truly-the ,(dd-name dd) - (%make-instance ,(dd-length dd)))) - ,@(when n-raw-data - `((,n-raw-data - (make-array ,(dd-raw-length dd) - :element-type '(unsigned-byte 32)))))) - (setf (%instance-layout ,temp) - (%delayed-get-compiler-layout ,(dd-name dd))) - ,@(when n-raw-data - `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data))) + (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) + :element-type '(unsigned-byte 32))))) ,@(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 named slot setter function here + ;; because the slot might be :READ-ONLY, so we + ;; whip up new LAMBDA representations of slot + ;; setters for the occasion.) + `(,(slot-setter-lambda-form dd dsd) ,value ,instance)) (dd-slots dd) values) - ,temp)))) + ,instance)))) ;;; Create a default (non-BOA) keyword constructor. (defun create-keyword-constructor (defstruct creator) @@ -1318,9 +1281,9 @@ (funcall creator defstruct (first boa) (arglist) (vars) (types) - (mapcar #'(lambda (slot) - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default slot))) + (mapcar (lambda (slot) + (or (find (dsd-name slot) (vars) :test #'string=) + (dsd-default slot))) (dd-slots defstruct)))))) ;;; Grovel the constructor options, and decide what constructors (if