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