1;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*- 2;;;; 3;;;; Copyright (C) 2009-2010, 2019 Free Software Foundation, Inc. 4;;;; 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 3 of the License, or (at your option) any later version. 9;;;; 10;;;; This library is distributed in the hope that it will be useful, 11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;;;; Lesser General Public License for more details. 14;;;; 15;;;; You should have received a copy of the GNU Lesser General Public 16;;;; License along with this library; if not, write to the Free Software 17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 18 19(define-module (test-records) 20 #:use-module (ice-9 format) 21 #:use-module (test-suite lib)) 22 23;; ascii names and symbols, custom printer 24(define rtd-foo (make-record-type 'foo '(x y) 25 (lambda (s p) 26 (display "#<it is a foo>" p)))) 27(define make-foo (record-constructor rtd-foo)) 28(define foo? (record-predicate rtd-foo)) 29(define get-foo-x (record-accessor rtd-foo 'x)) 30(define get-foo-y (record-accessor rtd-foo 'y)) 31(define set-foo-x! (record-modifier rtd-foo 'x)) 32(define set-foo-y! (record-modifier rtd-foo 'y)) 33 34;; non-Latin-1 names and symbols, default printer 35(define rtd-fŏŏ (make-record-type 'fŏŏ '(x ȳ))) 36(define make-fŏŏ (record-constructor rtd-fŏŏ)) 37(define fŏŏ? (record-predicate rtd-fŏŏ)) 38(define get-fŏŏ-x (record-accessor rtd-fŏŏ 'x)) 39(define get-fŏŏ-ȳ (record-accessor rtd-fŏŏ 'ȳ)) 40(define set-fŏŏ-x! (record-modifier rtd-fŏŏ 'x)) 41(define set-fŏŏ-ȳ! (record-modifier rtd-fŏŏ 'ȳ)) 42 43(with-test-prefix "records" 44 45 (with-test-prefix "constructor" 46 47 (pass-if-exception "0 args (2 required)" exception:wrong-num-args 48 (make-foo)) 49 50 (pass-if-exception "1 arg (2 required)" exception:wrong-num-args 51 (make-foo 1)) 52 53 (pass-if "2 args (2 required)" exception:wrong-num-args 54 (foo? (make-foo 1 2))) 55 56 (pass-if "non-latin-1" exception:wrong-num-args 57 (fŏŏ? (make-fŏŏ 1 2)))) 58 59 (with-test-prefix "modifier and getter" 60 61 (pass-if "set" 62 (let ((r (make-foo 1 2))) 63 (set-foo-x! r 3) 64 (eqv? (get-foo-x r) 3))) 65 66 (pass-if "set 2" 67 (let ((r (make-fŏŏ 1 2))) 68 (set-fŏŏ-ȳ! r 3) 69 (eqv? (get-fŏŏ-ȳ r) 3)))) 70 71 (with-test-prefix "record type name" 72 73 (pass-if "foo" 74 (string=? "foo" (symbol->string (record-type-name rtd-foo)))) 75 76 (pass-if "fŏŏ" 77 (string=? "fŏŏ" (symbol->string (record-type-name rtd-fŏŏ))))) 78 79 (with-test-prefix "printer" 80 81 (pass-if "foo" 82 (string=? "#<it is a foo>" 83 (with-output-to-string 84 (lambda () (display (make-foo 1 2)))))) 85 86 (pass-if "fŏŏ" 87 (with-locale "en_US.utf8" 88 (string-prefix? "#<fŏŏ" 89 (with-output-to-string 90 (lambda () (display (make-fŏŏ 1 2)))))))) 91 92 (with-test-prefix "subtyping" 93 (let () 94 (define a (make-record-type 'a '(s t))) 95 (define b (make-record-type 'b '(u v) #:extensible? #t)) 96 (define c (make-record-type 'c '(w x) #:parent b)) 97 98 (pass-if (not (record-type-extensible? a))) 99 (pass-if (record-type-extensible? b)) 100 (pass-if (not (record-type-extensible? c))) 101 102 (pass-if-exception "subtyping final: a" '(misc-error . "final") 103 (make-record-type 'd '(y x) #:parent a)) 104 (pass-if-exception "subtyping final: c" '(misc-error . "final") 105 (make-record-type 'd '(y x) #:parent c)) 106 107 (pass-if-equal "fields of subtype" '(u v w x) 108 (record-type-fields c)) 109 110 (pass-if "final predicate: a? a" 111 ((record-predicate a) ((record-constructor a) 1 2))) 112 (pass-if "final predicate: a? b" 113 (not ((record-predicate a) ((record-constructor b) 1 2)))) 114 115 (pass-if "non-final predicate: b? a" 116 (not ((record-predicate b) ((record-constructor a) 1 2)))) 117 (pass-if "non-final predicate: b? b" 118 ((record-predicate b) ((record-constructor b) 1 2))) 119 (pass-if "non-final predicate: b? c" 120 ((record-predicate b) ((record-constructor c) 1 2 3 4))) 121 122 (pass-if "final predicate: c? a" 123 (not ((record-predicate c) ((record-constructor a) 1 2)))) 124 (pass-if "final predicate: c? b" 125 (not ((record-predicate c) ((record-constructor b) 1 2)))) 126 (pass-if "final predicate: c? c" 127 ((record-predicate c) ((record-constructor c) 1 2 3 4))) 128 129 (pass-if-equal "b accessor on b" 1 130 ((record-accessor b 'u) ((record-constructor b) 1 2))) 131 (pass-if-equal "b accessor on c" 1 132 ((record-accessor b 'u) ((record-constructor c) 1 2 3 4))) 133 134 (pass-if-equal "c accessor on c" 3 135 ((record-accessor c 'w) ((record-constructor c) 1 2 3 4))))) 136 137 (with-test-prefix "prefab types" 138 (let () 139 (define uid 'ANhUpf2WpNnF2XIVLxq@IkavIc5wbqe8) 140 (define a (make-record-type 'a '(s t) #:uid uid)) 141 (define b (make-record-type 'b '() #:extensible? #t)) 142 143 (pass-if (eq? a (make-record-type 'a '(s t) #:uid uid))) 144 (pass-if-exception "different name" '(misc-error . "incompatible") 145 (make-record-type 'b '(s t) #:uid uid)) 146 (pass-if-exception "different fields" '(misc-error . "incompatible") 147 (make-record-type 'a '(u v) #:uid uid)) 148 (pass-if-exception "fewer fields" '(misc-error . "incompatible") 149 (make-record-type 'a '(s) #:uid uid)) 150 (pass-if-exception "more fields" '(misc-error . "incompatible") 151 (make-record-type 'a '(s t u) #:uid uid)) 152 (pass-if-exception "adding a parent" '(misc-error . "incompatible") 153 (make-record-type 'a '(s t) #:parent b #:uid uid)) 154 (pass-if-exception "specifying a printer" '(misc-error . "incompatible") 155 (make-record-type 'a '(s t) pk #:uid uid)) 156 (pass-if-exception "non-final" '(misc-error . "incompatible") 157 (make-record-type 'a '(s t) #:extensible? #t #:uid uid)))) 158 159 (with-test-prefix "opaque types" 160 (let () 161 (define a (make-record-type 'a '() #:extensible? #t #:opaque? #t)) 162 (define b (make-record-type 'b '())) 163 (define c (make-record-type 'c '() #:parent a)) 164 165 (pass-if (record-type-opaque? a)) 166 (pass-if (not (record-type-opaque? b))) 167 (pass-if (record-type-opaque? c)) 168 (pass-if-exception "non-opaque" '(misc-error . "opaque") 169 (make-record-type 'd '() #:opaque? #f #:parent a)))) 170 171 (with-test-prefix "immutable fields" 172 (let () 173 (define a (make-record-type 'a '(s t (mutable u) (immutable v)) 174 #:extensible? #t)) 175 (define b (make-record-type 'b '(w (immutable x)) #:parent a)) 176 177 (pass-if-exception "bad field" '(misc-error . "field") 178 (make-record-type 'a '("foo"))) 179 (pass-if-exception "bad field" '(misc-error . "field") 180 (make-record-type 'a '((mutable u x)))) 181 (pass-if-exception "bad field" '(misc-error . "field") 182 (make-record-type 'a '((qux u)))) 183 (pass-if-equal (record-type-mutable-fields a) #b0111) 184 (pass-if-equal (record-type-mutable-fields b) #b010111) 185 186 (pass-if (procedure? (record-modifier a 's))) 187 (pass-if (procedure? (record-modifier a 't))) 188 (pass-if (procedure? (record-modifier a 'u))) 189 (pass-if-exception "immutable" '(misc-error . "immutable") 190 (record-modifier a 'v)) 191 192 (pass-if (procedure? (record-modifier b 's))) 193 (pass-if (procedure? (record-modifier b 't))) 194 (pass-if (procedure? (record-modifier b 'u))) 195 (pass-if-exception "immutable" '(misc-error . "immutable") 196 (record-modifier b 'v)) 197 (pass-if (procedure? (record-modifier b 'w))) 198 (pass-if-exception "immutable" '(misc-error . "immutable") 199 (record-modifier b 'x))))) 200