for.rkt

#lang racket/gui

(require (for-syntax racket/match))
(require compatibility/defmacro)

(begin-for-syntax

  (define (displayf fmt . xs)
    (display (apply format fmt xs)))
  
  (define (trans-for name form [for? #t])
    (define (bad-form which) (error 'for "bad ~A form:~%~S" which (cons name form)))
    ;; all the followings need to be reversed after collection
    (define initialize '()) ; let*-values (...) ...
    (define condition '())  ; when (or ...) finally
    (define update '())     ; begin ...
    (define skip '())       ; if (or ...) main
    (define finally-do '())
    (define value= '())     ; this must contains only one value
    (define main '())
    (define (trans-with xs)
      (match xs (`(,id = ,v . ,xs) (set! initialize (cons (list `(,id) v) initialize))
                                   (trans-toplevel xs))
                (_ (bad-form "with"))))
    (define (trans-to-toplevel xs id [s 1] [update? #t])
      (define (build id s test to xs)
        (set! condition (cons `(,test ,id ,to) condition))
        (when update?
          (set! update (cons `(set! ,id (+ ,id ,s)) update)))
        (trans-toplevel xs))
      (when (and (number? s) (<= s 0))
        (error 'for "step should greater than 0:~%~A" form))
      (match xs
        (`(to ,to . ,xs) (build id s '> to xs))
        (`(below ,to . ,xs) (build id s '>= to xs))
        (`(downto ,to . ,xs) (build id s '< to xs))
        (`(above ,to . ,xs) (build id s '<= to xs))
        (_ (trans-toplevel xs))))
    (define (trans-for-as xs)
      (match xs
        (`(,id in ,s . ,xs) #:when (symbol? id)
         (let ((more? (gensym)) (get (gensym)) (done? (gensym)))
           (set! initialize (cons `((,more? ,get) (sequence-generate ,s)) initialize))
           (set! initialize (cons `((,id) (,get)) initialize))
           (set! initialize (cons `((,done?) #f) initialize))
           (set! condition (cons done? condition))
           (set! update (cons `(set! ,done? (not (,more?))) update))
           (set! update (cons `(set! ,id (when (,more?) (,get))) update)))
         (trans-toplevel xs))
        (`(,id iterate by ,f with ,v . ,xs) #:when (symbol? id)
         (set! initialize (cons `((,id) (,f ,v)) initialize))
         (set! update (cons `(set! ,id (,f ,id)) update))
         (trans-toplevel xs))
        (`(,id iterate as ,v . ,xs) #:when (symbol? id)
         (set! initialize (cons (list `(,id) v) initialize))
         (set! update (cons `(set! ,id ,v) update))
         (trans-toplevel xs))
        (`(,id = ,v then ,v* . ,xs) #:when (symbol? id)
         (set! initialize (cons (list `(,id) v) initialize))
         (set! update (cons `(set! ,id ,v*) update))
         (trans-to-toplevel xs id (void) #f))
        (`(,id = ,v step ,s . ,xs) #:when (symbol? id)
         (set! initialize (cons (list `(,id) v) initialize))
         (trans-to-toplevel xs id s))
        (`(,id = ,v . ,xs) #:when (symbol? id)
         (set! initialize (cons (list `(,id) v) initialize))
         (trans-to-toplevel xs id))
        (_ (bad-form "for/as"))))
    (define (trans-cond name desc)
      (λ (xs) (match xs (`(,x . ,xs) (set! condition (cons `(,desc ,x) condition))
                                     (trans-toplevel xs))
                        (_ (bad-form name)))))
    (define (trans-skip name desc)
      (λ (xs) (match xs (`(,x . ,xs) (set! skip (cons `(,desc ,x) skip))
                                     (trans-toplevel xs))
                        (_ (bad-form name)))))
    (define trans-while (trans-cond 'while 'not))
    (define trans-until (trans-cond 'until 'values))
    (define trans-when (trans-skip 'when 'not))
    (define trans-unless (trans-skip 'unless 'values))
    (define (trans-acc init build reverse? which)
      (λ (xs)
        (match xs
          (`(,x . ,xs)
           (let ((acc (gensym)))
             (set! initialize (cons (list `(,acc) init) initialize))
             (set! main (cons `(set! ,acc ,(build x acc)) main))
             (set! value= (cons (if reverse? `(reverse ,acc) acc) value=)))
           (trans-toplevel xs))
          (_ (bad-form which)))))
    (define trans-collect (trans-acc ''() (λ (x acc) `(cons ,x ,acc)) #t "collect"))
    (define trans-append (trans-acc ''() (λ (x acc) `(append ,acc ,x)) #f "append"))
    (define trans-count (trans-acc 0 (λ (x acc) `(add1 ,acc)) #f "add1"))
    (define trans-max (trans-acc -inf.0 (λ (x y) `(if (> ,x ,y) ,x ,y)) #f "max"))
    (define trans-min (trans-acc +inf.0 (λ (x y) `(if (< ,x ,y) ,x ,y)) #f "min"))
    (define trans-sum (trans-acc 0 (λ (x acc) `(+ ,x ,acc)) #f "sum"))
    (define (trans-reduce xs)
      (let ((tmp (gensym)))
        (match xs
          (`(firstly ,x then ,y by ,f)
           (set! initialize (cons `((,tmp) ,x) initialize))
           (set! main (cons `(set! ,tmp (,f ,tmp ,y)) main))
           (set! value= (cons tmp value=)))
          (`(,x by ,f)
           (let ((first-time? (gensym)))
             (set! initialize (cons `((,tmp) (void)) initialize))
             (set! initialize (cons `((,first-time?) #t) initialize))
             (set! main (cons `(cond (,first-time? (set! ,first-time? #f)
                                                   (set! ,tmp ,x))
                                     (else (set! ,tmp (,f ,tmp ,x))))
                              main))
             (trans-toplevel xs))))))
    (define (trans-finally xs)
      (match xs
        (`(= ,x . ,xs)
         (set! value= (cons x value=))
         (trans-toplevel xs))
        (`(do ,x . ,xs)
         (set! finally-do (cons x finally-do))
         (trans-toplevel xs))
        (_ (bad-form "finally"))))
    (define (trans-do xs)
      (match xs
        (`(,x . ,xs)
         (set! main (cons x main))
         (trans-do xs))
        ('() 'ok)))
    (define (trans-toplevel xs)
      (match xs
        (`(with . ,xs) (trans-with xs))
        (`(as  . ,xs) (trans-for-as xs))
        (`(while . ,xs) (trans-while xs))
        (`(until . ,xs) (trans-until xs))
        (`(when . ,xs) (trans-when xs))
        (`(unless . ,xs) (trans-unless xs))
        (`(collect . ,xs) (trans-collect xs))
        (`(append . ,xs) (trans-append xs))
        (`(count . ,xs) (trans-count xs))
        (`(max . ,xs) (trans-max xs))
        (`(min . ,xs) (trans-min xs))
        (`(sum . ,xs) (trans-sum xs))
        (`(reduce . ,xs) (trans-reduce xs))
        (`(finally . ,xs) (trans-finally xs))
        (`(do . ,xs) (trans-do xs))
        ('() 'ok)
        (_ (bad-form ""))))
    (if for? 
        (trans-for-as form)
        (trans-with form))
    (when (> (length value=) 1)
      (error "too many result form:~%~A" form))
    `(let*-values ,(reverse initialize)
       (do () ((or ,@(reverse condition))
               (begin ,@(reverse finally-do),@(reverse value=)))
         (unless (or ,@(reverse skip))
           ,@(reverse main))
         ,@(reverse update)))))

(define-macro (for . form)
  (trans-for 'for form #t))

(define-macro (with . form)
  (trans-for 'with form #f))

(define (displayf fmt . xs)
  (display (apply format fmt xs)))

(write (expand-once #'
(for x in (range 0 1000)
  as y = 10 step 10 to 200
  as z iterate as (expt y 2)
  as w iterate by (λ (x) (* x pi)) with 1
  when (odd? x)
  while (< x 10)
  collect (remainder x 3)
  finally do (displayf "done!~%")
  do (displayf "~A ~A ~A~%" x z w))
        ))
(newline)
(for x in (range 0 1000)
  as y = 10 step 10 to 200
  as z iterate as (expt y 2)
  as w iterate by (λ (x) (* x pi)) with 1
  when (odd? x)
  while (< x 10)
  collect (remainder x 3)
  finally do (displayf "done!~%")
  do (displayf "~A ~A ~A~%" x z w))