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

rename pointer keys

Browse Source
main
Matthew Butterick 6 years ago
parent d895e12fb2
commit 214f8992d9
6 changed files with 70 additions and 66 deletions
Show Stats Download Patch File Download Diff File

6
xenomorph/xenomorph/array.rkt
Unescape Escape View File

@ -63,13 +63,13 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(send @type x:encode item port parent)))) (send @type x:encode item port parent))))
(cond (cond
[(x:int? @len) [(x:int? @len)
(define new-parent (mhash 'pointers null (define new-parent (mhash x:pointers-key null
'startOffset (pos port) 'startOffset (pos port)
x:parent-key parent)) x:parent-key parent))
(hash-set! new-parent 'pointerOffset (+ (pos port) (x:size array new-parent))) (hash-set! new-parent x:pointer-offset-key (+ (pos port) (x:size array new-parent)))
(send @len x:encode (length array) port) ; encode length at front (send @len x:encode (length array) port) ; encode length at front
(encode-items new-parent) (encode-items new-parent)
(for ([ptr (in-list (hash-ref new-parent 'pointers))]) ; encode pointer data at end (for ([ptr (in-list (hash-ref new-parent x:pointers-key))]) ; encode pointer data at end
(send (hash-ref ptr 'type) x:encode (hash-ref ptr 'val) port))] (send (hash-ref ptr 'type) x:encode (hash-ref ptr 'val) port))]
[else (encode-items parent)])) [else (encode-items parent)]))

6
xenomorph/xenomorph/helper.rkt
Unescape Escape View File

