conservatory
/
vx-scheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
vx-scheme/testcases/dynamic.scm

2320 lines
82 KiB
Scheme
Raw Normal View History

initial import git-svn-id: svn://localhost/root/svnrepo/trunk@2 bee25f81-8ba7-4b93-944d-dfac3d1a11cc
2006-08-12 15:00:13 -04:00
;;; DYNAMIC -- Obtained from Andrew Wright.
;
; 08/06/01 (felix): renamed "null" to "null2" because stupid MZC can't
; handle redefinitions of primitives.
;
;
;; 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 (null2)
; ***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) (null2))
((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) (null2))
((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 (null2) 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)
(define doit
(lambda ()
(i!)
(let ((foo (dynamic-parse-file "dynamic.scm")))
(normalize-global-constraints!)
(reset-counters!)
(tag-ast*-show foo)
(counters-show))))
(display (doit))
(newline)