~ 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(\"\")" #u8())
111               ("#u8(\"\" \"a\")" #u8(97))
112               ("#u8(\"a\" \"\")" #u8(97))
113               ("#u8\"\"" #u8())
114               ("#s8\"\"" #s8())
115               ("#u64(\" \" #\\! 1 \"A\")" #u64(32 33 1 65))
116               ("#u64(\" \" #\\! \"A\" 1)" #u64(32 33 65 1)))))
117  (do ((cs cases (cdr cs)))
118      ((null? cs))
119      (let ((x (with-input-from-string (caar cs) read)))
120        (unless (equal? x (cadar cs))
121          (error "failed" x (cadar cs))))))