(with-vectors (a b c) (a <- (+ b c))) (with-vectors (a b c) (<- (+ a b c))) (with-vectors (a b c) (a <- (+ b 2)) (print "I can insert statements, too.") (c <- (+ a b)))

The second form above returns a fresh vector whose elements are the sums of the corresponding elements in a b and c. The length of the new vector is the same as the length of a. In all cases, the number of iterations of the body is the length of a (this isn't quite the right thing to do---that would be to make the number of iterations be the minimum of the lengths of a b and c or to throw an exception if a b and c are not the same length). The macro follows:

(define-expander with-vectors (lambda (x e) (match-case x ((with-vectors ?vecs (<- . ?body)) (with-gensyms (result n i) (e `(let* ((,n (vector-length ,(car vecs))) (,result (make-vector ,n))) (do-times (,i ,n) (let ,(map (lambda (sym) `(,sym (vector-ref ,sym ,i))) vecs) (vector-set! ,result ,i (begin ,@body)))) ,result) e))) ((with-vectors ?vecs . ?body) (with-gensyms (i n) (let* ((vector-syms (map (lambda (sym) (cons sym (gensym))) vecs)) (process-body-term (lambda (term) (match-case term ((?result <- . ?body) `(vector-set! ,(cdr (assoc result vector-syms)) ,i (begin ,@body))) (?- term))))) (e `(let ((,n (vector-length ,(car vecs)))) (let ,(map (lambda (sym) `(,(cdr (assoc sym vector-syms)) ,sym)) vecs) (do-times (,i ,n) (let ,(map (lambda (sym) `(,sym (vector-ref ,sym ,i))) vecs) ,@(map process-body-term body))))) e)))))))It requires a completely obvious (I hope) do-times macro, and also with-gensyms (a lisp favorite):

(define-expander do-times (lambda (x e) (match-case x ((do-times (?i ?n) . ?body) (with-gensyms (nn nn-1) (e `(let ((,nn ,n)) (let ((,nn-1 (-fx ,nn 1))) (do ((,i 0 (+fx ,i 1))) ((=fx ,i ,nn-1) ,@body) ,@body))) e)))))) (define-expander with-gensyms (lambda (x e) (match-case x ((with-gensyms (?sym) . ?body) (e `(let ((,sym (gensym))) ,@body) e)) ((with-gensyms (?sym . ?rest-syms) . ?body) (e `(let ((,sym (gensym))) (with-gensyms ,rest-syms ,@body)) e)))))Nifty, huh? I also have one for my f64vectors (as described in my last post one can make vectors of doubles---the natural behavior from bigloo approximates SRFI 4):

(define-expander with-f64vectors (lambda (x e) (match-case x ((with-f64vectors ?vecs (<- . ?body)) (with-gensyms (result n i) (e `(let* ((,n (f64vector-length ,(car vecs))) (,result (make-f64vector ,n 0.0))) (do-times (,i ,n) (let ,(map (lambda (sym) `(,sym (f64vector-ref ,sym ,i))) vecs) (f64vector-set! ,result ,i (begin ,@body)))) ,result) e))) ((with-f64vectors ?vecs . ?body) (with-gensyms (i n) (let* ((vector-syms (map (lambda (sym) (cons sym (gensym))) vecs)) (process-body-term (lambda (term) (match-case term ((?result <- . ?body) `(f64vector-set! ,(cdr (assoc result vector-syms)) ,i (begin ,@body))) (?- term))))) (e `(let ((,n (f64vector-length ,(car vecs)))) (let ,(map (lambda (sym) `(,(cdr (assoc sym vector-syms)) ,sym)) vecs) (do-times (,i ,n) (let ,(map (lambda (sym) `(,sym (f64vector-ref ,sym ,i))) vecs) ,@(map process-body-term body))))) e)))))))

## No comments:

Post a Comment