Avoid some exceptions in WAIT-UNTIL-FD-USABLE on Windows
[sbcl.git] / 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           ;; ANSI 5.1.2.3 explains this logic quite precisely.  --
89           ;; CSR, 2004-06-29
90           (setq all-dummies (append all-dummies dummies (cdr newval))
91                 all-vals (append all-vals vals
92                                  (mapcar (constantly nil) (cdr newval)))
93                 newvals (append newvals (list (car newval))))
94           (setters setter)
95           (getters getter)))
96       (values all-dummies all-vals newvals
97               `(values ,@(setters)) `(values ,@(getters))))))