

;;;===============================================================================
;;;
;;; Portable Hygienic Macros and Libraries:
;;;
;;;   Copyright (c) 2005 Andre van Tonder
;;;
;;;   Permission is hereby granted, free of charge, to any person obtaining a 
;;;   copy of this software and associated documentation files (the ``Software''), 
;;;   to deal in the Software without restriction, including without limitation 
;;;   the rights to use, copy, modify, merge, publish, distribute, sublicense, 
;;;   and/or sell copies of the Software, and to permit persons to whom the 
;;;   Software is furnished to do so, subject to the following conditions: 
;;; 
;;;   The above copyright notice and this permission notice shall be included in 
;;;   all copies or substantial portions of the Software. 
;;;
;;;   THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS 
;;;   OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
;;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;;   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
;;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
;;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 
;;;   DEALINGS IN THE SOFTWARE. 
;;;
;;;===============================================================================



;;;=====================================================================
;;;
;;; Gensym:
;;;
;;;=====================================================================

;; For separate compilation, this should be redone to generate a
;; globally unique symbol.  
;; It is essential for our purposes that symbols generated by gensym
;; not lose their separateness when converted to strings, and that
;; two gensyms that are equal as strings be treated as equivalent 
;; identifiers by eval.  For example, the native Chez gensym fails 
;; the former and the native MzScheme gensym fails the latter.

(define gensym                            
  (let ((count 0))
    (lambda maybe-prefix-string
      (set! count (+ 1 count))
      (string->symbol
       (string-append (if (null? maybe-prefix-string)
                          ""
                          (car maybe-prefix-string))
                      "#"
                      (number->string count))))))


;;;=====================================================================
;;;
;;; Miscellaneous utilities:
;;;
;;;=====================================================================

