Changeset 14993 in project for chicken/trunk


Ignore:
Timestamp:
06/14/09 21:56:10 (11 years ago)
Author:
felix winkelmann
Message:

scrutinizer: types.db fixes; noreturn propagates so value-count check in conditional doesn't fail

Location:
chicken/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/scrutinizer.scm

    r14874 r14993  
    238238                                     (cond ((and (pair? t) (eq? 'or (car t)))
    239239                                            (cdr t))
    240                                            ((eq? 'noreturn t) '())
     240                                           ;((eq? t 'noreturn) '())
    241241                                           ((eq? t 'undefined) (return 'undefined))
    242242                                           (else (list t)))))
     
    280280                 (else '(#!rest))))
    281281          ((eq? '#!rest (car ts1))
    282            (cond ((eq? '#!rest (car ts2))
     282           (cond ((and (pair? ts2) (eq? '#!rest (car ts2)))
    283283                  `(#!rest
    284284                    ,(simplify
     
    287287                 (else '(#!rest))))             ;XXX giving up
    288288          ((eq? '#!optional (car ts1))
    289            (cond ((eq? '#!optional (car ts2))
     289           (cond ((and (pair? ts2) (eq? '#!optional (car ts2)))
    290290                  `(#!optional
    291291                    ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
     
    546546                      (else (cons (car rt) (loop (cdr rt)))))))))
    547547          (else (bomb "not a procedure type: ~a" t))))
     548  (define (noreturn-type? t)
     549    (or (eq? 'noreturn t)
     550        (and (pair? t)
     551             (eq? 'or (car t))
     552             (any noreturn-type? (cdr t)))))
    548553  (define (walk n e loc dest)           ; returns result specifier
    549554    (let ((subs (node-subexpressions n))
     
    562567                       (let ((r1 (walk (second subs) e loc dest))
    563568                             (r2 (walk (third subs) e loc dest)))
    564                          (cond ((and (not (eq? r1 '*)) (not (eq? '* r2)))
    565                                 (when (not (= (length r1) (length r2)))
     569                         (cond ((and (not (eq? r1 '*))
     570                                     (not (eq? '* r2)) )
     571                                (when (and (not (any noreturn-type? r1))
     572                                           (not (any noreturn-type? r2))
     573                                           (not (= (length r1) (length r2))))
    566574                                  (report
    567575                                   loc
  • chicken/trunk/tests/scrutiny-tests.scm

    r14829 r14993  
    3131
    3232((values 1 2))
     33
     34; this should *not* signal a warning:
     35
     36(define (test-values x)
     37  (define (fail) (error "failed"))
     38  (if x
     39      (values 42 43)
     40      (fail)))
  • chicken/trunk/types.db

    r14987 r14993  
    368368(repl (procedure repl () undefined))
    369369(repl-prompt (procedure repl-prompt (#!optional procedure) procedure))
    370 (repository-path (procedure repository-path (#!optional *) string))
     370(repository-path (procedure repository-path (#!optional *) *))
    371371(require (procedure require (#!rest *) undefined))
    372372(reset (procedure reset () undefined))
     
    636636(change-directory (procedure change-directory (string) undefined))
    637637(change-file-mode (procedure change-file-mode (string fixnum) undefined))
    638 (change-file-owner (procedure change-file-owner (string fixnum) undefined))
     638(change-file-owner (procedure change-file-owner (string fixnum fixnum) undefined))
    639639(close-input-pipe (procedure close-input-pipe (port) fixnum))
    640640(close-output-pipe (procedure close-output-pipe (port) fixnum))
     
    926926(length+ (procedure length+ (list) *))
    927927(list-copy (procedure list-copy (list) list))
    928 (list-index (procedure list-index ((procedure (* #!rest) *) list #!rest list) fixnum))
     928(list-index (procedure list-index ((procedure (* #!rest) *) list #!rest list) *))
    929929(list-tabulate (procedure list-tabulate (fixnum (procedure (fixnum) *)) list))
    930930(list= (procedure list= (#!rest list) boolean))
     
    940940(lset-xor (procedure lset-xor ((procedure (* *) *) list #!rest list) list))
    941941(lset-xor! (procedure lset-xor! ((procedure (* *) *) list #!rest list) list))
    942 (lset<= (procedure lset<= ((procedure (* *) *) list #!rest list) list))
    943 (lset= (procedure lset= ((procedure (* *) *) list #!rest list) list))
     942(lset<= (procedure lset<= ((procedure (* *) *) list #!rest list) boolean))
     943(lset= (procedure lset= ((procedure (* *) *) list #!rest list) boolean))
    944944(make-list (procedure make-list (fixnum #!optional *) list))
    945945(map! (procedure map! ((procedure (*) *) list #!rest list) list))
     
    11021102(char-set-size (procedure char-set-size ((struct char-set)) fixnum))
    11031103(char-set-unfold (procedure char-set-unfold (procedure procedure procedure * #!optional (struct char-set)) (struct char-set)))
    1104 (char-set-unfold! (procedure char-set-unfold! () (procedure procedure procedure * (struct char-set)) (struct char-set)))
     1104(char-set-unfold! (procedure char-set-unfold! (procedure procedure procedure * (struct char-set)) (struct char-set)))
    11051105(char-set-union (procedure char-set-union (#!rest (struct char-set)) (struct char-set)))
    11061106(char-set-union! (procedure char-set-union! (#!rest (struct char-set)) (struct char-set)))
     
    11201120(char-set:printing (struct char-set))
    11211121(char-set:punctuation (struct char-set))
    1122 (char-set:s (procedure (struct char-set) *))
     1122(char-set:s (struct char-set))
    11231123(char-set:symbol (struct char-set))
    11241124(char-set:title-case (struct char-set))
Note: See TracChangeset for help on using the changeset viewer.