~ chicken-core (master) /tests/srfi-4-tests.scm

  1;;;; srfi-4-tests.scm
  2
  3
  4(import (chicken number-vector) (chicken port))
  5(import-for-syntax (chicken base))
  6
  7(define-syntax test1
  8  (er-macro-transformer
  9   (lambda (x r c)
 10     (let* ((t (strip-syntax (cadr x)))
 11	    (name (symbol->string (strip-syntax t)))
 12	    (min (caddr x))
 13	    (max (cadddr x)))
 14       (define (conc op)
 15	 (string->symbol (string-append name op)))
 16       `(let ((x (,(conc "vector") 100 101)))
 17	  (assert (eqv? 100 (,(conc "vector-ref") x 0)))
 18	  (assert (,(conc "vector?") x))
 19	  (assert (number-vector? x))
 20	  ;; Test direct setter and ref
 21	  (,(conc "vector-set!") x 1 99)
 22	  (assert (eqv? 99 (,(conc "vector-ref") x 1)))
 23	  ;; Test SRFI-17 generalised set! and ref
 24	  (set! (,(conc "vector-ref") x 0) 127)
 25	  (assert (eqv? 127 (,(conc "vector-ref") x 0)))
 26	  ;; Ensure length is okay
 27	  (assert (= 2 (,(conc "vector-length") x)))
 28	  (assert
 29	   (let ((result (,(conc "vector->list") x)))
 30	     (and (eqv? 127 (car result))
 31		  (eqv? 99 (cadr result))))))))))
 32
 33(define-syntax test-subv
 34  (er-macro-transformer
 35    (lambda (x r c)
 36      (let* ((t (strip-syntax (cadr x)))
 37	     (make (symbol-append 'make- t 'vector))
 38	     (subv (symbol-append 'sub   t 'vector))
 39	     (len  (symbol-append t 'vector-length)))
 40	`(let ((x (,make 10)))
 41	   (assert (eq? (,len (,subv x 0 5)) 5)))))))
 42
 43(test-subv u8)
 44(test-subv s8)
 45(test-subv u16)
 46(test-subv s16)
 47(test-subv u32)
 48(test-subv s32)
 49(test-subv u64)
 50(test-subv s64)
 51
 52(test1 u8 0 255)
 53(test1 u16 0 65535)
 54(test1 u32 0 4294967295)
 55(test1 u64 0 18446744073709551615)
 56(test1 s8 -128 127)
 57(test1 s16 -32768 32767)
 58(test1 s32 -2147483648 2147483647)
 59(test1 s64 -9223372036854775808 9223372036854775807)
 60
 61(define-syntax test2
 62  (er-macro-transformer
 63   (lambda (x r c)
 64     (let* ((t (strip-syntax (cadr x)))
 65	    (name (symbol->string (strip-syntax t))))
 66       (define (conc op)
 67	 (string->symbol (string-append name op)))
 68       `(let ((x (,(conc "vector") 100 101.0)))
 69	  (assert (eqv? 100.0 (,(conc "vector-ref") x 0)))
 70	  (assert (eqv? 101.0 (,(conc "vector-ref") x 1)))
 71	  (assert (,(conc "vector?") x))
 72	  (assert (number-vector? x))
 73	  (,(conc "vector-set!") x 1 99)
 74	  (assert (eqv? 99.0 (,(conc "vector-ref") x 1)))
 75	  (assert (= 2 (,(conc "vector-length") x)))
 76          (assert
 77	   (let ((result (,(conc "vector->list") x)))
 78	     (and (eqv? 100.0 (car result))
 79		  (eqv? 99.0 (cadr result))))))))))
 80
 81(test2 f32)
 82(test2 f64)
 83
 84;; Test implicit quoting/self evaluation
 85(assert (equal? #u8(1 2 3) '#u8(1 2 3)))
 86(assert (equal? #s8(-1 2 3) '#s8(-1 2 3)))
 87(assert (equal? #u16(1 2 3) '#u16(1 2 3)))
 88(assert (equal? #s16(-1 2 3) '#s16(-1 2 3)))
 89(assert (equal? #u32(1 2 3) '#u32(1 2 3)))
 90(assert (equal? #u64(1 2 3) '#u64(1 2 3)))
 91(assert (equal? #s32(-1 2 3) '#s32(-1 2 3)))
 92(assert (equal? #s64(-1 2 3) '#s64(-1 2 3)))
 93(assert (equal? #f32(1 2 3) '#f32(1 2 3)))
 94(assert (equal? #f64(-1 2 3) '#f64(-1 2 3)))
 95
 96; make sure the N parameter is a fixnum
 97(assert
 98  (handle-exceptions exn #t
 99    (make-f64vector 4.0) #f))
100; catch the overflow
101(assert
102  (handle-exceptions exn #t
103    (make-f64vector most-positive-fixnum) #f))
104
105;; test special read-syntax
106
107(let ((cases '(("#u8(1 2 #\\A)" #u8(1 2 65))
108               ("#u8(\"abc\")" #u8(97 98 99))
109               ("#u8\"abc\"" #u8(97 98 99))
110               ("#u8(\"abc\")" #u8(97 98 99))
111               ("#u8(\"ab\" \"c\")" #u8(97 98 99))
112               ("#u8(\"a\" \"b\" \"c\")" #u8(97 98 99))
113               ("#u8\"🐔\""               #u8(#xf0 #x9f #x90 #x94))
114               ("#u8(#\\🐔)"              #u8(#xf0 #x9f #x90 #x94))
115               ("#u8(\"🐔\"      \"🏫\")" #u8(#xf0 #x9f #x90 #x94   #xf0 #x9f #x8f #xab))
116               ("#u8(\"🐔\" \"\" \"🏫\")" #u8(#xf0 #x9f #x90 #x94   #xf0 #x9f #x8f #xab))
117               ("#u8(#\\🐔       \"🏫\")" #u8(#xf0 #x9f #x90 #x94   #xf0 #x9f #x8f #xab))
118               ("#u8(\"🐔\"       #\\🏫)" #u8(#xf0 #x9f #x90 #x94   #xf0 #x9f #x8f #xab))
119               ("#u8(\"🐔\"   0   #\\🏫)" #u8(#xf0 #x9f #x90 #x94 0 #xf0 #x9f #x8f #xab))
120               ("#u8(\"\")" #u8())
121               ("#u8(\"\" \"a\")" #u8(97))
122               ("#u8(\"a\" \"\")" #u8(97))
123               ("#u8\"\"" #u8())
124               ("#s8\"\"" #s8())
125               ("#u64(\" \" #\\! 1 \"A\")" #u64(32 33 1 65))
126               ("#u64(\" \" #\\! \"A\" 1)" #u64(32 33 65 1))
127               ("#u64(\"🐔\"      \"🏫\")" #u64(#xf0 #x9f #x90 #x94   #xf0 #x9f #x8f #xab)))))
128  (do ((cs cases (cdr cs)))
129      ((null? cs))
130      (let ((x (with-input-from-string (caar cs) read)))
131        (unless (equal? x (cadar cs))
132          (error "failed" x (caar cs))))))
133
134;; complex vectors
135
136(define (dot v1 v2 n ref)
137  (do ((i 0 (add1 i))
138  	   (sum 0 (+ sum (* (ref v1 i) (ref v2 i)))))
139  	  ((>= i n) sum)))
140
141(assert
142  (= 1-i
143     (dot '#c64(1+i 1-i 0) '#c64(-i 0 2-i) 3 c64vector-ref)))
144(assert
145  (= 1-i
146     (dot '#c128(1+i 1-i 0) '#c128(-i 0 2-i) 3 c128vector-ref)))
147
148(assert
149  (= -1-i
150     (dot (c64vector 1+i 1-i 0) (c64vector 2+i 1-3i 0+2i) 3 c64vector-ref)))
151(assert
152  (= -1-i
153     (dot (c128vector 1+i 1-i 0) (c128vector 2+i 1-3i 0+2i) 3 c128vector-ref)))