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

  1;;;; srfi-4-tests.scm
  2
  3
  4(import (srfi 4) (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;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.
 97(let ((input (open-input-string "abcdefghijklmnopqrstuvwxyz"))
 98      (u8vec (make-u8vector 10)))
 99  (assert (= 10 (read-u8vector! #f u8vec input)))
100  (assert (equal? u8vec #u8(97 98 99 100 101 102 103 104 105 106)))
101  (assert (= 5  (read-u8vector! #f u8vec input 5)))
102  (assert (equal? u8vec #u8(97 98 99 100 101 107 108 109 110 111)))
103  (assert (= 5  (read-u8vector! 5  u8vec input)))
104  (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))
105  (assert (= 6  (read-u8vector! 10 u8vec input)))
106  (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))
107
108(let ((input (open-input-string "abcdefghijklmnopqrs")))
109  (assert (equal? (read-u8vector 5 input)
110		  #u8(97 98 99 100 101)))
111  (assert (equal? (read-u8vector 5 input) #u8(102 103 104 105 106)))
112  (assert (equal? (read-u8vector #f input)
113		  #u8(107 108 109 110 111 112 113 114 115)))
114  (with-input-from-string "abcdefghijklmnopqrs"
115   (lambda ()
116     (assert (equal? (read-u8vector 5)
117		     #u8(97 98 99 100 101)))
118     (assert (equal? (read-u8vector 5) #u8(102 103 104 105 106)))
119     (assert (equal? (read-u8vector)
120		     #u8(107 108 109 110 111 112 113 114 115))))))
121
122(assert (string=?
123	 "abc"
124	 (with-output-to-string
125	   (lambda ()
126	     (write-u8vector #u8(97 98 99))))))
127
128(assert (string=?
129	 "bc"
130	 (with-output-to-string
131	   (lambda ()
132	     (write-u8vector #u8(97 98 99) (current-output-port) 1)))))
133
134(assert (string=?
135	 "a"
136	 (with-output-to-string
137	   (lambda ()
138	     (write-u8vector #u8(97 98 99) (current-output-port) 0 1)))))
139
140(assert (string=?
141	 "b"
142	 (with-output-to-string
143	   (lambda ()
144	     (write-u8vector #u8(97 98 99) (current-output-port) 1 2)))))
145
146(assert (string=?
147	 ""
148	 (with-output-to-string
149	   (lambda ()
150	     (write-u8vector #u8())))))
151
152; make sure the N parameter is a fixnum
153(assert
154  (handle-exceptions exn #t
155    (make-f64vector 4.0) #f))
156; catch the overflow
157(assert
158  (handle-exceptions exn #t
159    (make-f64vector most-positive-fixnum) #f))
160
161;; test special read-syntax
162
163(let ((cases '(("#u8(1 2 #\\A)" #u8(1 2 65))
164               ("#u8(\"abc\")" #u8(97 98 99))
165               ("#u8\"abc\"" #u8(97 98 99))
166               ("#u8(\"\")" #u8())
167               ("#u8(\"\" \"a\")" #u8(97))
168               ("#u8(\"a\" \"\")" #u8(97))
169               ("#u8\"\"" #u8())
170               ("#s8\"\"" #s8())
171               ("#u64(\" \" #\\! 1 \"A\")" #u64(32 33 1 65))
172               ("#u64(\" \" #\\! \"A\" 1)" #u64(32 33 65 1)))))
173  (do ((cs cases (cdr cs)))
174      ((null? cs))
175      (let ((x (with-input-from-string (caar cs) read)))
176        (unless (equal? x (cadar cs))
177          (error "failed" x (cadar cs))))))