;;; -*-Mode: Scheme; coding: iso-8859-1 -*-

;;;=======================================================================
;;;
;;; 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 '
; (

  (module syntax-case-module (syntax
                              quasisyntax
                              syntax-case
                              with-syntax
                              syntax-rules)

    ;; Since we will lexically redefine SYNTAX (see process-rules) and
    ;; and redefine QUASISYNTAX (see lower down) we need a way to still
    ;; refer to the original SYNTAX and QUASISYNTAX in generated
    ;; code.

    (import #%kernel (lambda (sym)
                       (case sym
                         ((syntax)      'scheme:syntax)
                         ((quasisyntax) 'scheme:quasisyntax)
                         (else #f))))


    (define-syntax (syntax x)
      (quasisyntax (scheme:syntax ,x)))


    (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))))

    ;; Toplevel pattern variable environment.
    ;; Incrementally extended in nested pattern contexts.
    ;; See the LET-SYNTAX generated by PROCESS-RULE.

    (define-syntax (pattern-env)
      (quasisyntax '()))


    (define (process-cases context rules subkeywords)

      (define (make-transformer rules)
        (if (null? rules)
            (quasisyntax (lambda (input) (syntax-error)))
            (let ((input (quasisyntax input))
                  (next (quasisyntax next)))
              (quasisyntax
               (let ((,next ,(make-transformer (cdr rules))))
                 (lambda (,input)
                   (if ,@(process-rule (car rules) input 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))
                     (let-syntax
                         ;; Incrementally extends the pattern variable environment,
                         ;; so that it can be referred to by locally redefined SYNTAX.
                         ;; See the next LET-SYNTAX below.
                         ((,(make-fluid-identifier (syntax here) 'pattern-env)
                           (let ((env (append (meta-variables
                                               (embedded-syntax ,pattern)
                                               (embedded-syntax ,subkeywords)
                                               0
                                               '())
                                              (pattern-env))))
                             (lambda (_) (quasisyntax (embedded-syntax ,env))))))
                       (let-syntax
                           ((,(make-fluid-identifier context 'syntax)
                             (lambda (form)
                               (cond ((and (pair? (cdr form))
                                           (null? (cddr form)))
                                      (quasisyntax
                                       (quasisyntax  ;; for fresh scope
                                        ,,(process-template (cadr form)
                                                            0
                                                            (pattern-env)))))
                                     (else (syntax-error "Invalid syntax template"))))))
                         ,template)))))))
              (else (syntax-error "Ill-formed syntax case:" (syntax-debug 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 (quasisyntax 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 (quasisyntax 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 (quasisyntax 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))

    (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?):"
                                     (syntax-debug 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" (syntax-debug 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" (syntax-debug 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)
       ; (display (syntax-debug x)) (display level) (display (contains-unquoted? x level)) (newline)
        (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))

    (define-syntax quasisyntax
      (lambda (form)
        (or (and (pair? (cdr form))
                 (null? (cddr form)))
            (syntax-error "Invalid quasisyntax template"))
        (let ((syntax0 (datum->syntax-object (car form) 'syntax)))
          (scheme:quasisyntax
           (scheme:quasisyntax  ;; for fresh scope
            ,,(expand-quasisyntax (cadr form)
                                  (lambda (e)
                                    (scheme:quasisyntax (,syntax0 ,e)))))))))


    ;; List and alist utilities:

    (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)))


    ;; 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))
                       ...)))))))

    ) ; module


;; )) ; repl
