Changeset 11285


Ignore:
Timestamp:
Nov 2, 2008, 2:01:17 AM (11 years ago)
Author:
gb
Message:

(SETF (THE TYPE PLACE) VALUE) => (SETF PLACE (THE TYPE VALUE)).

Whether the SETF expander on THE needs to exist or not probably has
to do with whether or not INCF, DECF, and things defined with
DEFINE-MODIFY-MACRO need it to. If it does "need to", it should
probably be fixed.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/macros.lisp

    r11207 r11285  
    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.