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

refac pointer

Browse Source
main
Matthew Butterick 7 years ago
parent 73ac0bd55b
commit 82e719dc11
2 changed files with 77 additions and 90 deletions
Show Stats Download Patch File Download Diff File

38
pitfall/restructure/pointer-test.rkt
Unescape Escape View File

@ -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))))

129
pitfall/restructure/pointer.rkt
Unescape Escape View File

@ -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

Write Preview
Loading…
Cancel
Save