mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

pre-encode and post-deocde

Browse Source
main
Matthew Butterick 6 years ago
parent 60ac5e801d
commit 7d22b9224c
12 changed files with 103 additions and 86 deletions
Show Stats Download Patch File Download Diff File

29
xenomorph/xenomorph/redo/array.rkt
Unescape Escape View File

@ -7,7 +7,7 @@ approximates
https://github.com/mbutterick/restructure/blob/master/src/Array.coffee https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
|# |#
(define (xarray-decode xa [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xarray-decode xa [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(define new-parent (if (xint? (xarray-base-len xa)) (define new-parent (if (xint? (xarray-base-len xa))
@ -33,7 +33,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
[else (for/list ([i (in-range decoded-len)]) [else (for/list ([i (in-range decoded-len)])
(decode (xarray-base-type xa) #:parent new-parent))]))) (decode (xarray-base-type xa) #:parent new-parent))])))
(define (xarray-encode xa array [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xarray-encode xa array [port-arg (current-output-port)] #:parent [parent #f])
(unless (sequence? array) (unless (sequence? array)
(raise-argument-error 'xarray-encode "sequence" array)) (raise-argument-error 'xarray-encode "sequence" array))
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
@ -59,22 +59,21 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
[else (encode-items parent)]) [else (encode-items parent)])
(unless port-arg (get-output-bytes port)))) (unless port-arg (get-output-bytes port))))
(define (xarray-size xa [val #f] #:parent [parent #f]) (define/finalize-size (xarray-size xa [val #f] #:parent [parent #f])
(when val (unless (sequence? val) (when val (unless (sequence? val)
(raise-argument-error 'xarray-size "sequence" val))) (raise-argument-error 'xarray-size "sequence" val)))
(finalize-size (cond
(cond [val (define-values (new-parent len-size) (if (xint? (xarray-base-len xa))
[val (define-values (new-parent len-size) (if (xint? (xarray-base-len xa)) (values (mhasheq 'parent parent) (size (xarray-base-len xa)))
(values (mhasheq 'parent parent) (size (xarray-base-len xa))) (values parent 0)))
(values parent 0))) (define items-size (for/sum ([item val])
(define items-size (for/sum ([item val]) (size (xarray-base-type xa) item #:parent new-parent)))
(size (xarray-base-type xa) item #:parent new-parent))) (+ items-size len-size)]
(+ items-size len-size)] [else (define item-count (resolve-length (xarray-base-len xa) #f #:parent parent))
[else (define item-count (resolve-length (xarray-base-len xa) #f #:parent parent)) (define item-size (size (xarray-base-type xa) #f #:parent parent))
(define item-size (size (xarray-base-type xa) #f #:parent parent)) (* item-size item-count)]))
(* item-size item-count)])))
(struct xarray-base (type len) #:transparent) (struct xarray-base xbase (type len) #:transparent)
(struct xarray xarray-base (length-type) #:transparent (struct xarray xarray-base (length-type) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xarray-decode) [(define decode xarray-decode)

6
xenomorph/xenomorph/redo/bitfield.rkt
Unescape Escape View File

@ -7,7 +7,7 @@ approximates
https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
|# |#
(define (xbitfield-decode xb [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xbitfield-decode xb [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(define flag-hash (mhasheq)) (define flag-hash (mhasheq))
@ -17,7 +17,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
(hash-set! flag-hash flag (bitwise-bit-set? val i))) (hash-set! flag-hash flag (bitwise-bit-set? val i)))
flag-hash)) flag-hash))
(define (xbitfield-encode xb flag-hash [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (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 port (if (output-port? port-arg) port-arg (open-output-bytes)))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(define bit-int (for/sum ([(flag i) (in-indexed (xbitfield-flags xb))] (define bit-int (for/sum ([(flag i) (in-indexed (xbitfield-flags xb))]
@ -29,7 +29,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
(define (xbitfield-size xb [val #f] #:parent [parent #f]) (define (xbitfield-size xb [val #f] #:parent [parent #f])
(size (xbitfield-type xb))) (size (xbitfield-type xb)))
(struct xbitfield (type flags) #:transparent (struct xbitfield xbase (type flags) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xbitfield-decode) [(define decode xbitfield-decode)
(define encode xbitfield-encode) (define encode xbitfield-encode)

15
xenomorph/xenomorph/redo/buffer.rkt
Unescape Escape View File

@ -7,13 +7,13 @@ approximates
https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
|# |#
(define (xbuffer-decode xb [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xbuffer-decode xb [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(define decoded-len (resolve-length (xbuffer-len xb) #:parent parent)) (define decoded-len (resolve-length (xbuffer-len xb) #:parent parent))
(read-bytes decoded-len))) (read-bytes decoded-len)))
(define (xbuffer-encode xb buf [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xbuffer-encode xb buf [port-arg (current-output-port)] #:parent [parent #f])
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(unless (bytes? buf) (unless (bytes? buf)
@ -23,15 +23,14 @@ https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
(write-bytes buf) (write-bytes buf)
(unless port-arg (get-output-bytes port)))) (unless port-arg (get-output-bytes port))))
(define (xbuffer-size xb [val #f] #:parent [parent #f]) (define/finalize-size (xbuffer-size xb [val #f] #:parent [parent #f])
(when val (unless (bytes? val) (when val (unless (bytes? val)
(raise-argument-error 'xbuffer-size "bytes" val))) (raise-argument-error 'xbuffer-size "bytes" val)))
(finalize-size (if (bytes? val)
(if (bytes? val) (bytes-length val)
(bytes-length val) (resolve-length (xbuffer-len xb) val #:parent parent)))
(resolve-length (xbuffer-len xb) val #:parent parent))))
(struct xbuffer (len) #:transparent (struct xbuffer xbase (len) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xbuffer-decode) [(define decode xbuffer-decode)
(define encode xbuffer-encode) (define encode xbuffer-encode)

6
xenomorph/xenomorph/redo/enum.rkt
Unescape Escape View File

@ -7,7 +7,7 @@ approximates
https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
|# |#
(define (xenum-decode xe [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xenum-decode xe [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(define index (decode (xenum-type xe))) (define index (decode (xenum-type xe)))
@ -16,7 +16,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
(define (xenum-size xe [val #f] #:parent [parent #f]) (define (xenum-size xe [val #f] #:parent [parent #f])
(size (xenum-type xe))) (size (xenum-type xe)))
(define (xenum-encode xe val [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xenum-encode xe val [port-arg (current-output-port)] #:parent [parent #f])
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(define index (index-of (xenum-options xe) val)) (define index (index-of (xenum-options xe) val))
@ -25,7 +25,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
(encode (xenum-type xe) index) (encode (xenum-type xe) index)
(unless port-arg (get-output-bytes port)))) (unless port-arg (get-output-bytes port))))
(struct xenum (type options) #:transparent (struct xenum xbase (type options) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xenum-decode) [(define decode xenum-decode)
(define encode xenum-encode) (define encode xenum-encode)

23
xenomorph/xenomorph/redo/helper.rkt
Unescape Escape View File

@ -24,7 +24,28 @@
(file-position p new-pos)) (file-position p new-pos))
(file-position p)) (file-position p))
(struct xbase (pre-encode post-decode) #:transparent #:mutable) (struct xbase ([pre-encode #:auto] [post-decode #:auto]) #:transparent #:mutable
#:auto-value values)
(define (pre-encode xb val)
((xbase-pre-encode xb) val))
(define (set-pre-encode! xb func)
(set-xbase-pre-encode! xb func))
(define (post-decode xb val)
((xbase-post-decode xb) val))
(define (set-post-decode! xb func)
(set-xbase-post-decode! xb func))
(define-syntax-rule (define/post-decode (ID X VAL . ARGS) . BODY)
(define (ID X VAL . ARGS) (post-decode X (let () . BODY))))
(define-syntax-rule (define/pre-encode (ID X VAL . ARGS) . BODY)
(define (ID X val-in . ARGS) (let ([VAL (pre-encode X val-in)]) . BODY)))
(define-syntax-rule (define/finalize-size ID+ARGS . BODY) (define ID+ARGS (finalize-size (let () . BODY))))
(define-generics xenomorphic (define-generics xenomorphic
(encode xenomorphic val [port] #:parent [parent]) (encode xenomorphic val [port] #:parent [parent])

2
xenomorph/xenomorph/redo/lazy-array.rkt
Unescape Escape View File

@ -26,7 +26,7 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee
(pos port (+ starting-pos (* (size type #f #:parent parent) index))) (pos port (+ starting-pos (* (size type #f #:parent parent) index)))
;; use explicit `port` arg below because this evaluation is delayed ;; use explicit `port` arg below because this evaluation is delayed
(begin0 (begin0
(decode type port #:parent parent) (post-decode xla (decode type port #:parent parent))
(pos port orig-pos))) (pos port orig-pos)))
(pos port (+ (pos port) (* decoded-len (size (xarray-base-type xla) #f #:parent parent)))))))) (pos port (+ (pos port) (* decoded-len (size (xarray-base-type xla) #f #:parent parent))))))))

14
xenomorph/xenomorph/redo/number.rkt
Unescape Escape View File

@ -23,7 +23,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(define system-endian (if (system-big-endian?) 'be 'le)) (define system-endian (if (system-big-endian?) 'be 'le))
(define (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f])
(unless (xint? i) (unless (xint? i)
(raise-argument-error 'encode "xint instance" i)) (raise-argument-error 'encode "xint instance" i))
(define-values (bound-min bound-max) (bounds i)) (define-values (bound-min bound-max) (bounds i))
@ -41,7 +41,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs))) (define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs)))
(if port-arg (write-bytes res) res))) (if port-arg (write-bytes res) res)))
(define (xint-decode i [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xint-decode i [port-arg (current-input-port)] #:parent [parent #f])
(unless (xint? i) (unless (xint? i)
(raise-argument-error 'decode "xint instance" i)) (raise-argument-error 'decode "xint instance" i))
(define port (->input-port port-arg)) (define port (->input-port port-arg))
@ -55,7 +55,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(arithmetic-shift b (* 8 i)))) (arithmetic-shift b (* 8 i))))
(if (xint-signed i) (unsigned->signed uint (bits i)) uint))) (if (xint-signed i) (unsigned->signed uint (bits i)) uint)))
(struct xnumber () #:transparent) (struct xnumber xbase () #:transparent)
(struct xint xnumber (size signed endian) #:transparent (struct xint xnumber (size signed endian) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
@ -157,13 +157,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(check-equal? (encode int8 -1 #f) (bytes 255)) (check-equal? (encode int8 -1 #f) (bytes 255))
(check-equal? (encode int8 127 #f) (bytes 127))) (check-equal? (encode int8 127 #f) (bytes 127)))
(define (xfloat-decode xf [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xfloat-decode xf [port-arg (current-input-port)] #:parent [parent #f])
(unless (xfloat? xf) (unless (xfloat? xf)
(raise-argument-error 'decode "xfloat instance" xf)) (raise-argument-error 'decode "xfloat instance" xf))
(define bs (read-bytes (xfloat-size xf) (->input-port port-arg))) (define bs (read-bytes (xfloat-size xf) (->input-port port-arg)))
(floating-point-bytes->real bs (eq? (xfloat-endian xf) 'be))) (floating-point-bytes->real bs (eq? (xfloat-endian xf) 'be)))
(define (xfloat-encode xf val [port (current-output-port)] #:parent [parent #f]) (define/pre-encode (xfloat-encode xf val [port (current-output-port)] #:parent [parent #f])
(unless (xfloat? xf) (unless (xfloat? xf)
(raise-argument-error 'encode "xfloat instance" xf)) (raise-argument-error 'encode "xfloat instance" xf))
(unless (or (not port) (output-port? port)) (unless (or (not port) (output-port? port))
@ -192,13 +192,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(define doublebe (+xfloat 8 #:endian 'be)) (define doublebe (+xfloat 8 #:endian 'be))
(define doublele (+xfloat 8 #:endian 'le)) (define doublele (+xfloat 8 #:endian 'le))
(define (xfixed-decode xf [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xfixed-decode xf [port-arg (current-input-port)] #:parent [parent #f])
(unless (xfixed? xf) (unless (xfixed? xf)
(raise-argument-error 'decode "xfixed instance" xf)) (raise-argument-error 'decode "xfixed instance" xf))
(define int (xint-decode xf port-arg)) (define int (xint-decode xf port-arg))
(exact-if-possible (/ int (fixed-shift xf) 1.0))) (exact-if-possible (/ int (fixed-shift xf) 1.0)))
(define (xfixed-encode xf val [port (current-output-port)] #:parent [parent #f]) (define/pre-encode (xfixed-encode xf val [port (current-output-port)] #:parent [parent #f])
(unless (xfixed? xf) (unless (xfixed? xf)
(raise-argument-error 'encode "xfixed instance" xf)) (raise-argument-error 'encode "xfixed instance" xf))
(define int (exact-if-possible (floor (* val (fixed-shift xf))))) (define int (exact-if-possible (floor (* val (fixed-shift xf)))))

13
xenomorph/xenomorph/redo/optional.rkt
Unescape Escape View File

@ -13,25 +13,24 @@ https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
(maybe-proc parent) (maybe-proc parent)
maybe-proc)) maybe-proc))
(define (xoptional-decode xo [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xoptional-decode xo [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(when (resolve-condition xo parent) (when (resolve-condition xo parent)
(decode (xoptional-type xo) #:parent parent)))) (decode (xoptional-type xo) #:parent parent))))
(define (xoptional-encode xo val [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xoptional-encode xo val [port-arg (current-output-port)] #:parent [parent #f])
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(when (resolve-condition xo parent) (when (resolve-condition xo parent)
(encode (xoptional-type xo) val #:parent parent)) (encode (xoptional-type xo) val #:parent parent))
(unless port-arg (get-output-bytes port)))) (unless port-arg (get-output-bytes port))))
(define (xoptional-size xo [val #f] #:parent [parent #f]) (define/finalize-size (xoptional-size xo [val #f] #:parent [parent #f])
(finalize-size (when (resolve-condition xo parent)
(when (resolve-condition xo parent) (size (xoptional-type xo) val #:parent parent)))
(size (xoptional-type xo) val #:parent parent))))
(struct xoptional (type condition) #:transparent (struct xoptional xbase (type condition) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xoptional-decode) [(define decode xoptional-decode)
(define encode xoptional-encode) (define encode xoptional-encode)

6
xenomorph/xenomorph/redo/pointer.rkt
Unescape Escape View File

@ -14,7 +14,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[(dict-ref parent 'parent #f) => find-top-parent] [(dict-ref parent 'parent #f) => find-top-parent]
[else parent])) [else parent]))
(define (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(define offset (decode (xpointer-offset-type xp) #:parent parent)) (define offset (decode (xpointer-offset-type xp) #:parent parent))
@ -52,7 +52,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))] [(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))]
[else (raise-argument-error 'Pointer:size "VoidPointer" val)])) [else (raise-argument-error 'Pointer:size "VoidPointer" val)]))
(define (xpointer-encode xp val [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xpointer-encode xp val [port-arg (current-output-port)] #:parent [parent #f])
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(unless parent ; todo: furnish default pointer context? adapt from Struct? (unless parent ; todo: furnish default pointer context? adapt from Struct?
(raise-argument-error 'xpointer-encode "valid pointer context" parent)) (raise-argument-error 'xpointer-encode "valid pointer context" parent))
@ -90,7 +90,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
(+ (dict-ref parent 'pointerSize) (size type val #:parent parent))))) (+ (dict-ref parent 'pointerSize) (size type val #:parent parent)))))
(size (xpointer-offset-type xp)))) (size (xpointer-offset-type xp))))
(struct xpointer (offset-type type options) #:transparent (struct xpointer xbase (offset-type type options) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xpointer-decode) [(define decode xpointer-decode)
(define encode xpointer-encode) (define encode xpointer-encode)

10
xenomorph/xenomorph/redo/reserved.rkt
Unescape Escape View File

@ -7,22 +7,22 @@ approximates
https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee
|# |#
(define (xreserved-decode xo [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xreserved-decode xo [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(pos port (+ (pos port) (size xo #f #:parent parent))) (pos port (+ (pos port) (size xo #f #:parent parent)))
(void)) (void))
(define (xreserved-encode xo val [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xreserved-encode xo val [port-arg (current-output-port)] #:parent [parent #f])
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(write-bytes (make-bytes (size xo val #:parent parent) 0) port) (write-bytes (make-bytes (size xo val #:parent parent) 0) port)
(unless port-arg (get-output-bytes port))) (unless port-arg (get-output-bytes port)))
(define (xreserved-size xo [val #f] #:parent [parent #f]) (define/finalize-size (xreserved-size xo [val #f] #:parent [parent #f])
(define item-size (size (xreserved-type xo))) (define item-size (size (xreserved-type xo)))
(define count (resolve-length (xreserved-count xo) #f #:parent parent)) (define count (resolve-length (xreserved-count xo) #f #:parent parent))
(finalize-size (* item-size count))) (* item-size count))
(struct xreserved (type count) #:transparent (struct xreserved xbase (type count) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xreserved-decode) [(define decode xreserved-decode)
(define encode xreserved-encode) (define encode xreserved-encode)

33
xenomorph/xenomorph/redo/string.rkt
Unescape Escape View File

@ -39,7 +39,7 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
[(ascii utf8) string->bytes/utf-8])) [(ascii utf8) string->bytes/utf-8]))
(bytes-length (encoder (format "~a" val)))) (bytes-length (encoder (format "~a" val))))
(define (xstring-decode xs [port-arg (current-input-port)] #:parent [parent #f]) (define/post-decode (xstring-decode xs [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg)) (define port (->input-port port-arg))
(parameterize ([current-input-port port]) (parameterize ([current-input-port port])
(let ([len (or (resolve-length (xstring-len xs) #:parent parent) (count-nonzero-chars port))] (let ([len (or (resolve-length (xstring-len xs) #:parent parent) (count-nonzero-chars port))]
@ -51,7 +51,7 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
(pos port (+ (pos port) adjustment)) (pos port (+ (pos port) adjustment))
string))) string)))
(define (xstring-encode xs val [port-arg (current-output-port)] #:parent [parent #f]) (define/pre-encode (xstring-encode xs val [port-arg (current-output-port)] #:parent [parent #f])
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
(let* ([val (format "~a" val)] (let* ([val (format "~a" val)]
@ -67,21 +67,20 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
(when (not (xstring-len xs)) (write-byte #x00)) ; null terminated when no len (when (not (xstring-len xs)) (write-byte #x00)) ; null terminated when no len
(unless port-arg (get-output-bytes port))))) (unless port-arg (get-output-bytes port)))))
(define (xstring-size xs [val #f] #:parent [parent #f]) (define/finalize-size (xstring-size xs [val #f] #:parent [parent #f])
(finalize-size (cond
(cond [val (define encoding (if (procedure? (xstring-encoding xs))
[val (define encoding (if (procedure? (xstring-encoding xs)) (or ((xstring-encoding xs) (and parent (dict-ref parent val)) 'ascii))
(or ((xstring-encoding xs) (and parent (dict-ref parent val)) 'ascii)) (xstring-encoding xs)))
(xstring-encoding xs))) (define string-size (byte-length val (if (eq? encoding 'utf16be) 'utf16le encoding)))
(define string-size (byte-length val (if (eq? encoding 'utf16be) 'utf16le encoding))) (define strlen-size (cond
(define strlen-size (cond [(not (xstring-len xs)) 1]
[(not (xstring-len xs)) 1] [(xint? (xstring-len xs)) (size (xstring-len xs))]
[(xint? (xstring-len xs)) (size (xstring-len xs))] [else 0]))
[else 0])) (+ string-size strlen-size)]
(+ string-size strlen-size)] [else (resolve-length (xstring-len xs) #f #:parent parent)]))
[else (resolve-length (xstring-len xs) #f #:parent parent)])))
(struct xstring xbase (len encoding) #:transparent
(struct xstring (len encoding) #:transparent
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xstring-decode) [(define decode xstring-decode)
(define encode xstring-encode) (define encode xstring-encode)

32
xenomorph/xenomorph/redo/struct.rkt
Unescape Escape View File

@ -60,20 +60,20 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(let* ([sdr (_setup port parent len)] ; returns StructDictRes (let* ([sdr (_setup port parent len)] ; returns StructDictRes
[sdr (_parse-fields port sdr (xstruct-fields xs))]) [sdr (_parse-fields port sdr (xstruct-fields xs))])
sdr)) sdr))
(let* ([res ((xstruct-post-decode xs) res port parent)] (let* ([res (post-decode xs res)]
#;[res (inner res post-decode res . args)]) #;[res (inner res post-decode res . args)])
(unless (d:dict? res) (raise-result-error 'xstruct-decode "dict" res)) (unless (d:dict? res) (raise-result-error 'xstruct-decode "dict" res))
res))) res)))
(define (xstruct-size xs [val #f] #:parent [parent-arg #f] [include-pointers #t]) (define/finalize-size (xstruct-size xs [val #f] #:parent [parent-arg #f] [include-pointers #t])
(define parent (mhasheq 'parent parent-arg (define parent (mhasheq 'parent parent-arg
'val val 'val val
'pointerSize 0)) 'pointerSize 0))
(define fields-size (for/sum ([(key type) (d:in-dict (xstruct-fields xs))] (define fields-size (for/sum ([(key type) (d:in-dict (xstruct-fields xs))]
#:when (xenomorphic? type)) #:when (xenomorphic? type))
(size type (and val (d:dict-ref val key)) #:parent parent))) (size type (and val (d:dict-ref val key)) #:parent parent)))
(define pointers-size (if include-pointers (d:dict-ref parent 'pointerSize) 0)) (define pointers-size (if include-pointers (d:dict-ref parent 'pointerSize) 0))
(finalize-size (+ fields-size pointers-size))) (+ fields-size pointers-size))
(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f]) (define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f])
(unless (d:dict? val-arg) (unless (d:dict? val-arg)
@ -81,7 +81,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(define port (if (output-port? port-arg) port-arg (open-output-bytes))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
(parameterize ([current-output-port port]) (parameterize ([current-output-port port])
;; check keys first, since `size` also relies on keys being valid ;; check keys first, since `size` also relies on keys being valid
(define val (let* ([val ((xstruct-pre-encode xs) val-arg port)] (define val (let* ([val (pre-encode xs val-arg)]
#;[val (inner res pre-encode val . args)]) #;[val (inner res pre-encode val . args)])
(unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val)) (unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val))
val)) val))
@ -90,10 +90,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(format "dict that contains superset of Struct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val))) (format "dict that contains superset of Struct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val)))
(define parent (mhash 'pointers empty (define parent (mhash 'pointers empty
'startOffset (pos port) 'startOffset (pos port)
'parent parent-arg 'parent parent-arg
'val val 'val val
'pointerSize 0)) 'pointerSize 0))
; deliberately use `xstruct-size` instead of `size` to use extra arg ; deliberately use `xstruct-size` instead of `size` to use extra arg
(d:dict-set! parent 'pointerOffset (+ (pos port) (xstruct-size xs val #:parent parent #f))) (d:dict-set! parent 'pointerOffset (+ (pos port) (xstruct-size xs val #:parent parent #f)))
@ -104,17 +104,17 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent))) (encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent)))
(unless port-arg (get-output-bytes port)))) (unless port-arg (get-output-bytes port))))
(struct structish () #:transparent) (struct structish xbase () #:transparent)
(struct xstruct structish (fields post-decode pre-encode) #:transparent #:mutable (struct xstruct structish (fields) #:transparent #:mutable
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xstruct-decode) [(define decode xstruct-decode)
(define encode xstruct-encode) (define encode xstruct-encode)
(define size xstruct-size)]) (define size xstruct-size)])
(define (+xstruct [fields null] [post-decode (λ (val port parent) val)] [pre-encode (λ (val port) val)]) (define (+xstruct [fields null])
(unless (d:dict? fields) (unless (d:dict? fields)
(raise-argument-error '+xstruct "dict" fields)) (raise-argument-error '+xstruct "dict" fields))
(xstruct fields post-decode pre-encode)) (xstruct fields))
(module+ test (module+ test
(require rackunit "number.rkt") (require rackunit "number.rkt")

Write Preview
Loading…
Cancel
Save