write

1 files changed, 76 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..8618059
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,76 @@
+#| Copyright (C) 2025 Peter McGoron
+ |
+ | Permission is hereby granted, free of charge, to any person obtaining a
+ | copy of this software and associated documentation files (the
+ | "Software"), to deal in the Software without restriction, including
+ | without limitation the rights to use, copy, modify, merge, publish,
+ | distribute, sublicense, and/or sell copies of the Software, and to
+ | permit persons to whom the Software is furnished to do so, subject to
+ | the following conditions:
+ |
+ | The above copyright notice and this permission notice (including the
+ | next paragraph) shall be included in all copies or substantial portions
+ | of the Software.
+ |
+ | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+ | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+
+ | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ |#
+
+(import r7rs test (srfi 259))
+
+(test-begin "SRFI 259")
+
+(define-procedure-tag tag-foo tag-foo? get-tag-foo)
+(define-procedure-tag tag-baz tag-baz? get-tag-baz)
+
+(test-group "tagging lambdas"
+  (let* ((var 100)
+         (tagged (tag-foo 'bar (lambda (x)
+                                 (set! var (+ var x))
+                                 var))))
+    (test-assert "tag-foo is tag-foo?" (tag-foo? tagged))
+    (test "get-tag-foo returns tagged value" 'bar (get-tag-foo tagged))
+    (test "var is previous value" 100 var)
+    (test "tagged procedure is callable" 110 (tagged 10))
+    (test "var has changed" 110 var)
+    (test-assert "not tag-baz?" (not (tag-baz? tagged)))
+    (test-assert "get-tag-baz raises an exception"
+                 (handle-exceptions exn #t
+                   (get-tag-baz tagged)
+                   #f))
+    (test-group "tagged again"
+      (let ((tagged-again (tag-foo 'quux tagged)))
+        (test-assert "tagging again retains tag-foo?" (tag-foo? tagged-again))
+        (test "tagging again sets new value" 'quux (get-tag-foo tagged-again))
+        (test "tagging again retains old value in previous procedure" 'bar (get-tag-foo tagged))
+        (test-assert "the procedures not eqv?" (not (eqv? tagged tagged-again)))
+        (test "tagging again returns a procedure" 150 (tagged 40))
+        (test "var has changed" 150 var)))
+    (test-group "tagged baz"
+      (let ((tagged-baz (tag-baz 'corge tagged)))
+        (test-assert "tag-baz?" (tag-baz? tagged-baz))
+        (test-assert "tag-baz and tag-foo?" (tag-foo? tagged-baz))
+        (test "retains get-tag-foo" 'bar (get-tag-foo tagged-baz))
+        (test "retains get-tag-baz" 'corge (get-tag-baz tagged-baz))
+        (test-assert "previous procedure is not tag-baz?" (not (tag-baz? tagged)))))))
+
+(test-group "tagging imported procedures"
+  (let* ((tagged (tag-foo 'foo +))
+         (tagged (tag-baz 'baz tagged)))
+    (test-assert "not tag-foo?" (not (tag-foo? +)))
+    (test-assert "not tag-baz?" (not (tag-baz? +)))
+    (test-assert "tag-foo?" (tag-foo? tagged))
+    (test-assert "tag-baz?" (tag-baz? tagged))
+    (test "operationally the same procedure?"
+          (+ 50 50)
+          (tagged 50 50))
+    (test "get-tag-foo" 'foo (get-tag-foo tagged))
+    (test "get-tag-baz" 'baz (get-tag-baz tagged))))
+
+(test-end "SRFI 259")