~ chicken-core (chicken-5) /tests/specialization-test-1.scm

 1;;;; specialization-test-1.scm
 2
 3
 4(module foo (foo bar)
 5(import scheme chicken.base chicken.foreign chicken.type)
 6
 7#>
 8static int inlined(int i) {
 9static int n = 0;
10n += i;
11return n;}
12<#
13
14(: foo (fixnum -> fixnum))
15
16(define (foo i)
17  (print "foo: " i)
18  0)
19
20(: bar (number -> fixnum)
21   ((fixnum) (##core#inline "inlined" #(1))))
22
23(define (bar i)
24  (print "bar: " i)
25  0)
26
27(assert (zero? (foo 1)))
28(assert (zero? (bar 1.0)))
29(assert (= 1 (bar 1)))
30
31(: spec (* -> *))
32(define (spec x) x)
33
34(define-specialization (spec (x fixnum)) fixnum
35  (+ x 1))
36
37(assert (= 2 (spec 1)))
38
39;; "smash-component-types!" had to convert "list[-of]" types to "pair" (#803)
40(let ((x (list 'a)))
41  (set-cdr! x x)
42  (assert (not (list? x))))
43
44;(define (some-proc x y) (if (string->number y) (set-cdr! x x) x))
45;(assert (null? (some-proc (list) "invalid number syntax")))
46
47(assert (null? (the (or undefined *) (list))))
48
49;; Ensure a foreign-primitive returning multiple values with C_values()
50;; isn't specialized to a single result.
51(let ((result (receive ((foreign-primitive ()
52			  "C_word av[ 4 ];"
53			  "av[ 0 ] = C_SCHEME_UNDEFINED;"
54			  "av[ 1 ] = C_k;"
55			  "av[ 2 ] = C_fix(1);"
56			  "av[ 3 ] = C_fix(2);"
57			  "C_values(4, av);")))))
58  (assert (equal? '(1 2) result)))
59
60;; dropped conditional branch is ignored
61(compiler-typecase (if #t 'a "a")
62  (symbol 1))
63
64;; specializations are prioritized by order of appearance
65(: abc (* -> boolean))
66(define (abc x) #f)
67(define-specialization (abc (x number)) #t)
68(define-specialization (abc (x fixnum)) #f)
69(assert (abc 1))
70
71;; user-defined specializations take precedence over built-ins
72(: foo (-> fixnum))
73(define (foo) (begin))
74(define-specialization (+ fixnum) fixnum 1)
75(assert (= (+ (foo)) 1))
76
77)