@ -11,8 +11,12 @@
(define x:current-offset-key 'x:current-offset) (define x:current-offset-key 'x:current-offset)
(define x:length-key 'x:length) (define x:length-key 'x:length)
(define x:parent-key 'x:parent) (define x:parent-key 'x:parent)
(define x:pointer-size-key 'x:pointer-size)
(define x:pointers-key 'x:pointers)
(define x:pointer-offset-key 'x:pointer-offset)
(define private-keys (list x:parent-key x:start-offset-key x:current-offset-key x:length-key)) (define private-keys (list x:parent-key x:start-offset-key x:current-offset-key x:length-key x:pointer-size-key
x:pointers-key x:pointer-offset-key))
(define (hash-ref* d . keys) (define (hash-ref* d . keys)
(for/fold ([d d]) (for/fold ([d d])

14
xenomorph/xenomorph/pointer.rkt
Unescape Escape View File

@ -69,12 +69,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[(local parent) (hash-ref new-parent 'startOffset)] [(local parent) (hash-ref new-parent 'startOffset)]
[(immediate) (+ (pos port) (send @offset-type x:size val-in parent))] [(immediate) (+ (pos port) (send @offset-type x:size val-in parent))]
[(global) 0]))) [(global) 0])))
(send @offset-type x:encode (- (hash-ref new-parent 'pointerOffset) relative) port) (send @offset-type x:encode (- (hash-ref new-parent x:pointer-offset-key) relative) port)
(define-values (type val) (resolve-pointer @type val-in)) (define-values (type val) (resolve-pointer @type val-in))
(hash-update! new-parent 'pointers (hash-update! new-parent x:pointers-key
(λ (ptrs) (append ptrs (list (mhasheq 'type type 'val val x:parent-key parent))))) (λ (ptrs) (append ptrs (list (mhasheq 'type type 'val val x:parent-key parent)))))
(hash-set! new-parent 'pointerOffset (hash-set! new-parent x:pointer-offset-key
(+ (hash-ref new-parent 'pointerOffset) (send type x:size val parent)))] (+ (hash-ref new-parent x:pointer-offset-key) (send type x:size val parent)))]
[else (send @offset-type x:encode @null-value port)])) [else (send @offset-type x:encode @null-value port)]))
(define/augment (x:size [val-in #f] [parent #f]) (define/augment (x:size [val-in #f] [parent #f])
@ -85,9 +85,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[else (error 'unknown-pointer-style)])) [else (error 'unknown-pointer-style)]))
(define-values (type val) (resolve-pointer @type val-in)) (define-values (type val) (resolve-pointer @type val-in))
(when (and val new-parent) (when (and val new-parent)
(hash-set! new-parent 'pointerSize (hash-set! new-parent x:pointer-size-key
(and (hash-ref new-parent 'pointerSize #f) (and (hash-ref new-parent x:pointer-size-key #f)
(+ (hash-ref new-parent 'pointerSize) (send type x:size val new-parent))))) (+ (hash-ref new-parent x:pointer-size-key) (send type x:size val new-parent)))))
(send @offset-type x:size)))) (send @offset-type x:size))))
(define (x:pointer [offset-arg #f] [type-arg #f] (define (x:pointer [offset-arg #f] [type-arg #f]

12
xenomorph/xenomorph/struct.rkt
Unescape Escape View File

@ -70,25 +70,25 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(raise-argument-error 'xstruct-encode (raise-argument-error 'xstruct-encode
(format "dict that contains superset of xstruct keys: ~a" (format "dict that contains superset of xstruct keys: ~a"
(dict-keys @fields)) (dict-keys val))) (dict-keys @fields)) (dict-keys val)))
(define parent (mhash 'pointers empty (define parent (mhash x:pointers-key empty
'startOffset (pos port) 'startOffset (pos port)
x:parent-key parent-arg x:parent-key parent-arg
'val val 'val val
'pointerSize 0)) x:pointer-size-key 0))
(dict-set! parent 'pointerOffset (+ (pos port) (x:size val parent #f))) (dict-set! parent x:pointer-offset-key (+ (pos port) (x:size val parent #f)))
(for ([(key type) (in-dict @fields)]) (for ([(key type) (in-dict @fields)])
(send type x:encode (dict-ref val key) port parent)) (send type x:encode (dict-ref val key) port parent))
(for ([ptr (in-list (dict-ref parent 'pointers))]) (for ([ptr (in-list (dict-ref parent x:pointers-key))])
(send (dict-ref ptr 'type) x:encode (dict-ref ptr 'val) port (dict-ref ptr x:parent-key)))) (send (dict-ref ptr 'type) x:encode (dict-ref ptr 'val) port (dict-ref ptr x:parent-key))))
(define/augride (x:size [val #f] [parent-arg #f] [include-pointers #t]) (define/augride (x:size [val #f] [parent-arg #f] [include-pointers #t])
(define parent (mhasheq x:parent-key parent-arg (define parent (mhasheq x:parent-key parent-arg
'val val 'val val
'pointerSize 0)) x:pointer-size-key 0))
(define fields-size (for/sum ([(key type) (in-dict @fields)] (define fields-size (for/sum ([(key type) (in-dict @fields)]
#:when (xenomorphic-type? type)) #:when (xenomorphic-type? type))
(send type x:size (and val (dict-ref val key)) parent))) (send type x:size (and val (dict-ref val key)) parent)))
(define pointers-size (if include-pointers (dict-ref parent 'pointerSize) 0)) (define pointers-size (if include-pointers (dict-ref parent x:pointer-size-key) 0))
(+ fields-size pointers-size)))) (+ fields-size pointers-size))))
(define (x:struct? x) (is-a? x x:struct%)) (define (x:struct? x) (is-a? x x:struct%))

86
xenomorph/xenomorph/test/pointer-test.rkt
Unescape Escape View File

@ -57,37 +57,37 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"pointer: size" "pointer: size"
(let ([parent (mhash 'pointerSize 0)]) (let ([parent (mhash x:pointer-size-key 0)])
(check-equal? (size (x:pointer) 10 #:parent parent) 1) (check-equal? (size (x:pointer) 10 #:parent parent) 1)
(check-equal? (hash-ref parent 'pointerSize) 1))) (check-equal? (hash-ref parent x:pointer-size-key) 1)))
(test-case (test-case
"pointer: size should add to immediate pointerSize" "pointer: size should add to immediate pointerSize"
(let ([parent (mhash 'pointerSize 0)]) (let ([parent (mhash x:pointer-size-key 0)])
(check-equal? (size (x:pointer #:relative-to 'immediate) 10 #:parent parent) 1) (check-equal? (size (x:pointer #:relative-to 'immediate) 10 #:parent parent) 1)
(check-equal? (hash-ref parent 'pointerSize) 1))) (check-equal? (hash-ref parent x:pointer-size-key) 1)))
(test-case (test-case
"pointer: size should add to parent pointerSize" "pointer: size should add to parent pointerSize"
(let ([parent (mhash x:parent-key (mhash 'pointerSize 0))]) (let ([parent (mhash x:parent-key (mhash x:pointer-size-key 0))])
(check-equal? (size (x:pointer #:relative-to 'parent) 10 #:parent parent) 1) (check-equal? (size (x:pointer #:relative-to 'parent) 10 #:parent parent) 1)
(check-equal? (hash-ref* parent x:parent-key 'pointerSize) 1))) (check-equal? (hash-ref* parent x:parent-key x:pointer-size-key) 1)))
(test-case (test-case
"pointer: size should add to global pointerSize" "pointer: size should add to global pointerSize"
(let ([parent (mhash x:parent-key (mhash x:parent-key (mhash x:parent-key (mhash 'pointerSize 0))))]) (let ([parent (mhash x:parent-key (mhash x:parent-key (mhash x:parent-key (mhash x:pointer-size-key 0))))])
(check-equal? (size (x:pointer #:relative-to 'global) 10 #:parent parent) 1) (check-equal? (size (x:pointer #:relative-to 'global) 10 #:parent parent) 1)
(check-equal? (hash-ref* parent x:parent-key x:parent-key x:parent-key 'pointerSize) 1))) (check-equal? (hash-ref* parent x:parent-key x:parent-key x:parent-key x:pointer-size-key) 1)))
(test-case (test-case
"pointer: size should handle void pointers" "pointer: size should handle void pointers"
(let ([parent (mhash 'pointerSize 0)]) (let ([parent (mhash x:pointer-size-key 0)])
(check-equal? (size (x:pointer uint8 'void) (x:void-pointer uint8 50) #:parent parent) 1) (check-equal? (size (x:pointer uint8 'void) (x:void-pointer uint8 50) #:parent parent) 1)
(check-equal? (hash-ref parent 'pointerSize) 1))) (check-equal? (hash-ref parent x:pointer-size-key) 1)))
(test-case (test-case
"pointer: size should throw if no type and not a void pointer" "pointer: size should throw if no type and not a void pointer"
(let ([parent (mhash 'pointerSize 0)]) (let ([parent (mhash x:pointer-size-key 0)])
(check-exn exn:fail:contract? (λ () (size (x:pointer uint8 'void) 30 #:parent parent))))) (check-exn exn:fail:contract? (λ () (size (x:pointer uint8 'void) 30 #:parent parent)))))
(test-case (test-case
@ -97,24 +97,24 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"pointer: encode should handle null pointers" "pointer: encode should handle null pointers"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash 'pointerSize 0 (define parent (mhash x:pointer-size-key 0
'startOffset 0 'startOffset 0
'pointerOffset 0 x:pointer-offset-key 0
'pointers null)) x:pointers-key null))
(encode (x:pointer) #f #:parent parent) (encode (x:pointer) #f #:parent parent)
(check-equal? (hash-ref parent 'pointerSize) 0) (check-equal? (hash-ref parent x:pointer-size-key) 0)
(check-equal? (get-output-bytes (current-output-port)) (bytes 0)))) (check-equal? (get-output-bytes (current-output-port)) (bytes 0))))
(test-case (test-case
"pointer: encode should handle local offsets" "pointer: encode should handle local offsets"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash 'pointerSize 0 (define parent (mhash x:pointer-size-key 0
'startOffset 0 'startOffset 0
'pointerOffset 1 x:pointer-offset-key 1
'pointers null)) x:pointers-key null))
(encode (x:pointer) 10 #:parent parent) (encode (x:pointer) 10 #:parent parent)
(check-equal? (hash-ref parent 'pointerOffset) 2) (check-equal? (hash-ref parent x:pointer-offset-key) 2)
(check-equal? (hash-ref parent 'pointers) (list (mhasheq 'type uint8 (check-equal? (hash-ref parent x:pointers-key) (list (mhasheq 'type uint8
'val 10 'val 10
x:parent-key parent))) x:parent-key parent)))
(check-equal? (get-output-bytes (current-output-port)) (bytes 1)))) (check-equal? (get-output-bytes (current-output-port)) (bytes 1))))
@ -122,13 +122,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"pointer: encode should handle immediate offsets" "pointer: encode should handle immediate offsets"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash 'pointerSize 0 (define parent (mhash x:pointer-size-key 0
'startOffset 0 'startOffset 0
'pointerOffset 1 x:pointer-offset-key 1
'pointers null)) x:pointers-key null))
(encode (x:pointer #:relative-to 'immediate) 10 #:parent parent) (encode (x:pointer #:relative-to 'immediate) 10 #:parent parent)
(check-equal? (hash-ref parent 'pointerOffset) 2) (check-equal? (hash-ref parent x:pointer-offset-key) 2)
(check-equal? (hash-ref parent 'pointers) (list (mhasheq 'type uint8 (check-equal? (hash-ref parent x:pointers-key) (list (mhasheq 'type uint8
'val 10 'val 10
x:parent-key parent))) x:parent-key parent)))
(check-equal? (get-output-bytes (current-output-port)) (bytes 0)))) (check-equal? (get-output-bytes (current-output-port)) (bytes 0))))
@ -136,13 +136,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"pointer: encode should handle offsets relative to parent" "pointer: encode should handle offsets relative to parent"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash x:parent-key (mhash 'pointerSize 0 (define parent (mhash x:parent-key (mhash x:pointer-size-key 0
'startOffset 3 'startOffset 3
'pointerOffset 5 x:pointer-offset-key 5
'pointers null))) x:pointers-key null)))
(encode (x:pointer #:relative-to 'parent) 10 #:parent parent) (encode (x:pointer #:relative-to 'parent) 10 #:parent parent)
(check-equal? (hash-ref* parent x:parent-key 'pointerOffset) 6) (check-equal? (hash-ref* parent x:parent-key x:pointer-offset-key) 6)
(check-equal? (hash-ref* parent x:parent-key 'pointers) (list (mhasheq 'type uint8 (check-equal? (hash-ref* parent x:parent-key x:pointers-key) (list (mhasheq 'type uint8
'val 10 'val 10
x:parent-key parent))) x:parent-key parent)))
(check-equal? (get-output-bytes (current-output-port)) (bytes 2)))) (check-equal? (get-output-bytes (current-output-port)) (bytes 2))))
@ -152,13 +152,13 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash x:parent-key (define parent (mhash x:parent-key
(mhash x:parent-key (mhash x:parent-key
(mhash x:parent-key (mhash 'pointerSize 0 (mhash x:parent-key (mhash x:pointer-size-key 0
'startOffset 3 'startOffset 3
'pointerOffset 5 x:pointer-offset-key 5
'pointers null))))) x:pointers-key null)))))
(encode (x:pointer #:relative-to 'global) 10 #:parent parent) (encode (x:pointer #:relative-to 'global) 10 #:parent parent)
(check-equal? (hash-ref* parent x:parent-key x:parent-key x:parent-key 'pointerOffset) 6) (check-equal? (hash-ref* parent x:parent-key x:parent-key x:parent-key x:pointer-offset-key) 6)
(check-equal? (hash-ref* parent x:parent-key x:parent-key x:parent-key 'pointers) (check-equal? (hash-ref* parent x:parent-key x:parent-key x:parent-key x:pointers-key)
(list (mhasheq 'type uint8 (list (mhasheq 'type uint8
'val 10 'val 10
x:parent-key parent))) x:parent-key parent)))
@ -167,20 +167,20 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
(test-case (test-case
"pointer: encode should support void pointers" "pointer: encode should support void pointers"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash 'pointerSize 0 (define parent (mhash x:pointer-size-key 0
'startOffset 0 'startOffset 0
'pointerOffset 1 x:pointer-offset-key 1
'pointers null)) x:pointers-key null))
(encode (x:pointer uint8 'void) (x:void-pointer uint8 55) #:parent parent) (encode (x:pointer uint8 'void) (x:void-pointer uint8 55) #:parent parent)
(check-equal? (hash-ref parent 'pointerOffset) 2) (check-equal? (hash-ref parent x:pointer-offset-key) 2)
(check-equal? (hash-ref parent 'pointers) (list (mhasheq 'type uint8 'val 55 x:parent-key parent))) (check-equal? (hash-ref parent x:pointers-key) (list (mhasheq 'type uint8 'val 55 x:parent-key parent)))
(check-equal? (get-output-bytes (current-output-port)) (bytes 1)))) (check-equal? (get-output-bytes (current-output-port)) (bytes 1))))
(test-case (test-case
"pointer: encode should throw if not a void pointer instance" "pointer: encode should throw if not a void pointer instance"
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(define parent (mhash 'pointerSize 0 (define parent (mhash x:pointer-size-key 0
'startOffset 0 'startOffset 0
'pointerOffset 1 x:pointer-offset-key 1
'pointers null)) x:pointers-key null))
(check-exn exn:fail:contract? (λ () (encode (x:pointer uint8 'void) 44 #:parent parent))))) (check-exn exn:fail:contract? (λ () (encode (x:pointer uint8 'void) 44 #:parent parent)))))

12
xenomorph/xenomorph/versioned-struct.rkt
Unescape Escape View File

@ -64,12 +64,12 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(define/override (x:encode encode-me port [parent-arg #f]) (define/override (x:encode encode-me port [parent-arg #f])
(unless (dict? encode-me) (unless (dict? encode-me)
(raise-argument-error 'xversioned-struct-encode "dict" encode-me)) (raise-argument-error 'xversioned-struct-encode "dict" encode-me))
(define parent (mhash 'pointers null (define parent (mhash x:pointers-key null
'startOffset (pos port) 'startOffset (pos port)
x:parent-key parent-arg x:parent-key parent-arg
'val encode-me 'val encode-me
'pointerSize 0)) x:pointer-size-key 0))
(dict-set! parent 'pointerOffset (+ (pos port) (x:size encode-me parent #f))) (dict-set! parent x:pointer-offset-key (+ (pos port) (x:size encode-me parent #f)))
(unless (or (symbol? @type) (procedure? @type)) (unless (or (symbol? @type) (procedure? @type))
(send @type x:encode (dict-ref encode-me x:version-key #f) port parent)) (send @type x:encode (dict-ref encode-me x:version-key #f) port parent))
(define maybe-header-dict (dict-ref @versions 'header #f)) (define maybe-header-dict (dict-ref @versions 'header #f))
@ -82,13 +82,13 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys encode-me))) (raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys encode-me)))
(for ([(key type) (in-dict fields)]) (for ([(key type) (in-dict fields)])
(send type x:encode (dict-ref encode-me key) port parent)) (send type x:encode (dict-ref encode-me key) port parent))
(for ([ptr (in-list (dict-ref parent 'pointers))]) (for ([ptr (in-list (dict-ref parent x:pointers-key))])
(send (dict-ref ptr 'type) x:encode (dict-ref ptr 'val) port (dict-ref ptr x:parent-key)))) (send (dict-ref ptr 'type) x:encode (dict-ref ptr 'val) port (dict-ref ptr x:parent-key))))
(define/override (x:size [val #f] [parent-arg #f] [include-pointers #t]) (define/override (x:size [val #f] [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 x:parent-key parent-arg 'val val 'pointerSize 0)) (define parent (mhash x:parent-key parent-arg 'val val x:pointer-size-key 0))
(define version-size (define version-size
(let ([struct-type @type]) (let ([struct-type @type])
(if (or (symbol? struct-type) (procedure? struct-type)) (if (or (symbol? struct-type) (procedure? struct-type))
@ -100,7 +100,7 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(define fields-size (define fields-size
(for/sum ([(key type) (in-dict (extract-fields-dict val))]) (for/sum ([(key type) (in-dict (extract-fields-dict val))])
(send type x:size (and val (dict-ref val key)) parent))) (send type x:size (and val (dict-ref val key)) parent)))
(define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0)) (define pointer-size (if include-pointers (dict-ref parent x:pointer-size-key) 0))
(+ version-size header-size fields-size pointer-size)))) (+ version-size header-size fields-size pointer-size))))
(define (x:versioned-struct? x) (is-a? x x:versioned-struct%)) (define (x:versioned-struct? x) (is-a? x x:versioned-struct%))

Write Preview
Loading…
Cancel
Save