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

pointer

Browse Source
main
Matthew Butterick 6 years ago
parent b1a5fd3a23
commit 52fa63e160
4 changed files with 72 additions and 87 deletions
Show Stats Download Patch File Download Diff File

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

@ -17,7 +17,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(class xenobase%
(super-new)
(init-field type len)
(unless (is-a? type xenobase%)
(unless (xenomorphic-type? type)
(raise-argument-error '+xarray "xenomorphic type" type))
(unless (length-resolvable? len)
(raise-argument-error '+xarray "length-resolvable?" len))))
@ -31,7 +31,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(inherit-field type len)
(define/augment (xxdecode port parent . _)
(define/augment (xxdecode port parent)
(define new-parent (if (xint? len)
(mhasheq 'parent parent
'_startOffset (pos port)

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

@ -6,7 +6,6 @@
"generic.rkt")
(provide (all-defined-out))
(define private-keys '(parent _startOffset _currentOffset _length))
(define (dump-mutable x)

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

@ -17,99 +17,78 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
[(dict-ref parent 'parent #f) => find-top-parent]
[else parent]))
#;(define/post-decode (xpointer-decode xp [port-arg (current-input-port)] #:parent [parent #f])
(define port (->input-port port-arg))
(parameterize ([current-input-port port])
(define offset (xdecode (xpointer-offset-type xp) #:parent parent))
(cond
[(and allow-null (= offset (null-value xp))) #f] ; handle null pointers
[else
(define relative (+ (case (pointer-relative-to xp)
[(local) (dict-ref parent '_startOffset)]
[(immediate) (- (pos port) (size (xpointer-offset-type xp)))]
[(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)]
[(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)]
[else (error 'unknown-pointer-style)])))
(define ptr (+ offset relative))
(cond
[(xpointer-type xp)
(define val (void))
(define (decode-value)
(cond
[(not (void? val)) val]
[else
(define orig-pos (pos port))
(pos port ptr)
(set! val (xdecode (xpointer-type xp) #:parent parent))
(pos port orig-pos)
val]))
(if (pointer-lazy? xp)
(delay (decode-value))
(decode-value))]
[else ptr])])))
(define (resolve-void-pointer type val)
(cond
[type (values type val)]
[(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))]
[else (raise-argument-error 'Pointer:size "VoidPointer" val)]))
#;(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)))
(unless parent ; todo: furnish default pointer context? adapt from Struct?
(raise-argument-error 'xpointer-encode "valid pointer context" parent))
(parameterize ([current-output-port port])
(if (not val)
(encode (xpointer-offset-type xp) (null-value xp) port)
(let* ([new-parent (case (pointer-relative-to xp)
[(local immediate) parent]
[(parent) (dict-ref parent 'parent)]
[(global) (find-top-parent parent)]
[else (error 'unknown-pointer-style)])]
[relative (+ (case (pointer-relative-to xp)
[(local parent) (dict-ref new-parent 'startOffset)]
[(immediate) (+ (pos port) (size (xpointer-offset-type xp) val #:parent parent))]
[(global) 0]))])
(encode (xpointer-offset-type xp) (- (dict-ref new-parent 'pointerOffset) relative))
(let-values ([(type val) (resolve-void-pointer (xpointer-type xp) val)])
(dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers)
(list (mhasheq 'type type
'val val
'parent parent))))
(dict-set! new-parent 'pointerOffset (+ (dict-ref new-parent 'pointerOffset) (size type val #:parent parent)))))))
(unless port-arg (get-output-bytes port)))
#;(define (xpointer-size xp [val #f] #:parent [parent #f])
(let*-values ([(parent) (case (pointer-relative-to xp)
[(local immediate) parent]
[(parent) (dict-ref parent 'parent)]
[(global) (find-top-parent parent)]
[else (error 'unknown-pointer-style)])]
[(type val) (resolve-void-pointer (xpointer-type xp) val)])
(when (and val parent)
(dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f)
(+ (dict-ref parent 'pointerSize) (size type val #:parent parent)))))
(size (xpointer-offset-type xp))))
(define xpointer%
(class* xenobase% ()
(class xenobase%
(super-new)
(init-field offset-type type options)
(define pointer-relative-to (dict-ref options 'relative-to))
(define allow-null (dict-ref options 'allowNull))
(define null-value (dict-ref options 'nullValue))
(define pointer-lazy? (dict-ref options 'lazy))
(define allow-null (dict-ref options 'allowNull))
(define null-value (dict-ref options 'nullValue))
(define pointer-lazy? (dict-ref options 'lazy))
(define/augment (xxdecode port parent)
(define offset (send offset-type xxdecode port parent))
(cond
[(and allow-null (= offset null-value)) #f] ; handle null pointers
[else
(define relative (+ (case pointer-relative-to
[(local) (dict-ref parent '_startOffset)]
[(immediate) (- (pos port) (send offset-type xxsize))]
[(parent) (dict-ref (dict-ref parent 'parent) '_startOffset)]
[(global) (or (dict-ref (find-top-parent parent) '_startOffset) 0)]
[else (error 'unknown-pointer-style)])))
(define ptr (+ offset relative))
(cond
[type (define (decode-value)
(define orig-pos (pos port))
(pos port ptr)
(begin0
(send type xxdecode port parent)
(pos port orig-pos)))
(if pointer-lazy? (delay (decode-value)) (decode-value))]
[else ptr])]))
))
(define/augment (xxencode val port [parent #f])
(unless parent ; todo: furnish default pointer context? adapt from Struct?
(raise-argument-error 'xpointer-encode "valid pointer context" parent))
(if (not val)
(send offset-type xxencode null-value port)
(let* ([new-parent (case pointer-relative-to
[(local immediate) parent]
[(parent) (dict-ref parent 'parent)]
[(global) (find-top-parent parent)]
[else (error 'unknown-pointer-style)])]
[relative (+ (case pointer-relative-to
[(local parent) (dict-ref new-parent 'startOffset)]
[(immediate) (+ (pos port) (send offset-type xxsize val parent))]
[(global) 0]))])
(send offset-type xxencode (- (dict-ref new-parent 'pointerOffset) relative) port)
(let-values ([(type val) (resolve-void-pointer type val)])
(dict-set! new-parent 'pointers (append (dict-ref new-parent 'pointers)
(list (mhasheq 'type type
'val val
'parent parent))))
(dict-set! new-parent 'pointerOffset
(+ (dict-ref new-parent 'pointerOffset) (send type xxsize val parent)))))))
#;(struct xpointer xbase (offset-type type options) #:transparent
#:methods gen:xenomorphic
[(define decode xpointer-decode)
(define xdecode xpointer-decode)
(define encode xpointer-encode)
(define size xpointer-size)])
(define/augment (xxsize [val #f] [parent #f])
(let*-values ([(parent) (case pointer-relative-to
[(local immediate) parent]
[(parent) (dict-ref parent 'parent)]
[(global) (find-top-parent parent)]
[else (error 'unknown-pointer-style)])]
[(type val) (resolve-void-pointer type val)])
(when (and val parent)
(dict-set! parent 'pointerSize (and (dict-ref parent 'pointerSize #f)
(+ (dict-ref parent 'pointerSize) (send type xxsize val parent)))))
(send offset-type xxsize)))))
(define (+xpointer [offset-arg #f] [type-arg #f]
#:offset-type [offset-kwarg #f]
@ -117,7 +96,8 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
#:relative-to [relative-to 'local]
#:lazy [lazy? #f]
#:allow-null [allow-null? #t]
#:null [null-value 0])
#:null [null-value 0]
#:subclass [class xpointer%])
(define valid-pointer-relatives '(local immediate parent global))
(unless (memq relative-to valid-pointer-relatives)
(raise-argument-error '+xpointer (format "~v" valid-pointer-relatives) relative-to))
@ -126,12 +106,17 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
'allowNull allow-null?
'nullValue null-value))
(define type-in (or type-arg type-kwarg uint8))
(new xpointer%
(new class
[offset-type (or offset-arg offset-kwarg uint8)]
[type (case type-in [(void) #f][else type-in])]
[options options]))
;; A pointer whose type is determined at decode time
(struct xvoid-pointer (type value) #:transparent)
(define +xvoid-pointer xvoid-pointer)
(define xvoid-pointer% (class xenobase%
(super-new)
(init-field type value)))
(define (+xvoid-pointer . args) (apply make-object xvoid-pointer% args))
(define (xvoid-pointer? x) (is-a? x xvoid-pointer%))
(define (xvoid-pointer-type x) (get-field type x))
(define (xvoid-pointer-value x) (get-field value x))

3
xenomorph/xenomorph/test/number-test.rkt
Unescape Escape View File

@ -2,7 +2,8 @@
(require rackunit
racket/class
"../number.rkt"
"../helper.rkt")
"../helper.rkt"
"../generic.rkt")
#|
approximates

Write Preview
Loading…
Cancel
Save