diff --git a/xenomorph/xenomorph/redo/array.rkt b/xenomorph/xenomorph/redo/array.rkt index 6b1b315d..9a46a03a 100644 --- a/xenomorph/xenomorph/redo/array.rkt +++ b/xenomorph/xenomorph/redo/array.rkt @@ -10,7 +10,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee (define (xarray-decode xa [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) (parameterize ([current-input-port port]) - (define ctx (if (xint? (xarray-base-len xa)) + (define new-parent (if (xint? (xarray-base-len xa)) (mhasheq 'parent parent '_startOffset (pos port) '_currentOffset 0 @@ -28,10 +28,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee [else +inf.0])) (for/list ([i (in-naturals)] #:break (or (eof-object? (peek-byte)) (= (pos port) end-pos))) - (decode (xarray-base-type xa) #:parent ctx))] + (decode (xarray-base-type xa) #:parent new-parent))] ;; we have decoded-len, which is treated as count of items [else (for/list ([i (in-range decoded-len)]) - (decode (xarray-base-type xa) #:parent ctx))]))) + (decode (xarray-base-type xa) #:parent new-parent))]))) (define (xarray-encode xa array [port-arg (current-output-port)] #:parent [parent #f]) (unless (sequence? array) diff --git a/xenomorph/xenomorph/redo/bitfield.rkt b/xenomorph/xenomorph/redo/bitfield.rkt index c1fbd369..e4f4d1aa 100644 --- a/xenomorph/xenomorph/redo/bitfield.rkt +++ b/xenomorph/xenomorph/redo/bitfield.rkt @@ -26,7 +26,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee (encode (xbitfield-type xb) bit-int) (unless port-arg (get-output-bytes port)))) -(define (xbitfield-size xb [val #f] [ctx #f]) +(define (xbitfield-size xb [val #f] [parent #f]) (size (xbitfield-type xb))) (struct xbitfield (type flags) #:transparent diff --git a/xenomorph/xenomorph/redo/lazy-array.rkt b/xenomorph/xenomorph/redo/lazy-array.rkt index 418ef825..623c2a7f 100644 --- a/xenomorph/xenomorph/redo/lazy-array.rkt +++ b/xenomorph/xenomorph/redo/lazy-array.rkt @@ -32,8 +32,8 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee (define (xlazy-array-encode xla val [port-arg (current-output-port)] #:parent [parent #f]) (xarray-encode xla (if (stream? val) (stream->list val) val) port-arg #:parent parent)) -(define (xlazy-array-size xla [val #f] [ctx #f]) - (xarray-size xla (if (stream? val) (stream->list val) val) ctx)) +(define (xlazy-array-size xla [val #f] [parent #f]) + (xarray-size xla (if (stream? val) (stream->list val) val) parent)) ;; xarray-base holds type and len fields (struct xlazy-array xarray-base () #:transparent diff --git a/xenomorph/xenomorph/redo/pointer.rkt b/xenomorph/xenomorph/redo/pointer.rkt index 00ffa1ff..c4d9ab55 100644 --- a/xenomorph/xenomorph/redo/pointer.rkt +++ b/xenomorph/xenomorph/redo/pointer.rkt @@ -9,25 +9,25 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee |# -(define (find-top-ctx ctx) +(define (find-top-parent parent) (cond - [(dict-ref ctx 'parent #f) => find-top-ctx] - [else ctx])) + [(dict-ref parent 'parent #f) => find-top-parent] + [else parent])) -(define (xpointer-decode xp [port-arg (current-input-port)] #:parent [ctx #f]) +(define (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) (parameterize ([current-input-port port]) - (define offset (decode (xpointer-offset-type xp) #:parent ctx)) + (define offset (decode (xpointer-offset-type xp) #:parent parent)) (cond [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers [else (define relative (+ (case (pointer-style xp) - [(local) (dict-ref ctx '_startOffset)] + [(local) (dict-ref parent '_startOffset)] [(immediate) (- (pos port) (size (xpointer-offset-type xp)))] - [(parent) (dict-ref (dict-ref ctx 'parent) '_startOffset)] - [(global) (or (dict-ref (find-top-ctx ctx) '_startOffset) 0)] + [(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)] + [(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)] [else (error 'unknown-pointer-style)]) - ((relative-getter-or-0 xp) ctx))) + ((relative-getter-or-0 xp) parent))) (define ptr (+ offset relative)) (cond [(xpointer-type xp) @@ -38,7 +38,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee [else (define orig-pos (pos port)) (pos port ptr) - (set! val (decode (xpointer-type xp) #:parent ctx)) + (set! val (decode (xpointer-type xp) #:parent parent)) (pos port orig-pos) val])) (if (lazy xp) @@ -52,44 +52,42 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee [(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))] [else (raise-argument-error 'Pointer:size "VoidPointer" val)])) -(define (xpointer-encode xp val [port-arg (current-output-port)] #:parent [ctx #f]) +(define (xpointer-encode xp val [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (unless ctx ; todo: furnish default pointer context? adapt from Struct? - (raise-argument-error 'xpointer-encode "valid pointer context" ctx)) + (unless parent ; todo: furnish default pointer context? adapt from Struct? + (raise-argument-error 'xpointer-encode "valid pointer context" parent)) (parameterize ([current-output-port port]) (if (not val) (encode (xpointer-offset-type xp) (null-value xp) port) - (let* ([parent ctx] - [ctx (case (pointer-style xp) - [(local immediate) ctx] - [(parent) (dict-ref ctx 'parent)] - [(global) (find-top-ctx ctx)] + (let* ([new-parent (case (pointer-style xp) + [(local immediate) parent] + [(parent) (dict-ref parent 'parent)] + [(global) (find-top-parent parent)] [else (error 'unknown-pointer-style)])] [relative (+ (case (pointer-style xp) - [(local parent) (dict-ref ctx 'startOffset)] + [(local parent) (dict-ref new-parent 'startOffset)] [(immediate) (+ (pos port) (size (xpointer-offset-type xp) val parent))] [(global) 0]) ((relative-getter-or-0 xp) (dict-ref parent 'val #f)))]) - (encode (xpointer-offset-type xp) (- (dict-ref ctx 'pointerOffset) relative)) + (encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative)) (let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)]) - (dict-set! ctx 'pointers (append (dict-ref ctx 'pointers) + (dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers) (list (mhasheq 'type type 'val val 'parent parent)))) - (dict-set! ctx 'pointerOffset (+ (dict-ref ctx 'pointerOffset) (size type val parent))))))) + (dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type val parent))))))) (unless port-arg (get-output-bytes port))) -(define (xpointer-size xp [val #f] [ctx #f]) - (let*-values ([(parent) ctx] - [(ctx) (case (pointer-style xp) - [(local immediate) ctx] - [(parent) (dict-ref ctx 'parent)] - [(global) (find-top-ctx ctx)] +(define (xpointer-size xp [val #f] [parent #f]) + (let*-values ([(parent) (case (pointer-style xp) + [(local immediate) parent] + [(parent) (dict-ref parent 'parent)] + [(global) (find-top-parent parent)] [else (error 'unknown-pointer-style)])] [(type val) (resolve-void-pointer (xpointer-type xp) val)]) - (when (and val ctx) - (dict-set! ctx 'pointerSize (and (dict-ref ctx 'pointerSize #f) - (+ (dict-ref ctx 'pointerSize) (size type val parent))))) + (when (and val parent) + (dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f) + (+ (dict-ref parent 'pointerSize) (size type val parent))))) (size (xpointer-offset-type xp)))) (struct xpointer (offset-type type options) #:transparent @@ -105,7 +103,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (define (allow-null xp) (or (dict-ref (xpointer-options xp) 'allowNull #f) #t)) (define (null-value xp) (or (dict-ref (xpointer-options xp) 'nullValue #f) 0)) (define (lazy xp) (dict-ref (xpointer-options xp) 'lazy #f)) -(define (relative-getter-or-0 xp) (or (dict-ref (xpointer-options xp) 'relativeTo #f) (λ (ctx) 0))) ; changed this to a simple lambda +(define (relative-getter-or-0 xp) (or (dict-ref (xpointer-options xp) 'relativeTo #f) (λ (parent) 0))) ; changed this to a simple lambda ;; A pointer whose type is determined at decode time (struct xvoid-pointer (type value) #:transparent) diff --git a/xenomorph/xenomorph/redo/struct.rkt b/xenomorph/xenomorph/redo/struct.rkt index 2000cd05..7ff77770 100644 --- a/xenomorph/xenomorph/redo/struct.rkt +++ b/xenomorph/xenomorph/redo/struct.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require (prefix-in d: racket/dict) racket/list "helper.rkt" "util.rkt" "number.rkt" sugar/unstable/dict) +(require (prefix-in d: racket/dict) racket/list "helper.rkt" "number.rkt" sugar/unstable/dict) (provide (all-defined-out)) #| @@ -65,16 +65,16 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (unless (d:dict? res) (raise-result-error 'xstruct-decode "dict" res)) res))) -(define (xstruct-size xs [val #f] [parent #f] [include-pointers #t]) - (define ctx (mhasheq 'parent parent +(define (xstruct-size xs [val #f] [parent-arg #f] [include-pointers #t]) + (define parent (mhasheq 'parent parent-arg 'val val 'pointerSize 0)) (+ (for/sum ([(key type) (d:in-dict (xstruct-fields xs))] #:when (xenomorphic? type)) - (size type (and val (d:dict-ref val key)) ctx)) - (if include-pointers (d:dict-ref ctx 'pointerSize) 0))) + (size type (and val (d:dict-ref val key)) parent)) + (if include-pointers (d:dict-ref parent 'pointerSize) 0))) -(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent #f]) +(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f]) (unless (d:dict? val-arg) (raise-argument-error 'xstruct-encode "dict" val-arg)) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) @@ -88,18 +88,18 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (raise-argument-error 'xstruct-encode (format "dict that contains superset of Struct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val))) - (define ctx (mhash 'pointers empty + (define parent (mhash 'pointers empty 'startOffset (pos port) - 'parent parent + 'parent parent-arg 'val val 'pointerSize 0)) ; deliberately use `xstruct-size` instead of `size` to use extra arg - (d:dict-set! ctx 'pointerOffset (+ (pos port) (xstruct-size xs val ctx #f))) + (d:dict-set! parent 'pointerOffset (+ (pos port) (xstruct-size xs val parent #f))) (for ([(key type) (d:in-dict (xstruct-fields xs))]) - (encode type (d:dict-ref val key) #:parent ctx)) - (for ([ptr (in-list (d:dict-ref ctx 'pointers))]) + (encode type (d:dict-ref val key) #:parent parent)) + (for ([ptr (in-list (d:dict-ref parent 'pointers))]) (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent))) (unless port-arg (get-output-bytes port)))) @@ -110,7 +110,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define encode xstruct-encode) (define size xstruct-size)]) -(define (+xstruct [fields null] [post-decode (λ (val port ctx) val)] [pre-encode (λ (val port) val)]) +(define (+xstruct [fields null] [post-decode (λ (val port parent) val)] [pre-encode (λ (val port) val)]) (unless (d:dict? fields) (raise-argument-error '+xstruct "dict" fields)) (xstruct fields post-decode pre-encode)) diff --git a/xenomorph/xenomorph/redo/versioned-struct.rkt b/xenomorph/xenomorph/redo/versioned-struct.rkt index 77210fdb..9fca8338 100644 --- a/xenomorph/xenomorph/redo/versioned-struct.rkt +++ b/xenomorph/xenomorph/redo/versioned-struct.rkt @@ -34,26 +34,26 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee [else (_parse-fields port res fields) res]) port parent)) -(define (xversioned-struct-size xvs [val #f] [parent #f] [include-pointers #t]) +(define (xversioned-struct-size xvs [val #f] [parent-arg #f] [include-pointers #t]) (unless val (raise-argument-error 'xversioned-struct-size "value" val)) - (define ctx (mhash 'parent parent 'val val 'pointerSize 0)) + (define parent (mhash 'parent parent-arg 'val val 'pointerSize 0)) (define version-size (if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) - (size (xversioned-struct-type xvs) (dict-ref val 'version) ctx) + (size (xversioned-struct-type xvs) (dict-ref val 'version) parent) 0)) (define header-size (for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))]) - (size type (and val (dict-ref val key)) ctx))) + (size type (and val (dict-ref val key)) parent))) (define fields-size (let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version)) (raise-argument-error 'xversioned-struct-size "valid version key" version))]) (for/sum ([(key type) (in-dict fields)]) - (size type (and val (dict-ref val key)) ctx)))) - (define pointer-size (if include-pointers (dict-ref ctx 'pointerSize) 0)) + (size type (and val (dict-ref val key)) parent)))) + (define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0)) (+ version-size header-size fields-size pointer-size)) -(define (xversioned-struct-encode xvs val-arg [port-arg (current-output-port)] #:parent [parent #f]) +(define (xversioned-struct-encode xvs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) (parameterize ([current-output-port port]) (define val ((xversioned-struct-pre-encode xvs) val-arg port)) @@ -61,19 +61,19 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (unless (dict? val) (raise-argument-error 'xversioned-struct-encode "dict" val)) - (define ctx (mhash 'pointers null + (define parent (mhash 'pointers null 'startOffset (pos port) - 'parent parent + 'parent parent-arg 'val val 'pointerSize 0)) - (dict-set! ctx 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val ctx #f))) + (dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val parent #f))) (when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) (encode (xversioned-struct-type xvs) (dict-ref val 'version #f))) (when (dict-ref (xversioned-struct-versions xvs) 'header #f) (for ([(key type) (in-dict (dict-ref (xversioned-struct-versions xvs) 'header))]) - (encode type (dict-ref val key) #:parent ctx))) + (encode type (dict-ref val key) #:parent parent))) (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f)) (raise-argument-error 'xversioned-struct-encode "valid version key" version))) @@ -82,8 +82,8 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val))) (for ([(key type) (in-dict fields)]) - (encode type (dict-ref val key) #:parent ctx)) - (for ([ptr (in-list (dict-ref ctx 'pointers))]) + (encode type (dict-ref val key) #:parent parent)) + (for ([ptr (in-list (dict-ref parent 'pointers))]) (encode (dict-ref ptr 'type) (dict-ref ptr 'val) #:parent (dict-ref ptr 'parent))) (unless port-arg (get-output-bytes port)))) @@ -110,143 +110,3 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee (define (no-op-post-decode xvs port ctx) xvs) (xversioned-struct type versions version-getter version-setter no-op-pre-encode no-op-post-decode)) -#| -(define-subclass Struct (VersionedStruct type [versions (dictify)]) - - (unless (for/or ([proc (list integer? procedure? xenomorph-base%? symbol?)]) - (proc type)) - (raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" type)) - (unless (and (dict? versions) (andmap (λ (val) (or (dict? val) (Struct? val))) (map cdr versions))) - (raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions)) - - (inherit _setup _parse-fields post-decode) - (inherit-field fields) - (field [forced-version #f] - [versionGetter void] - [versionSetter void]) - - (when (or (key? type) (procedure? type)) - (set-field! versionGetter this (if (procedure? type) - type - (λ (parent) (ref parent type)))) - (set-field! versionSetter this (if (procedure? type) - type - (λ (parent version) (ref-set! parent type version))))) - - (define/override (decode stream [parent #f] [length 0]) - (define res (_setup stream parent length)) - - (ref-set! res 'version - (cond - [forced-version] ; for testing purposes: pass an explicit version - [(or (key? type) (procedure? type)) - (unless parent - (raise-argument-error 'VersionedStruct:decode "valid parent" parent)) - (versionGetter parent)] - [else (send type decode stream)])) - - (when (ref versions 'header) - (_parse-fields stream res (ref versions 'header))) - - (define fields (or (ref versions (ref res 'version)) (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions))))) - - - (cond - [(VersionedStruct? fields) (send fields decode stream parent)] - [else - (_parse-fields stream res fields) - res])) - - (define/public-final (force-version! version) - (set! forced-version version)) - - (define/override (encode stream val [parent #f]) - (unless (hash? val) - (raise-argument-error 'VersionedStruct:encode "hash" val)) - - (define ctx (mhash 'pointers empty - 'startOffset (pos stream) - 'parent parent - 'val val - 'pointerSize 0)) - - (ref-set! ctx 'pointerOffset (+ (pos stream) (size val ctx #f))) - - (when (not (or (key? type) (procedure? type))) - (send type encode stream (or forced-version (· val version)))) - - (when (ref versions 'header) - (for ([(key type) (in-dict (ref versions 'header))]) - (send type encode stream (ref val key) ctx))) - - (define fields (or (ref versions (or forced-version (· val version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version))) - - (unless (andmap (λ (key) (member key (ref-keys val))) (ref-keys fields)) - (raise-argument-error 'VersionedStruct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val))) - - (for ([(key type) (in-dict fields)]) - (send type encode stream (ref val key) ctx)) - - (for ([ptr (in-list (ref ctx 'pointers))]) - (send (ref ptr 'type) encode stream (ref ptr 'val) (ref ptr 'parent)))) - - - (define/override (size [val #f] [parent #f] [includePointers #t]) - (unless (or val forced-version) - (raise-argument-error 'VersionedStruct:size "value" val)) - - (define ctx (mhash 'parent parent - 'val val - 'pointerSize 0)) - - (+ (if (not (or (key? type) (procedure? type))) - (send type size (or forced-version (ref val 'version)) ctx) - 0) - - (for/sum ([(key type) (in-dict (or (ref versions 'header) empty))]) - (send type size (and val (ref val key)) ctx)) - - (let ([fields (or (ref versions (or forced-version (ref val 'version))) - (raise-argument-error 'VersionedStruct:encode "valid version key" version))]) - (for/sum ([(key type) (in-dict fields)]) - (send type size (and val (ref val key)) ctx))) - - (if includePointers (ref ctx 'pointerSize) 0)))) - -|# - -#;(test-module - (require "number.rkt") - (define (random-pick xs) (list-ref xs (random (length xs)))) - (check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42))) - - ;; make random versioned structs and make sure we can round trip - #;(for ([i (in-range 1)]) - (define field-types (for/list ([i (in-range 1)]) - (random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) - (define num-versions 20) - (define which-struct (random num-versions)) - (define struct-versions (for/list ([v (in-range num-versions)]) - (cons v (for/list ([num-type (in-list field-types)]) - (cons (gensym) num-type))))) - (define vs (+VersionedStruct which-struct struct-versions)) - (define struct-size (for/sum ([num-type (in-list (map cdr (ref struct-versions which-struct)))]) - (send num-type size))) - (define bs (apply bytes (for/list ([i (in-range struct-size)]) - (random 256)))) - (check-equal? (send vs encode #f (send vs decode bs)) bs)) - - (define s (+Struct (dictify 'a uint8 'b uint8 'c uint8))) - (check-equal? (send s size) 3) - (define vs (+VersionedStruct uint8 (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s)))) - (send vs force-version! 1) - (check-equal? (send vs size) 6) - #| - (define s2 (+Struct (dictify 'a vs))) - (check-equal? (send s2 size) 6) - (define vs2 (+VersionedStruct (λ (p) 2) (dictify 1 vs 2 vs))) - (check-equal? (send vs2 size) 6) -|# - ) - -