I just coded up a macro which makes
Bigloo scheme behave more like Fortran 95 with respect to vectors. Usage:
(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)))))))
