~ chicken-core (chicken-5) /tests/lolevel-tests.scm

  1;;;; Unit lolevel testing
  2
  3(import chicken.format chicken.locative chicken.platform
  4        chicken.memory chicken.memory.representation srfi-4)
  5
  6(define-syntax assert-error
  7  (syntax-rules ()
  8    ((_ expr) 
  9     (assert (handle-exceptions _ #t expr #f)))))
 10
 11; move-memory!
 12
 13(let ((s "..."))
 14  (assert-error (move-memory! "abc" s 3 -1)))
 15
 16; overlapping src and dest, moving "right" (from SRFI-13 tests)
 17(assert (string=?
 18	 "aabce"
 19	 (let ((str (string-copy "abcde")))
 20	   (move-memory! str str 3 0 1) str)))
 21;; Specialisation rewrite from types.db
 22(assert (string=?
 23	 "aabce"
 24	 (let ((str (string-copy "abcde")))
 25	   (move-memory! (make-locative str) (make-locative str) 3 0 1) str)))
 26
 27; overlapping src and dest, moving "left" (from SRFI-13 tests)
 28(assert (string=?
 29	 "bcdde"
 30	 (let ((str (string-copy "abcde")))
 31	   (move-memory! str str 3 1) str)))
 32;; Specialisation rewrite from types.db
 33(assert (string=?
 34	 "bcdde"
 35	 (let ((str (string-copy "abcde")))
 36	   (move-memory! (make-locative str) (make-locative str) 3 1) str)))
 37
 38; object-copy
 39
 40; allocate
 41
 42(define some-chunk (allocate 23))
 43
 44(assert some-chunk)
 45
 46; free
 47
 48(free some-chunk)
 49
 50(define some-chunk (allocate 23))
 51
 52; pointer?
 53
 54(assert (pointer? some-chunk))
 55
 56; pointer-like?
 57
 58(assert (pointer-like? some-chunk))
 59
 60(assert (pointer-like? allocate))
 61
 62; address->pointer
 63
 64; pointer->address
 65
 66; object->pointer
 67
 68; pointer->object
 69
 70; pointer=?
 71
 72(assert (pointer=? some-chunk (address->pointer (pointer->address some-chunk))))
 73
 74; pointer+
 75
 76(assert (pointer=? (address->pointer #x9) (pointer+ (address->pointer #x5) #x4)))
 77
 78; align-to-word
 79
 80; pointer-u8-set!
 81
 82; pointer-s8-set!
 83
 84; pointer-u16-set!
 85
 86; pointer-s16-set!
 87
 88; pointer-u32-set!
 89
 90; pointer-s32-set!
 91
 92; pointer-u64-set!
 93
 94; pointer-s64-set!
 95
 96; pointer-f32-set!
 97
 98; pointer-f64-set!
 99
100; pointer-u8-ref
101
102(set! (pointer-u8-ref some-chunk) 255)
103
104(assert (= 255 (pointer-u8-ref some-chunk)))
105
106; pointer-s8-ref
107
108(set! (pointer-s8-ref some-chunk) -1)
109
110(assert (= -1 (pointer-s8-ref some-chunk)))
111
112; pointer-u16-ref
113
114; pointer-s16-ref
115
116; pointer-u32-ref
117
118; pointer-s32-ref
119
120; pointer-u64-ref
121
122; pointer-s64-ref
123
124; pointer-f32-ref
125
126; pointer-f64-ref
127
128; tag-pointer
129
130(define some-unique-tag '#(vector foo bar))
131
132(define some-tagged-pointer (tag-pointer some-chunk some-unique-tag))
133
134(assert some-tagged-pointer)
135
136; tagged-pointer?
137
138(assert (tagged-pointer? some-tagged-pointer))
139
140(assert (tagged-pointer? some-tagged-pointer some-unique-tag))
141
142; pointer-tag
143
144(assert (eq? some-unique-tag (pointer-tag some-tagged-pointer)))
145
146; make-locative, locative-ref, locative-set!, locative?
147
148;; Reverse an object vector of the given type by going through
149;; locatives.
150(define-syntax check-type-locative
151  (ir-macro-transformer
152   (lambda (e i c)
153     (let* ((type (strip-syntax (cadr e)))
154	    (inits (cddr e))
155	    (size (length inits))
156	    (construct type)
157	    (make (i (symbol-append 'make- type)))
158	    (ref (i (symbol-append type '-ref))))
159       `(let* ((old (,construct ,@inits))
160	       (new (,make ,size)))
161	  ;; Copy first
162	  (do ((i 0 (add1 i)))
163	      ((= i ,size))
164	    (let ((loc-src (make-locative old i))
165		  (loc-dst (make-locative new (- ,size i 1))))
166	      (assert (locative? loc-src))
167	      (assert (locative? loc-dst))
168	      (locative-set! loc-dst (locative-ref loc-src))))
169	  (printf "\nold: ~S\nnew: ~S\n" old new)
170	  ;; Now compare (unroll loop for better error reporting)
171	  ,@(let lp ((i 0) (res '()))
172	      (if (= i size)
173		  res
174		  (lp (add1 i)
175		      ;; Note: we must use eqv? because extraction
176		      ;; may cause fresh object allocation.
177		      (cons `(assert (eqv? (,ref old ,i)
178					   (,ref new ,(- size i 1))))
179			    res)))))))))
180
181(check-type-locative string #\nul #\y #\o #\xff)
182(check-type-locative vector 'yo 1 2 #f #t '(1 2 3) #(1 2 3))
183(check-type-locative u8vector 0 1 2 #xfe #xff)
184(check-type-locative s8vector #x-80 #x-7f -2 -1 0 1 2 #x7e #x7f)
185(check-type-locative u16vector 0 1 2 #xfffe #xffff)
186(check-type-locative s16vector #x-8000 #x-7fff -2 -1 0 1 2 #x7ffe #x7fff)
187(check-type-locative u32vector 0 1 2 #xfffffffe #xffffffff)
188(check-type-locative s32vector
189		     #x-80000000 #x-7fffffff -2 -1
190		     0 1 2 #x7ffffffe #x7fffffff)
191(check-type-locative u64vector
192		     0 1 2 #xfffffffffffffffe #xffffffffffffffff)
193(check-type-locative s64vector
194		     #x-8000000000000000 #x-7fffffffffffffff -2 -1
195		     0 1 2 #x7ffffffffffffffe #x7fffffffffffffff)
196;; TODO: better/more extreme values?
197(check-type-locative f32vector -1e100 -2.0 -1.0 0.0 1.0 2.0 1e100)
198(check-type-locative f64vector -1e200 -2.0 -1.0 0.0 1.0 2.0 1e200)
199
200; make-weak-locative
201
202; locative->object
203
204; locative-index
205
206;; Default index (0)
207(assert (= 0 (locative-index (make-locative '(0 . 1)))))
208(assert (= 0 (locative-index (make-locative #(a b c d e)))))
209(assert (= 0 (locative-index (make-locative "abcde"))))
210(assert (= 0 (locative-index (make-locative #${012345}))))
211(assert (= 0 (locative-index (make-locative #u8(0 1 2 3 4)))))
212(assert (= 0 (locative-index (make-locative #s8(0 1 2 3 4)))))
213(assert (= 0 (locative-index (make-locative #u16(0 1 2 3 4)))))
214(assert (= 0 (locative-index (make-locative #s16(0 1 2 3 4)))))
215(assert (= 0 (locative-index (make-locative #u32(0 1 2 3 4)))))
216(assert (= 0 (locative-index (make-locative #s32(0 1 2 3 4)))))
217(assert (= 0 (locative-index (make-locative #u64(0 1 2 3 4)))))
218(assert (= 0 (locative-index (make-locative #s64(0 1 2 3 4)))))
219(assert (= 0 (locative-index (make-locative #f32(0 1 2 3 4)))))
220(assert (= 0 (locative-index (make-locative #f64(0 1 2 3 4)))))
221
222;; Given index argument
223(assert (= 1 (locative-index (make-locative '(0 . 1) 1))))
224(assert (= 2 (locative-index (make-locative #(a b c d e) 2))))
225(assert (= 3 (locative-index (make-locative "abcde" 3))))
226(assert (= 2 (locative-index (make-locative #${01234} 2))))
227(assert (= 1 (locative-index (make-locative #u8(0 1 2 3 4) 1))))
228(assert (= 2 (locative-index (make-locative #s8(0 1 2 3 4) 2))))
229(assert (= 3 (locative-index (make-locative #u16(0 1 2 3 4) 3))))
230(assert (= 2 (locative-index (make-locative #s16(0 1 2 3 4) 2))))
231(assert (= 1 (locative-index (make-locative #u32(0 1 2 3 4) 1))))
232(assert (= 2 (locative-index (make-locative #s32(0 1 2 3 4) 2))))
233(assert (= 3 (locative-index (make-locative #u64(0 1 2 3 4) 3))))
234(assert (= 2 (locative-index (make-locative #s64(0 1 2 3 4) 2))))
235(assert (= 1 (locative-index (make-locative #f32(0 1 2 3 4) 1))))
236(assert (= 2 (locative-index (make-locative #f64(0 1 2 3 4) 2))))
237
238; extend-procedure
239
240(define (foo a b) (list a b))
241
242(define unique-proc-data-1 '(23 'skidoo))
243
244(define new-foo (extend-procedure foo unique-proc-data-1))
245
246(assert (not (eq? foo new-foo)))
247
248(define foo new-foo)
249
250; extended-procedure?
251
252(assert (extended-procedure? foo))
253
254; procedure-data
255
256(assert (eq? unique-proc-data-1 (procedure-data foo)))
257
258; set-procedure-data!
259
260(define unique-proc-data-2 '(23 'skidoo))
261
262(set-procedure-data! foo unique-proc-data-2)
263
264(assert (eq? unique-proc-data-2 (procedure-data foo)))
265
266; block-set!
267
268(define some-block (vector 1 2 3 4))
269
270(block-set! some-block 2 5)
271
272; block-ref
273
274(assert (= 5 (block-ref some-block 2)))
275
276; number-of-slots
277
278(assert (= 4 (number-of-slots some-block)))
279
280; number-of-bytes
281
282(assert (= 4 (number-of-bytes "abcd")))
283
284(assert (= (if (feature? #:64bit) 8 4) (number-of-bytes '#(1))))
285
286; make-record-instance
287
288(define some-record (make-record-instance 'test 'a 1))
289
290(assert some-record)
291
292; record-instance?
293
294(assert (record-instance? some-record))
295
296(assert (record-instance? some-record 'test))
297
298; record-instance-type
299
300(assert (eq? 'test (record-instance-type some-record)))
301
302; record-instance-length
303
304(assert (= 2 (record-instance-length some-record)))
305
306; record-instance-slot-set!
307
308; record-instance-slot
309
310(assert (eq? 1 (record-instance-slot some-record 1)))
311
312(record-instance-slot-set! some-record 1 'b)
313
314(assert (eq? 'b (record-instance-slot some-record 1)))
315
316; record->vector
317
318(assert (equal? '#(test a b) (record->vector some-record)))
319
320; object-become!
321
322(define some-foo '#(1 2 3))
323
324(define some-bar '(1 2 3))
325
326(object-become! (list (cons some-foo '(1 2 3)) (cons some-bar '#(1 2 3))))
327
328(assert (pair? some-foo))
329
330(assert (vector? some-bar))
331
332; mutate-procedure!
333
334(assert (equal? '(1 2) (foo 1 2)))
335
336(define new-foo
337  (mutate-procedure! foo (lambda (new) (lambda args (cons 'hello (apply new args))))))
338
339(assert (not (eq? foo new-foo)))
340
341(assert (equal? '(hello 1 2) (foo 1 2)))
342
343; pointer vectors
344
345(define pv (make-pointer-vector 42 #f))
346(assert (= 42 (pointer-vector-length pv)))
347(assert (not (pointer-vector-ref pv 0)))
348(pointer-vector-set! pv 1 (address->pointer 999))
349(set! (pointer-vector-ref pv 40) (address->pointer 777))
350(assert (not (pointer-vector-ref pv 0)))
351(assert (not (pointer-vector-ref pv 41)))
352(assert (= (pointer->address (pointer-vector-ref pv 1)) 999))
353(assert (= (pointer->address (pointer-vector-ref pv 40)) 777))
354(pointer-vector-fill! pv (address->pointer 1))
355(assert (= 1 (pointer->address (pointer-vector-ref pv 0))))
356
357#+(not csi)
358(begin
359  (define pv1
360    (foreign-lambda* bool ((pointer-vector pv))
361      "C_return(pv == NULL);"))
362  (define pv2
363    (foreign-lambda* c-pointer ((pointer-vector pv) (bool f))
364      "static void *xx = (void *)123;"
365      "if(f) pv[ 0 ] = xx;"
366      "C_return(xx);"))
367  (assert (eq? #t (pv1 #f)))
368  (define p (pv2 pv #t))
369  (assert (pointer=? p (pv2 pv #f))))