make define-procedure-tag a define form, and fix incorrect C primitive code

1 files changed, 25 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
index a6a9f29..feb1cc1 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -96,4 +96,29 @@
   (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))
+    (define-procedure-tag tag-order tag-order? get-tag-order)
+    (define tagged-square (tag-order 2 square))
+    (define-procedure-tag tag-pure tag-pure? get-tag-pure)
+    (define tagged-square (tag-pure #t tagged-square))
+    (test-assert "square is tag-order?" (tag-order? tagged-square))
+    (test-assert "square is tag-pure?" (tag-pure? tagged-square))
+    (test "square order" 2 (get-tag-order tagged-square))
+    (test-assert "square pure" (get-tag-pure tagged-square))
+    (test-assert "is a procedure?" (procedure? tagged-square))
+    (test "square value" (tagged-square 10) (square 10))))
+
 (test-end "SRFI 259")