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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
#lang racket/base
(require (only-in '#%flfxnum flvector? fxvector?)
(only-in '#%extfl extflonum? extflvector?))
(provide 2d-stx?
check-datum)
;; Checks for 3D syntax (syntax that contains unwritable values, etc)
(define INIT-FUEL #e1e6)
;; TO DO:
;; - extension via proc (any -> list/#f),
;; value considered good if result is list, all values in list are good
;; --
#|
Some other predicates one might like to have:
- would (read (write x)) succeed and be equal/similar to x?
- would (datum->syntax #f x) succeed?
- would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
- would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
where equal/similar could mean one of the following:
- equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
- equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
- equal? but also requiring same mutability at every point
Some aux definitions:
(define (rt x)
(define-values (in out) (make-pipe))
(write x out)
(close-output-port out)
(read in))
(define (wrsd x)
(define-values (in out) (make-pipe))
(write x out)
(close-output-port out)
(syntax->datum (read-syntax #f in)))
(define (dsd x)
(syntax->datum (datum->syntax #f x)))
(define (evalc x) ;; mimics compiled zo-file constraints
(eval (rt (compile `(quote ,x)))))
How mutability behaves:
- for vectors, boxes:
- read always mutable
- read-syntax always immutable
- (dsd x) always immutable
- (evalc x) always immutable
- for hashes:
- read always immutable
- (dsd x) same as x
- (evalc x) always immutable (!!!)
- for prefab structs:
- read same as x
- read-syntax same as x
- (dsd x) same as x
- (evalc x) same as x
Symbols
- (dsd x) same as x
- (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
Chaperones allow the lazy generation of infinite trees of data
undetectable by eq?-based cycle detection. Might be helpful to have
chaperone-eq? (not recursive, just chaperones of same object) and
chaperone-eq?-hash-code, to use with make-custom-hash.)
Impersonators allow the lazy generation of infinite trees of data,
period.
|#
;; ----
;; 2d-stx? : any ... -> boolean
;; Would (write (compile `(quote-syntax ,x))) succeed?
;; If traverse-syntax? is #t, recurs into existing syntax
;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
;; checks if *new* 3d syntax would be created.
(define (2d-stx? x
#:traverse-syntax? [traverse-syntax? #t]
#:irritant [irritant-box #f])
(check-datum x
#:syntax-mode (if traverse-syntax? 'compound 'atomic)
#:allow-impersonators? #f
#:allow-mutable? 'no-hash/prefab
#:allow-unreadable-symbols? #t
#:allow-cycles? #t
#:irritant irritant-box))
;; ----
;; check-datum : any ... -> boolean
;; where StxMode = (U 'atomic 'compound #f)
;; Returns nat if x is "good", #f if "bad"
;; If irritant-b is a box, the first bad subvalue found is put in the box.
;; If visited-t is a hash, it is used to detect cycles.
(define (check-datum x
#:syntax-mode [stx-mode #f]
#:allow-impersonators? [allow-impersonators? #f]
#:allow-mutable? [allow-mutable? #f]
#:allow-unreadable-symbols? [allow-unreadable? #f]
#:allow-cycles? [allow-cycles? #f]
#:irritant [irritant-b #f])
;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
(define (run fuel visited-t)
(check* x fuel visited-t
stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
irritant-b))
(let ([result (run INIT-FUEL #f)])
(cond [(not (equal? result 0)) ;; nat>0 or #f
(and result #t)]
[else
;; (eprintf "out of fuel, restarting\n")
(and (run +inf.0 (make-hasheq)) #t)])))
;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
;; If bad, places bad subvalue in irritant-b, if box
(define (check* x0 fuel0 visited-t
stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
irritant-b)
(define no-mutable? (not allow-mutable?))
(define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
(define no-cycle? (not allow-cycles?))
(define no-impersonator? (not allow-impersonators?))
(define (loop x fuel)
(if (and fuel (not (zero? fuel)))
(loop* x fuel)
fuel))
(define (loop* x fuel)
(define (bad) (when irritant-b (set-box! irritant-b x)) #f)
(define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
(cond [(and no-mutable? mutable?)
(bad)]
[else
body ...]))
(define-syntax-rule (with-cycle-check body ...)
(cond [(and visited-t (hash-ref visited-t x #f))
=> (lambda (status)
(cond [(and no-cycle? (eq? status 'traversing))
(bad)]
[else
fuel]))]
[else
(when visited-t
(hash-set! visited-t x 'traversing))
(begin0 (begin body ...)
(when visited-t
(hash-remove! visited-t x)))]))
;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
(cond
;; Immutable compound
[(and visited-t (list? x))
;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
;; don't do unless visited-t present, else expands fuel by arbitrary factors
(with-cycle-check
(for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
(loop e fuel)))]
[(pair? x)
(with-cycle-check
(let ([fuel (loop (car x) (sub1 fuel))])
(loop (cdr x) fuel)))]
;; Atomic
[(or (null? x)
(boolean? x)
(number? x)
(char? x)
(keyword? x)
(regexp? x)
(byte-regexp? x)
(extflonum? x))
fuel]
[(symbol? x)
(cond [(symbol-interned? x)
fuel]
[(symbol-unreadable? x)
(if allow-unreadable? fuel (bad))]
[else ;; uninterned
(if (eq? allow-unreadable? #t) fuel (bad))])]
;; Mutable flat
[(or (string? x)
(bytes? x))
(with-mutable-check (not (immutable? x))
fuel)]
[(or (fxvector? x)
(flvector? x)
(extflvector? x))
(with-mutable-check (not (immutable? x))
fuel)]
;; Syntax
[(syntax? x)
(case stx-mode
((atomic) fuel)
((compound) (loop (syntax-e x) fuel))
(else (bad)))]
;; Impersonators and chaperones
[(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type
(bad)]
[(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type
(bad)]
[else
(with-cycle-check
(cond
;; Mutable (maybe) compound
[(vector? x)
(with-mutable-check (not (immutable? x))
(for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
(loop e fuel)))]
[(box? x)
(with-mutable-check (not (immutable? x))
(loop (unbox x) (sub1 fuel)))]
[(prefab-struct-key x)
=> (lambda (key)
(cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
(bad)]
[else
;; traverse key, since contains arbitrary auto-value
(let ([fuel (loop key fuel)])
(loop (struct->vector x) fuel))]))]
[(hash? x)
(cond [(and no-mutable-hash/prefab? (not (immutable? x)))
(bad)]
[else
(for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
(let ([fuel (loop k fuel)])
(loop v fuel)))])]
;; Bad
[else
(bad)]))]))
(loop x0 fuel0))
;; mutable-prefab-key? : prefab-key -> boolean
(define (mutable-prefab-key? key)
;; A prefab-key is either
;; - symbol
;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
;; where mutable fields indicated by vector
;; This code is probably overly general; racket seems to normalize keys.
(let loop ([k key])
(and (pair? k)
(or (and (vector? (car k))
(positive? (vector-length (car k))))
(loop (cdr k))))))
|
