diff --git a/xenomorph/xenomorph/helper.rkt b/xenomorph/xenomorph/helper.rkt index bf73bf05..4ac901ba 100644 --- a/xenomorph/xenomorph/helper.rkt +++ b/xenomorph/xenomorph/helper.rkt @@ -1,10 +1,13 @@ -#lang racket/base +#lang debug racket/base (require racket/generic + racket/private/generic-methods racket/dict - racket/port) + racket/port + racket/class) (provide (all-defined-out)) -(define current-parent (make-parameter #f)) +(define (->output-port arg) + (if (output-port? arg) arg (open-output-bytes))) (define (->input-port arg) (cond @@ -12,19 +15,23 @@ [(input-port? arg) arg] [else (raise-argument-error '->input-port "byte string or input port" arg)])) -(define (dict-ref* d . keys) - (for/fold ([d d]) - ([k (in-list keys)]) - (dict-ref d k))) - (define private-keys '(parent _startOffset _currentOffset _length)) -(define (dict->mutable-hash x) +(define (dump-mutable x) (define h (make-hasheq)) - (for ([(k v) (in-dict x)] - #:unless (memq k private-keys)) + (for ([(k v) (in-dict (dump x))]) (hash-set! h k v)) h) +(define (dump x) + (cond + [(input-port? x) (port->bytes x)] + [(output-port? x) (get-output-bytes x)] + [(dict? x) (for/hasheq ([(k v) (in-dict x)] + #:unless (memq k private-keys)) + (values k v))] + [(list? x) (map dump x)] + [else x])) + (define (pos p [new-pos #f]) (when new-pos (file-position p new-pos)) @@ -55,12 +62,44 @@ (define-generics xenomorphic (encode xenomorphic val [port] #:parent [parent]) - (xdecode xenomorphic [port] #:parent [parent]) - (decode xenomorphic [port]) + (decode xenomorphic [port] #:parent [parent]) (size xenomorphic [item] #:parent [parent])) (define (finalize-size size) (cond [(void? size) 0] [(and (integer? size) (not (negative? size))) size] - [else (raise-argument-error 'size "nonnegative integer" size)])) \ No newline at end of file + [else (raise-argument-error 'size "nonnegative integer" size)])) + + +(define codec<%> + (interface* () + ([(generic-property gen:xenomorphic) + (generic-method-table gen:xenomorphic + (define (decode o [port-arg (current-input-port)] #:parent [parent #f]) + (send o xxdecode (->input-port port-arg) parent)) + + (define (encode o val [port-arg (current-output-port)] #:parent [parent #f]) + (define port (->output-port port-arg)) + (send o xxencode val port parent) + (unless port-arg (get-output-bytes port))) + + (define (size o [val #f] #:parent [parent #f]) + (send o xxsize val parent)))]))) + +(define xenobase% + (class* object% (codec<%>) + (super-new) + + (define/pubment (xxdecode input-port [parent #f]) + (post-decode (inner (void) xxdecode input-port parent))) + + (define/pubment (xxencode val output-port [parent #f]) + (define encode-result (inner (void) xxencode (pre-encode val) output-port parent)) + (when (bytes? encode-result) (write-bytes encode-result output-port))) + + (define/pubment (xxsize [val #f] [parent #f]) + (finalize-size (inner (void) xxsize val parent))) + + (define/public (post-decode val) val) + (define/public (pre-encode val) val))) \ No newline at end of file diff --git a/xenomorph/xenomorph/number.rkt b/xenomorph/xenomorph/number.rkt index b8361111..dde6cdc7 100644 --- a/xenomorph/xenomorph/number.rkt +++ b/xenomorph/xenomorph/number.rkt @@ -1,5 +1,5 @@ #lang debug racket/base -(require "helper.rkt") +(require "helper.rkt" racket/class) (provide (all-defined-out)) #| @@ -23,71 +23,71 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define system-endian (if (system-big-endian?) 'be 'le)) -(define/pre-encode (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f]) - (unless (xint? i) - (raise-argument-error 'encode "xint instance" i)) - (define-values (bound-min bound-max) (bounds i)) - (unless (<= bound-min val bound-max) - (raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (xint-signed i) "signed" "unsigned") (xint-size i) bound-min bound-max) val)) - (unless (or (not port-arg) (output-port? port-arg)) - (raise-argument-error 'encode "output port or #f" port-arg)) - (define port (if (output-port? port-arg) port-arg (open-output-bytes))) - (parameterize ([current-output-port port]) - (define bs (for/fold ([bs null] - [val (exact-if-possible val)] - #:result bs) - ([i (in-range (xint-size i))]) - (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8)))) - (define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs))) - (if port-arg (write-bytes res) res))) - -(define/post-decode (xint-decode i [port-arg (current-input-port)] #:parent [parent #f]) - (unless (xint? i) - (raise-argument-error 'decode "xint instance" i)) - (define port (->input-port port-arg)) - (parameterize ([current-input-port port]) - (define bstr (read-bytes (xint-size i))) - (define bs ((if (eq? (xint-endian i) system-endian) - values - reverse-bytes) bstr)) - (define uint (for/sum ([b (in-bytes bs)] - [i (in-naturals)]) - (arithmetic-shift b (* 8 i)))) - (if (xint-signed i) (unsigned->signed uint (bits i)) uint))) +#;(define/pre-encode (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f]) + ) + +#;(define/post-decode (xint-decode i [port-arg (current-input-port)] #:parent [parent #f]) + (unless (xint? i) + (raise-argument-error 'decode "xint instance" i)) + ) (struct xnumber xbase () #:transparent) +(define xnumber% (class* xenobase% () (super-new))) + +(define xint% (class* xnumber% () + (super-new) + (init-field size + signed + endian) + + (define/augment (xxdecode port [parent #f]) + (define bstr (read-bytes size port)) + (define bs ((if (eq? endian system-endian) + values + reverse-bytes) bstr)) + (define uint (for/sum ([b (in-bytes bs)] + [i (in-naturals)]) + (arithmetic-shift b (* 8 i)))) + (if signed (unsigned->signed uint (bits this)) uint)) + + (define/augment (xxencode val port [parent #f]) + (define-values (bound-min bound-max) (bounds this)) + (unless (<= bound-min val bound-max) + (raise-argument-error 'encode + (format "value that fits within ~a ~a-byte int (~a to ~a)" (if signed "signed" "unsigned") size bound-min bound-max) val)) + (for/fold ([bs null] + [val (exact-if-possible val)] + #:result (apply bytes ((if (eq? endian 'be) values reverse) bs))) + ([i (in-range size)]) + (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8)))) + + (define/augment (xxsize [val #f] [parent #f]) size))) -(struct xint xnumber (size signed endian) #:transparent - #:methods gen:xenomorphic - [(define decode xint-decode) - (define xdecode xint-decode) - (define encode xint-encode) - (define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))]) (define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian]) (unless (exact-positive-integer? size) (raise-argument-error '+xint "exact positive integer" size)) (unless (memq endian '(le be)) (raise-argument-error '+xint "'le or 'be" endian)) - (xint size signed endian)) + (make-object xint% size signed endian)) -(define (type-tag i) - (string->symbol - (string-append (if (xint-signed i) "" "u") - "int" - (number->string (bits i)) - (if (> (xint-size i) 1) (symbol->string (xint-endian i)) "")))) +#;(define (type-tag i) + (string->symbol + (string-append (if signed "" "u") + "int" + (number->string (bits i)) + (if (> (xint-size i) 1) (symbol->string (xint-endian i)) "")))) -(define (bits i) (* (xint-size i) 8)) +(define (bits i) (* (get-field size i) 8)) (define (bounds i) - (unless (xint? i) - (raise-argument-error 'bounds "integer instance" i)) + #;(unless (xint? i) + (raise-argument-error 'bounds "integer instance" i)) ;; if a signed integer has n bits, it can contain a number ;; between - (expt 2 (sub1 n)) and (sub1 (expt 2 (sub1 n)). (let* ([signed-max (sub1 (arithmetic-shift 1 (sub1 (bits i))))] [signed-min (sub1 (- signed-max))] - [delta (if (xint-signed i) 0 signed-min)]) + [delta (if (get-field signed i) 0 signed-min)]) (values (- signed-min delta) (- signed-max delta)))) (define int8 (+xint 1)) @@ -157,82 +157,3 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (check-equal? (decode int8 (bytes 255)) -1) (check-equal? (encode int8 -1 #f) (bytes 255)) (check-equal? (encode int8 127 #f) (bytes 127))) - -(define/post-decode (xfloat-decode xf [port-arg (current-input-port)] #:parent [parent #f]) - (unless (xfloat? xf) - (raise-argument-error 'decode "xfloat instance" xf)) - (define bs (read-bytes (xfloat-size xf) (->input-port port-arg))) - (floating-point-bytes->real bs (eq? (xfloat-endian xf) 'be))) - -(define/pre-encode (xfloat-encode xf val [port (current-output-port)] #:parent [parent #f]) - (unless (xfloat? xf) - (raise-argument-error 'encode "xfloat instance" xf)) - (unless (or (not port) (output-port? port)) - (raise-argument-error 'encode "output port or #f" port)) - (define res (real->floating-point-bytes val (xfloat-size xf) (eq? (xfloat-endian xf) 'be))) - (if port (write-bytes res port) res)) - -(struct xfloat xnumber (size endian) #:transparent - #:methods gen:xenomorphic - [(define decode xfloat-decode) - (define xdecode xfloat-decode) - (define encode xfloat-encode) - (define size (λ (i [item #f] #:parent [parent #f]) (xfloat-size i)))]) - -(define (+xfloat [size 4] #:endian [endian system-endian]) - (unless (exact-positive-integer? size) - (raise-argument-error '+xfloat "exact positive integer" size)) - (unless (memq endian '(le be)) - (raise-argument-error '+xfloat "'le or 'be" endian)) - (xfloat size endian)) - -(define float (+xfloat 4)) -(define floatbe (+xfloat 4 #:endian 'be)) -(define floatle (+xfloat 4 #:endian 'le)) - -(define double (+xfloat 8)) -(define doublebe (+xfloat 8 #:endian 'be)) -(define doublele (+xfloat 8 #:endian 'le)) - -(define/post-decode (xfixed-decode xf [port-arg (current-input-port)] #:parent [parent #f]) - (unless (xfixed? xf) - (raise-argument-error 'decode "xfixed instance" xf)) - (define int (xint-decode xf port-arg)) - (exact-if-possible (/ int (fixed-shift xf) 1.0))) - -(define/pre-encode (xfixed-encode xf val [port (current-output-port)] #:parent [parent #f]) - (unless (xfixed? xf) - (raise-argument-error 'encode "xfixed instance" xf)) - (define int (exact-if-possible (floor (* val (fixed-shift xf))))) - (xint-encode xf int port)) - -(struct xfixed xint (fracbits) #:transparent - #:methods gen:xenomorphic - [(define decode xfixed-decode) - (define xdecode xfixed-decode) - (define encode xfixed-encode) - (define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))]) - -(define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] [fracbits (/ (* size 8) 2)]) - (unless (exact-positive-integer? size) - (raise-argument-error '+xfixed "exact positive integer" size)) - (unless (exact-positive-integer? fracbits) - (raise-argument-error '+xfixed "exact positive integer" fracbits)) - (unless (memq endian '(le be)) - (raise-argument-error '+xfixed "'le or 'be" endian)) - (xfixed size signed endian fracbits)) - -(define (fixed-shift xf) - (arithmetic-shift 1 (xfixed-fracbits xf))) - -(define fixed16 (+xfixed 2)) -(define fixed16be (+xfixed 2 #:endian 'be)) -(define fixed16le (+xfixed 2 #:endian 'le)) -(define fixed32 (+xfixed 4)) -(define fixed32be (+xfixed 4 #:endian 'be)) -(define fixed32le (+xfixed 4 #:endian 'le)) - -(module+ test - (define bs (encode fixed16be 123.45 #f)) - (check-equal? bs #"{s") - (check-equal? (ceiling (* (decode fixed16be bs) 100)) 12345.0))