;;;=======================================================================
;;;
;;; SYNTAX-CASE: A portable implementation
;;;
;;;   Andre van Tonder, 2005 
;;;
;;;    Copyright:  Significant parts of this code was adapted
;;;                from the Scheme48 syntax-rules implementation.
;;;                I am therefore reproducing their original 
;;;                copyright notice below. 
;;; 
;;;=======================================================================


;;=======================================================================
;;
;; The Scheme48 copyright notice.
;;
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the authors may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;
;;=========================================================================


;; Assumes simple-macros.scm preloaded.



(repl '
 (    
  
  (library "syntax-case-base" "scheme://srfi-72"

    (export syntax quasisyntax syntax-case)
    
    (define-syntax syntax-case
      (lambda (exp)
        (if (and (list? exp)
                 (>= (length exp) 3))
            (let ((context (car exp))
                  (subkeywords (caddr exp))
                  (rules (cdddr exp)))
              (if (and (list? subkeywords)
                       (every? identifier? subkeywords)) 
                  (quasisyntax
                   (,(process-cases context rules subkeywords) ,(cadr exp)))  
                  (syntax-error)))
            (syntax-error))))
    
    
    ;; Since we will redefine SYNTAX, we need a way 
    ;; to still  refer to the original SYNTAX.
    
    (import (add-prefix (only "scheme://srfi-72" syntax) scheme:))
    
    (define-syntax syntax
      (lambda (form)
        (or (and (pair? (cdr form))
                 (null? (cddr form)))
            (syntax-error "Invalid syntax template"))
        (if (null? pattern-env)
            (quasisyntax (scheme:syntax ,(cadr form)))
            (quasisyntax 
             (quasisyntax  ;; for renaming scope
              ,,(process-template (cadr form) 
                                  0
                                  (car pattern-env)))))))
      
     
    (begin-for-syntax 
      
      ;; Toplevel pattern variable environment.
      ;; Incrementally extended in nested pattern contexts.
      ;; See the LET-SYNTAX generated by PROCESS-RULE.
      
      (define pattern-env (list '()))
      
      ;; Mechanism for reflecting expand-time values into syntax  
      ;; that can be included in generated code for later expand-time
      ;; access across macro invocations.
      
      (define reflected-objects '())
      
      (define reflect
        (let ((n 0))
          (lambda (x)
            (set! n (+ n 1))
            (set! reflected-objects (cons (cons n x) reflected-objects))
            n)))
      
      (define (reify reflected)
        (cdr (assq reflected reflected-objects)))
 
      
      ;; Syntax-case helpers:
      
      (define (process-cases context rules subkeywords)  
        
        (define (make-transformer rules)
          (if (null? rules)
              (quasisyntax (lambda (input) (syntax-error)))
              (quasisyntax
               (let ((next ,(make-transformer (cdr rules))))
                 (lambda (input)
                   (if ,@(process-rule (car rules) (syntax input) (syntax next)) 
                       (next input))))))) 
                   
        (define (process-rule rule input next)       
          (cond ((and (pair? rule)
                      (pair? (cdr rule))
                      (pair? (cddr rule))
                      (null? (cdddr rule)))
                 (process-rule (quasisyntax
                                (,(car rule)
                                  (if ,(cadr rule)
                                      ,(caddr rule)
                                      (,next ,input))))
                               input
                               next))
                ((and (pair? rule)
                      (pair? (cdr rule))
                      (null? (cddr rule)))
                 (let ((pattern (car rule))
                       (template (cadr rule)))       
                      
                   (quasisyntax
                    ((and ,@(process-match input pattern))
                     (let ,(process-pattern pattern
                                            input
                                            (lambda (x) x))
                       ;; Dynamically extends the pattern variable environment to control
                       ;; expansion of SYNTAX forms in subexpressions of template.
                       (around-syntax
                        (set! pattern-env 
                              (cons (append (reify
                                             ,(reflect (meta-variables pattern
                                                                       subkeywords
                                                                       0 
                                                                       '())))
                                            (car pattern-env))
                                    pattern-env))   
                        ,template 
                        (set! pattern-env (cdr pattern-env))))))))
                (else (syntax-error "Ill-formed syntax case:" rule))))
        
        ; Generate code to test whether input expression matches pattern
        
        (define (process-match input pattern)
          (cond ((identifier? pattern)
                 (if (member=? pattern subkeywords bound-identifier=?)
                     (quasisyntax ((literal-identifier=? ,input (scheme:syntax ,pattern))))
                     (quasisyntax ())))
                ((segment-pattern? pattern)
                 (process-segment-match input (car pattern)))
                ((pair? pattern)
                 (let ((temp (syntax temp)))
                   (quasisyntax 
                    ((let ((,temp ,input))
                       (and (pair? ,temp)
                            ,@(process-match (quasisyntax (car ,temp)) (car pattern))
                            ,@(process-match (quasisyntax (cdr ,temp)) (cdr pattern))))))))
                ((or (null? pattern) (boolean? pattern) (char? pattern))
                 (quasisyntax ((eq? ,input ',pattern))))
                (else
                 (quasisyntax ((equal? ,input ',pattern))))))
        
        (define (process-segment-match input pattern)
          (let ((l (syntax l)))
            (let ((conjuncts (process-match (quasisyntax (car ,l)) pattern)))
              (if (null? conjuncts)
                  (quasisyntax ((list? ,input)))			;+++
                  (quasisyntax 
                   ((let loop ((,l ,input))
                      (or (null? ,l)
                          (and (pair? ,l)
                               ,@conjuncts
                               (loop (cdr ,l)))))))))))
        
        ; Generate code to take apart the input expression
        ; This is pretty bad, but it seems to work (can't say why).
        
        (define (process-pattern pattern path mapit)
          (cond ((identifier? pattern)
                 (if (member=? pattern subkeywords bound-identifier=?)
                     '()
                     (list (list pattern (mapit path)))))
                ((segment-pattern? pattern)
                 (let ((temp (syntax temp)))
                   (process-pattern (car pattern)
                                    temp
                                    (lambda (x)	;temp is free in x
                                      (mapit (quasisyntax
                                              (map (lambda (,temp) ,x)
                                                   ,path)))))))
                ((pair? pattern)
                 (append (process-pattern (car pattern) (quasisyntax (car ,path)) mapit)
                         (process-pattern (cdr pattern) (quasisyntax (cdr ,path)) mapit)))
                (else '())))
        
        ; Generate code to compose the output expression according to template
        
        (make-transformer rules))  ; process-cases
      
      
      (define (process-template template dim env)
        (cond ((identifier? template)
               (let ((probe (assoc= template env bound-identifier=?))) 
                 (if probe
                     (if (<= (cdr probe) dim)
                         template
                         (syntax-error "Syntax-case: Template dimension error (too few ...'s?):" 
                                       template))
                     (quasisyntax (scheme:syntax ,template)))))
              ((segment-template? template)
               (let* ((depth (segment-depth template))
                      (seg-dim (+ dim depth))
                      (vars
                       (free-meta-variables (car template) seg-dim env '())))  
                 (if (null? vars)
                     (syntax-error "too many ...'s:" template)
                     (let* ((x (process-template (car template)
                                                 seg-dim
                                                 env))
                            (gen (quasisyntax
                                  (map (lambda ,vars ,x)
                                       ,@vars)))
                            (gen (do ((d depth (- d 1))
                                      (gen gen (quasisyntax (apply append ,gen))))
                                   ((= d 1)
                                    gen))))
                       (if (null? (segment-tail template))
                           gen		;+++
                           (quasisyntax
                            (append ,gen ,(process-template (segment-tail template)
                                                            dim env))))))))
              ((pair? template)
               (quasisyntax
                (cons ,(process-template (car template) dim env)
                      ,(process-template (cdr template) dim env))))
              (else
               (quasisyntax (quote ,template)))))
      
      
      ;; Return an association list of (var . dim)
      
      (define (meta-variables pattern subkeywords dim vars)
        (cond ((identifier? pattern)
               (if (member=? pattern subkeywords bound-identifier=?)
                   vars
                   (cons (cons pattern dim) vars)))
              ((segment-pattern? pattern)
               (meta-variables (car pattern) subkeywords (+ dim 1) vars))
              ((pair? pattern)
               (meta-variables (car pattern) subkeywords dim
                               (meta-variables (cdr pattern) subkeywords dim vars)))
              (else vars)))
      
      
      ;; Return a list of meta-variables of given higher dim
      
      (define (free-meta-variables template dim env free)
        (cond ((identifier? template)
               (if (and (not (member=? template free bound-identifier=?))
                        (let ((probe (assoc= template env bound-identifier=?)))  
                          (and probe (>= (cdr probe) dim))))
                   (cons template free)
                   free))
              ((segment-template? template)
               (free-meta-variables (car template)
                                    dim env
                                    (free-meta-variables (cddr template)
                                                         dim env free)))
              ((pair? template)
               (free-meta-variables (car template)
                                    dim env
                                    (free-meta-variables (cdr template)
                                                         dim env free)))
              (else free)))
      
      
      ;; Ellipsis utilities:
      
      (define indicators-for-zero-or-more (list (quasisyntax ...)))
      
      (define (segment-pattern? pattern)
        (and (segment-template? pattern)
             (or (null? (cddr pattern))
                 (syntax-error "segment matching not implemented" pattern))))
      
      (define (segment-template? pattern)
        (and (pair? pattern)
             (pair? (cdr pattern))
             (member=? (cadr pattern) indicators-for-zero-or-more literal-identifier=?)))
      
      ; Count the number of `...'s in PATTERN.
      
      (define (segment-depth pattern)
        (if (segment-template? pattern)
            (+ 1 (segment-depth (cdr pattern)))
            0))
      
      ; Get whatever is after the `...'s in PATTERN.
      
      (define (segment-tail pattern)
        (let loop ((pattern (cdr pattern)))
          (if (and (pair? pattern)
                   (member=? (car pattern) indicators-for-zero-or-more literal-identifier=?))
              (loop (cdr pattern))
              pattern)))
      
      
      ;; We redefine QUASISYNTAX so that implicit unquoting will work
      ;; as expected in the scope of a syntax-case pattern clause.
      ;; This is done as follows:
      ;; If a subexpression contains a level-0 unquote or unquote-splicing,
      ;; expand as one would a quasisyntax and recurse.
      ;; If not, wrap subexpression in SYNTAX so that implicit substitions
      ;; will be performed by the algorithm for the latter.
      
      (define (expand-quasisyntax x quoter)  
        
        (define (contains-unquoted? x level)
          
          (cond
            ((tag-backquote? x)                (contains-unquoted? (cadr x) (+ level 1)))
            ((and (= level 0)
                  (tag-comma? x)
                  (pair? (cdr x)) 
                  (null? (cddr x)))            #t)             
            ((and (= level 0)
                  (pair? x)
                  (tag-comma? (car x)))        #t)
            ((and (= level 0)
                  (pair? x)
                  (tag-comma-atsign? (car x))) #t)
            ((and (> level 0)
                  (or (tag-comma? x)
                      (tag-comma-atsign? x)))  (contains-unquoted? (cdr x) (- level 1)))
            ((pair? x)                         (or (contains-unquoted? (car x) level)
                                                   (contains-unquoted? (cdr x) level)))
            ((null? x)                         #f)
            ((identifier? x)                   #f)
            ((vector? x)                       (contains-unquoted? (vector->list x) level))
            (else                              #f)))
        
        (define (qq-expand x level)
          (cond
            ((not (contains-unquoted? x level)) (quoter x))
            ((tag-backquote? x)                 (quasisyntax
                                                 (list ,(quoter (car x))
                                                       ,(qq-expand (cadr x) (+ level 1)))))
            ((and (= level 0)
                  (tag-comma? x)
                  (pair? (cdr x)) 
                  (null? (cddr x)))             (cadr x))            
            ((and (= level 0)
                  (pair? x)
                  (tag-comma? (car x)))         (quasisyntax
                                                 (append (list . ,(cdar x))
                                                         ,(qq-expand (cdr x) 0))))
            ((and (= level 0)
                  (pair? x)
                  (tag-comma-atsign? (car x)))  (quasisyntax
                                                 (append (append . ,(cdar x))
                                                         ,(qq-expand (cdr x) 0))))
            ((and (> level 0)
                  (or (tag-comma? x)
                      (tag-comma-atsign? x)))   (quasisyntax
                                                 (cons ,(quoter (car x))
                                                       ,(qq-expand (cdr x) (- level 1)))))
            ((pair? x)                          (quasisyntax
                                                 (cons ,(qq-expand (car x) level)
                                                       ,(qq-expand (cdr x) level))))
            ((null? x)                          (quasisyntax '()))
            ((identifier? x)                    (quoter x))
            ((vector? x)                        (quasisyntax
                                                 (list->vector ,(qq-expand (vector->list x) level))))
            (else                               x)))
        
        (define (tag-comma? x)        (and (pair? x) 
                                           (literal-identifier=? (car x) (syntax unquote))))
        (define (tag-comma-atsign? x) (and (pair? x)
                                           (literal-identifier=? (car x) (syntax unquote-splicing))))
        (define (tag-backquote? x)    (and (pair? x)
                                           (pair? (cdr x))
                                           (null? (cddr x))
                                           (literal-identifier=? (car x) (syntax quasisyntax))))
        (define (tag-dots? x)         (and (pair? x)
                                           (pair? (cdr x))
                                           (literal-identifier=? (cadr x) (syntax ...))))
        
        (qq-expand x 0))
      
  
      ;; This gets expanded with the imported quasisyntax.
      ;; It is then used to redefine quasisyntax below.
      
      (define quasisyntax-transformer 
        (lambda (form)
          (or (and (pair? (cdr form))
                   (null? (cddr form)))
              (syntax-error "Invalid quasisyntax template"))
          (let ((implicit-syntax (datum->syntax-object (car form) 'syntax)))
            (quasisyntax    
             (quasisyntax  ;; for renaming scope
              ,,(expand-quasisyntax (cadr form)
                                    (lambda (e)
                                      (quasisyntax (,implicit-syntax ,e)))))))))
  
      ) ; begin-for-syntax
            
    (define-syntax quasisyntax quasisyntax-transformer)
    

    ;; List and alist utilities:
    
    (begin-for-syntax 
      
      (define (member=? x ls =)
        (cond ((null? ls) #f)
              ((pair? ls) (or (= x (car ls))
                              (member=? x (cdr ls) =)))
              (else (error "Member=?" x ls =))))
      
      (define (assoc= x alist =)
        (cond ((null? alist)      #f)
              ((= x (caar alist)) (car alist))
              (else               (assoc= x (cdr alist) =))))
      
      (define (every? p? ls)
        (cond ((null? ls) #t)
              ((pair? ls) (and (p? (car ls))
                               (every? p? (cdr ls))))
              (else #f)))
      
      ) ; begin-for-syntax
    
    ) ; syntax-case-base

  
  
  (library "syntax-case" "scheme://srfi-72"

    (export syntax
            quasisyntax
            syntax-case
            with-syntax
            syntax-rules)
    
    (import (for "syntax-case-base" run expand))

    ;; The usual macros:
    
    (define-syntax with-syntax
      (lambda (x)
        (syntax-case x ()
          ((_ ((p e0) ...) e1 e2 ...)
           (syntax (syntax-case (list e0 ...) ()
                     ((p ...) (begin e1 e2 ...))))))))
    
    (define-syntax syntax-rules
      (lambda (x)
        (syntax-case x ()
          ((_ (i ...) ((keyword . pattern) template) ...)
           (syntax (lambda (form)
                     (syntax-case form (i ...)
                       ((dummy . pattern) (syntax template))
                       ...)))))))
    
    ) ; syntax-case
  
  
  
  )) ; repl