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; extend-procedure 205 206(define (foo a b) (list a b)) 207 208(define unique-proc-data-1 '(23 'skidoo)) 209 210(define new-foo (extend-procedure foo unique-proc-data-1)) 211 212(assert (not (eq? foo new-foo))) 213 214(define foo new-foo) 215 216; extended-procedure? 217 218(assert (extended-procedure? foo)) 219 220; procedure-data 221 222(assert (eq? unique-proc-data-1 (procedure-data foo))) 223 224; set-procedure-data! 225 226(define unique-proc-data-2 '(23 'skidoo)) 227 228(set-procedure-data! foo unique-proc-data-2) 229 230(assert (eq? unique-proc-data-2 (procedure-data foo))) 231 232; block-set! 233 234(define some-block (vector 1 2 3 4)) 235 236(block-set! some-block 2 5) 237 238; block-ref 239 240(assert (= 5 (block-ref some-block 2))) 241 242; number-of-slots 243 244(assert (= 4 (number-of-slots some-block))) 245 246; number-of-bytes 247 248(assert (= 4 (number-of-bytes "abcd"))) 249 250(assert (= (if (feature? #:64bit) 8 4) (number-of-bytes '#(1)))) 251 252; make-record-instance 253 254(define some-record (make-record-instance 'test 'a 1)) 255 256(assert some-record) 257 258; record-instance? 259 260(assert (record-instance? some-record)) 261 262(assert (record-instance? some-record 'test)) 263 264; record-instance-type 265 266(assert (eq? 'test (record-instance-type some-record))) 267 268; record-instance-length 269 270(assert (= 2 (record-instance-length some-record))) 271 272; record-instance-slot-set! 273 274; record-instance-slot 275 276(assert (eq? 1 (record-instance-slot some-record 1))) 277 278(record-instance-slot-set! some-record 1 'b) 279 280(assert (eq? 'b (record-instance-slot some-record 1))) 281 282; record->vector 283 284(assert (equal? '#(test a b) (record->vector some-record))) 285 286; object-become! 287 288(define some-foo '#(1 2 3)) 289 290(define some-bar '(1 2 3)) 291 292(object-become! (list (cons some-foo '(1 2 3)) (cons some-bar '#(1 2 3)))) 293 294(assert (pair? some-foo)) 295 296(assert (vector? some-bar)) 297 298; mutate-procedure! 299 300(assert (equal? '(1 2) (foo 1 2))) 301 302(define new-foo 303 (mutate-procedure! foo (lambda (new) (lambda args (cons 'hello (apply new args)))))) 304 305(assert (not (eq? foo new-foo))) 306 307(assert (equal? '(hello 1 2) (foo 1 2))) 308 309; pointer vectors 310 311(define pv (make-pointer-vector 42 #f)) 312(assert (= 42 (pointer-vector-length pv))) 313(assert (not (pointer-vector-ref pv 0))) 314(pointer-vector-set! pv 1 (address->pointer 999)) 315(set! (pointer-vector-ref pv 40) (address->pointer 777)) 316(assert (not (pointer-vector-ref pv 0))) 317(assert (not (pointer-vector-ref pv 41))) 318(assert (= (pointer->address (pointer-vector-ref pv 1)) 999)) 319(assert (= (pointer->address (pointer-vector-ref pv 40)) 777)) 320(pointer-vector-fill! pv (address->pointer 1)) 321(assert (= 1 (pointer->address (pointer-vector-ref pv 0)))) 322 323#+(not csi) 324(begin 325 (define pv1 326 (foreign-lambda* bool ((pointer-vector pv)) 327 "C_return(pv == NULL);")) 328 (define pv2 329 (foreign-lambda* c-pointer ((pointer-vector pv) (bool f)) 330 "static void *xx = (void *)123;" 331 "if(f) pv[ 0 ] = xx;" 332 "C_return(xx);")) 333 (assert (eq? #t (pv1 #f))) 334 (define p (pv2 pv #t)) 335 (assert (pointer=? p (pv2 pv #f)))) 336