Changeset 14993 in project for chicken/trunk
- Timestamp:
- 06/14/09 21:56:10 (11 years ago)
- Location:
- chicken/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
chicken/trunk/scrutinizer.scm
r14874 r14993 238 238 (cond ((and (pair? t) (eq? 'or (car t))) 239 239 (cdr t)) 240 ((eq? 'noreturn t) '())240 ;((eq? t 'noreturn) '()) 241 241 ((eq? t 'undefined) (return 'undefined)) 242 242 (else (list t))))) … … 280 280 (else '(#!rest)))) 281 281 ((eq? '#!rest (car ts1)) 282 (cond (( eq? '#!rest (car ts2))282 (cond ((and (pair? ts2) (eq? '#!rest (car ts2))) 283 283 `(#!rest 284 284 ,(simplify … … 287 287 (else '(#!rest)))) ;XXX giving up 288 288 ((eq? '#!optional (car ts1)) 289 (cond (( eq? '#!optional (car ts2))289 (cond ((and (pair? ts2) (eq? '#!optional (car ts2))) 290 290 `(#!optional 291 291 ,(simplify `(or ,(cadr ts1) ,(cadr ts2))) … … 546 546 (else (cons (car rt) (loop (cdr rt))))))))) 547 547 (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))))) 548 553 (define (walk n e loc dest) ; returns result specifier 549 554 (let ((subs (node-subexpressions n)) … … 562 567 (let ((r1 (walk (second subs) e loc dest)) 563 568 (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)))) 566 574 (report 567 575 loc -
chicken/trunk/tests/scrutiny-tests.scm
r14829 r14993 31 31 32 32 ((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 368 368 (repl (procedure repl () undefined)) 369 369 (repl-prompt (procedure repl-prompt (#!optional procedure) procedure)) 370 (repository-path (procedure repository-path (#!optional *) string))370 (repository-path (procedure repository-path (#!optional *) *)) 371 371 (require (procedure require (#!rest *) undefined)) 372 372 (reset (procedure reset () undefined)) … … 636 636 (change-directory (procedure change-directory (string) undefined)) 637 637 (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)) 639 639 (close-input-pipe (procedure close-input-pipe (port) fixnum)) 640 640 (close-output-pipe (procedure close-output-pipe (port) fixnum)) … … 926 926 (length+ (procedure length+ (list) *)) 927 927 (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) *)) 929 929 (list-tabulate (procedure list-tabulate (fixnum (procedure (fixnum) *)) list)) 930 930 (list= (procedure list= (#!rest list) boolean)) … … 940 940 (lset-xor (procedure lset-xor ((procedure (* *) *) list #!rest list) list)) 941 941 (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)) 944 944 (make-list (procedure make-list (fixnum #!optional *) list)) 945 945 (map! (procedure map! ((procedure (*) *) list #!rest list) list)) … … 1102 1102 (char-set-size (procedure char-set-size ((struct char-set)) fixnum)) 1103 1103 (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))) 1105 1105 (char-set-union (procedure char-set-union (#!rest (struct char-set)) (struct char-set))) 1106 1106 (char-set-union! (procedure char-set-union! (#!rest (struct char-set)) (struct char-set))) … … 1120 1120 (char-set:printing (struct char-set)) 1121 1121 (char-set:punctuation (struct char-set)) 1122 (char-set:s ( procedure (struct char-set) *))1122 (char-set:s (struct char-set)) 1123 1123 (char-set:symbol (struct char-set)) 1124 1124 (char-set:title-case (struct char-set))
Note: See TracChangeset
for help on using the changeset viewer.