;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "ptree1.scm"

;------------------------------------------------------------------------------
;
; Parse tree manipulation package: (part 1)
; -------------------------------

; This package contains procedures to construct the parse tree of a Scheme
; expression and manipulate the parse tree.

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Definition of the structures found in the parse tree.

; These structures define the nodes associated to expressions.

; information common to all nodes

;  parent   ; the node of which this node is a child
;  children ; list of parse-trees of the sub-expressions
;  fv       ; set of free/non-global vars contained in this expr
;  decl     ; declarations that apply to this node
;  source   ; source corresponding to this node

(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 ; node that represents constants
         parent children fv decl source ; common to all nodes

    val) ; value of the constant

  (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 ; node that represents variable references
         parent children fv decl source ; common to all nodes

    var) ; the variable which is referenced

  (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 ; node that represents assignments (i.e. set! special forms)
         parent children fv decl source ; common to all nodes

    var) ; the variable which is assigned a value

  (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 ; node that represents toplevel definitions
         parent children fv decl source ; common to all nodes

    var) ; the global variable which is assigned a value

  (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 ; node that represents conditionals (i.e. if special forms)
         parent children fv decl source ; common to all nodes

    )

  (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 ; node that represents conjunctions (i.e. and special forms)
         parent children fv decl source ; common to all nodes

    )

  (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 ; node that represents disjunctions (i.e. or special forms)
         parent children fv decl source ; common to all nodes

    )

  (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 ; node that represents procedures (i.e. lambda-expressions)
         parent children fv decl source ; common to all nodes

    name   ; name of this procedure (string)
    min    ; number of required parameters
    rest   ; #t if the last parameter is a rest parameter
    parms) ; the list of parameter variables in order

  (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 ; node that represents procedure calls
         parent children fv decl source ; common to all nodes

    )

  (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 ; node that represents future constructs
         parent children fv decl source ; common to all nodes

    )

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

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Procedures to create parse tree nodes and extract sub-nodes.

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

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Procedures to get variable classes from nodes.

(define (free-variables node) ; set of free variables used in the expression
  (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) ; set of variables bound by a procedure
  (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) ; get value of a global if it is known to be constant
  (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))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Canonical symbols for procedures needed by the front end:

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

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Declarations relevant to parsing:

; Dialect related declarations:
;
; (ieee-scheme)     use IEEE Scheme
; (r4rs-scheme)     use R4RS Scheme
; (multilisp)       use Multilisp
;
; Lambda-lifting declarations:
;
; (lambda-lift)     can lambda-lift procedures
; (not lambda-lift) can't lambda-lift procedures
;
; Compilation strategy declarations:
;
; (block)     global vars defined are only mutated by code in the current file
; (separate)  global vars defined can be mutated by other code
;
; Global variable binding declarations:
;
; (standard-bindings)                 compiler can assume standard bindings
; (standard-bindings <var1> ...)      assume st. bind. for vars specified
; (not standard-bindings)             can't assume st. bind. for any var
; (not standard-bindings <var1> ...)  can't assume st. bind. for vars spec.
;
; (extended-bindings)                 compiler can assume extended bindings
; (extended-bindings <var1> ...)      assume ext. bind. for vars specified
; (not extended-bindings)             can't assume ext. bind. for any var
; (not extended-bindings <var1> ...)  can't assume ext. bind. for vars spec.
;
; Code safety declarations:
;
; (safe)                              runtime errors won't crash system
; (not safe)                          assume program doesn't contain errors
;
; Interrupt checking declarations:
;
; (intr-checks)     generate interrupt checks
; (not intr-checks) don't generate interrupt checks
;
; Future implementation method declarations:
;
; (futures off)                       future = identity operation
; (futures delay)                     'delay' future method
; (futures eager)                     'eager' future method
; (futures lazy)                      'lazy' future method
; (futures eager-inline)              inlined 'eager' future method
;
; Touching analysis declarations:
;
; (autotouch)                         compiler does touching wherever needed
; (not autotouch)                     (touch ...) are explicit

(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 INTR-CHECKS-sym       (string->canonical-symbol "INTR-CHECKS"))

(define FUTURES-sym           (string->canonical-symbol "FUTURES"))
(define OFF-sym               (string->canonical-symbol "OFF"))
(define LAZY-sym              (string->canonical-symbol "LAZY"))
(define EAGER-sym             (string->canonical-symbol "EAGER"))
(define EAGER-INLINE-sym      (string->canonical-symbol "EAGER-INLINE"))

