1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Type schemes
(define-record-type type-scheme :type-scheme
(make-type-scheme type free-uvars)
type-scheme?
(type type-scheme-type) ; a type
(free-uvars type-scheme-free-uvars)) ; uvars that are free
(define-record-discloser :type-scheme
(lambda (type-scheme)
(list 'type-scheme
(map uvar-id (type-scheme-free-uvars type-scheme))
(type-scheme-type type-scheme))))
; If TYPE has any variables bound at DEPTH this returns a type scheme making
; those variables polymorphic; otherwise TYPE is returned.
; Would like to do limited finalizing of uvars, but can't.
; Consider (lambda (g x) (tuple (g 3) (g x) x))
; (a -> b) -> c -> [d, e, f] with
; a > int8, d > b, a > c, e > b, f > c
; No polymorphism, and no simplification without restricting someone
; But consider NOT a ->b, bool > a, b > bool
; It could just as well be bool -> bool.
; Simplification okay on variables that are not used inside other types?
(define *free-uvars* '())
(define (schemify-type type depth)
(set! *free-uvars* '())
(let* ((type (find-free-uvars type depth))
(free-uvars *free-uvars*))
(set! *free-uvars* '()) ; drop pointers
(for-each (lambda (uvar)
(set-uvar-place! uvar #f))
free-uvars)
(if (not (null? free-uvars))
(make-type-scheme type free-uvars)
type)))
(define (find-free-uvars type depth)
(let label ((type type))
(cond ((other-type? type)
(make-other-type (other-type-kind type)
(map label
(other-type-subtypes type))))
((not (uvar? type))
type)
((uvar-binding type)
=> label)
((and (not (uvar-place type))
(<= depth (uvar-depth type)))
(set-uvar-place! type type)
(set! *free-uvars* (cons type *free-uvars*))
type)
(else
type))))
; Instantiate SCHEME at DEPTH.
;
; New sequence:
; (instantiate-type-scheme scheme depth)
; ... elide bindings in new copy ...
; (clean-type-scheme scheme)
(define (instantiate-type-scheme scheme depth . maybe-thunk)
(instantiate-type-scheme! scheme depth)
(let ((type (copy-type (type-scheme-type scheme))))
(if (not (null? maybe-thunk))
((car maybe-thunk)))
(clean-type-scheme! scheme)
type))
(define (instantiate-type-scheme! scheme depth)
(let ((uid (unique-id)))
(for-each (lambda (uvar)
(set-uvar-place!
uvar
(make-uvar (uvar-prefix uvar) depth uid)))
(type-scheme-free-uvars scheme))))
(define (clean-type-scheme! scheme)
(for-each (lambda (uvar)
(set-uvar-place! uvar #f))
(type-scheme-free-uvars scheme)))
(define (copy-type type)
(cond ((other-type? type)
(make-other-type (other-type-kind type)
(map copy-type
(other-type-subtypes type))))
((not (uvar? type))
type)
((uvar-place type)
=> identity)
((uvar-binding type)
=> copy-type)
(else
type)))
|
