From 991378aaaff8003e712ed4174b0159fdf7defe32 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 12 Dec 2018 14:12:40 -0800 Subject: [PATCH] parameterizing --- xenomorph/xenomorph/redo/array.rkt | 89 +++++++++--------- xenomorph/xenomorph/redo/bitfield.rkt | 24 ++--- xenomorph/xenomorph/redo/buffer.rkt | 20 ++-- xenomorph/xenomorph/redo/enum.rkt | 12 ++- xenomorph/xenomorph/redo/lazy-array.rkt | 37 ++++---- xenomorph/xenomorph/redo/number.rkt | 40 ++++---- xenomorph/xenomorph/redo/optional.rkt | 8 +- xenomorph/xenomorph/redo/pointer.rkt | 12 ++- xenomorph/xenomorph/redo/reserved.rkt | 4 +- xenomorph/xenomorph/redo/string.rkt | 26 +++--- xenomorph/xenomorph/redo/struct.rkt | 92 ++++++++++--------- xenomorph/xenomorph/redo/util.rkt | 2 +- xenomorph/xenomorph/redo/versioned-struct.rkt | 13 +-- 13 files changed, 200 insertions(+), 179 deletions(-) diff --git a/xenomorph/xenomorph/redo/array.rkt b/xenomorph/xenomorph/redo/array.rkt index a548b863..6b1b315d 100644 --- a/xenomorph/xenomorph/redo/array.rkt +++ b/xenomorph/xenomorph/redo/array.rkt @@ -9,54 +9,55 @@ 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)) - (define ctx (if (xint? (xarray-base-len xa)) - (mhasheq 'parent parent - '_startOffset (pos port) - '_currentOffset 0 - '_length (xarray-base-len xa)) - parent)) - (define decoded-len (resolve-length (xarray-base-len xa) port parent)) - (cond - [(or (not decoded-len) (eq? (xarray-length-type xa) 'bytes)) - (define end-pos (cond - ;; decoded-len is byte length - [decoded-len (+ (pos port) decoded-len)] - ;; no decoded-len, but parent has length - [(and parent (not (zero? (dict-ref parent '_length)))) (+ (dict-ref parent '_startOffset) (dict-ref parent '_length))] - ;; no decoded-len or parent, so consume whole stream - [else +inf.0])) - (for/list ([i (in-naturals)] - #:break (or (eof-object? (peek-byte port)) (= (pos port) end-pos))) - (decode (xarray-base-type xa) port #:parent ctx))] - ;; we have decoded-len, which is treated as count of items - [else (for/list ([i (in-range decoded-len)]) - (decode (xarray-base-type xa) port #:parent ctx))])) + (parameterize ([current-input-port port]) + (define ctx (if (xint? (xarray-base-len xa)) + (mhasheq 'parent parent + '_startOffset (pos port) + '_currentOffset 0 + '_length (xarray-base-len xa)) + parent)) + (define decoded-len (resolve-length (xarray-base-len xa) #:parent parent)) + (cond + [(or (not decoded-len) (eq? (xarray-length-type xa) 'bytes)) + (define end-pos (cond + ;; decoded-len is byte length + [decoded-len (+ (pos port) decoded-len)] + ;; no decoded-len, but parent has length + [(and parent (not (zero? (dict-ref parent '_length)))) (+ (dict-ref parent '_startOffset) (dict-ref parent '_length))] + ;; no decoded-len or parent, so consume whole stream + [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))] + ;; 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))]))) (define (xarray-encode xa array [port-arg (current-output-port)] #:parent [parent #f]) (unless (sequence? array) (raise-argument-error 'xarray-encode "sequence" array)) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (define (encode-items ctx) - ;; todo: should array with fixed length stop encoding after it reaches max? - ;; cf. xstring, which rejects input that is too big for fixed length. - (let* (#;[items (sequence->list array)] - #;[item-count (length items)] - #;[max-items (if (number? (xarray-len xa)) (xarray-len xa) item-count)]) - (for ([item array]) - (encode (xarray-base-type xa) item port #:parent ctx)))) - - (cond - [(xint? (xarray-base-len xa)) - (define ctx (mhash 'pointers null - 'startOffset (pos port) - 'parent parent)) - (dict-set! ctx 'pointerOffset (+ (pos port) (size xa array ctx))) - (encode (xarray-base-len xa) (length array) port) ; encode length at front - (encode-items ctx) - (for ([ptr (in-list (dict-ref ctx 'pointers))]) ; encode pointer data at end - (encode (dict-ref ptr 'type) (dict-ref ptr 'val) port))] - [else (encode-items parent)]) - (unless port-arg (get-output-bytes port))) + (parameterize ([current-output-port port]) + (define (encode-items ctx) + ;; todo: should array with fixed length stop encoding after it reaches max? + ;; cf. xstring, which rejects input that is too big for fixed length. + (let* (#;[items (sequence->list array)] + #;[item-count (length items)] + #;[max-items (if (number? (xarray-len xa)) (xarray-len xa) item-count)]) + (for ([item array]) + (encode (xarray-base-type xa) item #:parent ctx)))) + (cond + [(xint? (xarray-base-len xa)) + (define ctx (mhash 'pointers null + 'startOffset (pos port) + 'parent parent)) + (dict-set! ctx 'pointerOffset (+ (pos port) (size xa array ctx))) + (encode (xarray-base-len xa) (length array)) ; encode length at front + (encode-items ctx) + (for ([ptr (in-list (dict-ref ctx 'pointers))]) ; encode pointer data at end + (encode (dict-ref ptr 'type) (dict-ref ptr 'val)))] + [else (encode-items parent)]) + (unless port-arg (get-output-bytes port)))) (define (xarray-size xa [val #f] [ctx #f]) (when val (unless (sequence? val) @@ -67,7 +68,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee (values ctx 0))]) (+ len-size (for/sum ([item val]) (size (xarray-base-type xa) item ctx))))] - [else (let ([item-count (resolve-length (xarray-base-len xa) #f ctx)] + [else (let ([item-count (resolve-length (xarray-base-len xa) #f #:parent ctx)] [item-size (size (xarray-base-type xa) #f ctx)]) (* item-size item-count))])) diff --git a/xenomorph/xenomorph/redo/bitfield.rkt b/xenomorph/xenomorph/redo/bitfield.rkt index 79877e34..c1fbd369 100644 --- a/xenomorph/xenomorph/redo/bitfield.rkt +++ b/xenomorph/xenomorph/redo/bitfield.rkt @@ -9,20 +9,22 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee (define (xbitfield-decode xb [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) - (define flag-hash (mhasheq)) - (define val (decode (xbitfield-type xb) port)) - (for ([(flag i) (in-indexed (xbitfield-flags xb))] - #:when flag) - (hash-set! flag-hash flag (bitwise-bit-set? val i))) - flag-hash) + (parameterize ([current-input-port port]) + (define flag-hash (mhasheq)) + (define val (decode (xbitfield-type xb))) + (for ([(flag i) (in-indexed (xbitfield-flags xb))] + #:when flag) + (hash-set! flag-hash flag (bitwise-bit-set? val i))) + flag-hash)) (define (xbitfield-encode xb flag-hash [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (define bit-int (for/sum ([(flag i) (in-indexed (xbitfield-flags xb))] - #:when (and flag (dict-ref flag-hash flag #f))) - (arithmetic-shift 1 i))) - (encode (xbitfield-type xb) bit-int port) - (unless port-arg (get-output-bytes port))) + (parameterize ([current-output-port port]) + (define bit-int (for/sum ([(flag i) (in-indexed (xbitfield-flags xb))] + #:when (and flag (dict-ref flag-hash flag #f))) + (arithmetic-shift 1 i))) + (encode (xbitfield-type xb) bit-int) + (unless port-arg (get-output-bytes port)))) (define (xbitfield-size xb [val #f] [ctx #f]) (size (xbitfield-type xb))) diff --git a/xenomorph/xenomorph/redo/buffer.rkt b/xenomorph/xenomorph/redo/buffer.rkt index 43242f26..388e8e67 100644 --- a/xenomorph/xenomorph/redo/buffer.rkt +++ b/xenomorph/xenomorph/redo/buffer.rkt @@ -9,24 +9,26 @@ https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee (define (xbuffer-decode xb [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) - (define decoded-len (resolve-length (xbuffer-len xb) port parent)) - (read-bytes decoded-len port)) + (parameterize ([current-input-port port]) + (define decoded-len (resolve-length (xbuffer-len xb) #:parent parent)) + (read-bytes decoded-len))) (define (xbuffer-encode xb buf [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (unless (bytes? buf) - (raise-argument-error 'xbuffer-encode "bytes" buf)) - (when (xint? (xbuffer-len xb)) - (encode (xbuffer-len xb) (bytes-length buf) port)) - (write-bytes buf port) - (unless port-arg (get-output-bytes port))) + (parameterize ([current-output-port port]) + (unless (bytes? buf) + (raise-argument-error 'xbuffer-encode "bytes" buf)) + (when (xint? (xbuffer-len xb)) + (encode (xbuffer-len xb) (bytes-length buf))) + (write-bytes buf) + (unless port-arg (get-output-bytes port)))) (define (xbuffer-size xb [val #f] [parent #f]) (when val (unless (bytes? val) (raise-argument-error 'xbuffer-size "bytes" val))) (if (bytes? val) (bytes-length val) - (resolve-length (xbuffer-len xb) val parent))) + (resolve-length (xbuffer-len xb) val #:parent parent))) (struct xbuffer (len) #:transparent #:methods gen:xenomorphic diff --git a/xenomorph/xenomorph/redo/enum.rkt b/xenomorph/xenomorph/redo/enum.rkt index 4568e915..3ce6a41c 100644 --- a/xenomorph/xenomorph/redo/enum.rkt +++ b/xenomorph/xenomorph/redo/enum.rkt @@ -9,18 +9,20 @@ https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee (define (xenum-decode xe [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) - (define index (decode (xenum-type xe) port)) - (or (list-ref (xenum-options xe) index) index)) + (parameterize ([current-input-port port]) + (define index (decode (xenum-type xe))) + (or (list-ref (xenum-options xe) index) index))) (define (xenum-size xe [val #f] [parent #f]) (size (xenum-type xe))) (define (xenum-encode xe val [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) + (parameterize ([current-output-port port]) (define index (index-of (xenum-options xe) val)) (unless index - (raise-argument-error 'Enum:encode "valid option" val)) - (encode (xenum-type xe) index port) - (unless port-arg (get-output-bytes port))) + (raise-argument-error 'xenum-encode "valid option" val)) + (encode (xenum-type xe) index) + (unless port-arg (get-output-bytes port)))) (struct xenum (type options) #:transparent #:methods gen:xenomorphic diff --git a/xenomorph/xenomorph/redo/lazy-array.rkt b/xenomorph/xenomorph/redo/lazy-array.rkt index fc1743fd..418ef825 100644 --- a/xenomorph/xenomorph/redo/lazy-array.rkt +++ b/xenomorph/xenomorph/redo/lazy-array.rkt @@ -9,24 +9,25 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee (define (xlazy-array-decode xla [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) - (define starting-pos (pos port)) ; ! placement matters. `resolve-length` will change `pos` - (define decoded-len (resolve-length (xarray-base-len xla) port parent)) - (let ([parent (if (xint? (xarray-base-len xla)) - (mhasheq 'parent parent - '_startOffset starting-pos - '_currentOffset 0 - '_length (xarray-base-len xla)) - parent)]) - (define starting-pos (pos port)) - (define res (for/stream ([index (in-range decoded-len)]) - (define type (xarray-base-type xla)) - (define orig-pos (pos port)) - (pos port (+ starting-pos (* (size type #f parent) index))) - (define new-item (decode type port #:parent parent)) - (pos port orig-pos) - new-item)) - (pos port (+ (pos port) (* decoded-len (size (xarray-base-type xla) #f parent)))) - res)) + (parameterize ([current-input-port port]) + (define starting-pos (pos port)) ; ! placement matters. `resolve-length` will change `pos` + (define decoded-len (resolve-length (xarray-base-len xla) #:parent parent)) + (let ([parent (if (xint? (xarray-base-len xla)) + (mhasheq 'parent parent + '_startOffset starting-pos + '_currentOffset 0 + '_length (xarray-base-len xla)) + parent)]) + (define starting-pos (pos port)) + (define res (for/stream ([index (in-range decoded-len)]) + (define type (xarray-base-type xla)) + (define orig-pos (pos port)) + (pos port (+ starting-pos (* (size type #f parent) index))) + (define new-item (decode type port #:parent parent)) + (pos port orig-pos) + new-item)) + (pos port (+ (pos port) (* decoded-len (size (xarray-base-type xla) #f parent)))) + res))) (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)) diff --git a/xenomorph/xenomorph/redo/number.rkt b/xenomorph/xenomorph/redo/number.rkt index 5d060fa9..3e004760 100644 --- a/xenomorph/xenomorph/redo/number.rkt +++ b/xenomorph/xenomorph/redo/number.rkt @@ -12,33 +12,37 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define system-endian (if (system-big-endian?) 'be 'le)) -(define (xint-encode i val [port (current-output-port)] #:parent [parent #f]) +(define (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f]) (unless (xint? i) (raise-argument-error 'encode "xint instance" i)) (define-values (bound-min bound-max) (bounds i)) (unless (<= bound-min val bound-max) (raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (xint-signed i) "signed" "unsigned") (xint-size i) bound-min bound-max) val)) - (unless (or (not port) (output-port? port)) - (raise-argument-error 'encode "output port or #f" port)) - (define bs (for/fold ([bs null] - [val (exact-if-possible val)] - #:result bs) - ([i (in-range (xint-size i))]) - (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8)))) - (define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs))) - (if port (write-bytes res port) res)) + (unless (or (not port-arg) (output-port? port-arg)) + (raise-argument-error 'encode "output port or #f" port-arg)) + (define port (if (output-port? port-arg) port-arg (open-output-bytes))) + (parameterize ([current-output-port port]) + (define bs (for/fold ([bs null] + [val (exact-if-possible val)] + #:result bs) + ([i (in-range (xint-size i))]) + (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8)))) + (define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs))) + (if port-arg (write-bytes res) res))) (define (xint-decode i [port-arg (current-input-port)] #:parent [parent #f]) (unless (xint? i) (raise-argument-error 'decode "xint instance" i)) - (define bstr (read-bytes (xint-size i) (->input-port port-arg))) - (define bs ((if (eq? (xint-endian i) system-endian) - values - reverse-bytes) bstr)) - (define uint (for/sum ([b (in-bytes bs)] - [i (in-naturals)]) - (arithmetic-shift b (* 8 i)))) - (if (xint-signed i) (unsigned->signed uint (bits i)) uint)) + (define port (->input-port port-arg)) + (parameterize ([current-input-port port]) + (define bstr (read-bytes (xint-size i))) + (define bs ((if (eq? (xint-endian i) system-endian) + values + reverse-bytes) bstr)) + (define uint (for/sum ([b (in-bytes bs)] + [i (in-naturals)]) + (arithmetic-shift b (* 8 i)))) + (if (xint-signed i) (unsigned->signed uint (bits i)) uint))) (struct xnumber () #:transparent) diff --git a/xenomorph/xenomorph/redo/optional.rkt b/xenomorph/xenomorph/redo/optional.rkt index 82989430..178ad064 100644 --- a/xenomorph/xenomorph/redo/optional.rkt +++ b/xenomorph/xenomorph/redo/optional.rkt @@ -15,14 +15,16 @@ https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee (define (xoptional-decode xo [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) + (parameterize ([current-input-port port]) (when (resolve-condition xo parent) - (decode (xoptional-type xo) port #:parent parent))) + (decode (xoptional-type xo) #:parent parent)))) (define (xoptional-encode xo val [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) + (parameterize ([current-output-port port]) (when (resolve-condition xo parent) - (encode (xoptional-type xo) val port #:parent parent)) - (unless port-arg (get-output-bytes port))) + (encode (xoptional-type xo) val #:parent parent)) + (unless port-arg (get-output-bytes port)))) (define (xoptional-size xo [val #f] [parent #f]) (if (resolve-condition xo parent) diff --git a/xenomorph/xenomorph/redo/pointer.rkt b/xenomorph/xenomorph/redo/pointer.rkt index afca539f..00ffa1ff 100644 --- a/xenomorph/xenomorph/redo/pointer.rkt +++ b/xenomorph/xenomorph/redo/pointer.rkt @@ -16,7 +16,8 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (define (xpointer-decode xp [port-arg (current-input-port)] #:parent [ctx #f]) (define port (->input-port port-arg)) - (define offset (decode (xpointer-offset-type xp) port #:parent ctx)) + (parameterize ([current-input-port port]) + (define offset (decode (xpointer-offset-type xp) #:parent ctx)) (cond [(and allow-null (= offset (null-value xp))) #f] ; handle null pointers [else @@ -37,13 +38,13 @@ 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) port #:parent ctx)) + (set! val (decode (xpointer-type xp) #:parent ctx)) (pos port orig-pos) val])) (if (lazy xp) (lazy-thunk decode-value) (decode-value))] - [else ptr])])) + [else ptr])]))) (define (resolve-void-pointer type val) (cond @@ -55,6 +56,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee (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)) + (parameterize ([current-output-port port]) (if (not val) (encode (xpointer-offset-type xp) (null-value xp) port) (let* ([parent ctx] @@ -68,13 +70,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee [(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) port) + (encode (xpointer-offset-type xp) (- (dict-ref ctx 'pointerOffset) relative)) (let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)]) (dict-set! ctx 'pointers (append (dict-ref ctx 'pointers) (list (mhasheq 'type type 'val val 'parent parent)))) - (dict-set! ctx 'pointerOffset (+ (dict-ref ctx 'pointerOffset) (size type val parent)))))) + (dict-set! ctx 'pointerOffset (+ (dict-ref ctx 'pointerOffset) (size type val parent))))))) (unless port-arg (get-output-bytes port))) (define (xpointer-size xp [val #f] [ctx #f]) diff --git a/xenomorph/xenomorph/redo/reserved.rkt b/xenomorph/xenomorph/redo/reserved.rkt index 82cbaca2..8c4e5cc9 100644 --- a/xenomorph/xenomorph/redo/reserved.rkt +++ b/xenomorph/xenomorph/redo/reserved.rkt @@ -14,11 +14,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee (define (xreserved-encode xo val [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (write-bytes (make-bytes (size xo val parent) 0)) + (write-bytes (make-bytes (size xo val parent) 0) port) (unless port-arg (get-output-bytes port))) (define (xreserved-size xo [val #f] [parent #f]) - (* (size (xreserved-type xo)) (resolve-length (xreserved-count xo) #f parent))) + (* (size (xreserved-type xo)) (resolve-length (xreserved-count xo) #f #:parent parent))) (struct xreserved (type count) #:transparent #:methods gen:xenomorphic diff --git a/xenomorph/xenomorph/redo/string.rkt b/xenomorph/xenomorph/redo/string.rkt index f71485e3..14cb7e91 100644 --- a/xenomorph/xenomorph/redo/string.rkt +++ b/xenomorph/xenomorph/redo/string.rkt @@ -7,23 +7,23 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/String.coffee |# -(define (read-encoded-string port len [encoding 'ascii]) +(define (read-encoded-string len [encoding 'ascii]) (define proc (case encoding [(utf16le) (error 'bah)] [(ucs2) (error 'bleh)] [(utf8) bytes->string/utf-8] [(ascii) bytes->string/latin-1] [else values])) - (proc (read-bytes len port))) + (proc (read-bytes len))) -(define (write-encoded-string port string [encoding 'ascii]) +(define (write-encoded-string string [encoding 'ascii]) ;; todo: handle encodings correctly. ;; right now just utf8 and ascii are correct (define proc (case encoding [(ucs2 utf8 ascii) string->bytes/utf-8] [(utf16le) (error 'swap-bytes-unimplemented)] [else (error 'unsupported-string-encoding)])) - (write-bytes (proc string) port)) + (write-bytes (proc string))) (define (count-nonzero-chars port) ;; helper function for String @@ -41,17 +41,19 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (define (xstring-decode xs [port-arg (current-input-port)] #:parent [parent #f]) (define port (->input-port port-arg)) - (let ([len (or (resolve-length (xstring-len xs) port parent) (count-nonzero-chars port))] + (parameterize ([current-input-port port]) + (let ([len (or (resolve-length (xstring-len xs) #:parent parent) (count-nonzero-chars port))] [encoding (if (procedure? (xstring-encoding xs)) (or ((xstring-encoding xs) parent) 'ascii) (xstring-encoding xs))] [adjustment (if (and (not (xstring-len xs)) (bytes-left-in-port? port)) 1 0)]) - (define string (read-encoded-string port len encoding)) + (define string (read-encoded-string len encoding)) (pos port (+ (pos port) adjustment)) - string)) + string))) (define (xstring-encode xs val [port-arg (current-output-port)] #:parent [parent #f]) (define port (if (output-port? port-arg) port-arg (open-output-bytes))) + (parameterize ([current-output-port port]) (let* ([val (format "~a" val)] [encoding (if (procedure? (xstring-encoding xs)) (or ((xstring-encoding xs) (and parent (dict-ref parent val)) 'ascii)) @@ -60,14 +62,14 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (when (and (exact-nonnegative-integer? (xstring-len xs)) (> encoded-length (xstring-len xs))) (raise-argument-error 'xstring-encode (format "string no longer than ~a" (xstring-len xs)) val)) (when (xint? (xstring-len xs)) - (encode (xstring-len xs) encoded-length port)) - (write-encoded-string port val encoding) - (when (not (xstring-len xs)) (write-byte #x00 port)) ; null terminated when no len - (unless port-arg (get-output-bytes port)))) + (encode (xstring-len xs) encoded-length)) + (write-encoded-string val encoding) + (when (not (xstring-len xs)) (write-byte #x00)) ; null terminated when no len + (unless port-arg (get-output-bytes port))))) (define (xstring-size xs [val #f] [parent #f]) (if (not val) - (resolve-length (xstring-len xs) #f parent) + (resolve-length (xstring-len xs) #f #:parent parent) (let* ([encoding (if (procedure? (xstring-encoding xs)) (or ((xstring-encoding xs) (and parent (dict-ref parent val)) 'ascii)) (xstring-encoding xs))] diff --git a/xenomorph/xenomorph/redo/struct.rkt b/xenomorph/xenomorph/redo/struct.rkt index cb0fa494..2000cd05 100644 --- a/xenomorph/xenomorph/redo/struct.rkt +++ b/xenomorph/xenomorph/redo/struct.rkt @@ -54,15 +54,16 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define (xstruct-decode xs [port-arg (current-input-port)] #:parent [parent #f] [len 0]) (define port (->input-port port-arg)) - ;; _setup and _parse-fields are separate to cooperate with VersionedStruct - (define res - (let* ([sdr (_setup port parent len)] ; returns StructDictRes - [sdr (_parse-fields port sdr (xstruct-fields xs))]) - sdr)) - (let* ([res ((xstruct-post-decode xs) res port parent)] - #;[res (inner res post-decode res . args)]) - (unless (d:dict? res) (raise-result-error 'xstruct-decode "dict" res)) - res)) + (parameterize ([current-input-port port]) + ;; _setup and _parse-fields are separate to cooperate with VersionedStruct + (define res + (let* ([sdr (_setup port parent len)] ; returns StructDictRes + [sdr (_parse-fields port sdr (xstruct-fields xs))]) + sdr)) + (let* ([res ((xstruct-post-decode xs) res port parent)] + #;[res (inner res post-decode res . args)]) + (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 @@ -70,36 +71,37 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee '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)) + (size type (and val (d:dict-ref val key)) ctx)) (if include-pointers (d:dict-ref ctx 'pointerSize) 0))) (define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent #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))) - ;; check keys first, since `size` also relies on keys being valid - (define val (let* ([val ((xstruct-pre-encode xs) val-arg port)] - #;[val (inner res pre-encode val . args)]) - (unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val)) - val)) - (unless (andmap (λ (key) (memq key (d:dict-keys val))) (d:dict-keys (xstruct-fields xs))) - (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 - 'startOffset (pos port) - 'parent parent - '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))) - - (for ([(key type) (d:in-dict (xstruct-fields xs))]) - (encode type (d:dict-ref val key) port #:parent ctx)) - (for ([ptr (in-list (d:dict-ref ctx 'pointers))]) - (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) port #:parent (d:dict-ref ptr 'parent))) - (unless port-arg (get-output-bytes port))) + (parameterize ([current-output-port port]) + ;; check keys first, since `size` also relies on keys being valid + (define val (let* ([val ((xstruct-pre-encode xs) val-arg port)] + #;[val (inner res pre-encode val . args)]) + (unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val)) + val)) + (unless (andmap (λ (key) (memq key (d:dict-keys val))) (d:dict-keys (xstruct-fields xs))) + (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 + 'startOffset (pos port) + 'parent parent + '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))) + + (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 (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent))) + (unless port-arg (get-output-bytes port)))) (struct structish () #:transparent) (struct xstruct structish (fields post-decode pre-encode) #:transparent #:mutable @@ -118,15 +120,15 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define (random-pick xs) (list-ref xs (random (length xs)))) (check-exn exn:fail:contract? (λ () (+xstruct 42))) (for ([i (in-range 20)]) - ;; make random structs and make sure we can round trip - (define field-types - (for/list ([i (in-range 40)]) - (random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) - (define size-num-types - (for/sum ([num-type (in-list field-types)]) - (size num-type))) - (define xs (+xstruct (for/list ([num-type (in-list field-types)]) - (cons (gensym) num-type)))) - (define bs (apply bytes (for/list ([i (in-range size-num-types)]) - (random 256)))) - (check-equal? (encode xs (decode xs bs) #f) bs))) \ No newline at end of file + ;; make random structs and make sure we can round trip + (define field-types + (for/list ([i (in-range 40)]) + (random-pick (list uint8 uint16be uint16le uint32be uint32le double)))) + (define size-num-types + (for/sum ([num-type (in-list field-types)]) + (size num-type))) + (define xs (+xstruct (for/list ([num-type (in-list field-types)]) + (cons (gensym) num-type)))) + (define bs (apply bytes (for/list ([i (in-range size-num-types)]) + (random 256)))) + (check-equal? (encode xs (decode xs bs) #f) bs))) \ No newline at end of file diff --git a/xenomorph/xenomorph/redo/util.rkt b/xenomorph/xenomorph/redo/util.rkt index 9dd8c3bd..84104fa6 100644 --- a/xenomorph/xenomorph/redo/util.rkt +++ b/xenomorph/xenomorph/redo/util.rkt @@ -5,7 +5,7 @@ (define (length-resolvable? x) (or (not x) (symbol? x) (xenomorphic? x) (procedure? x) (exact-nonnegative-integer? x))) -(define (resolve-length x [port #f] [parent #f]) +(define (resolve-length x [port (current-input-port)] #:parent [parent #f]) (cond [(not x) #f] [(exact-nonnegative-integer? x) x] diff --git a/xenomorph/xenomorph/redo/versioned-struct.rkt b/xenomorph/xenomorph/redo/versioned-struct.rkt index 1b19aee5..77210fdb 100644 --- a/xenomorph/xenomorph/redo/versioned-struct.rkt +++ b/xenomorph/xenomorph/redo/versioned-struct.rkt @@ -6,7 +6,7 @@ #| approximates -https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee +https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee |# (define (xversioned-struct-decode xvs [port-arg (current-input-port)] #:parent [parent #f] [length 0]) @@ -55,6 +55,7 @@ https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.co (define (xversioned-struct-encode xvs val-arg [port-arg (current-output-port)] #:parent [parent #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)) (unless (dict? val) @@ -68,11 +69,11 @@ https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.co (dict-set! ctx 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val ctx #f))) (when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) - (encode (xversioned-struct-type xvs) (dict-ref val 'version #f) port)) + (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) port #:parent ctx))) + (encode type (dict-ref val key) #:parent ctx))) (define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f)) (raise-argument-error 'xversioned-struct-encode "valid version key" version))) @@ -81,11 +82,11 @@ https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.co (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) port #:parent ctx)) + (encode type (dict-ref val key) #:parent ctx)) (for ([ptr (in-list (dict-ref ctx 'pointers))]) - (encode (dict-ref ptr 'type) (dict-ref ptr 'val) port #:parent (dict-ref ptr 'parent))) + (encode (dict-ref ptr 'type) (dict-ref ptr 'val) #:parent (dict-ref ptr 'parent))) - (unless port-arg (get-output-bytes port))) + (unless port-arg (get-output-bytes port)))) (struct xversioned-struct structish (type versions version-getter version-setter pre-encode post-decode) #:transparent #:mutable #:methods gen:xenomorphic