1;;; Written by Eli Barzilay: Maze is Life!  (eli@barzilay.org)
2
3;;> This module provides the forms `setf!', `psetf!', and `setf!-values' for
4;;> generic setters, much like CL's `setf', and `psetf', and a form similar
5;;> to Racket's `set!-values'.  Note that when these are later re-exported
6;;> (by `turbo'), they are renamed as `set!', `pset!', and `set!-values'
7;;> (overriding the built-in `set!' and `set!-values').  Also, note that
8;;> this just defines the basic functionality, the `misc' module defines
9;;> many common setters.
10
11#lang mzscheme
12
13;;>> (setf! place value ...)
14;;>   Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'.  The generated
15;;>   `set-foo!' identifier has the same syntax context as `foo', which
16;;>   means that to use this for some `foo' you need to define `set-foo!'
17;;>   either as a function or a syntax in the same definition context of
18;;>   `foo'.  The nice feature that comes out of this and the syntax system
19;;>   is that examples like the following work as expected:
20;;>     (let ([foo mcar] [set-foo! set-mcar!]) (setf! (foo a) 11))
21;;>
22;;>   `place' gets expanded before this processing is done so macros work
23;;>   properly.  If the place is not a form, then this will just use the
24;;>   standard `set!'.
25;;>
26;;>   Another extension of the original `set!' is that it allows changing
27;;>   several places in sequence -- `(setf! x a y b)' will set `x' to `a'
28;;>   and then set `y' to `b'.
29;; Original idea thanks to Eric Kidd who stole it from Dylan
30(provide setf!)
31(define-syntax (setf! stx)
32  (define (set!-prefix id)
33    (datum->syntax-object
34     id
35     (string->symbol (string-append "set-" (symbol->string (syntax-e id)) "!"))
36     id id))
37  (syntax-case stx (setf!)
38    ;; if the getter is a set!-transformer, make it do its thing
39    [(setf! getter . xs)
40     (and (identifier? #'getter)
41          (set!-transformer? (syntax-local-value #'getter (lambda () #f))))
42     ((set!-transformer-procedure (syntax-local-value #'getter)) stx)]
43    [(setf! place val)
44     ;; need to expand place first, in case it is itself a macro
45     (with-syntax ([place (local-expand
46                           #'place 'expression
47                           (append (list #'#%app #'#%top #'#%datum)
48                                   (map (lambda (s)
49                                          (datum->syntax-object #'place s #f))
50                                        '(#%app #%top #%datum))))])
51       (syntax-case #'place ()
52         [(getter args ...)
53          (if (identifier? #'getter)
54            (with-syntax ([setter (set!-prefix #'getter)])
55              (syntax/loc stx (setter args ... val)))
56            (raise-syntax-error #f "not an identifier" stx #'getter))]
57         [_ (syntax/loc stx (set! place val))]))]
58    [(setf! place val . more)
59     (let loop ([pvs #'(place val . more)] [r '()])
60       (syntax-case pvs ()
61         [(p v . more)
62          (loop #'more (cons (syntax/loc stx (setf! p v)) r))]
63         [() (quasisyntax/loc stx (begin #,@(reverse r)))]
64         [_ (raise-syntax-error #f "uneven number of forms" stx)]))]))
65
66;;>> (psetf! place value ...)
67;;>   This is very similar to `setf!' above, except that the change to the
68;;>   places is done *simultaneously*.  For example, `(setf! x y y x)'
69;;>   switches the values of the two variables.
70;; This could have been expressed using `setf!-values', but that would lead to
71;; an unnecessary creation of a values tuple.
72(provide psetf!)
73(define-syntax (psetf! stx)
74  (syntax-case stx ()
75    ;; optimize common case
76    [(_ place val) (syntax/loc stx (setf! place val))]
77    [(_ more ...)
78     (let loop ([vars '()] [vals '()] [more (syntax->list #'(more ...))])
79       (cond
80        [(null? more)
81         (let ([vars (reverse vars)]
82               [vals (reverse vals)]
83               [tmps (generate-temporaries (map (lambda (x) 'x) vars))])
84           (quasisyntax/loc stx
85             (let #,(map (lambda (t v) #`(#,t #,v)) tmps vals)
86               #,@(map (lambda (v t) #`(setf! #,v #,t)) vars tmps))))]
87        [(null? (cdr more))
88         (raise-syntax-error #f "uneven number of forms" stx)]
89        [else (loop (cons (car more) vars) (cons (cadr more) vals)
90                    (cddr more))]))]))
91
92;;>> (setf!-values (place ...) expr)
93;;>   This is a version of `setf!', that works with multiple values.  `expr'
94;;>   is expected to evaluate to the correct number of values, and these are
95;;>   then put into the specified places which can be an place suited to
96;;>   `setf!'.  Note that no duplication of identifiers is checked, if an
97;;>   identifier appears more than once then it will have the last assigned
98;;>   value.
99(provide setf!-values)
100(define-syntax (setf!-values stx)
101  (syntax-case stx ()
102    ;; optimize common case
103    [(_ (place) val) (syntax/loc stx (setf! place val))]
104    [(_ (place ...) values)
105     (with-syntax ([(temp ...) (datum->syntax-object
106                                #'(place ...)
107                                (generate-temporaries #'(place ...))
108                                #'(place ...))])
109       (syntax/loc stx
110         (let-values ([(temp ...) values])
111           (setf! place temp) ...)))]))
112
113;;>> (set-values! places ... values-expr)
114;;>> (set-list! places ... list-expr)
115;;>> (set-vector! places ... vector-expr)
116;;>   These are defined as special forms that use `setf!-values' to set the
117;;>   given places to the appropriate components of the third form.  This
118;;>   allows foing the following:
119;;>     => (define (values a b c) (values 1 2 3))
120;;>     => (setf! (values a b c) (values 11 22 33))
121;;>     => (list a b c)
122;;>     (11 22 33)
123;;>     => (setf! (list a b c) (list 111 222 333))
124;;>     => (list a b c)
125;;>     (111 222 333)
126;;>     => (setf! (list a b c) (list 1111 2222 3333))
127;;>     => (list a b c)
128;;>     (1111 2222 3333)
129;;>   Furthermore, since the individual setting of each place is eventually
130;;>   done with `setf!', then this can be used recursively:
131;;>     => (set! (list a (vector b) (vector c c)) '(2 #(3) #(4 5)))
132;;>     => (list a b c)
133;;>     (2 3 5)
134(provide set-values! set-list! set-vector!)
135(define-syntaxes (set-values! set-list! set-vector!)
136  (let ([make-setter
137         (lambda (convert)
138           (lambda (stx)
139             (syntax-case stx ()
140               [(_ x y ...)
141                (let loop ([args (syntax->list #'(x y ...))] [as '()])
142                  (if (null? (cdr args))
143                    (quasisyntax/loc stx
144                      (setf!-values #,(datum->syntax-object
145                                       #'(x y ...) (reverse as) #'(x y ...))
146                                    #,(convert (car args))))
147                    (loop (cdr args) (cons (car args) as))))])))])
148    (values
149     ;; set-values!
150     (make-setter (lambda (x) x))
151     ;; set-list!
152     (make-setter (lambda (x) #`(apply values #,x)))
153     ;; set-vector!
154     (make-setter (lambda (x) #`(apply values (vector->list #,x)))))))
155
156(provide shift! rotate! inc! dec! push! pop!)
157(define-syntaxes (shift! rotate! inc! dec! push! pop!)
158  (let* ([protect-indexes
159          (lambda (place body)
160            (syntax-case place ()
161              [(getter . xs)
162               (let ([bindings+expr
163                      (let loop ([xs #'xs]
164                                 [bindings '()]
165                                 [expr (list #'getter)]
166                                 [all-ids? #t])
167                        (syntax-case xs ()
168                          [() (and (not all-ids?)
169                                   (cons (reverse bindings) (reverse expr)))]
170                          [(x . xs)
171                           (let ([new (datum->syntax-object
172                                       #'x (gensym) #'x)])
173                             (loop #'xs
174                                   (cons (list new #'x) bindings)
175                                   (cons new expr)
176                                   (and (identifier? #'x) all-ids?)))]
177                          [x (and (not (and all-ids? (identifier? #'x)))
178                                  (let ([new (datum->syntax-object
179                                              #'x (gensym) #'x)])
180                                    (cons (reverse (cons (list new #'x)
181                                                          bindings))
182                                          (append (reverse expr) new))))]))])
183                 (if bindings+expr
184                   #`(let #,(car bindings+expr) #,(body (cdr bindings+expr)))
185                   (body place)))]
186              [_ (body place)]))]
187         [protect-indexes-list
188          (lambda (places body)
189            (let loop ([ps places] [r '()])
190              (if (null? ps)
191                (body (reverse r))
192                (protect-indexes (car ps) (lambda (p)
193                                            (loop (cdr ps) (cons p r)))))))])
194    (values
195;;>> (shift! place ... newvalue)
196;;>   This is similar to CL's `shiftf' -- it is roughly equivalent to
197;;>     (begin0 place1
198;;>             (psetf! place1 place2
199;;>                     place2 place3
200;;>                     ...
201;;>                     placen newvalue))
202;;>   except that it avoids evaluating index subforms twice, for example:
203;;>     => (let ([foo (lambda (x) (printf ">>> ~s\n" x) x)]
204;;>              [a '(1)] [b '(2)])
205;;>          (list (shift! (car (foo a)) (car (foo b)) 3) a b))
206;;>     >>> (1)
207;;>     >>> (2)
208;;>     (1 (2) (3))
209     ;; --- shift!
210     (lambda (stx)
211       (syntax-case stx ()
212         [(_ x y more ...)
213          (protect-indexes-list (syntax->list #'(x y more ...))
214            (lambda (vars)
215              (let loop ([vs vars] [r '()])
216                (if (null? (cdr vs))
217                  (quasisyntax/loc stx
218                    (let ([v #,(car vars)])
219                      (psetf! #,@(datum->syntax-object
220                                  #'(x y more ...)
221                                  (reverse r)
222                                  #'(x y more ...)))
223                      v))
224                  (loop (cdr vs) (list* (cadr vs) (car vs) r))))))]))
225;;>> (rotate! place ...)
226;;>   This is similar to CL's `rotatef' -- it is roughly equivalent to
227;;>     (psetf! place1 place2
228;;>             place2 place3
229;;>             ...
230;;>             placen place1)
231;;>   except that it avoids evaluating index subforms twice.
232     ;; --- rotate!
233     (lambda (stx)
234       (syntax-case stx ()
235         [(_ x) #'(void)]
236         [(_ x xs ...)
237          (protect-indexes-list (syntax->list #'(x xs ...))
238            (lambda (vars)
239              (let loop ([vs vars] [r '()])
240                (if (null? (cdr vs))
241                  (quasisyntax/loc stx
242                    (psetf! #,@(datum->syntax-object
243                                #'(x xs ...)
244                                (reverse (list* (car vars) (car vs) r))
245                                #'(x xs ...))))
246                  (loop (cdr vs) (list* (cadr vs) (car vs) r))))))]))
247;;>> (inc! place [delta])
248;;>> (dec! place [delta])
249;;>> (push! x place)
250;;>> (pop! place)
251;;>   These are some simple usages of `setf!'.  Note that they also avoid
252;;>   evaluating any indexes twice.
253     ;; --- inc!
254     (lambda (stx)
255       (syntax-case stx ()
256         [(_ p) #'(_ p 1)]
257         [(_ p d) (protect-indexes #'p
258                    (lambda (p) #`(setf! #,p (+ #,p d))))]))
259     ;; --- dec!
260     (lambda (stx)
261       (syntax-case stx ()
262         [(_ p) #'(_ p 1)]
263         [(_ p d) (protect-indexes #'p
264                    (lambda (p) #`(setf! #,p (- #,p d))))]))
265     ;; --- push!
266     (lambda (stx)
267       (syntax-case stx ()
268         [(_ x p) (protect-indexes #'p
269                    (lambda (p) #`(setf! #,p (cons x #,p))))]))
270     ;; --- pop!
271     (lambda (stx)
272       (syntax-case stx ()
273         [(_ p) (protect-indexes #'p
274                  (lambda (p)
275                    #`(let ([p1 #,p])
276                        (begin0 (car p1) (setf! #,p (cdr p1))))))])))))
277