use defsubst

[bpt/guile.git] / gc-benchmarks / larceny / dynamic.sch

; This benchmark was obtained from Andrew Wright,
; based on Fritz Henglein's code.
; 970215 / wdc Removed most i/o and added dynamic-benchmark.
; 990707 / lth Added a quote and changed the call to run-benchmark.
; 010404 / wdc Changed the input file path name to "dynamic-input.sch".

;; Fritz's dynamic type inferencer, set up to run on itself
;; (see the end of this file).

;----------------------------------------------------------------------------
; Environment management
;----------------------------------------------------------------------------

;; environments are lists of pairs, the first component being the key

;; general environment operations
;;
;; empty-env: Env
;; gen-binding: Key x Value -> Binding
;; binding-key: Binding -> Key
;; binding-value: Binding -> Value
;; binding-show: Binding -> Symbol*
;; extend-env-with-binding: Env x Binding -> Env
;; extend-env-with-env: Env x Env -> Env
;; lookup: Key x Env -> (Binding + False)
;; env->list: Env -> Binding*
;; env-show: Env -> Symbol*


; bindings

(define gen-binding cons)
; generates a type binding, binding a symbol to a type variable

(define binding-key car)
; returns the key of a type binding

(define binding-value cdr)
; returns the tvariable of a type binding

(define (key-show key)
  ; default show procedure for keys
  key)

(define (value-show value)
  ; default show procedure for values
  value)

