1(import (chicken time)) 2 3(: deprecated-foo deprecated) 4(define deprecated-foo 1) 5(: deprecated-foo2 (deprecated foo)) 6(define deprecated-foo2 2) 7(: foo boolean) 8(define foo #t) 9 10(define (r-proc-call-argument-count-mismatch) (cons '())) 11(define (r-proc-call-argument-type-mismatch) (length 'symbol)) 12(define (r-proc-call-argument-value-count) (list (cpu-time)) (vector (values)) ((values))) 13(define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (values 1 2))) 14(define (r-invalid-called-procedure-type) (1 2)) 15(define (r-pred-call-always-true) (list? '())) 16(define (r-pred-call-always-false) (symbol? 1)) 17(define (r-cond-test-always-true) (if 'symbol 1)) 18(define (r-cond-test-always-false) (if #f 1)) 19(define (r-type-mismatch-in-the) (the symbol 1)) 20(define (r-zero-values-for-the) (the symbol (values))) 21(define (r-too-many-values-for-the) (the symbol (values 1 2))) 22(define (r-toplevel-var-assignment-type-mismatch) (set! foo 1)) 23(define (r-deprecated-identifier) (list deprecated-foo) (vector deprecated-foo2)) 24 25(set! foo 1) 26 27;; These have special cases 28(define (list-ref-negative-index) (list-ref '() -1)) 29(define (list-ref-out-of-range) (list-ref '() 1)) 30(define (append-invalid-arg) (append 1 (list 1))) 31(define (vector-ref-out-of-range) (vector-ref (vector) -1)) 32 33;; This is disabled because fail-compiler-typecase is a fatal warning 34;; (define (fail-compiler-typecase) (compiler-typecase 1 (symbol 1) (list 2))) 35 36(module 37 m 38 () 39 (import scheme) 40 (import (chicken base) (chicken type) (chicken time)) 41 42 (: foo2 boolean) 43 (define foo2 #t) 44 (: deprecated-foo deprecated) 45 (define deprecated-foo 1) 46 (: deprecated-foo2 (deprecated foo)) 47 (define deprecated-foo2 2) 48 49 (define (toplevel-foo) 50 (define (local-bar) 51 (define (r-proc-call-argument-count-mismatch) (cons '())) 52 (define (r-proc-call-argument-type-mismatch) (length 'symbol)) 53 (define (r-proc-call-argument-value-count) (list (cpu-time)) (vector (values))) 54 (define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (cpu-time))) 55 (define (r-invalid-called-procedure-type) 56 (define (variable) (foo2 2)) 57 (define (non-variable) (1 2))) 58 (define (r-pred-call-always-true) (list? '())) 59 (define (r-pred-call-always-false) (symbol? 1)) 60 (define (r-cond-test-always-true) (if (length '()) 1)) 61 (define (r-cond-test-always-false) (if #f 1)) 62 (define (r-type-mismatch-in-the) (the symbol 1)) 63 (define (r-zero-values-for-the) (the symbol (values))) 64 (define (r-too-many-values-for-the) (the symbol (values 1 2))) 65 (define (r-toplevel-var-assignment-type-mismatch) (set! foo2 1)) 66 (define (r-deprecated-identifier) (list deprecated-foo) (vector deprecated-foo2)) 67 68 (define (r-let-value-count-invalid) 69 (define (zero-values-for-let) (let ((a (values))) a)) 70 (define (too-many-values-for-let) (let ((a (values 1 2))) a))) 71 (define (r-conditional-value-count-invalid) 72 (define (zero-values-for-conditional) (if (values) 1)) 73 (define (too-many-values-for-conditional) (if (values (the * 1) 2) 1))) 74 (define (r-assignment-value-count-invalid) 75 (define (zero-values-for-assignment) (set! foo (values))) 76 (define (too-many-values-for-assignment) (set! foo (values #t 2)))) 77 78 ;; These have special cases 79 (define (list-ref-negative-index) (list-ref '() -1)) 80 (define (list-ref-out-of-range) (list-ref '() 1)) 81 (define (append-invalid-arg) (append 1 (list 1))) 82 (define (vector-ref-out-of-range) (vector-ref (vector) -1)) 83 84 (define (r-cond-test-always-true-with-pred) (if (symbol? 'symbol) 1)) 85 (define (r-cond-test-always-false-with-pred) (if (symbol? 1) 1)) 86 87 (define (fail-compiler-typecase) (compiler-typecase 1 (symbol 1) (list 2))) 88 ))) 89