srfi-229 supportHEAD1.1.0master

1 files changed, 76 insertions, 1 deletions

diff --git a/tests/run.scm b/tests/run.scm
index ce927ff..f965ba3 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -22,7 +22,7 @@
  | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  |#
 
-(import r7rs test (chicken condition) (chicken gc) (srfi 259 extensions))
+(import r7rs test (chicken condition) (chicken gc) (srfi 259 extensions) (srfi 229))
 
 (test-begin "SRFI 259")
 
@@ -133,4 +133,79 @@
 (test "does not affect the one with no tag" 10 (try-this 10))
 
 (test-end "SRFI 259 extensions")
+
+;; Copyright (C) Marc Nieper-Wißkirchen (2021).  All Rights Reserved.
+
+;; 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 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.
+
+
+(test-begin "SRFI-229")
+
+(define f
+  (lambda/tag 42
+      (x)
+    (* x x)))
+
+(test #t (procedure/tag? f))
+(test 9 (f 3))
+(test 42 (procedure-tag f))
+
+(define f*
+  (lambda/tag 43
+      (x)
+    (* x x)))
+
+(test #f (eqv? f f*))
+
+(define g
+  (let ((y 10))
+    (lambda/tag y ()
+	(set! y (+ y 1))
+	y)))
+
+(test 10 (procedure-tag g))
+(test 10 (let ((y 9)) (procedure-tag g)))
+(test 11 (g))
+(test 10 (procedure-tag g))
+
+(define h
+  (let ((box (vector #f)))
+    (case-lambda/tag box
+      (() (vector-ref box 0))
+      ((val) (vector-set! box 0 val)))))
+
+(h 1)
+(test 1 (vector-ref (procedure-tag h) 0))
+(test 1 (h))
+
+(test-begin "SRFI-229 and 259 do not conflict")
+(let ((proc (tag-foo 'foo (lambda/tag 'bar (x) x))))
+  (test-assert (tag-foo? proc))
+  (test-assert (procedure/tag? proc))
+  (test 'foo (get-tag-foo proc))
+  (test 'bar (procedure-tag proc)))
+(test-end)
+
+
+(test-end)
+
+
 (test-exit)