2.sf

; #F, part 2:  SFC macroexpander 

; Adapted from Al Petrofsky's alexp macroexpander for scheme
 
; This version is derived from alexpander.scm v1.65 2007/11/05 02:50:34,
; available on the net at <http://petrofsky.org/src/alexpander.scm>.
; See the original for documentation and extensive comments.
; Original alexpander.scm license:

; Copyright 2002-2004,2006,2007 Al Petrofsky <alexpander@petrofsky.org>
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
; 
;   Redistributions of source code must retain the above copyright
;     notice, this list of conditions and the following disclaimer.
; 
;   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.
; 
;   Neither the name of the author nor the names of its contributors
;     may be used to endorse or promote products derived from this
;     software without specific prior written permission.
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "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 COPYRIGHT
; HOLDERS OR CONTRIBUTORS 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.

; Modifications (esl): 
;
;  o  derived forms removed from null environment
;  o  added builtins letcc, withcc, removed delay
;  o  added builtins %prim %prim? %prim! %prim?! %prim* %prim*! %prim*? %prim*?! 
;  o  added builtins %quote %const %definition %localdef
;  o  added x-error for expander errors
;  o  added syntax-lambda; let-syntax became a derived form
;  o  literals are decomposed into %quote / %const
;  o  modified to get rid of variadics, not needed for self-compile
;  o  #&() patern matcher extensions
;  o  (syntax-rules () [_ templ]) supports simple identifier-syntax

#fload "0.sf"
; also refers to read/1

;------------------------------------------------------------------------------

; errors

(define (x-error* reason args)
  (let ([ep (current-error-port)])
    (newline ep)
    (display "Syntax error: " ep)
    (display reason ep)
    (for-each 
      (lambda (arg) 
        (if (string? arg) (display arg ep) (write (unwrap-vecs arg) ep))) 
      args)
    (newline ep)
    (reset)))

(define-syntax x-error
  (syntax-rules () [(_ r a ...) (x-error* r (list a ...))]))


; replacements for variadics

