Ignore:
Timestamp:
Sep 15, 2010, 12:07:42 AM (9 years ago)
Author:
gz
Message:

r14258 from trunk (defstruct changes)

Location:
branches/qres/ccl
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/compile-ccl.lisp

    r14049 r14259  
    371371  (require-update-modules *sysdef-modules* force) ;in the host
    372372  (let* ((backend (or (find-backend target) *target-backend*))
    373          (arch (backend-target-arch-name backend))
    374          (*defstruct-share-accessor-functions* nil))
     373         (arch (backend-target-arch-name backend)))
    375374    (target-compile-modules 'nxenv target force)
    376375    (target-compile-modules *compiler-modules* target force)
  • branches/qres/ccl/lib/defstruct-lds.lisp

    r14057 r14259  
    249249       (remove-structure-defs  ',struct-name) ; lose any previous defs
    250250        ,.(defstruct-slot-defs sd refnames env)
    251         ,.(if copier (defstruct-copier sd copier env))
    252         ,.(if predicate (defstruct-predicate sd named predicate env))
    253251        (eval-when (:compile-toplevel)
    254252          (define-compile-time-structure
     
    261259         ,(if (and predicate (null (sd-type sd))) `',predicate)
    262260         ,.(if documentation (list documentation)))
     261        ,.(if copier (defstruct-copier sd copier env))
     262        ,.(if predicate (defstruct-predicate sd named predicate env))
    263263        ,.(%defstruct-compile sd refnames env)
    264         ,.(defstruct-boa-constructors sd boa-constructors)
    265         ,.(if constructor (list (defstruct-constructor sd constructor)))
     264        ,.(defstruct-boa-constructors sd boa-constructors env)
     265        ,.(if constructor (list (defstruct-constructor sd constructor env)))
    266266       ;; Wait until slot accessors are defined, to avoid
    267267       ;; undefined function warnings in the print function/method.
     
    286286  (intern (%str-cat (string name1) (string name2))))
    287287
    288 (defun wrap-with-type-check (value slot &aux (slot-type (ssd-type slot)))
    289   (if (eq t slot-type)
    290     value
    291     `(require-type ,value ',slot-type)))
     288(defun wrap-with-typecheck (value slot env)
     289  (let ((slot-type (defstruct-type-for-typecheck (ssd-type slot) env)))
     290    (if (eq t slot-type)
     291      value
     292      `(typecheck ,value ,slot-type))))
    292293
    293294(defun make-class-cells-list (class-names)
     
    301302    class-names))
    302303
    303 (defun defstruct-constructor (sd constructor &aux (offset 0)
    304                                                   (args ())
    305                                                   (values ())
    306                                                   slot-offset
    307                                                   name)
     304(defun defstruct-constructor (sd constructor env &aux (offset 0)
     305                                                      (args ())
     306                                                      (values ())
     307                                                      slot-offset
     308                                                      name)
    308309  (dolist (slot (sd-slots sd))
    309310    (setq slot-offset (ssd-offset slot))
     
    316317      (if (eql 0 name)
    317318        (push (make-class-cells-list (ssd-initform slot)) values)
    318         (push (wrap-with-type-check (ssd-initform slot) slot) values))
     319        (push (wrap-with-typecheck (ssd-initform slot) slot env) values))
    319320      (let* ((temp (make-symbol (symbol-name name))))
    320321        (push (list (list (make-keyword name) temp) (ssd-initform slot)) args)
    321         (push (wrap-with-type-check temp slot) values)))
     322        (push (wrap-with-typecheck temp slot env) values)))
    322323    (setq offset (%i+ offset 1)))
    323324  (setq values (nreverse values))
     
    330331          (t `(uvector ,name ,@values)))))
    331332
    332 (defun defstruct-boa-constructors (sd boas &aux (list ()))
     333(defun defstruct-boa-constructors (sd boas env &aux (list ()))
    333334  (dolist (boa boas list)
    334     (push (defstruct-boa-constructor sd boa) list)))
    335 
    336 (defun defstruct-boa-constructor (sd boa &aux (args ())
     335    (push (defstruct-boa-constructor sd boa env) list)))
     336
     337(defun defstruct-boa-constructor (sd boa env &aux (args ())
    337338                                     (used-slots ())
    338339                                     (values ())
     
    375376          values)
    376377    (setq offset (%i+ offset 1)))
    377   (setq values (mapcar #'wrap-with-type-check (nreverse values) (sd-slots sd)))
     378  (setq values (mapcar (lambda (v s) (wrap-with-typecheck v s env)) (nreverse values) (sd-slots sd)))
    378379  `(defun ,(car boa) ,(nreverse args)
    379     ,(case (setq slot (defstruct-reftype (sd-type sd)))
    380            (#.$defstruct-nth `(list ,@values))
    381            (#.target::subtag-simple-vector `(vector ,@values))
    382            ((#.target::subtag-struct #.$defstruct-struct)
    383             `(gvector :struct ,@values))
    384            (t `(uvector ,slot ,@values)))))
     380     ,(case (setq slot (defstruct-reftype (sd-type sd)))
     381        (#.$defstruct-nth `(list ,@values))
     382        (#.target::subtag-simple-vector `(vector ,@values))
     383        ((#.target::subtag-struct #.$defstruct-struct)
     384         `(gvector :struct ,@values))
     385        (t `(uvector ,slot ,@values)))))
    385386
    386387(defun defstruct-copier (sd copier env)
    387   `((eval-when (:compile-toplevel)
    388       (record-function-info ',copier ',*one-arg-defun-def-info* ,env))
    389     (fset ',copier
    390           ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
    391     (record-source-file ',copier 'function)))
     388  (let* ((sd-name (sd-name sd))
     389         (sd-type (sd-type sd))
     390         (var (defstruct-var sd-name env))
     391         (arg (if sd-type var `(typecheck ,var ,sd-name)))
     392         (fn (if (eq sd-type 'list) 'copy-list 'copy-uvector)))
     393    `((defun ,copier (,var) (,fn ,arg)))))
    392394
    393395(defun defstruct-predicate (sd named predicate env)
  • branches/qres/ccl/lib/defstruct.lisp

    r14057 r14259  
    3535             (cons type refinfo)))))
    3636
    37 (declaim (inline type-and-refinfo-p))
    38 (defun type-and-refinfo-p (object)
    39   (or (fixnump object) (consp object)))
     37(declaim (inline accessor-structref-info-p))
     38(defun accessor-structref-info-p (object) ;; as opposed to predicate structref-info.
     39  (consp object))
     40
     41(declaim (inline structref-info-type))
     42(defun structref-info-type (info)
     43  (when (consp info)
     44    (if (consp (%car info)) (%caar info) 't)))
     45
     46(declaim (inline structref-info-refinfo))
     47(defun structref-info-refinfo (info)
     48  (when (consp info)
     49    (if (consp (%car info)) (%cdar info) (%car info))))
     50
     51(defun structref-set-r/o (sym &optional env)
     52  (let ((info (structref-info sym env)))
     53    (when (accessor-structref-info-p info)
     54      (if (consp (%car info))
     55        (setf (%cdar info) (%ilogior2 (%ilsl $struct-r/o 1) (%cdar info)))
     56        (setf (%car info) (%ilogior2 (%ilsl $struct-r/o 1) (%car info)))))))
     57
     58(declaim (inline structref-info-struct))
     59(defun structref-info-struct (info)
     60  (when (consp info)
     61    (%cdr info)))
    4062
    4163(defun ssd-set-reftype (ssd reftype)
     
    4668(defun ssd-set-r/o (ssd)
    4769  (ssd-update-refinfo (ssd refinfo)
    48                       (%ilogior2 #x1000000 refinfo)))
     70                      (%ilogior2 (%ilsl $struct-r/o 1) refinfo)))
    4971
    5072(defun ssd-set-inherited (ssd)
     
    139161;;; return stuff for defstruct to compile
    140162(defun %defstruct-compile (sd refnames env)
    141   (let ((stuff))   
     163  (let ((stuff)
     164        (struct (and (not (sd-type sd)) (sd-name sd))))
    142165    (dolist (slot (sd-slots sd))
    143166      (unless (fixnump (ssd-name slot))
     
    151174                      accessor)))
    152175            (unless (sd-refname-in-included-struct-p sd accessor env)
    153               (let ((fn (slot-accessor-fn slot accessor env)))
     176              (let ((fn (slot-accessor-fn sd slot accessor env))
     177                    (info (cons (ssd-type-and-refinfo slot) struct)))
    154178                (push
    155179                 `(progn
    156180                    ,.fn
    157                     (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
     181                    (puthash ',accessor %structure-refs% ',info)
    158182                    (record-source-file ',accessor 'structure-accessor))
    159183                 stuff)))))))
    160184    (nreverse stuff)))
    161185
    162 
    163 ; no #. for cross compile
    164 (defvar *struct-ref-vector*
    165   (vector #'(lambda (x) (struct-ref x 0))
    166           #'(lambda (x) (struct-ref x 1))
    167           #'(lambda (x) (struct-ref x 2))
    168           #'(lambda (x) (struct-ref x 3))
    169           #'(lambda (x) (struct-ref x 4))
    170           #'(lambda (x) (struct-ref x 5))
    171           #'(lambda (x) (struct-ref x 6))
    172           #'(lambda (x) (struct-ref x 7))
    173           #'(lambda (x) (struct-ref x 8))
    174           #'(lambda (x) (struct-ref x 9))))
    175 
    176 (defvar *svref-vector*
    177   (vector #'(lambda (x) (svref x 0))
    178           #'(lambda (x) (svref x 1))
    179           #'(lambda (x) (svref x 2))
    180           #'(lambda (x) (svref x 3))
    181           #'(lambda (x) (svref x 4))
    182           #'(lambda (x) (svref x 5))
    183           #'(lambda (x) (svref x 6))
    184           #'(lambda (x) (svref x 7))
    185           #'(lambda (x) (svref x 8))
    186           #'(lambda (x) (svref x 9))))
    187 
    188 
    189 ;;; too bad there isnt a way to suppress generating these darn
    190 ;;; functions when you dont want them.  Makes no sense to fetch
    191 ;;; functions from a vector of 68K functions and send them over to
    192 ;;; PPC.  So can use that space optimization iff host and target are
    193 ;;; the same.
    194 
    195 
    196 (defparameter *defstruct-share-accessor-functions* t)   ;; TODO: isn't it time to get rid of this?
    197 
    198 (defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot)))
    199   (cond ((eq ref $defstruct-nth)
    200          (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
    201            `((eval-when (:compile-toplevel)
    202                (record-function-info ',name ',*one-arg-defun-def-info* ,env))
    203               (fset ',name
    204                     ,(symbol-function
    205                       (%svref '#(first second third fourth fifth
    206                                  sixth seventh eighth ninth tenth) offset))))
    207            `((defun ,name (x)  (nth ,offset x)))))
    208         ((eq ref $defstruct-struct)
    209          (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    210            `((eval-when (:compile-toplevel)
    211                (record-function-info ',name ',*one-arg-defun-def-info* ,env))               
    212              (fset ',name , (%svref *struct-ref-vector* offset)))
    213            `((defun ,name (x)  (struct-ref x ,offset)))))
    214         ((or (eq ref target::subtag-simple-vector)
    215              (eq ref $defstruct-simple-vector))
    216          (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
    217            `((eval-when (:compile-toplevel)
    218                (record-function-info ',name ',*one-arg-defun-def-info* ,env))
    219              (fset ',name ,(%svref *svref-vector* offset)))
    220            `((defun ,name (x)  (svref x ,offset)))))
    221         (t `((defun ,name (x) (uvref x ,offset))))))
     186(defun defstruct-var (name env)
     187  (declare (ignore env))
     188  (if (symbolp name)
     189    (if (or (constant-symbol-p name) (proclaimed-special-p name))
     190      (make-symbol (symbol-name name))
     191      name)
     192    'object))
     193
     194(defun slot-accessor-fn (sd slot name env)
     195  (let* ((ref (ssd-reftype slot))
     196         (offset (ssd-offset slot))
     197         (arg (defstruct-var (sd-name sd) env))
     198         (value (gensym "VALUE"))
     199         (type (defstruct-type-for-typecheck (ssd-type slot) env))
     200         (form (cond ((eq ref $defstruct-nth)
     201                      `(nth ,offset ,arg))
     202                     ((eq ref $defstruct-struct)
     203                      `(struct-ref (typecheck ,arg ,(sd-name sd)) ,offset))
     204                     ((or (eq ref target::subtag-simple-vector)
     205                          (eq ref $defstruct-simple-vector))
     206                      `(svref ,arg ,offset))
     207                     (t `(uvref ,arg ,offset)))))
     208    `((defun ,name (,arg)
     209        ,(if (eq type 't) form `(the ,type ,form)))
     210      ,@(unless (ssd-r/o slot)
     211          `((defun (setf ,name) (,value ,arg)
     212              ,(if (eq type 't)
     213                 `(setf ,form ,value)
     214                 `(the ,type (setf ,form (typecheck ,value ,type))))))))))
    222215
    223216(defun defstruct-reftype (type)
     
    238231    `((declaim (inline ,@defs)))))
    239232
     233(defun structref-info (sym &optional env)
     234  (let ((info (or (and env (environment-structref-info sym env))
     235                  (gethash sym %structure-refs%))))
     236    ;; This can be removed once $fasl-min-vers is greater than #x5e
     237    #-BOOTSTRAPPED
     238    (when (or (fixnump info)
     239              (and (consp info) (fixnump (%cdr info))))
     240      ;; Old style, without struct type info.
     241      (setq info (cons info 'structure-object)))
     242    info))
     243
     244(defun defstruct-type-for-typecheck (type env)
     245  (if (or (eq type 't)
     246          (specifier-type-if-known type env)
     247          (nx-declarations-typecheck env))
     248    type
     249    ;; Else have an unknown type used only for an implicit declaration.
     250    ;; Just ignore it, it's most likely a forward reference, and while it
     251    ;; means we might be missing out on a possible optimization, most of
     252    ;; the time it's not worth warning about.
     253    't))
     254
    240255;;;Used by nx-transform, setf, and whatever...
    241 (defun defstruct-ref-transform (predicate-or-type-and-refinfo args &optional env)
    242   (if (type-and-refinfo-p predicate-or-type-and-refinfo)
    243     (multiple-value-bind (type refinfo)
    244                          (if (consp predicate-or-type-and-refinfo)
    245                            (values (%car predicate-or-type-and-refinfo)
    246                                    (%cdr predicate-or-type-and-refinfo))
    247                            (values 't predicate-or-type-and-refinfo))
    248       (let* ((offset (refinfo-offset refinfo))
    249              (ref (refinfo-reftype refinfo))
    250              (accessor
    251               (cond ((eq ref $defstruct-nth)
    252                      `(nth ,offset ,@args))
    253                     ((eq ref $defstruct-struct)
    254                      `(struct-ref ,@args ,offset))
    255                     ((eq ref target::subtag-simple-vector)
    256                      `(svref ,@args ,offset))
    257                     (ref
    258                      `(aref (the (simple-array ,(element-subtype-type ref) (*))
    259                                  ,@args) ,offset))
    260                     (t `(uvref ,@args ,offset)))))
    261         (if (eq type 't)
    262           accessor
    263           (if (specifier-type-if-known type env)
    264             `(the ,type ,accessor)
    265             (if (nx-declarations-typecheck env)
    266               `(require-type ,accessor ',type)
    267               ;; Otherwise just ignore the type, it's most likely a forward reference,
    268               ;; and while it means we might be missing out on a possible optimization,
    269               ;; most of the time it's not worth warning about.
    270               accessor)))))
    271     `(structure-typep ,@args ',predicate-or-type-and-refinfo)))
     256(defun defstruct-ref-transform (structref-info args env &optional no-type-p)
     257  (if (accessor-structref-info-p structref-info)
     258    (let* ((type (if no-type-p
     259                   't
     260                   (defstruct-type-for-typecheck (structref-info-type structref-info) env)))
     261           (refinfo (structref-info-refinfo structref-info))
     262           (offset (refinfo-offset refinfo))
     263           (ref (refinfo-reftype refinfo))
     264           (accessor
     265            (cond ((eq ref $defstruct-nth)
     266                   `(nth ,offset ,@args))
     267                  ((eq ref $defstruct-struct)
     268                   `(struct-ref (typecheck ,@args ,(structref-info-struct structref-info)) ,offset))
     269                  ((eq ref target::subtag-simple-vector)
     270                   `(svref ,@args ,offset))
     271                  (ref
     272                   `(aref (the (simple-array ,(element-subtype-type ref) (*))
     273                               ,@args) ,offset))
     274                  (t `(uvref ,@args ,offset)))))
     275      (if (eq type 't)
     276        accessor
     277        `(the ,type ,accessor)))
     278    `(structure-typep ,@args ',structref-info)))
    272279
    273280;;; Should probably remove the constructor, copier, and predicate as
     
    292299    (when sd
    293300      (dolist (refname (sd-refnames sd))
    294         (remhash refname %structure-refs%)
    295301        (let ((def (assq refname *nx-globally-inline*)))
    296302          (when def (set-function-info refname nil)))
    297         (when (symbolp refname)(fmakunbound refname)))
     303        (let ((info (structref-info refname)))
     304          (when (accessor-structref-info-p info)
     305            (unless (refinfo-r/o (structref-info-refinfo info))
     306              (fmakunbound (setf-function-name refname)))
     307            (fmakunbound refname))))
    298308      #|
    299309      ;; The print-function may indeed have become obsolete,
  • branches/qres/ccl/lib/foreign-types.lisp

    r13070 r14259  
    13671367  (etypecase type
    13681368    ((or foreign-pointer-type foreign-array-type)
    1369      (let* ((to (foreign-pointer-type-to type))
     1369     (let* ((to (if (foreign-array-type-p type)
     1370                  (foreign-array-type-element-type type)
     1371                  (foreign-pointer-type-to type)))
    13701372            (size (foreign-type-bits to))
    13711373            (bit-offset `(the fixnum (* ,size (the fixnum ,index-form)))))
  • branches/qres/ccl/lib/macros.lisp

    r14056 r14259  
    590590                                         ,setter)))
    591591                                 (push (list (car d) (car v)) let-list)))))
    592                           ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env)
    593                                                                    (and #-bccl (boundp '%structure-refs%)
    594                                                                         (gethash accessor %structure-refs%)))))
    595                                 (not (refinfo-r/o (if (consp temp) (%cdr temp) temp))))
    596                            (if (consp temp)
    597                              ;; strip off type, but add in a require-type
    598                              (let ((type (%car temp)))
    599                                `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args) env)
    600                                             (require-type ,value ',type))))
    601                              `(setf ,(defstruct-ref-transform temp (%cdar args) env)
    602                                ,value)))
     592                          ((and (setq temp (structref-info accessor env))
     593                                (accessor-structref-info-p temp)
     594                                (not (refinfo-r/o (structref-info-refinfo temp))))
     595                           (let ((form (defstruct-ref-transform temp (%cdar args) env t))
     596                                 (type (defstruct-type-for-typecheck (structref-info-type temp) env)))
     597                             (if (eq type t)
     598                               `(setf ,form ,value)
     599                               ;; strip off type, but add in a typecheck
     600                               `(the ,type (setf ,form (typecheck ,value ,type))))))
    603601                          (t
    604602                           (multiple-value-bind (res win)
     
    28202818       (setf ,place (%check-type ,val ',typespec ',place ,string))))))
    28212819
    2822 
     2820(defmacro typecheck (object typespec &environment env)
     2821  (cond ((eq typespec 't)
     2822         object)
     2823        ((nx-inhibit-safety-checking env)
     2824         `(the ,typespec ,object))
     2825        (t
     2826         `(require-type ,object ',(nx1-typespec-for-typep typespec env)))))
    28232827
    28242828
     
    33043308  (if (consp place)
    33053309    (let* ((sym (car place))
    3306            (struct-transform (or (environment-structref-info sym env)
    3307                                  (gethash sym %structure-refs%))))
     3310           (struct-transform (structref-info sym env)))
    33083311      (if struct-transform
    33093312        (setq place (defstruct-ref-transform struct-transform (cdr place) env)
     
    35483551      (signal-program-error "~s is not a special variable ." place))
    35493552    (let* ((sym (car place))
    3550            (struct-transform (or (ccl::environment-structref-info sym env)
    3551                                  (gethash sym ccl::%structure-refs%))))
     3553           (struct-transform (structref-info sym env)))
    35523554      (if struct-transform
    35533555        (setq place (defstruct-ref-transform struct-transform (cdr place) env)
  • branches/qres/ccl/lib/nfcomp.lisp

    r14164 r14259  
    938938
    939939(defun define-compile-time-structure (sd refnames predicate env)
    940   (let ((defenv (definition-environment env)))
     940  (let ((defenv (definition-environment env))
     941        (class-name (and (not (sd-type sd)) (symbolp (sd-name sd)) (sd-name sd))))
    941942    (when defenv
    942       (when (and (non-nil-symbolp (sd-name sd))
    943                  (not (sd-type sd)))
    944         (note-type-info (sd-name sd) 'class env)
    945         (push (make-instance 'compile-time-class :name (sd-name sd))
     943      (when class-name
     944        (note-type-info class-name 'class env)
     945        (push (make-instance 'compile-time-class :name class-name)
    946946              (defenv.classes defenv)))
    947947      (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv)))
    948948      (let* ((structrefs (defenv.structrefs defenv)))
    949         (when (and (null (sd-type sd))
    950                    predicate)
    951           (setq structrefs (alist-adjoin predicate (sd-name sd) structrefs)))
     949        (when (and predicate class-name)
     950          (setq structrefs (alist-adjoin predicate class-name structrefs)))
    952951        (dolist (slot (sd-slots sd))
    953952          (unless (fixnump (ssd-name slot))
    954953            (setq structrefs
    955954                (alist-adjoin (if refnames (pop refnames) (ssd-name slot))
    956                               (ssd-type-and-refinfo slot)
     955                              (cons (ssd-type-and-refinfo slot) class-name)
    957956                              structrefs))))
    958957        (setf (defenv.structrefs defenv) structrefs)))))
  • branches/qres/ccl/lib/setf.lisp

    r13140 r14259  
    3131(defun store-setf-method (name fn &optional doc)
    3232  (puthash name %setf-methods% fn)
    33   (let ((type-and-refinfo (and #-bccl (boundp '%structure-refs%)
    34                                (gethash name %structure-refs%))))
    35     (typecase type-and-refinfo
    36       (fixnum
    37        (puthash name %structure-refs% (%ilogior2 (%ilsl $struct-r/o 1)
    38                                                  type-and-refinfo)))
    39       (cons
    40        (setf (%cdr type-and-refinfo) (%ilogior2 (%ilsl $struct-r/o 1)
    41                                                 (%cdr type-and-refinfo))))
    42       (otherwise nil)))
     33  (when (structref-info name)
     34    (structref-set-r/o name))
    4335  (set-documentation name 'setf doc) ;clears it if doc = nil.
    4436  name)
     
    10395                  (signal-program-error "Multiple store variables not expected in setf expansion of ~S" form))
    10496                (values temps values storevars storeform accessform))))
    105            ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor environment)
    106                                                     (and #-bccl (boundp '%structure-refs%)
    107                                                          (gethash accessor %structure-refs%)))))
    108                  (not (refinfo-r/o (if (consp temp) (%cdr temp) temp))))
    109             (if (consp temp)
    110               (let ((type (%car temp)))
    111                 (multiple-value-bind
    112                   (temps values storevars storeform accessform)
    113                   (get-setf-method (defstruct-ref-transform (%cdr temp) (%cdr form) environment) environment)
     97           ((and (setq temp (structref-info accessor environment))
     98                 (accessor-structref-info-p temp)
     99                 (not (refinfo-r/o (structref-info-refinfo temp))))
     100            (let ((form (defstruct-ref-transform temp (%cdr form) environment t))
     101                  (type (defstruct-type-for-typecheck (structref-info-type temp) environment)))
     102              (if (eq type 't)
     103                (get-setf-method form environment)
     104                (multiple-value-bind (temps values storevars storeform accessform)
     105                                     (get-setf-method form environment)
    114106                  (values temps values storevars
    115107                          (let ((storevar (first storevars)))
    116108                            `(the ,type
    117                                   (let ((,storevar (require-type ,storevar ',type)))
     109                                  (let ((,storevar (typecheck ,storevar ,type)))
    118110                                    ,storeform)))
    119                           `(the ,type ,accessform))))
    120               (get-setf-method (defstruct-ref-transform temp (%cdr form) environment) environment)))
     111                          `(the ,type ,accessform))))))
    121112           (t
    122113            (multiple-value-bind (res win)
Note: See TracChangeset for help on using the changeset viewer.