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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
;;; This file also contains some random globals for the type checker:
(define-walker type ast-td-type-walker)
;;; Some pre-defined types
(define *bool-type* '())
(define *char-type* '())
(define *string-type* '())
(define *int-type* '())
(define *integer-type* '())
(define *rational-type* '())
;;; These two globals are used throughout the typechecker to avoid
;;; passing lots of stuff in each function call.
(define *placeholders* '())
(define *non-generic-tyvars* '())
(define *enclosing-decls* '())
;;; Used by the defaulting mechanism
(define *default-decls* '())
;;; Used in error handling & recovery
(define *type-error-handlers* '())
(define *type-error-recovery* '())
;;; This associates a type checker function with an ast type. The variable
;;; `object' is bound to the value being types.
(define-syntax (define-type-checker ast-type . cont)
`(define-walker-method type ,ast-type (object)
,@cont))
;;; This recursively type checks a structure slot in the current object.
;;; This updates the ast in the slot (since type checking rewrites the ast)
;;; and binds the computed type to a variable. The slot must contain an
;;; expression.
(define-syntax (type-check struct slot var . cont)
`(mlet ((($$$ast$$$ ,var)
(dispatch-type-check (struct-slot ',struct ',slot object))))
(setf (struct-slot ',struct ',slot object) $$$ast$$$)
,@cont))
;;; This is used to scope decls.
(define-syntax (with-new-tyvars . cont)
`(dynamic-let ((*non-generic-tyvars* (dynamic *non-generic-tyvars*)))
,@cont))
;;; Similar to type-check, the slot must contain a list of decls.
;;; This must be done before any reference to a variable defined in the
;;; decls is typechecked.
(define-syntax (type-check/decls struct slot . cont)
`(with-new-tyvars
(let (($$$decls$$$
(type-decls (struct-slot ',struct ',slot object))))
(setf (struct-slot ',struct ',slot object) $$$decls$$$)
,@cont)))
;;; The type checker returns an expression / type pair. This
;;; abstracts the returned value.
(define-syntax (return-type object type)
`(values ,object ,type))
;;; When an ast slot contains a list of expressions, there are two
;;; possibilities: the expressions all share the same type or each has
;;; an independant type. In the first case, a single type (computed
;;; by unifying all types in the list) is bound to a variable.
(define-syntax (type-check/unify-list struct slot var error-handler . cont)
`(mlet ((($$$ast$$$ $$$types$$$)
(do-type-check/list (struct-slot ',struct ',slot object))))
(setf (struct-slot ',struct ',slot object) $$$ast$$$)
(with-type-error-handler ,error-handler ($$$types$$$)
(unify-list/single-type $$$types$$$)
(let ((,var (car $$$types$$$)))
,@cont))))
;;; When a list of expressions does not share a common type, the result is
;;; a list of types.
(define-syntax (type-check/list struct slot var . cont)
`(mlet ((($$$ast$$$ ,var)
(do-type-check/list (struct-slot ',struct ',slot object))))
(setf (struct-slot ',struct ',slot object) $$$ast$$$)
,@cont))
;;; This creates a fresh tyvar and binds it to a variable.
(define-syntax (fresh-type var . cont)
`(let ((,var (**ntyvar)))
,@cont))
;;; This drives the unification routine. Two types are unified and the
;;; context is updated. Currently no error handling is implemented to
;;; deal with unification errors.
(define-syntax (type-unify type1 type2 error-handler)
`(with-type-error-handler ,error-handler ()
(unify ,type1 ,type2)))
;;; This generates a fresh set of monomorphic type variables.
(define-syntax (fresh-monomorphic-types n vars . cont)
`(with-new-tyvars
(let ((,vars '()))
(dotimes (i ,n)
(let ((tv (**ntyvar)))
(push tv ,vars)
(push tv (dynamic *non-generic-tyvars*))))
,@cont)))
;;; This creates a single monomorphic type variable.
(define-syntax (fresh-monomorphic-type var . cont)
`(let* ((,var (**ntyvar)))
(with-new-tyvars
(push ,var (dynamic *non-generic-tyvars*))
,@cont)))
;;; This is used to rewrite the current ast as a new ast and then
;;; recursively type check the new ast. The original ast is saved for
;;; error message printouts.
(define-syntax (type-rewrite ast)
`(mlet (((res-ast type) (dispatch-type-check ,ast))
(res (**save-old-exp object res-ast)))
(return-type res type)))
;;; These are the type error handlers
(define-syntax (recover-type-error error-handler . body)
(let ((temp (gensym))
(err-fn (gensym)))
`(let/cc ,temp
(let ((,err-fn ,error-handler))
(dynamic-let ((*type-error-recovery*
(cons (lambda ()
(funcall ,err-fn ,temp))
(dynamic *type-error-recovery*))))
,@body)))))
(define-syntax (with-type-error-handler handler extra-args . body)
(if (eq? handler '#f)
`(begin ,@body)
`(dynamic-let ((*type-error-handlers*
(cons (lambda ()
(,(car handler) ,@extra-args ,@(cdr handler)))
(dynamic *type-error-handlers*))))
,@body)))
|
