fix define-record-type/destructor and refactor tests

1 files changed, 138 insertions, 0 deletions

diff --git a/tests/values.scm b/tests/values.scm
new file mode 100644
index 0000000..f1d63f7
--- /dev/null
+++ b/tests/values.scm
@@ -0,0 +1,138 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(import (mcgoron cond-thunk values) (scheme write))
+
+(test-begin "(mcgoron cond-thunk values)")
+(test-assert
+ "like cond-thunk 1"
+ (cond-values
+   (when-ct #t #t)
+   (else #f)))
+
+(test-assert
+ "like cond-thunk 2"
+ (cond-values
+   (when-ct #f #f)
+   (else #t)))
+
+(define-syntax case-receive
+  (syntax-rules ()
+    ((case-receive generator clauses ...)
+     (call-with-values (lambda () generator)
+       (case-lambda clauses ...)))))
+
+(test-assert
+ "delivering no values 1"
+ (case-receive (cond-values (when-ct #f #f))
+   (() #t)
+   (_ #f)))
+(test-assert
+ "delivering no values 2"
+ (case-receive (cond-values (when-ct #t #t))
+   (() #f)
+   ((x) #t)
+   (_ #f)))
+
+(test-assert
+ "after 1"
+ (case-receive (cond-values
+                 (after ((when #t))
+                   #t))
+   (() #f)
+   ((x) #t)
+   (_ #f)))
+
+(test-assert
+ "after 2"
+ (case-receive (cond-values
+                 (after ((when #f))
+                   #f))
+   (() #t)
+   (_ #f)))
+
+(test
+ "pair=>"
+ '(2 3 4)
+ (cond-values
+   (after ((let (pair=> #f) => (head tail)))
+     'boolean)
+   (after ((let (pair=> 5) => (head tail)))
+     'number)
+   (after ((let (pair=> "xy") => (head tail)))
+     'string)
+   (after ((let (pair=> '(1 2 3 4)) => (head tail)))
+     tail)
+   (else #f)))
+
+(test-assert
+ "length-at-least=> 1"
+ (cond-values
+   (after ((let (length-at-least=> '(1 2 3 4) 5)
+             => _))
+     #f)
+   (after ((let (length-at-least=> '(1 2 3 4) 4)
+             => returned))
+     #t)
+   (else #f)))
+
+(cond-values
+  (after ((let (length-at-least=> '(1 2 3 4) 4)
+            => (a b c d rest)))
+    (test "length-at-least=> 2.1" 1 a)
+    (test "length-at-least=> 2.2" 2 b)
+    (test "length-at-least=> 2.3" 3 c)
+    (test "length-at-least=> 2.4" 4 d)
+    (test-assert "length-at-least=> 2.5" (null? rest)))
+  (else (error "length-at-least=> 2" #f)))
+
+(cond-values
+  (after ((let (length-at-least=> '(1 2 3 4) 3)
+            => (a b c rest)))
+    (test "length-at-least=> 3.1" 1 a)
+    (test "length-at-least=> 3.2" 2 b)
+    (test "length-at-least=> 3.3" 3 c)
+    (test-assert "length-at-least=> 3.4" (equal? rest '(4))))
+  (else (error "length-at-least=> 3" #f)))
+
+(define-syntax with-catch-predicate
+  (syntax-rules ()
+    ((with-catch-predicate predicate? body ...)
+     (guard (x ((predicate? x) #t)
+               (else #f))
+       body ...))))
+
+(define-record-type/destructor <test-object>
+  (test-object x y z)
+  test-object?
+  test-object=>
+  (x get-x)
+  (y get-y)
+  (z get-z))
+
+(let ((obj (test-object 1 2 3)))
+  (test-assert
+   "define-record-type/destructor"
+   (cond-thunk
+     (after ((let (test-object=> obj) => (a b c))
+             (when (= a 1))
+             (when (= b 2))
+             (when (= c 3)))
+       #t))))
+
+
+(test-end "(mcgoron cond-thunk values)")
+