3d-stx.rkt (8766B)
1 #lang racket/base 2 (require (only-in '#%flfxnum flvector? fxvector?) 3 (only-in '#%extfl extflonum? extflvector?)) 4 (provide 2d-stx? 5 check-datum) 6 7 ;; Checks for 3D syntax (syntax that contains unwritable values, etc) 8 9 (define INIT-FUEL #e1e6) 10 11 ;; TO DO: 12 ;; - extension via proc (any -> list/#f), 13 ;; value considered good if result is list, all values in list are good 14 15 ;; -- 16 17 #| 18 Some other predicates one might like to have: 19 - would (read (write x)) succeed and be equal/similar to x? 20 - would (datum->syntax #f x) succeed? 21 - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? 22 - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? 23 24 where equal/similar could mean one of the following: 25 - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) 26 - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) 27 - equal? but also requiring same mutability at every point 28 29 Some aux definitions: 30 31 (define (rt x) 32 (define-values (in out) (make-pipe)) 33 (write x out) 34 (close-output-port out) 35 (read in)) 36 37 (define (wrsd x) 38 (define-values (in out) (make-pipe)) 39 (write x out) 40 (close-output-port out) 41 (syntax->datum (read-syntax #f in))) 42 43 (define (dsd x) 44 (syntax->datum (datum->syntax #f x))) 45 46 (define (evalc x) ;; mimics compiled zo-file constraints 47 (eval (rt (compile `(quote ,x))))) 48 49 How mutability behaves: 50 - for vectors, boxes: 51 - read always mutable 52 - read-syntax always immutable 53 - (dsd x) always immutable 54 - (evalc x) always immutable 55 - for hashes: 56 - read always immutable 57 - (dsd x) same as x 58 - (evalc x) always immutable (!!!) 59 - for prefab structs: 60 - read same as x 61 - read-syntax same as x 62 - (dsd x) same as x 63 - (evalc x) same as x 64 65 Symbols 66 - (dsd x) same as x 67 - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) 68 69 Chaperones allow the lazy generation of infinite trees of data 70 undetectable by eq?-based cycle detection. Might be helpful to have 71 chaperone-eq? (not recursive, just chaperones of same object) and 72 chaperone-eq?-hash-code, to use with make-custom-hash.) 73 74 Impersonators allow the lazy generation of infinite trees of data, 75 period. 76 77 |# 78 79 ;; ---- 80 81 ;; 2d-stx? : any ... -> boolean 82 ;; Would (write (compile `(quote-syntax ,x))) succeed? 83 ;; If traverse-syntax? is #t, recurs into existing syntax 84 ;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only 85 ;; checks if *new* 3d syntax would be created. 86 (define (2d-stx? x 87 #:traverse-syntax? [traverse-syntax? #t] 88 #:irritant [irritant-box #f]) 89 (check-datum x 90 #:syntax-mode (if traverse-syntax? 'compound 'atomic) 91 #:allow-impersonators? #f 92 #:allow-mutable? 'no-hash/prefab 93 #:allow-unreadable-symbols? #t 94 #:allow-cycles? #t 95 #:irritant irritant-box)) 96 97 ;; ---- 98 99 ;; check-datum : any ... -> boolean 100 ;; where StxMode = (U 'atomic 'compound #f) 101 ;; Returns nat if x is "good", #f if "bad" 102 ;; If irritant-b is a box, the first bad subvalue found is put in the box. 103 ;; If visited-t is a hash, it is used to detect cycles. 104 (define (check-datum x 105 #:syntax-mode [stx-mode #f] 106 #:allow-impersonators? [allow-impersonators? #f] 107 #:allow-mutable? [allow-mutable? #f] 108 #:allow-unreadable-symbols? [allow-unreadable? #f] 109 #:allow-cycles? [allow-cycles? #f] 110 #:irritant [irritant-b #f]) 111 ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. 112 (define (run fuel visited-t) 113 (check* x fuel visited-t 114 stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? 115 irritant-b)) 116 (let ([result (run INIT-FUEL #f)]) 117 (cond [(not (equal? result 0)) ;; nat>0 or #f 118 (and result #t)] 119 [else 120 ;; (eprintf "out of fuel, restarting\n") 121 (and (run +inf.0 (make-hasheq)) #t)]))) 122 123 ;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f 124 ;; Returns #f if bad, positive nat if good, 0 if ran out of fuel 125 ;; If bad, places bad subvalue in irritant-b, if box 126 (define (check* x0 fuel0 visited-t 127 stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? 128 irritant-b) 129 (define no-mutable? (not allow-mutable?)) 130 (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) 131 (define no-cycle? (not allow-cycles?)) 132 (define no-impersonator? (not allow-impersonators?)) 133 (define (loop x fuel) 134 (if (and fuel (not (zero? fuel))) 135 (loop* x fuel) 136 fuel)) 137 (define (loop* x fuel) 138 (define (bad) (when irritant-b (set-box! irritant-b x)) #f) 139 (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab 140 (cond [(and no-mutable? mutable?) 141 (bad)] 142 [else 143 body ...])) 144 (define-syntax-rule (with-cycle-check body ...) 145 (cond [(and visited-t (hash-ref visited-t x #f)) 146 => (lambda (status) 147 (cond [(and no-cycle? (eq? status 'traversing)) 148 (bad)] 149 [else 150 fuel]))] 151 [else 152 (when visited-t 153 (hash-set! visited-t x 'traversing)) 154 (begin0 (begin body ...) 155 (when visited-t 156 (hash-remove! visited-t x)))])) 157 ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) 158 (cond 159 ;; Immutable compound 160 [(and visited-t (list? x)) 161 ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table 162 ;; don't do unless visited-t present, else expands fuel by arbitrary factors 163 (with-cycle-check 164 (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) 165 (loop e fuel)))] 166 [(pair? x) 167 (with-cycle-check 168 (let ([fuel (loop (car x) (sub1 fuel))]) 169 (loop (cdr x) fuel)))] 170 ;; Atomic 171 [(or (null? x) 172 (boolean? x) 173 (number? x) 174 (char? x) 175 (keyword? x) 176 (regexp? x) 177 (byte-regexp? x) 178 (extflonum? x)) 179 fuel] 180 [(symbol? x) 181 (cond [(symbol-interned? x) 182 fuel] 183 [(symbol-unreadable? x) 184 (if allow-unreadable? fuel (bad))] 185 [else ;; uninterned 186 (if (eq? allow-unreadable? #t) fuel (bad))])] 187 ;; Mutable flat 188 [(or (string? x) 189 (bytes? x)) 190 (with-mutable-check (not (immutable? x)) 191 fuel)] 192 [(or (fxvector? x) 193 (flvector? x) 194 (extflvector? x)) 195 (with-mutable-check (not (immutable? x)) 196 fuel)] 197 ;; Syntax 198 [(syntax? x) 199 (case stx-mode 200 ((atomic) fuel) 201 ((compound) (loop (syntax-e x) fuel)) 202 (else (bad)))] 203 ;; Impersonators and chaperones 204 [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type 205 (bad)] 206 [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type 207 (bad)] 208 [else 209 (with-cycle-check 210 (cond 211 ;; Mutable (maybe) compound 212 [(vector? x) 213 (with-mutable-check (not (immutable? x)) 214 (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) 215 (loop e fuel)))] 216 [(box? x) 217 (with-mutable-check (not (immutable? x)) 218 (loop (unbox x) (sub1 fuel)))] 219 [(prefab-struct-key x) 220 => (lambda (key) 221 (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) 222 (bad)] 223 [else 224 ;; traverse key, since contains arbitrary auto-value 225 (let ([fuel (loop key fuel)]) 226 (loop (struct->vector x) fuel))]))] 227 [(hash? x) 228 (cond [(and no-mutable-hash/prefab? (not (immutable? x))) 229 (bad)] 230 [else 231 (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) 232 (let ([fuel (loop k fuel)]) 233 (loop v fuel)))])] 234 ;; Bad 235 [else 236 (bad)]))])) 237 (loop x0 fuel0)) 238 239 ;; mutable-prefab-key? : prefab-key -> boolean 240 (define (mutable-prefab-key? key) 241 ;; A prefab-key is either 242 ;; - symbol 243 ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) 244 ;; where mutable fields indicated by vector 245 ;; This code is probably overly general; racket seems to normalize keys. 246 (let loop ([k key]) 247 (and (pair? k) 248 (or (and (vector? (car k)) 249 (positive? (vector-length (car k)))) 250 (loop (cdr k))))))