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
125
126
127
128
129
130
|
#| 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.
|#
;;; This is the low-level Chicken code that implements tagged procedures.
;;; The standard `extend-procedure` cannot be used because it is mutating
;;; by default, while SRFI-259 is persistent.
;;;
;;; The code works by having a "signifier pair", whose car is a unique
;;; (in the sense of eqv) symbol and whose cdr is a integer map to the
;;; tag values.
;;;
;;; The code is similar to `extend-procedure`.
(define unique-id
;; Generate a fixnum, which will serve as the ID for each tagged
;; procedure constructor.
(let ((i 0))
(lambda ()
(set! i (fx+ i 1))
i)))
(define unique-symbol
;; This uninterned symbol is guaranteed to be a unique memory location
;; and is used to pick out the procedure tag mapping from the closure
;; data.
(string->uninterned-symbol "srfi-259"))
(define create/signifier-pair
;; Given a procedure that does not have tags associated with it, create
;; a new procedure object, with the same underlying procedure and closed
;; over variables, with `sig` as the signifier pair.
(foreign-primitive scheme-object ((scheme-object proc)
(scheme-object sig))
"
int old_size = C_header_size(proc);
C_word closure[C_SIZEOF_CLOSURE(old_size + 1)];
int i;
closure[0] = C_CLOSURE_TYPE | (old_size + 1);
for (i = 0; i < old_size; i++)
C_block_item(closure, i) = C_block_item(proc, i);
// C_mutate_slot(&C_block_item(closure, i), C_block_item(proc, i));
C_block_item(closure, old_size) = sig;
C_return(closure);"))
(define set-signifier-pair
;; Given a procedure that has tags associated with it, create a new
;; procedure object, with the same underlying procedure and closure,
;; with `sig` as the signifier pair.
(foreign-primitive scheme-object ((scheme-object proc)
(scheme-object unique_symbol)
(scheme-object sig))
"
int size = C_header_size(proc);
C_word item;
int i;
C_word closure[C_SIZEOF_CLOSURE(size)];
closure[0] = C_CLOSURE_TYPE | size;
for (i = 0; i < size; i++) {
item = C_block_item(proc, i);
if (!C_immediatep(item) && C_pairp(item) && C_eqp(unique_symbol, C_u_i_car(item))) {
C_block_item(closure, i) = sig;
// C_mutate_slot(&C_block_item(closure, i), sig);
} else {
C_block_item(closure, i) = item;
// C_mutate_slot(&C_block_item(closure, i), C_block_item(proc, i));
}
}
C_return(closure);
"))
(define (decoration-is-tag? x)
;; Return true if a decoration is a tagged procedure.
(and (pair? x)
(eq? (car x) unique-symbol)))
(define (get-mapping proc)
;; Return the mapping in a tagged procedure if it exists, or `#f` if it
;; does not exist. This relies on an undocumented internal function,
;; although it could be implemented with documented functions.
(cond
((##sys#lambda-decoration proc decoration-is-tag?) => cdr)
(else #f)))
(define (make-signifier fxmap)
;; Create a signifier pair that can be inserted into the closure.
(cons unique-symbol fxmap))
(define (set-tagged-mapping proc key value)
;; Return a new closure object that is tagged, has all of its previous
;; tags except that `key` maps to `value`.
(cond
((not (procedure? proc)) (raise
(make-property-condition '(srfi-259 assertion-violation)
'message
"not a procedure"
'arguments
(list proc key value))))
((get-mapping proc)
=> (lambda (oldmap)
(set-signifier-pair proc
unique-symbol
(make-signifier
(fxmapping-set oldmap key value)))))
(else (create/signifier-pair proc (make-signifier
(fxmapping key value))))))
|
