Changeset 11415


Ignore:
Timestamp:
Nov 19, 2008, 4:16:57 PM (11 years ago)
Author:
gz
Message:

SETF THE fix from trunk (r11285)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/macros.lisp

    r11279 r11415  
    518518                  (value (cadr args)))
    519519             ;This must match get-setf-method .
    520              (if (atom form)
    521                (progn
    522                  (unless (symbolp form)(signal-program-error $XNotSym form))
    523                  `(setq ,form ,value))
    524                (multiple-value-bind (ftype local-p)
    525                                     (function-information (setq accessor (car form)) ENV)
    526                  (if local-p
    527                    (if (eq ftype :function)
    528                      ;Local function, so don't use global setf definitions.
    529                      (default-setf form value env)
    530                      `(setf ,(macroexpand-1 form env) ,value))
    531                    (cond
    532                     ((setq temp (%setf-method accessor))
    533                      (if (symbolp temp)
    534                        `(,temp ,@(cdar args) ,value)
    535                        (multiple-value-bind (dummies vals storevars setter #|getter|#)
    536                                             (funcall temp form env)
    537                          (do* ((d dummies (cdr d))
    538                                (v vals (cdr v))
    539                                (let-list nil))
    540                               ((null d)
    541                                (setq let-list (nreverse let-list))
    542                                `(let* ,let-list
    543                                   (declare (ignorable ,@dummies))
    544                                   (multiple-value-bind ,storevars ,value
    545                                     #|,getter|#
    546                                     ,setter)))
    547                            (push (list (car d) (car v)) let-list)))))
    548                     ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env)
    549                                                              (and #-bccl (boundp '%structure-refs%)
    550                                                                   (gethash accessor %structure-refs%)))))
    551                           (not (refinfo-r/o (if (consp temp) (%cdr temp) temp))))
    552                      (if (consp temp)
    553                        ;; strip off type, but add in a require-type
    554                        (let ((type (%car temp)))
    555                          `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args))
    556                                            (require-type ,value ',type))))
    557                        `(setf ,(defstruct-ref-transform temp (%cdar args))
    558                               ,value)))
    559                     (t
    560                      (multiple-value-bind (res win)
    561                                           (macroexpand-1 form env)
    562                        (if win
    563                          `(setf ,res ,value)
    564                          (default-setf form value env))))))))))
     520             (cond ((atom form)
     521                    (progn
     522                      (unless (symbolp form)(signal-program-error $XNotSym form))
     523                      `(setq ,form ,value)))
     524                   ((eq (car form) 'the)
     525                    (unless (eql (length form) 3)
     526                      (error "Bad THE place form in (SETF ~S ~S)" form value))
     527                    (destructuring-bind (type place) (cdr form)
     528                      `(setf ,place (the ,type ,value))))
     529                   (t
     530                    (multiple-value-bind (ftype local-p)
     531                        (function-information (setq accessor (car form)) ENV)
     532                      (if local-p
     533                        (if (eq ftype :function)
     534                                        ;Local function, so don't use global setf definitions.
     535                          (default-setf form value env)
     536                          `(setf ,(macroexpand-1 form env) ,value))
     537                        (cond
     538                          ((setq temp (%setf-method accessor))
     539                           (if (symbolp temp)
     540                             `(,temp ,@(cdar args) ,value)
     541                             (multiple-value-bind (dummies vals storevars setter #|getter|#)
     542                                 (funcall temp form env)
     543                               (do* ((d dummies (cdr d))
     544                                     (v vals (cdr v))
     545                                     (let-list nil))
     546                                    ((null d)
     547                                     (setq let-list (nreverse let-list))
     548                                     `(let* ,let-list
     549                                       (declare (ignorable ,@dummies))
     550                                       (multiple-value-bind ,storevars ,value
     551                                         #|,getter|#
     552                                         ,setter)))
     553                                 (push (list (car d) (car v)) let-list)))))
     554                          ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env)
     555                                                                   (and #-bccl (boundp '%structure-refs%)
     556                                                                        (gethash accessor %structure-refs%)))))
     557                                (not (refinfo-r/o (if (consp temp) (%cdr temp) temp))))
     558                           (if (consp temp)
     559                             ;; strip off type, but add in a require-type
     560                             (let ((type (%car temp)))
     561                               `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args))
     562                                            (require-type ,value ',type))))
     563                             `(setf ,(defstruct-ref-transform temp (%cdar args))
     564                               ,value)))
     565                          (t
     566                           (multiple-value-bind (res win)
     567                               (macroexpand-1 form env)
     568                             (if win
     569                               `(setf ,res ,value)
     570                               (default-setf form value env)))))))))))
    565571          ((oddp temp)
    566572           (signal-program-error "Odd number of args to SETF : ~s." args))
Note: See TracChangeset for help on using the changeset viewer.