2321 lines
82 KiB
Scheme
2321 lines
82 KiB
Scheme
;;; DYNAMIC -- Obtained from Andrew Wright.
|
|
|
|
;; 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 (fatal-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)
|
|
(fatal-error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
|
|
((dynamic-lookup e f-env)
|
|
(fatal-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))))
|
|
(fatal-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 (fatal-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 (fatal-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 (fatal-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)
|
|
(fatal-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))))
|
|
(fatal-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))
|
|
(fatal-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)))
|
|
(fatal-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)
|
|
(fatal-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 (fatal-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)))
|
|
(fatal-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))
|
|
(fatal-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)))
|
|
(fatal-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))
|
|
(fatal-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))
|
|
(fatal-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)))
|
|
(fatal-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 (fatal-error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
|
|
(dynamic-parse-body env (cdr e)))
|
|
(fatal-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))
|
|
(fatal-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)))
|
|
(fatal-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)))
|
|
(fatal-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)))
|
|
(fatal-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)))
|
|
(fatal-error 'dynamic-parse-sequential-bindings
|
|
"Illegal binding: ~s" fst-bind))))
|
|
(else (fatal-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)))
|
|
(fatal-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)))
|
|
(fatal-error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))
|
|
|
|
|
|
; dynamic-parse-do
|
|
|
|
(define (dynamic-parse-do env args)
|
|
;; parses do-expressions
|
|
;; ***Note***: Not implemented!
|
|
(fatal-error 'dynamic-parse-do "Nothing yet..."))
|
|
|
|
; dynamic-parse-quasiquote
|
|
|
|
(define (dynamic-parse-quasiquote env args)
|
|
;; ***Note***: Not implemented!
|
|
(fatal-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)
|
|
(fatal-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)))
|
|
(fatal-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 (fatal-error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
|
|
(fatal-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)
|
|
(fatal-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) (fatal-error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
|
|
((25) (fatal-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 (fatal-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 (fatal-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)
|
|
(write 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) (fatal-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 (fatal-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 (fatal-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) (fatal-error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
|
|
((25) (fatal-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 (fatal-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) (fatal-error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
|
|
((25) (fatal-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 (fatal-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)
|
|
|
|
|
|
(define doit
|
|
(lambda ()
|
|
(i!)
|
|
(let ((foo (dynamic-parse-file "r6rs-benchmarks/dynamic.src.ss")))
|
|
(normalize-global-constraints!)
|
|
(reset-counters!)
|
|
(tag-ast*-show foo)
|
|
(counters-show))))
|
|
|
|
(define (main . args)
|
|
(run-benchmark
|
|
"dynamic"
|
|
dynamic-iters
|
|
(lambda (result) (equal? result '((218 . 455) (6 . 1892) (2204 . 446))))
|
|
(lambda () (lambda () (doit)))))
|