; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2007-2010
; See the LICENSE file of the S9fES package for terms of use
;
; (syntax-rules (<keyword> ...) <rule> ...)  ==>  procedure
;
; Implement R4RS SYNTAX-RULES.
;
; Each <keyword> names a symbol that will not bind when matching
; a syntax rule. Each <rule> has the form
;
; (<pattern> <template>)
;
; See the R4RS appendix or the SYNTAX-RULES help page for further
; information.
;
; Caveat: Patterns *must* begin with the symbol _, i.e.:
;
; (define-syntax foo (syntax-rules ((_ x) 'x)))    will work, but
; (define-syntax foo (syntax-rules ((foo x) 'x)))  will *not*!
;
; Example: (apply (syntax-rules ()
;                   ((_ p c ...)
;                     (if p (begin c ...))))
;                 '((< 1 2)
;                   (display "true")
;                   (newline)
;                   #t))
;                                 ==> (if (< 1 2)
;                                         (begin (display "true")
;                                                (newline)
;                                                #t))

; Generate a SYNTAX-RULES transformer, e.g.:
;
; (define-syntax iff
;   (syntax-rules (then else)
;     ((_ p then c)        (and p c))
;     ((_ p then c else a) (if p c a))))
; ==>
; (define-syntax iff
;   (lambda . g283)
;     ((lambda (syntax-expand syntax-match g283)
;        (cond ((syntax-match g283 '(_ p then c) '(then else) '())
;                => (lambda (env)
;                     (syntax-expand '(_ p then c) '(and p c) env)))
;              ((syntax-match g283 '(_ p then c else a) '(then else) '())
;                => (lambda (env)
;                     (syntax-expand '(_ p then c else a) '(if p c a) env)))
;              (else
;                (error "invalid syntax" g283))))
;      #<PROCEDURE syntax-expand>
;      #<PROCEDURE syntax-match>
;      (cons '_ g283)))

; Match FORM against PATTERN.
; KEYWORDS contains the keywords of SYNTAX-RULES.
; When the given form matches the pattern, bind
; each variable of PATTERN to the corresponding
; part of the FORM, extend ENV by these bondings
; and return it.
; In case of a mismatch, return #F.
;
; NOTE: The ellipsis is an ordinary variable, but
; it binds to an environment rather than a form.
;
(define (syntax-match form pattern keywords env)
  (letrec
    ((match
       (lambda (form pattern keywords env)
         (cond
           ((pair? pattern)
             (cond
               ((and (pair? (cdr pattern))
                     (eq? '... (cadr pattern)))
                 (let ((e* (map (lambda (x)
                                  (match x (car pattern) keywords '()))
                                form)))
                   (cons (cons '... e*) env)))
               ((pair? form)
                 (let ((e (match (car form) (car pattern) keywords env)))
                   (and e (match (cdr form) (cdr pattern) keywords e))))
               (else
                 #f)))
           ((memq pattern keywords)
             (if (eq? pattern form) env #f))
           ((symbol? pattern)
             (cons (cons pattern form) env))
           (else
             (if (equal? pattern form) env #f))))))
    (let ((e (match form pattern keywords env)))
      (if e (reverse e) e))))

; Give a unique name to each variable that is bound in FORM.
; BOUND is a list of initially bound variables. This function
; also renames variables of LET, LET*, and LETREC, e.g.:
;
; (ALPHA-CONV '(LET ((X Y)) X) '()) => (LET ((G0 Y)) G0)
;
(define (alpha-conv form bound)
  (letrec
    ((subst
       (lambda (x env)
         (cond ((assq x env) => cdr)
               (else x))))
     (map-improper
       (lambda (f a r)
         (cond ((null? a)
                 (reverse r))
               ((not (pair? a))
                 (append (reverse r) (f a)))
               (else
                 (map-improper f (cdr a) (cons (f (car a)) r))))))
     (remove-bound
       (lambda (env bound)
         (cond ((null? env)
                 '())
               ((memq (caar env) bound)
                 (remove-bound (cdr env) bound))
               (else
                 (cons (car env)
                       (remove-bound (cdr env) bound))))))
     (conv
       (lambda (form env)
         (cond ((symbol? form)
                 (subst form env))
               ((not (pair? form))
                 form)
               ((and (eq? 'quote (car form))
                     (pair? (cdr form))
                     (null? (cddr form)))
                 form)
               ((and (eq? 'lambda (car form))
                     (pair? (cdr form))
                     (pair? (cddr form)))
                 (let ((e (map-improper (lambda (x)
                                          (cons x (gensym)))
                                        (cadr form)
                                        '())))
                   `(lambda ,@(conv (cdr form)
                                    (append (remove-bound e bound)
                                            env)))))
               ((and (or (eq? (car form) 'let)
                         (eq? (car form) 'letrec)
                         (eq? (car form) 'let*))
                     (pair? (cdr form))
                     (pair? (cadr form))
                     (pair? (caadr form))
                     (pair? (cddr form)))
                 (let ((e (map-improper (lambda (x)
                                          (cons x (gensym)))
                                        (map (lambda (x)
                                               (if (pair? x) (car x) #f))
                                             (cadr form))
                                        '())))
                   `(,(car form) ,@(conv (cdr form)
                                         (append (remove-bound e bound)
                                                 env)))))
               (else
                 (map-improper (lambda (x) (conv x env))
                               form
                               '()))))))
    (conv form '())))

; Substitute variables of FORM by values of ENV.
;
(define syntax-expand
  (let ((alpha-conv alpha-conv))
    (lambda (bound tmpl env)
      (letrec
        ((expand
           (lambda (tmpl env)
             (cond
               ((not (pair? tmpl))
                 (cond ((assq tmpl env) => cdr)
                       (else tmpl)))
               ((and (pair? tmpl)
                     (pair? (cdr tmpl))
                     (eq? (cadr tmpl) '...))
                 (let ((eenv (assq '... env)))
                   (if (not eenv)
                       (error
                         (string-append "syntax-rules: template without"
                                        " matching ... in pattern")
                         tmpl)
                       (begin (set-car! eenv '(#f))
                              (map (lambda (x)
                                     (expand (car tmpl) x))
                                   (cdr eenv))))))
               (else
                 (cons (expand (car tmpl) env)
                       (expand (cdr tmpl) env)))))))
        (alpha-conv (expand tmpl env) bound)))))

; Check the syntax of SYNTAX-RULES and rewrite it
; to a LAMBDA expression.
;
(define-syntax (syntax-rules keywords . rules)
  (letrec
    ((flatten
       (lambda (x r)
         (cond ((null? x) r)
               ((pair? x) (flatten (car x)
                                   (flatten (cdr x) r)))
               (else      (cons x r)))))
     (list-of?
       (lambda (p a)
         (or (null? a)
             (and (p (car a))
                  (list-of? p (cdr a))))))
     (keywords-ok?
       (lambda (x)
         (list-of? symbol? x)))
     (rules-ok?
       (lambda (x)
         (list-of? (lambda (x)
                     (and (pair? x)
                          (pair? (car x))
                          (pair? (cdr x))
                          (null? (cddr x))))
                   x)))
     (pattern caar)
     (template cadar)
     (rewrite-rules
       (lambda (app keywords rules-in rules-out)
         (if (null? rules-in)
             (reverse rules-out)
             (rewrite-rules
               app
               keywords
               (cdr rules-in)
               (cons `((syntax-match ,app
                                     ',(pattern rules-in)
                                     ',keywords
                                     '())
                        => (lambda (env)
                             (syntax-expand ',(flatten (pattern rules-in) '())
                                            ',(template rules-in)
                                            env)))
                     rules-out))))))
    (cond
      ((null? rules)
        (error "syntax-rules: too few arguments" rules))
      ((not (keywords-ok? keywords))
        (error "syntax-rules: malformed keyword list" keywords))
      ((not (rules-ok? rules))
        (error "syntax-rules: invalid clause in rules" rules))
      (else
        (let* ((app (gensym))
               (default `((else (error "invalid syntax" ,app)))))
          `(lambda ,app
             (let ((,app (cons '_ ,app))
                   (syntax-match ,syntax-match)
                   (syntax-expand ,syntax-expand))
               (cond ,@(append (rewrite-rules app keywords rules '())
                               default)))))))))