(define (append* lst)
  (cond [(null? lst) '()]
        [(null? (cdr lst)) (car lst)]
        [else (append (car lst) (append* (cdr lst)))]))

(define (apply-map-list lst)
  (let loop ([lst lst] [res '()])
    (if (ormap null? lst)
        (reverse res)
        (loop (map cdr lst) (cons (map car lst) res)))))

(define (pairwise-andmap pred? lst)
  (or (null? lst)
    (let ([x (car lst)] [r (cdr lst)])
      (or (null? r)
        (and (pred? x (car r))
          (pairwise-andmap pred? r))))))


; representation helpers

(define (unsigned-representation-width x)
  (and (not (negative? x))
       (let loop ([rb 8] [rb-max 255])
         (cond [(<= x rb-max) rb]
               [(< rb 24) (loop (+ rb 8) (+ (* rb-max 256) 255))]
               [else #f]))))

(define (signed-representation-width x)
  (let loop ([rb 8] [rb-min -128] [rb-max 127])
    (cond [(<= rb-min x rb-max) rb]
          [(< rb 24) (loop (+ rb 8) (* rb-min 256) (+ (* rb-max 256) 255) )]
          [else #f])))
               
(define (char-safe? c)
  (and (char<=? c #\~) (char>=? c #\space)
       (not (char=? c #\\)) (not (char=? c #\"))
       (not (char=? c #\')) (not (char=? c #\$))))

(define (fold-max base lst)
  (if (null? lst) base
      (let ([next (car lst)])
        (fold-max (and base next (max base next))
          (cdr lst)))))

(define (decompose-literal x) 
  (cond
    [(null? x)
     (list '%const 'null)]
    [(list? x)
     (list* '%const 'list
       (map decompose-literal x))]
    [(pair? x)
     (list '%const 'pair
       (decompose-literal (car x))
       (decompose-literal (cdr x)))]
    [(box? x)
     (list '%const 'box
       (decompose-literal (unbox x)))]
    [(vector? x)
     (list* '%const 'vector
       (map decompose-literal (vector->list x)))]
    [(char? x)
     (if (char-safe? x)
         (list '%const 'char (string x))
         (let ([x (char->integer x)])
           (list '%const 'char
             (unsigned-representation-width x)
             (number->string x))))]
    [(string? x)
     (let* ([c* (string->list x)] [l (map char->integer c*)])
       (if (andmap char-safe? c*)
           (list '%const 'string x)
           (list* '%const 'string
             (fold-max 8 (map unsigned-representation-width l))
             (map number->string l))))]
    [(symbol? x)
     (let* ([s (symbol->string x)] [c* (string->list s)] [l (map char->integer c*)])
       (if (andmap char-safe? c*)
           (list '%const 'symbol s)
           (list* '%const 'symbol
             (fold-max 8 (map unsigned-representation-width l))
             (map number->string l))))]
    [(boolean? x)
     (list '%const 'boolean (if x "1" "0"))]
    [(fixnum? x)
     (list '%const 'integer
       (signed-representation-width x)
       (if (negative? x) '- '+) 
       (number->string (abs x))
       10)]
    [(flonum? x)
     (list '%const 'decimal 'e (number->string x))]
    [(procedure? x) ; wrapped 'micro-syntax'
     (cons '%const (x))]
    [else (x-error "unsupported literal: " x)]))


;------------------------------------------------------------------------------

; alexpander

(define (sid? sexp) (or (symbol? sexp) (renamed-sid? sexp)))
(define (renamed-sid? sexp) (and (vector? sexp) (< 1 (vector-length sexp))))
(define (svector? sexp) (and (vector? sexp) (= 1 (vector-length sexp))))
(define (svector->list sexp) (vector-ref sexp 0))
(define (list->svector l) (vector l))

(define (make-sid name renamed-id location)
  (if (eq? name location)
      (vector name renamed-id)
      (vector name renamed-id location)))

(define (sid-name sid) (if (symbol? sid) sid (vector-ref sid 0)))
(define (sid-id sid) (if (symbol? sid) sid (vector-ref sid 1)))
(define (sid-location sid)
  (if (symbol? sid)
      sid
      (vector-ref sid (if (= 2 (vector-length sid)) 0 2))))

(define (list1? x) (and (pair? x) (null? (cdr x))))
(define (list2? x) (and (pair? x) (list1? (cdr x))))

(define (map-vecs f x)
  (define (mv2 x)
    (if (vector? x)
        (f x)
        (and (pair? x)
             (let ([a (car x)] [b (cdr x)])
               (let ([a-mapped (mv2 a)])
                 (if a-mapped
                     (cons a-mapped (mv b))
                     (let ([b-mapped (mv2 b)])
                       (and b-mapped (cons a b-mapped)))))))))
  (define (mv x) (or (mv2 x) x))
  (mv x))

(define (wrap-vec v) (list->svector (wrap-vecs (vector->list v))))
(define (wrap-vecs input) (map-vecs wrap-vec input))
(define (unwrap-vec v-sexp)
  (if (= 1 (vector-length v-sexp))
      (list->vector (unwrap-vecs (svector->list v-sexp)))
      (vector-ref v-sexp 0)))
(define (unwrap-vecs sexp) (map-vecs unwrap-vec sexp))

(define (make-code output) (list output))
(define (make-builtin name) (list '(builtin) name))

(define (variable? val) (symbol? val))
(define (expanded-code? val) (list1? val))
(define (code-output code) (car code))

(define (syntax? val) (list2? val))
(define (builtin? syntax) (eq? 'builtin (caar syntax)))
(define (builtin-name builtin) (cadr builtin))

(define (expander? syntax) (not (builtin? syntax)))
(define (make-expander form env) (list form env))
(define (expander-form expd) (car expd))
(define (expander-env expd) (cadr expd))


(define (acons key val alist) (cons (cons key val) alist))

(define empty-env '())
(define empty-store '())

(define (lookup-sid sid env)
  (cond [(assv (sid-id sid) env) => cdr] [else (sid-location sid)]))

(define (lookup-location location store)
  (cond [(assv location store) => cdr]
        [(symbol? location) (symloc->var location)]
        [else #f]))

(define (lookup2 sid env store)
  (or (lookup-location (lookup-sid sid env) store)
      (x-error (string-append
                 "premature use of keyword bound by letrec-syntax"
                 " (or an internal define-syntax): ")
             sid)))

(define (extend-env env id location) (acons id location env))
(define (extend-store store loc val) (acons loc val store))

(define (substitute-in-store store loc val)
  (let ([store
         (if (assv loc store)
             (let loop ([store store])
               (let ([p (car store)])
                 (if (eqv? loc (car p))
                     (cdr store)
                     (cons p (loop (cdr store))))))
             store)])
    (if (and (symbol? loc) (eq? val (symloc->var loc)))
        store
        (acons loc val store))))

(define (symloc->var sym)
  (define str (symbol->string sym))
  (define (rename) (string->symbol (string-append "_" str "_")))
  (case sym
    [(begin define if lambda letrec quote set! letcc withcc) (rename)]
    [(%prim %prim? %prim! %prim?! %prim* %prim*! %prim*? %prim*?!) (rename)]
    [(%quote %const %definition %localdef) (rename)] 
    [else (if (and (positive? (string-length str))
                   (char=? #\_ (string-ref str 0)))
              (rename)
              sym)]))

(define (intloc->var intloc sid)
  (let ([str (symbol->string (sid-name sid))])
    (string->symbol
      (string-append "_" str "_" (number->string intloc)))))

(define (loc->var loc sid)
  (if (symbol? loc) (symloc->var loc) (intloc->var loc sid)))

(define (make-begin outputs)
  (if (list1? outputs) (car outputs) (cons 'begin outputs)))

(define (expand-lambda formals expr id-n env store loc-n)
  (define (flatten-dotted x)
    (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
  (define (dot-flattened x)
    (if (null? (cdr x))
        (car x)
        (cons (car x) (dot-flattened (cdr x)))))
  (let* ([dotted? (not (list? formals))]
         [flattened (if dotted? (flatten-dotted formals) formals)])
    (define (check x)
      (or (sid? x)
          (x-error "non-identifier: " x " in lambda formals: " formals))
      (if (member x (cdr (member x flattened)))
          (x-error "duplicate variable: " x " in lambda formals: " formals)))
    (begin
      (for-each check flattened)
      (let loop ([formals flattened] [rvars '()]
                 [env env] [store store] [loc-n loc-n])
        (if (not (null? formals))
            (let* ([var (intloc->var loc-n (car formals))]
                   [env (extend-env env (sid-id (car formals)) loc-n)]
                   [store (extend-store store loc-n var)])
              (loop (cdr formals) (cons var rvars)
                env store (+ 1 loc-n)))
            (let* ([vars (reverse rvars)]
                   [vars (if dotted? (dot-flattened vars) vars)])
              (list vars (expand-expr expr id-n env store loc-n))))))))

(define (expand-letcc formal expr id-n env store loc-n)
  (if (sid? formal)
      (let* ([var (intloc->var loc-n formal)]
             [env (extend-env env (sid-id formal) loc-n)]
             [store (extend-store store loc-n var)]
             [loc-n (+ 1 loc-n)]) ;*** fixed in 153s
        (list var (expand-expr expr id-n env store loc-n)))
      (x-error "non-identifier: " formal " used as letcc formal")))

(define (check-syntax-bindings bindings)
  (or (list? bindings)
      (x-error "non-list syntax bindings list: " bindings))
  (for-each
    (lambda (b)
      (or (and (list2? b) (sid? (car b)))
          (x-error "malformed syntax binding: " b)))
    bindings)
  (do ([bs bindings (cdr bs)]) [(null? bs)]
    (let ([dup (assoc (caar bs) (cdr bs))])
      (if dup
          (x-error "duplicate bindings for a keyword: " (car bs)
            " and: " dup)))))

(define (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
  (let loop ([bs bindings] [vals '()] [store store] [loc-n loc-n])
    (if (not (null? bs))
        (expand-val (cadar bs) id-n syntax-env store loc-n
          (lambda (val store loc-n)
            (loop (cdr bs) (cons val vals) store loc-n)))
        (let loop ([store store] [vals (reverse vals)] [bs bindings])
          (if (not (null? vals))
              (let* ([loc (lookup-sid (caar bs) ienv)]
                     [store (extend-store store loc (car vals))])
                (loop store (cdr vals) (cdr bs)))
              (k store loc-n))))))

(define (apply-expander syntax sexp id-n env store loc-n lsd? ek sk dk bk)
  (case (sid-name (caar syntax))
    [(syntax-rules)
     (apply-synrules syntax sexp id-n env
       (lambda (sexp id-n) 
         (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)))]
    [(syntax-lambda)
     (or ek sk lsd? (pair? sexp)
         (x-error "syntax lambda applied in bad context: " sexp))
     (let ([formals (cadar syntax)] [sexps (cdr sexp)] 
           [body (cddar syntax)] [denv (cadr syntax)])
       (or (= (length formals) (length sexps))
          (x-error "incorrect number of arguments to syntax lambda: " sexp))
       (let loop ([ids formals] [loc-n loc-n] [ienv denv])
         (if (not (null? ids))
             (loop (cdr ids) (+ loc-n 1)
               (extend-env ienv (sid-id (car ids)) loc-n))
             (expand-syntax-bindings
               (map list formals sexps)
               id-n env ienv store loc-n
               (lambda (store loc-n)
                 (expand-body body
                   id-n ienv store loc-n lsd? ek sk
                   (and lsd? dk) (and lsd? bk)))))))]     
    [else
     (x-error "invalid expander: " syntax)]))

(define (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
  (define (get-k k sexp name)
    (or k (x-error (string-append name " used in bad context: ") sexp)))
  (define (get-ek sexp) (get-k ek sexp "expression"))
  (define (get-sk sexp) (get-k sk sexp "syntax"))
  (define (get-dk sexp) (get-k dk sexp "definition"))
  (define (expand-subexpr sexp)
    (expand-expr sexp id-n env store loc-n))
  (define (expand-subexpr-top sexp) ;++ : expand converted constants in empty env
    (expand-expr sexp id-n empty-env store loc-n))
  (define (handle-syntax-use syntax head store loc-n)
    (let* ([tail (cdr sexp)] [sexp (cons head tail)])
      (if (expander? syntax)
          (apply-expander syntax sexp id-n env store loc-n lsd? ek sk dk bk)
          (let ([builtin (builtin-name syntax)] [len (length tail)])
            (define (handle-expr-builtin)
              (define (expr-assert test)
                (or test 
                  (x-error "malformed " builtin " expression: " sexp)))
              (case builtin
                [(lambda)
                 (expr-assert (= len 2))
                 (cons 'lambda 
                   (expand-lambda
                     (car tail) (cadr tail) id-n env store loc-n))]
                [(quote)
                 (expr-assert (= len 1))
                 ;(list 'quote (unwrap-vecs (car tail)))
                 ;(expand-subexpr (decompose-literal (unwrap-vecs (car tail))))
                 ;** : changed to expand-subexpr-top (uses empty-env) in 160s
                 ;** : moved (list '%quote ...) into expand-subexpr-top call
                 (expand-subexpr-top (list '%quote (decompose-literal (unwrap-vecs (car tail)))))]
                [(set!)
                 (expr-assert (and (= len 2) (sid? (car tail))))
                 (let ([var (lookup2 (car tail) env store)])
                   (or (variable? var)
                       (x-error "attempt to set a keyword: " sexp))
                   (list 'set! var (expand-subexpr (cadr tail))))]
                [(if)
                 (expr-assert (<= 2 len 3))
                 (cons 'if (map expand-subexpr tail))]
                [(letcc)
                 (expr-assert (= len 2))
                 (cons 'letcc
                   (expand-letcc
                     (car tail) (cadr tail) id-n env store loc-n))]
                [(withcc)
                 (expr-assert (= len 2))
                 (cons 'withcc (map expand-subexpr tail))]
                [(%quote)
                 (expr-assert (= len 1))
                 (list '%quote (expand-subexpr (car tail)))]
                [(%const)
                 (expr-assert (>= len 1))
                 (cons '%const tail)]
                [(%definition %localdef)
                 (expr-assert (and (= len 1) (string? (car tail))))
                 (cons builtin tail)]
                [(%prim %prim? %prim! %prim?! %prim* %prim*! %prim*? %prim*?!)
                 (expr-assert 
                   (and (>= len 1)
                     (let ok? ([sf (car tail)]) 
                       (or (string? sf) (and (list? sf) (andmap ok? sf))
                         (and (vector? sf) (ok? (vector->list sf)))))))
                 (cons builtin (cons (car tail) (map expand-subexpr (cdr tail))))]))
            (case builtin
              [(syntax-rules)
               (if (< len 1)
                   (x-error "empty syntax-rules form: " sexp))
               (let ([syn (compile-syntax-rules sexp env)])
                 ((get-sk sexp) syn sexp store loc-n))]
              [(syntax-lambda)
               (if (< len 2)
                   (x-error "malformed syntax-lambda form: " sexp))
               (let ([syn (compile-syntax-lambda sexp env)])
                 ((get-sk sexp) syn sexp store loc-n))]
              [(begin)
               (cond
                 [bk (bk sexp id-n env store loc-n)]
                 [(null? tail)
                  (x-error "empty begin expression: " sexp)]
                 [else (make-begin (map expand-subexpr tail))])]
              [(define define-syntax)
               (or (and (= 2 len) (sid? (car tail)))
                   (and (= 1 len) (eq? builtin 'define))
                   (x-error "malformed definition: " sexp))
               ((get-dk sexp) builtin sexp id-n env store loc-n)]
              [else ((get-ek sexp) (handle-expr-builtin))])))))
  (define (handle-combination output)
    (ek (if (and (pair? output) (eq? 'lambda (car output))
                 (null? (cadr output)) (null? (cdr sexp)))
            (caddr output)
            (cons output (map expand-subexpr (cdr sexp))))))
  (cond
    [(sid? sexp)
     (let ([val (lookup2 sexp env store)])
       (if (syntax? val)
           (if (and (not sk) ek (expander? val)) 
               ;++ : support for identifier-syntax
               (apply-expander val sexp id-n env store loc-n #f ek #f #f #f)
               ((get-sk sexp) val sexp store loc-n))
           ((get-ek sexp)
            (if (expanded-code? val) (code-output val) val))))]
    [(null? sexp)
     (x-error "null used as an expression or syntax: " sexp)]
    [(list? sexp)
     (expand-any (car sexp)
       id-n env store loc-n #f
       (and ek handle-combination) handle-syntax-use
       #f #f)]
    [(or (number? sexp) (boolean? sexp) (string? sexp) (char? sexp)
         (procedure? sexp)) ; wrapped 'micro-syntax'
     ;((get-ek sexp) sexp)
     ;(expand-any (decompose-literal sexp) 
     ;   id-n env store loc-n lsd? ek sk dk bk)
     ;** : changed to empty-env in 160s
     ;** : moved (list '%quote ...) into expand-any call 
     (expand-any (list '%quote (decompose-literal sexp)) 
        id-n empty-env store loc-n lsd? ek sk dk bk)]
    [else
     (x-error (cond [(pair? sexp) "improper list: "]
                    [(vector? sexp) "vector: "]
                    [else "unexpected type of s-expression: "])
       sexp " used as an expression, syntax, or definition.")]))

(define (expand-val sexp id-n env store loc-n k)
  (expand-any sexp 
    id-n env store loc-n #f
    (lambda (output) (k (make-code output) store loc-n))
    (lambda (syn error-sexp store loc-n) (k syn store loc-n))
    #f #f))

(define (expand-expr sexp id-n env store loc-n)
  (expand-any sexp id-n env store loc-n #f (lambda (x) x) #f #f #f))

(define (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
  (define
   (expand-def sexp vds sds exprs id-n env store loc-n k ek)
    (define (dk builtin sexp id-n env store loc-n)
      (if (list2? sexp)
          (if exprs
              (k vds sds (cons (cadr sexp) exprs)
                 id-n env store loc-n)
              (x-error "non-syntax definition in a syntax body: " sexp))
          (let* ([sid (cadr sexp)]
                 [id (sid-id sid)]
                 [env (extend-env env id loc-n)])
            (define (check def)
              (if (eqv? id (sid-id (cadr def)))
                  (x-error "duplicate internal definitions: " def
                    " and: " sexp)))
            (begin
              (for-each check sds)
              (for-each check vds)
              (case builtin
                [(define-syntax)
                 (k vds (cons sexp sds) exprs
                    id-n env store (+ loc-n 1))]
                [(define)
                 (or exprs
                     (x-error "variable definition in a syntax body: " sexp))
                 (let* ([var (intloc->var loc-n sid)]
                        [store (extend-store store loc-n var)]
                        [loc-n (+ loc-n 1)])
                   (k (cons sexp vds) sds exprs
                      id-n env store loc-n))])))))
    (define (bk sexp id-n env store loc-n)
      (let loop ([sexps (cdr sexp)] [vds vds] [sds sds] [exprs exprs]
                 [id-n id-n] [env env] [store store] [loc-n loc-n] [ek ek])
        (if (null? sexps)
            (k vds sds exprs id-n env store loc-n)
            (expand-def (car sexps) vds sds exprs
              id-n env store loc-n
              (lambda (vds sds exprs id-n env store loc-n)
                (loop (cdr sexps) vds sds exprs
                  id-n env store loc-n #f))
              (and ek
                   (lambda (out)
                     (define (expand-one sexp)
                       (expand-expr sexp id-n env store loc-n))
                     (let ([rest (map expand-one (cdr sexps))])
                       (ek (make-begin (cons out rest))))))))))
    (expand-any sexp id-n env store loc-n #f ek #f dk bk))
  (let loop ([first (car sexps)] [rest (cdr sexps)] 
             [vds '()] [sds '()] [exprs (and ek '())] 
             [id-n id-n] [env env] [store store] [loc-n loc-n])
    (define (finish-body boundary-exp-output)
      (expand-syntax-bindings
        (map cdr sds) id-n env env store loc-n
        (lambda (store loc-n)
          (define (iexpand sexp)
            (expand-expr sexp id-n env store loc-n))
          (define (expand-vd vd)
            (list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
          (define (make-letrec bindings expr)
            (if (null? bindings) expr (list 'letrec bindings expr)))
          (if (and (null? rest) (null? vds) (not (pair? exprs)))
              (expand-any first id-n env store loc-n lsd? ek sk dk bk)
              (ek (make-letrec
                    (map expand-vd (reverse vds))
                    (let ([body-exprs-output
                           (if (null? rest)
                               (list (iexpand first))
                               (cons
                                 boundary-exp-output 
                                 (map iexpand rest)))])
                      (make-begin
                        (append (map iexpand (reverse exprs))
                                body-exprs-output)))))))))
    (if (null? rest)
        (finish-body #f)
        (expand-def first vds sds exprs id-n env store loc-n
          (lambda (vds sds exprs id-n env store loc-n)
            (loop (car rest) (cdr rest) vds sds exprs
                  id-n env store loc-n))
          (and ek finish-body)))))

(define (expand-top-level-forms forms store loc-n k)
  (define (finalize store loc-n acc) (k (reverse acc) store loc-n))
  (let expand ([sexps (wrap-vecs forms)] [id-n 0] [env empty-env]
               [store store] [loc-n loc-n] [acc '()] [k finalize])
    (if (null? sexps)
        (k store loc-n acc)
        (let ([rest (cdr sexps)])
          (define (ek output)
            (expand rest id-n env store loc-n (cons output acc) k))
          (define (dk builtin sexp id-n* env* store loc-n)
            (if (list2? sexp)
                (ek (expand-expr (cadr sexp) id-n* env* store loc-n))
                (let* ([tail (cdr sexp)] [sid (car tail)]
                       [loc (sid-location sid)] [init (cadr tail)])
                  (if (eq? builtin 'define)
                      (let* ([expr (expand-expr init id-n* env* store loc-n)]
                             [var (loc->var loc sid)]
                             [acc (cons (list 'define var expr) acc)]
                             [store (substitute-in-store store loc var)])
                        (expand rest id-n env store loc-n acc k))
                      (expand-val init id-n* env* store loc-n
                        (lambda (val store loc-n)
                          (let ([store (substitute-in-store store loc val)])
                            (expand rest id-n env store loc-n acc k))))))))
          (define (bk sexp id-n* env* store loc-n)
            (expand (cdr sexp) id-n* env* store loc-n acc
              (lambda (store loc-n acc)
                (expand rest id-n env store loc-n acc k))))
          (expand-any (car sexps) id-n env store loc-n #t ek #f dk bk)))))

(define (compile-syntax-lambda synlambda env)
  (let ([formals (cadr synlambda)])
    (define (check x)
        (or (sid? x)
            (x-error "non-identifier: " x 
              " in syntax-lambda formals: " formals))
        (if (member x (cdr (member x formals)))
            (x-error "duplicate variable: " x 
              " in syntax-lambda formals: " formals)))
    (for-each check formals) 
    (make-expander (cons 'syntax-lambda (cdr synlambda)) env))) ;*** fixed in 153s
  
;;++ : pattern matcher extension

(define (sbox->sexp-list b)  (cdr (unbox b)))

(define (pattern-sbox->sexp b) (cadr (unbox b)))

(define (pattern-sbox? b)
  (and (box? b) (list2? (unbox b))
    (memq (car (unbox b))
      '(number? string? id?))))

(define (pattern-sbox->test b)
  (case (car (unbox b))
    [(number?)
     (lambda (sexp env) (number? sexp))]
    [(string?)
     (lambda (sexp env) (string? sexp))]
    [(id?)
     (lambda (sexp env) (sid? sexp))]))

(define (template-sbox->sexp b) (cdr (unbox b)))

(define (template-sbox? b)
  (and (box? b) (pair? (unbox b))
    (let ([l (unbox b)])
      (case (car l)
        [(number->string) (list1? (cdr l))]
        [(string->number) (list1? (cdr l))]
        [(list->string) (list1? (cdr l))]
        [(string->list) (list1? (cdr l))]
        [(length) (list1? (cdr l))]
        [(string-append) (list? (cdr l))]
        [(+ *) (list? (cdr l))]
        [(id->string) (list1? (cdr l))]
        [(string->id) (list1? (cdr l))]
        [else #f]))))

(define (template-sbox->conv b)
  (case (car (unbox b))
    [(number->string)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (number? sexp)
             (number->string sexp)
             (x-error "number->string: not a number: " sexp))))]
    [(string->number)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (string? sexp)
             (string->number sexp)
             (x-error "string->number: not a string: " sexp))))]
    [(list->string)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (and (list? sexp) (andmap char? sexp))
             (list->string sexp)
             (x-error "list->string: not a list of chars: " sexp))))]
    [(string->list)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (string? sexp)
             (string->list sexp)
             (x-error "string->list: not a string: " sexp))))]
    [(length)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (list? sexp)
             (length sexp)
             (x-error "length: not a list: " sexp))))]
    [(string-append)
     (lambda (sexps env)
       (let loop ([sexps sexps])
         (cond [(null? sexps) ""]
               [(string? (car sexps))
                (string-append (car sexps) (loop (cdr sexps)))]
               [else (x-error "string-append: not a string: " (car sexps))])))]
    [(+)
     (lambda (sexps env)
       (let loop ([sexps sexps])
         (cond [(null? sexps) 0]
               [(number? (car sexps))
                (+ (car sexps) (loop (cdr sexps)))]
               [else (x-error "+: not a number: " (car sexps))])))]
    [(*)
     (lambda (sexps env)
       (let loop ([sexps sexps])
         (cond [(null? sexps) 1]
               [(number? (car sexps))
                (* (car sexps) (loop (cdr sexps)))]
               [else (x-error "*: not a number: " (car sexps))])))]
    [(id->string)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (sid? sexp)
             (symbol->string (sid-name sexp))
             (x-error "id->string: not an id: " sexp))))]
    [(string->id)
     (lambda (sexps env)
       (let ([sexp (car sexps)])
         (if (string? sexp)
             (let ([id (string->symbol sexp)])
               (let ([location (cond [(assv id env) => cdr] [else id])])
                 (make-sid id id location)))
             (x-error "string->id: not a string: " sexp))))]))


(define (compile-syntax-rules synrules env)
  (define ellipsis-id
    (and (pair? (cddr synrules))
         (sid? (cadr synrules))
         (sid-id (cadr synrules))))
  (define (ellipsis? x)
    (and (sid? x)
         (if ellipsis-id
             (eqv? ellipsis-id (sid-id x))
             (eq? '... (lookup-sid x env)))))
  (define (check-lit lit)
    (or (sid? lit)
        (x-error "non-id: " lit " in literals list of: " synrules))
    (if (ellipsis? lit)
        (x-error "ellipsis " lit " in literals list of: " synrules)))
  (let* ([rest (if ellipsis-id (cddr synrules) (cdr synrules))]
         [pat-literal-sids (car rest)]
         [rules (cdr rest)]
         [pat-literals
          (begin (or (list? pat-literal-sids)
                     (x-error "pattern literals list is not a list: "
                       pat-literal-sids))
                 (for-each check-lit pat-literal-sids)
                 (map sid-id pat-literal-sids))])
    (define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))
    (define (check-ellipses pat/tmpl in-template?)
      (define (bad-ellipsis x reason)
        (x-error (string-append reason ": ") x
          (if in-template? " in template: " " in pattern: ")
          pat/tmpl))
      (define (multi-ellipsis-error x)
        (bad-ellipsis x "list or vector pattern with multiple ellipses"))
      (define (ellipsis/tail-error x)
        (bad-ellipsis x "improper list pattern with an ellipsis"))
      (define (ellipsis-follows x thing)
        (bad-ellipsis x (string-append "ellipsis following " thing)))
      (let ([x (if in-template? pat/tmpl (cdr pat/tmpl))])
        (if in-template?
            (if (ellipsis? x) (ellipsis-follows x "nothing"))
            (cond [(ellipsis? x) (ellipsis-follows pat/tmpl "a '.'")]
                  [(ellipsis-pair? x)
                   (ellipsis-follows pat/tmpl "the pattern keyword")]))
        (let check ([x x])
          (cond
            [(pair? x)
             (if (ellipsis? (car x)) (ellipsis-follows x "a '('"))
             (check (car x))
             (if (ellipsis? (cdr x)) (ellipsis-follows x "a '.'"))
             (if (ellipsis-pair? (cdr x))
                 (cond
                   [(ellipsis? (cddr x))
                    (ellipsis-follows (cdr x) "a '.'")]
                   [(ellipsis-pair? (cddr x))
                    (ellipsis-follows (cdr x) "an ellipsis")]
                   [in-template? (check (cddr x))]
                   [else
                    (or (list? x) (ellipsis/tail-error x))
                    (for-each
                      (lambda (y)
                        (if (ellipsis? y) (multi-ellipsis-error x))
                        (check y))
                      (cddr x))])
                 (check (cdr x)))]
            [(svector? x)
             (let ([elts (svector->list x)])
               (if (ellipsis-pair? elts)
                   (ellipsis-follows x "a '#('")
                   (check elts)))]
            [(if in-template? (template-sbox? x) (pattern-sbox? x))
             (let ([elts (sbox->sexp-list x)])
               (if (ellipsis-pair? elts)
                   (ellipsis-follows x "a '#&(op'")
                   (check elts)))]
            [(box? x)
             (bad-ellipsis x "malformed box")]))))
    (define (make-pat-env pat)
      (let collect ([x (cdr pat)] [depth 0] [l '()])
        (cond
          [(sid? x)
           (let ([id (sid-id x)])
             (cond
               [(memv id pat-literals) l]
               [(assv id l)
                (x-error "duplicate pattern var: " x " in pattern: " pat)]
               [else (acons id depth l)]))]
          [(vector? x) (collect (svector->list x) depth l)]
          [(box? x) (collect (pattern-sbox->sexp x) depth l)]
          [(pair? x)
           (if (ellipsis-pair? (cdr x))
               (collect (car x) (+ 1 depth) (collect (cddr x) depth l))
               (collect (car x) depth (collect (cdr x) depth l)))]
          [else l])))
    (define (check-var-depths tmpl pat-env)
      (define (depth-error x)
        (x-error "pattern var used at bad depth: " x
          " in template: " tmpl))
      (define (close-error x)
        (x-error "template ellipsis closes no variables: " x
          " in template: " tmpl))
      (let collect ([x tmpl] [depth 0])
        (cond
          [(sid? x)
           (let ([p (assv (sid-id x) pat-env)])
             (and p
                  (let*
                   ([pat-depth (cdr p)]
                    [same-depth? (= depth pat-depth)])
                    (if (and (positive? pat-depth) (not same-depth?))
                        (depth-error x))
                    same-depth?)))]
          [(vector? x) (collect (svector->list x) depth)]
          [(box? x) (collect (template-sbox->sexp x) depth)]
          [(pair? x)
           (let* ([ellip? (ellipsis-pair? (cdr x))]
                  [car-closed?
                   (collect (car x) (if ellip? (+ 1 depth) depth))]
                  [cdr-closed? (collect ((if ellip? cddr cdr) x) depth)])
             (and ellip? (not car-closed?) (close-error x))
             (or car-closed? cdr-closed?))]
          [else #f])))
    (define (check-rule rule)
      (or (list2? rule) (x-error "malformed syntax rule: " rule))
      (let ([pat (car rule)] [tmpl (cadr rule)])
        (or (and (pair? pat) (sid? (car pat)))
            (sid? pat) ;++ : support for identifier-syntax
            (x-error "malformed pattern: " pat))
        ;++ : treat _ pat as (_) for checking purposes
        (let ([pat (if (sid? pat) (list pat) pat)])
          (check-ellipses pat #f)
          (check-ellipses tmpl #t)
          (let ([pat-env (make-pat-env pat)])
            (check-var-depths tmpl pat-env)
            (let collect ([x tmpl] [lits '()])
              (cond
                [(ellipsis? x) lits]
                [(sid? x)
                 (if (assv (sid-id x) pat-env) lits (cons (sid-id x) lits))]
                [(vector? x) (collect (svector->list x) lits)]
                [(box? x) (collect (template-sbox->sexp x) lits)]
                [(pair? x) (collect (car x) (collect (cdr x) lits))]
                [else lits]))))))
    (define (reduce-env lits)
      (define (list-dots-ids x ids)
        (cond
          [(sid? x)
           (if (eq? '... (sid-location x)) (cons (sid-id x) ids) ids)]
          [(vector? x) 
           (list-dots-ids (svector->list x) ids)]
          [(box? x)
           (list-dots-ids (sbox->sexp-list x) ids)]
          [(pair? x)
           (list-dots-ids (car x) (list-dots-ids (cdr x) ids))]
          [else ids]))
      (let loop ([ids (if ellipsis-id lits (list-dots-ids rules lits))]
                 [reduced-env empty-env])
        (if (null? ids)
            reduced-env
            (loop
              (cdr ids)
              (let ([id (car ids)])
                (cond
                  [(and (not (assv id reduced-env)) (assv id env))
                   => (lambda (binding) (cons binding reduced-env))]
                  [else reduced-env]))))))
    (let* ([lits (append* (cons pat-literals (map check-rule rules)))]
           [env (reduce-env lits)])
      (make-expander (cons 'syntax-rules (cdr synrules)) env)))) ;*** fixed in 153s

(define (apply-synrules transformer sexp id-n env k)
  (let* ([synrules (expander-form transformer)]
         [mac-env (expander-env transformer)]
         [ellipsis-id (and (sid? (cadr synrules)) (sid-id (cadr synrules)))]
         [rest (if ellipsis-id (cddr synrules) (cdr synrules))]
         [pat-literals (map sid-id (car rest))]
         [rules (cdr rest)])
    (define (pat-literal? id) (memv id pat-literals))
    (define (not-pat-literal? id) (not (pat-literal? id)))
    (define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))
    (define (ellipsis? x)
      (and (sid? x)
           (if ellipsis-id
               (eqv? ellipsis-id (sid-id x))
               (eq? '... (lookup-sid x mac-env)))))
    (define (list-ids x include-scalars pred?)
      (let collect ([x x] [inc include-scalars] [l '()])
        (cond [(sid? x)
               (let ([id (sid-id x)])
                 (if (and inc (pred? id)) (cons id l) l))]
              [(vector? x) (collect (svector->list x) inc l)]
              [(box? x) (collect (sbox->sexp-list x) inc l)]
              [(pair? x)
               (if (ellipsis-pair? (cdr x))
                   (collect (car x) #t (collect (cddr x) inc l))
                   (collect (car x) inc (collect (cdr x) inc l)))]
              [else l])))
    (define (matches? pat)
      (let match ([pat pat] [sexp (cdr sexp)])
        (cond [(sid? pat)
               (or (not (pat-literal? (sid-id pat)))
                   (and (sid? sexp)
                        (eqv?
                          (lookup-sid pat mac-env)
                          (lookup-sid sexp env))))]
              [(svector? pat)
               (and (svector? sexp)
                    (match (svector->list pat) (svector->list sexp)))]
              [(pattern-sbox? pat)
               (and ((pattern-sbox->test pat) sexp env)
                    (match (pattern-sbox->sexp pat) sexp))]
              [(not (pair? pat)) (equal? pat sexp)]
              [(ellipsis-pair? (cdr pat))
               (let skip ([p (cddr pat)] [s sexp])
                 (if (pair? p)
                     (and (pair? s) (skip (cdr p) (cdr s)))
                     (let match-cars ([sexp sexp] [s s])
                       (if (pair? s)
                           (and (match (car pat) (car sexp))
                                (match-cars (cdr sexp) (cdr s)))
                           (match (cddr pat) sexp)))))]
              [else
               (and (pair? sexp)
                    (match (car pat) (car sexp))
                    (match (cdr pat) (cdr sexp)))])))
    (define (make-bindings pat)
      (let collect ([pat pat] [sexp (cdr sexp)] [bindings '()])
        (cond
          [(and (sid? pat) (not (pat-literal? (sid-id pat))))
           (acons (sid-id pat) sexp bindings)]
          [(svector? pat)
           (collect (svector->list pat) (svector->list sexp) bindings)]
          [(box? pat)
           (collect (pattern-sbox->sexp pat) sexp bindings)]
          [(not (pair? pat)) bindings]
          [(ellipsis-pair? (cdr pat))
           (let* ([tail-len (length (cddr pat))]
                  [tail (list-tail sexp (- (length sexp) tail-len))]
                  [matches
                   (reverse (list-tail (reverse sexp) tail-len))]
                  [vars (list-ids (car pat) #t not-pat-literal?)])
             (define (collect1 match)
               (map cdr (collect (car pat) match '())))
             (append (apply-map-list (cons vars (map collect1 matches))) ; *
                     (collect (cddr pat) tail bindings)))]
          [else
           (collect (car pat) (car sexp)
             (collect (cdr pat) (cdr sexp) bindings))])))
    (define (remove-dups l)
      (let loop ([l l] [result '()])
        (if (null? l)
            result
            (loop (cdr l)
              (let ([elt (car l)])
                (if (memv elt result) result (cons elt result)))))))
    (define (expand-template pat tmpl top-bindings)
      (define tmpl-literals
        (remove-dups
          (list-ids tmpl #t (lambda (id) (not (assv id top-bindings))))))
      (define ellipsis-vars (list-ids pat #f not-pat-literal?))
      (define (list-ellipsis-vars subtmpl)
        (list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
      (define (expand tmpl bindings)
        (let expand-part ([tmpl tmpl])
          (cond
            [(sid? tmpl)
             (let ([id (sid-id tmpl)])
               (cond
                 [(assv id bindings) => cdr]
                 [(assv id top-bindings) => cdr]
                 [else
                  (let ([index (+ -1 (length (memv id tmpl-literals)))]
                        [location (lookup-sid tmpl mac-env)])
                    (make-sid (sid-name tmpl) (+ id-n index) location))]))]
            [(vector? tmpl)
             (list->svector (expand-part (svector->list tmpl)))]
            [(box? tmpl)
             ((template-sbox->conv tmpl) 
              (expand-part (template-sbox->sexp tmpl)) env)]
            [(pair? tmpl)
             (if (ellipsis-pair? (cdr tmpl))
                 (let ([vars-to-iterate (list-ellipsis-vars (car tmpl))])
                   (define (lookup var) (cdr (assv var bindings)))
                   (define (expand-using-vals-list vals)  ; used dotted arglist
                     (expand (car tmpl) (map cons vars-to-iterate vals)))
                   (let ([val-lists (map lookup vars-to-iterate)])
                     (if (or (null? (cdr val-lists))
                             (pairwise-andmap (lambda (x y) (= x y)) ; *
                               (map length val-lists))) ; was (apply = (map length val-lists))
                         (append
                           (map expand-using-vals-list (apply-map-list val-lists))
                           (expand-part (cddr tmpl)))
                         (x-error 
                           "unequal sequence lengths for pattern vars: "
                           vars-to-iterate " in macro call: " sexp))))
                 (cons (expand-part (car tmpl))
                       (expand-part (cdr tmpl))))]
            [else tmpl])))
      (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))
    (let loop ([rules rules])
      (if (null? rules)
          (x-error "no matching rule for macro use: " sexp)
          (let* ([rule (car rules)] [pat (car rule)] [tmpl (cadr rule)])
            (cond
               [(and (pair? pat) (pair? sexp) (matches? (cdr pat)))
                (expand-template (cdr pat) tmpl (make-bindings (cdr pat)))]
               ;++ : support for identifier-syntax
               [(and (sid? pat) (sid? sexp))
                (expand-template '() tmpl '())]
               [else
                (loop (cdr rules))])))))) 

(define builtins-store
  (let loop ([bs '(begin define define-syntax if lambda quote
                   set! syntax-rules syntax-lambda letcc withcc
                   %prim %prim? %prim! %prim?! %prim* %prim*! %prim*? %prim*?! 
                   %quote %const %definition %localdef)]
             [store empty-store])
    (if (null? bs)
        store
        (loop (cdr bs)
          (extend-store store (car bs) (make-builtin (car bs)))))))

(define null-prog '())
(define null-stuff 
  (expand-top-level-forms null-prog builtins-store 0 
    (lambda (acc store loc-n) (list acc store loc-n)))) ; *
(define null-output (car null-stuff))
(define null-store (cadr null-stuff))
(define null-loc-n (caddr null-stuff))


(define (null-mstore) (cons null-store null-loc-n))

(define (expand-top-level-forms! forms mstore)
  (expand-top-level-forms forms (car mstore) (cdr mstore)
    (lambda (outputs store loc-n)
      (set-car! mstore store) (set-cdr! mstore loc-n) outputs)))

(define (file-expand-top-level-forms! filename mstore)
  (call-with-input-file filename
    (lambda (port)
      (let loop ([forms '()])
        (let ([s (read/1 port)])
          (if (eof-object? s)
              (expand-top-level-forms! (reverse forms) mstore)
              (loop (cons s forms))))))))