syntax-rules-on-sc-closures.scm

;;; This code should be loadable into MIT Scheme as is.

(define (acons key datum alist) (cons (cons key datum) alist))

;;; Pattern parser should return 3 values, the pattern matching code,
;;; the bindings, and an alist of (var . rank).
(define (process-pattern input-var pattern literals ellipsis)
;;; TODO:
;;;   - segment matching where the segment is not at the end.
;;;   - misplaced ... errors
  (define (duplicate-variable-error identifier)
    (error "Duplicate non-literal identifier ~a found in pattern ~a."
           (identifier->symbol identifier) pattern))
  (define (duplicate-ellipsis-error sub-pattern)
    (error "Duplicate ellipsis not allowed in ~a at sub-pattern ~a."
           pattern sub-pattern))
  ;; TODO incorporate
  (define (initial-ellipsis-error sub-pattern)
    (error "Ellipsis cannot start sub-pattern ~a in ~a."
           sub-pattern pattern))
  (define variables '())
  (define (segment-pattern? pattern)
    (and (pair? pattern)
         (pair? (cdr pattern))
         (eq? (cadr pattern) ellipsis)
         (or (null? (cddr pattern))
             (error "segment matching not implemented" pattern))))
  (define (process match pattern bind rank)
    (cond ((symbol? pattern)
           (cond ((memq pattern literals)
                  (values `((eq? ',pattern ,match)) '()))
                 ((eqv? pattern '_)
                  (values '() '()))
                 (else
                  (when (assq pattern variables)
                    (duplicate-variable-error pattern))
                  (set! variables (acons pattern rank variables))
                  (values '() `((,pattern ,bind))))))
          ((segment-pattern? pattern)
           (let-values (((match-code bindings)
                         (process 'temp (car pattern) 'temp (1+ rank))))
             (values (if (null? match-code)
                         '()
                         `((every (lambda (temp)
                                    ,@match-code)
                                  ,match)))
                     (map (lambda (binding)
                            `(,(car binding)
                              (map (lambda (temp)
                                     ,(cadr binding))
                                   ,bind)))
                          bindings))))
          ((pair? pattern)
           (let-values (((car-match-code car-bindings)
                         (process '(car temp) (car pattern) `(car ,bind) rank))
                        ((cdr-match-code cdr-bindings)
                         (process '(cdr temp) (cdr pattern) `(cdr ,bind) rank)))
             (values `(((lambda (temp)
                           (if (pair? temp)
                               (if ,@(if (null? car-match-code)
                                         '(#t)
                                         car-match-code)
                                   ,@(if (null? cdr-match-code)
                                         '(#t)
                                         cdr-match-code)
                                   #f)
                               #f))                        
                        ,match))
                     (append car-bindings cdr-bindings))))
          ((vector? pattern) ; TODO: bare minimum implementation.
           (process `(vector->list ,match) (vector->list pattern)
                    `(vector->list ,bind) rank))
          (else
           (values `((equal? ,match ',pattern)) '()))))
  (let-values (((match bind) (process input-var pattern input-var 0)))
    (pretty-print match)
    (pretty-print bind)
    (values match bind variables)))

;;; Convert template into a quasiquote form, returning it and the
;;; pattern variables referenced.
(define (process-template template ellipsis signature)

  (define (misplaced-ellipsis-error)
    (error "Ellipsis governs no pattern variables in syntax-rules template." template))

  (define (rank-mismatch-error variable variable-rank rank)
    (error "The rank of ~a in the pattern is ~a, but the rank expected by the template ~a is ~a."
           variable variable-rank template rank))

  (define (variable-rank variable)
    (let ((cell (assq variable signature)))
      (and cell (cdr cell))))

  (define (escape-template? template ellipsis)
    (and ellipsis
         (pair? template)
         (eqv? (car template) ellipsis)
         (null? (cddr template))))

  (define (segment-template? template ellipsis)
    (and ellipsis
         (pair? template)
         (pair? (cdr template))
         (eq? (cadr template) ellipsis)))

  (define (segment-template-rank template ellipsis)
    (let loop ((rank 0)
               (template template))
      (if (segment-template? template ellipsis)
          (loop (+ rank 1) (cdr template))
          (values rank (cdr template)))))

  (define (wrap-reduce-append vars rank)
    (define (loop var rank)
      (if (= rank 1)
          var
          `(reduce-right append '() ,(loop var (- rank 1)))))
    (map (lambda (var) (loop var rank)) vars))

  (define (hygienify var)
    `(close-syntax ,var environment))

  (define (process template ellipsis rank)
    (cond ((eqv? template ellipsis)
           (misplaced-ellipsis-error))
          ((symbol? template)
           (let ((variable-rank (variable-rank template)))
             (if variable-rank
                 (if (= variable-rank rank)
                     (values (list 'unquote (hygienify template))
                             (list template))
                     (rank-mismatch-error template variable-rank rank))
                 (values template '()))))
          ((escape-template? template ellipsis)
           (process (cadr template) #f rank))
          ((segment-template? template ellipsis)
           (let*-values (((segment-rank rest)
                          (segment-template-rank template ellipsis))
                         ((code vars)
                          (process (car template)
                                   ellipsis
                                   (+ segment-rank rank))))
             (when (null? vars)
               (misplaced-ellipsis-error))
             (values (cons (list 'unquote-splicing
                                 `(map (lambda ,vars
                                         ,(list 'quasiquote code))
                                       ,@(wrap-reduce-append vars
                                                             segment-rank)))
                           (process rest ellipsis rank))
                     vars)))
          ((pair? template)
           (let-values (((car-code car-vars)
                         (process (car template) ellipsis rank))
                        ((cdr-code cdr-vars)
                         (process (cdr template) ellipsis rank)))
             (values (cons car-code cdr-code)
                     (lset-union eqv? car-vars cdr-vars))))
          ((vector? template)
           (let-values (((code vars)
                         (process (vector->list template) ellipsis rank)))
             (values (list->vector code) vars)))
          (else
           (values template '()))))
  (let-values (((qq-template free-vars) (process template ellipsis 0)))
    (pretty-print qq-template)
    (values (list 'quasiquote qq-template) free-vars)))

(define (syntax-rules-expander form environment definition-environment)

  (let-values (((ellipsis literals syntax-rules)
                (if (pair? (cadr form))
                    (values (cadr form) (caddr form) (cdddr form))
                    (values '... (cadr form) (cddr form)))))
    (define (process-rule rule)
      (if (and (pair? rule)
	       (pair? (cdr rule))
	       (null? (cddr rule)))
          (let ((pattern (cdar rule))
	        (template (cadr rule)))
            (let*-values (((match-code bind-code signature)
                           ;; skip first element of form
                           (process-pattern '(cdr form) pattern literals ellipsis))
                          ((qq-form vars)
                           (process-template template ellipsis signature)))
              (when (null? vars)
                (warn "style-warning: vars defined but not used in syntax rule." rule))
              
	      `(,@match-code
	        ((lambda ,(map car bind-code)
                   ,qq-form)
                 ,@(map cadr bind-code)))))
          (error "ill-formed syntax rule" rule)))

    (define (process-rules rules) ; TODO error checking for non-nil cons case.
      (if (null? rules)
          '(error "bad syntax" form)
          `(if ,@(process-rule (car rules))
               ,(process-rules (cdr rules)))))

    (close-syntax `(sc-macro-transformer
                    (lambda (form environment)
                      ,(process-rules syntax-rules)))
                  definition-environment)))

(define-syntax syntax-rules
  (sc-macro-transformer
   (lambda (form environment)
     (capture-syntactic-environment
      (lambda (definition-environment)
        (syntax-rules-expander form environment definition-environment))))))