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:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • 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.