;(define integer->char ascii->char)
;(define char->integer char->ascii)

(import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings))

(define open-input-file* open-input-file)
(define (pp-expression expr port) (write expr port) (newline port))
(define (write-returning-len obj port) (write obj port) 1)
(define (display-returning-len obj port) (display obj port) 1)
(define (write-word w port)
  (write-char (integer->char (div w 256)) port)
  (write-char (integer->char (mod w 256)) port))
(define char-nul (integer->char 0))
(define char-tab (integer->char 9))
(define char-newline (integer->char 10))
(define character-encoding char->integer)
(define max-character-encoding 255)
(define (fatal-err msg arg) (error #f msg arg))
(define (scheme-global-var name) name)
(define (scheme-global-var-ref var) (scheme-global-eval var fatal-err))
(define (scheme-global-var-set! var val)
  (scheme-global-eval (list 'set! var (list 'quote val)) fatal-err))
(define (scheme-global-eval expr err)
  ;(eval expr)
  (error #f "scheme-global-eval is no more"))
(define (pinpoint-error filename line char) #t)
(define file-path-sep #\:)
(define file-ext-sep #\.)
(define (path-absolute? x)
  (and (> (string-length x) 0)
       (let ((c (string-ref x 0))) (or (char=? c #\/) (char=? c #\~)))))
(define (file-path x)
  (let loop1 ((i (string-length x)))
    (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
        (loop1 (- i 1))
        (let ((result (make-string i)))
          (let loop2 ((j (- i 1)))
            (if (< j 0)
                result
                (begin
                  (string-set! result j (string-ref x j))
                  (loop2 (- j 1)))))))))
(define (file-name x)
  (let loop1 ((i (string-length x)))
    (if (and (> i 0) (not (char=? (string-ref x (- i 1)) file-path-sep)))
        (loop1 (- i 1))
        (let ((result (make-string (- (string-length x) i))))
          (let loop2 ((j (- (string-length x) 1)))
            (if (< j i)
                result
                (begin
                  (string-set! result (- j i) (string-ref x j))
                  (loop2 (- j 1)))))))))
(define (file-ext x)
  (let loop1 ((i (string-length x)))
    (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
        #f
        (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
            (loop1 (- i 1))
            (let ((result (make-string (- (string-length x) i))))
              (let loop2 ((j (- (string-length x) 1)))
                (if (< j i)
                    result
                    (begin
                      (string-set! result (- j i) (string-ref x j))
                      (loop2 (- j 1))))))))))
(define (file-root x)
  (let loop1 ((i (string-length x)))
    (if (or (= i 0) (char=? (string-ref x (- i 1)) file-path-sep))
        x
        (if (not (char=? (string-ref x (- i 1)) file-ext-sep))
            (loop1 (- i 1))
            (let ((result (make-string (- i 1))))
              (let loop2 ((j (- i 2)))
                (if (< j 0)
                    result
                    (begin
                      (string-set! result j (string-ref x j))
                      (loop2 (- j 1))))))))))
(define (make-counter next limit limit-error)
  (lambda ()
    (if (< next limit)
        (let ((result next)) (set! next (+ next 1)) result)
        (limit-error))))
(define (pos-in-list x l)
  (let loop ((l l) (i 0))
    (cond ((not (pair? l)) #f)
          ((eq? (car l) x) i)
          (else (loop (cdr l) (+ i 1))))))
(define (string-pos-in-list x l)
  (let loop ((l l) (i 0))
    (cond ((not (pair? l)) #f)
          ((string=? (car l) x) i)
          (else (loop (cdr l) (+ i 1))))))
(define (nth-after l n)
  (let loop ((l l) (n n)) (if (> n 0) (loop (cdr l) (- n 1)) l)))
(define (pair-up l1 l2)
  (define (pair l1 l2)
    (if (pair? l1)
        (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
        '()))
  (pair l1 l2))
(define (my-last-pair l)
  (let loop ((l l)) (if (pair? (cdr l)) (loop (cdr l)) l)))
(define (sort-list l <?)
  (define (mergesort l)
    (define (merge l1 l2)
      (cond ((null? l1) l2)
            ((null? l2) l1)
            (else
             (let ((e1 (car l1)) (e2 (car l2)))
               (if (<? e1 e2)
                   (cons e1 (merge (cdr l1) l2))
                   (cons e2 (merge l1 (cdr l2))))))))
    (define (split l)
      (if (or (null? l) (null? (cdr l))) l (cons (car l) (split (cddr l)))))
    (if (or (null? l) (null? (cdr l)))
        l
        (let* ((l1 (mergesort (split l))) (l2 (mergesort (split (cdr l)))))
          (merge l1 l2))))
  (mergesort l))
(define (lst->vector l)
  (let* ((n (length l)) (v (make-vector n)))
    (let loop ((l l) (i 0))
      (if (pair? l)
          (begin (vector-set! v i (car l)) (loop (cdr l) (+ i 1)))
          v))))
(define (vector->lst v)
  (let loop ((l '()) (i (- (vector-length v) 1)))
    (if (< i 0) l (loop (cons (vector-ref v i) l) (- i 1)))))
(define (lst->string l)
  (let* ((n (length l)) (s (make-string n)))
    (let loop ((l l) (i 0))
      (if (pair? l)
          (begin (string-set! s i (car l)) (loop (cdr l) (+ i 1)))
          s))))
(define (string->lst s)
  (let loop ((l '()) (i (- (string-length s) 1)))
    (if (< i 0) l (loop (cons (string-ref s i) l) (- i 1)))))
(define (with-exception-handling proc)
  (let ((old-exception-handler throw-to-exception-handler))
    (let ((val (call-with-current-continuation
                (lambda (cont)
                  (set! throw-to-exception-handler cont)
                  (proc)))))
      (set! throw-to-exception-handler old-exception-handler)
      val)))
(define (throw-to-exception-handler val)
  (fatal-err "Internal error, no exception handler at this point" val))
(define (compiler-error msg . args)
  (newline)
  (display "*** ERROR -- ")
  (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))
(define (compiler-user-error loc msg . args)
  (newline)
  (display "*** ERROR -- In ")
  (locat-show loc)
  (newline)
  (display "*** ")
  (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))
(define (compiler-internal-error msg . args)
  (newline)
  (display "*** ERROR -- Compiler internal error detected")
  (newline)
  (display "*** in procedure ")
  (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))
(define (compiler-limitation-error msg . args)
  (newline)
  (display "*** ERROR -- Compiler limit reached")
  (newline)
  (display "*** ")
  (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))
(define (compiler-abort) (throw-to-exception-handler #f))
(define (make-gnode label edges) (vector label edges))
(define (gnode-label x) (vector-ref x 0))
(define (gnode-edges x) (vector-ref x 1))
(define (transitive-closure graph)
  (define changed? #f)
  (define (closure edges)
    (list->set
     (set-union
      edges
      (apply set-union
             (map (lambda (label) (gnode-edges (gnode-find label graph)))
                  (set->list edges))))))
  (let ((new-graph
         (set-map (lambda (x)
                    (let ((new-edges (closure (gnode-edges x))))
                      (if (not (set-equal? new-edges (gnode-edges x)))
                          (set! changed? #t))
                      (make-gnode (gnode-label x) new-edges)))
                  graph)))
    (if changed? (transitive-closure new-graph) new-graph)))
(define (gnode-find label graph)
  (define (find label l)
    (cond ((null? l) #f)
          ((eq? (gnode-label (car l)) label) (car l))
          (else (find label (cdr l)))))
  (find label (set->list graph)))
(define (topological-sort graph)
  (if (set-empty? graph)
      '()
      (let ((to-remove (or (remove-no-edges graph) (remove-cycle graph))))
        (let ((labels (set-map gnode-label to-remove)))
          (cons labels
                (topological-sort
                 (set-map (lambda (x)
                            (make-gnode
                             (gnode-label x)
                             (set-difference (gnode-edges x) labels)))
                          (set-difference graph to-remove))))))))
(define (remove-no-edges graph)
  (let ((nodes-with-no-edges
         (set-keep (lambda (x) (set-empty? (gnode-edges x))) graph)))
    (if (set-empty? nodes-with-no-edges) #f nodes-with-no-edges)))
(define (remove-cycle graph)
  (define (remove l)
    (let ((edges (gnode-edges (car l))))
      (define (equal-edges? x) (set-equal? (gnode-edges x) edges))
      (define (member-edges? x) (set-member? (gnode-label x) edges))
      (if (set-member? (gnode-label (car l)) edges)
          (let ((edge-graph (set-keep member-edges? graph)))
            (if (set-every? equal-edges? edge-graph)
                edge-graph
                (remove (cdr l))))
          (remove (cdr l)))))
  (remove (set->list graph)))
(define (list->set list) list)
(define (set->list set) set)
(define (set-empty) '())
(define (set-empty? set) (null? set))
(define (set-member? x set) (memq x set))
(define (set-singleton x) (list x))
(define (set-adjoin set x) (if (memq x set) set (cons x set)))
(define (set-remove set x)
  (cond ((null? set) '())
        ((eq? (car set) x) (cdr set))
        (else (cons (car set) (set-remove (cdr set) x)))))
(define (set-equal? s1 s2)
  (cond ((null? s1) (null? s2))
        ((memq (car s1) s2) (set-equal? (cdr s1) (set-remove s2 (car s1))))
        (else #f)))
(define (set-difference set . other-sets)
  (define (difference s1 s2)
    (cond ((null? s1) '())
          ((memq (car s1) s2) (difference (cdr s1) s2))
          (else (cons (car s1) (difference (cdr s1) s2)))))
  (n-ary difference set other-sets))
(define (set-union . sets)
  (define (union s1 s2)
    (cond ((null? s1) s2)
          ((memq (car s1) s2) (union (cdr s1) s2))
          (else (cons (car s1) (union (cdr s1) s2)))))
  (n-ary union '() sets))
(define (set-intersection set . other-sets)
  (define (intersection s1 s2)
    (cond ((null? s1) '())
          ((memq (car s1) s2) (cons (car s1) (intersection (cdr s1) s2)))
          (else (intersection (cdr s1) s2))))
  (n-ary intersection set other-sets))
(define (n-ary function first rest)
  (if (null? rest)
      first
      (n-ary function (function first (car rest)) (cdr rest))))
(define (set-keep keep? set)
  (cond ((null? set) '())
        ((keep? (car set)) (cons (car set) (set-keep keep? (cdr set))))
        (else (set-keep keep? (cdr set)))))
(define (set-every? pred? set)
  (or (null? set) (and (pred? (car set)) (set-every? pred? (cdr set)))))
(define (set-map proc set)
  (if (null? set) '() (cons (proc (car set)) (set-map proc (cdr set)))))
(define (list->queue list)
  (cons list (if (pair? list) (my-last-pair list) '())))
(define (queue->list queue) (car queue))
(define (queue-empty) (cons '() '()))
(define (queue-empty? queue) (null? (car queue)))
(define (queue-get! queue)
  (if (null? (car queue))
      (compiler-internal-error "queue-get!, queue is empty")
      (let ((x (caar queue)))
        (set-car! queue (cdar queue))
        (if (null? (car queue)) (set-cdr! queue '()))
        x)))
(define (queue-put! queue x)
  (let ((entry (cons x '())))
    (if (null? (car queue))
        (set-car! queue entry)
        (set-cdr! (cdr queue) entry))
    (set-cdr! queue entry)
    x))
(define (string->canonical-symbol str)
  (let ((len (string-length str)))
    (let loop ((str str) (s (make-string len)) (i (- len 1)))
      (if (>= i 0)
          (begin
            (string-set! s i (char-downcase (string-ref str i)))
            (loop str s (- i 1)))
          (string->symbol s)))))
(define quote-sym (string->canonical-symbol "QUOTE"))
(define quasiquote-sym (string->canonical-symbol "QUASIQUOTE"))
(define unquote-sym (string->canonical-symbol "UNQUOTE"))
(define unquote-splicing-sym (string->canonical-symbol "UNQUOTE-SPLICING"))
(define lambda-sym (string->canonical-symbol "LAMBDA"))
(define if-sym (string->canonical-symbol "IF"))
(define set!-sym (string->canonical-symbol "SET!"))
(define cond-sym (string->canonical-symbol "COND"))
(define =>-sym (string->canonical-symbol "=>"))
(define else-sym (string->canonical-symbol "ELSE"))
(define and-sym (string->canonical-symbol "AND"))
(define or-sym (string->canonical-symbol "OR"))
(define case-sym (string->canonical-symbol "CASE"))
(define let-sym (string->canonical-symbol "LET"))
(define let*-sym (string->canonical-symbol "LET*"))
(define letrec-sym (string->canonical-symbol "LETREC"))
(define begin-sym (string->canonical-symbol "BEGIN"))
(define do-sym (string->canonical-symbol "DO"))
(define define-sym (string->canonical-symbol "DEFINE"))
(define delay-sym (string->canonical-symbol "DELAY"))
(define future-sym (string->canonical-symbol "FUTURE"))
(define **define-macro-sym (string->canonical-symbol "DEFINE-MACRO"))
(define **declare-sym (string->canonical-symbol "DECLARE"))
(define **include-sym (string->canonical-symbol "INCLUDE"))
(define not-sym (string->canonical-symbol "NOT"))
(define **c-declaration-sym (string->canonical-symbol "C-DECLARATION"))
(define **c-init-sym (string->canonical-symbol "C-INIT"))
(define **c-procedure-sym (string->canonical-symbol "C-PROCEDURE"))
(define void-sym (string->canonical-symbol "VOID"))
(define char-sym (string->canonical-symbol "CHAR"))
(define signed-char-sym (string->canonical-symbol "SIGNED-CHAR"))
(define unsigned-char-sym (string->canonical-symbol "UNSIGNED-CHAR"))
(define short-sym (string->canonical-symbol "SHORT"))
(define unsigned-short-sym (string->canonical-symbol "UNSIGNED-SHORT"))
(define int-sym (string->canonical-symbol "INT"))
(define unsigned-int-sym (string->canonical-symbol "UNSIGNED-INT"))
(define long-sym (string->canonical-symbol "LONG"))
(define unsigned-long-sym (string->canonical-symbol "UNSIGNED-LONG"))
(define float-sym (string->canonical-symbol "FLOAT"))
(define double-sym (string->canonical-symbol "DOUBLE"))
(define pointer-sym (string->canonical-symbol "POINTER"))
(define boolean-sym (string->canonical-symbol "BOOLEAN"))
(define string-sym (string->canonical-symbol "STRING"))
(define scheme-object-sym (string->canonical-symbol "SCHEME-OBJECT"))
(define c-id-prefix "___")
(define false-object (if (eq? '() #f) (string->symbol "#f") #f))
(define (false-object? obj) (eq? obj false-object))
(define undef-object (string->symbol "#[undefined]"))
(define (undef-object? obj) (eq? obj undef-object))
(define (symbol-object? obj)
  (and (not (false-object? obj)) (not (undef-object? obj)) (symbol? obj)))
(define scm-file-exts '("scm" #f))
(define compiler-version "2.2.2")
(define (open-sf filename)
  (define (open-err) (compiler-error "Can't find file" filename))
  (if (not (file-ext filename))
      (let loop ((exts scm-file-exts))
        (if (pair? exts)
            (let* ((ext (car exts))
                   (full-name
                    (if ext (string-append filename "." ext) filename))
                   (port (open-input-file* full-name)))
              (if port (vector port full-name 0 1 0) (loop (cdr exts))))
            (open-err)))
      (let ((port (open-input-file* filename)))
        (if port (vector port filename 0 1 0) (open-err)))))
(define (close-sf sf) (close-input-port (vector-ref sf 0)))
(define (sf-read-char sf)
  (let ((c (read-char (vector-ref sf 0))))
    (cond ((eof-object? c))
          ((char=? c char-newline)
           (vector-set! sf 3 (+ (vector-ref sf 3) 1))
           (vector-set! sf 4 0))
          (else (vector-set! sf 4 (+ (vector-ref sf 4) 1))))
    c))
(define (sf-peek-char sf) (peek-char (vector-ref sf 0)))
(define (sf-read-error sf msg . args)
  (apply compiler-user-error
         (cons (sf->locat sf)
               (cons (string-append "Read error -- " msg) args))))
(define (sf->locat sf)
  (vector 'file
          (vector-ref sf 1)
          (vector-ref sf 2)
          (vector-ref sf 3)
          (vector-ref sf 4)))
(define (expr->locat expr source) (vector 'expr expr source))
(define (locat-show loc)
  (if loc
      (case (vector-ref loc 0)
        ((file)
         (if (pinpoint-error
              (vector-ref loc 1)
              (vector-ref loc 3)
              (vector-ref loc 4))
             (begin
               (display "file \"")
               (display (vector-ref loc 1))
               (display "\", line ")
               (display (vector-ref loc 3))
               (display ", character ")
               (display (vector-ref loc 4)))))
        ((expr)
         (display "expression ")
         (write (vector-ref loc 1))
         (if (vector-ref loc 2)
             (begin
               (display " ")
               (locat-show (source-locat (vector-ref loc 2))))))
        (else (compiler-internal-error "locat-show, unknown location tag")))
      (display "unknown location")))
(define (locat-filename loc)
  (if loc
      (case (vector-ref loc 0)
        ((file) (vector-ref loc 1))
        ((expr)
         (let ((source (vector-ref loc 2)))
           (if source (locat-filename (source-locat source)) "")))
        (else
         (compiler-internal-error "locat-filename, unknown location tag")))
      ""))
(define (make-source code locat) (vector code locat))
(define (source-code x) (vector-ref x 0))
(define (source-code-set! x y) (vector-set! x 0 y) x)
(define (source-locat x) (vector-ref x 1))
(define (expression->source expr source)
  (define (expr->source x)
    (make-source
     (cond ((pair? x) (list->source x))
           ((vector? x) (vector->source x))
           ((symbol-object? x) (string->canonical-symbol (symbol->string x)))
           (else x))
     (expr->locat x source)))
  (define (list->source l)
    (cond ((pair? l) (cons (expr->source (car l)) (list->source (cdr l))))
          ((null? l) '())
          (else (expr->source l))))
  (define (vector->source v)
    (let* ((len (vector-length v)) (x (make-vector len)))
      (let loop ((i (- len 1)))
        (if (>= i 0)
            (begin
              (vector-set! x i (expr->source (vector-ref v i)))
              (loop (- i 1)))))
      x))
  (expr->source expr))
(define (source->expression source)
  (define (list->expression l)
    (cond ((pair? l)
           (cons (source->expression (car l)) (list->expression (cdr l))))
          ((null? l) '())
          (else (source->expression l))))
  (define (vector->expression v)
    (let* ((len (vector-length v)) (x (make-vector len)))
      (let loop ((i (- len 1)))
        (if (>= i 0)
            (begin
              (vector-set! x i (source->expression (vector-ref v i)))
              (loop (- i 1)))))
      x))
  (let ((code (source-code source)))
    (cond ((pair? code) (list->expression code))
          ((vector? code) (vector->expression code))
          (else code))))
(define (file->sources filename info-port)
  (if info-port
      (begin
        (display "(reading \"" info-port)
        (display filename info-port)
        (display "\"" info-port)))
  (let ((sf (open-sf filename)))
    (define (read-sources)
      (let ((source (read-source sf)))
        (if (not (eof-object? source))
            (begin
              (if info-port (display "." info-port))
              (cons source (read-sources)))
            '())))
    (let ((sources (read-sources)))
      (if info-port (display ")" info-port))
      (close-sf sf)
      sources)))
(define (file->sources* filename info-port loc)
  (file->sources
   (if (path-absolute? filename)
       filename
       (string-append (file-path (locat-filename loc)) filename))
   info-port))
(define (read-source sf)
  (define (read-char*)
    (let ((c (sf-read-char sf)))
      (if (eof-object? c)
          (sf-read-error sf "Premature end of file encountered")
          c)))
  (define (read-non-whitespace-char)
    (let ((c (read-char*)))
      (cond ((< 0 (vector-ref read-table (char->integer c)))
             (read-non-whitespace-char))
            ((char=? c #\;)
             (let loop ()
               (if (not (char=? (read-char*) char-newline))
                   (loop)
                   (read-non-whitespace-char))))
            (else c))))
  (define (delimiter? c)
    (or (eof-object? c) (not (= (vector-ref read-table (char->integer c)) 0))))
  (define (read-list first)
    (let ((result (cons first '())))
      (let loop ((end result))
        (let ((c (read-non-whitespace-char)))
          (cond ((char=? c #\)))
                ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
                 (let ((x (read-source sf)))
                   (if (char=? (read-non-whitespace-char) #\))
                       (set-cdr! end x)
                       (sf-read-error sf "')' expected"))))
                (else
                 (let ((tail (cons (rd* c) '())))
                   (set-cdr! end tail)
                   (loop tail))))))
      result))
  (define (read-vector)
    (define (loop i)
      (let ((c (read-non-whitespace-char)))
        (if (char=? c #\))
            (make-vector i '())
            (let* ((x (rd* c)) (v (loop (+ i 1)))) (vector-set! v i x) v))))
    (loop 0))
  (define (read-string)
    (define (loop i)
      (let ((c (read-char*)))
        (cond ((char=? c #\") (make-string i #\space))
              ((char=? c #\\)
               (let* ((c (read-char*)) (s (loop (+ i 1))))
                 (string-set! s i c)
                 s))
              (else (let ((s (loop (+ i 1)))) (string-set! s i c) s)))))
    (loop 0))
  (define (read-symbol/number-string i)
    (if (delimiter? (sf-peek-char sf))
        (make-string i #\space)
        (let* ((c (sf-read-char sf)) (s (read-symbol/number-string (+ i 1))))
          (string-set! s i (char-downcase c))
          s)))
  (define (read-symbol/number c)
    (let ((s (read-symbol/number-string 1)))
      (string-set! s 0 (char-downcase c))
      (or (string->number s 10) (string->canonical-symbol s))))
  (define (read-prefixed-number c)
    (let ((s (read-symbol/number-string 2)))
      (string-set! s 0 #\#)
      (string-set! s 1 c)
      (string->number s 10)))
  (define (read-special-symbol)
    (let ((s (read-symbol/number-string 2)))
      (string-set! s 0 #\#)
      (string-set! s 1 #\#)
      (string->canonical-symbol s)))
  (define (rd c)
    (cond ((eof-object? c) c)
          ((< 0 (vector-ref read-table (char->integer c)))
           (rd (sf-read-char sf)))
          ((char=? c #\;)
           (let loop ()
             (let ((c (sf-read-char sf)))
               (cond ((eof-object? c) c)
                     ((char=? c char-newline) (rd (sf-read-char sf)))
                     (else (loop))))))
          (else (rd* c))))
  (define (rd* c)
    (let ((source (make-source #f (sf->locat sf))))
      (source-code-set!
       source
       (cond ((char=? c #\()
              (let ((x (read-non-whitespace-char)))
                (if (char=? x #\)) '() (read-list (rd* x)))))
             ((char=? c #\#)
              (let ((c (char-downcase (sf-read-char sf))))
                (cond ((char=? c #\() (read-vector))
                      ((char=? c #\f) false-object)
                      ((char=? c #\t) #t)
                      ((char=? c #\\)
                       (let ((c (read-char*)))
                         (if (or (not (char-alphabetic? c))
                                 (delimiter? (sf-peek-char sf)))
                             c
                             (let ((name (read-symbol/number c)))
                               (let ((x (assq name named-char-table)))
                                 (if x
                                     (cdr x)
                                     (sf-read-error
                                      sf
                                      "Unknown character name"
                                      name)))))))
                      ((char=? c #\#) (read-special-symbol))
                      (else
                       (let ((num (read-prefixed-number c)))
                         (or num
                             (sf-read-error
                              sf
                              "Unknown '#' read macro"
                              c)))))))
             ((char=? c #\") (read-string))
             ((char=? c #\')
              (list (make-source quote-sym (sf->locat sf)) (read-source sf)))
             ((char=? c #\`)
              (list (make-source quasiquote-sym (sf->locat sf))
                    (read-source sf)))
             ((char=? c #\,)
              (if (char=? (sf-peek-char sf) #\@)
                  (let ((x (make-source unquote-splicing-sym (sf->locat sf))))
                    (sf-read-char sf)
                    (list x (read-source sf)))
                  (list (make-source unquote-sym (sf->locat sf))
                        (read-source sf))))
             ((char=? c #\)) (sf-read-error sf "Misplaced ')'"))
             ((or (char=? c #\[) (char=? c #\]) (char=? c #\{) (char=? c #\}))
              (sf-read-error sf "Illegal character" c))
             (else
              (if (char=? c #\.)
                  (if (delimiter? (sf-peek-char sf))
                      (sf-read-error sf "Misplaced '.'")))
              (read-symbol/number c))))))
  (rd (sf-read-char sf)))
(define named-char-table
  (list (cons (string->canonical-symbol "NUL") char-nul)
        (cons (string->canonical-symbol "TAB") char-tab)
        (cons (string->canonical-symbol "NEWLINE") char-newline)
        (cons (string->canonical-symbol "SPACE") #\space)))
(define read-table
  (let ((rt (make-vector (+ max-character-encoding 1) 0)))
    (vector-set! rt (char->integer char-tab) 1)
    (vector-set! rt (char->integer char-newline) 1)
    (vector-set! rt (char->integer #\space) 1)
    (vector-set! rt (char->integer #\;) -1)
    (vector-set! rt (char->integer #\() -1)
    (vector-set! rt (char->integer #\)) -1)
    (vector-set! rt (char->integer #\") -1)
    (vector-set! rt (char->integer #\') -1)
    (vector-set! rt (char->integer #\`) -1)
    rt))
(define (make-var name bound refs sets source)
  (vector var-tag name bound refs sets source #f))
(define (var? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) var-tag)))
(define (var-name x) (vector-ref x 1))
(define (var-bound x) (vector-ref x 2))
(define (var-refs x) (vector-ref x 3))
(define (var-sets x) (vector-ref x 4))
(define (var-source x) (vector-ref x 5))
(define (var-info x) (vector-ref x 6))
(define (var-name-set! x y) (vector-set! x 1 y))
(define (var-bound-set! x y) (vector-set! x 2 y))
(define (var-refs-set! x y) (vector-set! x 3 y))
(define (var-sets-set! x y) (vector-set! x 4 y))
(define (var-source-set! x y) (vector-set! x 5 y))
(define (var-info-set! x y) (vector-set! x 6 y))
(define var-tag (list 'var-tag))
(define (var-copy var)
  (make-var (var-name var) #t (set-empty) (set-empty) (var-source var)))
(define (make-temp-var name) (make-var name #t (set-empty) (set-empty) #f))
(define (temp-var? var) (eq? (var-bound var) #t))
(define ret-var (make-temp-var 'ret))
(define ret-var-set (set-singleton ret-var))
(define closure-env-var (make-temp-var 'closure-env))
(define empty-var (make-temp-var #f))
(define make-global-environment (lambda () (env-frame #f '())))
(define (env-frame env vars) (vector (cons vars #f) '() '() env))
(define (env-new-var! env name source)
  (let* ((glob (not (env-parent-ref env)))
         (var (make-var name (not glob) (set-empty) (set-empty) source)))
    (env-vars-set! env (cons var (env-vars-ref env)))
    var))
(define (env-macro env name def)
  (let ((name* (if (full-name? name)
                   name
                   (let ((prefix (env-namespace-prefix env name)))
                     (if prefix (make-full-name prefix name) name)))))
    (vector (vector-ref env 0)
            (cons (cons name* def) (env-macros-ref env))
            (env-decls-ref env)
            (env-parent-ref env))))
(define (env-declare env decl)
  (vector (vector-ref env 0)
          (env-macros-ref env)
          (cons decl (env-decls-ref env))
          (env-parent-ref env)))
(define (env-vars-ref env) (car (vector-ref env 0)))
(define (env-vars-set! env vars) (set-car! (vector-ref env 0) vars))
(define (env-macros-ref env) (vector-ref env 1))
(define (env-decls-ref env) (vector-ref env 2))
(define (env-parent-ref env) (vector-ref env 3))
(define (env-namespace-prefix env name)
  (let loop ((decls (env-decls-ref env)))
    (if (pair? decls)
        (let ((decl (car decls)))
          (if (eq? (car decl) namespace-sym)
              (let ((syms (cddr decl)))
                (if (or (null? syms) (memq name syms))
                    (cadr decl)
                    (loop (cdr decls))))
              (loop (cdr decls))))
        #f)))
(define (env-lookup env name stop-at-first-frame? proc)
  (define (search env name full?)
    (if full?
        (search* env name full?)
        (let ((prefix (env-namespace-prefix env name)))
          (if prefix
              (search* env (make-full-name prefix name) #t)
              (search* env name full?)))))
  (define (search* env name full?)
    (define (search-macros macros)
      (if (pair? macros)
          (let ((m (car macros)))
            (if (eq? (car m) name)
                (proc env name (cdr m))
                (search-macros (cdr macros))))
          (search-vars (env-vars-ref env))))
    (define (search-vars vars)
      (if (pair? vars)
          (let ((v (car vars)))
            (if (eq? (var-name v) name)
                (proc env name v)
                (search-vars (cdr vars))))
          (let ((env* (env-parent-ref env)))
            (if (or stop-at-first-frame? (not env*))
                (proc env name #f)
                (search env* name full?)))))
    (search-macros (env-macros-ref env)))
  (search env name (full-name? name)))
(define (valid-prefix? str)
  (let ((l (string-length str)))
    (or (= l 0) (and (>= l 2) (char=? (string-ref str (- l 1)) #\#)))))
(define (full-name? sym)
  (let ((str (symbol->string sym)))
    (let loop ((i (- (string-length str) 1)))
      (if (< i 0) #f (if (char=? (string-ref str i) #\#) #t (loop (- i 1)))))))
(define (make-full-name prefix sym)
  (if (= (string-length prefix) 0)
      sym
      (string->canonical-symbol (string-append prefix (symbol->string sym)))))
(define (env-lookup-var env name source)
  (env-lookup
   env
   name
   #f
   (lambda (env name x)
     (if x
         (if (var? x)
             x
             (compiler-internal-error
              "env-lookup-var, name is that of a macro"
              name))
         (env-new-var! env name source)))))
(define (env-define-var env name source)
  (env-lookup
   env
   name
   #t
   (lambda (env name x)
     (if x
         (if (var? x)
             (pt-syntax-error source "Duplicate definition of a variable")
             (compiler-internal-error
              "env-define-var, name is that of a macro"
              name))
         (env-new-var! env name source)))))
(define (env-lookup-global-var env name)
  (let ((env* (env-global-env env)))
    (define (search-vars vars)
      (if (pair? vars)
          (let ((v (car vars)))
            (if (eq? (var-name v) name) v (search-vars (cdr vars))))
          (env-new-var! env* name #f)))
    (search-vars (env-vars-ref env*))))
(define (env-global-variables env) (env-vars-ref (env-global-env env)))
(define (env-global-env env)
  (let loop ((env env))
    (let ((env* (env-parent-ref env))) (if env* (loop env*) env))))
(define (env-lookup-macro env name)
  (env-lookup
   env
   name
   #f
   (lambda (env name x) (if (or (not x) (var? x)) #f x))))
(define (env-declarations env) env)
(define flag-declarations '())
(define parameterized-declarations '())
(define boolean-declarations '())
(define namable-declarations '())
(define namable-boolean-declarations '())
(define namable-string-declarations '())
(define (define-flag-decl name type)
  (set! flag-declarations (cons (cons name type) flag-declarations))
  '())
(define (define-parameterized-decl name)
  (set! parameterized-declarations (cons name parameterized-declarations))
  '())
(define (define-boolean-decl name)
  (set! boolean-declarations (cons name boolean-declarations))
  '())
(define (define-namable-decl name type)
  (set! namable-declarations (cons (cons name type) namable-declarations))
  '())
(define (define-namable-boolean-decl name)
  (set! namable-boolean-declarations (cons name namable-boolean-declarations))
  '())
(define (define-namable-string-decl name)
  (set! namable-string-declarations (cons name namable-string-declarations))
  '())
(define (flag-decl source type val) (list type val))
(define (parameterized-decl source id parm) (list id parm))
(define (boolean-decl source id pos) (list id pos))
(define (namable-decl source type val names) (cons type (cons val names)))
(define (namable-boolean-decl source id pos names) (cons id (cons pos names)))
(define (namable-string-decl source id str names)
  (if (and (eq? id namespace-sym) (not (valid-prefix? str)))
      (pt-syntax-error source "Illegal namespace"))
  (cons id (cons str names)))
(define (declaration-value name element default decls)
  (if (not decls)
      default
      (let loop ((l (env-decls-ref decls)))
        (if (pair? l)
            (let ((d (car l)))
              (if (and (eq? (car d) name)
                       (or (null? (cddr d)) (memq element (cddr d))))
                  (cadr d)
                  (loop (cdr l))))
            (declaration-value name element default (env-parent-ref decls))))))
(define namespace-sym 
  (let ([s (string->canonical-symbol "NAMESPACE")])
    (define-namable-string-decl s)
    s))
(define (node-parent x) (vector-ref x 1))
(define (node-children x) (vector-ref x 2))
(define (node-fv x) (vector-ref x 3))
(define (node-decl x) (vector-ref x 4))
(define (node-source x) (vector-ref x 5))
(define (node-parent-set! x y) (vector-set! x 1 y))
(define (node-fv-set! x y) (vector-set! x 3 y))
(define (node-decl-set! x y) (vector-set! x 4 y))
(define (node-source-set! x y) (vector-set! x 5 y))
(define (node-children-set! x y)
  (vector-set! x 2 y)
  (for-each (lambda (child) (node-parent-set! child x)) y)
  (node-fv-invalidate! x))
(define (node-fv-invalidate! x)
  (let loop ((node x))
    (if node (begin (node-fv-set! node #t) (loop (node-parent node))))))
(define (make-cst parent children fv decl source val)
  (vector cst-tag parent children fv decl source val))
(define (cst? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) cst-tag)))
(define (cst-val x) (vector-ref x 6))
(define (cst-val-set! x y) (vector-set! x 6 y))
(define cst-tag (list 'cst-tag))
(define (make-ref parent children fv decl source var)
  (vector ref-tag parent children fv decl source var))
(define (ref? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) ref-tag)))
(define (ref-var x) (vector-ref x 6))
(define (ref-var-set! x y) (vector-set! x 6 y))
(define ref-tag (list 'ref-tag))
(define (make-set parent children fv decl source var)
  (vector set-tag parent children fv decl source var))
(define (set? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) set-tag)))
(define (set-var x) (vector-ref x 6))
(define (set-var-set! x y) (vector-set! x 6 y))
(define set-tag (list 'set-tag))
(define (make-def parent children fv decl source var)
  (vector def-tag parent children fv decl source var))
(define (def? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) def-tag)))
(define (def-var x) (vector-ref x 6))
(define (def-var-set! x y) (vector-set! x 6 y))
(define def-tag (list 'def-tag))
(define (make-tst parent children fv decl source)
  (vector tst-tag parent children fv decl source))
(define (tst? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) tst-tag)))
(define tst-tag (list 'tst-tag))
(define (make-conj parent children fv decl source)
  (vector conj-tag parent children fv decl source))
(define (conj? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) conj-tag)))
(define conj-tag (list 'conj-tag))
(define (make-disj parent children fv decl source)
  (vector disj-tag parent children fv decl source))
(define (disj? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) disj-tag)))
(define disj-tag (list 'disj-tag))
(define (make-prc parent children fv decl source name min rest parms)
  (vector prc-tag parent children fv decl source name min rest parms))
(define (prc? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) prc-tag)))
(define (prc-name x) (vector-ref x 6))
(define (prc-min x) (vector-ref x 7))
(define (prc-rest x) (vector-ref x 8))
(define (prc-parms x) (vector-ref x 9))
(define (prc-name-set! x y) (vector-set! x 6 y))
(define (prc-min-set! x y) (vector-set! x 7 y))
(define (prc-rest-set! x y) (vector-set! x 8 y))
(define (prc-parms-set! x y) (vector-set! x 9 y))
(define prc-tag (list 'prc-tag))
(define (make-app parent children fv decl source)
  (vector app-tag parent children fv decl source))
(define (app? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) app-tag)))
(define app-tag (list 'app-tag))
(define (make-fut parent children fv decl source)
  (vector fut-tag parent children fv decl source))
(define (fut? x)
  (and (vector? x) (> (vector-length x) 0) (eq? (vector-ref x 0) fut-tag)))
(define fut-tag (list 'fut-tag))
(define (new-cst source decl val) (make-cst #f '() #t decl source val))
(define (new-ref source decl var)
  (let ((node (make-ref #f '() #t decl source var)))
    (var-refs-set! var (set-adjoin (var-refs var) node))
    node))
(define (new-ref-extended-bindings source name env)
  (new-ref source
           (add-extended-bindings (env-declarations env))
           (env-lookup-global-var env name)))
(define (new-set source decl var val)
  (let ((node (make-set #f (list val) #t decl source var)))
    (var-sets-set! var (set-adjoin (var-sets var) node))
    (node-parent-set! val node)
    node))
(define (set-val x)
  (if (set? x)
      (car (node-children x))
      (compiler-internal-error "set-val, 'set' node expected" x)))
(define (new-def source decl var val)
  (let ((node (make-def #f (list val) #t decl source var)))
    (var-sets-set! var (set-adjoin (var-sets var) node))
    (node-parent-set! val node)
    node))
(define (def-val x)
  (if (def? x)
      (car (node-children x))
      (compiler-internal-error "def-val, 'def' node expected" x)))
(define (new-tst source decl pre con alt)
  (let ((node (make-tst #f (list pre con alt) #t decl source)))
    (node-parent-set! pre node)
    (node-parent-set! con node)
    (node-parent-set! alt node)
    node))
(define (tst-pre x)
  (if (tst? x)
      (car (node-children x))
      (compiler-internal-error "tst-pre, 'tst' node expected" x)))
(define (tst-con x)
  (if (tst? x)
      (cadr (node-children x))
      (compiler-internal-error "tst-con, 'tst' node expected" x)))
(define (tst-alt x)
  (if (tst? x)
      (caddr (node-children x))
      (compiler-internal-error "tst-alt, 'tst' node expected" x)))
(define (new-conj source decl pre alt)
  (let ((node (make-conj #f (list pre alt) #t decl source)))
    (node-parent-set! pre node)
    (node-parent-set! alt node)
    node))
(define (conj-pre x)
  (if (conj? x)
      (car (node-children x))
      (compiler-internal-error "conj-pre, 'conj' node expected" x)))
(define (conj-alt x)
  (if (conj? x)
      (cadr (node-children x))
      (compiler-internal-error "conj-alt, 'conj' node expected" x)))
(define (new-disj source decl pre alt)
  (let ((node (make-disj #f (list pre alt) #t decl source)))
    (node-parent-set! pre node)
    (node-parent-set! alt node)
    node))
(define (disj-pre x)
  (if (disj? x)
      (car (node-children x))
      (compiler-internal-error "disj-pre, 'disj' node expected" x)))
(define (disj-alt x)
  (if (disj? x)
      (cadr (node-children x))
      (compiler-internal-error "disj-alt, 'disj' node expected" x)))
(define (new-prc source decl name min rest parms body)
  (let ((node (make-prc #f (list body) #t decl source name min rest parms)))
    (for-each (lambda (x) (var-bound-set! x node)) parms)
    (node-parent-set! body node)
    node))
(define (prc-body x)
  (if (prc? x)
      (car (node-children x))
      (compiler-internal-error "prc-body, 'proc' node expected" x)))
(define (new-call source decl oper args)
  (let ((node (make-app #f (cons oper args) #t decl source)))
    (node-parent-set! oper node)
    (for-each (lambda (x) (node-parent-set! x node)) args)
    node))
(define (new-call* source decl oper args)
  (if *ptree-port*
      (if (ref? oper)
          (let ((var (ref-var oper)))
            (if (global? var)
                (let ((proc (standard-procedure
                             (var-name var)
                             (node-decl oper))))
                  (if (and proc
                           (not (nb-args-conforms?
                                 (length args)
                                 (standard-procedure-call-pattern proc))))
                      (begin
                        (display "*** WARNING -- \"" *ptree-port*)
                        (display (var-name var) *ptree-port*)
                        (display "\" is called with " *ptree-port*)
                        (display (length args) *ptree-port*)
                        (display " argument(s)." *ptree-port*)
                        (newline *ptree-port*))))))))
  (new-call source decl oper args))
(define (app-oper x)
  (if (app? x)
      (car (node-children x))
      (compiler-internal-error "app-oper, 'call' node expected" x)))
(define (app-args x)
  (if (app? x)
      (cdr (node-children x))
      (compiler-internal-error "app-args, 'call' node expected" x)))
(define (oper-pos? node)
  (let ((parent (node-parent node)))
    (if parent (and (app? parent) (eq? (app-oper parent) node)) #f)))
(define (new-fut source decl val)
  (let ((node (make-fut #f (list val) #t decl source)))
    (node-parent-set! val node)
    node))
(define (fut-val x)
  (if (fut? x)
      (car (node-children x))
      (compiler-internal-error "fut-val, 'fut' node expected" x)))
(define (new-disj-call source decl pre oper alt)
  (new-call*
   source
   decl
   (let* ((parms (new-temps source '(temp))) (temp (car parms)))
     (new-prc source
              decl
              #f
              1
              #f
              parms
              (new-tst source
                       decl
                       (new-ref source decl temp)
                       (new-call*
                        source
                        decl
                        oper
                        (list (new-ref source decl temp)))
                       alt)))
   (list pre)))
(define (new-seq source decl before after)
  (new-call*
   source
   decl
   (new-prc source decl #f 1 #f (new-temps source '(temp)) after)
   (list before)))
(define (new-let ptree proc vars vals body)
  (if (pair? vars)
      (new-call
       (node-source ptree)
       (node-decl ptree)
       (new-prc (node-source proc)
                (node-decl proc)
                (prc-name proc)
                (length vars)
                #f
                (reverse vars)
                body)
       (reverse vals))
      body))
(define (new-temps source names)
  (if (null? names)
      '()
      (cons (make-var (car names) #t (set-empty) (set-empty) source)
            (new-temps source (cdr names)))))
(define (new-variables vars)
  (if (null? vars)
      '()
      (cons (make-var
             (source-code (car vars))
             #t
             (set-empty)
             (set-empty)
             (car vars))
            (new-variables (cdr vars)))))
(define (set-prc-names! vars vals)
  (let loop ((vars vars) (vals vals))
    (if (not (null? vars))
        (let ((var (car vars)) (val (car vals)))
          (if (prc? val) (prc-name-set! val (symbol->string (var-name var))))
          (loop (cdr vars) (cdr vals))))))
(define (free-variables node)
  (if (eq? (node-fv node) #t)
      (let ((x (apply set-union (map free-variables (node-children node)))))
        (node-fv-set!
         node
         (cond ((ref? node)
                (if (global? (ref-var node)) x (set-adjoin x (ref-var node))))
               ((set? node)
                (if (global? (set-var node)) x (set-adjoin x (set-var node))))
               ((prc? node) (set-difference x (list->set (prc-parms node))))
               ((and (app? node) (prc? (app-oper node)))
                (set-difference x (list->set (prc-parms (app-oper node)))))
               (else x)))))
  (node-fv node))
(define (bound-variables node) (list->set (prc-parms node)))
(define (not-mutable? var) (set-empty? (var-sets var)))
(define (mutable? var) (not (not-mutable? var)))
(define (bound? var) (var-bound var))
(define (global? var) (not (bound? var)))
(define (global-val var)
  (and (global? var)
       (let ((sets (set->list (var-sets var))))
         (and (pair? sets)
              (null? (cdr sets))
              (def? (car sets))
              (eq? (compilation-strategy (node-decl (car sets))) block-sym)
              (def-val (car sets))))))
(define **not-sym (string->canonical-symbol "##NOT"))
(define **quasi-append-sym (string->canonical-symbol "##QUASI-APPEND"))
(define **quasi-list-sym (string->canonical-symbol "##QUASI-LIST"))
(define **quasi-cons-sym (string->canonical-symbol "##QUASI-CONS"))
(define **quasi-list->vector-sym
  (string->canonical-symbol "##QUASI-LIST->VECTOR"))
(define **case-memv-sym (string->canonical-symbol "##CASE-MEMV"))
(define **unassigned?-sym (string->canonical-symbol "##UNASSIGNED?"))
(define **make-cell-sym (string->canonical-symbol "##MAKE-CELL"))
(define **cell-ref-sym (string->canonical-symbol "##CELL-REF"))
(define **cell-set!-sym (string->canonical-symbol "##CELL-SET!"))
(define **make-placeholder-sym (string->canonical-symbol "##MAKE-PLACEHOLDER"))
(define ieee-scheme-sym (string->canonical-symbol "IEEE-SCHEME"))
(define r4rs-scheme-sym (string->canonical-symbol "R4RS-SCHEME"))
(define multilisp-sym (string->canonical-symbol "MULTILISP"))
(define lambda-lift-sym (string->canonical-symbol "LAMBDA-LIFT"))
(define block-sym (string->canonical-symbol "BLOCK"))
(define separate-sym (string->canonical-symbol "SEPARATE"))
(define standard-bindings-sym (string->canonical-symbol "STANDARD-BINDINGS"))
(define extended-bindings-sym (string->canonical-symbol "EXTENDED-BINDINGS"))
(define safe-sym (string->canonical-symbol "SAFE"))
(define interrupts-enabled-sym (string->canonical-symbol "INTERRUPTS-ENABLED"))

(define dummy1
  (begin
    (define-flag-decl ieee-scheme-sym 'dialect)
    (define-flag-decl r4rs-scheme-sym 'dialect)
    (define-flag-decl multilisp-sym 'dialect)
    (define-boolean-decl lambda-lift-sym)
    (define-flag-decl block-sym 'compilation-strategy)
    (define-flag-decl separate-sym 'compilation-strategy)
    (define-namable-boolean-decl standard-bindings-sym)
    (define-namable-boolean-decl extended-bindings-sym)
    (define-boolean-decl safe-sym)
    (define-boolean-decl interrupts-enabled-sym)
    #f))

(define (scheme-dialect decl)
  (declaration-value 'dialect #f ieee-scheme-sym decl))
(define (lambda-lift? decl) (declaration-value lambda-lift-sym #f #t decl))
(define (compilation-strategy decl)
  (declaration-value 'compilation-strategy #f separate-sym decl))
(define (standard-binding? name decl)
  (declaration-value standard-bindings-sym name #f decl))
(define (extended-binding? name decl)
  (declaration-value extended-bindings-sym name #f decl))
(define (add-extended-bindings decl)
  (add-decl (list extended-bindings-sym #t) decl))
(define (intrs-enabled? decl)
  (declaration-value interrupts-enabled-sym #f #t decl))
(define (add-not-interrupts-enabled decl)
  (add-decl (list interrupts-enabled-sym #f) decl))
(define (safe? decl) (declaration-value safe-sym #f #f decl))
(define (add-not-safe decl) (add-decl (list safe-sym #f) decl))
(define (dialect-specific-keywords dialect)
  (cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-keywords)
        ((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-keywords)
        ((eq? dialect multilisp-sym) multilisp-specific-keywords)
        (else
         (compiler-internal-error
          "dialect-specific-keywords, unknown dialect"
          dialect))))
(define (dialect-specific-procedures dialect)
  (cond ((eq? dialect ieee-scheme-sym) ieee-scheme-specific-procedures)
        ((eq? dialect r4rs-scheme-sym) r4rs-scheme-specific-procedures)
        ((eq? dialect multilisp-sym) multilisp-specific-procedures)
        (else
         (compiler-internal-error
          "dialect-specific-procedures, unknown dialect"
          dialect))))
(define (make-standard-procedure x)
  (cons (string->canonical-symbol (car x)) (cdr x)))
(define (standard-procedure name decl)
  (or (assq name (dialect-specific-procedures (scheme-dialect decl)))
      (assq name common-procedures)))
(define (standard-procedure-call-pattern proc) (cdr proc))
(define ieee-scheme-specific-keywords '())
(define ieee-scheme-specific-procedures (map make-standard-procedure '()))
(define r4rs-scheme-specific-keywords (list delay-sym))
(define r4rs-scheme-specific-procedures
  (map make-standard-procedure
       '(("LIST-TAIL" 2)
         ("-" . 1)
         ("/" . 1)
         ("STRING->LIST" 1)
         ("LIST->STRING" 1)
         ("STRING-COPY" 1)
         ("STRING-FILL!" 2)
         ("VECTOR->LIST" 1)
         ("LIST->VECTOR" 1)
         ("VECTOR-FILL!" 2)
         ("FORCE" 1)
         ("WITH-INPUT-FROM-FILE" 2)
         ("WITH-OUTPUT-TO-FILE" 2)
         ("CHAR-READY?" 0 1)
         ("LOAD" 1)
         ("TRANSCRIPT-ON" 1)
         ("TRANSCRIPT-OFF" 0))))
(define multilisp-specific-keywords (list delay-sym future-sym))
(define multilisp-specific-procedures
  (map make-standard-procedure '(("FORCE" 1) ("TOUCH" 1))))
(define common-keywords
  (list quote-sym
        quasiquote-sym
        unquote-sym
        unquote-splicing-sym
        lambda-sym
        if-sym
        set!-sym
        cond-sym
        =>-sym
        else-sym
        and-sym
        or-sym
        case-sym
        let-sym
        let*-sym
        letrec-sym
        begin-sym
        do-sym
        define-sym
        **define-macro-sym
        **declare-sym
        **include-sym))
(define common-procedures
  (map make-standard-procedure
       '(("NOT" 1)
         ("BOOLEAN?" 1)
         ("EQV?" 2)
         ("EQ?" 2)
         ("EQUAL?" 2)
         ("PAIR?" 1)
         ("CONS" 2)
         ("CAR" 1)
         ("CDR" 1)
         ("SET-CAR!" 2)
         ("SET-CDR!" 2)
         ("CAAR" 1)
         ("CADR" 1)
         ("CDAR" 1)
         ("CDDR" 1)
         ("CAAAR" 1)
         ("CAADR" 1)
         ("CADAR" 1)
         ("CADDR" 1)
         ("CDAAR" 1)
         ("CDADR" 1)
         ("CDDAR" 1)
         ("CDDDR" 1)
         ("CAAAAR" 1)
         ("CAAADR" 1)
         ("CAADAR" 1)
         ("CAADDR" 1)
         ("CADAAR" 1)
         ("CADADR" 1)
         ("CADDAR" 1)
         ("CADDDR" 1)
         ("CDAAAR" 1)
         ("CDAADR" 1)
         ("CDADAR" 1)
         ("CDADDR" 1)
         ("CDDAAR" 1)
         ("CDDADR" 1)
         ("CDDDAR" 1)
         ("CDDDDR" 1)
         ("NULL?" 1)
         ("LIST?" 1)
         ("LIST" . 0)
         ("LENGTH" 1)
         ("APPEND" . 0)
         ("REVERSE" 1)
         ("LIST-REF" 2)
         ("MEMQ" 2)
         ("MEMV" 2)
         ("MEMBER" 2)
         ("ASSQ" 2)
         ("ASSV" 2)
         ("ASSOC" 2)
         ("SYMBOL?" 1)
         ("SYMBOL->STRING" 1)
         ("STRING->SYMBOL" 1)
         ("NUMBER?" 1)
         ("COMPLEX?" 1)
         ("REAL?" 1)
         ("RATIONAL?" 1)
         ("INTEGER?" 1)
         ("EXACT?" 1)
         ("INEXACT?" 1)
         ("=" . 2)
         ("<" . 2)
         (">" . 2)
         ("<=" . 2)
         (">=" . 2)
         ("ZERO?" 1)
         ("POSITIVE?" 1)
         ("NEGATIVE?" 1)
         ("ODD?" 1)
         ("EVEN?" 1)
         ("MAX" . 1)
         ("MIN" . 1)
         ("+" . 0)
         ("*" . 0)
         ("-" 1 2)
         ("/" 1 2)
         ("ABS" 1)
         ("QUOTIENT" 2)
         ("REMAINDER" 2)
         ("MODULO" 2)
         ("GCD" . 0)
         ("LCM" . 0)
         ("NUMERATOR" 1)
         ("DENOMINATOR" 1)
         ("FLOOR" 1)
         ("CEILING" 1)
         ("TRUNCATE" 1)
         ("ROUND" 1)
         ("RATIONALIZE" 2)
         ("EXP" 1)
         ("LOG" 1)
         ("SIN" 1)
         ("COS" 1)
         ("TAN" 1)
         ("ASIN" 1)
         ("ACOS" 1)
         ("ATAN" 1 2)
         ("SQRT" 1)
         ("EXPT" 2)
         ("MAKE-RECTANGULAR" 2)
         ("MAKE-POLAR" 2)
         ("REAL-PART" 1)
         ("IMAG-PART" 1)
         ("MAGNITUDE" 1)
         ("ANGLE" 1)
         ("EXACT->INEXACT" 1)
         ("INEXACT->EXACT" 1)
         ("NUMBER->STRING" 1 2)
         ("STRING->NUMBER" 1 2)
         ("CHAR?" 1)
         ("CHAR=?" 2)
         ("CHAR<?" 2)
         ("CHAR>?" 2)
         ("CHAR<=?" 2)
         ("CHAR>=?" 2)
         ("CHAR-CI=?" 2)
         ("CHAR-CI<?" 2)
         ("CHAR-CI>?" 2)
         ("CHAR-CI<=?" 2)
         ("CHAR-CI>=?" 2)
         ("CHAR-ALPHABETIC?" 1)
         ("CHAR-NUMERIC?" 1)
         ("CHAR-WHITESPACE?" 1)
         ("CHAR-UPPER-CASE?" 1)
         ("CHAR-LOWER-CASE?" 1)
         ("CHAR->INTEGER" 1)
         ("INTEGER->CHAR" 1)
         ("CHAR-UPCASE" 1)
         ("CHAR-DOWNCASE" 1)
         ("STRING?" 1)
         ("MAKE-STRING" 1 2)
         ("STRING" . 0)
         ("STRING-LENGTH" 1)
         ("STRING-REF" 2)
         ("STRING-SET!" 3)
         ("STRING=?" 2)
         ("STRING<?" 2)
         ("STRING>?" 2)
         ("STRING<=?" 2)
         ("STRING>=?" 2)
         ("STRING-CI=?" 2)
         ("STRING-CI<?" 2)
         ("STRING-CI>?" 2)
         ("STRING-CI<=?" 2)
         ("STRING-CI>=?" 2)
         ("SUBSTRING" 3)
         ("STRING-APPEND" . 0)
         ("VECTOR?" 1)
         ("MAKE-VECTOR" 1 2)
         ("VECTOR" . 0)
         ("VECTOR-LENGTH" 1)
         ("VECTOR-REF" 2)
         ("VECTOR-SET!" 3)
         ("PROCEDURE?" 1)
         ("APPLY" . 2)
         ("MAP" . 2)
         ("FOR-EACH" . 2)
         ("CALL-WITH-CURRENT-CONTINUATION" 1)
         ("CALL-WITH-INPUT-FILE" 2)
         ("CALL-WITH-OUTPUT-FILE" 2)
         ("INPUT-PORT?" 1)
         ("OUTPUT-PORT?" 1)
         ("CURRENT-INPUT-PORT" 0)
         ("CURRENT-OUTPUT-PORT" 0)
         ("OPEN-INPUT-FILE" 1)
         ("OPEN-OUTPUT-FILE" 1)
         ("CLOSE-INPUT-PORT" 1)
         ("CLOSE-OUTPUT-PORT" 1)
         ("EOF-OBJECT?" 1)
         ("READ" 0 1)
         ("READ-CHAR" 0 1)
         ("PEEK-CHAR" 0 1)
         ("WRITE" 1 2)
         ("DISPLAY" 1 2)
         ("NEWLINE" 0 1)
         ("WRITE-CHAR" 1 2))))
(define (parse-program program env module-name proc)
  (define (parse-prog program env lst proc)
    (if (null? program)
        (proc (reverse lst) env)
        (let ((source (car program)))
          (cond ((macro-expr? source env)
                 (parse-prog
                  (cons (macro-expand source env) (cdr program))
                  env
                  lst
                  proc))
                ((begin-defs-expr? source)
                 (parse-prog
                  (append (begin-defs-body source) (cdr program))
                  env
                  lst
                  proc))
                ((include-expr? source)
                 (if *ptree-port* (display "  " *ptree-port*))
                 (let ((x (file->sources*
                           (include-filename source)
                           *ptree-port*
                           (source-locat source))))
                   (if *ptree-port* (newline *ptree-port*))
                   (parse-prog (append x (cdr program)) env lst proc)))
                ((define-macro-expr? source env)
                 (if *ptree-port*
                     (begin
                       (display "  \"macro\"" *ptree-port*)
                       (newline *ptree-port*)))
                 (parse-prog (cdr program) (add-macro source env) lst proc))
                ((declare-expr? source)
                 (if *ptree-port*
                     (begin
                       (display "  \"decl\"" *ptree-port*)
                       (newline *ptree-port*)))
                 (parse-prog
                  (cdr program)
                  (add-declarations source env)
                  lst
                  proc))
                ((define-expr? source env)
                 (let* ((var** (definition-variable source))
                        (var* (source-code var**))
                        (var (env-lookup-var env var* var**)))
                   (if *ptree-port*
                       (begin
                         (display "  " *ptree-port*)
                         (display (var-name var) *ptree-port*)
                         (newline *ptree-port*)))
                   (let ((node (pt (definition-value source) env 'true)))
                     (set-prc-names! (list var) (list node))
                     (parse-prog
                      (cdr program)
                      env
                      (cons (cons (new-def source
                                           (env-declarations env)
                                           var
                                           node)
                                  env)
                            lst)
                      proc))))
                ((c-declaration-expr? source)
                 (if *ptree-port*
                     (begin
                       (display "  \"c-decl\"" *ptree-port*)
                       (newline *ptree-port*)))
                 (add-c-declaration (source-code (cadr (source-code source))))
                 (parse-prog (cdr program) env lst proc))
                ((c-init-expr? source)
                 (if *ptree-port*
                     (begin
                       (display "  \"c-init\"" *ptree-port*)
                       (newline *ptree-port*)))
                 (add-c-init (source-code (cadr (source-code source))))
                 (parse-prog (cdr program) env lst proc))
                (else
                 (if *ptree-port*
                     (begin
                       (display "  \"expr\"" *ptree-port*)
                       (newline *ptree-port*)))
                 (parse-prog
                  (cdr program)
                  env
                  (cons (cons (pt source env 'true) env) lst)
                  proc))))))
  (if *ptree-port*
      (begin (display "Parsing:" *ptree-port*) (newline *ptree-port*)))
  (c-interface-begin module-name)
  (parse-prog
   program
   env
   '()
   (lambda (lst env)
     (if *ptree-port* (newline *ptree-port*))
     (proc lst env (c-interface-end)))))
(define (c-interface-begin module-name)
  (set! c-interface-module-name module-name)
  (set! c-interface-proc-count 0)
  (set! c-interface-decls '())
  (set! c-interface-procs '())
  (set! c-interface-inits '())
  #f)
(define (c-interface-end)
  (let ((i (make-c-intf
            (reverse c-interface-decls)
            (reverse c-interface-procs)
            (reverse c-interface-inits))))
    (set! c-interface-module-name #f)
    (set! c-interface-proc-count #f)
    (set! c-interface-decls #f)
    (set! c-interface-procs #f)
    (set! c-interface-inits #f)
    i))
(define c-interface-module-name #f)
(define c-interface-proc-count #f)
(define c-interface-decls #f)
(define c-interface-procs #f)
(define c-interface-inits #f)
(define (make-c-intf decls procs inits) (vector decls procs inits))
(define (c-intf-decls c-intf) (vector-ref c-intf 0))
(define (c-intf-decls-set! c-intf x) (vector-set! c-intf 0 x))
(define (c-intf-procs c-intf) (vector-ref c-intf 1))
(define (c-intf-procs-set! c-intf x) (vector-set! c-intf 1 x))
(define (c-intf-inits c-intf) (vector-ref c-intf 2))
(define (c-intf-inits-set! c-intf x) (vector-set! c-intf 2 x))
(define (c-declaration-expr? source)
  (and (mymatch **c-declaration-sym 1 source)
       (let ((code (source-code source)))
         (or (string? (source-code (cadr code)))
             (pt-syntax-error
              source
              "Argument to '##c-declaration' must be a string")))))
(define (c-init-expr? source)
  (and (mymatch **c-init-sym 1 source)
       (let ((code (source-code source)))
         (or (string? (source-code (cadr code)))
             (pt-syntax-error
              source
              "Argument to '##c-init' must be a string")))))
(define (c-procedure-expr? source)
  (and (mymatch **c-procedure-sym 3 source)
       (let ((code (source-code source)))
         (if (not (string? (source-code (cadddr code))))
             (pt-syntax-error
              source
              "Last argument to '##c-procedure' must be a string")
             (check-arg-and-result-types source (cadr code) (caddr code))))))
(define scheme-to-c-notation
  (list (list void-sym "VOID" "void")
        (list char-sym "CHAR" "char")
        (list signed-char-sym "SCHAR" "signed char")
        (list unsigned-char-sym "UCHAR" "unsigned char")
        (list short-sym "SHORT" "short")
        (list unsigned-short-sym "USHORT" "unsigned short")
        (list int-sym "INT" "int")
        (list unsigned-int-sym "UINT" "unsigned int")
        (list long-sym "LONG" "long")
        (list unsigned-long-sym "ULONG" "unsigned long")
        (list float-sym "FLOAT" "float")
        (list double-sym "DOUBLE" "double")
        (list pointer-sym "POINTER" "void*")
        (list boolean-sym "BOOLEAN" "int")
        (list string-sym "STRING" "char*")
        (list scheme-object-sym "SCMOBJ" "long")))
(define (convert-type typ) (if (assq typ scheme-to-c-notation) typ #f))
(define (check-arg-and-result-types source arg-typs-source res-typ-source)
  (let ((arg-typs (source-code arg-typs-source))
        (res-typ (source-code res-typ-source)))
    (let ((res-type (convert-type res-typ)))
      (if (not res-type)
          (pt-syntax-error res-typ-source "Invalid result type")
          (if (not (proper-length arg-typs))
              (pt-syntax-error
               arg-typs-source
               "Ill-terminated argument type list")
              (let loop ((lst arg-typs))
                (if (pair? lst)
                    (let* ((arg-typ (source-code (car lst)))
                           (arg-type (convert-type arg-typ)))
                      (if (or (not arg-type) (eq? arg-type void-sym))
                          (pt-syntax-error (car lst) "Invalid argument type")
                          (loop (cdr lst))))
                    #t)))))))
(define (add-c-declaration declaration-string)
  (set! c-interface-decls (cons declaration-string c-interface-decls))
  #f)
(define (add-c-init initialization-code-string)
  (set! c-interface-inits (cons initialization-code-string c-interface-inits))
  #f)
(define (add-c-proc scheme-name c-name arity def)
  (set! c-interface-procs
        (cons (vector scheme-name c-name arity def) c-interface-procs))
  #f)
(define (pt-c-procedure source env use)
  (let* ((code (source-code source))
         (name (build-c-procedure
                (map source-code (source-code (cadr code)))
                (source-code (caddr code))
                (source-code (cadddr code))))
         (decl (env-declarations env)))
    (new-ref source decl (env-lookup-global-var env (string->symbol name)))))
(define (build-c-procedure argument-types result-type proc-name-or-code)
  (define proc-name?
    (let loop ((i (- (string-length proc-name-or-code) 1)))
      (if (>= i 0)
          (let ((c (string-ref proc-name-or-code i)))
            (if (or (char-alphabetic? c) (char=? c #\_)) (loop (- i 1)) #f))
          #t)))
  (define nl (string #\newline))
  (define undefined-value "UND")
  (define scheme-arg-prefix "ARG")
  (define scheme-result-name "RESULT")
  (define c-arg-prefix "arg")
  (define c-result-name "result")
  (define scheme-to-c-prefix "SCMOBJ_TO_")
  (define c-to-scheme-suffix "_TO_SCMOBJ")
  (define (c-type-name typ) (cadr (assq typ scheme-to-c-notation)))
  (define (c-type-decl typ) (caddr (assq typ scheme-to-c-notation)))
  (define (listify strings)
    (if (null? strings)
        ""
        (string-append
         (car strings)
         (apply string-append
                (map (lambda (s) (string-append "," s)) (cdr strings))))))
  (define (scheme-arg-var t)
    (string-append c-id-prefix scheme-arg-prefix (number->string (cdr t))))
  (define (c-arg-var t)
    (string-append c-id-prefix c-arg-prefix (number->string (cdr t))))
  (define (make-c-procedure arg-types res-type)
    (define (make-arg-decl)
      (apply string-append
             (map (lambda (t)
                    (string-append
                     (c-type-decl (car t))
                     " "
                     (c-arg-var t)
                     ";"
                     nl))
                  arg-types)))
    (define (make-conversions)
      (if (not (null? arg-types))
          (let loop ((lst arg-types) (str (string-append "if (" nl)))
            (if (null? lst)
                (string-append str "   )" nl)
                (let ((t (car lst)) (rest (cdr lst)))
                  (loop rest
                        (string-append
                         str
                         "    "
                         c-id-prefix
                         scheme-to-c-prefix
                         (c-type-name (car t))
                         "("
                         (scheme-arg-var t)
                         ","
                         (c-arg-var t)
                         ")"
                         (if (null? rest) "" " &&")
                         nl)))))
          ""))
    (define (make-body)
      (if proc-name?
          (let* ((param-list (listify (map c-arg-var arg-types)))
                 (call (string-append proc-name-or-code "(" param-list ")")))
            (if (eq? res-type void-sym)
                (string-append
                 "{"
                 nl
                 call
                 ";"
                 nl
                 c-id-prefix
                 scheme-result-name
                 " = "
                 c-id-prefix
                 undefined-value
                 ";"
                 nl
                 "}"
                 nl)
                (string-append
                 c-id-prefix
                 (c-type-name res-type)
                 c-to-scheme-suffix
                 "("
                 call
                 ","
                 c-id-prefix
                 scheme-result-name
                 ");"
                 nl)))
          (if (eq? res-type void-sym)
              (string-append
               "{"
               nl
               proc-name-or-code
               nl
               c-id-prefix
               scheme-result-name
               " = "
               c-id-prefix
               undefined-value
               ";"
               nl
               "}"
               nl)
              (string-append
               "{"
               nl
               proc-name-or-code
               nl
               c-id-prefix
               (c-type-name res-type)
               c-to-scheme-suffix
               "("
               c-id-prefix
               c-result-name
               ","
               c-id-prefix
               scheme-result-name
               ");"
               nl
               "}"
               nl))))
    (let* ((index (number->string c-interface-proc-count))
           (scheme-name (string-append "#!" c-interface-module-name "#" index))
           (c-name (string-append c-id-prefix (scheme-id->c-id scheme-name)))
           (arity (length argument-types))
           (def (string-append
                 (if (or proc-name? (eq? res-type void-sym))
                     ""
                     (string-append
                      (c-type-decl res-type)
                      " "
                      c-id-prefix
                      c-result-name
                      ";"
                      nl))
                 (make-arg-decl)
                 (make-conversions)
                 (make-body))))
      (set! c-interface-proc-count (+ c-interface-proc-count 1))
      (add-c-proc scheme-name c-name arity def)
      scheme-name))
  (let loop ((i 1) (lst1 argument-types) (lst2 '()))
    (if (pair? lst1)
        (loop (+ i 1) (cdr lst1) (cons (cons (car lst1) i) lst2))
        (make-c-procedure (reverse lst2) result-type))))
(define (scheme-id->c-id s)
  (define (hex->char i) (string-ref "0123456789abcdef" i))
  (let loop ((i (- (string-length s) 1)) (l '()))
    (if (>= i 0)
        (let ((c (string-ref s i)))
          (cond ((or (char-alphabetic? c) (char-numeric? c))
                 (loop (- i 1) (cons c l)))
                ((char=? c #\_) (loop (- i 1) (cons c (cons c l))))
                (else
                 (let ((n (character-encoding c)))
                   (loop (- i 1)
                         (cons #\_
                               (cons (hex->char (div n 16))
                                     (cons (hex->char (mod n 16)) l))))))))
        (lst->string l))))
(define (pt-syntax-error source msg . args)
  (apply compiler-user-error
         (cons (source-locat source)
               (cons (string-append "Syntax error -- " msg) args))))
(define (pt source env use)
  (cond ((macro-expr? source env) (pt (macro-expand source env) env use))
        ((self-eval-expr? source) (pt-self-eval source env use))
        ((quote-expr? source) (pt-quote source env use))
        ((quasiquote-expr? source) (pt-quasiquote source env use))
        ((unquote-expr? source)
         (pt-syntax-error source "Ill-placed 'unquote'"))
        ((unquote-splicing-expr? source)
         (pt-syntax-error source "Ill-placed 'unquote-splicing'"))
        ((var-expr? source env) (pt-var source env use))
        ((set!-expr? source env) (pt-set! source env use))
        ((lambda-expr? source env) (pt-lambda source env use))
        ((if-expr? source) (pt-if source env use))
        ((cond-expr? source) (pt-cond source env use))
        ((and-expr? source) (pt-and source env use))
        ((or-expr? source) (pt-or source env use))
        ((case-expr? source) (pt-case source env use))
        ((let-expr? source env) (pt-let source env use))
        ((let*-expr? source env) (pt-let* source env use))
        ((letrec-expr? source env) (pt-letrec source env use))
        ((begin-expr? source) (pt-begin source env use))
        ((do-expr? source env) (pt-do source env use))
        ((define-expr? source env)
         (pt-syntax-error source "Ill-placed 'define'"))
        ((delay-expr? source env) (pt-delay source env use))
        ((future-expr? source env) (pt-future source env use))
        ((define-macro-expr? source env)
         (pt-syntax-error source "Ill-placed '##define-macro'"))
        ((begin-defs-expr? source)
         (pt-syntax-error source "Ill-placed 'begin' style definitions"))
        ((declare-expr? source)
         (pt-syntax-error source "Ill-placed '##declare'"))
        ((c-declaration-expr? source)
         (pt-syntax-error source "Ill-placed '##c-declaration'"))
        ((c-init-expr? source)
         (pt-syntax-error source "Ill-placed '##c-init'"))
        ((c-procedure-expr? source) (pt-c-procedure source env use))
        ((combination-expr? source) (pt-combination source env use))
        (else (compiler-internal-error "pt, unknown expression type" source))))
(define (macro-expand source env)
  (let ((code (source-code source)))
    (expression->source
     (apply (cdr (env-lookup-macro env (source-code (car code))))
            (cdr (source->expression source)))
     source)))
(define (pt-self-eval source env use)
  (let ((val (source->expression source)))
    (if (eq? use 'none)
        (new-cst source (env-declarations env) undef-object)
        (new-cst source (env-declarations env) val))))
(define (pt-quote source env use)
  (let ((code (source-code source)))
    (if (eq? use 'none)
        (new-cst source (env-declarations env) undef-object)
        (new-cst source
                 (env-declarations env)
                 (source->expression (cadr code))))))
(define (pt-quasiquote source env use)
  (let ((code (source-code source))) (pt-quasiquotation (cadr code) 1 env)))
(define (pt-quasiquotation form level env)
  (cond ((= level 0) (pt form env 'true))
        ((quasiquote-expr? form)
         (pt-quasiquotation-list form (source-code form) (+ level 1) env))
        ((unquote-expr? form)
         (if (= level 1)
             (pt (cadr (source-code form)) env 'true)
             (pt-quasiquotation-list form (source-code form) (- level 1) env)))
        ((unquote-splicing-expr? form)
         (if (= level 1)
             (pt-syntax-error form "Ill-placed 'unquote-splicing'")
             (pt-quasiquotation-list form (source-code form) (- level 1) env)))
        ((pair? (source-code form))
         (pt-quasiquotation-list form (source-code form) level env))
        ((vector? (source-code form))
         (vector-form
          form
          (pt-quasiquotation-list
           form
           (vector->lst (source-code form))
           level
           env)
          env))
        (else
         (new-cst form (env-declarations env) (source->expression form)))))
(define (pt-quasiquotation-list form l level env)
  (cond ((pair? l)
         (if (and (unquote-splicing-expr? (car l)) (= level 1))
             (let ((x (pt (cadr (source-code (car l))) env 'true)))
               (if (null? (cdr l))
                   x
                   (append-form
                    (car l)
                    x
                    (pt-quasiquotation-list form (cdr l) 1 env)
                    env)))
             (cons-form
              form
              (pt-quasiquotation (car l) level env)
              (pt-quasiquotation-list form (cdr l) level env)
              env)))
        ((null? l) (new-cst form (env-declarations env) '()))
        (else (pt-quasiquotation l level env))))
(define (append-form source ptree1 ptree2 env)
  (cond ((and (cst? ptree1) (cst? ptree2))
         (new-cst source
                  (env-declarations env)
                  (append (cst-val ptree1) (cst-val ptree2))))
        ((and (cst? ptree2) (null? (cst-val ptree2))) ptree1)
        (else
         (new-call*
          source
          (add-not-safe (env-declarations env))
          (new-ref-extended-bindings source **quasi-append-sym env)
          (list ptree1 ptree2)))))
(define (cons-form source ptree1 ptree2 env)
  (cond ((and (cst? ptree1) (cst? ptree2))
         (new-cst source
                  (env-declarations env)
                  (cons (cst-val ptree1) (cst-val ptree2))))
        ((and (cst? ptree2) (null? (cst-val ptree2)))
         (new-call*
          source
          (add-not-safe (env-declarations env))
          (new-ref-extended-bindings source **quasi-list-sym env)
          (list ptree1)))
        (else
         (new-call*
          source
          (add-not-safe (env-declarations env))
          (new-ref-extended-bindings source **quasi-cons-sym env)
          (list ptree1 ptree2)))))
(define (vector-form source ptree env)
  (if (cst? ptree)
      (new-cst source (env-declarations env) (lst->vector (cst-val ptree)))
      (new-call*
       source
       (add-not-safe (env-declarations env))
       (new-ref-extended-bindings source **quasi-list->vector-sym env)
       (list ptree))))
(define (pt-var source env use)
  (if (eq? use 'none)
      (new-cst source (env-declarations env) undef-object)
      (new-ref source
               (env-declarations env)
               (env-lookup-var env (source-code source) source))))
(define (pt-set! source env use)
  (let ((code (source-code source)))
    (new-set source
             (env-declarations env)
             (env-lookup-var env (source-code (cadr code)) (cadr code))
             (pt (caddr code) env 'true))))
(define (pt-lambda source env use)
  (let ((code (source-code source)))
    (define (new-params parms)
      (cond ((pair? parms)
             (let* ((parm* (car parms))
                    (parm (source-code parm*))
                    (p* (if (pair? parm) (car parm) parm*)))
               (cons (make-var (source-code p*) #t (set-empty) (set-empty) p*)
                     (new-params (cdr parms)))))
            ((null? parms) '())
            (else
             (list (make-var
                    (source-code parms)
                    #t
                    (set-empty)
                    (set-empty)
                    parms)))))
    (define (min-params parms)
      (let loop ((l parms) (n 0))
        (if (pair? l)
            (if (pair? (source-code (car l))) n (loop (cdr l) (+ n 1)))
            n)))
    (define (rest-param? parms)
      (if (pair? parms) (rest-param? (cdr parms)) (not (null? parms))))
    (define (optionals parms source body env)
      (if (pair? parms)
          (let* ((parm* (car parms)) (parm (source-code parm*)))
            (if (and (pair? parm) (length? parm 2))
                (let* ((var (car parm))
                       (vars (new-variables (list var)))
                       (decl (env-declarations env)))
                  (new-call*
                   parm*
                   decl
                   (new-prc parm*
                            decl
                            #f
                            1
                            #f
                            vars
                            (optionals
                             (cdr parms)
                             source
                             body
                             (env-frame env vars)))
                   (list (new-tst parm*
                                  decl
                                  (new-call*
                                   parm*
                                   decl
                                   (new-ref-extended-bindings
                                    parm*
                                    **unassigned?-sym
                                    env)
                                   (list (new-ref parm*
                                                  decl
                                                  (env-lookup-var
                                                   env
                                                   (source-code var)
                                                   var))))
                                  (pt (cadr parm) env 'true)
                                  (new-ref parm*
                                           decl
                                           (env-lookup-var
                                            env
                                            (source-code var)
                                            var))))))
                (optionals (cdr parms) source body env)))
          (pt-body source body env 'true)))
    (if (eq? use 'none)
        (new-cst source (env-declarations env) undef-object)
        (let* ((parms (source->parms (cadr code))) (frame (new-params parms)))
          (new-prc source
                   (env-declarations env)
                   #f
                   (min-params parms)
                   (rest-param? parms)
                   frame
                   (optionals
                    parms
                    source
                    (cddr code)
                    (env-frame env frame)))))))
(define (source->parms source)
  (let ((x (source-code source))) (if (or (pair? x) (null? x)) x source)))
(define (pt-body source body env use)
  (define (letrec-defines vars vals envs body env)
    (cond ((null? body)
           (pt-syntax-error
            source
            "Body must contain at least one evaluable expression"))
          ((macro-expr? (car body) env)
           (letrec-defines
            vars
            vals
            envs
            (cons (macro-expand (car body) env) (cdr body))
            env))
          ((begin-defs-expr? (car body))
           (letrec-defines
            vars
            vals
            envs
            (append (begin-defs-body (car body)) (cdr body))
            env))
          ((include-expr? (car body))
           (if *ptree-port* (display "  " *ptree-port*))
           (let ((x (file->sources*
                     (include-filename (car body))
                     *ptree-port*
                     (source-locat (car body)))))
             (if *ptree-port* (newline *ptree-port*))
             (letrec-defines vars vals envs (append x (cdr body)) env)))
          ((define-expr? (car body) env)
           (let* ((var** (definition-variable (car body)))
                  (var* (source-code var**))
                  (var (env-define-var env var* var**)))
             (letrec-defines
              (cons var vars)
              (cons (definition-value (car body)) vals)
              (cons env envs)
              (cdr body)
              env)))
          ((declare-expr? (car body))
           (letrec-defines
            vars
            vals
            envs
            (cdr body)
            (add-declarations (car body) env)))
          ((define-macro-expr? (car body) env)
           (letrec-defines
            vars
            vals
            envs
            (cdr body)
            (add-macro (car body) env)))
          ((c-declaration-expr? (car body))
           (add-c-declaration (source-code (cadr (source-code (car body)))))
           (letrec-defines vars vals envs (cdr body) env))
          ((c-init-expr? (car body))
           (add-c-init (source-code (cadr (source-code (car body)))))
           (letrec-defines vars vals envs (cdr body) env))
          ((null? vars) (pt-sequence source body env use))
          (else
           (let ((vars* (reverse vars)))
             (let loop ((vals* '()) (l1 vals) (l2 envs))
               (if (not (null? l1))
                   (loop (cons (pt (car l1) (car l2) 'true) vals*)
                         (cdr l1)
                         (cdr l2))
                   (pt-recursive-let source vars* vals* body env use)))))))
  (letrec-defines '() '() '() body (env-frame env '())))
(define (pt-sequence source seq env use)
  (if (length? seq 1)
      (pt (car seq) env use)
      (new-seq source
               (env-declarations env)
               (pt (car seq) env 'none)
               (pt-sequence source (cdr seq) env use))))
(define (pt-if source env use)
  (let ((code (source-code source)))
    (new-tst source
             (env-declarations env)
             (pt (cadr code) env 'pred)
             (pt (caddr code) env use)
             (if (length? code 3)
                 (new-cst source (env-declarations env) undef-object)
                 (pt (cadddr code) env use)))))
(define (pt-cond source env use)
  (define (pt-clauses clauses)
    (if (length? clauses 0)
        (new-cst source (env-declarations env) undef-object)
        (let* ((clause* (car clauses)) (clause (source-code clause*)))
          (cond ((eq? (source-code (car clause)) else-sym)
                 (pt-sequence clause* (cdr clause) env use))
                ((length? clause 1)
                 (new-disj
                  clause*
                  (env-declarations env)
                  (pt (car clause) env (if (eq? use 'true) 'true 'pred))
                  (pt-clauses (cdr clauses))))
                ((eq? (source-code (cadr clause)) =>-sym)
                 (new-disj-call
                  clause*
                  (env-declarations env)
                  (pt (car clause) env 'true)
                  (pt (caddr clause) env 'true)
                  (pt-clauses (cdr clauses))))
                (else
                 (new-tst clause*
                          (env-declarations env)
                          (pt (car clause) env 'pred)
                          (pt-sequence clause* (cdr clause) env use)
                          (pt-clauses (cdr clauses))))))))
  (pt-clauses (cdr (source-code source))))
(define (pt-and source env use)
  (define (pt-exprs exprs)
    (cond ((length? exprs 0) (new-cst source (env-declarations env) #t))
          ((length? exprs 1) (pt (car exprs) env use))
          (else
           (new-conj
            (car exprs)
            (env-declarations env)
            (pt (car exprs) env (if (eq? use 'true) 'true 'pred))
            (pt-exprs (cdr exprs))))))
  (pt-exprs (cdr (source-code source))))
(define (pt-or source env use)
  (define (pt-exprs exprs)
    (cond ((length? exprs 0)
           (new-cst source (env-declarations env) false-object))
          ((length? exprs 1) (pt (car exprs) env use))
          (else
           (new-disj
            (car exprs)
            (env-declarations env)
            (pt (car exprs) env (if (eq? use 'true) 'true 'pred))
            (pt-exprs (cdr exprs))))))
  (pt-exprs (cdr (source-code source))))
(define (pt-case source env use)
  (let ((code (source-code source)) (temp (new-temps source '(temp))))
    (define (pt-clauses clauses)
      (if (length? clauses 0)
          (new-cst source (env-declarations env) undef-object)
          (let* ((clause* (car clauses)) (clause (source-code clause*)))
            (if (eq? (source-code (car clause)) else-sym)
                (pt-sequence clause* (cdr clause) env use)
                (new-tst clause*
                         (env-declarations env)
                         (new-call*
                          clause*
                          (add-not-safe (env-declarations env))
                          (new-ref-extended-bindings
                           clause*
                           **case-memv-sym
                           env)
                          (list (new-ref clause*
                                         (env-declarations env)
                                         (car temp))
                                (new-cst (car clause)
                                         (env-declarations env)
                                         (source->expression (car clause)))))
                         (pt-sequence clause* (cdr clause) env use)
                         (pt-clauses (cdr clauses)))))))
    (new-call*
     source
     (env-declarations env)
     (new-prc source
              (env-declarations env)
              #f
              1
              #f
              temp
              (pt-clauses (cddr code)))
     (list (pt (cadr code) env 'true)))))
(define (pt-let source env use)
  (let ((code (source-code source)))
    (if (bindable-var? (cadr code) env)
        (let* ((self (new-variables (list (cadr code))))
               (bindings (map source-code (source-code (caddr code))))
               (vars (new-variables (map car bindings)))
               (vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))
               (env (env-frame (env-frame env vars) self))
               (self-proc
                (list (new-prc source
                               (env-declarations env)
                               #f
                               (length vars)
                               #f
                               vars
                               (pt-body source (cdddr code) env use)))))
          (set-prc-names! self self-proc)
          (set-prc-names! vars vals)
          (new-call*
           source
           (env-declarations env)
           (new-prc source
                    (env-declarations env)
                    #f
                    1
                    #f
                    self
                    (new-call*
                     source
                     (env-declarations env)
                     (new-ref source (env-declarations env) (car self))
                     vals))
           self-proc))
        (if (null? (source-code (cadr code)))
            (pt-body source (cddr code) env use)
            (let* ((bindings (map source-code (source-code (cadr code))))
                   (vars (new-variables (map car bindings)))
                   (vals (map (lambda (x) (pt (cadr x) env 'true)) bindings))
                   (env (env-frame env vars)))
              (set-prc-names! vars vals)
              (new-call*
               source
               (env-declarations env)
               (new-prc source
                        (env-declarations env)
                        #f
                        (length vars)
                        #f
                        vars
                        (pt-body source (cddr code) env use))
               vals))))))
(define (pt-let* source env use)
  (let ((code (source-code source)))
    (define (pt-bindings bindings env use)
      (if (null? bindings)
          (pt-body source (cddr code) env use)
          (let* ((binding* (car bindings))
                 (binding (source-code binding*))
                 (vars (new-variables (list (car binding))))
                 (vals (list (pt (cadr binding) env 'true)))
                 (env (env-frame env vars)))
            (set-prc-names! vars vals)
            (new-call*
             binding*
             (env-declarations env)
             (new-prc binding*
                      (env-declarations env)
                      #f
                      1
                      #f
                      vars
                      (pt-bindings (cdr bindings) env use))
             vals))))
    (pt-bindings (source-code (cadr code)) env use)))
(define (pt-letrec source env use)
  (let* ((code (source-code source))
         (bindings (map source-code (source-code (cadr code))))
         (vars* (new-variables (map car bindings)))
         (env* (env-frame env vars*)))
    (pt-recursive-let
     source
     vars*
     (map (lambda (x) (pt (cadr x) env* 'true)) bindings)
     (cddr code)
     env*
     use)))
(define (pt-recursive-let source vars vals body env use)
  (define (dependency-graph vars vals)
    (define (dgraph vars* vals*)
      (if (null? vars*)
          (set-empty)
          (let ((var (car vars*)) (val (car vals*)))
            (set-adjoin
             (dgraph (cdr vars*) (cdr vals*))
             (make-gnode
              var
              (set-intersection (list->set vars) (free-variables val)))))))
    (dgraph vars vals))
  (define (val-of var)
    (list-ref vals (- (length vars) (length (memq var vars)))))
  (define (bind-in-order order)
    (if (null? order)
        (pt-body source body env use)
        (let* ((vars-set (car order)) (vars (set->list vars-set)))
          (let loop1 ((l (reverse vars))
                      (vars-b '())
                      (vals-b '())
                      (vars-a '()))
            (if (not (null? l))
                (let* ((var (car l)) (val (val-of var)))
                  (if (or (prc? val)
                          (set-empty?
                           (set-intersection (free-variables val) vars-set)))
                      (loop1 (cdr l)
                             (cons var vars-b)
                             (cons val vals-b)
                             vars-a)
                      (loop1 (cdr l) vars-b vals-b (cons var vars-a))))
                (let* ((result1 (let loop2 ((l vars-a))
                                  (if (not (null? l))
                                      (let* ((var (car l)) (val (val-of var)))
                                        (new-seq source
                                                 (env-declarations env)
                                                 (new-set source
                                                          (env-declarations
                                                           env)
                                                          var
                                                          val)
                                                 (loop2 (cdr l))))
                                      (bind-in-order (cdr order)))))
                       (result2 (if (null? vars-b)
                                    result1
                                    (new-call*
                                     source
                                     (env-declarations env)
                                     (new-prc source
                                              (env-declarations env)
                                              #f
                                              (length vars-b)
                                              #f
                                              vars-b
                                              result1)
                                     vals-b)))
                       (result3 (if (null? vars-a)
                                    result2
                                    (new-call*
                                     source
                                     (env-declarations env)
                                     (new-prc source
                                              (env-declarations env)
                                              #f
                                              (length vars-a)
                                              #f
                                              vars-a
                                              result2)
                                     (map (lambda (var)
                                            (new-cst source
                                                     (env-declarations env)
                                                     undef-object))
                                          vars-a)))))
                  result3))))))
  (set-prc-names! vars vals)
  (bind-in-order
   (topological-sort (transitive-closure (dependency-graph vars vals)))))
(define (pt-begin source env use)
  (pt-sequence source (cdr (source-code source)) env use))
(define (pt-do source env use)
  (let* ((code (source-code source))
         (loop (new-temps source '(loop)))
         (bindings (map source-code (source-code (cadr code))))
         (vars (new-variables (map car bindings)))
         (init (map (lambda (x) (pt (cadr x) env 'true)) bindings))
         (env (env-frame env vars))
         (step (map (lambda (x)
                      (pt (if (length? x 2) (car x) (caddr x)) env 'true))
                    bindings))
         (exit (source-code (caddr code))))
    (set-prc-names! vars init)
    (new-call*
     source
     (env-declarations env)
     (new-prc source
              (env-declarations env)
              #f
              1
              #f
              loop
              (new-call*
               source
               (env-declarations env)
               (new-ref source (env-declarations env) (car loop))
               init))
     (list (new-prc source
                    (env-declarations env)
                    #f
                    (length vars)
                    #f
                    vars
                    (new-tst source
                             (env-declarations env)
                             (pt (car exit) env 'pred)
                             (if (length? exit 1)
                                 (new-cst (caddr code)
                                          (env-declarations env)
                                          undef-object)
                                 (pt-sequence (caddr code) (cdr exit) env use))
                             (if (length? code 3)
                                 (new-call*
                                  source
                                  (env-declarations env)
                                  (new-ref source
                                           (env-declarations env)
                                           (car loop))
                                  step)
                                 (new-seq source
                                          (env-declarations env)
                                          (pt-sequence
                                           source
                                           (cdddr code)
                                           env
                                           'none)
                                          (new-call*
                                           source
                                           (env-declarations env)
                                           (new-ref source
                                                    (env-declarations env)
                                                    (car loop))
                                           step)))))))))
(define (pt-combination source env use)
  (let* ((code (source-code source))
         (oper (pt (car code) env 'true))
         (decl (node-decl oper)))
    (new-call*
     source
     (env-declarations env)
     oper
     (map (lambda (x) (pt x env 'true)) (cdr code)))))
(define (pt-delay source env use)
  (let ((code (source-code source)))
    (new-call*
     source
     (add-not-safe (env-declarations env))
     (new-ref-extended-bindings source **make-placeholder-sym env)
     (list (new-prc source
                    (env-declarations env)
                    #f
                    0
                    #f
                    '()
                    (pt (cadr code) env 'true))))))
(define (pt-future source env use)
  (let ((decl (env-declarations env)) (code (source-code source)))
    (new-fut source decl (pt (cadr code) env 'true))))
(define (self-eval-expr? source)
  (let ((code (source-code source)))
    (and (not (pair? code)) (not (symbol-object? code)))))
(define (quote-expr? source) (mymatch quote-sym 1 source))
(define (quasiquote-expr? source) (mymatch quasiquote-sym 1 source))
(define (unquote-expr? source) (mymatch unquote-sym 1 source))
(define (unquote-splicing-expr? source)
  (mymatch unquote-splicing-sym 1 source))
(define (var-expr? source env)
  (let ((code (source-code source)))
    (and (symbol-object? code)
         (not-keyword source env code)
         (not-macro source env code))))
(define (not-macro source env name)
  (if (env-lookup-macro env name)
      (pt-syntax-error source "Macro name can't be used as a variable:" name)
      #t))
(define (bindable-var? source env)
  (let ((code (source-code source)))
    (and (symbol-object? code) (not-keyword source env code))))
(define (not-keyword source env name)
  (if (or (memq name common-keywords)
          (memq name
                (dialect-specific-keywords
                 (scheme-dialect (env-declarations env)))))
      (pt-syntax-error
       source
       "Predefined keyword can't be used as a variable:"
       name)
      #t))
(define (set!-expr? source env)
  (and (mymatch set!-sym 2 source)
       (var-expr? (cadr (source-code source)) env)))
(define (lambda-expr? source env)
  (and (mymatch lambda-sym -2 source)
       (proper-parms? (source->parms (cadr (source-code source))) env)))
(define (if-expr? source)
  (and (mymatch if-sym -2 source)
       (or (<= (length (source-code source)) 4)
           (pt-syntax-error source "Ill-formed special form" if-sym))))
(define (cond-expr? source)
  (and (mymatch cond-sym -1 source) (proper-clauses? source)))
(define (and-expr? source) (mymatch and-sym 0 source))
(define (or-expr? source) (mymatch or-sym 0 source))
(define (case-expr? source)
  (and (mymatch case-sym -2 source) (proper-case-clauses? source)))
(define (let-expr? source env)
  (and (mymatch let-sym -2 source)
       (let ((code (source-code source)))
         (if (bindable-var? (cadr code) env)
             (and (proper-bindings? (caddr code) #t env)
                  (or (> (length code) 3)
                      (pt-syntax-error source "Ill-formed named 'let'")))
             (proper-bindings? (cadr code) #t env)))))
(define (let*-expr? source env)
  (and (mymatch let*-sym -2 source)
       (proper-bindings? (cadr (source-code source)) #f env)))
(define (letrec-expr? source env)
  (and (mymatch letrec-sym -2 source)
       (proper-bindings? (cadr (source-code source)) #t env)))
(define (begin-expr? source) (mymatch begin-sym -1 source))
(define (do-expr? source env)
  (and (mymatch do-sym -2 source)
       (proper-do-bindings? source env)
       (proper-do-exit? source)))
(define (define-expr? source env)
  (and (mymatch define-sym -1 source)
       (proper-definition? source env)
       (let ((v (definition-variable source)))
         (not-macro v env (source-code v)))))
(define (combination-expr? source)
  (let ((length (proper-length (source-code source))))
    (if length
        (or (> length 0) (pt-syntax-error source "Ill-formed procedure call"))
        (pt-syntax-error source "Ill-terminated procedure call"))))
(define (delay-expr? source env)
  (and (not (eq? (scheme-dialect (env-declarations env)) ieee-scheme-sym))
       (mymatch delay-sym 1 source)))
(define (future-expr? source env)
  (and (eq? (scheme-dialect (env-declarations env)) multilisp-sym)
       (mymatch future-sym 1 source)))
(define (macro-expr? source env)
  (let ((code (source-code source)))
    (and (pair? code)
         (symbol-object? (source-code (car code)))
         (let ((macr (env-lookup-macro env (source-code (car code)))))
           (and macr
                (let ((len (proper-length (cdr code))))
                  (if len
                      (let ((len* (+ len 1)) (size (car macr)))
                        (or (if (> size 0) (= len* size) (>= len* (- size)))
                            (pt-syntax-error source "Ill-formed macro form")))
                      (pt-syntax-error
                       source
                       "Ill-terminated macro form"))))))))
(define (define-macro-expr? source env)
  (and (mymatch **define-macro-sym -1 source) (proper-definition? source env)))
(define (declare-expr? source) (mymatch **declare-sym -1 source))
(define (include-expr? source) (mymatch **include-sym 1 source))
(define (begin-defs-expr? source) (mymatch begin-sym 0 source))
(define (mymatch keyword size source)
  (let ((code (source-code source)))
    (and (pair? code)
         (eq? (source-code (car code)) keyword)
         (let ((length (proper-length (cdr code))))
           (if length
               (or (if (> size 0) (= length size) (>= length (- size)))
                   (pt-syntax-error source "Ill-formed special form" keyword))
               (pt-syntax-error
                source
                "Ill-terminated special form"
                keyword))))))
(define (proper-length l)
  (define (length l n)
    (cond ((pair? l) (length (cdr l) (+ n 1))) ((null? l) n) (else #f)))
  (length l 0))
(define (proper-definition? source env)
  (let* ((code (source-code source))
         (pattern* (cadr code))
         (pattern (source-code pattern*))
         (body (cddr code)))
    (cond ((bindable-var? pattern* env)
           (cond ((length? body 0) #t)
                 ((length? body 1) #t)
                 (else (pt-syntax-error source "Ill-formed definition body"))))
          ((pair? pattern)
           (if (length? body 0)
               (pt-syntax-error
                source
                "Body of a definition must have at least one expression"))
           (if (bindable-var? (car pattern) env)
               (proper-parms? (cdr pattern) env)
               (pt-syntax-error
                (car pattern)
                "Procedure name must be an identifier")))
          (else (pt-syntax-error pattern* "Ill-formed definition pattern")))))
(define (definition-variable def)
  (let* ((code (source-code def)) (pattern (cadr code)))
    (if (pair? (source-code pattern)) (car (source-code pattern)) pattern)))
(define (definition-value def)
  (let ((code (source-code def)) (loc (source-locat def)))
    (cond ((pair? (source-code (cadr code)))
           (make-source
            (cons (make-source lambda-sym loc)
                  (cons (parms->source (cdr (source-code (cadr code))) loc)
                        (cddr code)))
            loc))
          ((null? (cddr code))
           (make-source
            (list (make-source quote-sym loc) (make-source undef-object loc))
            loc))
          (else (caddr code)))))
(define (parms->source parms loc)
  (if (or (pair? parms) (null? parms)) (make-source parms loc) parms))
(define (proper-parms? parms env)
  (define (proper-parms parms seen optional-seen)
    (cond ((pair? parms)
           (let* ((parm* (car parms)) (parm (source-code parm*)))
             (cond ((pair? parm)
                    (if (eq? (scheme-dialect (env-declarations env))
                             multilisp-sym)
                        (let ((length (proper-length parm)))
                          (if (or (eqv? length 1) (eqv? length 2))
                              (let ((var (car parm)))
                                (if (bindable-var? var env)
                                    (if (memq (source-code var) seen)
                                        (pt-syntax-error
                                         var
                                         "Duplicate parameter in parameter list")
                                        (proper-parms
                                         (cdr parms)
                                         (cons (source-code var) seen)
                                         #t))
                                    (pt-syntax-error
                                     var
                                     "Parameter must be an identifier")))
                              (pt-syntax-error
                               parm*
                               "Ill-formed optional parameter")))
                        (pt-syntax-error
                         parm*
                         "optional parameters illegal in this dialect")))
                   (optional-seen
                    (pt-syntax-error parm* "Optional parameter expected"))
                   ((bindable-var? parm* env)
                    (if (memq parm seen)
                        (pt-syntax-error
                         parm*
                         "Duplicate parameter in parameter list"))
                    (proper-parms (cdr parms) (cons parm seen) #f))
                   (else
                    (pt-syntax-error
                     parm*
                     "Parameter must be an identifier")))))
          ((null? parms) #t)
          ((bindable-var? parms env)
           (if (memq (source-code parms) seen)
               (pt-syntax-error parms "Duplicate parameter in parameter list")
               #t))
          (else
           (pt-syntax-error parms "Rest parameter must be an identifier"))))
  (proper-parms parms '() #f))
(define (proper-clauses? source)
  (define (proper-clauses clauses)
    (or (null? clauses)
        (let* ((clause* (car clauses))
               (clause (source-code clause*))
               (length (proper-length clause)))
          (if length
              (if (>= length 1)
                  (if (eq? (source-code (car clause)) else-sym)
                      (cond ((= length 1)
                             (pt-syntax-error
                              clause*
                              "Else clause must have a body"))
                            ((not (null? (cdr clauses)))
                             (pt-syntax-error
                              clause*
                              "Else clause must be the last clause"))
                            (else (proper-clauses (cdr clauses))))
                      (if (and (>= length 2)
                               (eq? (source-code (cadr clause)) =>-sym)
                               (not (= length 3)))
                          (pt-syntax-error
                           (cadr clause)
                           "'=>' must be followed by a single expression")
                          (proper-clauses (cdr clauses))))
                  (pt-syntax-error clause* "Ill-formed 'cond' clause"))
              (pt-syntax-error clause* "Ill-terminated 'cond' clause")))))
  (proper-clauses (cdr (source-code source))))
(define (proper-case-clauses? source)
  (define (proper-case-clauses clauses)
    (or (null? clauses)
        (let* ((clause* (car clauses))
               (clause (source-code clause*))
               (length (proper-length clause)))
          (if length
              (if (>= length 2)
                  (if (eq? (source-code (car clause)) else-sym)
                      (if (not (null? (cdr clauses)))
                          (pt-syntax-error
                           clause*
                           "Else clause must be the last clause")
                          (proper-case-clauses (cdr clauses)))
                      (begin
                        (proper-selector-list? (car clause))
                        (proper-case-clauses (cdr clauses))))
                  (pt-syntax-error
                   clause*
                   "A 'case' clause must have a selector list and a body"))
              (pt-syntax-error clause* "Ill-terminated 'case' clause")))))
  (proper-case-clauses (cddr (source-code source))))
(define (proper-selector-list? source)
  (let* ((code (source-code source)) (length (proper-length code)))
    (if length
        (or (>= length 1)
            (pt-syntax-error
             source
             "Selector list must contain at least one element"))
        (pt-syntax-error source "Ill-terminated selector list"))))
(define (proper-bindings? bindings check-dupl? env)
  (define (proper-bindings l seen)
    (cond ((pair? l)
           (let* ((binding* (car l)) (binding (source-code binding*)))
             (if (eqv? (proper-length binding) 2)
                 (let ((var (car binding)))
                   (if (bindable-var? var env)
                       (if (and check-dupl? (memq (source-code var) seen))
                           (pt-syntax-error
                            var
                            "Duplicate variable in bindings")
                           (proper-bindings
                            (cdr l)
                            (cons (source-code var) seen)))
                       (pt-syntax-error
                        var
                        "Binding variable must be an identifier")))
                 (pt-syntax-error binding* "Ill-formed binding"))))
          ((null? l) #t)
          (else (pt-syntax-error bindings "Ill-terminated binding list"))))
  (proper-bindings (source-code bindings) '()))
(define (proper-do-bindings? source env)
  (let ((bindings (cadr (source-code source))))
    (define (proper-bindings l seen)
      (cond ((pair? l)
             (let* ((binding* (car l))
                    (binding (source-code binding*))
                    (length (proper-length binding)))
               (if (or (eqv? length 2) (eqv? length 3))
                   (let ((var (car binding)))
                     (if (bindable-var? var env)
                         (if (memq (source-code var) seen)
                             (pt-syntax-error
                              var
                              "Duplicate variable in bindings")
                             (proper-bindings
                              (cdr l)
                              (cons (source-code var) seen)))
                         (pt-syntax-error
                          var
                          "Binding variable must be an identifier")))
                   (pt-syntax-error binding* "Ill-formed binding"))))
            ((null? l) #t)
            (else (pt-syntax-error bindings "Ill-terminated binding list"))))
    (proper-bindings (source-code bindings) '())))
(define (proper-do-exit? source)
  (let* ((code (source-code (caddr (source-code source))))
         (length (proper-length code)))
    (if length
        (or (> length 0) (pt-syntax-error source "Ill-formed exit clause"))
        (pt-syntax-error source "Ill-terminated exit clause"))))
(define (include-filename source) (source-code (cadr (source-code source))))
(define (begin-defs-body source) (cdr (source-code source)))
(define (length? l n)
  (cond ((null? l) (= n 0)) ((> n 0) (length? (cdr l) (- n 1))) (else #f)))
(define (transform-declaration source)
  (let ((code (source-code source)))
    (if (not (pair? code))
        (pt-syntax-error source "Ill-formed declaration")
        (let* ((pos (not (eq? (source-code (car code)) not-sym)))
               (x (if pos code (cdr code))))
          (if (not (pair? x))
              (pt-syntax-error source "Ill-formed declaration")
              (let* ((id* (car x)) (id (source-code id*)))
                (cond ((not (symbol-object? id))
                       (pt-syntax-error
                        id*
                        "Declaration name must be an identifier"))
                      ((assq id flag-declarations)
                       (cond ((not pos)
                              (pt-syntax-error
                               id*
                               "Declaration can't be negated"))
                             ((null? (cdr x))
                              (flag-decl
                               source
                               (cdr (assq id flag-declarations))
                               id))
                             (else
                              (pt-syntax-error
                               source
                               "Ill-formed declaration"))))
                      ((memq id parameterized-declarations)
                       (cond ((not pos)
                              (pt-syntax-error
                               id*
                               "Declaration can't be negated"))
                             ((eqv? (proper-length x) 2)
                              (parameterized-decl
                               source
                               id
                               (source->expression (cadr x))))
                             (else
                              (pt-syntax-error
                               source
                               "Ill-formed declaration"))))
                      ((memq id boolean-declarations)
                       (if (null? (cdr x))
                           (boolean-decl source id pos)
                           (pt-syntax-error source "Ill-formed declaration")))
                      ((assq id namable-declarations)
                       (cond ((not pos)
                              (pt-syntax-error
                               id*
                               "Declaration can't be negated"))
                             (else
                              (namable-decl
                               source
                               (cdr (assq id namable-declarations))
                               id
                               (map source->expression (cdr x))))))
                      ((memq id namable-boolean-declarations)
                       (namable-boolean-decl
                        source
                        id
                        pos
                        (map source->expression (cdr x))))
                      ((memq id namable-string-declarations)
                       (if (not (pair? (cdr x)))
                           (pt-syntax-error source "Ill-formed declaration")
                           (let* ((str* (cadr x)) (str (source-code str*)))
                             (cond ((not pos)
                                    (pt-syntax-error
                                     id*
                                     "Declaration can't be negated"))
                                   ((not (string? str))
                                    (pt-syntax-error str* "String expected"))
                                   (else
                                    (namable-string-decl
                                     source
                                     id
                                     str
                                     (map source->expression (cddr x))))))))
                      (else (pt-syntax-error id* "Unknown declaration")))))))))
(define (add-declarations source env)
  (let loop ((l (cdr (source-code source))) (env env))
    (if (pair? l)
        (loop (cdr l) (env-declare env (transform-declaration (car l))))
        env)))
(define (add-decl d decl) (env-declare decl d))
(define (add-macro source env)
  (define (form-size parms)
    (let loop ((l parms) (n 1))
      (if (pair? l) (loop (cdr l) (+ n 1)) (if (null? l) n (- n)))))
  (define (error-proc . msgs)
    (apply compiler-user-error
           (cons (source-locat source) (cons "(in macro body)" msgs))))
  (let ((var (definition-variable source)) (proc (definition-value source)))
    (if (lambda-expr? proc env)
        (env-macro
         env
         (source-code var)
         (cons (form-size (source->parms (cadr (source-code proc))))
               (scheme-global-eval (source->expression proc) error-proc)))
        (pt-syntax-error source "Macro value must be a lambda expression"))))
(define (ptree.begin! info-port) (set! *ptree-port* info-port) '())
(define (ptree.end!) '())
(define *ptree-port* '())
(define (normalize-parse-tree ptree env)
  (define (normalize ptree)
    (let ((tree (assignment-convert (partial-evaluate ptree) env)))
      (lambda-lift! tree)
      tree))
  (if (def? ptree)
      (begin
        (node-children-set! ptree (list (normalize (def-val ptree))))
        ptree)
      (normalize ptree)))
(define (partial-evaluate ptree) (pe ptree '()))
(define (pe ptree consts)
  (cond ((cst? ptree)
         (new-cst (node-source ptree) (node-decl ptree) (cst-val ptree)))
        ((ref? ptree)
         (let ((var (ref-var ptree)))
           (var-refs-set! var (set-remove (var-refs var) ptree))
           (let ((x (assq var consts)))
             (if x
                 (new-cst (node-source ptree) (node-decl ptree) (cdr x))
                 (let ((y (global-val var)))
                   (if (and y (cst? y))
                       (new-cst (node-source ptree)
                                (node-decl ptree)
                                (cst-val y))
                       (new-ref (node-source ptree)
                                (node-decl ptree)
                                var)))))))
        ((set? ptree)
         (let ((var (set-var ptree)) (val (pe (set-val ptree) consts)))
           (var-sets-set! var (set-remove (var-sets var) ptree))
           (new-set (node-source ptree) (node-decl ptree) var val)))
        ((tst? ptree)
         (let ((pre (pe (tst-pre ptree) consts)))
           (if (cst? pre)
               (let ((val (cst-val pre)))
                 (if (false-object? val)
                     (pe (tst-alt ptree) consts)
                     (pe (tst-con ptree) consts)))
               (new-tst (node-source ptree)
                        (node-decl ptree)
                        pre
                        (pe (tst-con ptree) consts)
                        (pe (tst-alt ptree) consts)))))
        ((conj? ptree)
         (let ((pre (pe (conj-pre ptree) consts)))
           (if (cst? pre)
               (let ((val (cst-val pre)))
                 (if (false-object? val) pre (pe (conj-alt ptree) consts)))
               (new-conj
                (node-source ptree)
                (node-decl ptree)
                pre
                (pe (conj-alt ptree) consts)))))
        ((disj? ptree)
         (let ((pre (pe (disj-pre ptree) consts)))
           (if (cst? pre)
               (let ((val (cst-val pre)))
                 (if (false-object? val) (pe (disj-alt ptree) consts) pre))
               (new-disj
                (node-source ptree)
                (node-decl ptree)
                pre
                (pe (disj-alt ptree) consts)))))
        ((prc? ptree)
         (new-prc (node-source ptree)
                  (node-decl ptree)
                  (prc-name ptree)
                  (prc-min ptree)
                  (prc-rest ptree)
                  (prc-parms ptree)
                  (pe (prc-body ptree) consts)))
        ((app? ptree)
         (let ((oper (app-oper ptree)) (args (app-args ptree)))
           (if (and (prc? oper)
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
               (pe-let ptree consts)
               (new-call
                (node-source ptree)
                (node-decl ptree)
                (pe oper consts)
                (map (lambda (x) (pe x consts)) args)))))
        ((fut? ptree)
         (new-fut (node-source ptree)
                  (node-decl ptree)
                  (pe (fut-val ptree) consts)))
        (else (compiler-internal-error "pe, unknown parse tree node type"))))
(define (pe-let ptree consts)
  (let* ((proc (app-oper ptree))
         (vals (app-args ptree))
         (vars (prc-parms proc))
         (non-mut-vars (set-keep not-mutable? (list->set vars))))
    (for-each
     (lambda (var)
       (var-refs-set! var (set-empty))
       (var-sets-set! var (set-empty)))
     vars)
    (let loop ((l vars)
               (v vals)
               (new-vars '())
               (new-vals '())
               (new-consts consts))
      (if (null? l)
          (if (null? new-vars)
              (pe (prc-body proc) new-consts)
              (new-call
               (node-source ptree)
               (node-decl ptree)
               (new-prc (node-source proc)
                        (node-decl proc)
                        #f
                        (length new-vars)
                        #f
                        (reverse new-vars)
                        (pe (prc-body proc) new-consts))
               (reverse new-vals)))
          (let ((var (car l)) (val (pe (car v) consts)))
            (if (and (set-member? var non-mut-vars) (cst? val))
                (loop (cdr l)
                      (cdr v)
                      new-vars
                      new-vals
                      (cons (cons var (cst-val val)) new-consts))
                (loop (cdr l)
                      (cdr v)
                      (cons var new-vars)
                      (cons val new-vals)
                      new-consts)))))))
(define (assignment-convert ptree env)
  (ac ptree (env-declare env (list safe-sym #f)) '()))
(define (ac ptree env mut)
  (cond ((cst? ptree) ptree)
        ((ref? ptree)
         (let ((var (ref-var ptree)))
           (if (global? var)
               ptree
               (let ((x (assq var mut)))
                 (if x
                     (let ((source (node-source ptree)))
                       (var-refs-set! var (set-remove (var-refs var) ptree))
                       (new-call
                        source
                        (node-decl ptree)
                        (new-ref-extended-bindings source **cell-ref-sym env)
                        (list (new-ref source (node-decl ptree) (cdr x)))))
                     ptree)))))
        ((set? ptree)
         (let ((var (set-var ptree))
               (source (node-source ptree))
               (val (ac (set-val ptree) env mut)))
           (var-sets-set! var (set-remove (var-sets var) ptree))
           (if (global? var)
               (new-set source (node-decl ptree) var val)
               (new-call
                source
                (node-decl ptree)
                (new-ref-extended-bindings source **cell-set!-sym env)
                (list (new-ref source (node-decl ptree) (cdr (assq var mut)))
                      val)))))
        ((tst? ptree)
         (new-tst (node-source ptree)
                  (node-decl ptree)
                  (ac (tst-pre ptree) env mut)
                  (ac (tst-con ptree) env mut)
                  (ac (tst-alt ptree) env mut)))
        ((conj? ptree)
         (new-conj
          (node-source ptree)
          (node-decl ptree)
          (ac (conj-pre ptree) env mut)
          (ac (conj-alt ptree) env mut)))
        ((disj? ptree)
         (new-disj
          (node-source ptree)
          (node-decl ptree)
          (ac (disj-pre ptree) env mut)
          (ac (disj-alt ptree) env mut)))
        ((prc? ptree) (ac-proc ptree env mut))
        ((app? ptree)
         (let ((oper (app-oper ptree)) (args (app-args ptree)))
           (if (and (prc? oper)
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
               (ac-let ptree env mut)
               (new-call
                (node-source ptree)
                (node-decl ptree)
                (ac oper env mut)
                (map (lambda (x) (ac x env mut)) args)))))
        ((fut? ptree)
         (new-fut (node-source ptree)
                  (node-decl ptree)
                  (ac (fut-val ptree) env mut)))
        (else (compiler-internal-error "ac, unknown parse tree node type"))))
(define (ac-proc ptree env mut)
  (let* ((mut-parms (ac-mutables (prc-parms ptree)))
         (mut-parms-copies (map var-copy mut-parms))
         (mut (append (pair-up mut-parms mut-parms-copies) mut))
         (new-body (ac (prc-body ptree) env mut)))
    (new-prc (node-source ptree)
             (node-decl ptree)
             (prc-name ptree)
             (prc-min ptree)
             (prc-rest ptree)
             (prc-parms ptree)
             (if (null? mut-parms)
                 new-body
                 (new-call
                  (node-source ptree)
                  (node-decl ptree)
                  (new-prc (node-source ptree)
                           (node-decl ptree)
                           #f
                           (length mut-parms-copies)
                           #f
                           mut-parms-copies
                           new-body)
                  (map (lambda (var)
                         (new-call
                          (var-source var)
                          (node-decl ptree)
                          (new-ref-extended-bindings
                           (var-source var)
                           **make-cell-sym
                           env)
                          (list (new-ref (var-source var)
                                         (node-decl ptree)
                                         var))))
                       mut-parms))))))
(define (ac-let ptree env mut)
  (let* ((proc (app-oper ptree))
         (vals (app-args ptree))
         (vars (prc-parms proc))
         (vals-fv (apply set-union (map free-variables vals)))
         (mut-parms (ac-mutables vars))
         (mut-parms-copies (map var-copy mut-parms))
         (mut (append (pair-up mut-parms mut-parms-copies) mut)))
    (let loop ((l vars)
               (v vals)
               (new-vars '())
               (new-vals '())
               (new-body (ac (prc-body proc) env mut)))
      (if (null? l)
          (new-let ptree proc new-vars new-vals new-body)
          (let ((var (car l)) (val (car v)))
            (if (memq var mut-parms)
                (let ((src (node-source val))
                      (decl (node-decl val))
                      (var* (cdr (assq var mut))))
                  (if (set-member? var vals-fv)
                      (loop (cdr l)
                            (cdr v)
                            (cons var* new-vars)
                            (cons (new-call
                                   src
                                   decl
                                   (new-ref-extended-bindings
                                    src
                                    **make-cell-sym
                                    env)
                                   (list (new-cst src decl undef-object)))
                                  new-vals)
                            (new-seq src
                                     decl
                                     (new-call
                                      src
                                      decl
                                      (new-ref-extended-bindings
                                       src
                                       **cell-set!-sym
                                       env)
                                      (list (new-ref src decl var*)
                                            (ac val env mut)))
                                     new-body))
                      (loop (cdr l)
                            (cdr v)
                            (cons var* new-vars)
                            (cons (new-call
                                   src
                                   decl
                                   (new-ref-extended-bindings
                                    src
                                    **make-cell-sym
                                    env)
                                   (list (ac val env mut)))
                                  new-vals)
                            new-body)))
                (loop (cdr l)
                      (cdr v)
                      (cons var new-vars)
                      (cons (ac val env mut) new-vals)
                      new-body)))))))
(define (ac-mutables l)
  (if (pair? l)
      (let ((var (car l)) (rest (ac-mutables (cdr l))))
        (if (mutable? var) (cons var rest) rest))
      '()))
(define (lambda-lift! ptree) (ll! ptree (set-empty) '()))
(define (ll! ptree cst-procs env)
  (define (new-env env vars)
    (define (loop i l)
      (if (pair? l)
          (let ((var (car l)))
            (cons (cons var (cons (length (set->list (var-refs var))) i))
                  (loop (+ i 1) (cdr l))))
          env))
    (loop (length env) vars))
  (cond ((or (cst? ptree)
             (ref? ptree)
             (set? ptree)
             (tst? ptree)
             (conj? ptree)
             (disj? ptree)
             (fut? ptree))
         (for-each
          (lambda (child) (ll! child cst-procs env))
          (node-children ptree)))
        ((prc? ptree)
         (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))
        ((app? ptree)
         (let ((oper (app-oper ptree)) (args (app-args ptree)))
           (if (and (prc? oper)
                    (not (prc-rest oper))
                    (= (length (prc-parms oper)) (length args)))
               (ll!-let ptree cst-procs (new-env env (prc-parms oper)))
               (for-each
                (lambda (child) (ll! child cst-procs env))
                (node-children ptree)))))
        (else (compiler-internal-error "ll!, unknown parse tree node type"))))
(define (ll!-let ptree cst-procs env)
  (let* ((proc (app-oper ptree))
         (vals (app-args ptree))
         (vars (prc-parms proc))
         (var-val-map (pair-up vars vals)))
    (define (var->val var) (cdr (assq var var-val-map)))
    (define (liftable-proc-vars vars)
      (let loop ((cst-proc-vars
                  (set-keep
                   (lambda (var)
                     (let ((val (var->val var)))
                       (and (prc? val)
                            (lambda-lift? (node-decl val))
                            (set-every? oper-pos? (var-refs var)))))
                   (list->set vars))))
        (let* ((non-cst-proc-vars
                (set-keep
                 (lambda (var)
                   (let ((val