add lambda/this

1 files changed, 24 insertions, 12 deletions

diff --git a/tests/run.scm b/tests/run.scm
index feb1cc1..ce927ff 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))
+(import r7rs test (chicken condition) (chicken gc) (srfi 259 extensions))
 
 (test-begin "SRFI 259")
 
@@ -96,17 +96,6 @@
   (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4))))
   (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4))))
 
-(import (chicken pretty-print))
-
-(define (debug-dump obj)
-  (let ((vec (make-vector (##sys#size obj))))
-    (display (##sys#size obj)) (newline)
-    (do ((i 0 (+ i 1)))
-        ((= i (##sys#size obj)) (newline))
-      (vector-set! vec i (##sys#slot obj i)))
-    (pp vec)
-    (newline)))
-
 (test-group "define-procedure-tag is a define form"
   (let ()
     (define (square x) (* x x))
@@ -122,3 +111,26 @@
     (test "square value" (tagged-square 10) (square 10))))
 
 (test-end "SRFI 259")
+
+(test-begin "SRFI 259 extensions")
+
+(define/this (try-this this x)
+  (when (tag-foo? this)
+    (set! x (+ x (get-tag-foo this))))
+  (when (tag-baz? this)
+    (set! x (+ x (get-tag-baz this))))
+  x)
+
+(test "no tag" 10 (try-this 10))
+
+(define new-try-this (tag-foo 10 try-this))
+(test "with tag-foo" 20 (new-try-this 10))
+(test "does not affect the one with no tag" 10 (try-this 10))
+
+(define new-new-try-this (tag-baz 20 new-try-this))
+(test "with tag-baz" 40 (new-new-try-this 10))
+(test "does not affect the one with tag-foo" 20 (new-try-this 10))
+(test "does not affect the one with no tag" 10 (try-this 10))
+
+(test-end "SRFI 259 extensions")
+(test-exit)