blob: c5ffe14ba091ffd9fc53c461d82c41ba10e3dec9 (
about) (
plain)
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
|
;;; This is the main entry point to the type checker.
(define (do-haskell-type-check object modules)
(type-init modules)
(when (is-type? 'let object) ; may be void
(dynamic-let ((*non-generic-tyvars* '())
(*placeholders* '())
(*enclosing-decls* '()))
(type-check/decls let decls
(setf (dynamic *non-generic-tyvars*) '())
(process-placeholders (dynamic *placeholders*) '() '()))))
'done)
;;; This is the main recursive entry to the type checker.
(define (dispatch-type-check exp)
(remember-context exp
(call-walker type exp)))
(define (do-type-check/list exps)
(if (null? exps)
(values '() '())
(mlet (((obj1 type1) (dispatch-type-check (car exps)))
((objs types) (do-type-check/list (cdr exps))))
(values (cons obj1 objs) (cons type1 types)))))
(define (type-init modules)
;; Built in types
(setf *char-type* (**ntycon (core-symbol "Char") '()))
(setf *string-type* (**ntycon (core-symbol "List")
(list *char-type*)))
(setf *bool-type* (**ntycon (core-symbol "Bool") '()))
(setf *int-type* (**ntycon (core-symbol "Int") '()))
(setf *integer-type* (**ntycon (core-symbol "Integer") '()))
(setf *rational-type* (**ntycon (core-symbol "Ratio")
(list *integer-type*)))
(setf *default-decls* '())
(dolist (m modules)
(let ((default-types '()))
(dolist (d (default-decl-types (module-default m)))
(let* ((ty (ast->gtype '() d))
(ntype (gtype-type ty)))
(cond ((not (null? (gtype-context ty)))
(recoverable-error 'not-monotype
"~A is not a monotype in default decl" ty))
((not (type-in-class? ntype (core-symbol "Num")))
(recoverable-error 'not-Num-class
"~A is not in class Num" ty))
(else
(push ntype default-types)))))
(push (tuple (module-name m) (reverse default-types)) *default-decls*))))
(define (remember-placeholder placeholder)
(push placeholder (dynamic *placeholders*)))
|
