; The macros syntax-error, syntax-unsupported, and non-tail-call have no
; syntax-rules.  They are used to report errors.

(define-syntax syntax-error (syntax-rules ()))

(define-syntax syntax-unsupported (syntax-rules ()))

(define-syntax non-tail-call (syntax-rules ()))

; (tail-form e) expands to e iff e is in tail form.
; If e is not in tail form, the offending non-tail call is tagged
; as (non-tail-call e), causing a syntax error.  Unrecognized or
; unsupported Scheme constructs are tagged as (syntax-error e) and
; (syntax-unsupported e), also causing a syntax error.

(define-syntax tail-form
  (syntax-rules (lambda define begin if let let* letrec cond else => case
                 and or
                 do quote delay set!
                 quasiquote let-syntax letrec-syntax syntax-rules define-syntax)

    ((tail-form (lambda formals e0 ... e))
     (lambda formals (simple-tail-form e0) ... (tail-form e)))
    ((tail-form (lambda stuff ...))
     (syntax-error (lambda stuff ...)))

    ((tail-form (define head e))
     (define head (tail-form e)))
    ((tail-form (define stuff ...))
     (syntax-error (define stuff ...)))

    ((tail-form (begin e0 ... e))
     (begin (simple-tail-form e0) ... (tail-form e)))
    ((tail-form (begin stuff ...))
     (syntax-error (begin stuff ...)))

    ((tail-form (if test consequent))
     (if (simple-tail-form test) (tail-form consequent)))
    ((tail-form (if test consequent alternate))
     (if (simple-tail-form test) (tail-form consequent) (tail-form alternate)))
    ((tail-form (if stuff ...))
     (syntax-error (if stuff ...)))

    ((tail-form (let ((var init) ...) e0 ... e))
     (let ((var (simple-tail-form init)) ...)
       (simple-tail-form e0) ... (tail-form e)))
    ((tail-form (let name ((var init) ...) e0 ... e))
     (let name ((var (simple-tail-form init)) ...)
       (simple-tail-form e0) ... (tail-form e)))
    ((tail-form (let stuff ...))
     (syntax-error (let stuff ...)))

    ((tail-form (let* ((var init) ...) e0 ... e))
     (let* ((var (simple-tail-form init)) ...)
       (simple-tail-form e0) ... (tail-form e)))
    ((tail-form (let* stuff ...))
     (syntax-error (let* stuff ...)))

    ((tail-form (letrec ((var init) ...) e0 ... e))
     (letrec ((var (simple-tail-form init)) ...)
       (simple-tail-form e0) ... (tail-form e)))
    ((tail-form (letrec stuff ...))
     (syntax-error (letrec stuff ...)))

    ((tail-form (cond (else e ...)))
     (tail-form (begin e ...)))
    ((tail-form (cond (else e ...) clause ...))
     (syntax-error (cond (else e ...) clause ...)))
    ((tail-form (cond (test)))
     (tail-form (let ((x test)) (if x x))))
    ((tail-form (cond (test) clause ...))
     (tail-form (let ((x test)) (if x x (cond clause ...)))))
    ((tail-form (cond (test => recipient)))
     (tail-form (let ((x test)) (if x (recipient x)))))
    ((tail-form (cond (test => recipient) clause ...))
     (tail-form (let ((x test)) (if x (recipient x) (cond clause ...)))))
    ((tail-form (cond (test e ...)))
     (tail-form (if test (begin e ...))))
    ((tail-form (cond (test e ...) clause ...))
     (tail-form (if test (begin e ...) (cond clause ...))))
    ((tail-form (cond stuff ...))
     (syntax-error (cond stuff ...)))

    ((tail-form (case key (data e0 ... e) ...))
     (case (simple-tail-form key)
       (data (simple-tail-form e0) ... (tail-form e)) ...))
    ((tail-form (case stuff ...))
     (syntax-error (case stuff ...)))

    ((tail-form (and))
     (and))
    ((tail-form (and e0 ... e))
     (and (simple-tail-form e0) ... (tail-form e)))

    ((tail-form (or))
     (or))
    ((tail-form (or e0 ... e))
     (or (simple-tail-form e0) ... (tail-form e)))

    ((tail-form (do ((var init step) ...)
                    (test)
                  command ...))
     (do ((var (simple-tail-form init) (simple-tail-form step)) ...)
         ((simple-tail-form test))
        (simple-tail-form command) ...))
    ((tail-form (do ((var init step) ...)
                    (test e0 ... e)
                  command ...))
     (do ((var (simple-tail-form init) (simple-tail-form step)) ...)
         ((simple-tail-form test) (simple-tail-form e0) ... (tail-form e))
        (simple-tail-form command) ...))
    ((tail-form (do stuff ...))
     (syntax-error (do stuff ...)))

    ((tail-form (quote datum))
     (quote datum))
    ((tail-form (quote stuff ...))
     (syntax-error (quote stuff ...)))

    ((tail-form (delay e))
     (delay (tail-form e)))
    ((tail-form (delay stuff ...))
     (syntax-error (delay stuff ...)))

    ((tail-form (set! var e))
     (set! var (simple-tail-form e)))
    ((tail-form (set! stuff ...))
     (syntax-error (set! stuff ...)))

    ((tail-form (quasiquote stuff ...))
     (syntax-unsupported (quasiquote stuff ...)))
    ((tail-form (let-syntax stuff ...))
     (syntax-unsupported (let-syntax stuff ...)))
    ((tail-form (letrec-syntax stuff ...))
     (syntax-unsupported (letrec-syntax stuff ...)))
    ((tail-form (syntax-rules stuff ...))
     (syntax-unsupported (syntax-rules stuff ...)))
    ((tail-form (define-syntax stuff ...))
     (syntax-unsupported (define-syntax stuff ...)))

    ((tail-form ())
     (syntax-error ()))
    ((tail-form (e ...))
     ((simple-tail-form e) ...))
    ((tail-form x)
     x)

    ((tail-form e0 ... e) ; support multiple forms inside single tail-form
     (begin (simple-tail-form e0) ... (tail-form e)))

    ))

