4 (and (list? t) (eq? (car t) 'abs)))
13 (char-upper-case? (string-ref (symbol->string t) 0))))
15 (define (pretty-type t)
19 (string-append "(" (pretty-type (cadr t)) ")")
20 (pretty-type (cadr t)))
22 (pretty-type (caddr t))))
23 (else (symbol->string t))))
25 (define (pretty-constraints cs)
27 (fold-left string-append
39 (define (env-lookup env n)
40 (if (null? env) (error #f "empty env") ; it's a type equality
41 (if (eq? (caar env) n)
43 (env-lookup (cdr env) n))))
45 (define (env-insert env n t)
46 (cons (cons n t) env))
53 (set! cur-tvar (+ cur-tvar 1))
55 (string-append "t" (number->string (- cur-tvar 1))))))
62 (define (normalize prog) ; (+ a b) -> ((+ a) b)
65 ; (lambda (x y) (+ x y)) -> (lambda (x) (lambda (y) (+ x y)))
66 (if (> (length (lambda-args prog)) 1)
67 (list 'lambda (list (car (lambda-args prog)))
68 (normalize (list 'lambda (cdr (lambda-args prog)) (caddr prog))))
69 (list 'lambda (lambda-args prog) (normalize (caddr prog)))))
71 (if (null? (cddr prog))
72 `(,(normalize (car prog)) ,(normalize (cadr prog))) ; (f a)
73 (normalize `(,(list (normalize (car prog)) (normalize (cadr prog)))
74 ,@(cddr prog))))) ; (f a b)
77 (map (lambda (x) `(,(car x) ,(normalize (cadr x))))
79 (map normalize (let-body prog))))
80 (else (ast-traverse normalize prog))))
82 (define (builtin-type x)
84 ('+ '(abs Int (abs Int Int)))
85 ('- '(abs Int (abs Int Int)))
86 ('* '(abs Int (abs Int Int)))
88 ('= '(abs Int (abs Int Bool)))
89 ('bool->int '(abs Bool Int))
90 ('print '(abs String Void))
91 (else (error #f "Couldn't find type for builtin" x))))
93 (define (check-let env x)
94 ; takes in the current environment and a scc
95 ; returns new environment with scc's types added in
96 (let* ([components (reverse (sccs (graph (let-bindings x))))]
100 ; create a new env with tvars for each component
102 ; scc-env = ((x . t0) (y . t1))
106 (env-insert acc c (fresh-tvar)))
108 ; typecheck each component
112 (let ([body (cadr (assoc c (let-bindings x)))])
113 (check scc-env body)))
115 ; collect all the constraints in the scc
121 ; unify with tvars from scc-env
123 (~ (env-lookup scc-env c) (cadr res))
126 '() type-results comps)]
127 ; substitute *only* the bindings in this scc
130 (if (memv (car x) comps)
131 (cons (car x) (substitute cs (cdr x)))
135 [new-env (fold-left process-component env components)])
136 (check new-env (last (let-body x)))))
138 (define (check env x)
147 ('int-literal (list '() 'Int))
148 ('bool-literal (list '() 'Bool))
149 ('string-literal (list '() 'String))
150 ('builtin (list '() (builtin-type x)))
153 (let* ((cond-type-res (check env (cadr x)))
154 (then-type-res (check env (caddr x)))
155 (else-type-res (check env (cadddr x)))
156 (then-eq-else-cs (~ (cadr then-type-res)
157 (cadr else-type-res)))
158 (cs (constraint-merge
160 (constraint-merge (~ (cadr cond-type-res) 'Bool)
161 (constraint-merge (car else-type-res)
163 (return-type (substitute cs (cadr then-type-res))))
164 (list cs return-type)))
166 ('var (list '() (env-lookup env x)))
167 ('let (check-let env x))
171 (let* [(new-env (env-insert env (lambda-arg x) (fresh-tvar)))
173 (body-type-res (check new-env (lambda-body x)))
174 (cs (car body-type-res))
175 (subd-env (substitute-env (car body-type-res) new-env))
176 (arg-type (env-lookup subd-env (lambda-arg x)))
177 (resolved-arg-type (substitute cs arg-type))]
178 ;; (display "lambda:\n\t")
183 ;; (display (format "subd-env: ~a\n" subd-env))
184 ;; (display resolved-arg-type)
186 (list (car body-type-res)
189 (cadr body-type-res)))))
192 (if (eqv? (car x) (cadr x))
193 ; recursive function (f f)
194 (let* [(func-type (env-lookup env (car x)))
195 (return-type (fresh-tvar))
196 (other-func-type `(abs ,func-type ,return-type))
197 (cs (~ func-type other-func-type))
198 (resolved-return-type (substitute cs return-type))]
199 (list cs resolved-return-type)))
202 (let* ((arg-type-res (check env (cadr x)))
203 (arg-type (cadr arg-type-res))
204 (func-type-res (check env (car x)))
205 (func-type (cadr func-type-res))
209 (substitute (car arg-type-res) func-type)
210 `(abs ,arg-type ,(fresh-tvar))))
211 (cs (constraint-merge
212 (constraint-merge func-c (car arg-type-res))
213 (car func-type-res)))
215 (resolved-func-type (substitute cs func-type))
216 (resolved-return-type (caddr resolved-func-type)))
217 ;; (display "app:\n")
220 ;; (display func-type)
222 ;; (display resolved-func-type)
224 ;; (display arg-type-res)
226 (if (abs? resolved-func-type)
227 (let ((return-type (substitute cs (caddr resolved-func-type))))
228 (list cs return-type))
229 (error #f "not a function")))))))
230 (display "result of ")
233 (display (pretty-type (cadr res)))
235 (display (pretty-constraints (car res)))
239 ; we typecheck the lambda calculus only (only single arg lambdas)
240 (define (typecheck prog)
241 (define (constructor-type t ctr)
242 (fold-left (lambda (acc x) `(abs ,x ,acc)) t (cdr ctr)))
243 (define (constructors data-def)
244 (let ([type-name (cadr data-def)]
245 [ctrs (cddr data-def)])
246 (fold-left (lambda (acc ctr)
247 (cons (cons (car ctr) (constructor-type type-name ctr))
251 (let ([init-env (flat-map constructors (program-datas prog))])
253 (cadr (check init-env (normalize (program-body prog))))))
255 ; returns a list of constraints
257 (let ([res (unify? a b)])
261 (format "couldn't unify ~a ~~ ~a" a b)))))
264 (cond [(eq? a b) '()]
265 [(tvar? a) (list (cons a b))]
266 [(tvar? b) (list (cons b a))]
267 [(and (abs? a) (abs? b))
268 (let* [(arg-cs (unify? (cadr a) (cadr b)))
269 (body-cs (unify? (substitute arg-cs (caddr a))
270 (substitute arg-cs (caddr b))))]
271 (constraint-merge body-cs arg-cs))]
274 (define (substitute cs t)
280 [(abs? t) `(abs ,(substitute cs (cadr t))
281 ,(substitute cs (caddr t)))]
284 ; applies substitutions to all variables in environment
285 (define (substitute-env cs env)
286 (map (lambda (x) (cons (car x) (substitute cs (cdr x)))) env))
288 ; composes constraints a onto b and merges, i.e. applies a to b
289 ; a should be the "more important" constraints
290 (define (constraint-merge a b)
291 (define (f cs constraint)
292 (cons (car constraint)
293 (substitute cs (cdr constraint))))
295 (define (most-concrete a b)
299 [(and (abs? a) (abs? b))
300 `(abs ,(most-concrete (cadr a) (cadr b))
301 ,(most-concrete (caddr a) (caddr b)))]
306 ; for any two constraints that clash, e.g. t1 ~ abs t2 t3
307 ; and t1 ~ abs int t3
308 ; prepend the most concrete version of the type to the
309 ; list of constraints
312 (if (assoc (car x) a)
313 (cons (cons (car x) (most-concrete (cdr (assoc (car x) a))
317 (fold-left gen '() b))
320 (append (filter (lambda (x) (not (assoc (car x) p)))
323 (append (clashes) (union a (map (lambda (z) (f a z)) b))))
326 ;; ; a1 -> a2 ~ a3 -> a4;
327 ;; ; a1 -> a2 !~ Bool -> Bool
328 ;; ; basically can the tvars be renamed
329 (define (types-equal? x y)
330 (let ([cs (unify? x y)])
333 ([test (lambda (acc c)
335 (tvar? (car c)) ; the only substitutions allowed are tvar -> tvar
337 (fold-left test #t cs)))))
339 ; input: a list of binds ((x . y) (y . 3))
340 ; returns: pair of verts, edges ((x y) . (x . y))
342 (define (go bs orig-bs)
343 (define (find-refs prog)
347 ; only count a reference if its a binding
348 ['var (if (assoc x orig-bs) (list x) '())]
353 (let* [(bind (car bs))
356 (refs (find-refs (cdr bind)))
357 (edges (map (lambda (x) (cons vert x))
360 (rest (if (null? (cdr bs))
362 (go (cdr bs) orig-bs)))
363 (total-verts (cons vert (car rest)))
364 (total-edges (append edges (cdr rest)))]
365 (cons total-verts total-edges))))
368 (define (successors graph v)
372 (if (eqv? v (caar E))
373 (cons (cdar E) (go v (cdr E)))
377 ; takes in a graph (pair of vertices, edges)
378 ; returns a list of strongly connected components
380 ; ((x y w) . ((x . y) (x . w) (w . x))
390 ; this uses tarjan's algorithm, to get reverse
391 ; topological sorting for free
394 (let* ([indices (make-hash-table)]
395 [lowlinks (make-hash-table)]
396 [on-stack (make-hash-table)]
402 (get-hash-table indices v #f))
404 (get-hash-table lowlinks v #f))
410 (put-hash-table! indices v current)
411 (put-hash-table! lowlinks v current)
412 (set! current (+ current 1))
414 (put-hash-table! on-stack v #t)
418 (if (not (hashtable-contains? indices w))
419 ; successor w has not been visited, recurse
422 (put-hash-table! lowlinks
424 (min (lowlink v) (lowlink w))))
425 ; successor w has been visited
426 (when (get-hash-table on-stack w #f)
427 (put-hash-table! lowlinks v (min (lowlink v) (index w))))))
428 (successors graph v))
430 (when (= (index v) (lowlink v))
433 (let ([w (pop! stack)])
434 (put-hash-table! on-stack w #f)
437 (cons w (new-scc)))))])
438 (set! result (cons scc result))))))])
441 (when (not (hashtable-contains? indices v)) ; v.index == -1