1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
4
5; Rudimentary type reconstruction, hardly worthy of the name.
6
7; Currently, NODE-TYPE is called in two places.  One is to determine
8; the type of the right-hand side of a DEFINE for a variable that is
9; never assigned, so uses of the variable can be checked later.  The
10; other is when compiling a call, to check types of arguments and
11; produce warning messages.
12
13; This is heuristic, to say the least.  It's not clear what the right
14; interface or formalism is for Scheme; I'm still experimenting.
15
16; Obviously we can't do Hindley-Milner inference.  Not only does
17; Scheme have subtyping, but it also has dependent types up the wazoo.
18; For example, the following is perfectly correct Scheme:
19;
20;   (define (foo x y) (if (even? x) (car y) (vector-ref y 3)))
21
22(define (node-type node)
23  (reconstruct node 'fast any-values-type))
24
25(define (reconstruct-type node env)
26  (reconstruct node '() any-values-type))
27
28(define (reconstruct node constrained want-type)
29  ((operator-table-ref reconstructors (node-operator-id node))
30    node
31    constrained
32    want-type))
33
34(define (examine node constrained want-type)
35  (if (pair? constrained)
36      (reconstruct node constrained want-type)
37      want-type))
38
39(define reconstructors
40  (make-operator-table (lambda (node constrained want-type)
41                         (reconstruct-call (node-form node)
42					   constrained
43					   want-type))))
44
45(define (define-reconstructor name type proc)
46  (operator-define! reconstructors name type proc))
47
48(define-reconstructor 'lambda syntax-type
49  (lambda (node constrained want-type)
50    (reconstruct-lambda node constrained want-type #f)))
51
52(define-reconstructor 'flat-lambda syntax-type
53  (lambda (node constrained want-type)
54    (reconstruct-lambda node constrained want-type #f)))
55
56(define (reconstruct-lambda node constrained want-type called?)
57  (if (eq? constrained 'fast)
58      any-procedure-type
59      (let* ((form (node-form node))
60	     (want-result (careful-codomain want-type))
61	     (formals (cadr form))
62	     (alist (map (lambda (node)
63			   (cons node value-type))
64			 (normalize-formals formals)))
65	     (cod (reconstruct (last form)	; works for normal and flat
66			       (if called?
67				   (append alist constrained)
68				   alist)
69			       want-result)))
70	(procedure-type (if (n-ary? formals)
71			    any-values-type ;lose
72			    (make-some-values-type (map cdr alist)))
73			cod
74			#t))))
75
76(define (careful-codomain proc-type)
77  (if (procedure-type? proc-type)
78      (procedure-type-codomain proc-type)
79      any-values-type))
80
81(define-reconstructor 'name 'leaf
82  (lambda (node constrained want-type)
83    (if (eq? constrained 'fast)
84        (reconstruct-name node)
85        (let ((z (assq node constrained)))
86          (if z
87              (let ((type (meet-type (cdr z) want-type)))
88                (begin (set-cdr! z type)
89                       type))
90              (reconstruct-name node))))))
91
92(define (reconstruct-name node)
93  (let ((probe (node-ref node 'binding)))
94    (if (binding? probe)
95        (let ((type (binding-type probe)))
96          (cond ((variable-type? type)
97		 (variable-value-type type))
98                ((subtype? type value-type)
99		 type)
100                (else
101		 value-type)))
102        value-type)))
103
104(define-reconstructor 'call 'internal
105  (lambda (node constrained want-type)
106    (let ((form (node-form node)))
107      (cond ((proc->reconstructor (car form))
108	     => (lambda (recon)
109		  (recon (cdr form) constrained want-type)))
110	    (else
111	     (reconstruct-call form constrained want-type))))))
112
113; See if PROC is a primop or a variable bound to a primop, and then return
114; that primops reconstructor, if it has one.
115
116(define (proc->reconstructor proc)
117  (cond ((name-node? proc)
118	 (let ((probe (node-ref proc 'binding)))
119	   (if (and probe
120		    (binding? probe)
121		    (primop? (binding-static probe)))
122	       (table-ref primop-reconstructors
123			  (binding-static probe))
124	       #f)))
125	((literal-node? proc)
126	 (if (primop? (node-form proc))
127	     (table-ref primop-reconstructors
128			(node-form proc))
129	     #f))
130	(else #f)))
131
132(define (reconstruct-call form constrained want-type)
133  (let* ((want-op-type (procedure-type any-arguments-type
134				       want-type
135				       #f))
136	 (op-type (if (lambda-node? (car form))
137		      (reconstruct-lambda (car form)
138					  constrained
139					  want-op-type
140					  #t)
141		      (reconstruct (car form)
142				   constrained
143				   want-op-type)))
144	 (args (cdr form))
145	 (lose (lambda ()
146		 (for-each (lambda (arg)
147			     (examine arg constrained value-type))
148			   args))))
149    (if (procedure-type? op-type)
150	(begin (if (restrictive? op-type)
151		   (let loop ((args args)
152			      (dom (procedure-type-domain op-type)))
153		     (if (not (or (null? args)
154				  (empty-rail-type? dom)))
155			 (begin (examine (car args)
156					 constrained
157					 (head-type dom))
158				(loop (cdr args) (tail-type dom)))))
159		   (lose))
160	       (procedure-type-codomain op-type))
161	(begin (lose)
162	       any-values-type))))
163
164(define-reconstructor 'literal 'leaf
165  (lambda (node constrained want-type)
166    (constant-type (node-form node))))
167
168(define-reconstructor 'quote syntax-type
169  (lambda (node constrained want-type)
170    (constant-type (cadr (node-form node)))))
171
172(define-reconstructor 'unspecific #f
173  (lambda (node constrained wnat-type)
174    unspecific-type))
175
176(define-reconstructor 'unassigned #f
177  (lambda (node constrained wnat-type)
178    unspecific-type))
179
180(define-reconstructor 'if syntax-type
181  (lambda (node constrained want-type)
182    (let ((form (node-form node)))
183      (examine (cadr form) constrained value-type)
184      ;; Fork off two different constrain sets
185      (let ((con-alist (fork-constraints constrained))
186            (alt-alist (fork-constraints constrained)))
187        (let ((con-type (reconstruct (caddr form) con-alist want-type))
188              (alt-type (reconstruct (cadddr form) alt-alist want-type)))
189          (if (pair? constrained)
190              (for-each (lambda (c1 c2 c)
191                          (set-cdr! c (join-type (cdr c1) (cdr c2))))
192                        con-alist
193                        alt-alist
194                        constrained))
195          (join-type con-type alt-type))))))
196
197(define (fork-constraints constrained)
198  (if (pair? constrained)
199      (map (lambda (x) (cons (car x) (cdr x)))
200           constrained)
201      constrained))-
202
203(define-reconstructor 'begin syntax-type
204  (lambda (node constrained want-type)
205    ;; This is unsound - there might be a throw out of some subform
206    ;; other than the final one.
207    (do ((forms (cdr (node-form node)) (cdr forms)))
208        ((null? (cdr forms))
209         (reconstruct (car forms) constrained want-type))
210      (examine (car forms) constrained any-values-type))))
211
212(define-reconstructor 'set! syntax-type
213  (lambda (node constrained want-type)
214    (examine (caddr (node-form node)) constrained value-type)
215    unspecific-type))
216
217(let ((letrec-reconstructor
218       (lambda (node constrained want-type)
219	 (let ((form (node-form node)))
220	   (reconstruct-letrec (cadr form) (caddr form) constrained want-type)))))
221  (define-reconstructor 'letrec syntax-type
222    letrec-reconstructor)
223  (define-reconstructor 'letrec* syntax-type
224    letrec-reconstructor))
225
226(define-reconstructor 'pure-letrec syntax-type
227  (lambda (node constrained want-type)
228    (let ((form (node-form node)))
229      (reconstruct-letrec (cadr form) (cadddr form) constrained want-type))))
230
231(define (reconstruct-letrec specs body constrained want-type)
232  (if (eq? constrained 'fast)
233      (reconstruct body 'fast want-type)
234      (let ((alist (map (lambda (spec)
235			  (cons (car spec)
236				(reconstruct (cadr spec)
237					     constrained
238					     value-type)))
239			specs)))
240	(reconstruct body
241		     (append alist constrained)
242		     want-type))))
243
244(define-reconstructor 'loophole syntax-type
245  (lambda (node constrained want-type)
246    (let ((args (cdr (node-form node))))
247      (examine (cadr args) constrained any-values-type)
248      (car args))))
249
250(define (node->type node)
251  (if (node? node)
252      (let ((form (node-form node)))
253        (if (pair? form)
254            (map node->type form)
255            (desyntaxify form)))
256      (desyntaxify node)))
257
258(define-reconstructor 'define syntax-type
259  (lambda (node constrained want-type)
260    ':definition))
261
262(define-reconstructor 'lap syntax-type
263  (lambda (node constrained want-type)
264    any-procedure-type))
265
266; --------------------
267; Primops.
268;
269; Most primops just have the types assigned in comp-prim.scm.
270
271(define primop-reconstructors (make-symbol-table))
272
273(define (define-primop-reconstructor name proc)
274  (table-set! primop-reconstructors name proc))
275
276(define-reconstructor 'primitive-procedure syntax-type
277  (lambda (node constrained want-type)
278    (primop-type (get-primop (cadr (node-form node))))))
279
280(define-primop-reconstructor 'values
281  (lambda (args constrained want-type)
282    (make-some-values-type (map (lambda (node)
283                                  (meet-type
284                                   (reconstruct node constrained value-type)
285                                   value-type))
286				args))))
287
288(define-primop-reconstructor 'call-with-values
289  (lambda (args constrained want-type)
290    (if (= (length args) 2)
291	(let ((thunk-type (reconstruct (car args)
292				       constrained
293				       (procedure-type empty-rail-type
294						       any-values-type
295						       #f))))
296	  (careful-codomain
297	   (reconstruct (cadr args)
298			constrained
299			(procedure-type (careful-codomain thunk-type)
300					any-values-type
301					#f))))
302	error-type)))
303
304(define (reconstruct-apply args constrained want-type)
305  (if (not (null? args))
306      (let ((proc-type (reconstruct (car args)
307				    constrained
308				    any-procedure-type)))
309	(for-each (lambda (arg) (examine arg constrained value-type))
310		  (cdr args))
311	(careful-codomain proc-type))
312      error-type))
313
314(define-primop-reconstructor 'apply reconstruct-apply)
315
316(define-primop-reconstructor 'primitive-catch reconstruct-apply)
317
318(define (constant-type x)
319  (cond ((number? x)
320         (meet-type (if (exact? x) exact-type inexact-type)
321                    (cond ((integer? x) integer-type)
322                          ((rational? x) rational-type)
323                          ((real? x) real-type)
324                          ((complex? x) complex-type)
325                          (else number-type))))
326        ((boolean? x) boolean-type)
327        ((pair? x) pair-type)
328        ((string? x) string-type)
329        ((char? x) char-type)
330        ((null? x) null-type)
331        ((symbol? x) symbol-type)
332	((primop? x) (primop-type x))
333        ((vector? x) vector-type)
334        (else value-type)))
335
336