(define AUTOTOUCH-sym         (string->canonical-symbol "AUTOTOUCH"))

(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 INTR-CHECKS-sym)

(define-parameterized-decl FUTURES-sym)

(define-boolean-decl AUTOTOUCH-sym)

(define (scheme-dialect decl) ; returns dialect in effect
  (declaration-value 'dialect #f IEEE-SCHEME-sym decl))

(define (lambda-lift? decl) ; true iff should lambda-lift
  (declaration-value LAMBDA-LIFT-sym #f #t decl))

(define (compilation-strategy decl) ; returns compilation strategy in effect
  (declaration-value 'compilation-strategy #f SEPARATE-sym decl))

(define (standard-binding? name decl) ; true iff name's binding is standard
  (declaration-value STANDARD-BINDINGS-sym name #f decl))

(define (extended-binding? name decl) ; true iff name's binding is extended
  (declaration-value EXTENDED-BINDINGS-sym name #f decl))

(define (add-extended-bindings decl)
  (add-decl (list EXTENDED-BINDINGS-sym #t) decl))

(define (intr-checks? decl) ; true iff system should generate interrupt checks
  (declaration-value INTR-CHECKS-sym #f #t decl))

(define (futures-method decl) ; returns type of future implementation method
  (declaration-value FUTURES-sym #f LAZY-sym decl))

(define (add-delay decl)
  (add-decl (list FUTURES-sym DELAY-sym) decl))

(define (autotouch? decl) ; true iff autotouching (default depends on dialect)
  (declaration-value AUTOTOUCH-sym
                     #f
                     (eq? (scheme-dialect decl) MULTILISP-sym)
                     decl))

(define (safe? decl) ; true iff system should prevent fatal runtime errors
  (declaration-value SAFE-sym #f #f decl))

(define (add-not-safe decl)
  (add-decl (list SAFE-sym #f) decl))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Dialect info:

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

; IEEE Scheme

(define ieee-scheme-specific-keywords
  '())

(define ieee-scheme-specific-procedures (map make-standard-procedure '(

)))

; R4RS Scheme

(define r4rs-scheme-specific-keywords
  (list DELAY-sym))

(define r4rs-scheme-specific-procedures (map make-standard-procedure '(

; section 6.3

("LIST-TAIL" 2)

; section 6.5

("-" . 1) ("/" . 1)

; section 6.7

("STRING->LIST" 1) ("LIST->STRING" 1) ("STRING-COPY" 1) ("STRING-FILL!" 2)

; section 6.8

("VECTOR->LIST" 1) ("LIST->VECTOR" 1) ("VECTOR-FILL!" 2)

; section 6.9

("FORCE" 1)

; section 6.10

("WITH-INPUT-FROM-FILE" 2) ("WITH-OUTPUT-TO-FILE" 2) ("CHAR-READY?" 0 1)
("LOAD" 1) ("TRANSCRIPT-ON" 1) ("TRANSCRIPT-OFF" 0)

)))

; Multilisp

(define multilisp-specific-keywords
  (list DELAY-sym FUTURE-sym))

(define multilisp-specific-procedures (map make-standard-procedure '(

("FORCE" 1)
("TOUCH" 1)

)))

; common stuff

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

; taken from IEEE Scheme standard draft P1178/D4

; section 6.1

("NOT" 1) ("BOOLEAN?" 1)

; section 6.2

("EQV?" 2) ("EQ?" 2) ("EQUAL?" 2)

; section 6.3

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

; section 6.4

("SYMBOL?" 1) ("SYMBOL->STRING" 1) ("STRING->SYMBOL" 1)

; section 6.5

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

; section 6.6

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

; section 6.7

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

; section 6.8

("VECTOR?" 1) ("MAKE-VECTOR" 1 2) ("VECTOR" . 0) ("VECTOR-LENGTH" 1)
("VECTOR-REF" 2) ("VECTOR-SET!" 3)

; section 6.9

("PROCEDURE?" 1) ("APPLY" . 2) ("MAP" . 2) ("FOR-EACH" . 2)
("CALL-WITH-CURRENT-CONTINUATION" 1)

; section 6.10

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

)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; (parse-program program env proc) returns a list of parse trees/environment
; pairs describing the program and the final global environment.

(define (parse-program program env proc)

  (if *ptree-port*
    (begin
      (display "Parsing:" *ptree-port*)
      (newline *ptree-port*)))

  (parse-prog program env '()
    (lambda (lst env)

      (if *ptree-port*
        (newline *ptree-port*))

      (proc lst env))))

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

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

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; (pt source env use) returns the parse tree for the Scheme source expression
; 'source' in the environment 'env'.  If 'source' is not syntactically
; correct, an error is signaled.  The value of 'use' determines what the
; expression's value will be used for; it must be one of the following:
;
;  TRUE  : the true value of the expression is needed
;  PRED  : the value is used as a predicate
;  NONE  : the value is not needed (but its side effect might)

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

      ; get vars to be bound and vars to be assigned

      (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-fut source (add-delay (env-declarations env))
      (pt (cadr code) env 'TRUE))))

(define (pt-future source env use)
  (let ((decl (env-declarations env))
        (code (source-code source)))
    (if (eq? (futures-method decl) OFF-sym)
      (pt (cadr code) env 'TRUE)
      (new-fut source decl
        (pt (cadr code) env 'TRUE)))))

; Expression identification predicates and syntax checking.

(define (self-eval-expr? source)
  (let ((code (source-code source)))
    (and (not (pair? code)) (not (symbol-object? code)))))

(define (quote-expr? source)
  (match QUOTE-sym 1 source))

(define (quasiquote-expr? source)
  (match QUASIQUOTE-sym 1 source))

(define (unquote-expr? source)
  (match UNQUOTE-sym 1 source))

(define (unquote-splicing-expr? source)
  (match 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 (match SET!-sym 2 source)
       (var-expr? (cadr (source-code source)) env)))

(define (lambda-expr? source env)
  (and (match LAMBDA-sym -2 source)
       (proper-parms? (source->parms (cadr (source-code source))) env)))

(define (if-expr? source)
  (and (match 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 (match COND-sym -1 source)
       (proper-clauses? source)))

(define (and-expr? source)
  (match AND-sym 0 source))

(define (or-expr? source)
  (match OR-sym 0 source))

(define (case-expr? source)
  (and (match CASE-sym -2 source)
       (proper-case-clauses? source)))

(define (let-expr? source env)
  (and (match 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 (match LET*-sym -2 source)
       (proper-bindings? (cadr (source-code source)) #f env)))

(define (letrec-expr? source env)
  (and (match LETREC-sym -2 source)
       (proper-bindings? (cadr (source-code source)) #t env)))

(define (begin-expr? source)
  (match BEGIN-sym -1 source))

(define (do-expr? source env)
  (and (match DO-sym -2 source)
       (proper-do-bindings? source env)
       (proper-do-exit? source)))

(define (define-expr? source env)
  (and (match 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))
       (match DELAY-sym 1 source)))
       
(define (future-expr? source env)
  (and (eq? (scheme-dialect (env-declarations env)) MULTILISP-sym)
       (match 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 (match **DEFINE-MACRO-sym -1 source)
       (proper-definition? source env)))

(define (declare-expr? source)
  (match **DECLARE-sym -1 source))

(define (include-expr? source)
  (match **INCLUDE-sym 1 source))

(define (begin-defs-expr? source)
  (match BEGIN-sym 0 source))

(define (match 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) ; an unbound variable
                 ((length? body 1) #t) ; a bound variable
                 (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)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Variable dependency analysis for recursive definitions (e.g. 'letrec's).

(define (make-gnode label edges)
  (vector gnode-tag label edges))

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

(define (gnode-label x)        (vector-ref x 1))
(define (gnode-edges x)        (vector-ref x 2))
(define (gnode-label-set! x y) (vector-set! x 1 y))
(define (gnode-edges-set! x y) (vector-set! x 2 y))

(define gnode-tag (list 'gnode))

(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 (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) ; topological sort fixed to handle cycles
  (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)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Declaration handling:
; --------------------

; A declaration has the form: (##declare <item1> <item2> ...)
;
; an <item> can be one of 6 types:
;
; - flag declaration           : (<id>)
; - parameterized declaration  : (<id> <parameter>)
; - boolean declaration        : (<id>)  or  (NOT <id>)
; - namable declaration        : (<id> <name>...)
; - namable boolean declaration: (<id> <name>...)  or  (NOT <id> <name>...)
; - namable string declaration : (<id> <string> <name>...)

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

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Macro handling:
; --------------

(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) ; initialize package
  (set! *ptree-port* info-port)
  '())

(define (ptree.end!) ; finalize package
  '())

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; Stuff local to the package:

(define *ptree-port* '())

;==============================================================================