source: project/chicken/branches/scrutiny/scrutinizer.scm @ 14628

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

some types; fixnum and float type specifiers

File size: 22.7 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(private compiler
30  compiler-arguments process-command-line perform-lambda-lifting!
31  default-standard-bindings default-extended-bindings
32  foldable-bindings llist-length
33  installation-home decompose-lambda-list external-to-pointer
34  copy-node! variable-visible? mark-variable intrinsic?
35  unit-name insert-timer-checks used-units external-variables hide-variable
36  debug-info-index debug-info-vector-name profile-info-vector-name
37  foreign-declarations emit-trace-info block-compilation line-number-database-size
38  make-block-variable-literal block-variable-literal? block-variable-literal-name
39  target-heap-size target-stack-size constant-declarations variable-mark
40  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
41  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
42  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
43  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
44  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
45  direct-call-ids foreign-type-table first-analysis expand-debug-lambda expand-debug-assignment expand-debug-call
46  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
47  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
48  reorganize-recursive-bindings substitution-table simplify-named-call compiler-warning real-name
49  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
50  transform-direct-lambdas! expand-foreign-callback-lambda* debug-lambda-list debug-variable-list debugging
51  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
52  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
53  collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
54  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
55  build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
56  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list 
57  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
58  topological-sort print-version print-usage initialize-analysis-database
59  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
60  units-used-by-default words-per-flonum rewrite inline-locally
61  parameter-limit eq-inline-operator optimizable-rest-argument-operators
62  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
63  make-random-name final-foreign-type inline-max-size simplified-ops
64  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
65  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result
66  scrutinize load-type-database source-info->line)
67
68
69(include "tweaks")
70
71
72(define (d fstr . args)
73  (when (##sys#fudge 13)
74    (printf "[debug] ~?~%" fstr args)) )
75
76;XXX (define-syntax d (syntax-rules () ((_ . _) (void))))
77
78
79;;; Walk node tree, keeping type and binding information
80;
81; result specifiers:
82;
83;   SPEC = * | (VAL1 ...)
84;   VAL = (or VAL1 ...)
85;       | (struct NAME)
86;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL]]) . RESULTS)
87;       | BASIC
88;       | deprecated
89;   BASIC = * | string | symbol | char | number | boolean | list | pair |
90;           procedure | vector | null | eof | undefined | port |
91;           blob | noreturn | pointer | locative | fixnum | float
92;   RESULTS = *
93;           | (VAL1 ...)
94
95; global symbol properties:
96;
97;   ##core#type           ->  <typespec>
98;   ##core#declared-type  ->  <bool>
99
100(define-constant +fragment-max-length+ 5)
101
102(define (scrutinize node db)
103  (define (constant-result lit)
104    (cond ((string? lit) 'string)
105          ((symbol? lit) 'symbol)
106          ((fixnum? lit) 'fixnum)
107          ((flonum? lit) 'float)
108          ((number? lit) 'number)       ; in case...
109          ((boolean? lit) 'boolean)
110          ((list? lit) 'list)
111          ((pair? lit) 'pair)
112          ((eof-object? lit) 'eof)
113          ((vector? lit) 'vector)
114          ((and (not (##sys#immediate? lit)) ##sys#generic-structure? lit)
115           `(struct ,(##sys#slot lit 0)))
116          ((null? lit) 'null)
117          ((char? lit) 'char)
118          (else '*)))
119  (define (global-result id loc)
120    (cond ((##sys#get id '##core#type) =>
121           (lambda (a) 
122             (cond #;((and (get db id 'assigned)
123                         (not (##sys#get id '##core#declared-type)))
124                    (##sys#put! id '##core#type #f)
125                    '*)
126                   ((eq? a 'deprecated)
127                    (report1 
128                     loc
129                     (sprintf "use of deprecated toplevel identifier `~a'" id) )
130                    '*)
131                   (else (list a)))))
132          (else '*)))
133  (define (variable-result id e loc)
134    (cond #;((and (get db id 'assigned)
135                (not (##sys#get id '##core#declared-type)) )
136           '*)
137          ((assq id e) =>
138           (lambda (a)
139             (cond ((eq? 'undefined (cdr a))
140                    (report1 
141                     loc
142                     (sprintf "access to variable `~a' which has an undefined value"
143                              (real-name id db)))
144                    '*)
145                   (else (list (cdr a))))))
146          (else (global-result id loc))))
147  (define (always-true1 t)
148    (cond ((and (pair? t) (eq? 'or (car t)))
149           (every always-true1 (cdr t)))
150          ((memq t '(* boolean undefined noreturn)) #f)
151          (else #t)))
152  (define (always-true t loc x)
153    (let ((f (always-true1 t)))
154      (when f
155        (report 
156         loc "of type boolean" 
157         (sprintf 
158          "a result that is of type `~a' and thus always true"
159          t)
160         "value"
161         (sprintf "in conditional `~s'," (fragment x))))
162      f))
163  (define (typename t)
164    (case t
165      ((*) "anything")
166      ((char) "character")
167      (else
168       (cond ((symbol? t) (symbol->string t))
169             ((pair? t)
170              (case (car t)
171                ((procedure) 
172                 (if (or (string? (cadr t)) (symbol? (cadr t)))
173                     (->string (cadr t))
174                     (sprintf "a procedure with ~a returning ~a"
175                              (argument-string (cadr t))
176                              (result-string (cddr t)))))
177                ((or)
178                 (string-intersperse
179                  (map typename (cdr t))
180                  " OR "))
181                ((struct)
182                 (sprintf "a structure of type ~a" (cadr t)))
183                (else (bomb "invalid type: ~a" t))))
184             (else (bomb "invalid type: ~a" t))))))
185  (define (argument-string args)
186    (let ((len (length args))
187          (m (multiples len)))
188      (if (zero? len)
189          "zero arguments"
190          (sprintf 
191           "~a argument~a of type~a ~a"
192           len m m
193           (map typename args)))))
194  (define (result-string results)
195    (if (eq? '* results) 
196        "an unknown number of values"
197        (let ((len (length results))
198              (m (multiples len)))
199          (if (zero? len)
200              "zero values"
201              (sprintf 
202               "~a value~a of type~a ~a"
203               len m m
204               (map typename results))))))
205  (define (simplify t)
206    (let ((t2 (simplify1 t)))
207      (d "simplify: ~a -> ~a" t t2)
208      t2))
209  (define (simplify1 t)
210    (call/cc
211     (lambda (return)
212       (if (pair? t)
213           (case (car t)
214             ((or)
215              (cond ((= 2 (length t)) (simplify (second t)))
216                    ((every procedure-type? (cdr t))
217                     (if (any (cut eq? 'procedure <>) (cdr t))
218                         'procedure
219                         (reduce
220                          (lambda (t pt)
221                            (let* ((name1 (and (named? t) (cadr t)))
222                                   (atypes1 (if name1 (third t) (second t)))
223                                   (rtypes1 (if name1 (cdddr t) (cddr t)))
224                                   (name2 (and (named? pt) (cadr pt)))
225                                   (atypes2 (if name1 (third pt) (second pt)))
226                                   (rtypes2 (if name1 (cdddr pt) (cddr pt))))
227                              `(procedure
228                                ,@(if (eq? name1 name2) (list name1) '())
229                                ,(merge-argument-types atypes1 atypes2)
230                                ,@(merge-result-types rtypes1 rtypes2))))
231                          #f
232                          (cdr t))))
233                    (else
234                     (let* ((ts (append-map
235                                 (lambda (t)
236                                   (let ((t (simplify t)))
237                                     (cond ((and (pair? t) (eq? 'or (car t)))
238                                            (cdr t))
239                                           ((eq? 'noreturn t) '())
240                                           ((eq? t 'undefined) (return 'undefined))
241                                           (else (list t)))))
242                                 (cdr t)))
243                            (ts2 (let loop ((ts ts))
244                                   (cond ((null? ts) '())
245                                         ((eq? '* (car ts)) (return '*))
246                                         ((any (cut type<=? (car ts) <>) (cdr ts))
247                                          (loop (cdr ts)))
248                                         (else (cons (car ts) (loop (cdr ts))))))))
249                       (cond ((equal? ts2 (cdr t)) t)
250                             (else
251                              (d "  or-simplify: ~a" ts2)
252                              (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
253             ((procedure)
254              (let* ((name (and (named? t) (cadr t)))
255                     (rtypes (if name (cdddr t) (cddr t))))
256                `(procedure 
257                  ,@(if name (list name) '())
258                  ,(map simplify (if name (third t) (second t)))
259                  ,@(if (eq? '* rtypes)
260                        '*
261                        (map simplify rtypes)))))
262             (else t))
263           t))))
264  (define (named? t)
265    (and (pair? t) 
266         (eq? 'procedure (car t))
267         (not (or (null? (cadr t)) (pair? (cadr t))))))
268  (define (merge-argument-types ts1 ts2) 
269    (cond ((null? ts1) 
270           (cond ((null? ts2) '())
271                 ((memq (car ts2) '(#!rest #!optional)) ts2)
272                 (else '(#!rest))))
273          ((eq? '#!rest (car ts1))
274           (cond ((eq? '#!rest (car ts2))
275                  `(#!rest
276                    ,(simplify 
277                      `(or ,(if (pair? (cdr ts1)) (cadr ts1) '*)
278                           ,(if (pair? (cdr ts2)) (cadr ts2) '*)))))
279                 (else '(#!rest))))             ;XXX giving up
280          ((eq? '#!optional (car ts1))
281           (cond ((eq? '#!optional (car ts2))
282                  `(#!optional 
283                    ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
284                    ,@(merge-argument-types (cddr ts1) (cddr ts2))))
285                 (else '(#!rest))))     ;XXX
286          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
287                      (merge-argument-types (cdr ts1) (cdr ts2))))))
288  (define (merge-result-types ts1 ts2)  ;XXX possibly overly conservative
289    (cond ((null? ts1) ts2)
290          ((null? ts2) ts1)
291          (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
292                      (merge-result-types (cdr ts1) (cdr ts2))))))
293  (define (match t1 t2)
294    (let ((m (match1 t1 t2)))
295      (d "match ~a <-> ~a -> ~a" t1 t2 m)
296      m))
297  (define (match1 t1 t2)
298    (cond ((eq? t1 t2))
299          ((eq? t1 '*))
300          ((eq? t2 '*))
301          ((eq? t1 'noreturn))
302          ((eq? t2 'noreturn))
303          ((eq? t1 'number) (memq t2 '(number fixnum float)))
304          ((eq? t2 'number) (memq t1 '(number fixnum float)))
305          ((eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2))))
306          ((eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))))
307          ((and (pair? t1) (eq? 'or (car t1))) (any (cut match <> t2) (cdr t1)))
308          ((and (pair? t2) (eq? 'or (car t2))) (any (cut match t1 <>) (cdr t2)))
309          ((memq t1 '(pair list)) (memq t2 '(pair list)))
310          ((memq t1 '(null list)) (memq t2 '(null list)))
311          ((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
312           (case (car t1)
313             ((procedure)
314              (let ((args1 (if (named? t1) (third t1) (second t1)))
315                    (args2 (if (named? t2) (third t2) (second t2))) 
316                    (results1 (if (named? t1) (cdddr t1) (cddr t1))) 
317                    (results2 (if (named? t2) (cdddr t2) (cddr t2))) )
318                (and (match-args args1 args2)
319                     (match-results results1 results2))))
320             ((struct) (equal? t1 t2))
321             (else #f) ) )
322          (else #f)))
323  (define (match-args args1 args2)
324    (d "match-args: ~s <-> ~s" args1 args2)
325    (define (match-rest rtype args opt) ;XXX currently ignores `opt'
326      (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
327        (and (every (cut match rtype <>) head) ; match required args
328             (match
329                 rtype
330               (if (and (pair? tail) (pair? (cdr tail)))
331                   (cadr tail)
332                   '*) ) ) ) )
333    (define (optargs a)
334      (memq a '(#!rest #!optional)))
335    (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
336      (d "  args ~a ~a ~a ~a" args1 args2 opt1 opt2)
337      (cond ((null? args1) 
338             (or opt2
339                 (null? args2)
340                 (optargs (car args2))))
341            ((null? args2) 
342             (or opt1
343                 (optargs (car args1))))
344            ((eq? '#!optional (car args1))
345             (loop (cdr args1) args2 #t opt2))
346            ((eq? '#!optional (car args2))
347             (loop args1 (cdr args2) opt1 #t))
348            ((eq? '#!rest (car args1))
349             (match-rest (if (pair? (cdr args1)) (cadr args1) '*) args2 opt2))
350            ((eq? '#!rest (car args2))
351             (match-rest (if (pair? (cdr args2)) (cadr args2) '*) args1 opt1))
352            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
353            (else #f))))
354  (define (match-results results1 results2)
355    (cond ((null? results1) (atom? results2))
356          ((atom? results2))
357          ((match (car results1) (car results2)) 
358           (match-results (cdr results1) (cdr results2)))
359          (else #f)))
360  (define (type<=? t1 t2)
361    (or (eq? t1 t2)
362        (memq t2 '(* undefined))
363        (case t2
364          ((list) (memq t1 '(null pair)))
365          ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
366          ((number) (memq t1 '(fixnum float)))
367          (else
368           (and (pair? t1) (pair? t2)
369                (case (car t1)
370                  ((or) (every (cut type<=? <> t2) (cdr t1)))
371                  ((procedure)
372                   (let ((args1 (if (pair? (cadr t1)) (cadr t1) (caddr t1)))
373                         (args2 (if (pair? (cadr t2)) (cadr t2) (caddr t2)))
374                         (res1 (if (pair? (cadr t1)) (cddr t1) (cdddr t1)))
375                         (res2 (if (pair? (cadr t2)) (cddr t2) (cdddr t2))) )
376                     (let loop1 ((args1 args1)
377                                 (args2 args2)
378                                 (m1 0) 
379                                 (m2 0))
380                       (cond ((null? args1) 
381                              (and (or (null? args2) (> m2 0))
382                                   (let loop2 ((res1 res1) (res2 res2))
383                                     (cond ((eq? '* res2) #t)
384                                           ((null? res2) (null? res1))
385                                           ((eq? '* res1) #f)
386                                           ((type<=? (car res1) (car res2))
387                                            (loop2 (cdr res1) (cdr res2)))
388                                           (else #f)))))
389                             ((null? args2) #f)
390                             ((eq? (car args1) '#!optional)
391                              (loop1 (cdr args1) args2 1 m2))
392                             ((eq? (car args2) '#!optional)
393                              (loop1 args1 (cdr args2) m1 1))
394                             ((eq? (car args1) '#!rest)
395                              (loop1 (cdr args1) args2 2 m2))
396                             ((eq? (car args2) '#!rest)
397                              (loop1 args1 (cdr args2) m1 2))
398                             ((type<=? (car args1) (car args2)) 
399                              (loop1 (cdr args1) (cdr args2) m1 m2))
400                             (else #f)))))))))))
401  (define (check expected given loc what #!optional desc) 
402    (d "check: ~a <-> ~a (~a)" expected given loc)
403    (if (match expected given)
404        given
405        (report loc expected given what desc)))
406  (define (multiples n)
407    (if (= n 1) "" "s"))
408  (define (single what tv loc)
409    (if (eq? '* tv)
410        '*
411        (let ((n (length tv)))
412          (cond ((= 1 n) (car tv))
413                ((zero? n)
414                 (report loc "a single result" "zero results" what)
415                 'undefined)
416                (else
417                 (report loc "a single result" (sprintf "~a result~a" n (multiples n)) what)
418                 (first tv))))))
419  (define (report1 loc desc)
420    (compiler-warning
421     'scrutiny
422     "~a~a" 
423     (location-name loc) desc))
424  (define (report loc expected given what #!optional desc)
425    (report1 
426     loc 
427     (sprintf 
428      "~a~a~a~a"
429      (or desc "")
430      (if desc " " "")
431      (if expected
432          (sprintf "expected ~a~a~a" (or what "") (if what " " "") expected)
433          "")
434      (sprintf ", but where given ~a" given))))
435  (define (location-name loc)
436    (define (lname loc1)
437      (if loc1
438          (sprintf "procedure `~a'" (real-name loc1))
439          "unknown procedure"))
440    (cond ((null? loc) "at toplevel:\n  ")
441          ((null? (cdr loc))
442           (sprintf "in toplevel ~a:\n  " (lname (car loc))))
443          (else
444           (let rec ((loc loc))
445             (if (null? (cdr loc))
446                 (location-name loc)
447                 (sprintf "in local ~a,\n  ~a" (lname (car loc)) (rec (cdr loc))))))))
448  (define add-loc cons)
449  (define (fragment x)
450    (let ((x (build-expression-tree x)))
451      (cond ((atom? x) x)
452            ((list? x) 
453             (let ((x1 (if (> (length x) +fragment-max-length+)
454                           (append (take x +fragment-max-length+) '(...))
455                           x)))
456               (map (lambda (x) 
457                      (if (and (list? x) (any pair? x))
458                          '(...)
459                          x))
460                    x1)))
461            (else x))))
462  (define (call-result args e loc x params)
463    (define (pname)
464      (sprintf 
465       "in procedure call to `~s'~a" 
466       (fragment x)
467       (if (and (pair? params) (pair? (cdr params)))
468           (sprintf " (line ~a)" (source-info->line (cadr params)))
469           "")))
470    (d "call-result: ~a (~a)" args loc)
471    (let ((ptype (car args))
472          (nargs (length (cdr args))))
473      (unless (procedure-type? ptype)
474        (check 
475         `(procedure ,(make-list nargs '*) *)
476         ptype
477         loc "a procedure of type" (pname)))
478      (let ((atypes (procedure-argument-types ptype (length (cdr args)))))
479        (d "  argument-types: ~a" atypes)
480        (unless (= (length atypes) nargs)
481          (let ((alen (length atypes)))
482            (report 
483             loc
484             (sprintf "~a argument~a" alen (multiples alen))
485             (sprintf "~a argument~a" nargs (multiples nargs))
486             (pname))))
487        (do ((args (cdr args) (cdr args))
488             (atypes atypes (cdr atypes))
489             (i 1 (add1 i)))
490            ((or (null? args) (null? atypes)))
491          (check (car atypes) (car args) loc (sprintf "argument #~a of type" i) (pname)))
492        (let ((r (procedure-result-types ptype)))
493          (d  "  result-types: ~a" r)
494          r))))
495  (define (procedure-type? t)
496    (or (eq? 'procedure t)
497        (and (pair? t) 
498             (or (eq? 'procedure (car t))
499                 (and (eq? 'or (car t))
500                      (every procedure-type? (cdr t)))))))
501  (define (procedure-argument-types t n)
502    (cond ((or (memq t '(* procedure)) 
503               (not-pair? t) )
504           (make-list n '*))
505          ((eq? 'procedure (car t))
506           (let loop ((at (if (or (string? (second t)) (symbol? (second t)))
507                              (third t)
508                              (second t)))
509                      (m n)
510                      (opt #f))
511             (cond ((null? at) '())
512                   ((eq? '#!optional (car at)) 
513                    (loop (cdr at) m #t) )
514                   ((eq? '#!rest (car at))
515                    (if (pair? (cdr at))
516                        (make-list m (cadr at))
517                        (make-list m '*)))
518                   ((and opt (<= m 0)) '())
519                   (else (cons (car at) (loop (cdr at) (sub1 m) opt))))))
520          (else (bomb "not a procedure type" t))))
521  (define (procedure-result-types t)
522    (cond ((or (memq t '(* procedure)) 
523               (not-pair? t) )
524           '*)
525          ((eq? 'procedure (car t))
526           (call/cc
527            (lambda (return)
528              (let loop ((rt (if (or (string? (second t)) (symbol? (second t)))
529                                 (cdddr t)
530                                 (cddr t))))
531                (cond ((null? rt) '())
532                      ((eq? '* rt) (return '*))
533                      (else (cons (car rt) (loop (cdr rt)))))))))
534          (else (bomb "not a procedure type: ~a" t))))
535  (define (walk n e loc dest)           ; returns result specifier
536    (let ((subs (node-subexpressions n))
537          (params (node-parameters n)) 
538          (class (node-class n)) )
539      (d "walk: ~a ~a (loc: ~a, dest: ~a)" class params loc dest)
540      (let ((results
541             (case class
542               ((quote) (list (constant-result (first params))))
543               ((##core#undefined) '(*))
544               ((##core#proc) '(procedure))
545               ((##core#global-ref) (global-result (first params) loc))
546               ((##core#variable) (variable-result (first params) e loc))
547               ((if) (let ((rt (single "in conditional" (walk (first subs) e loc dest) loc)))
548                       (always-true rt loc n)
549                       (let ((r1 (walk (second subs) e loc dest))
550                             (r2 (walk (third subs) e loc dest)))
551                         (cond ((and (not (eq? r1 '*)) (not (eq? '* r2)))
552                                (when (not (= (length r1) (length r2)))
553                                  (report1 
554                                   loc
555                                   "branches in conditional expression differ in the number of results"))
556                                (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
557                                     r1 r2))
558                               (else '*)))))
559               ((let)
560                (let loop ((vars params) (body subs) (e2 '()))
561                  (if (null? vars)
562                      (walk (car body) (append e2 e) loc dest)
563                      (let ((t (single "in `let' binding" (walk (car body) e loc (car vars)) loc)))
564                        (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
565               ((##core#lambda lambda)
566                (decompose-lambda-list
567                 (first params)
568                 (lambda (vars argc rest)
569                   `((procedure
570                      ,@(if dest (list dest) '())
571                      ,(append (make-list argc '*) (if rest '(#!rest) '()))
572                      ,@(let* ((e2 (append (map (lambda (v) (cons v '*)) 
573                                                (if rest (butlast vars) vars))
574                                           e))
575                               (r (walk (first subs)
576                                        (if rest (alist-cons rest 'list e2) e2)
577                                        (add-loc dest loc)
578                                        #f)))
579                          (if (eq? r '*)
580                              '(*)
581                              r)))))))
582               ((set! ##core#set!)
583                (let* ((var (first params))
584                       (type (##sys#get var '##core#type))
585                       (rt (single 
586                            (sprintf "in assignment to `~a'" var)
587                            (walk (first subs) e loc var)
588                            loc))
589                       (b (assq var e)) )
590                  (when (and type (not b)
591                             (not (match type rt)))
592                    (report1
593                     loc
594                     (sprintf 
595                      "assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
596                      rt var type)))
597                  (when (and b (eq? 'undefined (cdr b)))
598                    (set-cdr! b rt))
599                  '(undefined)))
600               ((##core#primitive ##core#inline_ref) '*)
601               ((##core#call)
602                (let ((args (map (lambda (n)
603                                   (single 
604                                    "in procedure call argument"
605                                    (walk n e loc #f) loc))
606                                 subs)))
607                  (call-result args e loc (first subs) params)))
608               ((##core#switch ##core#cond)
609                (bomb "unexpected node class: ~a" class))
610               (else
611                (for-each (lambda (n) (walk n e loc #f)) subs)
612                '*))))
613        (d "  -> ~a" results)
614        results)))
615  (walk (first (node-subexpressions node)) '() '() #f))
616
617(define (load-type-database name #!optional (path (repository-path)))
618  (and-let* ((dbfile (file-exists? (make-pathname path name))))
619    (when verbose-mode
620      (printf "loading type database ~a ...~%" dbfile))
621    (for-each
622     (lambda (e)
623       (let* ((name (car e))
624              (old (##sys#get name '##core#type))
625              (new (cadr e)))
626         (when (and old (not (equal? old new)))
627           (compiler-warning 
628            'scrutiny
629            "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
630            name new old))
631         (##sys#put! name '##core#type new)))
632     (read-file dbfile))))
633
634(define (source-info->line info)
635  (if (list? info)
636      (cadr info)
637      (and info (->string info))) )
Note: See TracBrowser for help on using the repository browser.