X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=8b83b5505cd5afc52cd6ac9f22a49e5aef68dc3f;hb=f1407e424f1063203af07d2e61ceef58515a4797;hp=c0205452502c2764ef439f0829a80a15cd4466e4;hpb=670010e3f3dcd62efaf23f61abdc73950edb88c6;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index c020545..8b83b55 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -174,8 +174,8 @@ (:conc-name dsd-) (:copier nil) #-sb-xc-host (:pure t)) - ;; string name of slot - %name + ;; name of slot + name ;; its position in the implementation sequence (index (missing-arg) :type fixnum) ;; the name of the accessor function @@ -204,14 +204,6 @@ (def!method print-object ((x defstruct-slot-description) stream) (print-unreadable-object (x stream :type t) (prin1 (dsd-name x) stream))) - -;;; Return the name of a defstruct slot as a symbol. We store it as a -;;; string to avoid creating lots of worthless symbols at load time. -(defun dsd-name (dsd) - (intern (string (dsd-%name dsd)) - (if (dsd-accessor-name dsd) - (symbol-package (dsd-accessor-name dsd)) - (sane-package)))) ;;;; typed (non-class) structures @@ -223,7 +215,7 @@ ;;;; shared machinery for inline and out-of-line slot accessor functions -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed (defstruct raw-slot-data @@ -479,7 +471,7 @@ ((not (= (cdr inherited) index)) (style-warn "~@" name (dsd-%name slot)))))))) + instead).~:@>" name (dsd-name slot)))))))) (stuff))) ;;;; parsing @@ -608,7 +600,7 @@ ;;; that we modify to get the new slot. This is supplied when handling ;;; included slots. (defun parse-1-dsd (defstruct spec &optional - (slot (make-defstruct-slot-description :%name "" + (slot (make-defstruct-slot-description :name "" :index 0 :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) @@ -630,11 +622,13 @@ spec)) spec)) - (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) + (when (find name (dd-slots defstruct) + :test #'string= + :key (lambda (x) (symbol-name (dsd-name x)))) (error 'simple-program-error :format-control "duplicate slot name ~S" :format-arguments (list name))) - (setf (dsd-%name slot) (string name)) + (setf (dsd-name slot) name) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot))) (let ((accessor-name (if (dd-conc-name defstruct) @@ -894,26 +888,29 @@ `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd)) ,scaled-dsd-index)))))) -;;; Return inline expansion designators (i.e. values suitable for -;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader -;;; and writer functions of the slot described by DSD. -(defun slot-accessor-inline-expansion-designators (dd dsd) - (let ((instance-type-decl `(declare (type ,(dd-name dd) instance))) - (accessor-place-form (%accessor-place-form dd dsd 'instance)) +;;; Return source transforms for the reader and writer functions of +;;; the slot described by DSD. They should be inline expanded, but +;;; source transforms work faster. +(defun slot-accessor-transforms (dd dsd) + (let ((accessor-place-form (%accessor-place-form dd dsd + `(the ,(dd-name dd) instance))) (dsd-type (dsd-type dsd)) (value-the (if (dsd-safe-p dsd) 'truly-the 'the))) - (values (lambda () `(lambda (instance) - ,instance-type-decl - (,value-the ,dsd-type ,accessor-place-form))) - (lambda () `(lambda (new-value instance) - (declare (type ,dsd-type new-value)) - ,instance-type-decl - (setf ,accessor-place-form new-value)))))) + (values (sb!c:source-transform-lambda (instance) + `(,value-the ,dsd-type ,(subst instance 'instance + accessor-place-form))) + (sb!c:source-transform-lambda (new-value instance) + (destructuring-bind (accessor-name &rest accessor-args) + accessor-place-form + `(,(info :setf :inverse accessor-name) + ,@(subst instance 'instance accessor-args) + (the ,dsd-type ,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)))) + `(lambda (new-value instance) + ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd)) + '(dummy new-value instance)))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities @@ -974,15 +971,15 @@ (let ((copier-name (dd-copier-name dd))) (when copier-name - (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name)))) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name)))) (let ((predicate-name (dd-predicate-name dd))) (when predicate-name - (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name)) + (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name)) ;; Provide inline expansion (or not). (ecase (dd-type dd) ((structure funcallable-structure) - ;; Let the predicate be inlined. + ;; Let the predicate be inlined. (setf (info :function :inline-expansion-designator predicate-name) (lambda () `(lambda (x) @@ -1008,31 +1005,24 @@ (cond ((not inherited) (multiple-value-bind (reader-designator writer-designator) - (slot-accessor-inline-expansion-designators dd dsd) - (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) + (slot-accessor-transforms dd dsd) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type) ,accessor-name)) - (setf (info :function :inline-expansion-designator - accessor-name) - reader-designator - (info :function :inlinep accessor-name) - :inline) + (setf (info :function :source-transform accessor-name) + reader-designator) (unless (dsd-read-only dsd) (let ((setf-accessor-name `(setf ,accessor-name))) (sb!xc:proclaim - `(ftype (function (,dsd-type ,dtype) ,dsd-type) + `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type) ,setf-accessor-name)) - (setf (info :function - :inline-expansion-designator - setf-accessor-name) - writer-designator - (info :function :inlinep setf-accessor-name) - :inline))))) + (setf (info :function :source-transform setf-accessor-name) + writer-designator))))) ((not (= (cdr inherited) (dsd-index dsd))) (style-warn "~@" accessor-name - (dsd-%name dsd))))))))) + (dsd-name dsd))))))))) (values)) ;;;; redefinition stuff @@ -1049,16 +1039,16 @@ (collect ((moved) (retyped)) (dolist (name (intersection onames nnames)) - (let ((os (find name oslots :key #'dsd-name)) - (ns (find name nslots :key #'dsd-name))) - (unless (subtypep (dsd-type ns) (dsd-type os)) + (let ((os (find name oslots :key #'dsd-name :test #'string=)) + (ns (find name nslots :key #'dsd-name :test #'string=))) + (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os)) (retyped name)) (unless (and (= (dsd-index os) (dsd-index ns)) (eq (dsd-raw-type os) (dsd-raw-type ns))) (moved name)))) (values (moved) (retyped) - (set-difference onames nnames))))) + (set-difference onames nnames :test #'string=))))) ;;; If we are redefining a structure with different slots than in the ;;; currently loaded version, give a warning and return true. @@ -1498,7 +1488,7 @@ (index 1)) (dolist (slot-name slot-names) (push (make-defstruct-slot-description - :%name (symbol-name slot-name) + :name slot-name :index index :accessor-name (symbolicate conc-name slot-name)) reversed-result) @@ -1588,7 +1578,8 @@ (let ((,object-gensym ,raw-maker-form)) ,@(mapcar (lambda (slot-name) (let ((dsd (find (symbol-name slot-name) dd-slots - :key #'dsd-%name + :key (lambda (x) + (symbol-name (dsd-name x))) :test #'string=))) ;; KLUDGE: bug 117 bogowarning. Neither ;; DECLAREing the type nor TRULY-THE cut