; (simple-tail-form e) expands to e iff e is simple and in tail form.
; If e is not in tail form, the offending non-tail call is tagged
; as (non-tail-call e), causing a syntax error.  Unrecognized or
; unsupported Scheme constructs are tagged as (syntax-error e) and
; (syntax-unsupported e), also causing a syntax error.

(define-syntax simple-tail-form
  (syntax-rules (lambda define begin if let let* letrec cond else => case
                 and or + - * / quotient remainder modulo < = > <= >=
                 eq? eqv? not zero? positive? negative? odd? even? max min abs
                 pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr caaar
                 caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar
                 caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr
                 cddaar cddadr cdddar cddddr null? list
                 do quote delay set!
                 quasiquote let-syntax letrec-syntax syntax-rules define-syntax)

    ((simple-tail-form (lambda formals e0 ... e))
     (lambda formals (simple-tail-form e0) ... (tail-form e)))
    ((simple-tail-form (lambda stuff ...))
     (syntax-error (lambda stuff ...)))

    ((simple-tail-form (define head e))
     (define head (simple-tail-form e)))
    ((simple-tail-form (define stuff ...))
     (syntax-error (define stuff ...)))

    ((simple-tail-form (begin e ...))
     (begin (simple-tail-form e) ...))

    ((simple-tail-form (if e ...))
     (if (simple-tail-form e) ...))

    ((simple-tail-form (let ((var init) ...) e ...))
     (let ((var (simple-tail-form init)) ...) (simple-tail-form e) ...))
    ((simple-tail-form (let name ((var init) ...) e ...))
     (let name ((var (simple-tail-form init)) ...) (simple-tail-form e) ...))
    ((simple-tail-form (let stuff ...))
     (syntax-error (let stuff ...)))

    ((simple-tail-form (let* ((var init) ...) e ...))
     (let* ((var (simple-tail-form init)) ...) (simple-tail-form e) ...))
    ((simple-tail-form (let* stuff ...))
     (syntax-error (let* stuff ...)))

    ((simple-tail-form (letrec ((var init) ...) e ...))
     (letrec ((var (simple-tail-form init)) ...) (simple-tail-form e) ...))
    ((simple-tail-form (letrec stuff ...))
     (syntax-error (letrec stuff ...)))

    ((simple-tail-form (cond (else e ...)))
     (simple-tail-form (begin e ...)))
    ((simple-tail-form (cond (else e ...) clause ...))
     (syntax-error (cond (else e ...) clause ...)))
    ((simple-tail-form (cond (test)))
     (simple-tail-form (let ((x test)) (if x x))))
    ((simple-tail-form (cond (test) clause ...))
     (simple-tail-form (let ((x test)) (if x x (cond clause ...)))))
    ((simple-tail-form (cond (test => recipient)))
     (simple-tail-form (let ((x test)) (if x (recipient x)))))
    ((simple-tail-form (cond (test => recipient) clause ...))
     (simple-tail-form (let ((x test)) (if x (recipient x) (cond clause ...)))))
    ((simple-tail-form (cond (test e ...)))
     (simple-tail-form (if test (begin e ...))))
    ((simple-tail-form (cond (test e ...) clause ...))
     (simple-tail-form (if test (begin e ...) (cond clause ...))))
    ((simple-tail-form (cond stuff ...))
     (syntax-error (cond stuff ...)))

    ((simple-tail-form (case key (data e ...) ...))
     (case (simple-tail-form key) (data (simple-tail-form e) ...) ...))
    ((simple-tail-form (case stuff ...))
     (syntax-error (case stuff ...)))

    ((simple-tail-form (and e ...)) (and (simple-tail-form e) ...))
    ((simple-tail-form (or e ...)) (or (simple-tail-form e) ...))
    ((simple-tail-form (+ e ...)) (+ (simple-tail-form e) ...))
    ((simple-tail-form (- e ...)) (- (simple-tail-form e) ...))
    ((simple-tail-form (* e ...)) (* (simple-tail-form e) ...))
    ((simple-tail-form (/ e ...)) (/ (simple-tail-form e) ...))
    ((simple-tail-form (quotient e ...)) (quotient (simple-tail-form e) ...))
    ((simple-tail-form (remainder e ...)) (remainder (simple-tail-form e) ...))
    ((simple-tail-form (modulo e ...)) (modulo (simple-tail-form e) ...))
    ((simple-tail-form (< e ...)) (< (simple-tail-form e) ...))
    ((simple-tail-form (= e ...)) (= (simple-tail-form e) ...))
    ((simple-tail-form (> e ...)) (> (simple-tail-form e) ...))
    ((simple-tail-form (<= e ...)) (<= (simple-tail-form e) ...))
    ((simple-tail-form (>= e ...)) (>= (simple-tail-form e) ...))
    ((simple-tail-form (eq? e ...)) (eq? (simple-tail-form e) ...))
    ((simple-tail-form (eqv? e ...)) (eqv? (simple-tail-form e) ...))
    ((simple-tail-form (not e ...)) (not (simple-tail-form e) ...))
    ((simple-tail-form (zero? e ...)) (zero? (simple-tail-form e) ...))
    ((simple-tail-form (positive? e ...)) (positive? (simple-tail-form e) ...))
    ((simple-tail-form (negative? e ...)) (negative? (simple-tail-form e) ...))
    ((simple-tail-form (odd? e ...)) (odd? (simple-tail-form e) ...))
    ((simple-tail-form (even? e ...)) (even? (simple-tail-form e) ...))
    ((simple-tail-form (max e ...)) (max (simple-tail-form e) ...))
    ((simple-tail-form (min e ...)) (min (simple-tail-form e) ...))
    ((simple-tail-form (abs e ...)) (abs (simple-tail-form e) ...))
    ((simple-tail-form (pair? e ...)) (pair? (simple-tail-form e) ...))
    ((simple-tail-form (cons e ...)) (cons (simple-tail-form e) ...))
    ((simple-tail-form (car e ...)) (car (simple-tail-form e) ...))
    ((simple-tail-form (cdr e ...)) (cdr (simple-tail-form e) ...))
    ((simple-tail-form (set-car! e ...)) (set-car! (simple-tail-form e) ...))
    ((simple-tail-form (set-cdr! e ...)) (set-cdr! (simple-tail-form e) ...))
    ((simple-tail-form (caar e ...)) (caar (simple-tail-form e) ...))
    ((simple-tail-form (cadr e ...)) (cadr (simple-tail-form e) ...))
    ((simple-tail-form (cdar e ...)) (cdar (simple-tail-form e) ...))
    ((simple-tail-form (cddr e ...)) (cddr (simple-tail-form e) ...))
    ((simple-tail-form (caaar e ...)) (caaar (simple-tail-form e) ...))
    ((simple-tail-form (caadr e ...)) (caadr (simple-tail-form e) ...))
    ((simple-tail-form (cadar e ...)) (cadar (simple-tail-form e) ...))
    ((simple-tail-form (caddr e ...)) (caddr (simple-tail-form e) ...))
    ((simple-tail-form (cdaar e ...)) (cdaar (simple-tail-form e) ...))
    ((simple-tail-form (cdadr e ...)) (cdadr (simple-tail-form e) ...))
    ((simple-tail-form (cddar e ...)) (cddar (simple-tail-form e) ...))
    ((simple-tail-form (cdddr e ...)) (cdddr (simple-tail-form e) ...))
    ((simple-tail-form (caaaar e ...)) (caaaar (simple-tail-form e) ...))
    ((simple-tail-form (caaadr e ...)) (caaadr (simple-tail-form e) ...))
    ((simple-tail-form (caadar e ...)) (caadar (simple-tail-form e) ...))
    ((simple-tail-form (caaddr e ...)) (caaddr (simple-tail-form e) ...))
    ((simple-tail-form (cadaar e ...)) (cadaar (simple-tail-form e) ...))
    ((simple-tail-form (cadadr e ...)) (cadadr (simple-tail-form e) ...))
    ((simple-tail-form (caddar e ...)) (caddar (simple-tail-form e) ...))
    ((simple-tail-form (cadddr e ...)) (cadddr (simple-tail-form e) ...))
    ((simple-tail-form (cdaaar e ...)) (cdaaar (simple-tail-form e) ...))
    ((simple-tail-form (cdaadr e ...)) (cdaadr (simple-tail-form e) ...))
    ((simple-tail-form (cdadar e ...)) (cdadar (simple-tail-form e) ...))
    ((simple-tail-form (cdaddr e ...)) (cdaddr (simple-tail-form e) ...))
    ((simple-tail-form (cddaar e ...)) (cddaar (simple-tail-form e) ...))
    ((simple-tail-form (cddadr e ...)) (cddadr (simple-tail-form e) ...))
    ((simple-tail-form (cdddar e ...)) (cdddar (simple-tail-form e) ...))
    ((simple-tail-form (cddddr e ...)) (cddddr (simple-tail-form e) ...))
    ((simple-tail-form (null? e ...)) (null? (simple-tail-form e) ...))
    ((simple-tail-form (list e ...)) (list (simple-tail-form e) ...))

    ((simple-tail-form (do ((var init step) ...)
                           (e ...)
                         command ...))
     (do ((var (simple-tail-form init) (simple-tail-form step)) ...)
         ((simple-tail-form e) ...)
        (simple-tail-form command) ...))
    ((simple-tail-form (do stuff ...))
     (syntax-error (do stuff ...)))

    ((simple-tail-form (quote datum))
     (quote datum))
    ((simple-tail-form (quote stuff ...))
     (syntax-error (quote stuff ...)))

    ((simple-tail-form (delay e))
     (delay (tail-form e)))
    ((simple-tail-form (delay stuff ...))
     (syntax-error (delay stuff ...)))

    ((simple-tail-form (set! var e))
     (set! var (simple-tail-form e)))
    ((simple-tail-form (set! stuff ...))
     (syntax-error (set! stuff ...)))

    ((simple-tail-form (quasiquote stuff ...))
     (syntax-unsupported (quasiquote stuff ...)))
    ((simple-tail-form (let-syntax stuff ...))
     (syntax-unsupported (let-syntax stuff ...)))
    ((simple-tail-form (letrec-syntax stuff ...))
     (syntax-unsupported (letrec-syntax stuff ...)))
    ((simple-tail-form (syntax-rules stuff ...))
     (syntax-unsupported (syntax-rules stuff ...)))
    ((simple-tail-form (define-syntax stuff ...))
     (syntax-unsupported (define-syntax stuff ...)))

    ((simple-tail-form ())
     (syntax-error ()))
    ((simple-tail-form (e ...))
     (non-tail-call (e ...)))

    ((simple-tail-form x)
     x)

    ))