(define (sexp-map f s)
  (cond ((null? s) '())
        ((pair? s) (cons (sexp-map f (car s))
                         (sexp-map f (cdr s))))
        ((vector? s)
         (apply vector (sexp-map f (vector->list s))))
        (else (f s))))

(define (map-in-order f ls)
  (if (null? ls)
      '()
      (let ((first (f (car ls))))
        (cons first
              (map-in-order f (cdr ls))))))

(define (filter p? lst)
      (if (null? lst)
          '()
          (if (p? (car lst))
              (cons (car lst)
                    (filter p? (cdr lst)))
              (filter p? (cdr lst)))))

(define (dotted-member? x ls =)
  (cond ((null? ls) #f)
        ((pair? ls) (or (= x (car ls))
                        (dotted-member? x (cdr ls) =)))
        (else (= x ls))))

(define (dotted-map f lst)
  (cond ((null? lst) '())
        ((pair? lst) (cons (f (car lst))
                           (dotted-map f (cdr lst))))
        (else (f lst))))

(define (dotted-for-each f lst)
  (cond ((null? lst) '())
        ((pair? lst) (begin (f (car lst))
                            (dotted-for-each f (cdr lst))))
        (else (f lst))))

(define (every? p? ls)
  (cond ((null? ls) #t)
        ((pair? ls) (and (p? (car ls))
                         (every? p? (cdr ls))))
        (else #f)))

(define (alist-cons key datum alist)
  (cons (cons key datum) alist))

(define (alist-ref key alist)
  (cond ((assq key alist) => cdr)
        (else #f)))

(define (alist-delete key alist)             
  (cond ((null? alist) 
         '())
        ((eq? (caar alist) key) 
         (alist-delete key (cdr alist)))
        (else 
         (cons (car alist)
               (alist-delete key (cdr alist))))))

(define (alist-delete-first key alist)             
  (cond ((null? alist) 
         '())
        ((eq? (caar alist) key)
         (cdr alist))
        (else 
         (cons (car alist)
               (alist-delete-first key (cdr alist))))))

(define (alist-remove-duplicates alist)
  (define (rem alist already)
    (cond ((null? alist)               '())
          ((memq (caar alist) already) (rem (cdr alist) already))
          (else                        (cons (car alist)
                                             (rem (cdr alist)
                                                  (cons (caar alist)
                                                        already))))))
  (rem alist '()))

(define (void) (if #f #f))

(define (make-parameter val)
  (lambda maybe-new
    (if (null? maybe-new)
        val
        (set! val (car maybe-new)))))

;; Since we do not assume the language to have macros already,  
;; we avoid defining the usual macro for this.
;; Usage: (parametrize par1 val1 ... parn valn thunk)

(define (parametrize . args)
  (if (null? (cdr args))
      ((car args))
      (let* ((parameter (car args))
             (restore   (parameter)))
        (parameter (cadr args))
        (let ((result (apply parametrize (cddr args))))
          (parameter restore)
          result))))


;;;==========================================================================
;;;
;;; Infrastructure for hygiene:
;;;
;;;==========================================================================

;; The current phase in the syntactic tower. 

(define *phase* (make-parameter 0))

;; Creates a substitution context, in which bound-identifier=?
;; identifiers share a location, so that substitutions can be done by an
;; imperative update of an identifier (see bind! below) and we do not have
;; to do any additional work to propagate substitution environments to leaves. 
;; The resulting hygiene algorithm is eager, has linear complexity, and is
;; very fast.

;; Initial-phase is the syntactic phase in force when the originating
;; syntax or quasisyntax expression was expanded.

(define (make-renaming-procedure initial-phase
                                 colour
                                 initial-environment
                                 capturing?) 
  
  (let ((phase-correction (- (*phase*) initial-phase))
        (inserted '())
        (environment initial-environment)
        (environment-dirty? #f)) 
    
    ;; The optional initial tower of binding names will always be supplied
    ;; (avoiding a search through the initial environment) except in
    ;; the case of datum->syntax-object.  
    
    ;; A tower of bindings is an alist ((phase . binding-name) ...)
    ;; where phase = non-negative-integer | all | free
    ;;
    ;; all  - a binding name valid for all phases. 
    ;; free - a binding name prefix that is to be qualified by the phase 
    ;;        to obtain the binding name for a given phase.
    ;;        This mechanism keeps namespaces for different phases 
    ;;        separate.
    ;;
    ;; See binding-name below for lookup sequence.
    
    (define (rename symbolic-name . maybe-tower)   
      (cond ((assq symbolic-name inserted) => cdr)
            (else
             (if (null? maybe-tower)
                 (cond ((env-lookup symbolic-name initial-environment)   
                        => (lambda (entry)
                             (insert symbolic-name entry #f)))
                       (else (insert symbolic-name 
                                     (list (cons 'free
                                                 (paint-name symbolic-name
                                                             colour)))
                                     #t)))
                 (insert symbolic-name (car maybe-tower) #t)))))
    
    (define (insert symbolic-name tower dirty?)
      
      (define (binding-name)                                         
        (cond ((assq (current-phase) tower) => cdr)
              ((assq 'all            tower) => cdr)
              (else 
               (phase-qualify (cdr (assq 'free tower))
                              (current-phase)))))
      
      (define bind!                 
        (if capturing? 
            (lambda (binding-name . maybe-phase) (void))
            (lambda (binding-name . maybe-phase)
              (set! tower
                    (alist-cons (if (null? maybe-phase)
                                    (current-phase)
                                    (car maybe-phase))
                                binding-name 
                                tower))
              (mark-dirty!))))
      
      (define unbind!
        (if capturing?
            (lambda () (void))
            (lambda ()
              (set! tower
                    (alist-delete-first (current-phase) tower))
              (mark-dirty!))))
      
      (define (current-phase) (- (*phase*) phase-correction)) 
      
      ;; Generates a representation of the identifier that can be inserted
      ;; in generated code.  
      
      (define (reflect-syntax) 
        `(',colour ',symbolic-name ,(- (current-phase) 1) ',tower ',(close-environment)))
      
      (define (mark-dirty!)
        (set! dirty? #t)
        (set! environment-dirty? #t))
      
      (define (mark-clean!)
        (set! dirty? #f))
      
      (define (maybe-reflect-tower)
        (if dirty?
            (begin
              (mark-clean!)
              tower)
            #f))
      
      (let ((new (make-identifier symbolic-name
                                  binding-name
                                  colour
                                  bind!
                                  unbind!
                                  rename
                                  close-environment
                                  current-phase
                                  reflect-syntax
                                  maybe-reflect-tower))) 
        (set! inserted (alist-cons symbolic-name new inserted))
        (if dirty? 
            (set! environment-dirty? #t))  
        new))
    
    ;; Provides a persistent snapshot of the current bindings.
    ;; Invoked when compiling |syntax| forms and when executing 
    ;; make-capturing-identifier.
    
    ;; To support separate compilation, environments are 
    ;; included in the expanded representation of a library.
    ;; We are careful to only record differences in environments
    ;; that the serialized representation will be small.
    
    (define (close-environment)   
      (if environment-dirty?
          (begin 
            (set! environment
                  (reflect-environment
                   (let loop ((inserted inserted))
                     (if (null? inserted)
                         environment
                         (let ((maybe-tower (maybe-reflect-tower (cdar inserted))))
                           (if maybe-tower
                               (alist-cons (caar inserted)
                                           maybe-tower 
                                           (loop (cdr inserted)))
                               (loop (cdr inserted))))))))
            (set! environment-dirty? #f)))
      environment)
    
    rename))

;; Meta-renaming procedures are used to implement syntax and 
;; quasisyntax expressions, which should paint identifiers with 
;; a new colour without unifying previously different colours.  
;; This is done by appending a new colour to an identifier's 
;; existing colour.  

(define (make-meta-renaming-procedure)
  (let ((fresh-colour (generate-colour))
        (colours->renamers '()))
    (lambda (colour symbolic-name initial-phase tower environment)  
      (let ((rename
             (cond ((assq colour colours->renamers) => cdr)
                   (else
                    (let ((rename (make-renaming-procedure
                                   initial-phase
                                   (append-colours fresh-colour colour)
                                   environment
                                   #f)))  
                      (set! colours->renamers
                            (alist-cons colour rename colours->renamers))   
                      rename)))))
        (rename symbolic-name tower))))) 

;; Used below for writing primitive macros in explicit renaming style.

(define (make-primitive-renaming-procedure)      
  (let ((rename
         (make-renaming-procedure 0 no-colour (make-empty-env) #f)))
    (lambda (symbolic-name)
      (rename symbolic-name
              (list (cons 'all symbolic-name)))))) 


;;;=========================================================================
;;;
;;; The identifier type:
;;;
;;;=========================================================================

(define identifier-tag (list 'identifier))

(define real-vector?
  ;; In case this code is rerun in same environment:
  (eval 'vector? (scheme-report-environment 5)))

(define (vector? x) (and (real-vector? x)
                         (not (identifier? x))))

(define (identifier? x) 
  (and (real-vector? x)
       (> (vector-length x) 0)
       (eq? (vector-ref x 0) identifier-tag)))

(define (make-identifier symbolic-name
                         binding-name
                         colour
                         bind!
                         unbind!
                         renamer
                         close-environment 
                         current-phase
                         reflect-syntax 
                         maybe-reflect-tower) 
  (vector identifier-tag
          symbolic-name
          binding-name
          colour
          bind!
          unbind!
          renamer
          close-environment 
          current-phase
          reflect-syntax 
          maybe-reflect-tower)) 

(define (symbolic-name       id)                            (vector-ref id 1))
(define (binding-name        id)                            ((vector-ref id 2)))
(define (colour              id)                            (vector-ref id 3))
(define (bind!               id binding-name . maybe-phase) (apply (vector-ref id 4) binding-name maybe-phase))
(define (unbind!             id)                            ((vector-ref id 5)))
(define (renamer             id)                            (vector-ref id 6))
(define (close-environment   id)                            ((vector-ref id 7)))  
(define (current-phase       id)                            ((vector-ref id 8)))
(define (reflect-syntax      id)                            ((vector-ref id 9))) 
(define (maybe-reflect-tower id)                            ((vector-ref id 10)))

;; Lexical bindings:

(define (bind-lexical! id)
  (bind! id (gensym (string-append "@" (symbol->string (symbolic-name id))))))

(define (lexically-bound? id)
  (char=? #\@ (string-ref (symbol->string (binding-name id)) 0)))

;; Toplevel binding forms use as binding name the name 
;; painted with the colour.  Since colours of macro-generated 
;; substitution contexts are secret, this causes binding names in 
;; macro-generated defines and define-syntaxes to be secret and 
;; protects imported library locations (including primitives) from 
;; being inadvertently rebound (although they can still be set!).  

(define (bind-toplevel! id)
  (bind! id 
         (phase-qualify (paint-name (symbolic-name id) (colour id))
                        (current-phase id))))                                  

;; Imported bindings:

(define (import! symbolic-name imported-name context-id . maybe-phase)  
  (let ((local-id ((renamer context-id) symbolic-name)))
    (apply bind! local-id imported-name maybe-phase))) 


;;;=====================================================================
;;;
;;; Comparing identifiers:
;;;
;;;=====================================================================

(define (bound-identifier=? x y)             
  (and (identifier? x)
       (eq? x y)))

(define (free-identifier=? x y)                            
  (and (identifier? x)
       (identifier? y)
       (eq? (binding-name x)
            (binding-name y))))

;; This should be used to compare literals independently of library.

(define (literal-identifier=? x y)
  (and (identifier? x)
       (identifier? y)
       (or (eq? (binding-name x)
                (binding-name y))                             
           (and (not (lexically-bound? x))
                (not (lexically-bound? y))
                (eq? (symbolic-name x)
                     (symbolic-name y))))))
       
;; For internal use.  Equivalent to  
;; (free-identifier=? x (syntax symbol))

(define (free=? x symbol)           
  (and (identifier? x)
       (eq? (binding-name x) symbol)))  

;; For internal use.  Equivalent to   
;; (literal-identifier=? x (syntax symbol))

(define (literal=? x symbol)           
  (and (identifier? x)
       (or (eq? (binding-name x) symbol)
           (and (not (lexically-bound? x))
                (eq? (symbolic-name x) symbol)))))


;;;=====================================================================
;;;
;;; Intentional capture:
;;;
;;;=====================================================================

(define (datum->syntax-object tid datum) 
  (if (identifier? tid)
      (datum->syntax (renamer tid) datum)
      (syntax-error "Datum->syntax-object: First argument must be identifier:" tid))) 

(define (datum->syntax rename datum)
  (sexp-map (lambda (leaf)
              (cond ((const? leaf)  leaf)
                    ((symbol? leaf) (rename leaf))
                    (else
                     (syntax-error "Datum->syntax-object: Invalid datum:" leaf))))
            datum))                   

(define (syntax-object->datum stx)
  (sexp-map (lambda (leaf)
              (cond ((const? leaf)      leaf)
                    ((identifier? leaf) (symbolic-name leaf))
                    (else 
                     (syntax-error "Syntax-object->datum: Invalid syntax object:" leaf))))
            stx))

;; A fluid identifier in a binding form will capture
;; unbound free-identifier=? identifiers in its scope.
;; The idetifier tid provides the environment for
;; determining the denotation of the identifier.

(define (make-capturing-identifier tid symbolic-name)
  (or (and (identifier? tid)
           (symbol? symbolic-name))
      (syntax-error "Make-fluid-identifier :: identifier symbol -> identifier"
                    tid symbolic-name))
  (let ((rename (make-renaming-procedure 
                 (current-phase tid)
                 (colour tid)
                 (close-environment tid)
                 #t)))
    (rename symbolic-name)))


;;;=======================================================================
;;;
;;; Environments:
;;;
;;;=======================================================================

;; Table of reflected environments:

(define *environments* (make-parameter '()))

;; An environment is either a reflected environment (symbol)
;; or an association possibly improper list whose tail may be a reflected   
;; environment.

(define (env-lookup key env)
  (cond ((null? env) #f)
        ((pair? env) (if (eq? key (caar env))
                         (cdar env)
                         (env-lookup key (cdr env))))
        (else (env-lookup key 
                          (reify-environment env)))))

;; Returns a single-symbol representation of an environment 
;; that can be included in object code.

(define (reflect-environment env)  
  (let ((key (gensym "env")))
    (*environments* (alist-cons key
                                (cons (*current-library-name*) env)
                                (*environments*)))
    key))

;; The inverse of the above.

(define (reify-environment reflected-env)
  (cdr (alist-ref reflected-env (*environments*))))


;;;=======================================================================
;;;
;;; Colours:
;;;
;;;=======================================================================

;; To support separate compilation, generated colours should be 
;; globally unique. 

(define (generate-colour)
  (gensym "#"))

(define no-colour             (string->symbol ""))
(define source-colour         (string->symbol "#top"))
(define (library-colour name) (gensym (string-append "#" (symbol->string name))))

;; Appending colours c1 and c2 must give a colour disjoint from
;; the range of generate-colour unless either is no-colour.  

(define (append-colours c1 c2)
  (string->symbol 
   (string-append (symbol->string c1)  
                  (symbol->string c2))))

;; Generates the painted names used for free toplevel or 
;; library identifiers, or secret names in generated defines.
;; Painted names should be disjoint from all source symbols
;; and all previous and future gensyms.  

(define (paint-name symbolic-name colour)    
  (string->symbol                             
   (string-append (symbol->string symbolic-name)
                  (symbol->string colour)))) 

;; Further qualifies a name by a syntactic phase.

(define (phase-qualify name phase)
  (string->symbol 
   (string-append (symbol->string name)
                  (if (= phase 0) 
                      "" 
                      (string-append "'"                              
                                     (number->string phase))))))


;;;=========================================================================
;;;
;;; Expander dispatch: 
;;;
;;;=========================================================================

;; Debugging information displayed by syntax-error.

(define *backtrace* (make-parameter '())) 

;; Transformers are user-defined macros.
;; Expanders are system macros that fully expand
;; their arguments to core Scheme.

(define (expand t)
  (parametrize *backtrace* (cons t (*backtrace*))
               (lambda ()
                 (cond ((identifier? t)                 (binding-name t))       
                       ((syntax-use t (*transformers*)) => (lambda (transformer)
                                                             (expand (transformer t))))
                       ((syntax-use t expanders)        => (lambda (expander)
                                                             (expander t)))
                       ((list?  t)                      (map-in-order expand t))
                       ((const? t)                      t)
                       (else 
                        (syntax-error "Expand: Invalid syntax object:" t))))))

;; Used to determine internal defintions in lambda.

(define (head-expand t)
  (parametrize *backtrace* (cons t (*backtrace*))
               (lambda ()
                 (cond 
                   ((syntax-use t (*transformers*)) => (lambda (transformer)
                                                         (head-expand (transformer t))))
                   (else t)))))

(define (const? t)
  (or (null?    t)
      (boolean? t)
      (number?  t)
      (string?  t)
      (char?    t)))

(define (syntax-use t table)            
  (and (pair? t)                          
       (identifier? (car t))
       (alist-ref (binding-name (car t)) table)))

(define expanders '())

(define (install-expanders)
  (set! expanders
        `((lambda           . ,expand-lambda)
          (syntax           . ,expand-syntax)
          (quasisyntax      . ,expand-quasisyntax)
          (quote            . ,syntax-object->datum)
          (,'quasiquote     . ,expand-quasiquote) 
          (define           . ,expand-define)
          (define-syntax    . ,expand-define-syntax)
          (let-syntax       . ,expand-let-syntax)
          (letrec-syntax    . ,expand-letrec-syntax) 
          (begin-for-syntax . ,expand-begin-for-syntax)
          (around-syntax    . ,expand-around-syntax)
          (set-syntax!      . ,expand-set-syntax)
          (library          . ,expand-library)
          (export-0         . ,expand-export)
          (import-0         . ,expand-import))))


;; Global transformer table:
;; This could benefit from being implemented 
;; as an O(1) data structure:

(define *transformers* (make-parameter '()))

(define (register-transformer name proc)
  (*transformers* (alist-cons name proc (*transformers*))))


;;;=========================================================================
;;;
;;; Syntax:
;;;
;;;=========================================================================

(define (expand-syntax form)
  (define (descend x)
    (cond ((pair? x)       `(cons ,(descend (car x)) ,(descend (cdr x))))
          ((vector? x)     `(list->vector ,(descend (vector->list x))))
          ((identifier? x) `(,(*current-renamer*) ,@(reflect-syntax x)))  
          ((const? x)      `(quote ,x))
          (else
           (syntax-error "Syntax: Invalid element in syntax object:" form))))
  (nest-in-fresh-scope 
   (lambda () (descend (cadr form)))))


(define *current-renamer* (make-parameter 'no-root-renamer)) 
(define *in-syntax*       (make-parameter #f))

(define (nest-in-fresh-scope thunk)
  (if (*in-syntax*)
      (thunk)
      (parametrize *current-renamer* (gensym "rename")
                   *in-syntax* #t 
                   (lambda ()
                     `(let ((,(*current-renamer*) (make-meta-renaming-procedure)))
                        ,(thunk))))))
 

;;;=========================================================================
;;;
;;; Quasisyntax and quasiquote: 
;;;
;;;=========================================================================


(define (quasi x quasi-tag id-quoter)  
    
    (define (qq-expand x level)
      
      (cond
        ((tag-backquote? x)                `(list ,(id-quoter (car x))
                                                  ,(qq-expand (cadr x) (+ level 1))))
        ((and (= level 0)
              (tag-comma? x)
              (pair? (cdr x)) 
              (null? (cddr x)))            (expand (cadr x)))            
        ((and (= level 0)
              (pair? x)
              (tag-comma? (car x)))        `(append (list . ,(map expand (cdar x)))
                                                    ,(qq-expand (cdr x) 0)))
        ((and (= level 0)
              (pair? x)
              (tag-comma-atsign? (car x))) `(append (append . ,(map expand (cdar x)))
                                                    ,(qq-expand (cdr x) 0)))
        ((and (> level 0)
              (or (tag-comma? x)
                  (tag-comma-atsign? x)))  `(cons ,(id-quoter (car x))
                                                  ,(qq-expand (cdr x) (- level 1))))
        ((pair? x)                         `(cons ,(qq-expand (car x) level)
                                                  ,(qq-expand (cdr x) level)))
        ((null? x)                         `(quote ()))
        ((identifier? x)                   (id-quoter x))
        ((vector? x)                       `(list->vector 
                                             ,(qq-expand (vector->list x) level)))
        (else                              (expand x))))
    
    (define (tag-comma? x)        (and (pair? x) 
                                       (literal=? (car x) `unquote)))
    (define (tag-comma-atsign? x) (and (pair? x)
                                       (literal=? (car x) `unquote-splicing)))
    (define (tag-backquote? x)    (and (pair? x)
                                       (pair? (cdr x))
                                       (null? (cddr x))
                                       (literal=? (car x) quasi-tag)))
    
    (qq-expand x 0))


(define (expand-quasisyntax form)
  (or (and (pair? (cdr form))
           (null? (cddr form))) 
      (syntax-error "Quasisyntax:  Should have one argument"))
  (nest-in-fresh-scope
   (lambda () 
     (quasi (cadr form)
            'quasisyntax
            (lambda (id) (expand-syntax `(dummy ,id)))))))
 

(define (expand-quasiquote form)
  (or (and (pair? (cdr form))
           (null? (cddr form))) 
      (syntax-error "Quasiquote:  Should have one argument"))
  (quasi (cadr form)
         'quasiquote
         (lambda (id) `(quote ,(syntax-object->datum id)))))
 

;;;=========================================================================
;;;
;;; Lambda:
;;;
;;;=========================================================================


;; Here we expand internal definitions to internal definitions in
;; the host Scheme, thus preserving the semantics of the latter.  
;; We could just as easily have expanded to a letrec or letrec*.

(define (expand-lambda exp)
  (if (and (pair?    (cdr exp))
           (formals? (cadr exp))
           (list?    (cddr exp)))
      (let ((formals (cadr exp))
            (body    (cddr exp)))
        (dotted-for-each bind-lexical! formals)
        (scan-body body
                   (lambda (definitions exp exps)
                     (let ((result
                            `(lambda ,(dotted-map binding-name formals)
                               ,@(map (lambda (def)
                                        `(define ,(binding-name (cadr def))
                                           ,(expand (caddr def))))
                                      definitions)
                               ,exp
                               ,@(map expand exps))))
                       (for-each unbind! (map cadr definitions)) 
                       (dotted-for-each unbind! formals)
                       result))))
      (syntax-error "Invalid lambda syntax:" exp)))

;; Here we expand the first expression atomically in case expansion
;; relies on side effects.  This is important in a procedural macro 
;; system.  So that the first expression will be expanded correctly,
;; definition-bound identifiers are bound as soon as they are
;; encountered.  

(define (scan-body forms k)
  (let loop ((forms forms)
             (defs  '()))
    (if (null? forms)
        (syntax-error "Lambda: Empty body.")
        (let ((form  (head-expand (car forms)))
              (forms (cdr forms)))
          (cond ((define? form)                           
                 (let ((def (normalize-definition form #f)))
                   (bind-lexical! (cadr def))  
                   (loop forms
                         (cons def defs))))
                ((begin? form)
                 (loop (append (cdr form) forms)
                       defs))
                (else
                 (k (reverse defs) 
                    (expand form) 
                    forms)))))))    

(define (make-operator-predicate name)
  (lambda (t)
    (and (pair? t)
         (free=? (car t) name))))

(define define? (make-operator-predicate 'define))
(define begin?  (make-operator-predicate 'begin))

(define (formals? s)
  (or (null? s)
      (identifier? s)
      (and (pair? s)
           (identifier? (car s))
           (formals? (cdr s))
           (not (dotted-member? (car s)              
                                (cdr s)
                                bound-identifier=?)))))


;;;=========================================================================
;;;
;;; Define, define-syntax! and set-syntax!
;;;
;;;=========================================================================


(define (normalize-definition t syntax-definition?)
  (cond ((pair? (cdr t))
         (let ((_    (car t))
               (head (cadr t))
               (body (cddr t)))
           (cond ((and (identifier? head)
                       (pair? body)
                       (null? (cdr body)))
                  `(,_ ,head . ,body))
                 ((and (pair? head)
                       (identifier? (car head))
                       (formals? (cdr head)))
                  (let ((r (make-primitive-renaming-procedure)))
                    (if syntax-definition?
                        `(,_ ,(car head)
                           ,(let ((transformer (r (symbolic-name (car head)))))
                              `((,(r 'lambda) (,transformer)
                                  (,(r 'lambda) (,(r 'form))
                                    (,(r 'apply) ,transformer ,(r 'form))))
                                (,(r 'lambda) (,(r 'dummy) . ,(cdr head)) . ,body))))
                        `(,_ ,(car head)
                           (,(r 'lambda) ,(cdr head) . ,body)))))
                 (else (syntax-error "Syntax error in definition:" t)))))
        (else (syntax-error "Syntax error in definition:" t))))

;; A macro expands to an instance of for-syntax, which
;; is a no-op at toplevel but will be further processed
;; when inside a library.

(define (expand-define-syntax t)
  (let ((t (normalize-definition t #t)))
    (bind-toplevel! (cadr t))
    (let ((expanded
           `(register-transformer ',(binding-name (cadr t))
                                  ,(parametrize *phase* (+ (*phase*) 1)
                                                (lambda ()
                                                  (expand (caddr t)))))))
      (eval expanded)  
      `(for-syntax (quote ,expanded)))))       

(define (expand-define t)
  (let ((t (normalize-definition t #f)))
    (bind-toplevel! (cadr t))
    (*transformers* (alist-delete (binding-name (cadr t))
                                  (*transformers*)))     
    `(define ,(binding-name (cadr t))
       ,(expand (caddr t)))))

(define (expand-set-syntax t)
  (or (and (list? t)
           (= (length t) 3)
           (identifier? (cadr t)))
      (syntax-error))
  (let ((expanded
         `(set-syntax! ',(binding-name (cadr t))
                       ,(parametrize *phase* (+ (*phase*) 1)
                                     (lambda ()
                                       (expand (caddr t)))))))
    (eval expanded)
    `(for-syntax (quote ,expanded))))               

(define (set-syntax! binding-name transformer)            
  (cond ((assq binding-name (*transformers*))
         => (lambda (entry) 
              (set-cdr! entry transformer)))
        (else
         (error "Set-syntax! Unbound variable:" binding-name))))


;;;=========================================================================
;;;
;;; Let[rec]-syntax:
;;;
;;;=========================================================================

(define (expand-let-syntax t)        
  (scan-let t
            (lambda (formals exps body)
              (or (formals? formals)
                  (syntax-error "Invalid formals:" formals))
              (let ((transformers 
                     (parametrize *in-syntax* #f  
                                  *phase* (+ (*phase*) 1)
                                  (lambda ()
                                    (map (lambda (exp) 
                                           (eval (expand exp)))
                                         exps)))))
                (for-each bind-lexical! formals)
                (emit-lexical-syntax formals transformers body)))))

(define (expand-letrec-syntax t)
  (scan-let t
            (lambda (formals exps body)
              (or (formals? formals)
                  (syntax-error "Invalid formals:" formals))
              (for-each bind-lexical! formals)
              (let ((transformers 
                     (parametrize *in-syntax* #f
                                  *phase* (+ (*phase*) 1)
                                  (lambda ()
                                    (map (lambda (exp) 
                                           (eval (expand exp)))
                                         exps)))))
                (emit-lexical-syntax formals transformers body)))))


;; Let[rec]-syntax is implemented as a splicing form, wrapping its
;; body in an implicit begin instead of let as in R5RS.
;; This is a more useful semantics, allowing the body to expand
;; into toplevel definitions, and the R5RS semantics can be 
;; obtained by explicitly writing the let.  

(define (emit-lexical-syntax formals transformers body)
  (parametrize *transformers*
               (append (map (lambda (formal transformer)
                              (cons (binding-name formal)
                                    transformer))
                            formals
                            transformers)
                       (*transformers*))
               (lambda ()
                 (let ((result (map-in-order expand body)))      
                   (for-each unbind! formals)
                   `(begin ,@result)))))

(define (scan-let t k)                
  (or (and (pair? (cdr t))
           (list? (cadr t))
           (list? (cddr t))
           (every? (lambda (binding)
                     (and (pair? binding)
                          (identifier? (car binding))
                          (pair? (cdr binding))
                          (null? (cddr binding))))
                   (cadr t)))
      (syntax-error))
  (let ((formals (map car (cadr t)))
        (exps    (map cadr (cadr t)))
        (body    (cddr t)))
    (k formals
       exps
       body)))


;;;===========================================================================
;;;
;;; Begin-for-syntax:
;;;
;;;===========================================================================

;; Expands enclosed code at phase + 1 and evaluate at expansion time.
;; The expanded code cannot be discarded - it needs to be included in 
;; the proper way in the library so that libraries will compose correctly.
;; We therefore quote it and wrap it in for-syntax, which is a no-op
;; when evaluated at toplevel, but will be further processed when 
;; included in a library.

(define (expand-begin-for-syntax t)
  (or (list? (cdr t))
      (syntax-error))
  (parametrize *phase* (+ (*phase*) 1)
               (lambda ()
                 (let ((result
                        (map-in-order expand (cdr t))))
                   (eval `(begin ,@result))
                   `(begin ,@(map (lambda (form) 
                                    `(for-syntax (quote ,form)))                              
                                  result))))))             

(define (for-syntax . exps) (void))


;;;===========================================================================
;;;
;;; Around-syntax:
;;;
;;;===========================================================================

;; Allows code to be executed before and after expanding an expression.

(define (expand-around-syntax t)
  (or (and (list? t)
           (= (length t) 4))
      (syntax-error))
  (parametrize *phase* (+ (*phase*) 1)
               (lambda () 
                 (eval (expand (cadr t)))))
  (let ((result (expand (caddr t))))
    (parametrize *phase* (+ (*phase*) 1)
                 (lambda ()
                   (eval (expand (cadddr t)))
                   result))))


;;;============================================================================
;;;
;;; Libraries:
;;;
;;;============================================================================


(define (make-library name exports)
  (list name exports))

(define library-name    car)
(define library-exports cadr)


(define *loaded-libraries* (make-parameter '()))
     
;; mode = visited | invoked

(define (load-library mode library action-thunk)
  (let ((name (string->symbol (library-name library))))
    (if (not (lookup-library name mode (*phase*)))
        (begin
          (*loaded-libraries* (alist-cons (list name mode (*phase*))
                                          library
                                          (*loaded-libraries*)))
          (action-thunk)
          (void)))))

;; key :: (name mode phase)

(define (lookup-library name mode phase)
  (cond ((assoc (list name mode phase) (*loaded-libraries*)) => cdr)
        (else #f)))

(define *current-library-name* (make-parameter "")) 


(define (expand-library exp)
  
  (or (string=? (*current-library-name*) "")
      (syntax-error "Nested libraries are not allowed:" exp))
  
  (or (and (list? exp)
           (>= (length exp) 3)
           (string? (cadr exp))
           (string? (caddr exp)))
      (syntax-error "Invalid library syntax:" exp))
      
  ;; Since imported libraries may be mutated during expansion
  ;; that follows, we make sure that we continue with a clean
  ;; slate afterwards.  This causes all libraries imported after 
  ;; expanding this library to be re-instantiated.  
           
  (*loaded-libraries* '())
  
  ;; To ensure repeatability and consistency with incremental compilation,
  ;; libraries are expanded in a fresh environment.
  
  (parametrize *current-library-name* (cadr exp)
               *transformers*         (*transformers*)
               *environments*         '()
               *loaded-libraries*     '()
               (lambda ()
                 (define primitive-rename (make-primitive-renaming-procedure))
                 (let* ((name     (cadr exp))
                        (language (caddr exp))
                        
                        ;; Paint the entire body with a new colour in a
                        ;; clean Scheme environment, achieving a private
                        ;; namespace.
                                 
                        (rename   (make-renaming-procedure
                                   0
                                   (library-colour (string->symbol name)) 
                                   (make-empty-env)
                                   #f))
                        (initial  (expand-import `(,(primitive-rename 'import) 
                                                   ,(rename 'import)  ; import context 
                                                   ,language
                                                   ,(primitive-rename 'identity) 
                                                   ,(primitive-rename 'all))))
                        (body     (datum->syntax rename (syntax-object->datum (cdr exp))))
                        (exps     (cdr body)) 
                        (expanded (cons initial
                                        (flatten-for-syntax
                                         (flatten-begins (map-in-order expand exps)))))
                        (exports  (extract-exports expanded))
                        (defines  (extract-defines (append expanded
                                                           (extract-for-syntax expanded))))     
                        (code
                         (let ((mode  (gensym "mode")))
                           `(begin ,@(map (lambda (def)
                                            `(define ,(cadr def) (void)))
                                          defines)    
                                   (define ,(string->symbol name)
                                     (lambda (,mode)
                                       (case ,mode
                                         ((unbind)
                                          (void) ;; prevents possibly empty clause
                                          ,@(map (lambda (def)
                                                   `(set! ,(cadr def) (void)))
                                                 defines))
                                         (else
                                          (load-library ,mode 
                                                        (make-library 
                                                         ',name   
                                                         ',(map (lambda (name-export)
                                                                  (cons (symbolic-name 
                                                                         (car name-export))
                                                                        (binding-name  
                                                                         (cadr name-export))))
                                                                exports))
                                                        ;; action-thunk
                                                        (lambda ()
                                                          (case ,mode
                                                            ((visited)
                                                             (*environments* 
                                                              (append (uncompress-envs 
                                                                       (quote ,(compress-envs
                                                                                (*environments*))))
                                                                      (*environments*)))
                                                             ,@(defines->sets 
                                                                 (extract-for-syntax expanded)))    
                                                            ((invoked)
                                                             (void) ;; prevents possibly empty clause
                                                             ,@(defines->sets
                                                                 (delete-for-syntax
                                                                  (delete-exports expanded)))))))))))))))
                   
                   ;; Unbind imported libraries:
                   
                   (for-each (lambda (library-entry)
                               (eval `(,(caar library-entry) 'unbind)))
                             (*loaded-libraries*)) 
                   
                   (eval code)                                        
                   code))))

(define (identity x) x)

(define (flatten-begins forms)
  (let loop ((result '())
             (forms forms)) 
    (if (null? forms)
        (reverse result)
        (let ((form  (car forms))
              (forms (cdr forms)))
          (if (call? form 'begin)
              (loop result
                    (append (cdr form) forms))
              (loop (cons form result) 
                    forms))))))

(define (call? form name)
  (and (pair? form)
       (eq? (car form) name)))
 
;; Each for-syntax has a single argument.
;; Flattens (for-syntax '(begin e ...))  -> (for-syntax 'e) ...
;;          (for-syntax '(for-syntax e)) -> (for-syntax 'e)
;; and recurses.

(define (flatten-for-syntax forms)  
  (apply append 
         (map (lambda (form)
                (if (call? form 'for-syntax)
                    (let ((embedded (cadadr form)))
                      (cond
                        ((call? embedded 'for-syntax)
                         (flatten-for-syntax (list embedded)))
                        ((call? embedded 'begin)
                         (flatten-for-syntax (map (lambda (form) 
                                                    `(for-syntax ',form))
                                                  (cdr embedded))))
                        (else (list form))))
                    (list form)))
              forms)))

;; Extract expressions e occurring in forms (for-syntax 'e)

(define (extract-for-syntax forms)                     
  (map cadadr
       (filter (lambda (form) 
                 (call? form 'for-syntax))
               forms)))

(define (delete-for-syntax forms)                
  (filter (lambda (form) 
            (not (call? form 'for-syntax)))
          forms))

(define (extract-exports forms)
  (apply append
         (map cdr
              (filter (lambda (form)
                        (call? form 'export-0))
                      forms))))

(define (delete-exports forms)                
  (filter (lambda (form) 
            (not (call? form 'export-0)))
          forms))
                                                
(define (extract-defines forms)
  (filter (lambda (form)
            (call? form 'define))
          forms))

(define (defines->sets forms)
  (map (lambda (form)
         (if (call? form 'define)
             `(set! ,(cadr form) ,(caddr form)) 
             form))
       forms))


;; Internal export:
;; Preserve identifiers in (cdr t), since they
;; may still be (impperatively) bound upon further
;; processing of library form.

(define (expand-export t)
  `(export-0 ,@(cdr t)))


;; Internal import:

;; The term t is of the form 
;; (import-0 template-identifier library-string renaming-procedure . maybe-phase) 
;; Renaming-procedure should evaluate (at (*phase*) + 1) to a 
;; procedure : symbol -> symbol | #f representing an arbitrary computation 
;; on the imported symbols.
;; If #f, the symbol is not imported.
;; Maybe-all may override the current (*phase*) with 'all, for
;; making a "language" available for all phases.

;; Semantics:
;;
;; To invoke a library at phase N:
;;
;;    * Invoke at phase N any library that is imported by this library
;;      for run time, and that is not yet invoked at phase N. 
;;    * Evaluate all variable definitions and top-level expressions within
;;      the library. (Macro definitions are not evaluated.)
;;
;; To visit a library at phase N:
;;
;;    * For each k >= 1, invoke at phase N+k any library that is imported
;;      by this library for .... (phase k), and that is not yet invoked at
;;      phase N+k.
;;    * For each k >= 0, visit at phase N+k any library that is imported by
;;      this library for .... (phase k), and that is not yet visited at phase
;;      N+k.
;;    * Evaluate all syntax definitions within the library.
;;      (Top-level expressions are not evaluated, and the right-hand sides
;;      of variable definitions are not evaluated.)

(define (expand-import t)
  (let ((template  (cadr t))
        (name      (string->symbol (caddr t))) 
        (renamer   (parametrize *phase* (+ (*phase*) 1)
                                (lambda ()
                                  (eval (expand (cadddr t))))))   
        (maybe-all (syntax-object->datum (cddddr t)))) 

    ;; For each k >= 0, visit at phase (*phase*) = N + k any library imported
    ;; by this library at phase k, and that is not yet visited at phase
    ;; N+k.

    ;; Import expressions for .... (phase k) have already been translated by
    ;; wrapping them in nested begin-for-syntax commands.  When expanded, these
    ;; will cause the global (*phase*) parameter to have been incremented to
    ;; N + k.
    
    (eval `(,name 'visited)) 

    ;; This is a little hack for making the "language"
    ;; available in all phases.
    
    (and (pair? maybe-all)
         (eq? (car maybe-all) 'all)
         (eval `(,name 'invoked))) 

    ;; Library has just been visited, so it is in the registry.
    
    (let* ((exports (library-exports (lookup-library name 'visited (*phase*)))))
      (for-each (lambda (export)
                  (let ((import-name (renamer (car export))))
                    (if import-name
                        (apply import! import-name (cdr export) template maybe-all))))
                exports)
      `(begin
         
         ;; This will cause visits to be properly chained.
         ;; See how expand-library post-processes this.  

         (for-syntax (quote (,name 'visited)))

         ;; When containing library invoked:
         ;;
         ;; Invoke at phase N any library that is imported by this library
         ;; for run time, and that is not yet invoked at phase N. 
         ;;
         ;; =AND=
         ;;
         ;; When containing library visited:
         ;;
         ;; For each k >= 1, invoke at phase N+k any library that is imported
         ;; by this library for .... (phase k), and that is not yet invoked at
         ;; phase N+k.

         ;; To see why the latter will happen, remember that if this expanded
         ;; import is already inside a begin-for-syntax, it will be evaluated
         ;; immediately after expansion.
         
         (,name 'invoked))))) 



;;;===========================================================================
;;;
;;; Compression stub:
;;;
;;;===========================================================================

;; Because close-environment is careful to keep sharing and
;; not record duplicate information, not much is needed here.
;; We need do nothing more than filter out the environments 
;; needed for the current library, discarding those that may have 
;; been accumulated when importing other libraries.

(define (uncompress-envs compressed) compressed)

(define (compress-envs envs)
  (alist-remove-duplicates (filter-current-library envs)))
 
(define (filter-current-library envs)
  (filter (lambda (env) 
            (string=? (cadr env) (*current-library-name*)))
          envs))


;;;===========================================================================
;;;
;;; Standard environments:
;;;
;;;===========================================================================

(install-expanders)

(define scheme-tokens '( 
                        ;; R5RS Scheme minus macros and literals:
                        
                        * 
                        + 
                        - 
                        ;; ...
                        /  
                        < 
                        <= 
                        = 
                        ;; =>   
                        > 
                        >= 
                        abs 
                        acos 
                        and 
                        append 
                        apply 
                        asin 
                        assoc
                        assq
                        assv
                        atan
                        begin
                        boolean?
                        caar
                        cadr
                        call-with-current-continuation
                        call-with-input-file
                        call-with-output-file
                        call-with-values
                        call/cc
                        case
                        car
                        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
                        ceiling
                        char->integer
                        char-alphabetic?
                        char-ci<=?
                        char-ci<?
                        char-ci=?
                        char-ci>=?
                        char-ci>?
                        char-downcase
                        char-lower-case?
                        char-numeric?
                        char-ready?
                        char-upcase
                        char-upper-case?
                        char-whitespace?
                        char<=?
                        char<?
                        char=?
                        char>=?
                        char>?
                        char?
                        close-input-port
                        close-output-port
                        complex?
                        cond
                        cons
                        cos
                        current-input-port
                        current-output-port
                        define
                        ;; define-syntax
                        delay
                        denominator
                        display
                        do
                        dynamic-wind
                        ;; else            
                        eof-object?
                        eq?
                        equal?
                        eqv?
                        error
                        eval
                        even?
                        exact->inexact
                        exact?
                        exp
                        expt
                        floor
                        for-each
                        force
                        gcd
                        if
                        imag-part
                        inexact->exact
                        inexact?
                        input-port?
                        integer->char
                        integer?
                        interaction-environment
                        lambda
                        lcm
                        length
                        let
                        let*
                        ;; let-syntax
                        letrec
                        ;; letrec-syntax
                        list
                        list->string
                        list->vector
                        list-ref
                        list-tail
                        list?
                        load
                        location
                        log
                        magnitude
                        make-polar
                        make-rectangular
                        make-string
                        make-vector
                        map
                        max
                        member
                        memq
                        memv
                        min
                        modulo
                        negative?
                        newline
                        not
                        null-environment
                        null?
                        number->string
                        number?
                        numerator
                        odd?
                        open-input-file
                        open-output-file
                        or
                        output-port?
                        pair?
                        peek-char
                        port?
                        positive?
                        procedure?
                        quasiquote
                        quote
                        quotient
                        rational?
                        rationalize
                        read
                        read-char
                        real-part
                        real?
                        remainder
                        reverse
                        round
                        scheme-report-environment
                        set!
                        set-car!
                        set-cdr!
                        sin
                        sqrt
                        string
                        string->list
                        string->number
                        string->symbol
                        string-append
                        string-ci<=?
                        string-ci<?
                        string-ci=?
                        string-ci>=?
                        string-ci>?
                        string-copy
                        string-fill!
                        string-length
                        string-ref
                        string-set!
                        string<=?
                        string<?
                        string=?
                        string>=?
                        string>?
                        string?
                        substring
                        symbol->string
                        symbol?
                        ;; syntax-rules
                        tan
                        transcript-off
                        transcript-on
                        truncate
                        unbound
                        ;; unquote
                        ;; unquote-splicing
                        values
                        vector
                        vector->list
                        vector-fill!
                        vector-length
                        vector-ref
                        vector-set!
                        vector?
                        with-input-from-file
                        with-output-to-file
                        write
                        write-char
                        zero?
                        
                        ;; Additions for macros and libraries:
                        
                        define-syntax
                        let-syntax
                        letrec-syntax
                        set-syntax!
                        
                        syntax
                        quasisyntax
                        identifier?
                        bound-identifier=?
                        free-identifier=?
                        literal-identifier=?
                        
                        make-capturing-identifier
                        datum->syntax-object       
                        syntax-object->datum
                        
                        begin-for-syntax
                        around-syntax
                        
                        syntax-error 
                        
                        library
                        export
                        indirect-export
                        import
                        
                        import-primitives
                        import-primitives-for-all
                        ))

(define (make-empty-env) (reflect-environment '()))

(define make-scheme-env
  (let ((env (map (lambda (name) 
                    (cons name `((all . ,name))))   
                  scheme-tokens)))
    (lambda ()
      (reflect-environment env))))

(define scheme-library (make-library "scheme://srfi-72"
                                     (map (lambda (token) (cons token token))
                                          scheme-tokens))) 

(*loaded-libraries* '())

(define (scheme://srfi-72 mode)
  (case mode
    ((unbind) (void))
    (else
     (*loaded-libraries* (alist-cons `(scheme://srfi-72 ,mode ,(*phase*)) 
                                     scheme-library
                                     (*loaded-libraries*))))))


;;;==========================================================================
;;;
;;; Debugging facilities:
;;;
;;;==========================================================================

;; Displays a syntax object in human-readable format:

(define (syntax-debug obj) 
  (sexp-map (lambda (leaf)
              (if (identifier? leaf) 
                  (symbolic-name leaf)
                  leaf))
            obj)) 

(define (syntax-error . args)
  (newline)
  (display "Syntax error:")
  (newline) (newline)
  (for-each (lambda (arg)
              (display (syntax-debug arg)) (display " "))
            args)
  (newline) (newline)
  (display "In source context:")
  (newline) (newline)
  (for-each (lambda (exp)
              (display "  ") 
              (display (syntax-debug exp))
              (newline) (newline))
            (*backtrace*))
  (error "Expansion stopped"))


;;;============================================================================
;;;
;;; Compiler and REPL integration:
;;;
;;;============================================================================

;; The procedure make-expander can be integrated with the host REPL and 
;; compiler.  The result of (make-expander) takes a sequence of source-level 
;; s-expressions and expands it to a sequence of core Scheme expressions that 
;; can be either compiled or fed to eval.  

;; To compile a file separately, invoke (make-expander) to make an 
;; expander with a clean environment.  A single invocation of the result
;; of (make-expander) will expand the sequence of expressions to core
;; Scheme.

;; For REPL use, reuse a single expander for subsequent evaluations
;; to ensure continuity of toplevel bindings.  

;; Each time an expander is reinvoked, a new renaming procedure 
;; is used, taking its initial toplevel binding environment from 
;; the previous invocation of the same expander.  We could have reused the 
;; same renaming procedure, but since the hygiene algorithm destructively 
;; updates bindings, we would have had to guard against inconsistent states 
;; in case an error occurred during expansion (relevant in a typical toplevel 
;; debugging cycle where the system is not necessarily reinitialized after 
;; each error).  
;; As a result, identifiers with the same symbolic name in 
;; separate toplevel expressions are not guaranteed to be 
;; bound-identifier=?  This is not a serious restriction.   


(define (make-expander)
  (let ((source-rename (make-renaming-procedure 0 source-colour (make-scheme-env) #f)))
    (lambda (exps)
      (*backtrace*            '())
      (*current-library-name* "")
      (*in-syntax*            #f)
      (*phase*                0)
      (set! source-rename
            (make-renaming-procedure 0
                                     source-colour 
                                     ;; This copies the toplevel binding environment 
                                     ;; from the previous invocation.
                                     (close-environment (source-rename 'dummy))
                                     #f))
      (map-in-order expand (datum->syntax source-rename exps)))))

;; This may be used to simulate a REPL in the meantime.

;; Due to the syntactic tower, we have the nice property that
;;
;; (for-each eval (expand-toplevel (list exp ...)))
;;     == (for-each (lambda (exp)
;;                    (eval (expand-toplevel (list exp)))))
;;
;; In other words, it doesn't matter whether we expand the whole 
;; sequence first and then evaluate or expand and evaluate one by one.   

(define repl 
  (let ((expand-toplevel (make-expander)))
    (lambda (exps)         
      (for-each (lambda (exp)
                  (for-each (lambda (result)
                              (display result)
                              (newline))
                            (call-with-values
                             (lambda ()
                               (eval (car (expand-toplevel (list exp)))))                       
                             list)))
                exps))))
    

;;;=========================================================================
;;;
;;; The usual macros:                                                    
;;;
;;;=========================================================================

;; Here we need to redefine all binding forms of the host Scheme.
;; We also need to redefine all forms that treat parts of their body
;; as literals.   


;; Expands a sequence of expressions using primitive renaming procedure
;; so that we can have access to primitives above without needing to import
;; things.

(define (primitive-expand exps)                     
  (let ((rename (make-primitive-renaming-procedure))) 
    (map-in-order expand 
                  (datum->syntax rename exps))))
    

;; For a production system, instead of eval, the following can be replaced 
;; by the result of primitive-expand, which can then be compiled with the 
;; rest of the file.

(for-each 
 eval 
 (primitive-expand 
  '(                            
    
    (define-syntax let
      (lambda (t)
        (if (and (pair? t)
                 (pair? (cdr t))
                 (identifier? (cadr t)))
            (scan-let (cons (car t) (cddr t))
                      (lambda (formals exps body)
                        (quasisyntax
                         ((letrec ((,(cadr t) (lambda ,formals ,@body))) ,(cadr t))
                          ,@exps))))
            (scan-let t
                      (lambda (formals exps body)
                        (quasisyntax
                         ((lambda ,formals ,@body) ,@exps)))))))
   
    
    (define-syntax letrec
      (lambda (t)
        (scan-let t
                  (lambda (formals exps body)
                    (let ((definitions (map (lambda (formal exp)
                                              (quasisyntax (define ,formal ,exp)))
                                            formals
                                            exps)))
                      (quasisyntax ((lambda () ,@definitions ,@body))))))))
    
    
    (define-syntax let*
      (lambda (t)
        (scan-let t
                  (lambda (formals exps body)
                    (let ((bindings (cadr t)))
                      (if (or (null? bindings)
                              (null? (cdr bindings)))
                          (quasisyntax (let ,bindings ,@body))
                          (quasisyntax (let (,(car bindings))
                                         (let* ,(cdr bindings) ,@body)))))))))
    
    
    (define-syntax (cond . clauses)
      (if (null? clauses)
          (syntax-error  "Cond: Must have at least one clause"))
      (car
       (let f ((clauses clauses))
         (if (null? clauses)
             '()
             (list
              (if (pair? clauses)
                  (let ((clause (car clauses))
                        (rest   (f (cdr clauses))))
                    (if (or (null? clause)
                            (not (list? clause)))
                        (syntax-error "Cond: Invalid clause" clause))
                    (if (and (literal-identifier=? (car clause) (syntax else))
                             (null? rest))
                        (quasisyntax (begin ,@(cdr clause)))
                        (if (null? (cdr clause)) 
                            (quasisyntax (let ((t ,(car clause)))
                                           (if t t ,@rest)))
                            (if (and (literal-identifier=? (cadr clause) (syntax =>))
                                     (pair? (cddr clause))
                                     (null? (cdddr clause)))
                                (quasisyntax (let ((t ,(car clause)))
                                               (if t (,(caddr clause) t) ,@rest)))
                                (quasisyntax (if ,(car clause)
                                                 (begin ,@(cdr clause))
                                                 ,@rest))))))
                  (syntax-error)))))))
    
    
    (define-syntax (case . rest)
      (or (pair? rest)
          (syntax-error))
      (let ((key (car rest))
            (temp (syntax temp))
            (clauses (cdr rest)))
        (or (list? clauses)
            (syntax-error))
        (quasisyntax
         (let ((,temp ,key))
           (cond
             ,@(map (lambda (clause)
                      (or (pair? clause)
                          (syntax-error "Case: Invalid clause:" clause))
                      (quasisyntax
                       (,(cond ((literal-identifier=? (car clause) (syntax else))
                                (car clause))
                               ((list? (car clause))
                                (quasisyntax (memv ,temp ',(car clause))))
                               (else
                                (syntax-error "Case: Invalid literals list:" (car clause))))
                         ,@(cdr clause))))
                    clauses))))))
    
    
    (define-syntax do
      (lambda (exp)
        (or (and (pair? (cdr exp))
                 (pair? (cddr exp)))
            (syntax-error))
        (let ((specs (cadr exp))
              (end (caddr exp))
              (body (cdddr exp))
              (loop (syntax loop)))
          (or (and (list? specs)
                   (every? do-spec? specs)
                   (list? end))
              (syntax-error))
          (quasisyntax
           (letrec ((,loop
                      (lambda ,(map car specs)
                        (cond ,end
                              (else ,@body
                                    (,loop
                                      ,@(map (lambda (spec)
                                               (if (null? (cddr spec))
                                                   (car spec)
                                                   (caddr spec)))
                                             specs)))))))
             (,loop ,@(map cadr specs)))))))
    
    
    (define (do-spec? s)                       
      (and (pair? s)
           (identifier? (car s))
           (pair? (cdr s))
           (let ((rest (cddr s)))
             (or (null? rest)
                 (and (pair? rest)
                      (null? (cdr rest)))))))

    
    ;; R6RS library support:

    (define-syntax export
      (lambda (form)
        (let ((x-sets (cdr form)))
          (or (and (list? x-sets)
                   (andmap export-set? x-sets))
            (syntax-error "Export: Invalid syntax:" form))
        (let loop ((x-sets x-sets)
                   (exports '()))
          (if (null? x-sets)
              (quasisyntax (export-0 ,@exports))
              (let ((x-set (car x-sets)))
                (if (identifier? x-set)
                    (loop (cdr x-sets)
                          (cons (list x-set x-set)
                                exports))
                    (let ((renames (cdr x-set)))
                      (loop (cdr x-sets)
                            (append (map reverse renames) exports))))))))))

          
    (define (export-set? x)
      (or (identifier? x)
          (and (list? x)
               (not (null? x))
               (literal-identifier=? (car x) (syntax rename))
               (andmap (lambda (e)
                         (and (list? e)
                              (= (length e) 2)
                              (andmap identifier? e)))
                       (cdr x)))))
    
     
    (define-syntax indirect-export
      (lambda (form)
        (or (and (list? (cdr form))
                 (andmap indirect-spec? (cdr form)))
            (syntax-error "Indirect-export: Invalid syntax:" form))
        (quasisyntax 
         (export ,@(apply append (map cdr (cdr form)))))))
    
    (define (indirect-spec? e)
      (and (list? e)
           (>= (length e) 1)
           (andmap identifier? e)))

    

    (define-syntax import
      (lambda (form)
        (or (and (list? (cdr form))
                 (andmap import-spec? (cdr form)))
            (syntax-error "Import: Invalid syntax:" form))
        (quasisyntax
         (begin
           ,@(map (lambda (spec)
                    (translate-import-spec (car form) spec))
                  (cdr form))))))

    ;; Here k is the source-level |import| keyword, which determines
    ;; the hygienic context into which the imports are inserted.
    
    (define (translate-import-spec k e . maybe-all)
      (cond ((for? e)
             (quasisyntax
              (begin ,@(map (lambda (phase)
                              (let loop ((phase phase))
                                (cond ((literal-identifier=? phase (syntax run))    (loop 0))
                                      ((literal-identifier=? phase (syntax expand)) (loop 1))
                                      ((literal-identifier=? phase (syntax all)) 
                                       (translate-import-spec k (cadr e) (syntax all)))
                                      ((= phase 0) 
                                       (translate-import-spec k (cadr e)))
                                      (else
                                       (quasisyntax
                                        (begin-for-syntax ,(loop (- phase 1))))))))
                            (cddr e)))))
            (else
             ;; e is import-set
             (let loop ((e e)
                        (rename (quasisyntax (lambda (x) x))))
               (if (lib-path? e) 
                   (quasisyntax (import-0 ,k ,e ,rename . ,maybe-all))
                   (loop (cadr e)
                         (quasisyntax
                          (lambda (x)
                            (,rename
                             ,(cond
                               ((literal-identifier=? (car e) (syntax only))
                                (quasisyntax
                                 (if (memv x ',(cddr e))
                                     x
                                     #f)))
                               ((literal-identifier=? (car e) (syntax except))
                                (quasisyntax
                                 (if (not (memv x ',(cddr e)))
                                     x
                                     #f)))
                               ((literal-identifier=? (car e) (syntax add-prefix))
                                (quasisyntax
                                 (if x
                                     (string->symbol
                                      (string-append (symbol->string ',(caddr e))
                                                     (symbol->string x)))
                                     #f)))
                               ((literal-identifier=? (car e) (syntax rename))
                                (quasisyntax
                                 (case x
                                   ,@(map (lambda (old+new)
                                            (quasisyntax
                                             ((,(car old+new)) ',(cdr old+new))))
                                          (cddr e))
                                   (else x))))))))))))))
                                                

    (define (import-spec? e)
      (or (import-set? e)
          (for? e)))

    (define (import-set? e)
      (or (lib-path? e)
          (and (pair? e)
               (or (and (or (literal-identifier=? (car e) (syntax only))
                            (literal-identifier=? (car e) (syntax except)))
                        (list? e)
                        (>= (length e) 2)
                        (import-set? (cadr e))
                        (andmap identifier? (cddr e)))
                   (and (literal-identifier=? (car e) (syntax add-prefix))
                        (list? e)
                        (= (length e) 3)
                        (import-set? (cadr e))
                        (identifier? (caddr e)))
                   (and (literal-identifier=? (car e) (syntax rename))
                        (list? e)
                        (>= (length e) 2)
                        (import-set? (cadr e))
                        (andmap (lambda (e)
                                  (and (list? e)
                                       (= (length e) 2)
                                       (andmap identifier? e)))
                                (cddr e)))))))

    (define (lib-path? e)
      (string? e))
                                     
    (define (for? e)
      (and (list? e)
           (>= (length e) 2)
           (literal-identifier=? (car e) (syntax for))
           (import-set? (cadr e))
           (andmap import-phase? (cddr e))))

    (define (import-phase? e)
      (or (literal-identifier=? e (syntax run))
          (literal-identifier=? e (syntax expand))
          (literal-identifier=? e (syntax all))
          (and (integer? e)
               (>= e 0))))

    
    (define-syntax import-primitives
      (lambda (form)
        (expand-import-primitives form))) 
    
    (define-syntax import-primitives-for-all
      (lambda (form)
        (expand-import-primitives form 'all)))
    
    (define expand-import-primitives
      (lambda (form . maybe-phase)
        (or (and (list? (cdr form))
                 (every? identifier? (cdr form)))
            (syntax-error))
        (let ((k     (car form))
              (names (map syntax-object->datum (cdr form))))
          (for-each (lambda (name)
                      (apply import! name name k maybe-phase))
                    names)
          (syntax (void)))))
    
    
    ))) ; REPL

(load "simple-syntax-case.scm")

(repl '
 (

  ;; Compose with syntax-case:
  
  (library "scheme://r6rs" "scheme://srfi-72"
    
    (import "syntax-case")
    
    (export * 
            + 
            - 
            ;; ...
            /  
            < 
            <= 
            = 
            ;; =>   
            > 
            >= 
            abs 
            acos 
            and 
            append 
            apply 
            asin 
            assoc
            assq
            assv
            atan
            begin
            boolean?
            caar
            cadr
            call-with-current-continuation
            call-with-input-file
            call-with-output-file
            call-with-values
            call/cc
            case
            car
            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
            ceiling
            char->integer
            char-alphabetic?
            char-ci<=?
            char-ci<?
            char-ci=?
            char-ci>=?
            char-ci>?
            char-downcase
            char-lower-case?
            char-numeric?
            char-ready?
            char-upcase
            char-upper-case?
            char-whitespace?
            char<=?
            char<?
            char=?
            char>=?
            char>?
            char?
            close-input-port
            close-output-port
            complex?
            cond
            cons
            cos
            current-input-port
            current-output-port
            define
            ;; define-syntax
            delay
            denominator
            display
            do
            dynamic-wind
            ;; else            
            eof-object?
            eq?
            equal?
            eqv?
            error
            eval
            even?
            exact->inexact
            exact?
            exp
            expt
            floor
            for-each
            force
            gcd
            if
            imag-part
            inexact->exact
            inexact?
            input-port?
            integer->char
            integer?
            interaction-environment
            lambda
            lcm
            length
            let
            let*
            ;; let-syntax
            letrec
            ;; letrec-syntax
            list
            list->string
            list->vector
            list-ref
            list-tail
            list?
            load
            location
            log
            magnitude
            make-polar
            make-rectangular
            make-string
            make-vector
            map
            max
            member
            memq
            memv
            min
            modulo
            negative?
            newline
            not
            null-environment
            null?
            number->string
            number?
            numerator
            odd?
            open-input-file
            open-output-file
            or
            output-port?
            pair?
            peek-char
            port?
            positive?
            procedure?
            quasiquote
            quote
            quotient
            rational?
            rationalize
            read
            read-char
            real-part
            real?
            remainder
            reverse
            round
            scheme-report-environment
            set!
            set-car!
            set-cdr!
            sin
            sqrt
            string
            string->list
            string->number
            string->symbol
            string-append
            string-ci<=?
            string-ci<?
            string-ci=?
            string-ci>=?
            string-ci>?
            string-copy
            string-fill!
            string-length
            string-ref
            string-set!
            string<=?
            string<?
            string=?
            string>=?
            string>?
            string?
            substring
            symbol->string
            symbol?
            ;; syntax-rules
            tan
            transcript-off
            transcript-on
            truncate
            unbound
            ;; unquote
            ;; unquote-splicing
            values
            vector
            vector->list
            vector-fill!
            vector-length
            vector-ref
            vector-set!
            vector?
            with-input-from-file
            with-output-to-file
            write
            write-char
            zero?
            
            ;; Additions for macros and libraries:
            
            define-syntax
            let-syntax
            letrec-syntax
            set-syntax!
            
            syntax
            quasisyntax
            identifier?
            bound-identifier=?
            free-identifier=?
            literal-identifier=?
            
            make-capturing-identifier
            datum->syntax-object       
            syntax-object->datum
            
            begin-for-syntax
            around-syntax
            
            syntax-error 
           
            library
            export
            indirect-export
            import
            
             ;; From syntax-case library:
            
            syntax-case
            with-syntax
            syntax-rules))
 
  
  )) ; repl
            
            
