src/code/late-setf.lisp

   1 ;;;; SETF-related stuff which requires COLLECT, separated into this
   2 ;;;; separate file to deal with boot order problems (since COLLECT
   3 ;;;; requires other SETF-related stuff)
   4 ;;;;
   5 ;;;; FIXME: Now that we don't do bogobootstrapping, these boot order
   6 ;;;; problems may no longer exist, so perhaps we could merge back with
   7 ;;;; other SETF logic.
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11 ;;;;
  12 ;;;; This software is derived from the CMU CL system, which was
  13 ;;;; written at Carnegie Mellon University and released into the
  14 ;;;; public domain. The software is in the public domain and is
  15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  16 ;;;; files for more information.
  17
  18 (in-package "SB!IMPL")
  19
  20 (file-comment
  21   "$Header$")
  22
  23 (defmacro-mundanely psetf (&rest args &environment env)
  24   #!+sb-doc
  25   "This is to SETF as PSETQ is to SETQ. Args are alternating place
  26   expressions and values to go into those places. All of the subforms and
  27   values are determined, left to right, and only then are the locations
  28   updated. Returns NIL."
  29   (declare (type sb!c::lexenv env))
  30   (collect ((let*-bindings) (mv-bindings) (setters))
  31     (do ((a args (cddr a)))
  32         ((endp a))
  33       (if (endp (cdr a))
  34           (error "Odd number of args to PSETF."))
  35       (multiple-value-bind (dummies vals newval setter getter)
  36           (sb!xc:get-setf-expansion (car a) env)
  37         (declare (ignore getter))
  38         (let*-bindings (mapcar #'list dummies vals))
  39         (mv-bindings (list newval (cadr a)))
  40         (setters setter)))
  41     (labels ((thunk (let*-bindings mv-bindings)
  42                (if let*-bindings
  43                    `(let* ,(car let*-bindings)
  44                       (multiple-value-bind ,@(car mv-bindings)
  45                         ,(thunk (cdr let*-bindings) (cdr mv-bindings))))
  46                    `(progn ,@(setters) nil))))
  47       (thunk (let*-bindings) (mv-bindings)))))
  48
  49 ;;; FIXME: Compiling this definition of ROTATEF apparently blows away the
  50 ;;; definition in the cross-compiler itself, so that after that, any
  51 ;;; ROTATEF operations can no longer be compiled, because
  52 ;;; GET-SETF-EXPANSION is called instead of SB!XC:GET-SETF-EXPANSION.
  53 (defmacro-mundanely rotatef (&rest args &environment env)
  54   #!+sb-doc
  55   "Takes any number of SETF-style place expressions. Evaluates all of the
  56    expressions in turn, then assigns to each place the value of the form to
  57    its right. The rightmost form gets the value of the leftmost.
  58    Returns NIL."
  59   (declare (type sb!c::lexenv env))
  60   (when args
  61     (collect ((let*-bindings) (mv-bindings) (setters) (getters))
  62       (dolist (arg args)
  63         (multiple-value-bind (temps subforms store-vars setter getter)
  64             (sb!xc:get-setf-expansion arg env)
  65           (loop
  66             for temp in temps
  67             for subform in subforms
  68             do (let*-bindings `(,temp ,subform)))
  69           (mv-bindings store-vars)
  70           (setters setter)
  71           (getters getter)))
  72       (setters nil)
  73       (getters (car (getters)))
  74       (labels ((thunk (mv-bindings getters)
  75                  (if mv-bindings
  76                      `((multiple-value-bind ,(car mv-bindings) ,(car getters)
  77                          ,@(thunk (cdr mv-bindings) (cdr getters))))
  78                      (setters))))
  79         `(let* ,(let*-bindings)
  80            ,@(thunk (mv-bindings) (cdr (getters))))))))
  81
  82 (sb!xc:define-setf-expander values (&rest places &environment env)
  83   (declare (type sb!c::lexenv env))
  84   (collect ((setters) (getters))
  85     (let ((all-dummies '())
  86           (all-vals '())
  87           (newvals '()))
  88       (dolist (place places)
  89         (multiple-value-bind (dummies vals newval setter getter)
  90             (sb!xc:get-setf-expansion place env)
  91           (setq all-dummies (append all-dummies dummies)
  92                 all-vals (append all-vals vals)
  93                 newvals (append newvals newval))
  94           (setters setter)
  95           (getters getter)))
  96       (values all-dummies all-vals newvals
  97               `(values ,@(setters)) `(values ,@(getters))))))