suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added case in zo-marshal for prefab structs

Browse Source 
Made quoted not-prefab so it isn't captured by prefab case

original commit: 63c6cc5d2c
This commit is contained in:
Blake Johnson 2010-07-30 15:30:14 -06:00 committed by Jay McCarthy
parent 7c32e885f3
commit f7c42c1e6a
1 changed files with 19 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/compiler/zo-marshal.rkt
View File

@ -234,6 +234,11 @@
(for ([(k v) (in-hash expr)]) (for ([(k v) (in-hash expr)])
(traverse-data k visit) (traverse-data k visit)
(traverse-data v visit)))] (traverse-data v visit)))]
[(prefab-struct-key expr)
(when (visit expr)
(let ([v (struct->vector expr)])
(for ([i (in-range 1 (vector-length v))])
(traverse-data (vector-ref v i) visit))))]
[(protected-symref? expr) [(protected-symref? expr)
(visit (protected-symref-val expr))] (visit (protected-symref-val expr))]
[else [else
@ -310,7 +315,7 @@
CPT_MODULE_VAR CPT_MODULE_VAR
CPT_PATH CPT_PATH
CPT_CLOSURE CPT_CLOSURE
CPT_DELAY_REF CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF
CPT_PREFAB CPT_PREFAB
CPT_LET_ONE_UNUSED) CPT_LET_ONE_UNUSED)
@ -681,7 +686,9 @@
p))])) p))]))
(define (lookup-encoded-wrapped w out) (define (lookup-encoded-wrapped w out)
(hash-ref (out-encoded-wraps out) w)) (hash-ref (out-encoded-wraps out) w
(lambda ()
(error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w))))
(define (out-wrapped w out) (define (out-wrapped w out)
(out-data (lookup-encoded-wrapped w out) out)) (out-data (lookup-encoded-wrapped w out) out))
@ -1053,6 +1060,7 @@
(print-contents-as-proper) (print-contents-as-proper)
(out-data null out))) (out-data null out)))
(if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START))
; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR
(begin (out-byte (+ CPT_SMALL_LIST_START len) out) (begin (out-byte (+ CPT_SMALL_LIST_START len) out)
(print-contents-as-improper)) (print-contents-as-improper))
(begin (out-byte CPT_LIST out) (begin (out-byte CPT_LIST out)
@ -1099,7 +1107,13 @@
[(stx? expr) [(stx? expr)
(out-stx expr out)] (out-stx expr out)]
[(wrapped? expr) [(wrapped? expr)
(out-wrapped expr out)] (out-wrapped expr out)]
[(prefab-struct-key expr)
=> (lambda (key)
(define pre-v (struct->vector expr))
(vector-set! pre-v 0 key)
(out-byte CPT_PREFAB out)
(out-data pre-v out))]
[else [else
(out-byte CPT_QUOTE out) (out-byte CPT_QUOTE out)
(if (quoted? expr) (if (quoted? expr)
@ -1112,12 +1126,12 @@
(out-bytes bstr out))))])) (out-bytes bstr out))))]))
(define-struct quoted (v) #:prefab) (define-struct quoted (v))
; protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off ; protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off
(define (protect-quote v) (define (protect-quote v)
#;v #;v
(if (or (list? v) (vector? v) (box? v) (hash? v)) (if (or (pair? v) (vector? v) (prefab-struct-key v) (box? v) (hash? v) (svector? v))
(make-quoted v) (make-quoted v)
v)) v))