(define (binding-show binding)
  ; returns a printable representation of a type binding
  (cons (key-show (binding-key binding))
	(cons ': (value-show (binding-value binding)))))


; environments

(define dynamic-empty-env '())
; returns the empty environment

(define (extend-env-with-binding env binding)
  ; extends env with a binding, which hides any other binding in env
  ; for the same key (see dynamic-lookup)
  ; returns the extended environment
  (cons binding env))

(define (extend-env-with-env env ext-env)
  ; extends environment env with environment ext-env 
  ; a binding for a key in ext-env hides any binding in env for
  ; the same key (see dynamic-lookup)
  ; returns the extended environment
  (append ext-env env))

(define dynamic-lookup (lambda (x l) (assv x l)))
; returns the first pair in env that matches the key; returns #f
; if no such pair exists

(define (env->list e)
  ; converts an environment to a list of bindings
  e)

(define (env-show env)
  ; returns a printable list representation of a type environment
  (map binding-show env))
;----------------------------------------------------------------------------
;	Parsing for Scheme
;----------------------------------------------------------------------------


;; Needed packages: environment management

;(load "env-mgmt.ss")
;(load "pars-act.ss")

;; Lexical notions

(define syntactic-keywords
  ;; source: IEEE Scheme, 7.1, <expression keyword>, <syntactic keyword>
  '(lambda if set! begin cond and or case let let* letrec do
	  quasiquote else => define unquote unquote-splicing))


;; Parse routines

; Datum

; dynamic-parse-datum: parses nonterminal <datum>

(define (dynamic-parse-datum e)
  ;; Source: IEEE Scheme, sect. 7.2, <datum>
  ;; Note: "'" is parsed as 'quote, "`" as 'quasiquote, "," as
  ;; 'unquote, ",@" as 'unquote-splicing (see sect. 4.2.5, p. 18)
  ;; ***Note***: quasi-quotations are not permitted! (It would be
  ;; necessary to pass the environment to dynamic-parse-datum.)
  (cond
   ((null? e)
    (dynamic-parse-action-null-const))
   ((boolean? e)
    (dynamic-parse-action-boolean-const e))
   ((char? e)
    (dynamic-parse-action-char-const e))
   ((number? e)
    (dynamic-parse-action-number-const e))
   ((string? e)
    (dynamic-parse-action-string-const e))
   ((symbol? e)
    (dynamic-parse-action-symbol-const e))
   ((vector? e)
    (dynamic-parse-action-vector-const (map dynamic-parse-datum (vector->list e))))
   ((pair? e)
    (dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
			     (dynamic-parse-datum (cdr e))))
   (else (error 'dynamic-parse-datum "Unknown datum: ~s" e))))


; VarDef

; dynamic-parse-formal: parses nonterminal <variable> in defining occurrence position

(define (dynamic-parse-formal f-env e)
  ; e is an arbitrary object, f-env is a forbidden environment;
  ; returns: a variable definition (a binding for the symbol), plus
  ; the value of the binding as a result
  (if (symbol? e)
      (cond
       ((memq e syntactic-keywords)
	(error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
       ((dynamic-lookup e f-env)
	(error 'dynamic-parse-formal "Duplicate variable definition: ~s" e))
       (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e)))
	       (cons (gen-binding e dynamic-parse-action-result)
		     dynamic-parse-action-result))))
      (error 'dynamic-parse-formal "Not an identifier: ~s" e)))

; dynamic-parse-formal*

(define (dynamic-parse-formal* formals)
  ;; parses a list of formals and returns a pair consisting of generated
  ;; environment and list of parsing action results
  (letrec
      ((pf*
	(lambda (f-env results formals)
	  ;; f-env: "forbidden" environment (to avoid duplicate defs)
	  ;; results: the results of the parsing actions
	  ;; formals: the unprocessed formals
	  ;; Note: generates the results of formals in reverse order!
	  (cond
	   ((null? formals)
	    (cons f-env results))
	   ((pair? formals)
	    (let* ((fst-formal (car formals))
		   (binding-result (dynamic-parse-formal f-env fst-formal))
		   (binding (car binding-result))
		   (var-result (cdr binding-result)))
	      (pf*
	       (extend-env-with-binding f-env binding)
	       (cons var-result results)
	       (cdr formals))))
	   (else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals))))))
    (let ((renv-rres (pf* dynamic-empty-env '() formals)))
      (cons (car renv-rres) (reverse (cdr renv-rres))))))


; dynamic-parse-formals: parses <formals>

(define (dynamic-parse-formals formals)
  ;; parses <formals>; see IEEE Scheme, sect. 7.3
  ;; returns a pair: env and result
  (letrec ((pfs (lambda (f-env formals)
		  (cond
		   ((null? formals)
		    (cons dynamic-empty-env (dynamic-parse-action-null-formal)))
		   ((pair? formals)
		    (let* ((fst-formal (car formals))
			   (rem-formals (cdr formals))
			   (bind-res (dynamic-parse-formal f-env fst-formal))
			   (bind (car bind-res))
			   (res (cdr bind-res))
			   (nf-env (extend-env-with-binding f-env bind))
			   (renv-res* (pfs nf-env rem-formals))
			   (renv (car renv-res*))
			   (res* (cdr renv-res*)))
		      (cons
		       (extend-env-with-binding renv bind)
		       (dynamic-parse-action-pair-formal res res*))))
		   (else
		    (let* ((bind-res (dynamic-parse-formal f-env formals))
			   (bind (car bind-res))
			   (res (cdr bind-res)))
		      (cons
		       (extend-env-with-binding dynamic-empty-env bind)
		       res)))))))
    (pfs dynamic-empty-env formals)))


; Expr

; dynamic-parse-expression: parses nonterminal <expression>

(define (dynamic-parse-expression env e)
  (cond
   ((symbol? e)
    (dynamic-parse-variable env e))
   ((pair? e)
    (let ((op (car e)) (args (cdr e)))
      (case op
	((quote) (dynamic-parse-quote env args))
	((lambda) (dynamic-parse-lambda env args))
	((if) (dynamic-parse-if env args))
	((set!) (dynamic-parse-set env args))
	((begin) (dynamic-parse-begin env args))
	((cond) (dynamic-parse-cond env args))
	((case) (dynamic-parse-case env args))
	((and) (dynamic-parse-and env args))
	((or) (dynamic-parse-or env args))
	((let) (dynamic-parse-let env args))
	((let*) (dynamic-parse-let* env args))
	((letrec) (dynamic-parse-letrec env args))
	((do) (dynamic-parse-do env args))
	((quasiquote) (dynamic-parse-quasiquote env args))
        (else (dynamic-parse-procedure-call env op args)))))
   (else (dynamic-parse-datum e))))

; dynamic-parse-expression*

(define (dynamic-parse-expression* env exprs)
  ;; Parses lists of expressions (returns them in the right order!)
  (letrec ((pe*
	    (lambda (results es)
	      (cond
	       ((null? es) results)
	       ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es)))
	       (else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es))))))
    (reverse (pe* '() exprs))))


; dynamic-parse-expressions

(define (dynamic-parse-expressions env exprs)
  ;; parses lists of arguments of a procedure call
  (cond
   ((null? exprs) (dynamic-parse-action-null-arg))
   ((pair? exprs) (let* ((fst-expr (car exprs))
			 (rem-exprs (cdr exprs))
			 (fst-res (dynamic-parse-expression env fst-expr))
			 (rem-res (dynamic-parse-expressions env rem-exprs)))
		    (dynamic-parse-action-pair-arg fst-res rem-res)))
   (else (error 'dynamic-parse-expressions "Illegal expression list: ~s"
		exprs))))


; dynamic-parse-variable: parses variables (applied occurrences)

(define (dynamic-parse-variable env e)
  (if (symbol? e)
      (if (memq e syntactic-keywords)
	  (error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e)
	  (let ((assoc-var-def (dynamic-lookup e env)))
	    (if assoc-var-def
		(dynamic-parse-action-variable (binding-value assoc-var-def))
		(dynamic-parse-action-identifier e))))
      (error 'dynamic-parse-variable "Not an identifier: ~s" e)))


; dynamic-parse-procedure-call

(define (dynamic-parse-procedure-call env op args)
  (dynamic-parse-action-procedure-call
   (dynamic-parse-expression env op)
   (dynamic-parse-expressions env args)))


; dynamic-parse-quote

(define (dynamic-parse-quote env args)
  (if (list-of-1? args)
      (dynamic-parse-datum (car args))
      (error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args)))


; dynamic-parse-lambda

(define (dynamic-parse-lambda env args)
  (if (pair? args)
      (let* ((formals (car args))
	     (body (cdr args))
	     (nenv-fresults (dynamic-parse-formals formals))
	     (nenv (car nenv-fresults))
	     (fresults (cdr nenv-fresults)))
	(dynamic-parse-action-lambda-expression
	 fresults
	 (dynamic-parse-body (extend-env-with-env env nenv) body)))
      (error 'dynamic-parse-lambda "Illegal formals/body: ~s" args)))


; dynamic-parse-body

(define (dynamic-parse-body env body)
  ; <body> = <definition>* <expression>+
  (define (def-var* f-env body)
    ; finds the defined variables in a body and returns an 
    ; environment containing them
    (if (pair? body)
        (let ((n-env (def-var f-env (car body))))
          (if n-env
              (def-var* n-env (cdr body))
              f-env))
        f-env))
  (define (def-var f-env clause)
    ; finds the defined variables in a single clause and extends
    ; f-env accordingly; returns false if it's not a definition
    (if (pair? clause)
        (case (car clause)
          ((define) (if (pair? (cdr clause))
                        (let ((pattern (cadr clause)))
                          (cond
			   ((symbol? pattern)
			    (extend-env-with-binding 
			     f-env 
			     (gen-binding pattern
					  (dynamic-parse-action-var-def pattern))))
			   ((and (pair? pattern) (symbol? (car pattern)))
			    (extend-env-with-binding
			     f-env
			     (gen-binding (car pattern)
					  (dynamic-parse-action-var-def 
					   (car pattern)))))
			   (else f-env)))
                        f-env))
          ((begin) (def-var* f-env (cdr clause)))
          (else #f))
        #f))
  (if (pair? body)
      (dynamic-parse-command* (def-var* env body) body)
      (error 'dynamic-parse-body "Illegal body: ~s" body)))

; dynamic-parse-if

(define (dynamic-parse-if env args)
  (cond
   ((list-of-3? args)
    (dynamic-parse-action-conditional
     (dynamic-parse-expression env (car args))
     (dynamic-parse-expression env (cadr args))
     (dynamic-parse-expression env (caddr args))))
   ((list-of-2? args)
    (dynamic-parse-action-conditional
     (dynamic-parse-expression env (car args))
     (dynamic-parse-expression env (cadr args))
     (dynamic-parse-action-empty)))
   (else (error 'dynamic-parse-if "Not an if-expression: ~s" args))))


; dynamic-parse-set

(define (dynamic-parse-set env args)
  (if (list-of-2? args)
      (dynamic-parse-action-assignment
       (dynamic-parse-variable env (car args))
       (dynamic-parse-expression env (cadr args)))
      (error 'dynamic-parse-set "Not a variable/expression pair: ~s" args)))


; dynamic-parse-begin

(define (dynamic-parse-begin env args)
  (dynamic-parse-action-begin-expression
   (dynamic-parse-body env args)))


; dynamic-parse-cond

(define (dynamic-parse-cond env args)
  (if (and (pair? args) (list? args))
      (dynamic-parse-action-cond-expression
       (map (lambda (e)
	      (dynamic-parse-cond-clause env e))
	    args))
      (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args)))

; dynamic-parse-cond-clause

(define (dynamic-parse-cond-clause env e)
  ;; ***Note***: Only (<test> <sequence>) is permitted!
  (if (pair? e)
      (cons
       (if (eqv? (car e) 'else)
	   (dynamic-parse-action-empty)
	   (dynamic-parse-expression env (car e)))
       (dynamic-parse-body env (cdr e)))
      (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e)))


; dynamic-parse-and

(define (dynamic-parse-and env args)
  (if (list? args)
      (dynamic-parse-action-and-expression
       (dynamic-parse-expression* env args))
      (error 'dynamic-parse-and "Not a list of arguments: ~s" args)))


; dynamic-parse-or

(define (dynamic-parse-or env args)
  (if (list? args)
      (dynamic-parse-action-or-expression
       (dynamic-parse-expression* env args))
      (error 'dynamic-parse-or "Not a list of arguments: ~s" args)))


; dynamic-parse-case

(define (dynamic-parse-case env args)
  (if (and (list? args) (> (length args) 1))
      (dynamic-parse-action-case-expression
       (dynamic-parse-expression env (car args))
       (map (lambda (e)
	       (dynamic-parse-case-clause env e))
	     (cdr args)))
      (error 'dynamic-parse-case "Not a list of clauses: ~s" args)))

; dynamic-parse-case-clause

(define (dynamic-parse-case-clause env e)
  (if (pair? e)
      (cons
       (cond
	((eqv? (car e) 'else)
	 (list (dynamic-parse-action-empty)))
	((list? (car e))
	 (map dynamic-parse-datum (car e)))
	(else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
       (dynamic-parse-body env (cdr e)))
      (error 'dynamic-parse-case-clause "Not case clause: ~s" e)))


; dynamic-parse-let

(define (dynamic-parse-let env args)
  (if (pair? args)
      (if (symbol? (car args))
	  (dynamic-parse-named-let env args)
	  (dynamic-parse-normal-let env args))
      (error 'dynamic-parse-let "Illegal bindings/body: ~s" args)))


; dynamic-parse-normal-let

(define (dynamic-parse-normal-let env args)
  ;; parses "normal" let-expressions
  (let* ((bindings (car args))
	 (body (cdr args))
	 (env-ast (dynamic-parse-parallel-bindings env bindings))
	 (nenv (car env-ast))
	 (bresults (cdr env-ast)))
    (dynamic-parse-action-let-expression
     bresults
     (dynamic-parse-body (extend-env-with-env env nenv) body))))

; dynamic-parse-named-let

(define (dynamic-parse-named-let env args)
  ;; parses a named let-expression
  (if (pair? (cdr args))
      (let* ((variable (car args))
	     (bindings (cadr args))
	     (body (cddr args))
	     (vbind-vres (dynamic-parse-formal dynamic-empty-env variable))
	     (vbind (car vbind-vres))
	     (vres (cdr vbind-vres))
	     (env-ast (dynamic-parse-parallel-bindings env bindings))
	     (nenv (car env-ast))
	     (bresults (cdr env-ast)))
	(dynamic-parse-action-named-let-expression
	 vres bresults
	 (dynamic-parse-body (extend-env-with-env 
		      (extend-env-with-binding env vbind)
		      nenv) body)))
      (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))


; dynamic-parse-parallel-bindings

(define (dynamic-parse-parallel-bindings env bindings)
  ; returns a pair consisting of an environment
  ; and a list of pairs (variable . asg)
  ; ***Note***: the list of pairs is returned in reverse unzipped form!
  (if (list-of-list-of-2s? bindings)
      (let* ((env-formals-asg
	     (dynamic-parse-formal* (map car bindings)))
	    (nenv (car env-formals-asg))
	    (bresults (cdr env-formals-asg))
	    (exprs-asg
	     (dynamic-parse-expression* env (map cadr bindings))))
	(cons nenv (cons bresults exprs-asg)))
      (error 'dynamic-parse-parallel-bindings
	     "Not a list of bindings: ~s" bindings)))


; dynamic-parse-let*

(define (dynamic-parse-let* env args)
  (if (pair? args)
      (let* ((bindings (car args))
	     (body (cdr args))
	     (env-ast (dynamic-parse-sequential-bindings env bindings))
	     (nenv (car env-ast))
	     (bresults (cdr env-ast)))
	(dynamic-parse-action-let*-expression
	 bresults
	 (dynamic-parse-body (extend-env-with-env env nenv) body)))
      (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args)))

; dynamic-parse-sequential-bindings

(define (dynamic-parse-sequential-bindings env bindings)
  ; returns a pair consisting of an environment
  ; and a list of pairs (variable . asg)
  ;; ***Note***: the list of pairs is returned in reverse unzipped form!
  (letrec
      ((psb
	(lambda (f-env c-env var-defs expr-asgs binds)
	  ;; f-env: forbidden environment
	  ;; c-env: constructed environment
	  ;; var-defs: results of formals
	  ;; expr-asgs: results of corresponding expressions
	  ;; binds: reminding bindings to process
	  (cond
	   ((null? binds)
	    (cons f-env (cons var-defs expr-asgs)))
	   ((pair? binds)
	    (let ((fst-bind (car binds)))
	      (if (list-of-2? fst-bind)
		  (let* ((fbinding-bres
			  (dynamic-parse-formal f-env (car fst-bind)))
			 (fbind (car fbinding-bres))
			 (bres (cdr fbinding-bres))
			 (new-expr-asg
			  (dynamic-parse-expression c-env (cadr fst-bind))))
		    (psb
		     (extend-env-with-binding f-env fbind)
		     (extend-env-with-binding c-env fbind)
		     (cons bres var-defs)
		     (cons new-expr-asg expr-asgs)
		     (cdr binds)))
		  (error 'dynamic-parse-sequential-bindings
			 "Illegal binding: ~s" fst-bind))))
	   (else (error 'dynamic-parse-sequential-bindings
			"Illegal bindings: ~s" binds))))))
    (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
      (cons (car env-vdefs-easgs)
	    (cons (reverse (cadr env-vdefs-easgs))
		  (reverse (cddr env-vdefs-easgs)))))))


; dynamic-parse-letrec

(define (dynamic-parse-letrec env args)
  (if (pair? args)
      (let* ((bindings (car args))
	     (body (cdr args))
	     (env-ast (dynamic-parse-recursive-bindings env bindings))
	     (nenv (car env-ast))
	     (bresults (cdr env-ast)))
	(dynamic-parse-action-letrec-expression
	  bresults
	  (dynamic-parse-body (extend-env-with-env env nenv) body)))
      (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args)))

; dynamic-parse-recursive-bindings

(define (dynamic-parse-recursive-bindings env bindings)
  ;; ***Note***: the list of pairs is returned in reverse unzipped form!
  (if (list-of-list-of-2s? bindings)
      (let* ((env-formals-asg
	      (dynamic-parse-formal* (map car bindings)))
	     (formals-env
	      (car env-formals-asg))
	     (formals-res
	      (cdr env-formals-asg))
	     (exprs-asg
	      (dynamic-parse-expression*
	       (extend-env-with-env env formals-env)
	       (map cadr bindings))))
	(cons
	 formals-env
	 (cons formals-res exprs-asg)))
      (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))


; dynamic-parse-do

(define (dynamic-parse-do env args)
  ;; parses do-expressions
  ;; ***Note***: Not implemented!
  (error 'dynamic-parse-do "Nothing yet..."))

; dynamic-parse-quasiquote

(define (dynamic-parse-quasiquote env args)
  ;; ***Note***: Not implemented!
  (error 'dynamic-parse-quasiquote "Nothing yet..."))


;; Command

; dynamic-parse-command

(define (dynamic-parse-command env c)
  (if (pair? c)
      (let ((op (car c))
	    (args (cdr c)))
	(case op
	 ((define) (dynamic-parse-define env args))
;	 ((begin) (dynamic-parse-command* env args))  ;; AKW
	 ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args)))
	 (else (dynamic-parse-expression env c))))
      (dynamic-parse-expression env c)))


; dynamic-parse-command*

(define (dynamic-parse-command* env commands)
  ;; parses a sequence of commands
  (if (list? commands)
      (map (lambda (command) (dynamic-parse-command env command)) commands)
      (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands)))


; dynamic-parse-define

(define (dynamic-parse-define env args)
  ;; three cases -- see IEEE Scheme, sect. 5.2
  ;; ***Note***: the parser admits forms (define (x . y) ...)
  ;; ***Note***: Variables are treated as applied occurrences!
  (if (pair? args)
      (let ((pattern (car args))
	    (exp-or-body (cdr args)))
	(cond
	 ((symbol? pattern)
	  (if (list-of-1? exp-or-body)
	      (dynamic-parse-action-definition
	       (dynamic-parse-variable env pattern)
	       (dynamic-parse-expression env (car exp-or-body)))
	      (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body)))
	 ((pair? pattern)
	  (let* ((function-name (car pattern))
		 (function-arg-names (cdr pattern))
		 (env-ast (dynamic-parse-formals function-arg-names))
		 (formals-env (car env-ast))
		 (formals-ast (cdr env-ast)))
	    (dynamic-parse-action-function-definition
	     (dynamic-parse-variable env function-name)
	     formals-ast
	     (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
	 (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
      (error 'dynamic-parse-define "Not a valid definition: ~s" args)))

;; Auxiliary routines

; forall?

(define (forall? pred list)
  (if (null? list)
      #t
      (and (pred (car list)) (forall? pred (cdr list)))))

; list-of-1?

(define (list-of-1? l)
  (and (pair? l) (null? (cdr l))))

; list-of-2?

(define (list-of-2? l)
  (and (pair? l) (pair? (cdr l)) (null? (cddr l))))

; list-of-3?

(define (list-of-3? l)
  (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l))))

; list-of-list-of-2s?

(define (list-of-list-of-2s? e)
  (cond
   ((null? e)
    #t)
   ((pair? e)
    (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e))))
   (else #f)))


;; File processing

; dynamic-parse-from-port

(define (dynamic-parse-from-port port)
  (let ((next-input (read port)))
    (if (eof-object? next-input)
	'()
	(dynamic-parse-action-commands
	 (dynamic-parse-command dynamic-empty-env next-input)
	 (dynamic-parse-from-port port)))))

; dynamic-parse-file

(define (dynamic-parse-file file-name)
  (let ((input-port (open-input-file file-name)))
    (dynamic-parse-from-port input-port)))
;----------------------------------------------------------------------------
; Implementation of Union/find data structure in Scheme
;----------------------------------------------------------------------------

;; for union/find the following attributes are necessary: rank, parent 
;; (see Tarjan, "Data structures and network algorithms", 1983)
;; In the Scheme realization an element is represented as a single
;; cons cell; its address is the element itself; the car field contains 
;; the parent, the cdr field is an address for a cons
;; cell containing the rank (car field) and the information (cdr field)


;; general union/find data structure
;; 
;; gen-element: Info -> Elem
;; find: Elem -> Elem
;; link: Elem! x Elem! -> Elem
;; asymm-link: Elem! x Elem! -> Elem
;; info: Elem -> Info
;; set-info!: Elem! x Info -> Void


(define (gen-element info)
  ; generates a new element: the parent field is initialized to '(),
  ; the rank field to 0
  (cons '() (cons 0 info)))

(define info (lambda (l) (cddr l)))
  ; returns the information stored in an element

(define (set-info! elem info)
  ; sets the info-field of elem to info
  (set-cdr! (cdr elem) info))

; (define (find! x)
;   ; finds the class representative of x and sets the parent field 
;   ; directly to the class representative (a class representative has
;   ; '() as its parent) (uses path halving)
;   ;(display "Find!: ")
;   ;(display (pretty-print (info x)))
;   ;(newline)
;   (let ((px (car x)))
;     (if (null? px)
; 	x
; 	(let ((ppx (car px)))
; 	  (if (null? ppx)
; 	      px
; 	      (begin
; 		(set-car! x ppx)
; 		(find! ppx)))))))

(define (find! elem)
  ; finds the class representative of elem and sets the parent field 
  ; directly to the class representative (a class representative has
  ; '() as its parent)
  ;(display "Find!: ")
  ;(display (pretty-print (info elem)))
  ;(newline)
  (let ((p-elem (car elem)))
    (if (null? p-elem)
	elem
	(let ((rep-elem (find! p-elem)))
	  (set-car! elem rep-elem)
	  rep-elem))))

(define (link! elem-1 elem-2)
  ; links class elements by rank
  ; they must be distinct class representatives
  ; returns the class representative of the merged equivalence classes
  ;(display "Link!: ")
  ;(display (pretty-print (list (info elem-1) (info elem-2))))
  ;(newline)
  (let ((rank-1 (cadr elem-1))
	(rank-2 (cadr elem-2)))
    (cond
     ((= rank-1 rank-2)
      (set-car! (cdr elem-2) (+ rank-2 1))
      (set-car! elem-1 elem-2)
      elem-2)
     ((> rank-1 rank-2)
      (set-car! elem-2 elem-1)
      elem-1)
     (else
      (set-car! elem-1 elem-2)
      elem-2))))

(define asymm-link! (lambda (l x) (set-car! l x)))

;(define (asymm-link! elem-1 elem-2)
  ; links elem-1 onto elem-2 no matter what rank; 
  ; does not update the rank of elem-2 and does not return a value
  ; the two arguments must be distinct
  ;(display "AsymmLink: ")
  ;(display (pretty-print (list (info elem-1) (info elem-2))))
  ;(newline)
  ;(set-car! elem-1 elem-2))

;----------------------------------------------------------------------------
; Type management
;----------------------------------------------------------------------------

; introduces type variables and types for Scheme,


;; type TVar (type variables)
;;
;; gen-tvar:          () -> TVar
;; gen-type:          TCon x TVar* -> TVar
;; dynamic:           TVar
;; tvar-id:           TVar -> Symbol
;; tvar-def:          TVar -> Type + Null
;; tvar-show:         TVar -> Symbol*
;;
;; set-def!:          !TVar x TCon x TVar* -> Null
;; equiv!:            !TVar x !TVar -> Null
;;
;;
;; type TCon (type constructors)
;;
;; ...
;;
;; type Type (types)
;;
;; gen-type:          TCon x TVar* -> Type
;; type-con:          Type -> TCon
;; type-args:         Type -> TVar*
;;
;; boolean:           TVar
;; character:         TVar
;; null:              TVar
;; pair:              TVar x TVar -> TVar
;; procedure:         TVar x TVar* -> TVar
;; charseq:           TVar
;; symbol:            TVar
;; array:             TVar -> TVar


; Needed packages: union/find

;(load "union-fi.so")

; TVar

(define counter 0)
; counter for generating tvar id's

(define (gen-id)
  ; generates a new id (for printing purposes)
  (set! counter (+ counter 1))
  counter)

(define (gen-tvar)
  ; generates a new type variable from a new symbol
  ; uses union/find elements with two info fields
  ; a type variable has exactly four fields:
  ; car:     TVar (the parent field; initially null)
  ; cadr:    Number (the rank field; is always nonnegative)
  ; caddr:   Symbol (the type variable identifier; used only for printing)
  ; cdddr:   Type (the leq field; initially null)
  (gen-element (cons (gen-id) '())))

(define (gen-type tcon targs)
  ; generates a new type variable with an associated type definition
  (gen-element (cons (gen-id) (cons tcon targs))))

(define dynamic (gen-element (cons 0 '())))
; the special type variable dynamic
; Generic operations

(define (tvar-id tvar)
  ; returns the (printable) symbol representing the type variable
  (car (info tvar)))

(define (tvar-def tvar)
  ; returns the type definition (if any) of the type variable
  (cdr (info tvar)))

(define (set-def! tvar tcon targs)
  ; sets the type definition part of tvar to type
  (set-cdr! (info tvar) (cons tcon targs))
  '())

(define (reset-def! tvar)
  ; resets the type definition part of tvar to nil
  (set-cdr! (info tvar) '()))

(define type-con (lambda (l) (car l)))
; returns the type constructor of a type definition

(define type-args (lambda (l) (cdr l)))
; returns the type variables of a type definition

(define (tvar->string tvar)
  ; converts a tvar's id to a string
  (if (eqv? (tvar-id tvar) 0)
      "Dynamic"
      (string-append "t#" (number->string (tvar-id tvar) 10))))

(define (tvar-show tv)
  ; returns a printable list representation of type variable tv
  (let* ((tv-rep (find! tv))
	 (tv-def (tvar-def tv-rep)))
    (cons (tvar->string tv-rep)
	  (if (null? tv-def)
	      '()
	      (cons 'is (type-show tv-def))))))

(define (type-show type)
  ; returns a printable list representation of type definition type
  (cond
   ((eqv? (type-con type) ptype-con)
    (let ((new-tvar (gen-tvar)))
      (cons ptype-con
	    (cons (tvar-show new-tvar)
		  (tvar-show ((type-args type) new-tvar))))))
   (else
    (cons (type-con type)
	  (map (lambda (tv)
		 (tvar->string (find! tv)))
	       (type-args type))))))



; Special type operations

; type constructor literals

(define boolean-con 'boolean)
(define char-con 'char)
(define null-con 'null)
(define number-con 'number)
(define pair-con 'pair)
(define procedure-con 'procedure)
(define string-con 'string)
(define symbol-con 'symbol)
(define vector-con 'vector)

; type constants and type constructors

(define (null)
  ; ***Note***: Temporarily changed to be a pair!
  ; (gen-type null-con '())
  (pair (gen-tvar) (gen-tvar)))
(define (boolean)
  (gen-type boolean-con '()))
(define (character)
  (gen-type char-con '()))
(define (number)
  (gen-type number-con '()))
(define (charseq)
  (gen-type string-con '()))
(define (symbol)
  (gen-type symbol-con '()))
(define (pair tvar-1 tvar-2)
  (gen-type pair-con (list tvar-1 tvar-2)))
(define (array tvar)
  (gen-type vector-con (list tvar)))
(define (procedure arg-tvar res-tvar)
  (gen-type procedure-con (list arg-tvar res-tvar)))


; equivalencing of type variables

(define (equiv! tv1 tv2)
  (let* ((tv1-rep (find! tv1))
	 (tv2-rep (find! tv2))
	 (tv1-def (tvar-def tv1-rep))
	 (tv2-def (tvar-def tv2-rep)))
    (cond
     ((eqv? tv1-rep tv2-rep)
      '())
     ((eqv? tv2-rep dynamic)
      (equiv-with-dynamic! tv1-rep))
     ((eqv? tv1-rep dynamic)
      (equiv-with-dynamic! tv2-rep))
     ((null? tv1-def)
      (if (null? tv2-def)
	  ; both tv1 and tv2 are distinct type variables
	  (link! tv1-rep tv2-rep)
	  ; tv1 is a type variable, tv2 is a (nondynamic) type
	  (asymm-link! tv1-rep tv2-rep)))
     ((null? tv2-def)
      ; tv1 is a (nondynamic) type, tv2 is a type variable
      (asymm-link! tv2-rep tv1-rep))
     ((eqv? (type-con tv1-def) (type-con tv2-def))
      ; both tv1 and tv2 are (nondynamic) types with equal numbers of
      ; arguments
      (link! tv1-rep tv2-rep)
      (map equiv! (type-args tv1-def) (type-args tv2-def)))
     (else
      ; tv1 and tv2 are types with distinct type constructors or different
      ; numbers of arguments
      (equiv-with-dynamic! tv1-rep)
      (equiv-with-dynamic! tv2-rep))))
  '())

(define (equiv-with-dynamic! tv)
  (let ((tv-rep (find! tv)))
    (if (not (eqv? tv-rep dynamic))
	(let ((tv-def (tvar-def tv-rep)))
	  (asymm-link! tv-rep dynamic)
	  (if (not (null? tv-def))
	      (map equiv-with-dynamic! (type-args tv-def))))))
  '())
;----------------------------------------------------------------------------
; Polymorphic type management
;----------------------------------------------------------------------------

; introduces parametric polymorphic types


;; forall: (Tvar -> Tvar) -> TVar
;; fix: (Tvar -> Tvar) -> Tvar
;;  
;; instantiate-type: TVar -> TVar

; type constructor literal for polymorphic types

(define ptype-con 'forall)

(define (forall tv-func)
  (gen-type ptype-con tv-func))

(define (forall2 tv-func2)
  (forall (lambda (tv1)
	    (forall (lambda (tv2)
		      (tv-func2 tv1 tv2))))))

(define (forall3 tv-func3)
  (forall (lambda (tv1)
	    (forall2 (lambda (tv2 tv3)
		       (tv-func3 tv1 tv2 tv3))))))

(define (forall4 tv-func4)
  (forall (lambda (tv1)
	    (forall3 (lambda (tv2 tv3 tv4)
		       (tv-func4 tv1 tv2 tv3 tv4))))))

(define (forall5 tv-func5)
  (forall (lambda (tv1)
	    (forall4 (lambda (tv2 tv3 tv4 tv5)
		       (tv-func5 tv1 tv2 tv3 tv4 tv5))))))


; (polymorphic) instantiation

(define (instantiate-type tv)
  ; instantiates type tv and returns a generic instance
  (let* ((tv-rep (find! tv))
	 (tv-def (tvar-def tv-rep)))
    (cond 
     ((null? tv-def)
      tv-rep)
     ((eqv? (type-con tv-def) ptype-con)
      (instantiate-type ((type-args tv-def) (gen-tvar))))
     (else
      tv-rep))))

(define (fix tv-func)
  ; forms a recursive type: the fixed point of type mapping tv-func
  (let* ((new-tvar (gen-tvar))
	 (inst-tvar (tv-func new-tvar))
	 (inst-def (tvar-def inst-tvar)))
    (if (null? inst-def)
	(error 'fix "Illegal recursive type: ~s"
	       (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
	(begin
	  (set-def! new-tvar 
		    (type-con inst-def)
		    (type-args inst-def))
	  new-tvar))))

  
;----------------------------------------------------------------------------
;	Constraint management 
;----------------------------------------------------------------------------


; constraints

(define gen-constr (lambda (a b) (cons a b)))
; generates an equality between tvar1 and tvar2

(define constr-lhs (lambda (c) (car c)))
; returns the left-hand side of a constraint

(define constr-rhs (lambda (c) (cdr c)))
; returns the right-hand side of a constraint

(define (constr-show c)
  (cons (tvar-show (car c)) 
	(cons '= 
	      (cons (tvar-show (cdr c)) '()))))


; constraint set management

(define global-constraints '())

(define (init-global-constraints!)
  (set! global-constraints '()))

(define (add-constr! lhs rhs)
  (set! global-constraints
	(cons (gen-constr lhs rhs) global-constraints))
  '())

(define (glob-constr-show) 
  ; returns printable version of global constraints
  (map constr-show global-constraints))


; constraint normalization

; Needed packages: type management

;(load "typ-mgmt.so")

(define (normalize-global-constraints!) 
  (normalize! global-constraints)
  (init-global-constraints!))

(define (normalize! constraints)
  (map (lambda (c)
	 (equiv! (constr-lhs c) (constr-rhs c))) constraints))
; ----------------------------------------------------------------------------
; Abstract syntax definition and parse actions
; ----------------------------------------------------------------------------

; Needed packages: ast-gen.ss
;(load "ast-gen.ss")

;; Abstract syntax
;;
;; VarDef
;;
;; Identifier =		Symbol - SyntacticKeywords
;; SyntacticKeywords =	{ ... } (see Section 7.1, IEEE Scheme Standard)
;;
;; Datum
;;
;; null-const:		Null		-> Datum
;; boolean-const:	Bool		-> Datum
;; char-const:		Char		-> Datum
;; number-const:	Number		-> Datum
;; string-const:	String		-> Datum
;; vector-const:	Datum*		-> Datum
;; pair-const:		Datum x Datum	-> Datum
;;
;; Expr
;;
;; Datum < 		Expr
;;
;; var-def:             Identifier              -> VarDef
;; variable:		VarDef			-> Expr
;; identifier:		Identifier		-> Expr
;; procedure-call:	Expr x Expr*		-> Expr
;; lambda-expression:	Formals x Body		-> Expr
;; conditional:		Expr x Expr x Expr 	-> Expr
;; assignment:		Variable x Expr		-> Expr
;; cond-expression:	CondClause+	        -> Expr
;; case-expression:	Expr x CaseClause* 	-> Expr
;; and-expression:	Expr* 			-> Expr
;; or-expression:	Expr* 			-> Expr
;; let-expression:	(VarDef* x Expr*) x Body -> Expr
;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr
;; let*-expression:	(VarDef* x Expr*) x Body -> Expr
;; letrec-expression:	(VarDef* x Expr*) x Body -> Expr
;; begin-expression:	Expr+ 			-> Expr
;; do-expression:	IterDef* x CondClause x Expr* -> Expr
;; empty:					-> Expr
;;
;; VarDef* <		Formals
;;
;; simple-formal:	VarDef			-> Formals
;; dotted-formals:	VarDef* x VarDef	-> Formals
;;
;; Body =		Definition* x Expr+	(reversed)
;; CondClause =		Expr x Expr+
;; CaseClause =		Datum* x Expr+
;; IterDef =		VarDef x Expr x Expr
;;
;; Definition
;;
;; definition:		Identifier x Expr	-> Definition
;; function-definition: Identifier x Formals x Body -> Definition
;; begin-command:	Definition*		-> Definition
;;
;; Expr <		Command
;; Definition <		Command
;;
;; Program =		Command*


;; Abstract syntax operators

; Datum

(define null-const 0)
(define boolean-const 1)
(define char-const 2)
(define number-const 3)
(define string-const 4)
(define symbol-const 5)
(define vector-const 6)
(define pair-const 7)

; Bindings

(define var-def 8)
(define null-def 29)
(define pair-def 30)

; Expr

(define variable 9)
(define identifier 10)
(define procedure-call 11)
(define lambda-expression 12)
(define conditional 13)
(define assignment 14)
(define cond-expression 15)
(define case-expression 16)
(define and-expression 17)
(define or-expression 18)
(define let-expression 19)
(define named-let-expression 20)
(define let*-expression 21)
(define letrec-expression 22)
(define begin-expression 23)
(define do-expression 24)
(define empty 25)
(define null-arg 31)
(define pair-arg 32)

; Command

(define definition 26)
(define function-definition 27)
(define begin-command 28)


;; Parse actions for abstract syntax construction

(define (dynamic-parse-action-null-const)
  ;; dynamic-parse-action for '()
  (ast-gen null-const '()))

(define (dynamic-parse-action-boolean-const e)
  ;; dynamic-parse-action for #f and #t
  (ast-gen boolean-const e))

(define (dynamic-parse-action-char-const e)
  ;; dynamic-parse-action for character constants
  (ast-gen char-const e))

(define (dynamic-parse-action-number-const e)
  ;; dynamic-parse-action for number constants
  (ast-gen number-const e))

(define (dynamic-parse-action-string-const e)
  ;; dynamic-parse-action for string literals
  (ast-gen string-const e))

(define (dynamic-parse-action-symbol-const e)
  ;; dynamic-parse-action for symbol constants
  (ast-gen symbol-const e))

(define (dynamic-parse-action-vector-const e)
  ;; dynamic-parse-action for vector literals
  (ast-gen vector-const e))

(define (dynamic-parse-action-pair-const e1 e2)
  ;; dynamic-parse-action for pairs
  (ast-gen pair-const (cons e1 e2)))

(define (dynamic-parse-action-var-def e)
  ;; dynamic-parse-action for defining occurrences of variables;
  ;; e is a symbol
  (ast-gen var-def e))

(define (dynamic-parse-action-null-formal)
  ;; dynamic-parse-action for null-list of formals
  (ast-gen null-def '()))

(define (dynamic-parse-action-pair-formal d1 d2)
  ;; dynamic-parse-action for non-null list of formals;
  ;; d1 is the result of parsing the first formal,
  ;; d2 the result of parsing the remaining formals
  (ast-gen pair-def (cons d1 d2)))

(define (dynamic-parse-action-variable e)
  ;; dynamic-parse-action for applied occurrences of variables
  ;; ***Note***: e is the result of a dynamic-parse-action on the
  ;; corresponding variable definition!
  (ast-gen variable e))

(define (dynamic-parse-action-identifier e)
  ;; dynamic-parse-action for undeclared identifiers (free variable
  ;; occurrences)
  ;; ***Note***: e is a symbol (legal identifier)
  (ast-gen identifier e))
 
(define (dynamic-parse-action-null-arg)
  ;; dynamic-parse-action for a null list of arguments in a procedure call
  (ast-gen null-arg '()))

(define (dynamic-parse-action-pair-arg a1 a2)
  ;; dynamic-parse-action for a non-null list of arguments in a procedure call
  ;; a1 is the result of parsing the first argument, 
  ;; a2 the result of parsing the remaining arguments
  (ast-gen pair-arg (cons a1 a2)))

(define (dynamic-parse-action-procedure-call op args)
  ;; dynamic-parse-action for procedure calls: op function, args list of arguments
  (ast-gen procedure-call (cons op args)))

(define (dynamic-parse-action-lambda-expression formals body)
  ;; dynamic-parse-action for lambda-abstractions
  (ast-gen lambda-expression (cons formals body)))

(define (dynamic-parse-action-conditional test then-branch else-branch)
  ;; dynamic-parse-action for conditionals (if-then-else expressions)
  (ast-gen conditional (cons test (cons then-branch else-branch))))

(define (dynamic-parse-action-empty)
  ;; dynamic-parse-action for missing or empty field
  (ast-gen empty '()))

(define (dynamic-parse-action-assignment lhs rhs)
  ;; dynamic-parse-action for assignment
  (ast-gen assignment (cons lhs rhs)))

(define (dynamic-parse-action-begin-expression body)
  ;; dynamic-parse-action for begin-expression
  (ast-gen begin-expression body))

(define (dynamic-parse-action-cond-expression clauses)
  ;; dynamic-parse-action for cond-expressions
  (ast-gen cond-expression clauses))

(define (dynamic-parse-action-and-expression args)
  ;; dynamic-parse-action for and-expressions
  (ast-gen and-expression args))

(define (dynamic-parse-action-or-expression args)
  ;; dynamic-parse-action for or-expressions
  (ast-gen or-expression args))

(define (dynamic-parse-action-case-expression key clauses)
  ;; dynamic-parse-action for case-expressions
  (ast-gen case-expression (cons key clauses)))

(define (dynamic-parse-action-let-expression bindings body)
  ;; dynamic-parse-action for let-expressions
  (ast-gen let-expression (cons bindings body)))

(define (dynamic-parse-action-named-let-expression variable bindings body)
  ;; dynamic-parse-action for named-let expressions
  (ast-gen named-let-expression (cons variable (cons bindings body))))

(define (dynamic-parse-action-let*-expression bindings body)
  ;; dynamic-parse-action for let-expressions
  (ast-gen let*-expression (cons bindings body)))

(define (dynamic-parse-action-letrec-expression bindings body)
  ;; dynamic-parse-action for let-expressions
  (ast-gen letrec-expression (cons bindings body)))

(define (dynamic-parse-action-definition variable expr)
  ;; dynamic-parse-action for simple definitions
  (ast-gen definition (cons variable expr)))

(define (dynamic-parse-action-function-definition variable formals body)
  ;; dynamic-parse-action for function definitions
  (ast-gen function-definition (cons variable (cons formals body))))


(define dynamic-parse-action-commands (lambda (a b) (cons a b)))
;; dynamic-parse-action for processing a command result followed by a the
;; result of processing the remaining commands


;; Pretty-printing abstract syntax trees

(define (ast-show ast)
  ;; converts abstract syntax tree to list representation (Scheme program)
  ;; ***Note***: check translation of constructors to numbers at the top of the file
  (let ((syntax-op (ast-con ast))
	(syntax-arg (ast-arg ast)))
    (case syntax-op
      ((0 1 2 3 4 8 10) syntax-arg)
      ((29 31) '())
      ((30 32) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
      ((5) (list 'quote syntax-arg))
      ((6) (list->vector (map ast-show syntax-arg)))
      ((7) (list 'cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
      ((9) (ast-arg syntax-arg))
      ((11) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
      ((12) (cons 'lambda (cons (ast-show (car syntax-arg)) 
				(map ast-show (cdr syntax-arg)))))
      ((13) (cons 'if (cons (ast-show (car syntax-arg))
			    (cons (ast-show (cadr syntax-arg))
				  (let ((alt (cddr syntax-arg)))
				    (if (eqv? (ast-con alt) empty)
					'()
					(list (ast-show alt))))))))
      ((14) (list 'set! (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
      ((15) (cons 'cond
		  (map (lambda (cc)
			 (let ((guard (car cc))
			       (body (cdr cc)))
			   (cons
			    (if (eqv? (ast-con guard) empty)
				'else
				(ast-show guard))
			    (map ast-show body))))
		       syntax-arg)))
      ((16) (cons 'case
		  (cons (ast-show (car syntax-arg))
			(map (lambda (cc)
			       (let ((data (car cc)))
				 (if (and (pair? data)
					  (eqv? (ast-con (car data)) empty))
				     (cons 'else
					   (map ast-show (cdr cc)))
				     (cons (map datum-show data)
					   (map ast-show (cdr cc))))))
			     (cdr syntax-arg)))))
      ((17) (cons 'and (map ast-show syntax-arg)))
      ((18) (cons 'or (map ast-show syntax-arg)))
      ((19) (cons 'let
		  (cons (map
			 (lambda (vd e)
			   (list (ast-show vd) (ast-show e)))
			 (caar syntax-arg)
			 (cdar syntax-arg))
			(map ast-show (cdr syntax-arg)))))
      ((20) (cons 'let
		  (cons (ast-show (car syntax-arg))
			(cons (map
			       (lambda (vd e)
				 (list (ast-show vd) (ast-show e)))
			       (caadr syntax-arg)
			       (cdadr syntax-arg))
			      (map ast-show (cddr syntax-arg))))))
      ((21) (cons 'let*
		  (cons (map
			 (lambda (vd e)
			   (list (ast-show vd) (ast-show e)))
			 (caar syntax-arg)
			 (cdar syntax-arg))
			(map ast-show (cdr syntax-arg)))))
      ((22) (cons 'letrec
		  (cons (map
			 (lambda (vd e)
			   (list (ast-show vd) (ast-show e)))
			 (caar syntax-arg)
			 (cdar syntax-arg))
			(map ast-show (cdr syntax-arg)))))
      ((23) (cons 'begin
		  (map ast-show syntax-arg)))
      ((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
      ((25) (error 'ast-show "This can't happen: empty encountered!"))
      ((26) (list 'define
		  (ast-show (car syntax-arg))
		  (ast-show (cdr syntax-arg))))
      ((27) (cons 'define
		  (cons
		   (cons (ast-show (car syntax-arg))
			 (ast-show (cadr syntax-arg)))
		   (map ast-show (cddr syntax-arg)))))
      ((28) (cons 'begin
		  (map ast-show syntax-arg)))
      (else (error 'ast-show "Unknown abstract syntax operator: ~s"
		   syntax-op)))))


;; ast*-show

(define (ast*-show p)
  ;; shows a list of abstract syntax trees
  (map ast-show p))


;; datum-show

(define (datum-show ast)
  ;; prints an abstract syntax tree as a datum
  (case (ast-con ast)
    ((0 1 2 3 4 5) (ast-arg ast))
    ((6) (list->vector (map datum-show (ast-arg ast))))
    ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
    (else (error 'datum-show "This should not happen!"))))

; write-to-port

(define (write-to-port prog port)
  ; writes a program to a port
  (for-each
   (lambda (command)
     (pretty-print command port)
     (newline port))
   prog)
  '())

; write-file 

(define (write-to-file prog filename)
  ; write a program to a file
  (let ((port (open-output-file filename)))
    (write-to-port prog port)
    (close-output-port port)
    '()))

; ----------------------------------------------------------------------------
; Typed abstract syntax tree management: constraint generation, display, etc.
; ----------------------------------------------------------------------------


;; Abstract syntax operations, incl. constraint generation

(define (ast-gen syntax-op arg)
  ; generates all attributes and performs semantic side effects
  (let ((ntvar
	 (case syntax-op
	   ((0 29 31) (null))
	   ((1) (boolean))
	   ((2) (character))
	   ((3) (number))
	   ((4) (charseq))
	   ((5) (symbol))
	   ((6) (let ((aux-tvar (gen-tvar)))
		  (for-each (lambda (t)
			      (add-constr! t aux-tvar))
			    (map ast-tvar arg))
		  (array aux-tvar)))
	   ((7 30 32) (let ((t1 (ast-tvar (car arg)))
			    (t2 (ast-tvar (cdr arg))))
			(pair t1 t2)))
	   ((8) (gen-tvar))
	   ((9) (ast-tvar arg))
	   ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env)))
		   (if in-env
		       (instantiate-type (binding-value in-env))
		       (let ((new-tvar (gen-tvar)))
			 (set! dynamic-top-level-env (extend-env-with-binding
					      dynamic-top-level-env
					      (gen-binding arg new-tvar)))
			 new-tvar))))
	   ((11) (let ((new-tvar (gen-tvar)))
		   (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar)
				(ast-tvar (car arg)))
		   new-tvar))
	   ((12) (procedure (ast-tvar (car arg))
			    (ast-tvar (tail (cdr arg)))))
	   ((13) (let ((t-test (ast-tvar (car arg)))
		       (t-consequent (ast-tvar (cadr arg)))
		       (t-alternate (ast-tvar (cddr arg))))
		   (add-constr! (boolean) t-test)
		   (add-constr! t-consequent t-alternate)
		   t-consequent))
	   ((14) (let ((var-tvar (ast-tvar (car arg)))
		       (exp-tvar (ast-tvar (cdr arg))))
		   (add-constr! var-tvar exp-tvar)
		   var-tvar))
	   ((15) (let ((new-tvar (gen-tvar)))
		   (for-each (lambda (body)
			       (add-constr! (ast-tvar (tail body)) new-tvar))
			     (map cdr arg))
		   (for-each (lambda (e)
			       (add-constr! (boolean) (ast-tvar e)))
			     (map car arg))
		   new-tvar))
	   ((16) (let* ((new-tvar (gen-tvar))
			(t-key (ast-tvar (car arg)))
			(case-clauses (cdr arg)))
		   (for-each (lambda (exprs)
			       (for-each (lambda (e)
					   (add-constr! (ast-tvar e) t-key))
					 exprs))
			     (map car case-clauses))
		   (for-each (lambda (body)
			       (add-constr! (ast-tvar (tail body)) new-tvar))
			     (map cdr case-clauses))
		   new-tvar))
	   ((17 18) (for-each (lambda (e)
				(add-constr! (boolean) (ast-tvar e)))
			      arg)
		    (boolean))
	   ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg)))
			     (def-expr-types (map ast-tvar (cdar arg)))
			     (body-type (ast-tvar (tail (cdr arg)))))
			 (for-each add-constr! var-def-tvars def-expr-types)
			 body-type))
	   ((20) (let ((var-def-tvars (map ast-tvar (caadr arg)))
		       (def-expr-types (map ast-tvar (cdadr arg)))
		       (body-type (ast-tvar (tail (cddr arg))))
		       (named-var-type (ast-tvar (car arg))))
		   (for-each add-constr! var-def-tvars def-expr-types)
		   (add-constr! (procedure (convert-tvars var-def-tvars) body-type)
				named-var-type)
		   body-type))
	   ((23) (ast-tvar (tail arg)))
	   ((24) (error 'ast-gen
			"Do-expressions not handled! (Argument: ~s) arg"))
	   ((25) (gen-tvar))
	   ((26) (let ((t-var (ast-tvar (car arg)))
		       (t-exp (ast-tvar (cdr arg))))
		   (add-constr! t-var t-exp)
		   t-var))
	   ((27) (let ((t-var (ast-tvar (car arg)))
		       (t-formals (ast-tvar (cadr arg)))
		       (t-body (ast-tvar (tail (cddr arg)))))
		   (add-constr! (procedure t-formals t-body) t-var)
		   t-var))
	   ((28) (gen-tvar))
	   (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op)))))
    (cons syntax-op (cons ntvar arg))))

(define ast-con car)
;; extracts the ast-constructor from an abstract syntax tree

(define ast-arg cddr)
;; extracts the ast-argument from an abstract syntax tree

(define ast-tvar cadr)
;; extracts the tvar from an abstract syntax tree


;; tail

(define (tail l)
  ;; returns the tail of a nonempty list
  (if (null? (cdr l))
      (car l)
      (tail (cdr l))))

; convert-tvars

(define (convert-tvars tvar-list)
  ;; converts a list of tvars to a single tvar
  (cond
   ((null? tvar-list) (null))
   ((pair? tvar-list) (pair (car tvar-list)
			    (convert-tvars (cdr tvar-list))))
   (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list))))


;; Pretty-printing abstract syntax trees

(define (tast-show ast)
  ;; converts abstract syntax tree to list representation (Scheme program)
  (let ((syntax-op (ast-con ast))
        (syntax-tvar (tvar-show (ast-tvar ast)))
	(syntax-arg (ast-arg ast)))
    (cons
     (case syntax-op
       ((0 1 2 3 4 8 10) syntax-arg)
       ((29 31) '())
       ((30 32) (cons (tast-show (car syntax-arg))
		      (tast-show (cdr syntax-arg))))
       ((5) (list 'quote syntax-arg))
       ((6) (list->vector (map tast-show syntax-arg)))
       ((7) (list 'cons (tast-show (car syntax-arg))
		  (tast-show (cdr syntax-arg))))
       ((9) (ast-arg syntax-arg))
       ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg))))
       ((12) (cons 'lambda (cons (tast-show (car syntax-arg))
				 (map tast-show (cdr syntax-arg)))))
       ((13) (cons 'if (cons (tast-show (car syntax-arg))
			     (cons (tast-show (cadr syntax-arg))
				   (let ((alt (cddr syntax-arg)))
				     (if (eqv? (ast-con alt) empty)
					 '()
					 (list (tast-show alt))))))))
       ((14) (list 'set! (tast-show (car syntax-arg))
		   (tast-show (cdr syntax-arg))))
       ((15) (cons 'cond
		   (map (lambda (cc)
			  (let ((guard (car cc))
				(body (cdr cc)))
			    (cons
			     (if (eqv? (ast-con guard) empty)
				 'else
				 (tast-show guard))
			     (map tast-show body))))
			syntax-arg)))
       ((16) (cons 'case
		   (cons (tast-show (car syntax-arg))
			 (map (lambda (cc)
				(let ((data (car cc)))
				  (if (and (pair? data)
					   (eqv? (ast-con (car data)) empty))
				      (cons 'else
					    (map tast-show (cdr cc)))
				      (cons (map datum-show data)
					    (map tast-show (cdr cc))))))
			      (cdr syntax-arg)))))
       ((17) (cons 'and (map tast-show syntax-arg)))
       ((18) (cons 'or (map tast-show syntax-arg)))
       ((19) (cons 'let
		   (cons (map
			  (lambda (vd e)
			    (list (tast-show vd) (tast-show e)))
			  (caar syntax-arg)
			  (cdar syntax-arg))
			 (map tast-show (cdr syntax-arg)))))
       ((20) (cons 'let
		   (cons (tast-show (car syntax-arg))
			 (cons (map
				(lambda (vd e)
				  (list (tast-show vd) (tast-show e)))
				(caadr syntax-arg)
				(cdadr syntax-arg))
			       (map tast-show (cddr syntax-arg))))))
       ((21) (cons 'let*
		   (cons (map
			  (lambda (vd e)
			    (list (tast-show vd) (tast-show e)))
			  (caar syntax-arg)
			  (cdar syntax-arg))
			 (map tast-show (cdr syntax-arg)))))
       ((22) (cons 'letrec
		   (cons (map
			  (lambda (vd e)
			    (list (tast-show vd) (tast-show e)))
			  (caar syntax-arg)
			  (cdar syntax-arg))
			 (map tast-show (cdr syntax-arg)))))
       ((23) (cons 'begin
		   (map tast-show syntax-arg)))
       ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
       ((25) (error 'tast-show "This can't happen: empty encountered!"))
       ((26) (list 'define
		   (tast-show (car syntax-arg))
		   (tast-show (cdr syntax-arg))))
       ((27) (cons 'define
		   (cons
		    (cons (tast-show (car syntax-arg))
			  (tast-show (cadr syntax-arg)))
		    (map tast-show (cddr syntax-arg)))))
       ((28) (cons 'begin
		   (map tast-show syntax-arg)))
       (else (error 'tast-show "Unknown abstract syntax operator: ~s"
		    syntax-op)))
     syntax-tvar)))

;; tast*-show

(define (tast*-show p)
  ;; shows a list of abstract syntax trees
  (map tast-show p))


;; counters for tagging/untagging

(define untag-counter 0)
(define no-untag-counter 0)
(define tag-counter 0)
(define no-tag-counter 0)
(define may-untag-counter 0)
(define no-may-untag-counter 0)

(define (reset-counters!)
  (set! untag-counter 0)
  (set! no-untag-counter 0)
  (set! tag-counter 0)
  (set! no-tag-counter 0)
  (set! may-untag-counter 0)
  (set! no-may-untag-counter 0))

(define (counters-show)
  (list
   (cons tag-counter no-tag-counter)
   (cons untag-counter no-untag-counter)
   (cons may-untag-counter no-may-untag-counter)))  


;; tag-show

(define (tag-show tvar-rep prog)
  ; display prog with tagging operation
  (if (eqv? tvar-rep dynamic)
      (begin
	(set! tag-counter (+ tag-counter 1))
	(list 'tag prog))
      (begin
	(set! no-tag-counter (+ no-tag-counter 1))
	(list 'no-tag prog))))


;; untag-show

(define (untag-show tvar-rep prog)
  ; display prog with untagging operation
  (if (eqv? tvar-rep dynamic)
      (begin
	(set! untag-counter (+ untag-counter 1))
	(list 'untag prog))
      (begin
	(set! no-untag-counter (+ no-untag-counter 1))
	(list 'no-untag prog))))

(define (may-untag-show tvar-rep prog)
  ; display possible untagging in actual arguments
  (if (eqv? tvar-rep dynamic)
      (begin
	(set! may-untag-counter (+ may-untag-counter 1))
	(list 'may-untag prog))
      (begin
	(set! no-may-untag-counter (+ no-may-untag-counter 1))
	(list 'no-may-untag prog))))


;; tag-ast-show

(define (tag-ast-show ast)
  ;; converts typed and normalized abstract syntax tree to
  ;; a Scheme program with explicit tagging and untagging operations
  (let ((syntax-op (ast-con ast))
        (syntax-tvar (find! (ast-tvar ast)))
	(syntax-arg (ast-arg ast)))
    (case syntax-op
      ((0 1 2 3 4)
       (tag-show syntax-tvar syntax-arg))
      ((8 10) syntax-arg)
      ((29 31) '())
      ((30) (cons (tag-ast-show (car syntax-arg))
                  (tag-ast-show (cdr syntax-arg))))
      ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg)))
                              (tag-ast-show (car syntax-arg)))
                  (tag-ast-show (cdr syntax-arg))))
      ((5) (tag-show syntax-tvar (list 'quote syntax-arg)))
      ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg))))
      ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg))
				       (tag-ast-show (cdr syntax-arg)))))
      ((9) (ast-arg syntax-arg))
      ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg)))))
	      (cons (untag-show proc-tvar 
				(tag-ast-show (car syntax-arg)))
		    (tag-ast-show (cdr syntax-arg)))))
      ((12) (tag-show syntax-tvar
		      (cons 'lambda (cons (tag-ast-show (car syntax-arg))
					  (map tag-ast-show (cdr syntax-arg))))))
      ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg)))))
	      (cons 'if (cons (untag-show test-tvar
					  (tag-ast-show (car syntax-arg)))
			      (cons (tag-ast-show (cadr syntax-arg))
				    (let ((alt (cddr syntax-arg)))
				      (if (eqv? (ast-con alt) empty)
					  '()
					  (list (tag-ast-show alt)))))))))
      ((14) (list 'set! (tag-ast-show (car syntax-arg))
                  (tag-ast-show (cdr syntax-arg))))
      ((15) (cons 'cond
		  (map (lambda (cc)
			 (let ((guard (car cc))
			       (body (cdr cc)))
			   (cons
			    (if (eqv? (ast-con guard) empty)
				'else
				(untag-show (find! (ast-tvar guard))
					    (tag-ast-show guard)))
			    (map tag-ast-show body))))
		       syntax-arg)))
      ((16) (cons 'case
		  (cons (tag-ast-show (car syntax-arg))
			(map (lambda (cc)
			       (let ((data (car cc)))
				 (if (and (pair? data)
					  (eqv? (ast-con (car data)) empty))
				     (cons 'else
					   (map tag-ast-show (cdr cc)))
				     (cons (map datum-show data)
					   (map tag-ast-show (cdr cc))))))
			     (cdr syntax-arg)))))
      ((17) (cons 'and (map
			(lambda (ast)
			  (let ((bool-tvar (find! (ast-tvar ast))))
			    (untag-show bool-tvar (tag-ast-show ast))))
			syntax-arg)))
      ((18) (cons 'or (map
		       (lambda (ast)
			 (let ((bool-tvar (find! (ast-tvar ast))))
			   (untag-show bool-tvar (tag-ast-show ast))))
		       syntax-arg)))
      ((19) (cons 'let
		  (cons (map
			 (lambda (vd e)
			   (list (tag-ast-show vd) (tag-ast-show e)))
			 (caar syntax-arg)
			 (cdar syntax-arg))
			(map tag-ast-show (cdr syntax-arg)))))
      ((20) (cons 'let
		  (cons (tag-ast-show (car syntax-arg))
			(cons (map
			       (lambda (vd e)
				 (list (tag-ast-show vd) (tag-ast-show e)))
			       (caadr syntax-arg)
			       (cdadr syntax-arg))
			      (map tag-ast-show (cddr syntax-arg))))))
      ((21) (cons 'let*
		  (cons (map
			 (lambda (vd e)
			   (list (tag-ast-show vd) (tag-ast-show e)))
			 (caar syntax-arg)
			 (cdar syntax-arg))
			(map tag-ast-show (cdr syntax-arg)))))
      ((22) (cons 'letrec
		  (cons (map
			 (lambda (vd e)
			   (list (tag-ast-show vd) (tag-ast-show e)))
			 (caar syntax-arg)
			 (cdar syntax-arg))
			(map tag-ast-show (cdr syntax-arg)))))
      ((23) (cons 'begin
		  (map tag-ast-show syntax-arg)))
      ((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
      ((25) (error 'tag-ast-show "This can't happen: empty encountered!"))
      ((26) (list 'define
		  (tag-ast-show (car syntax-arg))
		  (tag-ast-show (cdr syntax-arg))))
      ((27) (let ((func-tvar (find! (ast-tvar (car syntax-arg)))))
	      (list 'define
		    (tag-ast-show (car syntax-arg))
		    (tag-show func-tvar
			      (cons 'lambda
				    (cons (tag-ast-show (cadr syntax-arg))
					  (map tag-ast-show (cddr syntax-arg))))))))
      ((28) (cons 'begin
		  (map tag-ast-show syntax-arg)))
      (else (error 'tag-ast-show "Unknown abstract syntax operator: ~s"
		   syntax-op)))))


; tag-ast*-show

(define (tag-ast*-show p)
  ; display list of commands/expressions with tagging/untagging
  ; operations
  (map tag-ast-show p))
; ----------------------------------------------------------------------------
; Top level type environment
; ----------------------------------------------------------------------------


; Needed packages: type management (monomorphic and polymorphic)

;(load "typ-mgmt.ss")
;(load "ptyp-mgm.ss")


; type environment for miscellaneous

(define misc-env
  (list
   (cons 'quote (forall (lambda (tv) tv)))
   (cons 'eqv? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
					       (boolean)))))
   (cons 'eq? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
					      (boolean)))))
   (cons 'equal? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
						 (boolean)))))
   ))

; type environment for input/output

(define io-env
  (list
   (cons 'open-input-file (procedure (convert-tvars (list (charseq))) dynamic))
   (cons 'eof-object? (procedure (convert-tvars (list dynamic)) (boolean)))
   (cons 'read (forall (lambda (tv)
			 (procedure (convert-tvars (list tv)) dynamic))))
   (cons 'write (forall (lambda (tv)
			  (procedure (convert-tvars (list tv)) dynamic))))
   (cons 'display (forall (lambda (tv)
			    (procedure (convert-tvars (list tv)) dynamic))))
   (cons 'newline (procedure (null) dynamic))
   (cons 'pretty-print (forall (lambda (tv)
				 (procedure (convert-tvars (list tv)) dynamic))))))


; type environment for Booleans

(define boolean-env
  (list
   (cons 'boolean? (forall (lambda (tv)
			     (procedure (convert-tvars (list tv)) (boolean)))))
   ;(cons #f (boolean))
   ; #f doesn't exist in Chez Scheme, but gets mapped to null!
   (cons #t (boolean))
   (cons 'not (procedure (convert-tvars (list (boolean))) (boolean)))
   ))


; type environment for pairs and lists

(define (list-type tv)
  (fix (lambda (tv2) (pair tv tv2))))

(define list-env
  (list
   (cons 'pair? (forall2 (lambda (tv1 tv2)
			   (procedure (convert-tvars (list (pair tv1 tv2)))
				      (boolean)))))
   (cons 'null? (forall2 (lambda (tv1 tv2)
			   (procedure (convert-tvars (list (pair tv1 tv2)))
				      (boolean)))))
   (cons 'list? (forall2 (lambda (tv1 tv2)
			   (procedure (convert-tvars (list (pair tv1 tv2)))
				      (boolean)))))
   (cons 'cons (forall2 (lambda (tv1 tv2)
			  (procedure (convert-tvars (list tv1 tv2))
				     (pair tv1 tv2)))))
   (cons 'car (forall2 (lambda (tv1 tv2)
			 (procedure (convert-tvars (list (pair tv1 tv2)))
				    tv1))))
   (cons 'cdr (forall2 (lambda (tv1 tv2)
			 (procedure (convert-tvars (list (pair tv1 tv2)))
				    tv2))))
   (cons 'set-car! (forall2 (lambda (tv1 tv2)
			      (procedure (convert-tvars (list (pair tv1 tv2)
							      tv1))
					 dynamic))))
   (cons 'set-cdr! (forall2 (lambda (tv1 tv2)
			      (procedure (convert-tvars (list (pair tv1 tv2)
							      tv2))
					 dynamic))))
   (cons 'caar (forall3 (lambda (tv1 tv2 tv3)
			  (procedure (convert-tvars
				      (list (pair (pair tv1 tv2) tv3)))
				     tv1))))
   (cons 'cdar (forall3 (lambda (tv1 tv2 tv3)
			  (procedure (convert-tvars
				      (list (pair (pair tv1 tv2) tv3)))
				     tv2))))

   (cons 'cadr (forall3 (lambda (tv1 tv2 tv3)
			  (procedure (convert-tvars
				      (list (pair tv1 (pair tv2 tv3))))
				     tv2))))
   (cons 'cddr (forall3 (lambda (tv1 tv2 tv3)
			  (procedure (convert-tvars
				      (list (pair tv1 (pair tv2 tv3))))
				     tv3))))
   (cons 'caaar (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair (pair (pair tv1 tv2) tv3) tv4)))
			      tv1))))
   (cons 'cdaar (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair (pair (pair tv1 tv2) tv3) tv4)))
			      tv2))))
   (cons 'cadar (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
			      tv2))))
   (cons 'cddar (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
			      tv3))))
   (cons 'caadr (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair tv1 (pair (pair tv2 tv3) tv4))))
			      tv2))))
   (cons 'cdadr (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair tv1 (pair (pair tv2 tv3) tv4))))
			      tv3))))
   (cons 'caddr (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
			      tv3))))
   (cons 'cdddr (forall4
		 (lambda (tv1 tv2 tv3 tv4)
		   (procedure (convert-tvars
			       (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
			      tv4))))
   (cons 'cadddr
         (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
                    (procedure (convert-tvars
				(list (pair tv1
					    (pair tv2
						  (pair tv3
							(pair tv4 tv5))))))
			       tv4))))
   (cons 'cddddr
         (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
                    (procedure (convert-tvars
				(list (pair tv1
					    (pair tv2
						  (pair tv3
							(pair tv4 tv5))))))
			       tv5))))
   (cons 'list (forall (lambda (tv)
			 (procedure tv tv))))
   (cons 'length (forall (lambda (tv)
			   (procedure (convert-tvars (list (list-type tv)))
				      (number)))))
   (cons 'append (forall (lambda (tv)
			   (procedure (convert-tvars (list (list-type tv)
							   (list-type tv)))
				      (list-type tv)))))
   (cons 'reverse (forall (lambda (tv)
			    (procedure (convert-tvars (list (list-type tv)))
				       (list-type tv)))))
   (cons 'list-ref (forall (lambda (tv)
			     (procedure (convert-tvars (list (list-type tv)
							     (number)))
					tv))))
   (cons 'memq (forall (lambda (tv)
			 (procedure (convert-tvars (list tv
							 (list-type tv)))
				    (boolean)))))
   (cons 'memv (forall (lambda (tv)
			 (procedure (convert-tvars (list tv
							 (list-type tv)))
				    (boolean)))))
   (cons 'member (forall (lambda (tv)
			   (procedure (convert-tvars (list tv
							   (list-type tv)))
				      (boolean)))))
   (cons 'assq (forall2 (lambda (tv1 tv2)
			  (procedure (convert-tvars
				      (list tv1
					    (list-type (pair tv1 tv2))))
				     (pair tv1 tv2)))))
   (cons 'assv (forall2 (lambda (tv1 tv2)
			  (procedure (convert-tvars
				      (list tv1
					    (list-type (pair tv1 tv2))))
				     (pair tv1 tv2)))))
   (cons 'assoc (forall2 (lambda (tv1 tv2)
			   (procedure (convert-tvars
				       (list tv1
					     (list-type (pair tv1 tv2))))
				      (pair tv1 tv2)))))
   ))


(define symbol-env
  (list
   (cons 'symbol? (forall (lambda (tv)
			    (procedure (convert-tvars (list tv)) (boolean)))))
   (cons 'symbol->string (procedure (convert-tvars (list (symbol))) (charseq)))
   (cons 'string->symbol (procedure (convert-tvars (list (charseq))) (symbol)))
   ))

(define number-env
  (list
   (cons 'number? (forall (lambda (tv)
			    (procedure (convert-tvars (list tv)) (boolean)))))
   (cons '+ (procedure (convert-tvars (list (number) (number))) (number)))
   (cons '- (procedure (convert-tvars (list (number) (number))) (number)))
   (cons '* (procedure (convert-tvars (list (number) (number))) (number)))
   (cons '/ (procedure (convert-tvars (list (number) (number))) (number)))
   (cons 'number->string (procedure (convert-tvars (list (number))) (charseq)))
   (cons 'string->number (procedure (convert-tvars (list (charseq))) (number)))
   ))

(define char-env
  (list
   (cons 'char? (forall (lambda (tv)
			  (procedure (convert-tvars (list tv)) (boolean)))))
   (cons 'char->integer (procedure (convert-tvars (list (character)))
                                   (number)))
   (cons 'integer->char (procedure (convert-tvars (list (number)))
                                   (character)))
   ))

(define string-env
  (list
   (cons 'string? (forall (lambda (tv)
			    (procedure (convert-tvars (list tv)) (boolean)))))
   ))

(define vector-env
  (list
   (cons 'vector? (forall (lambda (tv)
			    (procedure (convert-tvars (list tv)) (boolean)))))
   (cons 'make-vector (forall (lambda (tv)
				(procedure (convert-tvars (list (number)))
					   (array tv)))))
   (cons 'vector-length (forall (lambda (tv)
				  (procedure (convert-tvars (list (array tv)))
					     (number)))))
   (cons 'vector-ref (forall (lambda (tv)
			       (procedure (convert-tvars (list (array tv)
							       (number)))
					  tv))))
   (cons 'vector-set! (forall (lambda (tv)
				(procedure (convert-tvars (list (array tv)
								(number)
								tv))
					   dynamic))))
   ))

(define procedure-env
  (list
   (cons 'procedure? (forall (lambda (tv)
			       (procedure (convert-tvars (list tv)) (boolean)))))
   (cons 'map (forall2 (lambda (tv1 tv2)
			 (procedure (convert-tvars
				     (list (procedure (convert-tvars
						       (list tv1)) tv2)
					   (list-type tv1)))
				    (list-type tv2)))))
   (cons 'foreach (forall2 (lambda (tv1 tv2)
			     (procedure (convert-tvars
					 (list (procedure (convert-tvars
							   (list tv1)) tv2)
					       (list-type tv1)))
					(list-type tv2)))))
   (cons 'call-with-current-continuation
	 (forall2 (lambda (tv1 tv2) 
		   (procedure (convert-tvars
			       (list (procedure
				      (convert-tvars
				       (list (procedure (convert-tvars
							 (list tv1)) tv2)))
				      tv2)))
			      tv2))))
   ))


; global top level environment

(define (global-env)
  (append misc-env
	  io-env
	  boolean-env
	  symbol-env
	  number-env
	  char-env
	  string-env
	  vector-env
	  procedure-env
	  list-env))

(define dynamic-top-level-env (global-env))

(define (init-dynamic-top-level-env!)
  (set! dynamic-top-level-env (global-env))
  '())

(define (dynamic-top-level-env-show)
  ; displays the top level environment
  (map (lambda (binding)
	 (cons (key-show (binding-key binding))
	       (cons ': (tvar-show (binding-value binding)))))
       (env->list dynamic-top-level-env)))
; ----------------------------------------------------------------------------
; Dynamic type inference for Scheme
; ----------------------------------------------------------------------------

; Needed packages:

(define (ic!) (init-global-constraints!))
(define (pc) (glob-constr-show))
(define (lc) (length global-constraints))
(define (n!) (normalize-global-constraints!))
(define (pt) (dynamic-top-level-env-show))
(define (it!) (init-dynamic-top-level-env!))
(define (io!) (set! tag-ops 0) (set! no-ops 0))
(define (i!) (ic!) (it!) (io!) '())

(define tag-ops 0)
(define no-ops 0)


; This wasn't intended to be an i/o benchmark,
; so let's read the file just once.

(define *forms*
  (call-with-input-file
    "dynamic-input.sch"
    (lambda (port)
      (define (loop forms)
        (let ((form (read port)))
          (if (eof-object? form)
              (reverse forms)
              (loop (cons form forms)))))
      (loop '()))))

(define (dynamic-parse-forms forms)
  (if (null? forms)
      '()
      (let ((next-input (car forms)))
	(dynamic-parse-action-commands
	 (dynamic-parse-command dynamic-empty-env next-input)
	 (dynamic-parse-forms (cdr forms))))))

(define doit 
  (lambda ()
    (i!)
    (let ((foo (dynamic-parse-forms *forms*)))
      (normalize-global-constraints!)
      (reset-counters!)
      (tag-ast*-show foo)
      (counters-show))))

(define (dynamic-benchmark . rest)
  (let ((n (if (null? rest) 1 (car rest))))
    (run-benchmark "dynamic"
                   n
                   doit 
                   (lambda (result) 
                     #t))))

; eof