diff --git a/pitfall/restructure/pointer-test.rkt b/pitfall/restructure/pointer-test.rkt index 6e510612..c7c50c5e 100644 --- a/pitfall/restructure/pointer-test.rkt +++ b/pitfall/restructure/pointer-test.rkt @@ -115,7 +115,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (let ([pointer (+Pointer uint8 uint8)] [ctx (mhash 'pointerSize 0)]) (check-equal? (send pointer size 10 ctx) 1) - (check-equal? (ref ctx 'pointerSize) 1)) + (check-equal? (· ctx pointerSize) 1)) ; @@ -128,7 +128,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (let ([pointer (+Pointer uint8 uint8 (mhash 'type 'immediate))] [ctx (mhash 'pointerSize 0)]) (check-equal? (send pointer size 10 ctx) 1) - (check-equal? (ref ctx 'pointerSize) 1)) + (check-equal? (· ctx pointerSize) 1)) ; ; it 'should add to parent pointerSize', -> @@ -140,7 +140,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (let ([pointer (+Pointer uint8 uint8 (mhash 'type 'parent))] [ctx (mhash 'parent (mhash 'pointerSize 0))]) (check-equal? (send pointer size 10 ctx) 1) - (check-equal? (ref* ctx 'parent 'pointerSize) 1)) + (check-equal? (· ctx parent pointerSize) 1)) ; ; it 'should add to global pointerSize', -> @@ -152,7 +152,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (let ([pointer (+Pointer uint8 uint8 (mhash 'type 'global))] [ctx (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))]) (check-equal? (send pointer size 10 ctx) 1) - (check-equal? (ref* ctx 'parent 'parent 'parent 'pointerSize) 1)) + (check-equal? (· ctx parent parent parent pointerSize) 1)) ; it 'should handle void pointers', -> @@ -164,7 +164,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (let ([pointer (+Pointer uint8 'void)] [ctx (mhash 'pointerSize 0)]) (check-equal? (send pointer size (+VoidPointer uint8 50) ctx) 1) - (check-equal? (ref ctx 'pointerSize) 1)) + (check-equal? (· ctx pointerSize) 1)) @@ -215,7 +215,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 0 'pointers null)]) (send ptr encode stream #f ctx) - (check-equal? (ref ctx 'pointerSize) 0) + (check-equal? (· ctx pointerSize) 0) (check-equal? (send stream dump) (+Buffer '(0)))) ; @@ -248,8 +248,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 1 'pointers null)]) (send ptr encode stream 10 ctx) - (check-equal? (ref ctx 'pointerOffset) 2) - (check-equal? (ref ctx 'pointers) (list (mhash 'type uint8 + (check-equal? (· ctx pointerOffset) 2) + (check-equal? (· ctx pointers) (list (mhasheq 'type uint8 'val 10 'parent ctx))) (check-equal? (send stream dump) (+Buffer '(1)))) @@ -284,8 +284,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 1 'pointers null)]) (send ptr encode stream 10 ctx) - (check-equal? (ref ctx 'pointerOffset) 2) - (check-equal? (ref ctx 'pointers) (list (mhash 'type uint8 + (check-equal? (· ctx pointerOffset) 2) + (check-equal? (· ctx pointers) (list (mhasheq 'type uint8 'val 10 'parent ctx))) (check-equal? (send stream dump) (+Buffer '(0)))) @@ -321,8 +321,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 5 'pointers null))]) (send ptr encode stream 10 ctx) - (check-equal? (ref* ctx 'parent 'pointerOffset) 6) - (check-equal? (ref* ctx 'parent 'pointers) (list (mhash 'type uint8 + (check-equal? (· ctx parent pointerOffset) 6) + (check-equal? (· ctx parent pointers) (list (mhasheq 'type uint8 'val 10 'parent ctx))) (check-equal? (send stream dump) (+Buffer '(2)))) @@ -363,8 +363,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 5 'pointers null))))]) (send ptr encode stream 10 ctx) - (check-equal? (ref* ctx 'parent 'parent 'parent 'pointerOffset) 6) - (check-equal? (ref* ctx 'parent 'parent 'parent 'pointers) (list (mhash 'type uint8 + (check-equal? (· ctx parent parent parent pointerOffset) 6) + (check-equal? (· ctx parent parent parent pointers) (list (mhasheq 'type uint8 'val 10 'parent ctx))) (check-equal? (send stream dump) (+Buffer '(5)))) @@ -396,15 +396,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee (let ([stream (+EncodeStream)] - [ptr (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (ref ctx 'ptr))))] + [ptr (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx ptr))))] [ctx (mhash 'pointerSize 0 'startOffset 0 'pointerOffset 10 'pointers null 'val (mhash 'ptr 4))]) (send ptr encode stream 10 ctx) - (check-equal? (ref ctx 'pointerOffset) 11) - (check-equal? (ref ctx 'pointers) (list (mhash 'type uint8 + (check-equal? (· ctx pointerOffset) 11) + (check-equal? (· ctx pointers) (list (mhasheq 'type uint8 'val 10 'parent ctx))) (check-equal? (send stream dump) (+Buffer '(6)))) @@ -438,8 +438,8 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee 'pointerOffset 1 'pointers null)]) (send ptr encode stream (+VoidPointer uint8 55) ctx) - (check-equal? (ref ctx 'pointerOffset) 2) - (check-equal? (ref ctx 'pointers) (list (mhash 'type uint8 + (check-equal? (· ctx pointerOffset) 2) + (check-equal? (· ctx pointers) (list (mhasheq 'type uint8 'val 55 'parent ctx))) (check-equal? (send stream dump) (+Buffer '(1)))) diff --git a/pitfall/restructure/pointer.rkt b/pitfall/restructure/pointer.rkt index 0a55ee89..2e080b21 100644 --- a/pitfall/restructure/pointer.rkt +++ b/pitfall/restructure/pointer.rkt @@ -6,33 +6,39 @@ approximates https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee |# -(define-subclass object% (Pointer offset-type type [options (mhash)]) - (when (eq? type 'void) (set! type #f)) - (hash-ref! options 'type 'local) - (hash-ref! options 'allowNull #t) - (hash-ref! options 'nullValue 0) - (hash-ref! options 'lazy #f) - (define relative-getter-or-0 (or (ref options 'relativeTo) (λ (ctx) 0))) ; changed this to a simple lambda +(define (resolve-void-pointer type val) + (cond + [type (values type val)] + [(VoidPointer? val) (values (· val type) (· val value))] + [else (raise-argument-error 'Pointer:size "VoidPointer" val)])) + +(define (find-top-ctx ctx) + (cond + [(· ctx parent) => find-top-ctx] + [else ctx])) + +(define-subclass object% (Pointer offset-type type-in [options (mhasheq)]) + (field [type (and (not (eq? type-in 'void)) type-in)]) + (define pointer-style (or (· options type) 'local)) + (define allow-null (or (· options allowNull) #t)) + (define null-value (or (· options nullValue) 0)) + (define lazy (· options lazy)) + (define relative-getter-or-0 (or (· options relativeTo) (λ (ctx) 0))) ; changed this to a simple lambda (define/public (decode stream [ctx #f]) (define offset (send offset-type decode stream ctx)) (cond - ;; handle NULL pointers - [(and (ref options 'allowNull) (= offset (ref options 'nullValue))) #f] + [(and allow-null (= offset null-value)) #f] ; handle null pointers [else - (define relative (+ (caseq (ref options 'type) - [(local) (ref ctx '_startOffset)] + (define relative (+ (caseq pointer-style + [(local) (· ctx _startOffset)] [(immediate) (- (· stream pos) (send offset-type size))] - [(parent) (ref* ctx 'parent '_startOffset)] - [else (let loop ([ctx ctx]) - (cond - [(· ctx parent) => loop] - [(ref ctx '_startOffset)] - [else 0]))]) + [(parent) (· ctx parent _startOffset)] + [(global) (or (· (find-top-ctx ctx) _startOffset) 0)] + [else (error 'unknown-pointer-style)]) (relative-getter-or-0 ctx))) (define ptr (+ offset relative)) - (cond - ;; omitted: lazy pointer implementation + (cond ; omitted: lazy pointer implementation [type (define orig-pos (· stream pos)) (send stream pos ptr) (define val (send type decode stream ctx)) @@ -41,61 +47,42 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee [else ptr])])) - (define/public (size [val #f] [ctx-in #f]) - (define parent ctx-in) - (define ctx (caseq (ref options 'type) - [(local immediate) ctx-in] - [(parent) (· ctx-in parent)] - [(global) (let loop ([ctx ctx-in]) - (cond - [(· ctx parent) => loop] - [else ctx]))] - [else (error 'unknown-pointer-type)])) - (unless type - (unless (VoidPointer? val) - (raise-argument-error 'Pointer:size "VoidPointer" val)) - (set! type (ref val 'type)) - (set! val (ref val 'value))) - (when (and val ctx) - (ref-set! ctx 'pointerSize (and (· ctx pointerSize) - (+ (· ctx pointerSize) (send type size val parent))))) - (send offset-type size)) + (define/public (size [val #f] [ctx #f]) + (let*-values ([(parent) ctx] + [(ctx) (caseq pointer-style + [(local immediate) ctx] + [(parent) (· ctx parent)] + [(global) (find-top-ctx ctx)] + [else (error 'unknown-pointer-style)])] + [(type val) (resolve-void-pointer type val)]) + (when (and val ctx) + (ref-set! ctx 'pointerSize (and (· ctx pointerSize) + (+ (· ctx pointerSize) (send type size val parent))))) + (send offset-type size))) (define/public (encode stream val [ctx #f]) - (define parent ctx) - (define relative #f) - (cond - [(not val) - (send offset-type encode stream (ref options 'nullValue))] - [else - (caseq (ref options 'type) - [(local) (set! relative (ref ctx 'startOffset))] - [(immediate) (set! relative (+ (· stream pos) (send offset-type size val parent)))] - [(parent) (set! ctx (ref ctx 'parent)) - (set! relative (ref ctx 'startOffset))] - [(global) (set! relative 0) - (set! ctx (let loop ([ctx ctx]) - (cond - [(ref ctx 'parent) => loop] - [else ctx])))] - [else (error 'unknown-pointer-type)]) - - (increment! relative (relative-getter-or-0 (ref parent 'val))) - (send offset-type encode stream (- (ref ctx 'pointerOffset) relative)) - - (define type_ type) - (unless type_ - (unless (VoidPointer? val) - (raise-argument-error 'Pointer:encode "VoidPointer" val)) - - (set! type (ref val 'type)) - (set! val (ref val 'value))) - - (ref-set! ctx 'pointers (append (ref ctx 'pointers) (list (mhash 'type type - 'val val - 'parent parent)))) - (ref-set! ctx 'pointerOffset (+ (ref ctx 'pointerOffset) (send type size val parent)))]))) + (if (not val) + (send offset-type encode stream null-value) + (let* ([parent ctx] + [ctx (caseq pointer-style + [(local immediate) ctx] + [(parent) (· ctx parent)] + [(global) (find-top-ctx ctx)] + [else (error 'unknown-pointer-style)])] + [relative (+ (caseq pointer-style + [(local parent) (· ctx startOffset)] + [(immediate) (+ (· stream pos) (send offset-type size val parent))] + [(global) 0]) + (relative-getter-or-0 (· parent val)))]) + + (send offset-type encode stream (- (· ctx pointerOffset) relative)) + + (let-values ([(type val) (resolve-void-pointer type val)]) + (ref-set! ctx 'pointers (append (· ctx pointers) (list (mhasheq 'type type + 'val val + 'parent parent)))) + (ref-set! ctx 'pointerOffset (+ (· ctx pointerOffset) (send type size val parent)))))))) ;; A pointer whose type is determined at decode time