;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

(require-extension syntactic-closures)
(require-extension term-optimizer)

(define-syntax fast-math
  (sc-macro-transformer
   (lambda (form ue)  ; usage-environment
     (capture-syntactic-environment
      (lambda (ce)    ; closing-environment
        (let ((lets '()))
          (define (extract-unknowns x)
            (if (not (pair? x))
                x
                (cond
                  ((identifier=? ue (car x) ce '+)
                   (cons '+ (map extract-unknowns (cdr x))))
                  ((identifier=? ue (car x) ce '-)
                   (cons '- (map extract-unknowns (cdr x))))
                  ((identifier=? ue (car x) ce '*)
                   (cons '* (map extract-unknowns (cdr x))))
                  ((identifier=? ue (car x) ce '/)
                   (cons '/ (map extract-unknowns (cdr x))))
                  (else
                   (let ((tmp (gensym)))
                     (set! lets (cons (list tmp x) lets))
                     tmp)))))
          (let* ((known (extract-unknowns (cadr form)))
                 (opt (optimize-expr known)))
            ;;(pp `(let ,lets ,opt) (current-error-port))
            (make-syntactic-closure ue '(+ - * /) `(let ,lets ,opt)))))))))

;; unhygienic defmacro version
'(define-macro (fast-math x)
  (let ((lets '()))
    (define (extract-unknowns x)
      (if (not (pair? x))
          x
          (if (memq (car x) '(+ - * /))
              (cons (car x) (map extract-unknowns (cdr x)))
              (let ((tmp (gensym)))
                (set! lets (cons (list tmp x) lets))
                tmp))))
    (let* ((known (extract-unknowns x))
           (opt (optimize-expr known)))
      `(let ,lets ,opt))))