~ chicken-core (chicken-5) /tests/test-scrutinizer-message-format.scm

 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     )))