From becfaeb778a3c8ba241e2155b998d6b27dcfad0c Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Tue, 26 Jul 2022 19:24:10 -0700 Subject: Fix a potential R7RS issue. I was using the load procedure to load a program, but by a strict reading of R7RS, load can only handle expressions and definitions, not imports. So instead I'm defining each test as a library, and using the environment procedure to load them at runtime. --- csc/match-test.csc | 224 +++++++++++++++++++++++++++-------------------------- 1 file changed, 113 insertions(+), 111 deletions(-) (limited to 'csc/match-test.csc') diff --git a/csc/match-test.csc b/csc/match-test.csc index 8323952..c5923e4 100644 --- a/csc/match-test.csc +++ b/csc/match-test.csc @@ -1,111 +1,113 @@ -(import (scheme base) - (only (csc testing) assert-equal test) - (csc match)) - - -(test match-cond - (assert-equal - 3 - (match 3 - ('0 0) - ('1 1) - ('2 2) - ('3 3) - ('4 4)))) - - -(test match-list - (assert-equal - 2 - (match '(1 2 3) - ('() 0) - (('1 '2) 1) - (('1 '2 '3) 2) - (('1 '2 '3 '4) 3) - (_ 4)))) - - -(test match-binding - (assert-equal - 2 - (match '(1 2 3) - (('1 x '3) x)))) - - -(test match-destructuring - (assert-equal - 1 - (match '(1 2 3) - ('() 0) - ((head . _) head)))) - - -(test match-ignore - (assert-equal - 2 - (match '(1 2 3) - ((_ _ _ _) 0) - (('2 _ _) 1) - (('1 _ _) 2) - (_ 3)))) - - -(test match-improper-list - (assert-equal - 2 - (match '(1 2 3) - (('2 . _) 1) - (('1 . x) (car x)) - (_ 3)))) - - -(test match-symbol - (assert-equal - 2 - (match 'b - ('a 1) - ('b 2) - (_ 3)))) - - -(test match-when - (assert-equal - 3 - (match 'b - ('a 1) - ('b when #f 2) - ('b when #t 3) - (_ 4)))) - - -(test match-when-depending-on-pattern-variable - (assert-equal - 2 - (match 10 - (n when (= 1 n) 1) - (n when (= 10 n) 2) - (_ 3)))) - - -(define-match-record-type - (make-test-record-type a b c) - test-record-type? - %test-record-type - (a test-record-type-a) - (b test-record-type-b) - (c test-record-type-c)) - - -(test match-record-type - (assert-equal - 2 - (match (make-test-record-type 1 2 3) - ((% %test-record-type a b c) b)))) - - -(test match-record-type-any - (assert-equal - 2 - (match '(1 2 3) - ((% %test-record-type . _) 1) - ('(1 2 3) 2)))) +(define-library (csc match-test) + (import (scheme base) + (only (csc testing) assert-equal test) + (csc match)) + (begin + + + (test match-cond + (assert-equal + 3 + (match 3 + ('0 0) + ('1 1) + ('2 2) + ('3 3) + ('4 4)))) + + + (test match-list + (assert-equal + 2 + (match '(1 2 3) + ('() 0) + (('1 '2) 1) + (('1 '2 '3) 2) + (('1 '2 '3 '4) 3) + (_ 4)))) + + + (test match-binding + (assert-equal + 2 + (match '(1 2 3) + (('1 x '3) x)))) + + + (test match-destructuring + (assert-equal + 1 + (match '(1 2 3) + ('() 0) + ((head . _) head)))) + + + (test match-ignore + (assert-equal + 2 + (match '(1 2 3) + ((_ _ _ _) 0) + (('2 _ _) 1) + (('1 _ _) 2) + (_ 3)))) + + + (test match-improper-list + (assert-equal + 2 + (match '(1 2 3) + (('2 . _) 1) + (('1 . x) (car x)) + (_ 3)))) + + + (test match-symbol + (assert-equal + 2 + (match 'b + ('a 1) + ('b 2) + (_ 3)))) + + + (test match-when + (assert-equal + 3 + (match 'b + ('a 1) + ('b when #f 2) + ('b when #t 3) + (_ 4)))) + + + (test match-when-depending-on-pattern-variable + (assert-equal + 2 + (match 10 + (n when (= 1 n) 1) + (n when (= 10 n) 2) + (_ 3)))) + + + (define-match-record-type + (make-test-record-type a b c) + test-record-type? + %test-record-type + (a test-record-type-a) + (b test-record-type-b) + (c test-record-type-c)) + + + (test match-record-type + (assert-equal + 2 + (match (make-test-record-type 1 2 3) + ((% %test-record-type a b c) b)))) + + + (test match-record-type-any + (assert-equal + 2 + (match '(1 2 3) + ((% %test-record-type . _) 1) + ('(1 2 3) 2)))))) -- cgit v1.3.1