Making Scheme behave like Fortran 95

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)))))))