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 (defmacro-mundanely psetf (&rest args &environment env)
  21   #!+sb-doc
  22   "This is to SETF as PSETQ is to SETQ. Args are alternating place
  23   expressions and values to go into those places. All of the subforms and
  24   values are determined, left to right, and only then are the locations
  25   updated. Returns NIL."
  26   (declare (type sb!c::lexenv env))
  27   (collect ((let*-bindings) (mv-bindings) (setters))
  28     (do ((a args (cddr a)))
  29         ((endp a))
  30       (if (endp (cdr a))
  31           (error "Odd number of args to PSETF."))
  32       (multiple-value-bind (dummies vals newval setter getter)
  33           (sb!xc:get-setf-expansion (car a) env)
  34         (declare (ignore getter))
  35         (let*-bindings (mapcar #'list dummies vals))
  36         (mv-bindings (list newval (cadr a)))
  37         (setters setter)))
  38     (labels ((thunk (let*-bindings mv-bindings)
  39                (if let*-bindings
  40                    `(let* ,(car let*-bindings)
  41                       (multiple-value-bind ,@(car mv-bindings)
  42                         ,(thunk (cdr let*-bindings) (cdr mv-bindings))))
  43                    `(progn ,@(setters) nil))))
  44       (thunk (let*-bindings) (mv-bindings)))))
  45
  46 ;;; FIXME: Compiling this definition of ROTATEF apparently blows away the
  47 ;;; definition in the cross-compiler itself, so that after that, any
  48 ;;; ROTATEF operations can no longer be compiled, because
  49 ;;; GET-SETF-EXPANSION is called instead of SB!XC:GET-SETF-EXPANSION.
  50 (defmacro-mundanely rotatef (&rest args &environment env)
  51   #!+sb-doc
  52   "Takes any number of SETF-style place expressions. Evaluates all of the
  53    expressions in turn, then assigns to each place the value of the form to
  54    its right. The rightmost form gets the value of the leftmost.
  55    Returns NIL."
  56   (declare (type sb!c::lexenv env))
  57   (when args
  58     (collect ((let*-bindings) (mv-bindings) (setters) (getters))
  59       (dolist (arg args)
  60         (multiple-value-bind (temps subforms store-vars setter getter)
  61             (sb!xc:get-setf-expansion arg env)
  62           (loop
  63             for temp in temps
  64             for subform in subforms
  65             do (let*-bindings `(,temp ,subform)))
  66           (mv-bindings store-vars)
  67           (setters setter)
  68           (getters getter)))
  69       (setters nil)
  70       (getters (car (getters)))
  71       (labels ((thunk (mv-bindings getters)
  72                  (if mv-bindings
  73                      `((multiple-value-bind ,(car mv-bindings) ,(car getters)
  74                          ,@(thunk (cdr mv-bindings) (cdr getters))))
  75                      (setters))))
  76         `(let* ,(let*-bindings)
  77            ,@(thunk (mv-bindings) (cdr (getters))))))))
  78
  79 (sb!xc:define-setf-expander values (&rest places &environment env)
  80   (declare (type sb!c::lexenv env))
  81   (collect ((setters) (getters))
  82     (let ((all-dummies '())
  83           (all-vals '())
  84           (newvals '()))
  85       (dolist (place places)
  86         (multiple-value-bind (dummies vals newval setter getter)
  87             (sb!xc:get-setf-expansion place env)
  88           (setq all-dummies (append all-dummies dummies)
  89                 all-vals (append all-vals vals)
  90                 newvals (append newvals newval))
  91           (setters setter)
  92           (getters getter)))
  93       (values all-dummies all-vals newvals
  94               `(values ,@(setters)) `(values ,@(getters))))))