1 ; This benchmark was obtained from Andrew Wright,
2 ; based on Fritz Henglein's code.
3 ; 970215 / wdc Removed most i/o and added dynamic-benchmark.
4 ; 990707 / lth Added a quote and changed the call to run-benchmark.
5 ; 010404 / wdc Changed the input file path name to "dynamic-input.sch".
7 ;; Fritz's dynamic type inferencer, set up to run on itself
8 ;; (see the end of this file).
10 ;----------------------------------------------------------------------------
11 ; Environment management
12 ;----------------------------------------------------------------------------
14 ;; environments are lists of pairs, the first component being the key
16 ;; general environment operations
19 ;; gen-binding: Key x Value -> Binding
20 ;; binding-key: Binding -> Key
21 ;; binding-value: Binding -> Value
22 ;; binding-show: Binding -> Symbol*
23 ;; extend-env-with-binding: Env x Binding -> Env
24 ;; extend-env-with-env: Env x Env -> Env
25 ;; lookup: Key x Env -> (Binding + False)
26 ;; env->list: Env -> Binding*
27 ;; env-show: Env -> Symbol*
32 (define gen-binding cons)
33 ; generates a type binding, binding a symbol to a type variable
35 (define binding-key car)
36 ; returns the key of a type binding
38 (define binding-value cdr)
39 ; returns the tvariable of a type binding
41 (define (key-show key)
42 ; default show procedure for keys
45 (define (value-show value)
46 ; default show procedure for values
49 (define (binding-show binding)
50 ; returns a printable representation of a type binding
51 (cons (key-show (binding-key binding))
52 (cons ': (value-show (binding-value binding)))))
57 (define dynamic-empty-env '())
58 ; returns the empty environment
60 (define (extend-env-with-binding env binding)
61 ; extends env with a binding, which hides any other binding in env
62 ; for the same key (see dynamic-lookup)
63 ; returns the extended environment
66 (define (extend-env-with-env env ext-env)
67 ; extends environment env with environment ext-env
68 ; a binding for a key in ext-env hides any binding in env for
69 ; the same key (see dynamic-lookup)
70 ; returns the extended environment
73 (define dynamic-lookup (lambda (x l) (assv x l)))
74 ; returns the first pair in env that matches the key; returns #f
75 ; if no such pair exists
78 ; converts an environment to a list of bindings
81 (define (env-show env)
82 ; returns a printable list representation of a type environment
83 (map binding-show env))
84 ;----------------------------------------------------------------------------
86 ;----------------------------------------------------------------------------
89 ;; Needed packages: environment management
96 (define syntactic-keywords
97 ;; source: IEEE Scheme, 7.1, <expression keyword>, <syntactic keyword>
98 '(lambda if set! begin cond and or case let let* letrec do
99 quasiquote else => define unquote unquote-splicing))
106 ; dynamic-parse-datum: parses nonterminal <datum>
108 (define (dynamic-parse-datum e)
109 ;; Source: IEEE Scheme, sect. 7.2, <datum>
110 ;; Note: "'" is parsed as 'quote, "`" as 'quasiquote, "," as
111 ;; 'unquote, ",@" as 'unquote-splicing (see sect. 4.2.5, p. 18)
112 ;; ***Note***: quasi-quotations are not permitted! (It would be
113 ;; necessary to pass the environment to dynamic-parse-datum.)
116 (dynamic-parse-action-null-const))
118 (dynamic-parse-action-boolean-const e))
120 (dynamic-parse-action-char-const e))
122 (dynamic-parse-action-number-const e))
124 (dynamic-parse-action-string-const e))
126 (dynamic-parse-action-symbol-const e))
128 (dynamic-parse-action-vector-const (map dynamic-parse-datum (vector->list e))))
130 (dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
131 (dynamic-parse-datum (cdr e))))
132 (else (error 'dynamic-parse-datum "Unknown datum: ~s" e))))
137 ; dynamic-parse-formal: parses nonterminal <variable> in defining occurrence position
139 (define (dynamic-parse-formal f-env e)
140 ; e is an arbitrary object, f-env is a forbidden environment;
141 ; returns: a variable definition (a binding for the symbol), plus
142 ; the value of the binding as a result
145 ((memq e syntactic-keywords)
146 (error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
147 ((dynamic-lookup e f-env)
148 (error 'dynamic-parse-formal "Duplicate variable definition: ~s" e))
149 (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e)))
150 (cons (gen-binding e dynamic-parse-action-result)
151 dynamic-parse-action-result))))
152 (error 'dynamic-parse-formal "Not an identifier: ~s" e)))
154 ; dynamic-parse-formal*
156 (define (dynamic-parse-formal* formals)
157 ;; parses a list of formals and returns a pair consisting of generated
158 ;; environment and list of parsing action results
161 (lambda (f-env results formals)
162 ;; f-env: "forbidden" environment (to avoid duplicate defs)
163 ;; results: the results of the parsing actions
164 ;; formals: the unprocessed formals
165 ;; Note: generates the results of formals in reverse order!
168 (cons f-env results))
170 (let* ((fst-formal (car formals))
171 (binding-result (dynamic-parse-formal f-env fst-formal))
172 (binding (car binding-result))
173 (var-result (cdr binding-result)))
175 (extend-env-with-binding f-env binding)
176 (cons var-result results)
178 (else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals))))))
179 (let ((renv-rres (pf* dynamic-empty-env '() formals)))
180 (cons (car renv-rres) (reverse (cdr renv-rres))))))
183 ; dynamic-parse-formals: parses <formals>
185 (define (dynamic-parse-formals formals)
186 ;; parses <formals>; see IEEE Scheme, sect. 7.3
187 ;; returns a pair: env and result
188 (letrec ((pfs (lambda (f-env formals)
191 (cons dynamic-empty-env (dynamic-parse-action-null-formal)))
193 (let* ((fst-formal (car formals))
194 (rem-formals (cdr formals))
195 (bind-res (dynamic-parse-formal f-env fst-formal))
196 (bind (car bind-res))
198 (nf-env (extend-env-with-binding f-env bind))
199 (renv-res* (pfs nf-env rem-formals))
200 (renv (car renv-res*))
201 (res* (cdr renv-res*)))
203 (extend-env-with-binding renv bind)
204 (dynamic-parse-action-pair-formal res res*))))
206 (let* ((bind-res (dynamic-parse-formal f-env formals))
207 (bind (car bind-res))
208 (res (cdr bind-res)))
210 (extend-env-with-binding dynamic-empty-env bind)
212 (pfs dynamic-empty-env formals)))
217 ; dynamic-parse-expression: parses nonterminal <expression>
219 (define (dynamic-parse-expression env e)
222 (dynamic-parse-variable env e))
224 (let ((op (car e)) (args (cdr e)))
226 ((quote) (dynamic-parse-quote env args))
227 ((lambda) (dynamic-parse-lambda env args))
228 ((if) (dynamic-parse-if env args))
229 ((set!) (dynamic-parse-set env args))
230 ((begin) (dynamic-parse-begin env args))
231 ((cond) (dynamic-parse-cond env args))
232 ((case) (dynamic-parse-case env args))
233 ((and) (dynamic-parse-and env args))
234 ((or) (dynamic-parse-or env args))
235 ((let) (dynamic-parse-let env args))
236 ((let*) (dynamic-parse-let* env args))
237 ((letrec) (dynamic-parse-letrec env args))
238 ((do) (dynamic-parse-do env args))
239 ((quasiquote) (dynamic-parse-quasiquote env args))
240 (else (dynamic-parse-procedure-call env op args)))))
241 (else (dynamic-parse-datum e))))
243 ; dynamic-parse-expression*
245 (define (dynamic-parse-expression* env exprs)
246 ;; Parses lists of expressions (returns them in the right order!)
251 ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es)))
252 (else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es))))))
253 (reverse (pe* '() exprs))))
256 ; dynamic-parse-expressions
258 (define (dynamic-parse-expressions env exprs)
259 ;; parses lists of arguments of a procedure call
261 ((null? exprs) (dynamic-parse-action-null-arg))
262 ((pair? exprs) (let* ((fst-expr (car exprs))
263 (rem-exprs (cdr exprs))
264 (fst-res (dynamic-parse-expression env fst-expr))
265 (rem-res (dynamic-parse-expressions env rem-exprs)))
266 (dynamic-parse-action-pair-arg fst-res rem-res)))
267 (else (error 'dynamic-parse-expressions "Illegal expression list: ~s"
271 ; dynamic-parse-variable: parses variables (applied occurrences)
273 (define (dynamic-parse-variable env e)
275 (if (memq e syntactic-keywords)
276 (error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e)
277 (let ((assoc-var-def (dynamic-lookup e env)))
279 (dynamic-parse-action-variable (binding-value assoc-var-def))
280 (dynamic-parse-action-identifier e))))
281 (error 'dynamic-parse-variable "Not an identifier: ~s" e)))
284 ; dynamic-parse-procedure-call
286 (define (dynamic-parse-procedure-call env op args)
287 (dynamic-parse-action-procedure-call
288 (dynamic-parse-expression env op)
289 (dynamic-parse-expressions env args)))
292 ; dynamic-parse-quote
294 (define (dynamic-parse-quote env args)
295 (if (list-of-1? args)
296 (dynamic-parse-datum (car args))
297 (error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args)))
300 ; dynamic-parse-lambda
302 (define (dynamic-parse-lambda env args)
304 (let* ((formals (car args))
306 (nenv-fresults (dynamic-parse-formals formals))
307 (nenv (car nenv-fresults))
308 (fresults (cdr nenv-fresults)))
309 (dynamic-parse-action-lambda-expression
311 (dynamic-parse-body (extend-env-with-env env nenv) body)))
312 (error 'dynamic-parse-lambda "Illegal formals/body: ~s" args)))
317 (define (dynamic-parse-body env body)
318 ; <body> = <definition>* <expression>+
319 (define (def-var* f-env body)
320 ; finds the defined variables in a body and returns an
321 ; environment containing them
323 (let ((n-env (def-var f-env (car body))))
325 (def-var* n-env (cdr body))
328 (define (def-var f-env clause)
329 ; finds the defined variables in a single clause and extends
330 ; f-env accordingly; returns false if it's not a definition
333 ((define) (if (pair? (cdr clause))
334 (let ((pattern (cadr clause)))
337 (extend-env-with-binding
340 (dynamic-parse-action-var-def pattern))))
341 ((and (pair? pattern) (symbol? (car pattern)))
342 (extend-env-with-binding
344 (gen-binding (car pattern)
345 (dynamic-parse-action-var-def
349 ((begin) (def-var* f-env (cdr clause)))
353 (dynamic-parse-command* (def-var* env body) body)
354 (error 'dynamic-parse-body "Illegal body: ~s" body)))
358 (define (dynamic-parse-if env args)
361 (dynamic-parse-action-conditional
362 (dynamic-parse-expression env (car args))
363 (dynamic-parse-expression env (cadr args))
364 (dynamic-parse-expression env (caddr args))))
366 (dynamic-parse-action-conditional
367 (dynamic-parse-expression env (car args))
368 (dynamic-parse-expression env (cadr args))
369 (dynamic-parse-action-empty)))
370 (else (error 'dynamic-parse-if "Not an if-expression: ~s" args))))
375 (define (dynamic-parse-set env args)
376 (if (list-of-2? args)
377 (dynamic-parse-action-assignment
378 (dynamic-parse-variable env (car args))
379 (dynamic-parse-expression env (cadr args)))
380 (error 'dynamic-parse-set "Not a variable/expression pair: ~s" args)))
383 ; dynamic-parse-begin
385 (define (dynamic-parse-begin env args)
386 (dynamic-parse-action-begin-expression
387 (dynamic-parse-body env args)))
392 (define (dynamic-parse-cond env args)
393 (if (and (pair? args) (list? args))
394 (dynamic-parse-action-cond-expression
396 (dynamic-parse-cond-clause env e))
398 (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args)))
400 ; dynamic-parse-cond-clause
402 (define (dynamic-parse-cond-clause env e)
403 ;; ***Note***: Only (<test> <sequence>) is permitted!
406 (if (eqv? (car e) 'else)
407 (dynamic-parse-action-empty)
408 (dynamic-parse-expression env (car e)))
409 (dynamic-parse-body env (cdr e)))
410 (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e)))
415 (define (dynamic-parse-and env args)
417 (dynamic-parse-action-and-expression
418 (dynamic-parse-expression* env args))
419 (error 'dynamic-parse-and "Not a list of arguments: ~s" args)))
424 (define (dynamic-parse-or env args)
426 (dynamic-parse-action-or-expression
427 (dynamic-parse-expression* env args))
428 (error 'dynamic-parse-or "Not a list of arguments: ~s" args)))
433 (define (dynamic-parse-case env args)
434 (if (and (list? args) (> (length args) 1))
435 (dynamic-parse-action-case-expression
436 (dynamic-parse-expression env (car args))
438 (dynamic-parse-case-clause env e))
440 (error 'dynamic-parse-case "Not a list of clauses: ~s" args)))
442 ; dynamic-parse-case-clause
444 (define (dynamic-parse-case-clause env e)
448 ((eqv? (car e) 'else)
449 (list (dynamic-parse-action-empty)))
451 (map dynamic-parse-datum (car e)))
452 (else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
453 (dynamic-parse-body env (cdr e)))
454 (error 'dynamic-parse-case-clause "Not case clause: ~s" e)))
459 (define (dynamic-parse-let env args)
461 (if (symbol? (car args))
462 (dynamic-parse-named-let env args)
463 (dynamic-parse-normal-let env args))
464 (error 'dynamic-parse-let "Illegal bindings/body: ~s" args)))
467 ; dynamic-parse-normal-let
469 (define (dynamic-parse-normal-let env args)
470 ;; parses "normal" let-expressions
471 (let* ((bindings (car args))
473 (env-ast (dynamic-parse-parallel-bindings env bindings))
475 (bresults (cdr env-ast)))
476 (dynamic-parse-action-let-expression
478 (dynamic-parse-body (extend-env-with-env env nenv) body))))
480 ; dynamic-parse-named-let
482 (define (dynamic-parse-named-let env args)
483 ;; parses a named let-expression
484 (if (pair? (cdr args))
485 (let* ((variable (car args))
486 (bindings (cadr args))
488 (vbind-vres (dynamic-parse-formal dynamic-empty-env variable))
489 (vbind (car vbind-vres))
490 (vres (cdr vbind-vres))
491 (env-ast (dynamic-parse-parallel-bindings env bindings))
493 (bresults (cdr env-ast)))
494 (dynamic-parse-action-named-let-expression
496 (dynamic-parse-body (extend-env-with-env
497 (extend-env-with-binding env vbind)
499 (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))
502 ; dynamic-parse-parallel-bindings
504 (define (dynamic-parse-parallel-bindings env bindings)
505 ; returns a pair consisting of an environment
506 ; and a list of pairs (variable . asg)
507 ; ***Note***: the list of pairs is returned in reverse unzipped form!
508 (if (list-of-list-of-2s? bindings)
509 (let* ((env-formals-asg
510 (dynamic-parse-formal* (map car bindings)))
511 (nenv (car env-formals-asg))
512 (bresults (cdr env-formals-asg))
514 (dynamic-parse-expression* env (map cadr bindings))))
515 (cons nenv (cons bresults exprs-asg)))
516 (error 'dynamic-parse-parallel-bindings
517 "Not a list of bindings: ~s" bindings)))
522 (define (dynamic-parse-let* env args)
524 (let* ((bindings (car args))
526 (env-ast (dynamic-parse-sequential-bindings env bindings))
528 (bresults (cdr env-ast)))
529 (dynamic-parse-action-let*-expression
531 (dynamic-parse-body (extend-env-with-env env nenv) body)))
532 (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args)))
534 ; dynamic-parse-sequential-bindings
536 (define (dynamic-parse-sequential-bindings env bindings)
537 ; returns a pair consisting of an environment
538 ; and a list of pairs (variable . asg)
539 ;; ***Note***: the list of pairs is returned in reverse unzipped form!
542 (lambda (f-env c-env var-defs expr-asgs binds)
543 ;; f-env: forbidden environment
544 ;; c-env: constructed environment
545 ;; var-defs: results of formals
546 ;; expr-asgs: results of corresponding expressions
547 ;; binds: reminding bindings to process
550 (cons f-env (cons var-defs expr-asgs)))
552 (let ((fst-bind (car binds)))
553 (if (list-of-2? fst-bind)
554 (let* ((fbinding-bres
555 (dynamic-parse-formal f-env (car fst-bind)))
556 (fbind (car fbinding-bres))
557 (bres (cdr fbinding-bres))
559 (dynamic-parse-expression c-env (cadr fst-bind))))
561 (extend-env-with-binding f-env fbind)
562 (extend-env-with-binding c-env fbind)
564 (cons new-expr-asg expr-asgs)
566 (error 'dynamic-parse-sequential-bindings
567 "Illegal binding: ~s" fst-bind))))
568 (else (error 'dynamic-parse-sequential-bindings
569 "Illegal bindings: ~s" binds))))))
570 (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
571 (cons (car env-vdefs-easgs)
572 (cons (reverse (cadr env-vdefs-easgs))
573 (reverse (cddr env-vdefs-easgs)))))))
576 ; dynamic-parse-letrec
578 (define (dynamic-parse-letrec env args)
580 (let* ((bindings (car args))
582 (env-ast (dynamic-parse-recursive-bindings env bindings))
584 (bresults (cdr env-ast)))
585 (dynamic-parse-action-letrec-expression
587 (dynamic-parse-body (extend-env-with-env env nenv) body)))
588 (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args)))
590 ; dynamic-parse-recursive-bindings
592 (define (dynamic-parse-recursive-bindings env bindings)
593 ;; ***Note***: the list of pairs is returned in reverse unzipped form!
594 (if (list-of-list-of-2s? bindings)
595 (let* ((env-formals-asg
596 (dynamic-parse-formal* (map car bindings)))
598 (car env-formals-asg))
600 (cdr env-formals-asg))
602 (dynamic-parse-expression*
603 (extend-env-with-env env formals-env)
604 (map cadr bindings))))
607 (cons formals-res exprs-asg)))
608 (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))
613 (define (dynamic-parse-do env args)
614 ;; parses do-expressions
615 ;; ***Note***: Not implemented!
616 (error 'dynamic-parse-do "Nothing yet..."))
618 ; dynamic-parse-quasiquote
620 (define (dynamic-parse-quasiquote env args)
621 ;; ***Note***: Not implemented!
622 (error 'dynamic-parse-quasiquote "Nothing yet..."))
627 ; dynamic-parse-command
629 (define (dynamic-parse-command env c)
634 ((define) (dynamic-parse-define env args))
635 ; ((begin) (dynamic-parse-command* env args)) ;; AKW
636 ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args)))
637 (else (dynamic-parse-expression env c))))
638 (dynamic-parse-expression env c)))
641 ; dynamic-parse-command*
643 (define (dynamic-parse-command* env commands)
644 ;; parses a sequence of commands
646 (map (lambda (command) (dynamic-parse-command env command)) commands)
647 (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands)))
650 ; dynamic-parse-define
652 (define (dynamic-parse-define env args)
653 ;; three cases -- see IEEE Scheme, sect. 5.2
654 ;; ***Note***: the parser admits forms (define (x . y) ...)
655 ;; ***Note***: Variables are treated as applied occurrences!
657 (let ((pattern (car args))
658 (exp-or-body (cdr args)))
661 (if (list-of-1? exp-or-body)
662 (dynamic-parse-action-definition
663 (dynamic-parse-variable env pattern)
664 (dynamic-parse-expression env (car exp-or-body)))
665 (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body)))
667 (let* ((function-name (car pattern))
668 (function-arg-names (cdr pattern))
669 (env-ast (dynamic-parse-formals function-arg-names))
670 (formals-env (car env-ast))
671 (formals-ast (cdr env-ast)))
672 (dynamic-parse-action-function-definition
673 (dynamic-parse-variable env function-name)
675 (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
676 (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
677 (error 'dynamic-parse-define "Not a valid definition: ~s" args)))
679 ;; Auxiliary routines
683 (define (forall? pred list)
686 (and (pred (car list)) (forall? pred (cdr list)))))
690 (define (list-of-1? l)
691 (and (pair? l) (null? (cdr l))))
695 (define (list-of-2? l)
696 (and (pair? l) (pair? (cdr l)) (null? (cddr l))))
700 (define (list-of-3? l)
701 (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l))))
703 ; list-of-list-of-2s?
705 (define (list-of-list-of-2s? e)
710 (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e))))
716 ; dynamic-parse-from-port
718 (define (dynamic-parse-from-port port)
719 (let ((next-input (read port)))
720 (if (eof-object? next-input)
722 (dynamic-parse-action-commands
723 (dynamic-parse-command dynamic-empty-env next-input)
724 (dynamic-parse-from-port port)))))
728 (define (dynamic-parse-file file-name)
729 (let ((input-port (open-input-file file-name)))
730 (dynamic-parse-from-port input-port)))
731 ;----------------------------------------------------------------------------
732 ; Implementation of Union/find data structure in Scheme
733 ;----------------------------------------------------------------------------
735 ;; for union/find the following attributes are necessary: rank, parent
736 ;; (see Tarjan, "Data structures and network algorithms", 1983)
737 ;; In the Scheme realization an element is represented as a single
738 ;; cons cell; its address is the element itself; the car field contains
739 ;; the parent, the cdr field is an address for a cons
740 ;; cell containing the rank (car field) and the information (cdr field)
743 ;; general union/find data structure
745 ;; gen-element: Info -> Elem
746 ;; find: Elem -> Elem
747 ;; link: Elem! x Elem! -> Elem
748 ;; asymm-link: Elem! x Elem! -> Elem
749 ;; info: Elem -> Info
750 ;; set-info!: Elem! x Info -> Void
753 (define (gen-element info)
754 ; generates a new element: the parent field is initialized to '(),
755 ; the rank field to 0
756 (cons '() (cons 0 info)))
758 (define info (lambda (l) (cddr l)))
759 ; returns the information stored in an element
761 (define (set-info! elem info)
762 ; sets the info-field of elem to info
763 (set-cdr! (cdr elem) info))
766 ; ; finds the class representative of x and sets the parent field
767 ; ; directly to the class representative (a class representative has
768 ; ; '() as its parent) (uses path halving)
769 ; ;(display "Find!: ")
770 ; ;(display (pretty-print (info x)))
772 ; (let ((px (car x)))
775 ; (let ((ppx (car px)))
783 ; finds the class representative of elem and sets the parent field
784 ; directly to the class representative (a class representative has
787 ;(display (pretty-print (info elem)))
789 (let ((p-elem (car elem)))
792 (let ((rep-elem (find! p-elem)))
793 (set-car! elem rep-elem)
796 (define (link! elem-1 elem-2)
797 ; links class elements by rank
798 ; they must be distinct class representatives
799 ; returns the class representative of the merged equivalence classes
801 ;(display (pretty-print (list (info elem-1) (info elem-2))))
803 (let ((rank-1 (cadr elem-1))
804 (rank-2 (cadr elem-2)))
807 (set-car! (cdr elem-2) (+ rank-2 1))
808 (set-car! elem-1 elem-2)
811 (set-car! elem-2 elem-1)
814 (set-car! elem-1 elem-2)
817 (define asymm-link! (lambda (l x) (set-car! l x)))
819 ;(define (asymm-link! elem-1 elem-2)
820 ; links elem-1 onto elem-2 no matter what rank;
821 ; does not update the rank of elem-2 and does not return a value
822 ; the two arguments must be distinct
823 ;(display "AsymmLink: ")
824 ;(display (pretty-print (list (info elem-1) (info elem-2))))
826 ;(set-car! elem-1 elem-2))
828 ;----------------------------------------------------------------------------
830 ;----------------------------------------------------------------------------
832 ; introduces type variables and types for Scheme,
835 ;; type TVar (type variables)
837 ;; gen-tvar: () -> TVar
838 ;; gen-type: TCon x TVar* -> TVar
840 ;; tvar-id: TVar -> Symbol
841 ;; tvar-def: TVar -> Type + Null
842 ;; tvar-show: TVar -> Symbol*
844 ;; set-def!: !TVar x TCon x TVar* -> Null
845 ;; equiv!: !TVar x !TVar -> Null
848 ;; type TCon (type constructors)
854 ;; gen-type: TCon x TVar* -> Type
855 ;; type-con: Type -> TCon
856 ;; type-args: Type -> TVar*
861 ;; pair: TVar x TVar -> TVar
862 ;; procedure: TVar x TVar* -> TVar
865 ;; array: TVar -> TVar
868 ; Needed packages: union/find
870 ;(load "union-fi.so")
875 ; counter for generating tvar id's
878 ; generates a new id (for printing purposes)
879 (set! counter (+ counter 1))
883 ; generates a new type variable from a new symbol
884 ; uses union/find elements with two info fields
885 ; a type variable has exactly four fields:
886 ; car: TVar (the parent field; initially null)
887 ; cadr: Number (the rank field; is always nonnegative)
888 ; caddr: Symbol (the type variable identifier; used only for printing)
889 ; cdddr: Type (the leq field; initially null)
890 (gen-element (cons (gen-id) '())))
892 (define (gen-type tcon targs)
893 ; generates a new type variable with an associated type definition
894 (gen-element (cons (gen-id) (cons tcon targs))))
896 (define dynamic (gen-element (cons 0 '())))
897 ; the special type variable dynamic
900 (define (tvar-id tvar)
901 ; returns the (printable) symbol representing the type variable
904 (define (tvar-def tvar)
905 ; returns the type definition (if any) of the type variable
908 (define (set-def! tvar tcon targs)
909 ; sets the type definition part of tvar to type
910 (set-cdr! (info tvar) (cons tcon targs))
913 (define (reset-def! tvar)
914 ; resets the type definition part of tvar to nil
915 (set-cdr! (info tvar) '()))
917 (define type-con (lambda (l) (car l)))
918 ; returns the type constructor of a type definition
920 (define type-args (lambda (l) (cdr l)))
921 ; returns the type variables of a type definition
923 (define (tvar->string tvar)
924 ; converts a tvar's id to a string
925 (if (eqv? (tvar-id tvar) 0)
927 (string-append "t#" (number->string (tvar-id tvar) 10))))
929 (define (tvar-show tv)
930 ; returns a printable list representation of type variable tv
931 (let* ((tv-rep (find! tv))
932 (tv-def (tvar-def tv-rep)))
933 (cons (tvar->string tv-rep)
936 (cons 'is (type-show tv-def))))))
938 (define (type-show type)
939 ; returns a printable list representation of type definition type
941 ((eqv? (type-con type) ptype-con)
942 (let ((new-tvar (gen-tvar)))
944 (cons (tvar-show new-tvar)
945 (tvar-show ((type-args type) new-tvar))))))
947 (cons (type-con type)
949 (tvar->string (find! tv)))
950 (type-args type))))))
954 ; Special type operations
956 ; type constructor literals
958 (define boolean-con 'boolean)
959 (define char-con 'char)
960 (define null-con 'null)
961 (define number-con 'number)
962 (define pair-con 'pair)
963 (define procedure-con 'procedure)
964 (define string-con 'string)
965 (define symbol-con 'symbol)
966 (define vector-con 'vector)
968 ; type constants and type constructors
971 ; ***Note***: Temporarily changed to be a pair!
972 ; (gen-type null-con '())
973 (pair (gen-tvar) (gen-tvar)))
975 (gen-type boolean-con '()))
977 (gen-type char-con '()))
979 (gen-type number-con '()))
981 (gen-type string-con '()))
983 (gen-type symbol-con '()))
984 (define (pair tvar-1 tvar-2)
985 (gen-type pair-con (list tvar-1 tvar-2)))
987 (gen-type vector-con (list tvar)))
988 (define (procedure arg-tvar res-tvar)
989 (gen-type procedure-con (list arg-tvar res-tvar)))
992 ; equivalencing of type variables
994 (define (equiv! tv1 tv2)
995 (let* ((tv1-rep (find! tv1))
996 (tv2-rep (find! tv2))
997 (tv1-def (tvar-def tv1-rep))
998 (tv2-def (tvar-def tv2-rep)))
1000 ((eqv? tv1-rep tv2-rep)
1002 ((eqv? tv2-rep dynamic)
1003 (equiv-with-dynamic! tv1-rep))
1004 ((eqv? tv1-rep dynamic)
1005 (equiv-with-dynamic! tv2-rep))
1008 ; both tv1 and tv2 are distinct type variables
1009 (link! tv1-rep tv2-rep)
1010 ; tv1 is a type variable, tv2 is a (nondynamic) type
1011 (asymm-link! tv1-rep tv2-rep)))
1013 ; tv1 is a (nondynamic) type, tv2 is a type variable
1014 (asymm-link! tv2-rep tv1-rep))
1015 ((eqv? (type-con tv1-def) (type-con tv2-def))
1016 ; both tv1 and tv2 are (nondynamic) types with equal numbers of
1018 (link! tv1-rep tv2-rep)
1019 (map equiv! (type-args tv1-def) (type-args tv2-def)))
1021 ; tv1 and tv2 are types with distinct type constructors or different
1022 ; numbers of arguments
1023 (equiv-with-dynamic! tv1-rep)
1024 (equiv-with-dynamic! tv2-rep))))
1027 (define (equiv-with-dynamic! tv)
1028 (let ((tv-rep (find! tv)))
1029 (if (not (eqv? tv-rep dynamic))
1030 (let ((tv-def (tvar-def tv-rep)))
1031 (asymm-link! tv-rep dynamic)
1032 (if (not (null? tv-def))
1033 (map equiv-with-dynamic! (type-args tv-def))))))
1035 ;----------------------------------------------------------------------------
1036 ; Polymorphic type management
1037 ;----------------------------------------------------------------------------
1039 ; introduces parametric polymorphic types
1042 ;; forall: (Tvar -> Tvar) -> TVar
1043 ;; fix: (Tvar -> Tvar) -> Tvar
1045 ;; instantiate-type: TVar -> TVar
1047 ; type constructor literal for polymorphic types
1049 (define ptype-con 'forall)
1051 (define (forall tv-func)
1052 (gen-type ptype-con tv-func))
1054 (define (forall2 tv-func2)
1055 (forall (lambda (tv1)
1056 (forall (lambda (tv2)
1057 (tv-func2 tv1 tv2))))))
1059 (define (forall3 tv-func3)
1060 (forall (lambda (tv1)
1061 (forall2 (lambda (tv2 tv3)
1062 (tv-func3 tv1 tv2 tv3))))))
1064 (define (forall4 tv-func4)
1065 (forall (lambda (tv1)
1066 (forall3 (lambda (tv2 tv3 tv4)
1067 (tv-func4 tv1 tv2 tv3 tv4))))))
1069 (define (forall5 tv-func5)
1070 (forall (lambda (tv1)
1071 (forall4 (lambda (tv2 tv3 tv4 tv5)
1072 (tv-func5 tv1 tv2 tv3 tv4 tv5))))))
1075 ; (polymorphic) instantiation
1077 (define (instantiate-type tv)
1078 ; instantiates type tv and returns a generic instance
1079 (let* ((tv-rep (find! tv))
1080 (tv-def (tvar-def tv-rep)))
1084 ((eqv? (type-con tv-def) ptype-con)
1085 (instantiate-type ((type-args tv-def) (gen-tvar))))
1089 (define (fix tv-func)
1090 ; forms a recursive type: the fixed point of type mapping tv-func
1091 (let* ((new-tvar (gen-tvar))
1092 (inst-tvar (tv-func new-tvar))
1093 (inst-def (tvar-def inst-tvar)))
1094 (if (null? inst-def)
1095 (error 'fix "Illegal recursive type: ~s"
1096 (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
1100 (type-args inst-def))
1104 ;----------------------------------------------------------------------------
1105 ; Constraint management
1106 ;----------------------------------------------------------------------------
1111 (define gen-constr (lambda (a b) (cons a b)))
1112 ; generates an equality between tvar1 and tvar2
1114 (define constr-lhs (lambda (c) (car c)))
1115 ; returns the left-hand side of a constraint
1117 (define constr-rhs (lambda (c) (cdr c)))
1118 ; returns the right-hand side of a constraint
1120 (define (constr-show c)
1121 (cons (tvar-show (car c))
1123 (cons (tvar-show (cdr c)) '()))))
1126 ; constraint set management
1128 (define global-constraints '())
1130 (define (init-global-constraints!)
1131 (set! global-constraints '()))
1133 (define (add-constr! lhs rhs)
1134 (set! global-constraints
1135 (cons (gen-constr lhs rhs) global-constraints))
1138 (define (glob-constr-show)
1139 ; returns printable version of global constraints
1140 (map constr-show global-constraints))
1143 ; constraint normalization
1145 ; Needed packages: type management
1147 ;(load "typ-mgmt.so")
1149 (define (normalize-global-constraints!)
1150 (normalize! global-constraints)
1151 (init-global-constraints!))
1153 (define (normalize! constraints)
1155 (equiv! (constr-lhs c) (constr-rhs c))) constraints))
1156 ; ----------------------------------------------------------------------------
1157 ; Abstract syntax definition and parse actions
1158 ; ----------------------------------------------------------------------------
1160 ; Needed packages: ast-gen.ss
1161 ;(load "ast-gen.ss")
1167 ;; Identifier = Symbol - SyntacticKeywords
1168 ;; SyntacticKeywords = { ... } (see Section 7.1, IEEE Scheme Standard)
1172 ;; null-const: Null -> Datum
1173 ;; boolean-const: Bool -> Datum
1174 ;; char-const: Char -> Datum
1175 ;; number-const: Number -> Datum
1176 ;; string-const: String -> Datum
1177 ;; vector-const: Datum* -> Datum
1178 ;; pair-const: Datum x Datum -> Datum
1184 ;; var-def: Identifier -> VarDef
1185 ;; variable: VarDef -> Expr
1186 ;; identifier: Identifier -> Expr
1187 ;; procedure-call: Expr x Expr* -> Expr
1188 ;; lambda-expression: Formals x Body -> Expr
1189 ;; conditional: Expr x Expr x Expr -> Expr
1190 ;; assignment: Variable x Expr -> Expr
1191 ;; cond-expression: CondClause+ -> Expr
1192 ;; case-expression: Expr x CaseClause* -> Expr
1193 ;; and-expression: Expr* -> Expr
1194 ;; or-expression: Expr* -> Expr
1195 ;; let-expression: (VarDef* x Expr*) x Body -> Expr
1196 ;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr
1197 ;; let*-expression: (VarDef* x Expr*) x Body -> Expr
1198 ;; letrec-expression: (VarDef* x Expr*) x Body -> Expr
1199 ;; begin-expression: Expr+ -> Expr
1200 ;; do-expression: IterDef* x CondClause x Expr* -> Expr
1203 ;; VarDef* < Formals
1205 ;; simple-formal: VarDef -> Formals
1206 ;; dotted-formals: VarDef* x VarDef -> Formals
1208 ;; Body = Definition* x Expr+ (reversed)
1209 ;; CondClause = Expr x Expr+
1210 ;; CaseClause = Datum* x Expr+
1211 ;; IterDef = VarDef x Expr x Expr
1215 ;; definition: Identifier x Expr -> Definition
1216 ;; function-definition: Identifier x Formals x Body -> Definition
1217 ;; begin-command: Definition* -> Definition
1220 ;; Definition < Command
1222 ;; Program = Command*
1225 ;; Abstract syntax operators
1229 (define null-const 0)
1230 (define boolean-const 1)
1231 (define char-const 2)
1232 (define number-const 3)
1233 (define string-const 4)
1234 (define symbol-const 5)
1235 (define vector-const 6)
1236 (define pair-const 7)
1241 (define null-def 29)
1242 (define pair-def 30)
1247 (define identifier 10)
1248 (define procedure-call 11)
1249 (define lambda-expression 12)
1250 (define conditional 13)
1251 (define assignment 14)
1252 (define cond-expression 15)
1253 (define case-expression 16)
1254 (define and-expression 17)
1255 (define or-expression 18)
1256 (define let-expression 19)
1257 (define named-let-expression 20)
1258 (define let*-expression 21)
1259 (define letrec-expression 22)
1260 (define begin-expression 23)
1261 (define do-expression 24)
1263 (define null-arg 31)
1264 (define pair-arg 32)
1268 (define definition 26)
1269 (define function-definition 27)
1270 (define begin-command 28)
1273 ;; Parse actions for abstract syntax construction
1275 (define (dynamic-parse-action-null-const)
1276 ;; dynamic-parse-action for '()
1277 (ast-gen null-const '()))
1279 (define (dynamic-parse-action-boolean-const e)
1280 ;; dynamic-parse-action for #f and #t
1281 (ast-gen boolean-const e))
1283 (define (dynamic-parse-action-char-const e)
1284 ;; dynamic-parse-action for character constants
1285 (ast-gen char-const e))
1287 (define (dynamic-parse-action-number-const e)
1288 ;; dynamic-parse-action for number constants
1289 (ast-gen number-const e))
1291 (define (dynamic-parse-action-string-const e)
1292 ;; dynamic-parse-action for string literals
1293 (ast-gen string-const e))
1295 (define (dynamic-parse-action-symbol-const e)
1296 ;; dynamic-parse-action for symbol constants
1297 (ast-gen symbol-const e))
1299 (define (dynamic-parse-action-vector-const e)
1300 ;; dynamic-parse-action for vector literals
1301 (ast-gen vector-const e))
1303 (define (dynamic-parse-action-pair-const e1 e2)
1304 ;; dynamic-parse-action for pairs
1305 (ast-gen pair-const (cons e1 e2)))
1307 (define (dynamic-parse-action-var-def e)
1308 ;; dynamic-parse-action for defining occurrences of variables;
1310 (ast-gen var-def e))
1312 (define (dynamic-parse-action-null-formal)
1313 ;; dynamic-parse-action for null-list of formals
1314 (ast-gen null-def '()))
1316 (define (dynamic-parse-action-pair-formal d1 d2)
1317 ;; dynamic-parse-action for non-null list of formals;
1318 ;; d1 is the result of parsing the first formal,
1319 ;; d2 the result of parsing the remaining formals
1320 (ast-gen pair-def (cons d1 d2)))
1322 (define (dynamic-parse-action-variable e)
1323 ;; dynamic-parse-action for applied occurrences of variables
1324 ;; ***Note***: e is the result of a dynamic-parse-action on the
1325 ;; corresponding variable definition!
1326 (ast-gen variable e))
1328 (define (dynamic-parse-action-identifier e)
1329 ;; dynamic-parse-action for undeclared identifiers (free variable
1331 ;; ***Note***: e is a symbol (legal identifier)
1332 (ast-gen identifier e))
1334 (define (dynamic-parse-action-null-arg)
1335 ;; dynamic-parse-action for a null list of arguments in a procedure call
1336 (ast-gen null-arg '()))
1338 (define (dynamic-parse-action-pair-arg a1 a2)
1339 ;; dynamic-parse-action for a non-null list of arguments in a procedure call
1340 ;; a1 is the result of parsing the first argument,
1341 ;; a2 the result of parsing the remaining arguments
1342 (ast-gen pair-arg (cons a1 a2)))
1344 (define (dynamic-parse-action-procedure-call op args)
1345 ;; dynamic-parse-action for procedure calls: op function, args list of arguments
1346 (ast-gen procedure-call (cons op args)))
1348 (define (dynamic-parse-action-lambda-expression formals body)
1349 ;; dynamic-parse-action for lambda-abstractions
1350 (ast-gen lambda-expression (cons formals body)))
1352 (define (dynamic-parse-action-conditional test then-branch else-branch)
1353 ;; dynamic-parse-action for conditionals (if-then-else expressions)
1354 (ast-gen conditional (cons test (cons then-branch else-branch))))
1356 (define (dynamic-parse-action-empty)
1357 ;; dynamic-parse-action for missing or empty field
1358 (ast-gen empty '()))
1360 (define (dynamic-parse-action-assignment lhs rhs)
1361 ;; dynamic-parse-action for assignment
1362 (ast-gen assignment (cons lhs rhs)))
1364 (define (dynamic-parse-action-begin-expression body)
1365 ;; dynamic-parse-action for begin-expression
1366 (ast-gen begin-expression body))
1368 (define (dynamic-parse-action-cond-expression clauses)
1369 ;; dynamic-parse-action for cond-expressions
1370 (ast-gen cond-expression clauses))
1372 (define (dynamic-parse-action-and-expression args)
1373 ;; dynamic-parse-action for and-expressions
1374 (ast-gen and-expression args))
1376 (define (dynamic-parse-action-or-expression args)
1377 ;; dynamic-parse-action for or-expressions
1378 (ast-gen or-expression args))
1380 (define (dynamic-parse-action-case-expression key clauses)
1381 ;; dynamic-parse-action for case-expressions
1382 (ast-gen case-expression (cons key clauses)))
1384 (define (dynamic-parse-action-let-expression bindings body)
1385 ;; dynamic-parse-action for let-expressions
1386 (ast-gen let-expression (cons bindings body)))
1388 (define (dynamic-parse-action-named-let-expression variable bindings body)
1389 ;; dynamic-parse-action for named-let expressions
1390 (ast-gen named-let-expression (cons variable (cons bindings body))))
1392 (define (dynamic-parse-action-let*-expression bindings body)
1393 ;; dynamic-parse-action for let-expressions
1394 (ast-gen let*-expression (cons bindings body)))
1396 (define (dynamic-parse-action-letrec-expression bindings body)
1397 ;; dynamic-parse-action for let-expressions
1398 (ast-gen letrec-expression (cons bindings body)))
1400 (define (dynamic-parse-action-definition variable expr)
1401 ;; dynamic-parse-action for simple definitions
1402 (ast-gen definition (cons variable expr)))
1404 (define (dynamic-parse-action-function-definition variable formals body)
1405 ;; dynamic-parse-action for function definitions
1406 (ast-gen function-definition (cons variable (cons formals body))))
1409 (define dynamic-parse-action-commands (lambda (a b) (cons a b)))
1410 ;; dynamic-parse-action for processing a command result followed by a the
1411 ;; result of processing the remaining commands
1414 ;; Pretty-printing abstract syntax trees
1416 (define (ast-show ast)
1417 ;; converts abstract syntax tree to list representation (Scheme program)
1418 ;; ***Note***: check translation of constructors to numbers at the top of the file
1419 (let ((syntax-op (ast-con ast))
1420 (syntax-arg (ast-arg ast)))
1422 ((0 1 2 3 4 8 10) syntax-arg)
1424 ((30 32) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
1425 ((5) (list 'quote syntax-arg))
1426 ((6) (list->vector (map ast-show syntax-arg)))
1427 ((7) (list 'cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
1428 ((9) (ast-arg syntax-arg))
1429 ((11) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
1430 ((12) (cons 'lambda (cons (ast-show (car syntax-arg))
1431 (map ast-show (cdr syntax-arg)))))
1432 ((13) (cons 'if (cons (ast-show (car syntax-arg))
1433 (cons (ast-show (cadr syntax-arg))
1434 (let ((alt (cddr syntax-arg)))
1435 (if (eqv? (ast-con alt) empty)
1437 (list (ast-show alt))))))))
1438 ((14) (list 'set! (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
1441 (let ((guard (car cc))
1444 (if (eqv? (ast-con guard) empty)
1447 (map ast-show body))))
1450 (cons (ast-show (car syntax-arg))
1452 (let ((data (car cc)))
1453 (if (and (pair? data)
1454 (eqv? (ast-con (car data)) empty))
1456 (map ast-show (cdr cc)))
1457 (cons (map datum-show data)
1458 (map ast-show (cdr cc))))))
1459 (cdr syntax-arg)))))
1460 ((17) (cons 'and (map ast-show syntax-arg)))
1461 ((18) (cons 'or (map ast-show syntax-arg)))
1465 (list (ast-show vd) (ast-show e)))
1468 (map ast-show (cdr syntax-arg)))))
1470 (cons (ast-show (car syntax-arg))
1473 (list (ast-show vd) (ast-show e)))
1476 (map ast-show (cddr syntax-arg))))))
1480 (list (ast-show vd) (ast-show e)))
1483 (map ast-show (cdr syntax-arg)))))
1487 (list (ast-show vd) (ast-show e)))
1490 (map ast-show (cdr syntax-arg)))))
1492 (map ast-show syntax-arg)))
1493 ((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
1494 ((25) (error 'ast-show "This can't happen: empty encountered!"))
1496 (ast-show (car syntax-arg))
1497 (ast-show (cdr syntax-arg))))
1500 (cons (ast-show (car syntax-arg))
1501 (ast-show (cadr syntax-arg)))
1502 (map ast-show (cddr syntax-arg)))))
1504 (map ast-show syntax-arg)))
1505 (else (error 'ast-show "Unknown abstract syntax operator: ~s"
1511 (define (ast*-show p)
1512 ;; shows a list of abstract syntax trees
1518 (define (datum-show ast)
1519 ;; prints an abstract syntax tree as a datum
1521 ((0 1 2 3 4 5) (ast-arg ast))
1522 ((6) (list->vector (map datum-show (ast-arg ast))))
1523 ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
1524 (else (error 'datum-show "This should not happen!"))))
1528 (define (write-to-port prog port)
1529 ; writes a program to a port
1532 (pretty-print command port)
1539 (define (write-to-file prog filename)
1540 ; write a program to a file
1541 (let ((port (open-output-file filename)))
1542 (write-to-port prog port)
1543 (close-output-port port)
1546 ; ----------------------------------------------------------------------------
1547 ; Typed abstract syntax tree management: constraint generation, display, etc.
1548 ; ----------------------------------------------------------------------------
1551 ;; Abstract syntax operations, incl. constraint generation
1553 (define (ast-gen syntax-op arg)
1554 ; generates all attributes and performs semantic side effects
1563 ((6) (let ((aux-tvar (gen-tvar)))
1564 (for-each (lambda (t)
1565 (add-constr! t aux-tvar))
1568 ((7 30 32) (let ((t1 (ast-tvar (car arg)))
1569 (t2 (ast-tvar (cdr arg))))
1572 ((9) (ast-tvar arg))
1573 ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env)))
1575 (instantiate-type (binding-value in-env))
1576 (let ((new-tvar (gen-tvar)))
1577 (set! dynamic-top-level-env (extend-env-with-binding
1578 dynamic-top-level-env
1579 (gen-binding arg new-tvar)))
1581 ((11) (let ((new-tvar (gen-tvar)))
1582 (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar)
1583 (ast-tvar (car arg)))
1585 ((12) (procedure (ast-tvar (car arg))
1586 (ast-tvar (tail (cdr arg)))))
1587 ((13) (let ((t-test (ast-tvar (car arg)))
1588 (t-consequent (ast-tvar (cadr arg)))
1589 (t-alternate (ast-tvar (cddr arg))))
1590 (add-constr! (boolean) t-test)
1591 (add-constr! t-consequent t-alternate)
1593 ((14) (let ((var-tvar (ast-tvar (car arg)))
1594 (exp-tvar (ast-tvar (cdr arg))))
1595 (add-constr! var-tvar exp-tvar)
1597 ((15) (let ((new-tvar (gen-tvar)))
1598 (for-each (lambda (body)
1599 (add-constr! (ast-tvar (tail body)) new-tvar))
1601 (for-each (lambda (e)
1602 (add-constr! (boolean) (ast-tvar e)))
1605 ((16) (let* ((new-tvar (gen-tvar))
1606 (t-key (ast-tvar (car arg)))
1607 (case-clauses (cdr arg)))
1608 (for-each (lambda (exprs)
1609 (for-each (lambda (e)
1610 (add-constr! (ast-tvar e) t-key))
1612 (map car case-clauses))
1613 (for-each (lambda (body)
1614 (add-constr! (ast-tvar (tail body)) new-tvar))
1615 (map cdr case-clauses))
1617 ((17 18) (for-each (lambda (e)
1618 (add-constr! (boolean) (ast-tvar e)))
1621 ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg)))
1622 (def-expr-types (map ast-tvar (cdar arg)))
1623 (body-type (ast-tvar (tail (cdr arg)))))
1624 (for-each add-constr! var-def-tvars def-expr-types)
1626 ((20) (let ((var-def-tvars (map ast-tvar (caadr arg)))
1627 (def-expr-types (map ast-tvar (cdadr arg)))
1628 (body-type (ast-tvar (tail (cddr arg))))
1629 (named-var-type (ast-tvar (car arg))))
1630 (for-each add-constr! var-def-tvars def-expr-types)
1631 (add-constr! (procedure (convert-tvars var-def-tvars) body-type)
1634 ((23) (ast-tvar (tail arg)))
1635 ((24) (error 'ast-gen
1636 "Do-expressions not handled! (Argument: ~s) arg"))
1638 ((26) (let ((t-var (ast-tvar (car arg)))
1639 (t-exp (ast-tvar (cdr arg))))
1640 (add-constr! t-var t-exp)
1642 ((27) (let ((t-var (ast-tvar (car arg)))
1643 (t-formals (ast-tvar (cadr arg)))
1644 (t-body (ast-tvar (tail (cddr arg)))))
1645 (add-constr! (procedure t-formals t-body) t-var)
1648 (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op)))))
1649 (cons syntax-op (cons ntvar arg))))
1651 (define ast-con car)
1652 ;; extracts the ast-constructor from an abstract syntax tree
1654 (define ast-arg cddr)
1655 ;; extracts the ast-argument from an abstract syntax tree
1657 (define ast-tvar cadr)
1658 ;; extracts the tvar from an abstract syntax tree
1664 ;; returns the tail of a nonempty list
1671 (define (convert-tvars tvar-list)
1672 ;; converts a list of tvars to a single tvar
1674 ((null? tvar-list) (null))
1675 ((pair? tvar-list) (pair (car tvar-list)
1676 (convert-tvars (cdr tvar-list))))
1677 (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list))))
1680 ;; Pretty-printing abstract syntax trees
1682 (define (tast-show ast)
1683 ;; converts abstract syntax tree to list representation (Scheme program)
1684 (let ((syntax-op (ast-con ast))
1685 (syntax-tvar (tvar-show (ast-tvar ast)))
1686 (syntax-arg (ast-arg ast)))
1689 ((0 1 2 3 4 8 10) syntax-arg)
1691 ((30 32) (cons (tast-show (car syntax-arg))
1692 (tast-show (cdr syntax-arg))))
1693 ((5) (list 'quote syntax-arg))
1694 ((6) (list->vector (map tast-show syntax-arg)))
1695 ((7) (list 'cons (tast-show (car syntax-arg))
1696 (tast-show (cdr syntax-arg))))
1697 ((9) (ast-arg syntax-arg))
1698 ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg))))
1699 ((12) (cons 'lambda (cons (tast-show (car syntax-arg))
1700 (map tast-show (cdr syntax-arg)))))
1701 ((13) (cons 'if (cons (tast-show (car syntax-arg))
1702 (cons (tast-show (cadr syntax-arg))
1703 (let ((alt (cddr syntax-arg)))
1704 (if (eqv? (ast-con alt) empty)
1706 (list (tast-show alt))))))))
1707 ((14) (list 'set! (tast-show (car syntax-arg))
1708 (tast-show (cdr syntax-arg))))
1711 (let ((guard (car cc))
1714 (if (eqv? (ast-con guard) empty)
1717 (map tast-show body))))
1720 (cons (tast-show (car syntax-arg))
1722 (let ((data (car cc)))
1723 (if (and (pair? data)
1724 (eqv? (ast-con (car data)) empty))
1726 (map tast-show (cdr cc)))
1727 (cons (map datum-show data)
1728 (map tast-show (cdr cc))))))
1729 (cdr syntax-arg)))))
1730 ((17) (cons 'and (map tast-show syntax-arg)))
1731 ((18) (cons 'or (map tast-show syntax-arg)))
1735 (list (tast-show vd) (tast-show e)))
1738 (map tast-show (cdr syntax-arg)))))
1740 (cons (tast-show (car syntax-arg))
1743 (list (tast-show vd) (tast-show e)))
1746 (map tast-show (cddr syntax-arg))))))
1750 (list (tast-show vd) (tast-show e)))
1753 (map tast-show (cdr syntax-arg)))))
1757 (list (tast-show vd) (tast-show e)))
1760 (map tast-show (cdr syntax-arg)))))
1762 (map tast-show syntax-arg)))
1763 ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
1764 ((25) (error 'tast-show "This can't happen: empty encountered!"))
1766 (tast-show (car syntax-arg))
1767 (tast-show (cdr syntax-arg))))
1770 (cons (tast-show (car syntax-arg))
1771 (tast-show (cadr syntax-arg)))
1772 (map tast-show (cddr syntax-arg)))))
1774 (map tast-show syntax-arg)))
1775 (else (error 'tast-show "Unknown abstract syntax operator: ~s"
1781 (define (tast*-show p)
1782 ;; shows a list of abstract syntax trees
1786 ;; counters for tagging/untagging
1788 (define untag-counter 0)
1789 (define no-untag-counter 0)
1790 (define tag-counter 0)
1791 (define no-tag-counter 0)
1792 (define may-untag-counter 0)
1793 (define no-may-untag-counter 0)
1795 (define (reset-counters!)
1796 (set! untag-counter 0)
1797 (set! no-untag-counter 0)
1798 (set! tag-counter 0)
1799 (set! no-tag-counter 0)
1800 (set! may-untag-counter 0)
1801 (set! no-may-untag-counter 0))
1803 (define (counters-show)
1805 (cons tag-counter no-tag-counter)
1806 (cons untag-counter no-untag-counter)
1807 (cons may-untag-counter no-may-untag-counter)))
1812 (define (tag-show tvar-rep prog)
1813 ; display prog with tagging operation
1814 (if (eqv? tvar-rep dynamic)
1816 (set! tag-counter (+ tag-counter 1))
1819 (set! no-tag-counter (+ no-tag-counter 1))
1820 (list 'no-tag prog))))
1825 (define (untag-show tvar-rep prog)
1826 ; display prog with untagging operation
1827 (if (eqv? tvar-rep dynamic)
1829 (set! untag-counter (+ untag-counter 1))
1832 (set! no-untag-counter (+ no-untag-counter 1))
1833 (list 'no-untag prog))))
1835 (define (may-untag-show tvar-rep prog)
1836 ; display possible untagging in actual arguments
1837 (if (eqv? tvar-rep dynamic)
1839 (set! may-untag-counter (+ may-untag-counter 1))
1840 (list 'may-untag prog))
1842 (set! no-may-untag-counter (+ no-may-untag-counter 1))
1843 (list 'no-may-untag prog))))
1848 (define (tag-ast-show ast)
1849 ;; converts typed and normalized abstract syntax tree to
1850 ;; a Scheme program with explicit tagging and untagging operations
1851 (let ((syntax-op (ast-con ast))
1852 (syntax-tvar (find! (ast-tvar ast)))
1853 (syntax-arg (ast-arg ast)))
1856 (tag-show syntax-tvar syntax-arg))
1859 ((30) (cons (tag-ast-show (car syntax-arg))
1860 (tag-ast-show (cdr syntax-arg))))
1861 ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg)))
1862 (tag-ast-show (car syntax-arg)))
1863 (tag-ast-show (cdr syntax-arg))))
1864 ((5) (tag-show syntax-tvar (list 'quote syntax-arg)))
1865 ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg))))
1866 ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg))
1867 (tag-ast-show (cdr syntax-arg)))))
1868 ((9) (ast-arg syntax-arg))
1869 ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg)))))
1870 (cons (untag-show proc-tvar
1871 (tag-ast-show (car syntax-arg)))
1872 (tag-ast-show (cdr syntax-arg)))))
1873 ((12) (tag-show syntax-tvar
1874 (cons 'lambda (cons (tag-ast-show (car syntax-arg))
1875 (map tag-ast-show (cdr syntax-arg))))))
1876 ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg)))))
1877 (cons 'if (cons (untag-show test-tvar
1878 (tag-ast-show (car syntax-arg)))
1879 (cons (tag-ast-show (cadr syntax-arg))
1880 (let ((alt (cddr syntax-arg)))
1881 (if (eqv? (ast-con alt) empty)
1883 (list (tag-ast-show alt)))))))))
1884 ((14) (list 'set! (tag-ast-show (car syntax-arg))
1885 (tag-ast-show (cdr syntax-arg))))
1888 (let ((guard (car cc))
1891 (if (eqv? (ast-con guard) empty)
1893 (untag-show (find! (ast-tvar guard))
1894 (tag-ast-show guard)))
1895 (map tag-ast-show body))))
1898 (cons (tag-ast-show (car syntax-arg))
1900 (let ((data (car cc)))
1901 (if (and (pair? data)
1902 (eqv? (ast-con (car data)) empty))
1904 (map tag-ast-show (cdr cc)))
1905 (cons (map datum-show data)
1906 (map tag-ast-show (cdr cc))))))
1907 (cdr syntax-arg)))))
1908 ((17) (cons 'and (map
1910 (let ((bool-tvar (find! (ast-tvar ast))))
1911 (untag-show bool-tvar (tag-ast-show ast))))
1913 ((18) (cons 'or (map
1915 (let ((bool-tvar (find! (ast-tvar ast))))
1916 (untag-show bool-tvar (tag-ast-show ast))))
1921 (list (tag-ast-show vd) (tag-ast-show e)))
1924 (map tag-ast-show (cdr syntax-arg)))))
1926 (cons (tag-ast-show (car syntax-arg))
1929 (list (tag-ast-show vd) (tag-ast-show e)))
1932 (map tag-ast-show (cddr syntax-arg))))))
1936 (list (tag-ast-show vd) (tag-ast-show e)))
1939 (map tag-ast-show (cdr syntax-arg)))))
1943 (list (tag-ast-show vd) (tag-ast-show e)))
1946 (map tag-ast-show (cdr syntax-arg)))))
1948 (map tag-ast-show syntax-arg)))
1949 ((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
1950 ((25) (error 'tag-ast-show "This can't happen: empty encountered!"))
1952 (tag-ast-show (car syntax-arg))
1953 (tag-ast-show (cdr syntax-arg))))
1954 ((27) (let ((func-tvar (find! (ast-tvar (car syntax-arg)))))
1956 (tag-ast-show (car syntax-arg))
1959 (cons (tag-ast-show (cadr syntax-arg))
1960 (map tag-ast-show (cddr syntax-arg))))))))
1962 (map tag-ast-show syntax-arg)))
1963 (else (error 'tag-ast-show "Unknown abstract syntax operator: ~s"
1969 (define (tag-ast*-show p)
1970 ; display list of commands/expressions with tagging/untagging
1972 (map tag-ast-show p))
1973 ; ----------------------------------------------------------------------------
1974 ; Top level type environment
1975 ; ----------------------------------------------------------------------------
1978 ; Needed packages: type management (monomorphic and polymorphic)
1980 ;(load "typ-mgmt.ss")
1981 ;(load "ptyp-mgm.ss")
1984 ; type environment for miscellaneous
1988 (cons 'quote (forall (lambda (tv) tv)))
1989 (cons 'eqv? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
1991 (cons 'eq? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
1993 (cons 'equal? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
1997 ; type environment for input/output
2001 (cons 'open-input-file (procedure (convert-tvars (list (charseq))) dynamic))
2002 (cons 'eof-object? (procedure (convert-tvars (list dynamic)) (boolean)))
2003 (cons 'read (forall (lambda (tv)
2004 (procedure (convert-tvars (list tv)) dynamic))))
2005 (cons 'write (forall (lambda (tv)
2006 (procedure (convert-tvars (list tv)) dynamic))))
2007 (cons 'display (forall (lambda (tv)
2008 (procedure (convert-tvars (list tv)) dynamic))))
2009 (cons 'newline (procedure (null) dynamic))
2010 (cons 'pretty-print (forall (lambda (tv)
2011 (procedure (convert-tvars (list tv)) dynamic))))))
2014 ; type environment for Booleans
2018 (cons 'boolean? (forall (lambda (tv)
2019 (procedure (convert-tvars (list tv)) (boolean)))))
2020 ;(cons #f (boolean))
2021 ; #f doesn't exist in Chez Scheme, but gets mapped to null!
2023 (cons 'not (procedure (convert-tvars (list (boolean))) (boolean)))
2027 ; type environment for pairs and lists
2029 (define (list-type tv)
2030 (fix (lambda (tv2) (pair tv tv2))))
2034 (cons 'pair? (forall2 (lambda (tv1 tv2)
2035 (procedure (convert-tvars (list (pair tv1 tv2)))
2037 (cons 'null? (forall2 (lambda (tv1 tv2)
2038 (procedure (convert-tvars (list (pair tv1 tv2)))
2040 (cons 'list? (forall2 (lambda (tv1 tv2)
2041 (procedure (convert-tvars (list (pair tv1 tv2)))
2043 (cons 'cons (forall2 (lambda (tv1 tv2)
2044 (procedure (convert-tvars (list tv1 tv2))
2046 (cons 'car (forall2 (lambda (tv1 tv2)
2047 (procedure (convert-tvars (list (pair tv1 tv2)))
2049 (cons 'cdr (forall2 (lambda (tv1 tv2)
2050 (procedure (convert-tvars (list (pair tv1 tv2)))
2052 (cons 'set-car! (forall2 (lambda (tv1 tv2)
2053 (procedure (convert-tvars (list (pair tv1 tv2)
2056 (cons 'set-cdr! (forall2 (lambda (tv1 tv2)
2057 (procedure (convert-tvars (list (pair tv1 tv2)
2060 (cons 'caar (forall3 (lambda (tv1 tv2 tv3)
2061 (procedure (convert-tvars
2062 (list (pair (pair tv1 tv2) tv3)))
2064 (cons 'cdar (forall3 (lambda (tv1 tv2 tv3)
2065 (procedure (convert-tvars
2066 (list (pair (pair tv1 tv2) tv3)))
2069 (cons 'cadr (forall3 (lambda (tv1 tv2 tv3)
2070 (procedure (convert-tvars
2071 (list (pair tv1 (pair tv2 tv3))))
2073 (cons 'cddr (forall3 (lambda (tv1 tv2 tv3)
2074 (procedure (convert-tvars
2075 (list (pair tv1 (pair tv2 tv3))))
2077 (cons 'caaar (forall4
2078 (lambda (tv1 tv2 tv3 tv4)
2079 (procedure (convert-tvars
2080 (list (pair (pair (pair tv1 tv2) tv3) tv4)))
2082 (cons 'cdaar (forall4
2083 (lambda (tv1 tv2 tv3 tv4)
2084 (procedure (convert-tvars
2085 (list (pair (pair (pair tv1 tv2) tv3) tv4)))
2087 (cons 'cadar (forall4
2088 (lambda (tv1 tv2 tv3 tv4)
2089 (procedure (convert-tvars
2090 (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
2092 (cons 'cddar (forall4
2093 (lambda (tv1 tv2 tv3 tv4)
2094 (procedure (convert-tvars
2095 (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
2097 (cons 'caadr (forall4
2098 (lambda (tv1 tv2 tv3 tv4)
2099 (procedure (convert-tvars
2100 (list (pair tv1 (pair (pair tv2 tv3) tv4))))
2102 (cons 'cdadr (forall4
2103 (lambda (tv1 tv2 tv3 tv4)
2104 (procedure (convert-tvars
2105 (list (pair tv1 (pair (pair tv2 tv3) tv4))))
2107 (cons 'caddr (forall4
2108 (lambda (tv1 tv2 tv3 tv4)
2109 (procedure (convert-tvars
2110 (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
2112 (cons 'cdddr (forall4
2113 (lambda (tv1 tv2 tv3 tv4)
2114 (procedure (convert-tvars
2115 (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
2118 (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
2119 (procedure (convert-tvars
2126 (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
2127 (procedure (convert-tvars
2133 (cons 'list (forall (lambda (tv)
2134 (procedure tv tv))))
2135 (cons 'length (forall (lambda (tv)
2136 (procedure (convert-tvars (list (list-type tv)))
2138 (cons 'append (forall (lambda (tv)
2139 (procedure (convert-tvars (list (list-type tv)
2142 (cons 'reverse (forall (lambda (tv)
2143 (procedure (convert-tvars (list (list-type tv)))
2145 (cons 'list-ref (forall (lambda (tv)
2146 (procedure (convert-tvars (list (list-type tv)
2149 (cons 'memq (forall (lambda (tv)
2150 (procedure (convert-tvars (list tv
2153 (cons 'memv (forall (lambda (tv)
2154 (procedure (convert-tvars (list tv
2157 (cons 'member (forall (lambda (tv)
2158 (procedure (convert-tvars (list tv
2161 (cons 'assq (forall2 (lambda (tv1 tv2)
2162 (procedure (convert-tvars
2164 (list-type (pair tv1 tv2))))
2166 (cons 'assv (forall2 (lambda (tv1 tv2)
2167 (procedure (convert-tvars
2169 (list-type (pair tv1 tv2))))
2171 (cons 'assoc (forall2 (lambda (tv1 tv2)
2172 (procedure (convert-tvars
2174 (list-type (pair tv1 tv2))))
2181 (cons 'symbol? (forall (lambda (tv)
2182 (procedure (convert-tvars (list tv)) (boolean)))))
2183 (cons 'symbol->string (procedure (convert-tvars (list (symbol))) (charseq)))
2184 (cons 'string->symbol (procedure (convert-tvars (list (charseq))) (symbol)))
2189 (cons 'number? (forall (lambda (tv)
2190 (procedure (convert-tvars (list tv)) (boolean)))))
2191 (cons '+ (procedure (convert-tvars (list (number) (number))) (number)))
2192 (cons '- (procedure (convert-tvars (list (number) (number))) (number)))
2193 (cons '* (procedure (convert-tvars (list (number) (number))) (number)))
2194 (cons '/ (procedure (convert-tvars (list (number) (number))) (number)))
2195 (cons 'number->string (procedure (convert-tvars (list (number))) (charseq)))
2196 (cons 'string->number (procedure (convert-tvars (list (charseq))) (number)))
2201 (cons 'char? (forall (lambda (tv)
2202 (procedure (convert-tvars (list tv)) (boolean)))))
2203 (cons 'char->integer (procedure (convert-tvars (list (character)))
2205 (cons 'integer->char (procedure (convert-tvars (list (number)))
2211 (cons 'string? (forall (lambda (tv)
2212 (procedure (convert-tvars (list tv)) (boolean)))))
2217 (cons 'vector? (forall (lambda (tv)
2218 (procedure (convert-tvars (list tv)) (boolean)))))
2219 (cons 'make-vector (forall (lambda (tv)
2220 (procedure (convert-tvars (list (number)))
2222 (cons 'vector-length (forall (lambda (tv)
2223 (procedure (convert-tvars (list (array tv)))
2225 (cons 'vector-ref (forall (lambda (tv)
2226 (procedure (convert-tvars (list (array tv)
2229 (cons 'vector-set! (forall (lambda (tv)
2230 (procedure (convert-tvars (list (array tv)
2236 (define procedure-env
2238 (cons 'procedure? (forall (lambda (tv)
2239 (procedure (convert-tvars (list tv)) (boolean)))))
2240 (cons 'map (forall2 (lambda (tv1 tv2)
2241 (procedure (convert-tvars
2242 (list (procedure (convert-tvars
2246 (cons 'foreach (forall2 (lambda (tv1 tv2)
2247 (procedure (convert-tvars
2248 (list (procedure (convert-tvars
2252 (cons 'call-with-current-continuation
2253 (forall2 (lambda (tv1 tv2)
2254 (procedure (convert-tvars
2257 (list (procedure (convert-tvars
2264 ; global top level environment
2266 (define (global-env)
2278 (define dynamic-top-level-env (global-env))
2280 (define (init-dynamic-top-level-env!)
2281 (set! dynamic-top-level-env (global-env))
2284 (define (dynamic-top-level-env-show)
2285 ; displays the top level environment
2286 (map (lambda (binding)
2287 (cons (key-show (binding-key binding))
2288 (cons ': (tvar-show (binding-value binding)))))
2289 (env->list dynamic-top-level-env)))
2290 ; ----------------------------------------------------------------------------
2291 ; Dynamic type inference for Scheme
2292 ; ----------------------------------------------------------------------------
2296 (define (ic!) (init-global-constraints!))
2297 (define (pc) (glob-constr-show))
2298 (define (lc) (length global-constraints))
2299 (define (n!) (normalize-global-constraints!))
2300 (define (pt) (dynamic-top-level-env-show))
2301 (define (it!) (init-dynamic-top-level-env!))
2302 (define (io!) (set! tag-ops 0) (set! no-ops 0))
2303 (define (i!) (ic!) (it!) (io!) '())
2309 ; This wasn't intended to be an i/o benchmark,
2310 ; so let's read the file just once.
2313 (call-with-input-file
2316 (define (loop forms)
2317 (let ((form (read port)))
2318 (if (eof-object? form)
2320 (loop (cons form forms)))))
2323 (define (dynamic-parse-forms forms)
2326 (let ((next-input (car forms)))
2327 (dynamic-parse-action-commands
2328 (dynamic-parse-command dynamic-empty-env next-input)
2329 (dynamic-parse-forms (cdr forms))))))
2334 (let ((foo (dynamic-parse-forms *forms*)))
2335 (normalize-global-constraints!)
2340 (define (dynamic-benchmark . rest)
2341 (let ((n (if (null? rest) 1 (car rest))))
2342 (run-benchmark "dynamic"