diff --git a/xenomorph/xenomorph/array.rkt b/xenomorph/xenomorph/array.rkt index 9be5809f..a6ad6d6b 100644 --- a/xenomorph/xenomorph/array.rkt +++ b/xenomorph/xenomorph/array.rkt @@ -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) diff --git a/xenomorph/xenomorph/helper.rkt b/xenomorph/xenomorph/helper.rkt index 076eaeab..256e7a6c 100644 --- a/xenomorph/xenomorph/helper.rkt +++ b/xenomorph/xenomorph/helper.rkt @@ -6,7 +6,6 @@ "generic.rkt") (provide (all-defined-out)) - (define private-keys '(parent _startOffset _currentOffset _length)) (define (dump-mutable x) diff --git a/xenomorph/xenomorph/pointer.rkt b/xenomorph/xenomorph/pointer.rkt index d60093a1..077fc92a 100644 --- a/xenomorph/xenomorph/pointer.rkt +++ b/xenomorph/xenomorph/pointer.rkt @@ -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)) diff --git a/xenomorph/xenomorph/test/number-test.rkt b/xenomorph/xenomorph/test/number-test.rkt index 4ea276c2..728f6d29 100644 --- a/xenomorph/xenomorph/test/number-test.rkt +++ b/xenomorph/xenomorph/test/number-test.rkt @@ -2,7 +2,8 @@ (require rackunit racket/class "../number.rkt" - "../helper.rkt") + "../helper.rkt" + "../generic.rkt") #| approximates