X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=2a81fb3d226b36f4f2c165c3e4d7db10e3297457;hb=5edd74f6911093805a009a152b32216b3dba59f7;hp=472e2e45cfe006d6fbf40efc7ee8d9d3885f7115;hpb=bed279acc9bd04eb1bbf56acb0dcaa3b1acf04f0;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 472e2e4..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))) @@ -676,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 @@ -721,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 @@ -1141,15 +1148,15 @@ (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) @@ -1160,34 +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) - ;; (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)) + ;; (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) @@ -1276,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