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
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
(define (prescheme-front-end package-ids spec-files copy no-copy shadow)
(receive (packages exports lookup)
(package-specs->packages+exports package-ids spec-files)
(let ((forms (flatten-definitions (scan-packages packages))))
(annotate-forms! (car package-ids) lookup exports copy no-copy shadow)
(receive (forms producer)
(sort-forms forms)
(format #t "Checking types~%")
(let ((sorted (let loop ((forms '()))
(cond ((producer)
=> (lambda (f)
(type-check-form f)
(loop (cons f forms))))
(else
(reverse forms))))))
; (format #t "Adding coercions~%")
; (add-type-coercions (form-reducer forms))
sorted)))))
(define (form-reducer forms)
(lambda (proc init)
(let loop ((forms forms) (value init))
(if (null? forms)
value
(loop (cdr forms)
(proc (form-name (car forms))
(form-value (car forms))
value))))))
(define (test id files)
((structure-ref node reset-node-id))
((structure-ref record-types reset-record-data!))
(prescheme-front-end id files '() '() '()))
(define (annotate-forms! package-id lookup exports copy no-copy shadow)
(mark-forms! exports
lookup
(lambda (f) (set-form-exported?! f #t))
"exported")
(mark-forms! copy
lookup
(lambda (f) (set-form-integrate! f 'yes))
"to be copied")
(mark-forms! no-copy
lookup
(lambda (f) (set-form-integrate! f 'no))
"not to be copied")
(for-each (lambda (data)
(let ((owner (package-lookup lookup (caar data) (cadar data))))
(if owner
(mark-forms! (cdr data)
lookup
(lambda (f)
(set-form-shadowed! owner
(cons (form-var f)
(form-shadowed owner))))
(format #f "shadowed in ~S" (car data)))
(format #t "Warning: no definition for ~S, cannot shadow ~S~%"
(car data) (cdr data)))))
shadow))
(define (mark-forms! specs lookup marker mark)
(let ((lose (lambda (p n)
(format #t "Warning: no definition for ~S, cannot mark as ~A~%"
(list p n) mark))))
(for-each (lambda (spec)
(let ((package-id (car spec))
(ids (cdr spec)))
(for-each (lambda (id)
(cond ((package-lookup lookup package-id id)
=> marker)
(else
(lose package-id id))))
ids)))
specs)))
(define (package-lookup lookup package-id id)
(let ((var (lookup package-id id)))
(and (variable? var)
(maybe-variable->form var))))
; Two possibilities:
; 1. The variable is settable but the thunk gives it no particular value.
; 2. A real value is or needs to be present, so we relate the type of
; the variable with the type of the value.
; thunk's value may be a STOB and not a lambda.
(define (type-check-form form)
;; (format #t " ~S: " (variable-name (form-var form)))
(let* ((value (form-value form))
(var (form-var form))
(name (form-name form))
(value-type (cond (((structure-ref nodes node?) value)
(infer-definition-type value (source-proc form)))
((variable? value)
(get-package-variable-type value))
(else
(bug "unknown kind of form value ~S" value)))))
(set-form-value-type! form value-type)
(cond ((not (variable-set!? var))
(let ((type (cond ((eq? type/unknown (variable-type var))
(let ((type (schemify-type value-type 0)))
(set-variable-type! var type)
type))
(else
(unify! value-type (get-package-variable-type var) form)
value-type))))
(if (not (type-scheme? type))
(make-nonpolymorphic! type)) ; lock down any related uvars
;;(format #t "~S~%" (instantiate type))
))
((not (or (eq? type/unit value-type)
(eq? type/null value-type)))
(make-nonpolymorphic! value-type) ; no polymorphism allowed (so it
;; is not checked for, so there may be depth 0 uvars in the type)
;; (format #t " ~S~%" (instantiate value-type))
(unify! value-type (get-package-variable-type var) form))
((eq? type/unknown (variable-type var))
(get-package-variable-type var)))))
(define (source-proc form)
(lambda (port)
(write-one-line port
70
(lambda (port)
(format port "~S = ~S"
(form-name form)
((structure-ref nodes schemify)
(form-value form)))))))
|
