run-tests.scm (4681B)
1 ;;; generic-ref-set --- Generic accessor and modifier operators. 2 3 ;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> 4 5 ;; Permission is hereby granted, free of charge, to any person obtaining 6 ;; a copy of this software and associated documentation files (the 7 ;; "Software"), to deal in the Software without restriction, including 8 ;; without limitation the rights to use, copy, modify, merge, publish, 9 ;; distribute, sublicense, and/or sell copies of the Software, and to 10 ;; permit persons to whom the Software is furnished to do so, subject to 11 ;; the following conditions: 12 13 ;; The above copyright notice and this permission notice shall be 14 ;; included in all copies or substantial portions of the Software. 15 16 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 24 (use-modules 25 ((scheme base) #:select (bytevector)) 26 (rnrs hashtables) 27 (srfi srfi-4) 28 (srfi srfi-64) 29 (srfi srfi-111) 30 (srfi srfi-123) 31 (rnrs records syntactic) 32 (rnrs records procedural) 33 (rnrs records inspection) 34 (rnrs exceptions) 35 ) 36 37 (define using-broken-srfi99 #f) 38 39 (define-record-type foo 40 (fields 41 (mutable a) 42 (immutable b)) 43 ) 44 45 (define (run-tests) 46 (let ((runner (test-runner-create))) 47 (parameterize ((test-runner-current runner)) 48 (test-begin "SRFI-123") 49 50 (test-begin "ref") 51 (test-assert "bytevector" (= 1 (ref (bytevector 0 1 2) 1))) 52 (test-assert "hashtable" (let ((table (make-eqv-hashtable))) 53 (hashtable-set! table 'foo 0) 54 (= 0 (ref table 'foo)))) 55 (test-assert "hashtable default" (let ((table (make-eqv-hashtable))) 56 (= 1 (ref table 0 1)))) 57 (test-assert "pair" (= 1 (ref (cons 0 1) 'cdr))) 58 (test-assert "list" (= 1 (ref (list 0 1 2) 1))) 59 (test-assert "string" (char=? #\b (ref "abc" 1))) 60 (test-assert "vector" (= 1 (ref (vector 0 1 2) 1))) 61 (test-assert "record" (= 1 (ref (make-foo 0 1) 'b))) 62 (values) 63 (test-assert "srfi-4" (= 1 (ref (s16vector 0 1 2) 1))) 64 (values) 65 (test-assert "srfi-111" (= 1 (ref (box 1) '*))) 66 (test-end "ref") 67 68 (test-assert "ref*" (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr))) 69 70 (test-begin "ref setter") 71 (test-assert "bytevector" (let ((bv (bytevector 0 1 2))) 72 (set! (ref bv 1) 3) 73 (= 3 (ref bv 1)))) 74 (test-assert "hashtable" (let ((ht (make-eqv-hashtable))) 75 (set! (ref ht 'foo) 0) 76 (= 0 (ref ht 'foo)))) 77 (test-assert "pair" (let ((p (cons 0 1))) 78 (set! (ref p 'cdr) 2) 79 (= 2 (ref p 'cdr)))) 80 (test-assert "list" (let ((l (list 0 1 2))) 81 (set! (ref l 1) 3) 82 (= 3 (ref l 1)))) 83 (test-assert "string" (let ((s (string #\a #\b #\c))) 84 (set! (ref s 1) #\d) 85 (char=? #\d (ref s 1)))) 86 (test-assert "vector" (let ((v (vector 0 1 2))) 87 (set! (ref v 1) 3) 88 (= 3 (ref v 1)))) 89 (test-assert "record" (let ((r (make-foo 0 1))) 90 (set! (ref r 'a) 2) 91 (= 2 (ref r 'a)))) 92 (when using-broken-srfi99 93 (test-expect-fail 1)) 94 (test-assert "bad record assignment" 95 (not (guard (err (else #f)) (set! (ref (make-foo 0 1) 'b) 2) #t))) 96 (values) 97 (test-assert "srfi-4" (let ((s16v (s16vector 0 1 2))) 98 (set! (ref s16v 1) 3) 99 (= 3 (ref s16v 1)))) 100 (values) 101 (test-assert "srfi-111" (let ((b (box 0))) 102 (set! (ref b '*) 1) 103 (= 1 (ref b '*)))) 104 (test-end "ref setter") 105 106 (test-assert "ref* setter" 107 (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_))) 108 (set! (ref* obj 1 1 'cdr) 2) 109 (= 2 (ref* obj 1 1 'cdr)))) 110 111 (test-end "SRFI-123") 112 (and (= 0 (test-runner-xpass-count runner)) 113 (= 0 (test-runner-fail-count runner)))))) 114 115 (if (run-tests) 116 (exit 0) 117 (exit 1))