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