source: project/chicken/trunk/scrutinizer.scm @ 15700

Last change on this file since 15700 was 15246, checked in by felix winkelmann, 11 years ago

-debug v; compile-file; all namespace decls in one file

File size: 20.6 KB
Line 
1;;;; scrutinizer.scm - The CHICKEN Scheme compiler (local flow analysis)
2;
3; Copyright (c) 2009, The Chicken Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(declare (unit scrutinizer))
28
29
30(include "compiler-namespace")
31(include "tweaks")
32
33
34(define (d fstr . args)
35  (when (##sys#fudge 13)
36    (printf "[debug] ~?~%" fstr args)) )
37
38(define-syntax d (syntax-rules () ((_ . _) (void))))
39
40
41;;; Walk node tree, keeping type and binding information
42;
43; result specifiers:
44;
45;   SPEC = * | (VAL1 ...)
46;   VAL = (or VAL1 ...)
47;       | (struct NAME)
48;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL | values]]) . RESULTS)
49;       | BASIC
50;       | deprecated
51;   BASIC = * | string | symbol | char | number | boolean | list | pair |
52;           procedure | vector | null | eof | undefined | port |
53;           blob | noreturn | pointer | locative | fixnum | float
54;   RESULTS = *
55;           | (VAL1 ...)
56
57; global symbol properties:
58;
59;   ##core#type           ->  <typespec>
60;   ##core#declared-type  ->  <bool>
61
62(define-constant +fragment-max-length+ 5)
63(define-constant +fragment-max-depth+ 3)
64
65(define (scrutinize node db)
66  (define (constant-result lit)
67    (cond ((string? lit) 'string)
68          ((symbol? lit) 'symbol)
69          ((fixnum? lit) 'fixnum)
70          ((flonum? lit) 'float)
71          ((number? lit) 'number)       ; in case...
72          ((boolean? lit) 'boolean)
73          ((list? lit) 'list)
74          ((pair? lit) 'pair)
75          ((eof-object? lit) 'eof)
76          ((vector? lit) 'vector)
77          ((and (not (##sys#immediate? lit)) ##sys#generic-structure? lit)
78           `(struct ,(##sys#slot lit 0)))
79          ((null? lit) 'null)
80          ((char? lit) 'char)
81          (else '*)))
82  (define (global-result id loc)
83    (cond ((##sys#get id '##core#type) =>
84           (lambda (a) 
85             (cond #;((and (get db id 'assigned)      ; remove assigned global from type db
86                         (not (##sys#get id '##core#declared-type)))
87                    (##sys#put! id '##core#type #f)
88                    '*)
89                   ((eq? a 'deprecated)
90                    (report
91                     loc
92                     (sprintf "use of deprecated toplevel identifier `~a'" id) )
93                    '*)
94                   (else (list a)))))
95          (else '*)))
96  (define (variable-result id e loc)
97    (cond ((and (get db id 'assigned) 
98                (not (##sys#get id '##core#declared-type)) )
99           '*)
100          ((assq id e) =>
101           (lambda (a)
102             (cond ((eq? 'undefined (cdr a))
103                    (report 
104                     loc
105                     (sprintf "access to variable `~a' which has an undefined value"
106                              (real-name id db)))
107                    '*)
108                   (else (list (cdr a))))))
109          (else (global-result id loc))))
110  (define (always-true1 t)
111    (cond ((and (pair? t) (eq? 'or (car t)))
112           (every always-true1 (cdr t)))
113          ((memq t '(* boolean undefined noreturn)) #f)
114          (else #t)))
115  (define (always-true t loc x)
116    (let ((f (always-true1 t)))
117      (when f
118        (report 
119         loc
120         (sprintf
121          "expected value of type boolean in conditional but were given a value of type `~a' which is always true:~%~%~a"
122          t
123          (pp-fragment x))))
124      f))
125  (define (typename t)
126    (case t
127      ((*) "anything")
128      ((char) "character")
129      (else
130       (cond ((symbol? t) (symbol->string t))
131             ((pair? t)
132              (case (car t)
133                ((procedure) 
134                 (if (or (string? (cadr t)) (symbol? (cadr t)))
135                     (->string (cadr t))
136                     (sprintf "a procedure with ~a returning ~a"
137                              (argument-string (cadr t))
138                              (result-string (cddr t)))))
139                ((or)
140                 (string-intersperse
141                  (map typename (cdr t))
142                  " OR "))
143                ((struct)
144                 (sprintf "a structure of type ~a" (cadr t)))
145                (else (bomb "invalid type: ~a" t))))
146             (else (bomb "invalid type: ~a" t))))))
147  (define (argument-string args)
148    (let ((len (length args))
149          (m (multiples len)))
150      (if (zero? len)
151          "zero arguments"
152          (sprintf 
153           "~a argument~a of type~a ~a"
154           len m m
155           (map typename args)))))
156  (define (result-string results)
157    (if (eq? '* results) 
158        "an unknown number of values"
159        (let ((len (length results))
160              (m (multiples len)))
161          (if (zero? len)
162              "zero values"
163              (sprintf 
164               "~a value~a of type~a ~a"
165               len m m
166               (map typename results))))))
167  (define (simplify t)
168    (let ((t2 (simplify1 t)))
169      (d "simplify: ~a -> ~a" t t2)
170      t2))
171  (define (simplify1 t)
172    (call/cc
173     (lambda (return)
174       (if (pair? t)
175           (case (car t)
176             ((or)
177              (cond ((= 2 (length t)) (simplify (second t)))
178                    ((every procedure-type? (cdr t))
179                     (if (any (cut eq? 'procedure <>) (cdr t))
180                         'procedure
181                         (reduce
182                          (lambda (t pt)
183                            (let* ((name1 (and (named? t) (cadr t)))
184                                   (atypes1 (if name1 (third t) (second t)))
185                                   (rtypes1 (if name1 (cdddr t) (cddr t)))
186                                   (name2 (and (named? pt) (cadr pt)))
187                                   (atypes2 (if name2 (third pt) (second pt)))
188                                   (rtypes2 (if name2 (cdddr pt) (cddr pt))))
189                              (append
190                               '(procedure)
191                               (if (and name1 name2 (eq? name1 name2)) (list name1) '())
192                               (list (merge-argument-types atypes1 atypes2))
193                               (merge-result-types rtypes1 rtypes2))))
194                          #f
195                          (cdr t))))
196                    (else
197                     (let* ((ts (append-map
198                                 (lambda (t)
199                                   (let ((t (simplify t)))
200                                     (cond ((and (pair? t) (eq? 'or (car t)))
201                                            (cdr t))
202                                           ;((eq? t 'noreturn) '())
203                                           ((eq? t 'undefined) (return 'undefined))
204                                           (else (list t)))))
205                                 (cdr t)))
206                            (ts2 (let loop ((ts ts) (done '()))
207                                   (cond ((null? ts) (reverse done))
208                                         ((eq? '* (car ts)) (return '*))
209                                         ((any (cut type<=? (car ts) <>) (cdr ts))
210                                          (loop (cdr ts) done))
211                                         ((any (cut type<=? (car ts) <>) done)
212                                          (loop (cdr ts) done))
213                                         (else (loop (cdr ts) (cons (car ts) done)))))))
214                       (cond ((equal? ts2 (cdr t)) t)
215                             (else
216                              (d "  or-simplify: ~a" ts2)
217                              (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
218             ((procedure)
219              (let* ((name (and (named? t) (cadr t)))
220                     (rtypes (if name (cdddr t) (cddr t))))
221                (append
222                 '(procedure)
223                 (if name (list name) '())
224                 (list (map simplify (if name (third t) (second t))))
225                 (if (eq? '* rtypes)
226                     '*
227                     (map simplify rtypes)))))
228             (else t))
229           t))))
230  (define (named? t)
231    (and (pair? t) 
232         (eq? 'procedure (car t))
233         (not (or (null? (cadr t)) (pair? (cadr t))))))
234  (define (rest-type r)
235    (cond ((null? r) '*)
236          ((eq? 'values (car r)) '*)
237          (else (car r))))
238  (define (merge-argument-types ts1 ts2) 
239    (cond ((null? ts1) 
240           (cond ((null? ts2) '())
241                 ((memq (car ts2) '(#!rest #!optional)) ts2)
242                 (else '(#!rest))))
243          ((eq? '#!rest (car ts1))
244           (cond ((and (pair? ts2) (eq? '#!rest (car ts2)))
245                  `(#!rest
246                    ,(simplify 
247                      `(or ,(rest-type (cdr ts1))
248                           ,(rest-type (cdr ts2))))))
249                 (else '(#!rest))))             ;XXX giving up
250          ((eq? '#!optional (car ts1))
251           (cond ((and (pair? ts2) (eq? '#!optional (car ts2)))
252                  `(#!optional 
253                    ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
254                    ,@(merge-argument-types (cddr ts1) (cddr ts2))))
255                 (else '(#!rest))))     ;XXX
256          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
257                      (merge-argument-types (cdr ts1) (cdr ts2))))))
258  (define (merge-result-types ts1 ts2)  ;XXX possibly overly conservative
259    (cond ((null? ts1) ts2)
260          ((null? ts2) ts1)
261          ((or (atom? ts1) (atom? ts2)) '*)
262          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
263                      (merge-result-types (cdr ts1) (cdr ts2))))))
264  (define (match t1 t2)
265    (let ((m (match1 t1 t2)))
266      (d "match ~a <-> ~a -> ~a" t1 t2 m)
267      m))
268  (define (match1 t1 t2)
269    (cond ((eq? t1 t2))
270          ((eq? t1 '*))
271          ((eq? t2 '*))
272          ((eq? t1 'noreturn))
273          ((eq? t2 'noreturn))
274          ((and (eq? t1 'number) (memq t2 '(number fixnum float))))
275          ((and (eq? t2 'number) (memq t1 '(number fixnum float))))
276          ((eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2))))
277          ((eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))))
278          ((and (pair? t1) (eq? 'or (car t1))) (any (cut match <> t2) (cdr t1)))
279          ((and (pair? t2) (eq? 'or (car t2))) (any (cut match t1 <>) (cdr t2)))
280          ((memq t1 '(pair list)) (memq t2 '(pair list)))
281          ((memq t1 '(null list)) (memq t2 '(null list)))
282          ((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
283           (case (car t1)
284             ((procedure)
285              (let ((args1 (if (named? t1) (third t1) (second t1)))
286                    (args2 (if (named? t2) (third t2) (second t2))) 
287                    (results1 (if (named? t1) (cdddr t1) (cddr t1))) 
288                    (results2 (if (named? t2) (cdddr t2) (cddr t2))) )
289                (and (match-args args1 args2)
290                     (match-results results1 results2))))
291             ((struct) (equal? t1 t2))
292             (else #f) ) )
293          (else #f)))
294  (define (match-args args1 args2)
295    (d "match-args: ~s <-> ~s" args1 args2)
296    (define (match-rest rtype args opt) ;XXX currently ignores `opt'
297      (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
298        (and (every (cut match rtype <>) head) ; match required args
299             (match rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
300    (define (optargs a)
301      (memq a '(#!rest #!optional)))
302    (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
303      (d "  args ~a ~a ~a ~a" args1 args2 opt1 opt2)
304      (cond ((null? args1) 
305             (or opt2
306                 (null? args2)
307                 (optargs (car args2))))
308            ((null? args2) 
309             (or opt1
310                 (optargs (car args1))))
311            ((eq? '#!optional (car args1))
312             (loop (cdr args1) args2 #t opt2))
313            ((eq? '#!optional (car args2))
314             (loop args1 (cdr args2) opt1 #t))
315            ((eq? '#!rest (car args1))
316             (match-rest (rest-type (cdr args1)) args2 opt2))
317            ((eq? '#!rest (car args2))
318             (match-rest (rest-type (cdr args2)) args1 opt1))
319            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
320            (else #f))))
321  (define (match-results results1 results2)
322    (cond ((null? results1) (atom? results2))
323          ((eq? '* results1))
324          ((eq? '* results2))
325          ((null? results2) #f)
326          ((match (car results1) (car results2)) 
327           (match-results (cdr results1) (cdr results2)))
328          (else #f)))
329  (define (type<=? t1 t2)
330    (or (eq? t1 t2)
331        (memq t2 '(* undefined))
332        (case t2
333          ((list) (memq t1 '(null pair)))
334          ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
335          ((number) (memq t1 '(fixnum float)))
336          (else
337           (and (pair? t1) (pair? t2)
338                (case (car t1)
339                  ((or) (every (cut type<=? <> t2) (cdr t1)))
340                  ((procedure)
341                   (let ((args1 (if (pair? (cadr t1)) (cadr t1) (caddr t1)))
342                         (args2 (if (pair? (cadr t2)) (cadr t2) (caddr t2)))
343                         (res1 (if (pair? (cadr t1)) (cddr t1) (cdddr t1)))
344                         (res2 (if (pair? (cadr t2)) (cddr t2) (cdddr t2))) )
345                     (let loop1 ((args1 args1)
346                                 (args2 args2)
347                                 (m1 0) 
348                                 (m2 0))
349                       (cond ((null? args1) 
350                              (and (or (null? args2) (> m2 0))
351                                   (let loop2 ((res1 res1) (res2 res2))
352                                     (cond ((eq? '* res2) #t)
353                                           ((null? res2) (null? res1))
354                                           ((eq? '* res1) #f)
355                                           ((type<=? (car res1) (car res2))
356                                            (loop2 (cdr res1) (cdr res2)))
357                                           (else #f)))))
358                             ((null? args2) #f)
359                             ((eq? (car args1) '#!optional)
360                              (loop1 (cdr args1) args2 1 m2))
361                             ((eq? (car args2) '#!optional)
362                              (loop1 args1 (cdr args2) m1 1))
363                             ((eq? (car args1) '#!rest)
364                              (loop1 (cdr args1) args2 2 m2))
365                             ((eq? (car args2) '#!rest)
366                              (loop1 args1 (cdr args2) m1 2))
367                             ((type<=? (car args1) (car args2)) 
368                              (loop1 (cdr args1) (cdr args2) m1 m2))
369                             (else #f)))))))))))
370  (define (multiples n)
371    (if (= n 1) "" "s"))
372  (define (single what tv loc)
373    (if (eq? '* tv)
374        '*
375        (let ((n (length tv)))
376          (cond ((= 1 n) (car tv))
377                ((zero? n)
378                 (report 
379                  loc
380                  (sprintf "expected ~a a single result, but were given zero results" what))
381                 'undefined)
382                (else
383                 (report 
384                  loc
385                  (sprintf "expected ~a a single result, but were given ~a result~a"
386                           what n (multiples n)))
387                 (first tv))))))
388  (define (report loc desc)
389    (compiler-warning
390     'scrutiny
391     "~a~a" 
392     (location-name loc) desc))
393  (define (location-name loc)
394    (define (lname loc1)
395      (if loc1
396          (sprintf "procedure `~a'" (real-name loc1))
397          "unknown procedure"))
398    (cond ((null? loc) "at toplevel:\n  ")
399          ((null? (cdr loc))
400           (sprintf "in toplevel ~a:\n  " (lname (car loc))))
401          (else
402           (let rec ((loc loc))
403             (if (null? (cdr loc))
404                 (location-name loc)
405                 (sprintf "in local ~a,\n  ~a" (lname (car loc)) (rec (cdr loc))))))))
406  (define add-loc cons)
407  (define (fragment x)
408    (let ((x (build-expression-tree x)))
409      (let walk ((x x) (d 0))
410        (cond ((atom? x) x)
411              ((>= d +fragment-max-depth+) '...)
412              ((list? x)
413               (map (cute walk <> (add1 d)) (take x (min +fragment-max-length+ (length x)))))
414              (else x)))))
415  (define (pp-fragment x)
416    (string-chomp
417     (with-output-to-string
418       (lambda ()
419         (pp (fragment x))))))
420  (define (call-result args e loc x params)
421    (define (pname)
422      (sprintf 
423       "in procedure call to `~s'~a" 
424       (fragment x)
425       (if (and (pair? params) (pair? (cdr params)))
426           (let ((n (source-info->line (cadr params))))
427             (if (number? n)
428                 (sprintf " (line ~a)" n)
429                 ""))
430           "")))
431    (d "call-result: ~a (~a)" args loc)
432    (let* ((ptype (car args))
433           (nargs (length (cdr args)))
434           (xptype `(procedure ,(make-list nargs '*) *)))
435      (when (and (not (procedure-type? ptype))
436                 (not (match xptype ptype)))
437        (report
438         loc
439         (sprintf
440          "expected ~a a value of type `~a', but were given a value of type `~a'"
441          (pname) 
442          xptype
443          ptype)))
444      (let-values (((atypes values-rest) (procedure-argument-types ptype (length (cdr args)))))
445        (d "  argument-types: ~a (~a)" atypes values-rest)
446        (unless (= (length atypes) nargs)
447          (let ((alen (length atypes)))
448            (report 
449             loc
450             (sprintf
451              "expected ~a ~a argument~a, but where given ~a argument~a"
452              (pname) alen (multiples alen)
453              nargs (multiples nargs)))))
454        (do ((args (cdr args) (cdr args))
455             (atypes atypes (cdr atypes))
456             (i 1 (add1 i)))
457            ((or (null? args) (null? atypes)))
458          (unless (match (car atypes) (car args))
459            (report
460             loc
461             (sprintf
462              "expected argument #~a of type `~a' ~a, but where given an argument of type `~a'"
463              i (car atypes) (pname) (car args)))))
464        (let ((r (procedure-result-types ptype values-rest (cdr args))))
465          (d  "  result-types: ~a" r)
466          r))))
467  (define (procedure-type? t)
468    (or (eq? 'procedure t)
469        (and (pair? t) 
470             (or (eq? 'procedure (car t))
471                 (and (eq? 'or (car t))
472                      (every procedure-type? (cdr t)))))))
473  (define (procedure-argument-types t n)
474    (cond ((or (memq t '(* procedure)) 
475               (not-pair? t) )
476           (values (make-list n '*) #f))
477          ((eq? 'procedure (car t))
478           (let* ((vf #f)
479                  (llist
480                   (let loop ((at (if (or (string? (second t)) (symbol? (second t)))
481                                      (third t)
482                                      (second t)))
483                              (m n)
484                              (opt #f))
485                     (cond ((null? at) '())
486                           ((eq? '#!optional (car at)) 
487                            (loop (cdr at) m #t) )
488                           ((eq? '#!rest (car at))
489                            (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))
490                            (make-list m (rest-type (cdr at))))
491                           ((and opt (<= m 0)) '())
492                           (else (cons (car at) (loop (cdr at) (sub1 m) opt)))))))
493             (values llist vf)))
494          (else (bomb "not a procedure type" t))))
495  (define (procedure-result-types t values-rest? args)
496    (cond (values-rest? args)
497          ((or (memq t '(* procedure))
498               (not-pair? t) )
499           '*)
500          ((eq? 'procedure (car t))
501           (call/cc
502            (lambda (return)
503              (let loop ((rt (if (or (string? (second t)) (symbol? (second t)))
504                                 (cdddr t)
505                                 (cddr t))))
506                (cond ((null? rt) '())
507                      ((eq? '* rt) (return '*))
508                      (else (cons (car rt) (loop (cdr rt)))))))))
509          (else (bomb "not a procedure type: ~a" t))))
510  (define (noreturn-type? t)
511    (or (eq? 'noreturn t)
512        (and (pair? t)
513             (eq? 'or (car t))
514             (any noreturn-type? (cdr t)))))
515  (define (walk n e loc dest)           ; returns result specifier
516    (let ((subs (node-subexpressions n))
517          (params (node-parameters n)) 
518          (class (node-class n)) )
519      (d "walk: ~a ~a (loc: ~a, dest: ~a)" class params loc dest)
520      (let ((results
521             (case class
522               ((quote) (list (constant-result (first params))))
523               ((##core#undefined) '(*))
524               ((##core#proc) '(procedure))
525               ((##core#global-ref) (global-result (first params) loc))
526               ((##core#variable) (variable-result (first params) e loc))
527               ((if) (let ((rt (single "in conditional" (walk (first subs) e loc dest) loc)))
528                       (always-true rt loc n)
529                       (let ((r1 (walk (second subs) e loc dest))
530                             (r2 (walk (third subs) e loc dest)))
531                         (cond ((and (not (eq? r1 '*)) 
532                                     (not (eq? '* r2)) )
533                                (when (and (not (any noreturn-type? r1))
534                                           (not (any noreturn-type? r2))
535                                           (not (= (length r1) (length r2))))
536                                  (report 
537                                   loc
538                                   (sprintf
539                                    "branches in conditional expression differ in the number of results:~%~%~a"
540                                    (pp-fragment n))))
541                                (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
542                                     r1 r2))
543                               (else '*)))))
544               ((let)
545                (let loop ((vars params) (body subs) (e2 '()))
546                  (if (null? vars)
547                      (walk (car body) (append e2 e) loc dest)
548                      (let ((t (single 
549                                (sprintf "in `let' binding of `~a'" (real-name (car vars)))
550                                (walk (car body) e loc (car vars)) loc)))
551                        (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
552               ((##core#lambda lambda)
553                (decompose-lambda-list
554                 (first params)
555                 (lambda (vars argc rest)
556                   (let* ((name (if dest (list dest) '()))
557                          (args (append (make-list argc '*) (if rest '(#!rest) '()))) 
558                          (e2 (append (map (lambda (v) (cons v '*)) 
559                                           (if rest (butlast vars) vars))
560                                      e))
561                          (r (walk (first subs)
562                                   (if rest (alist-cons rest 'list e2) e2)
563                                   (add-loc dest loc)
564                                   #f)))
565                     (list
566                      (append
567                       '(procedure) 
568                       name
569                       (list args)
570                       r))))))
571               ((set! ##core#set!)
572                (let* ((var (first params))
573                       (type (##sys#get var '##core#type))
574                       (rt (single 
575                            (sprintf "in assignment to `~a'" var)
576                            (walk (first subs) e loc var)
577                            loc))
578                       (b (assq var e)) )
579                  (when (and type (not b)
580                             (not (eq? type 'deprecated))
581                             (not (match type rt)))
582                    (report
583                     loc
584                     (sprintf 
585                      "assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
586                      rt var type)))
587                  (when (and b (eq? 'undefined (cdr b)))
588                    (set-cdr! b rt))
589                  '(undefined)))
590               ((##core#primitive ##core#inline_ref) '*)
591               ((##core#call)
592                (let* ((f (fragment n))
593                       (args (map (lambda (n i)
594                                    (single 
595                                     (sprintf 
596                                      "in ~a of procedure call `~s'"
597                                      (if (zero? i)
598                                          "operator position"
599                                          (sprintf "argument #~a" i))
600                                      f)
601                                     (walk n e loc #f) loc))
602                                  subs (iota (length subs)))))
603                  (call-result args e loc (first subs) params)))
604               ((##core#switch ##core#cond)
605                (bomb "unexpected node class: ~a" class))
606               (else
607                (for-each (lambda (n) (walk n e loc #f)) subs)
608                '*))))
609        (d "  -> ~a" results)
610        results)))
611  (walk (first (node-subexpressions node)) '() '() #f))
612
613(define (load-type-database name #!optional (path (repository-path)))
614  (and-let* ((dbfile (file-exists? (make-pathname path name))))
615    (when verbose-mode
616      (printf "loading type database ~a ...~%" dbfile))
617    (for-each
618     (lambda (e)
619       (let* ((name (car e))
620              (old (##sys#get name '##core#type))
621              (new (cadr e)))
622         (when (and old (not (equal? old new)))
623           (compiler-warning 
624            'scrutiny
625            "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
626            name new old))
627         (##sys#put! name '##core#type new)))
628     (read-file dbfile))))
Note: See TracBrowser for help on using the repository browser.