1;; Filename : test-srfi9.scm 2;; About : unit tests for SRFI-9 3;; 4;; Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com> 5;; 6;; All rights reserved. 7;; 8;; Redistribution and use in source and binary forms, with or without 9;; modification, are permitted provided that the following conditions 10;; are met: 11;; 12;; 1. Redistributions of source code must retain the above copyright 13;; notice, this list of conditions and the following disclaimer. 14;; 2. Redistributions in binary form must reproduce the above copyright 15;; notice, this list of conditions and the following disclaimer in the 16;; documentation and/or other materials provided with the distribution. 17;; 3. Neither the name of authors nor the names of its contributors 18;; may be used to endorse or promote products derived from this software 19;; without specific prior written permission. 20;; 21;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS 22;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 23;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 24;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 25;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 26;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 27;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 33(define orig-vector? vector?) 34(define orig-eval eval) 35 36(require-extension (unittest) (srfi 9)) 37 38 39(test-begin "SRFI-9 overridden R5RS procedures") 40(test-false (eq? vector? orig-vector?)) 41(cond-expand 42 (sigscheme 43 (test-true (eq? eval orig-eval))) 44 (else 45 (test-false (eq? eval orig-eval)))) 46(test-eq #t (vector? (vector))) 47(test-eq #f (vector? (list))) 48;; Overridden 'eval' must be capable of (interaction-environment). 49(test-read-eval-string "(define foo 3)") 50;; Original reference implementation of SRFI-9 lacks environment argument 51;; handling. 52(test-error (eval '(+ 2 3))) 53(test-eqv 5 (eval '(+ 2 3) (interaction-environment))) 54;; 'vector? must be evaluated to the redefined vector?. 55(test-eq vector? (eval 'vector? (interaction-environment))) 56(test-end) 57 58(test-begin "SRFI-9 invalid forms") 59;; invalid definition placement 60(test-error (if #t (define-record-type my-rec (make-my-rec) my-rec?))) 61(test-error (test-read-eval-string 62 "(if #t (define-record-type my-rec (make-my-rec) my-rec?))")) 63;; invalid record names 64(test-error (define-record-type 'my-rec (make-my-rec) my-rec?)) 65(test-error (define-record-type "my-rec" (make-my-rec) my-rec?)) 66;; invalid predicate names 67(test-error (define-record-type my-rec (make-my-rec) 'my-rec?)) 68(test-error (define-record-type my-rec (make-my-rec) "my-rec?")) 69;; invalid constructor 70(test-error (define-record-type my-rec make-my-rec my-rec?)) 71(test-error (define-record-type my-rec '(make-my-rec) my-rec?)) 72(test-error (define-record-type my-rec (list make-my-rec) my-rec?)) 73(test-error (define-record-type my-rec (list 'make-my-rec) my-rec?)) 74(test-error (define-record-type my-rec #(make-my-rec) my-rec?)) 75(test-error (define-record-type my-rec '#(make-my-rec) my-rec?)) 76;; non-existent field name in constructor 77(test-error (define-record-type my-rec (make-my-rec x) my-rec?)) 78;; without accessor 79(test-error (define-record-type my-rec (make-my-rec x) my-rec? 80 (x))) 81(test-end) 82 83(test-begin "SRFI-9 no-field record") 84(test-false (symbol-bound? 'make-my-null)) 85(test-false (symbol-bound? 'my-null?)) 86(test-eq (undef) 87 (define-record-type my-null (make-my-null) my-null?)) 88(test-true (procedure? make-my-null)) 89(test-true (procedure? my-null?)) 90(test-error (make-my-null 0)) 91(test-eq #t (record? (make-my-null))) 92(test-true (not (vector? (make-my-null)))) 93(test-eq #t (my-null? (make-my-null))) 94(test-false (my-null? (vector))) 95(test-end) 96 97(test-begin "SRFI-9 2-field record") 98(define x (list 'x)) 99(define y (list 'y)) 100(define z (list 'z)) 101(test-false (symbol-bound? 'make-my-pair)) 102(test-false (symbol-bound? 'my-pair?)) 103(test-false (symbol-bound? 'my-pair-kar)) 104(test-false (symbol-bound? 'my-pair-kdr)) 105(test-false (symbol-bound? 'my-pair-set-kar!)) 106(test-false (symbol-bound? 'my-pair-set-kdr!)) 107(test-eq (undef) 108 (define-record-type my-pair (make-my-pair kar kdr) my-pair? 109 (kar my-pair-kar my-pair-set-kar!) 110 (kdr my-pair-kdr my-pair-set-kdr!))) 111(test-true (procedure? make-my-pair)) 112(test-true (procedure? my-pair?)) 113(test-true (procedure? my-pair-kar)) 114(test-true (procedure? my-pair-kdr)) 115(test-true (procedure? my-pair-set-kar!)) 116(test-true (procedure? my-pair-set-kdr!)) 117(test-error (make-my-pair)) 118(test-error (make-my-pair x)) 119(test-error (make-my-pair x y z)) 120(test-eq #t (record? (make-my-pair x y))) 121(test-true (not (vector? (make-my-pair x y)))) 122(test-eq #t (my-pair? (make-my-pair x y))) 123(test-false (my-pair? (vector x y))) 124(test-false (my-pair? (make-my-null))) 125(test-eq x (my-pair-kar (make-my-pair x y))) 126(test-eq y (my-pair-kdr (make-my-pair x y))) 127(define foo (make-my-pair x y)) 128(test-eq x (my-pair-kar foo)) 129(test-eq y (my-pair-kdr foo)) 130(test-eq (undef) (my-pair-set-kar! foo z)) 131(test-eq z (my-pair-kar foo)) 132(test-eq y (my-pair-kdr foo)) 133(test-eq (undef) (my-pair-set-kdr! foo x)) 134(test-eq z (my-pair-kar foo)) 135(test-eq x (my-pair-kdr foo)) 136(test-end) 137 138(test-begin "SRFI-9 2-field record with swapped constructor tags") 139(define x (list 'x)) 140(define y (list 'y)) 141(define z (list 'z)) 142(test-false (symbol-bound? 'make-my-pair2)) 143(test-false (symbol-bound? 'my-pair2?)) 144(test-false (symbol-bound? 'my-pair2-kar)) 145(test-false (symbol-bound? 'my-pair2-kdr)) 146(test-false (symbol-bound? 'my-pair2-set-kar!)) 147(test-false (symbol-bound? 'my-pair2-set-kdr!)) 148(test-eq (undef) 149 (define-record-type my-pair2 (make-my-pair2 kdr kar) my-pair2? 150 (kar my-pair2-kar my-pair2-set-kar!) 151 (kdr my-pair2-kdr my-pair2-set-kdr!))) 152(test-true (procedure? make-my-pair2)) 153(test-true (procedure? my-pair2?)) 154(test-true (procedure? my-pair2-kar)) 155(test-true (procedure? my-pair2-kdr)) 156(test-true (procedure? my-pair2-set-kar!)) 157(test-true (procedure? my-pair2-set-kdr!)) 158(test-error (make-my-pair2)) 159(test-error (make-my-pair2 x)) 160(test-error (make-my-pair2 x y z)) 161(test-eq #t (record? (make-my-pair2 x y))) 162(test-true (not (vector? (make-my-pair2 x y)))) 163(test-eq #t (my-pair2? (make-my-pair2 x y))) 164(test-false (my-pair2? (vector x y))) 165(test-eq y (my-pair2-kar (make-my-pair2 x y))) 166(test-eq x (my-pair2-kdr (make-my-pair2 x y))) 167(define foo (make-my-pair2 x y)) 168(test-eq y (my-pair2-kar foo)) 169(test-eq x (my-pair2-kdr foo)) 170(test-eq (undef) (my-pair2-set-kar! foo z)) 171(test-eq z (my-pair2-kar foo)) 172(test-eq x (my-pair2-kdr foo)) 173(test-eq (undef) (my-pair2-set-kdr! foo y)) 174(test-eq z (my-pair2-kar foo)) 175(test-eq y (my-pair2-kdr foo)) 176(test-end) 177 178(test-begin "SRFI-9 2-field record with partial constructor tags") 179(define x (list 'x)) 180(define y (list 'y)) 181(define z (list 'z)) 182(test-false (symbol-bound? 'make-my-pair3)) 183(test-false (symbol-bound? 'my-pair3?)) 184(test-false (symbol-bound? 'my-pair3-kar)) 185(test-false (symbol-bound? 'my-pair3-kdr)) 186(test-false (symbol-bound? 'my-pair3-set-kar!)) 187(test-false (symbol-bound? 'my-pair3-set-kdr!)) 188(test-eq (undef) 189 (define-record-type my-pair3 (make-my-pair3 kdr) my-pair3? 190 (kar my-pair3-kar my-pair3-set-kar!) 191 (kdr my-pair3-kdr my-pair3-set-kdr!))) 192(test-true (procedure? make-my-pair3)) 193(test-true (procedure? my-pair3?)) 194(test-true (procedure? my-pair3-kar)) 195(test-true (procedure? my-pair3-kdr)) 196(test-true (procedure? my-pair3-set-kar!)) 197(test-true (procedure? my-pair3-set-kdr!)) 198(test-error (make-my-pair3)) 199(test-error (make-my-pair3 x y)) 200(test-error (make-my-pair3 x y z)) 201(test-eq #t (record? (make-my-pair3 x))) 202(test-true (not (vector? (make-my-pair3 x)))) 203(test-eq #t (my-pair3? (make-my-pair3 x))) 204(test-false (my-pair3? (vector x y))) 205(test-false (my-pair3? (make-my-null))) 206(test-eq (undef) (my-pair3-kar (make-my-pair3 x))) 207(test-eq x (my-pair3-kdr (make-my-pair3 x))) 208(define foo (make-my-pair3 x)) 209(test-eq (undef) (my-pair3-kar foo)) 210(test-eq x (my-pair3-kdr foo)) 211(test-eq (undef) (my-pair3-set-kar! foo z)) 212(test-eq z (my-pair3-kar foo)) 213(test-eq x (my-pair3-kdr foo)) 214(test-eq (undef) (my-pair3-set-kdr! foo y)) 215(test-eq z (my-pair3-kar foo)) 216(test-eq y (my-pair3-kdr foo)) 217(test-end) 218 219(test-begin "SRFI-9 2-field record without constructor tags") 220(define x (list 'x)) 221(define y (list 'y)) 222(define z (list 'z)) 223(test-false (symbol-bound? 'make-my-pair4)) 224(test-false (symbol-bound? 'my-pair4?)) 225(test-false (symbol-bound? 'my-pair4-kar)) 226(test-false (symbol-bound? 'my-pair4-kdr)) 227(test-false (symbol-bound? 'my-pair4-set-kar!)) 228(test-false (symbol-bound? 'my-pair4-set-kdr!)) 229(test-eq (undef) 230 (define-record-type my-pair4 (make-my-pair4) my-pair4? 231 (kar my-pair4-kar my-pair4-set-kar!) 232 (kdr my-pair4-kdr my-pair4-set-kdr!))) 233(test-true (procedure? make-my-pair4)) 234(test-true (procedure? my-pair4?)) 235(test-true (procedure? my-pair4-kar)) 236(test-true (procedure? my-pair4-kdr)) 237(test-true (procedure? my-pair4-set-kar!)) 238(test-true (procedure? my-pair4-set-kdr!)) 239(test-error (make-my-pair4 x)) 240(test-error (make-my-pair4 x y)) 241(test-error (make-my-pair4 x y z)) 242(test-eq #t (record? (make-my-pair4))) 243(test-true (not (vector? (make-my-pair4)))) 244(test-eq #t (my-pair4? (make-my-pair4))) 245(test-false (my-pair4? (vector x y))) 246(test-eq (undef) (my-pair4-kar (make-my-pair4))) 247(test-eq (undef) (my-pair4-kdr (make-my-pair4))) 248(define foo (make-my-pair4)) 249(test-eq (undef) (my-pair4-kar foo)) 250(test-eq (undef) (my-pair4-kdr foo)) 251(test-eq (undef) (my-pair4-set-kar! foo z)) 252(test-eq z (my-pair4-kar foo)) 253(test-eq (undef) (my-pair4-kdr foo)) 254(test-eq (undef) (my-pair4-set-kdr! foo x)) 255(test-eq z (my-pair4-kar foo)) 256(test-eq x (my-pair4-kdr foo)) 257(test-end) 258 259(test-begin "SRFI-9 2-field record without modifiers") 260(test-false (symbol-bound? 'make-my-pair5)) 261(test-false (symbol-bound? 'my-pair5?)) 262(test-false (symbol-bound? 'my-pair5-kar)) 263(test-false (symbol-bound? 'my-pair5-kdr)) 264(test-eq (undef) 265 (define-record-type my-pair5 (make-my-pair5 kar kdr) my-pair5? 266 (kar my-pair5-kar) 267 (kdr my-pair5-kdr))) 268(test-true (procedure? make-my-pair5)) 269(test-true (procedure? my-pair5?)) 270(test-true (procedure? my-pair5-kar)) 271(test-true (procedure? my-pair5-kdr)) 272(test-end) 273 274(test-report-result) 275