;; transformer-macro-blocks.scm: Macro blocks for transformers.
;; Authored 2002, 2003 by Al Petrofsky and released into the public domain.
;;
;; Define-syntax+, let-syntax+, and letrec-syntax+ work like their
;; standard counterparts, but allow (let-syntax+ <bindings> <transformer>)
;; blocks and letrec-syntax+ blocks as valid transformers.

(define-syntax let-syntax+
  (syntax-rules ()
    ((_ bindings . body)
     (reduce-bindings (let-syntax . body) () . bindings))))

(define-syntax letrec-syntax+
  (syntax-rules ()
    ((_ bindings . body)
     (reduce-bindings (letrec-syntax . body) () . bindings))))

(define-syntax define-syntax+
  (syntax-rules ()
    ((_ . binding)
     (reduce-bindings (define-syntax-binding) () binding))))

(define-syntax define-syntax-binding
  (syntax-rules () ((_ (binding)) (define-syntax . binding))))

;; (reduce-bindings (binder . body) () binding ...)
;; expands to (binder reduced-bindings . body), with any macro-block
;; transformers in the bindings replaced by ordinary transformers.
(define-syntax reduce-bindings
  (syntax-rules (let-syntax+ letrec-syntax+)
    ((reduce-bindings bb reduced (key (let-syntax+ bs t)) . unreduced)
     (reduce-binding  bb reduced (key (let-syntax+ bs t)) . unreduced))
    ((reduce-bindings bb reduced (key (letrec-syntax+ bs t)) . unreduced)
     (reduce-binding  bb reduced (key (letrec-syntax+ bs t)) . unreduced))
    ((reduce-bindings bb             reduced  ordinary . unreduced)
     (reduce-bindings bb (ordinary . reduced)          . unreduced))
    ((reduce-bindings (binder . body) reduced)
     (binder reduced . body))))

;; Reduce a macro-block transformer in the first binding.
;; This version uses (... <subtemplate>) ellipsis escapement, as provided
;; by Chez scheme.
(define-syntax reduce-binding
  (syntax-rules ()
    ((_ bb reduced (key (let/letrec-syntax+ bindings trans)) . unreduced)
     (reduce-bindings bb
		      ((key (syntax-rules ()
			      ((_ . args)
			       ((... ...) (let/letrec-syntax+ bindings
					    (let-syntax+ ((t trans))
					      (t . args)))))))
		       . reduced)
		      . unreduced))))

;; Using new-fangled choose-your-own-ellipsis feature from draft SRFI-46.
(define-syntax reduce-binding
  (syntax-rules ()
    ((_ bb reduced (key (let/letrec-syntax+ bindings trans)) . unreduced)
     (reduce-bindings bb
		      ((key (syntax-rules no-ellipsis ()
			      ((_ . args)
			       (let/letrec-syntax+ bindings
				 (let-syntax+ ((t trans))
				   (t . args))))))
		       . reduced)
		      . unreduced))))

;; Examples, adapted from r5rs:

;; Note that I can use the same pattern variable names in do and
;; do-step without any conflict.  Also note that (syntax-rules ()) is
;; a legal syntax-rules transformer with zero rules, which means that
;; any use of it will cause an expansion-time error (a "no pattern
;; matches" error) that will presumably be reported with a message
;; that includes the arguments.
(define-syntax+ do+
  (letrec-syntax+
      ((do-step (syntax-rules ()
		  ((_ var init) var)
		  ((_ var init step) step)
		  ((_ . clause) (syntax-error "Bad do clause: " clause))))
       (syntax-error (syntax-rules ())))
    (syntax-rules ()
      ((do ((var init step ...) ...)
	   (test expr ...)
	 command ...)
       (let loop ((var init) ...)
	 (if test
	     (begin (if #f #f) expr ...)
	     (begin command ... (loop (do-step var init step ...) ...))))))))

;; Note that the auxiliary macro has dots all over the place, with no
;; need to escape them.
(define-syntax+ letrec+
  (letrec-syntax+
      ((gentemps
	(syntax-rules ()
	  ((gentemps (x y ...)         (temp ...) ((var1 init1) ...) body ...)
	   (gentemps   (y ...) (newtemp temp ...) ((var1 init1) ...) body ...))
	  ((gentemps        (       ) (temp1 ...) ((var1 init1) ...) body ...)
	   (let ((var1 'undefined) ...)
	     (let ((temp1 init1) ...)
	       (set! var1 temp1)
	       ...
	       (let () body ...)))))))
    (syntax-rules ()
      ((letrec ((var1 init1) ...) body1 body2 ...)
       (gentemps (var1 ...) () ((var1 init1) ...) body1 body2 ...)))))