1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
#| 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 (chicken condition) (chicken gc) (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 "get-tag-baz raises an exception"
'assertion
(condition-case (begin (get-tag-baz tagged) 'success)
((exn assertion) 'assertion)
(exn () 'error)))
(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))
(gc #f)
(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))))
(define-syntax raises-type-error
(syntax-rules ()
((raises-type-error name expr)
(test name
'type
(condition-case (begin expr 'success)
((exn type) 'type)
(var () (display (condition->list var)) 'error))))))
(test-group "predicates on other objects"
(test-assert "integers are not tagged" (not (tag-foo? 0)))
(raises-type-error "integers are not tagged" (tag-foo 'data 0))
(test-assert "strings are not tagged" (not (tag-foo? "hello")))
(raises-type-error "strings are not tagged" (tag-foo 'data "hello"))
(test-assert "bytevectors are not tagged" (not (tag-foo? #u8(1 2 3 4))))
(raises-type-error "bytevectors are not tagged" (tag-foo 'data #u8(1 2 3 4)))
(test-assert "vectors are not tagged" (not (tag-foo? #(call/cc))))
(raises-type-error "vectors are not tagged" (tag-foo 'data #(call/cc)))
(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")
|
