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

add kwarg to `size`

Browse Source
main
Matthew Butterick 6 years ago
parent e83dac781b
commit c9f87e364b
14 changed files with 86 additions and 86 deletions
Show Stats Download Patch File Download Diff File

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

@ -51,7 +51,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(let ([parent (mhash 'pointers null (let ([parent (mhash 'pointers null
'startOffset (pos port) 'startOffset (pos port)
'parent parent)]) 'parent parent)])
(dict-set! parent 'pointerOffset (+ (pos port) (size xa array parent))) (dict-set! parent 'pointerOffset (+ (pos port) (size xa array #:parent parent)))
(encode (xarray-base-len xa) (length array)) ; encode length at front (encode (xarray-base-len xa) (length array)) ; encode length at front
(encode-items parent) (encode-items parent)
(for ([ptr (in-list (dict-ref parent 'pointers))]) ; encode pointer data at end (for ([ptr (in-list (dict-ref parent 'pointers))]) ; encode pointer data at end
@ -59,7 +59,7 @@ 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 #f]) (define (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)))
(cond (cond
@ -67,9 +67,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(values (mhasheq 'parent parent) (size (xarray-base-len xa))) (values (mhasheq 'parent parent) (size (xarray-base-len xa)))
(values parent 0))]) (values parent 0))])
(+ len-size (for/sum ([item val]) (+ len-size (for/sum ([item val])
(size (xarray-base-type xa) item parent))))] (size (xarray-base-type xa) item #:parent parent))))]
[else (let ([item-count (resolve-length (xarray-base-len xa) #f #:parent parent)] [else (let ([item-count (resolve-length (xarray-base-len xa) #f #:parent parent)]
[item-size (size (xarray-base-type xa) #f parent)]) [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 (type len) #:transparent)

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

@ -26,7 +26,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
(encode (xbitfield-type xb) bit-int) (encode (xbitfield-type xb) bit-int)
(unless port-arg (get-output-bytes port)))) (unless port-arg (get-output-bytes port))))
(define (xbitfield-size xb [val #f] [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 (type flags) #:transparent

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

@ -23,7 +23,7 @@ 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 #f]) (define (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)))
(if (bytes? val) (if (bytes? val)

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

@ -13,7 +13,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
(define index (decode (xenum-type xe))) (define index (decode (xenum-type xe)))
(or (list-ref (xenum-options xe) index) index))) (or (list-ref (xenum-options xe) index) index)))
(define (xenum-size xe [val #f] [parent #f]) (size (xenum-type xe))) (define (xenum-size xe [val #f] #:parent [parent #f]) (size (xenum-type xe)))
(define (xenum-encode xe val [port-arg (current-output-port)] #:parent [parent #f]) (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))) (define port (if (output-port? port-arg) port-arg (open-output-bytes)))

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

@ -27,6 +27,6 @@
(define-generics xenomorphic (define-generics xenomorphic
(encode xenomorphic val [port] #:parent [parent]) (encode xenomorphic val [port] #:parent [parent])
(decode xenomorphic [port] #:parent [parent]) (decode xenomorphic [port] #:parent [parent])
(size xenomorphic [item] [parent])) (size xenomorphic [item] #:parent [parent]))
(struct lazy-thunk (proc) #:transparent) (struct lazy-thunk (proc) #:transparent)

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

@ -22,18 +22,18 @@ https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee
(define res (for/stream ([index (in-range decoded-len)]) (define res (for/stream ([index (in-range decoded-len)])
(define type (xarray-base-type xla)) (define type (xarray-base-type xla))
(define orig-pos (pos port)) (define orig-pos (pos port))
(pos port (+ starting-pos (* (size type #f parent) index))) (pos port (+ starting-pos (* (size type #f #:parent parent) index)))
(define new-item (decode type port #:parent parent)) (define new-item (decode type port #:parent parent))
(pos port orig-pos) (pos port orig-pos)
new-item)) new-item))
(pos port (+ (pos port) (* decoded-len (size (xarray-base-type xla) #f parent)))) (pos port (+ (pos port) (* decoded-len (size (xarray-base-type xla) #f #:parent parent))))
res))) res)))
(define (xlazy-array-encode xla val [port-arg (current-output-port)] #:parent [parent #f]) (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)) (xarray-encode xla (if (stream? val) (stream->list val) val) port-arg #:parent parent))
(define (xlazy-array-size xla [val #f] [parent #f]) (define (xlazy-array-size xla [val #f] #:parent [parent #f])
(xarray-size xla (if (stream? val) (stream->list val) val) parent)) (xarray-size xla (if (stream? val) (stream->list val) val) #:parent parent))
;; xarray-base holds type and len fields ;; xarray-base holds type and len fields
(struct xlazy-array xarray-base () #:transparent (struct xlazy-array xarray-base () #:transparent

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

@ -61,7 +61,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xint-decode) [(define decode xint-decode)
(define encode xint-encode) (define encode xint-encode)
(define size (λ (i [item #f] [parent #f]) (xint-size i)))]) (define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))])
(define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian]) (define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian])
(unless (exact-positive-integer? size) (unless (exact-positive-integer? size)
@ -175,7 +175,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xfloat-decode) [(define decode xfloat-decode)
(define encode xfloat-encode) (define encode xfloat-encode)
(define size (λ (i [item #f] [parent #f]) (xfloat-size i)))]) (define size (λ (i [item #f] #:parent [parent #f]) (xfloat-size i)))])
(define (+xfloat [size 4] #:endian [endian system-endian]) (define (+xfloat [size 4] #:endian [endian system-endian])
(unless (exact-positive-integer? size) (unless (exact-positive-integer? size)
@ -208,7 +208,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
#:methods gen:xenomorphic #:methods gen:xenomorphic
[(define decode xfixed-decode) [(define decode xfixed-decode)
(define encode xfixed-encode) (define encode xfixed-encode)
(define size (λ (i [item #f] [parent #f]) (xint-size i)))]) (define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))])
(define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] [fracbits (/ (* size 8) 2)]) (define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] [fracbits (/ (* size 8) 2)])
(unless (exact-positive-integer? size) (unless (exact-positive-integer? size)

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

@ -26,9 +26,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
(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 #f]) (define (xoptional-size xo [val #f] #:parent [parent #f])
(if (resolve-condition xo parent) (if (resolve-condition xo parent)
(size (xoptional-type xo) val parent) (size (xoptional-type xo) val #:parent parent)
0)) 0))
(struct xoptional (type condition) #:transparent (struct xoptional (type condition) #:transparent

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

@ -66,7 +66,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[else (error 'unknown-pointer-style)])] [else (error 'unknown-pointer-style)])]
[relative (+ (case (pointer-style xp) [relative (+ (case (pointer-style xp)
[(local parent) (dict-ref new-parent 'startOffset)] [(local parent) (dict-ref new-parent 'startOffset)]
[(immediate) (+ (pos port) (size (xpointer-offset-type xp) val parent))] [(immediate) (+ (pos port) (size (xpointer-offset-type xp) val #:parent parent))]
[(global) 0]) [(global) 0])
((relative-getter-or-0 xp) (dict-ref parent 'val #f)))]) ((relative-getter-or-0 xp) (dict-ref parent 'val #f)))])
(encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative)) (encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative))
@ -75,10 +75,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
(list (mhasheq 'type type (list (mhasheq 'type type
'val val 'val val
'parent parent)))) 'parent parent))))
(dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type val parent))))))) (dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type val #:parent parent)))))))
(unless port-arg (get-output-bytes port))) (unless port-arg (get-output-bytes port)))
(define (xpointer-size xp [val #f] [parent #f]) (define (xpointer-size xp [val #f] #:parent [parent #f])
(let*-values ([(parent) (case (pointer-style xp) (let*-values ([(parent) (case (pointer-style xp)
[(local immediate) parent] [(local immediate) parent]
[(parent) (dict-ref parent 'parent)] [(parent) (dict-ref parent 'parent)]
@ -87,7 +87,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[(type val) (resolve-void-pointer (xpointer-type xp) val)]) [(type val) (resolve-void-pointer (xpointer-type xp) val)])
(when (and val parent) (when (and val parent)
(dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f) (dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f)
(+ (dict-ref parent 'pointerSize) (size type val 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 (offset-type type options) #:transparent

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

@ -9,15 +9,15 @@ https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee
(define (xreserved-decode xo [port-arg (current-input-port)] #:parent [parent #f]) (define (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))) (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 (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) 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 #f]) (define (xreserved-size xo [val #f] #:parent [parent #f])
(* (size (xreserved-type xo)) (resolve-length (xreserved-count xo) #f #:parent parent))) (* (size (xreserved-type xo)) (resolve-length (xreserved-count xo) #f #:parent parent)))
(struct xreserved (type count) #:transparent (struct xreserved (type count) #:transparent

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

@ -67,7 +67,7 @@ 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 #f]) (define (xstring-size xs [val #f] #:parent [parent #f])
(if (not val) (if (not val)
(resolve-length (xstring-len xs) #f #:parent parent) (resolve-length (xstring-len xs) #f #:parent parent)
(let* ([encoding (if (procedure? (xstring-encoding xs)) (let* ([encoding (if (procedure? (xstring-encoding xs))

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

@ -65,13 +65,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(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-arg #f] [include-pointers #t]) (define (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))
(+ (for/sum ([(key type) (d:in-dict (xstruct-fields xs))] (+ (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)) (size type (and val (d:dict-ref val key)) #:parent parent))
(if include-pointers (d:dict-ref parent 'pointerSize) 0))) (if include-pointers (d:dict-ref parent 'pointerSize) 0)))
(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])
@ -95,7 +95,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
'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 #f))) (d:dict-set! parent 'pointerOffset (+ (pos port) (xstruct-size xs val #:parent parent #f)))
(for ([(key type) (d:in-dict (xstruct-fields xs))]) (for ([(key type) (d:in-dict (xstruct-fields xs))])
(encode type (d:dict-ref val key) #:parent parent)) (encode type (d:dict-ref val key) #:parent parent))

106
xenomorph/xenomorph/redo/test/pointer-test.rkt
Unescape Escape View File

@ -45,7 +45,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"decode should support offsets relative to a property on the parent" "decode should support offsets relative to a property on the parent"
(parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))]) (parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))])
(check-equal? (decode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (dict-ref (dict-ref ctx 'parent) 'ptr)))) (check-equal? (decode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (parent) (dict-ref (dict-ref parent 'parent) 'ptr))))
#:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4))) #:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
53))) 53)))
@ -64,38 +64,38 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"size" "size"
(let ([ctx (mhash 'pointerSize 0)]) (let ([parent (mhash 'pointerSize 0)])
(check-equal? (size (+xpointer uint8 uint8) 10 ctx) 1) (check-equal? (size (+xpointer uint8 uint8) 10 #:parent parent) 1)
(check-equal? (dict-ref ctx 'pointerSize) 1))) (check-equal? (dict-ref parent 'pointerSize) 1)))
(test-case (test-case
"size should add to immediate pointerSize" "size should add to immediate pointerSize"
(let ([ctx (mhash 'pointerSize 0)]) (let ([parent (mhash 'pointerSize 0)])
(check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 ctx) 1) (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent parent) 1)
(check-equal? (dict-ref ctx 'pointerSize) 1))) (check-equal? (dict-ref parent 'pointerSize) 1)))
(test-case (test-case
"size should add to parent pointerSize" "size should add to parent pointerSize"
(let ([ctx (mhash 'parent (mhash 'pointerSize 0))]) (let ([parent (mhash 'parent (mhash 'pointerSize 0))])
(check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 ctx) 1) (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent parent) 1)
(check-equal? (dict-ref (dict-ref ctx 'parent) 'pointerSize) 1))) (check-equal? (dict-ref (dict-ref parent 'parent) 'pointerSize) 1)))
(test-case (test-case
"size should add to global pointerSize" "size should add to global pointerSize"
(let ([ctx (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))]) (let ([parent (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
(check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'global)) 10 ctx) 1) (check-equal? (size (+xpointer uint8 uint8 (mhash 'type 'global)) 10 #:parent parent) 1)
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref ctx 'parent) 'parent) 'parent) 'pointerSize) 1))) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerSize) 1)))
(test-case (test-case
"size should handle void pointers" "size should handle void pointers"
(let ([ctx (mhash 'pointerSize 0)]) (let ([parent (mhash 'pointerSize 0)])
(check-equal? (size (+xpointer uint8 'void) (+xvoid-pointer uint8 50) ctx) 1) (check-equal? (size (+xpointer uint8 'void) (+xvoid-pointer uint8 50) #:parent parent) 1)
(check-equal? (dict-ref ctx 'pointerSize) 1))) (check-equal? (dict-ref parent 'pointerSize) 1)))
(test-case (test-case
"size should throw if no type and not a void pointer" "size should throw if no type and not a void pointer"
(let ([ctx (mhash 'pointerSize 0)]) (let ([parent (mhash 'pointerSize 0)])
(check-exn exn:fail:contract? (λ () (size (+xpointer uint8 'void) 30 ctx))))) (check-exn exn:fail:contract? (λ () (size (+xpointer uint8 'void) 30 #:parent parent)))))
(test-case (test-case
"size should return a fixed size without a value" "size should return a fixed size without a value"
@ -104,107 +104,107 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"encode should handle null pointers" "encode should handle null pointers"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0 (define parent (mhash 'pointerSize 0
'startOffset 0 'startOffset 0
'pointerOffset 0 'pointerOffset 0
'pointers null)) 'pointers null))
(encode (+xpointer uint8 uint8) #f #:parent ctx) (encode (+xpointer uint8 uint8) #f #:parent parent)
(check-equal? (dict-ref ctx 'pointerSize) 0) (check-equal? (dict-ref parent 'pointerSize) 0)
(check-equal? (dump (current-output-port)) (bytes 0)))) (check-equal? (dump (current-output-port)) (bytes 0))))
(test-case (test-case
"encode should handle local offsets" "encode should handle local offsets"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0 (define parent (mhash 'pointerSize 0
'startOffset 0 'startOffset 0
'pointerOffset 1 'pointerOffset 1
'pointers null)) 'pointers null))
(encode (+xpointer uint8 uint8) 10 #:parent ctx) (encode (+xpointer uint8 uint8) 10 #:parent parent)
(check-equal? (dict-ref ctx 'pointerOffset) 2) (check-equal? (dict-ref parent 'pointerOffset) 2)
(check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
'parent ctx))) 'parent parent)))
(check-equal? (dump (current-output-port)) (bytes 1)))) (check-equal? (dump (current-output-port)) (bytes 1))))
(test-case (test-case
"encode should handle immediate offsets" "encode should handle immediate offsets"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0 (define parent (mhash 'pointerSize 0
'startOffset 0 'startOffset 0
'pointerOffset 1 'pointerOffset 1
'pointers null)) 'pointers null))
(encode (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent ctx) (encode (+xpointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent parent)
(check-equal? (dict-ref ctx 'pointerOffset) 2) (check-equal? (dict-ref parent 'pointerOffset) 2)
(check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
'parent ctx))) 'parent parent)))
(check-equal? (dump (current-output-port)) (bytes 0)))) (check-equal? (dump (current-output-port)) (bytes 0))))
(test-case (test-case
"encode should handle offsets relative to parent" "encode should handle offsets relative to parent"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'parent (mhash 'pointerSize 0 (define parent (mhash 'parent (mhash 'pointerSize 0
'startOffset 3 'startOffset 3
'pointerOffset 5 'pointerOffset 5
'pointers null))) 'pointers null)))
(encode (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent ctx) (encode (+xpointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent parent)
(check-equal? (dict-ref (dict-ref ctx 'parent) 'pointerOffset) 6) (check-equal? (dict-ref (dict-ref parent 'parent) 'pointerOffset) 6)
(check-equal? (dict-ref (dict-ref ctx 'parent) 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref (dict-ref parent 'parent) 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
'parent ctx))) 'parent parent)))
(check-equal? (dump (current-output-port)) (bytes 2)))) (check-equal? (dump (current-output-port)) (bytes 2))))
(test-case (test-case
"encode should handle global offsets" "encode should handle global offsets"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'parent (define parent (mhash 'parent
(mhash 'parent (mhash 'parent
(mhash 'parent (mhash 'pointerSize 0 (mhash 'parent (mhash 'pointerSize 0
'startOffset 3 'startOffset 3
'pointerOffset 5 'pointerOffset 5
'pointers null))))) 'pointers null)))))
(encode (+xpointer uint8 uint8 (mhash 'type 'global)) 10 #:parent ctx) (encode (+xpointer uint8 uint8 (mhash 'type 'global)) 10 #:parent parent)
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref ctx 'parent) 'parent) 'parent) 'pointerOffset) 6) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerOffset) 6)
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref ctx 'parent) 'parent) 'parent) 'pointers) (check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointers)
(list (mhasheq 'type uint8 (list (mhasheq 'type uint8
'val 10 'val 10
'parent ctx))) 'parent parent)))
(check-equal? (dump (current-output-port)) (bytes 5)))) (check-equal? (dump (current-output-port)) (bytes 5))))
(test-case (test-case
"encode should support offsets relative to a property on the parent" "encode should support offsets relative to a property on the parent"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0 (define parent (mhash 'pointerSize 0
'startOffset 0 'startOffset 0
'pointerOffset 10 'pointerOffset 10
'pointers null 'pointers null
'val (mhash 'ptr 4))) 'val (mhash 'ptr 4)))
(encode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (dict-ref ctx 'ptr)))) 10 #:parent ctx) (encode (+xpointer uint8 uint8 (mhash 'relativeTo (λ (parent) (dict-ref parent 'ptr)))) 10 #:parent parent)
(check-equal? (dict-ref ctx 'pointerOffset) 11) (check-equal? (dict-ref parent 'pointerOffset) 11)
(check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 10 'val 10
'parent ctx))) 'parent parent)))
(check-equal? (dump (current-output-port)) (bytes 6)))) (check-equal? (dump (current-output-port)) (bytes 6))))
(test-case (test-case
"encode should support void pointers" "encode should support void pointers"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0 (define parent (mhash 'pointerSize 0
'startOffset 0 'startOffset 0
'pointerOffset 1 'pointerOffset 1
'pointers null)) 'pointers null))
(encode (+xpointer uint8 'void) (+xvoid-pointer uint8 55) #:parent ctx) (encode (+xpointer uint8 'void) (+xvoid-pointer uint8 55) #:parent parent)
(check-equal? (dict-ref ctx 'pointerOffset) 2) (check-equal? (dict-ref parent 'pointerOffset) 2)
(check-equal? (dict-ref ctx 'pointers) (list (mhasheq 'type uint8 (check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
'val 55 'val 55
'parent ctx))) 'parent parent)))
(check-equal? (dump (current-output-port)) (bytes 1)))) (check-equal? (dump (current-output-port)) (bytes 1))))
(test-case (test-case
"encode should throw if not a void pointer instance" "encode should throw if not a void pointer instance"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define ctx (mhash 'pointerSize 0 (define parent (mhash 'pointerSize 0
'startOffset 0 'startOffset 0
'pointerOffset 1 'pointerOffset 1
'pointers null)) 'pointers null))
(check-exn exn:fail:contract? (λ () (encode (+xpointer uint8 'void) 44 #:parent ctx))))) (check-exn exn:fail:contract? (λ () (encode (+xpointer uint8 'void) 44 #:parent parent)))))

10
xenomorph/xenomorph/redo/versioned-struct.rkt
Unescape Escape View File

@ -34,22 +34,22 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
[else (_parse-fields port res fields) [else (_parse-fields port res fields)
res]) port parent)) res]) port parent))
(define (xversioned-struct-size xvs [val #f] [parent-arg #f] [include-pointers #t]) (define (xversioned-struct-size xvs [val #f] #:parent [parent-arg #f] [include-pointers #t])
(unless val (unless val
(raise-argument-error 'xversioned-struct-size "value" val)) (raise-argument-error 'xversioned-struct-size "value" val))
(define parent (mhash 'parent parent-arg 'val val 'pointerSize 0)) (define parent (mhash 'parent parent-arg 'val val 'pointerSize 0))
(define version-size (define version-size
(if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) (if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
(size (xversioned-struct-type xvs) (dict-ref val 'version) parent) (size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent)
0)) 0))
(define header-size (define header-size
(for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))]) (for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))])
(size type (and val (dict-ref val key)) parent))) (size type (and val (dict-ref val key)) #:parent parent)))
(define fields-size (define fields-size
(let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version)) (let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version))
(raise-argument-error 'xversioned-struct-size "valid version key" version))]) (raise-argument-error 'xversioned-struct-size "valid version key" version))])
(for/sum ([(key type) (in-dict fields)]) (for/sum ([(key type) (in-dict fields)])
(size type (and val (dict-ref val key)) parent)))) (size type (and val (dict-ref val key)) #:parent parent))))
(define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0)) (define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0))
(+ version-size header-size fields-size pointer-size)) (+ version-size header-size fields-size pointer-size))
@ -66,7 +66,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
'parent parent-arg 'parent parent-arg
'val val 'val val
'pointerSize 0)) 'pointerSize 0))
(dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val parent #f))) (dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val #:parent parent #f)))
(when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))) (when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
(encode (xversioned-struct-type xvs) (dict-ref val 'version #f))) (encode (xversioned-struct-type xvs) (dict-ref val 'version #f)))

Write Preview
Loading…
Cancel
Save