diff --git a/xenomorph/xenomorph/base.rkt b/xenomorph/xenomorph/base.rkt index cbb1a9cf..75156cb0 100644 --- a/xenomorph/xenomorph/base.rkt +++ b/xenomorph/xenomorph/base.rkt @@ -70,6 +70,19 @@ (define (symbol-append . syms) (string->symbol (apply string-append (map symbol->string syms)))) +;;;;;;;;;;;;;;;;;;;;;;;;; structing + +(define (->input-port arg) + (cond + [(bytes? arg) (open-input-bytes arg)] + [(input-port? arg) arg] + [else (raise-argument-error '->port "byte string or input port" arg)])) + +(define (reverse-bytes bstr) (apply bytes (reverse (bytes->list bstr)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define xenomorph-base% (class* object% (codable<%> sizable<%>) (super-new) @@ -79,7 +92,7 @@ (define/pubment (decode port [parent #f] . args) ;; todo: is `indexable?` really a necessary condition? doesn't seem to break anything withou it #;(when parent (unless (indexable? parent) - #;(raise-argument-error (symbol-append (get-class-name) ':decode) "indexable" parent))) + #;(raise-argument-error (symbol-append (get-class-name) ':decode) "indexable" parent))) (define ip (cond [(bytes? port) (open-input-bytes port)] [(input-port? port) port] @@ -90,7 +103,7 @@ #;(report* port val-in parent) (define val (pre-encode val-in port)) #;(when parent (unless (indexable? parent) - (raise-argument-error (symbol-append (get-class-name) ':encode) "indexable" parent))) + (raise-argument-error (symbol-append (get-class-name) ':encode) "indexable" parent))) (define op (cond [(output-port? port) port] [(not port) (open-output-bytes)] diff --git a/xenomorph/xenomorph/number.rkt b/xenomorph/xenomorph/number.rkt index b555c926..4a124c45 100644 --- a/xenomorph/xenomorph/number.rkt +++ b/xenomorph/xenomorph/number.rkt @@ -28,6 +28,53 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define (exact-if-possible x) (if (integer? x) (inexact->exact x) x)) (define system-endian (if (system-big-endian?) 'be 'le)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; structing + +(struct $integer (bytes signed endian) #:transparent) + +(define (+$integer [bytes 2] [signed #false] [endian system-endian]) + ($integer bytes signed endian)) + +(define $int16 (+$integer)) + +(define ($bits int) (* ($integer-bytes int) 8)) + +(define ($bounds int) + ;; 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 int))))] + [signed-min (sub1 (- signed-max))] + [delta (if ($integer-signed int) 0 signed-min)]) + (values (- signed-min delta) (- signed-max delta)))) + +(define ($decode int [port-arg (current-input-port)]) + (define bstr (read-bytes ($integer-bytes int) (->input-port port-arg))) + (define bs ((if (eq? ($integer-endian int) system-endian) + values + reverse-bytes) bstr)) + (define uint (for/sum ([b (in-bytes bs)] + [i (in-naturals)]) + (arithmetic-shift b (* 8 i)))) + (if ($integer-signed int) (unsigned->signed uint ($bits int)) uint)) + +(define ($encode int val [port-arg #f]) + (define-values (bound-min bound-max) ($bounds int)) + (unless (<= bound-min val bound-max) + (raise-argument-error '$encode (format "value within range of ~a ~a-byte int (~a to ~a)" (if ($integer-signed int) "signed" "unsigned") ($integer-bytes int) bound-min bound-max) val)) + (define-values (bs _) + (for/fold ([bs null] + [n (exact-if-possible val)]) + ([i (in-range ($integer-bytes int))]) + (values (cons (bitwise-and n #xff) bs) (arithmetic-shift n -8)))) + (define res (apply bytes ((if (eq? ($integer-endian int) 'be) values reverse) bs))) + (if (and port-arg (output-port? port-arg)) + (write-bytes res port-arg) + res)) + +($decode $int16 ($encode $int16 123)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define-subclass xenomorph-base% (Integer [type 'uint16] [endian system-endian]) (getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))]) (define _signed? (signed-type? type)) diff --git a/xenomorph/xenomorph/redo/base.rkt b/xenomorph/xenomorph/redo/base.rkt new file mode 100644 index 00000000..cf13ad87 --- /dev/null +++ b/xenomorph/xenomorph/redo/base.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(provide (all-defined-out)) + +(define (->input-port arg) + (cond + [(bytes? arg) (open-input-bytes arg)] + [(input-port? arg) arg] + [else (raise-argument-error '->port "byte string or input port" arg)])) + +(define (reverse-bytes bstr) (apply bytes (reverse (bytes->list bstr)))) + +(define (unsigned->signed uint bits) + (define most-significant-bit-mask (arithmetic-shift 1 (sub1 bits))) + (- (bitwise-xor uint most-significant-bit-mask) most-significant-bit-mask)) + +(define (signed->unsigned sint bits) + (bitwise-and sint (arithmetic-shift 1 bits))) \ No newline at end of file diff --git a/xenomorph/xenomorph/redo/number.rkt b/xenomorph/xenomorph/redo/number.rkt new file mode 100644 index 00000000..8103a261 --- /dev/null +++ b/xenomorph/xenomorph/redo/number.rkt @@ -0,0 +1,109 @@ +#lang racket/base +(require "base.rkt") +(provide (all-defined-out)) + +(define (exact-if-possible x) (if (integer? x) (inexact->exact x) x)) + +(define system-endian (if (system-big-endian?) 'be 'le)) + +(struct int (bytes signed endian) #:transparent) + +(define (+integer [bytes 2] [signed #false] [endian system-endian]) + (unless (exact-positive-integer? bytes) + (raise-argument-error '+integer "exact positive integer" bytes)) + (unless (boolean? signed) + (raise-argument-error '+integer "boolean" signed)) + (unless (memq endian '(le be)) + (raise-argument-error '+integer "'le or 'be" endian)) + (int bytes signed endian)) + +(define (type-tag i) + (string->symbol + (string-append (if (int-signed i) "" "u") + "int" + (number->string (bits i)) + (if (> (int-bytes i) 1) (symbol->string (int-endian i)) "")))) + +(define (bits i) (* (int-bytes i) 8)) + +(define (bounds 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 (int-signed i) 0 signed-min)]) + (values (- signed-min delta) (- signed-max delta)))) + +(define (decode i [port-arg (current-input-port)]) + (define bstr (read-bytes (int-bytes i) (->input-port port-arg))) + (define bs ((if (eq? (int-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 (int-signed i) (unsigned->signed uint (bits i)) uint)) + +(define (encode int val [port #f]) + (define-values (bound-min bound-max) (bounds int)) + (unless (<= bound-min val bound-max) + (raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (int-signed int) "signed" "unsigned") (int-bytes int) bound-min bound-max) val)) + (unless (or (not port) (output-port? port)) + (raise-argument-error 'encode "output port or #f" port)) + (define bs (for/fold ([bs null] + [val (exact-if-possible val)] + #:result bs) + ([i (in-range (int-bytes int))]) + (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8)))) + (define res (apply bytes ((if (eq? (int-endian int) 'be) values reverse) bs))) + (if port (write-bytes res port) res)) + + +(define uint8 (+integer 1)) +(define int8 (+integer 1 #t)) +(define uint16 (+integer 2)) + +(module+ test + (require rackunit) + (check-exn exn:fail:contract? (λ () (+integer 'not-a-valid-type))) + (check-exn exn:fail:contract? (λ () (encode uint8 256))) + (check-not-exn (λ () (encode uint8 255))) + (check-exn exn:fail:contract? (λ () (encode int8 256))) + (check-exn exn:fail:contract? (λ () (encode int8 255))) + (check-not-exn (λ () (encode int8 127))) + (check-not-exn (λ () (encode int8 -128))) + (check-exn exn:fail:contract? (λ () (encode int8 -129))) + (check-exn exn:fail:contract? (λ () (encode uint16 (add1 #xffff)))) + (check-not-exn (λ () (encode uint16 #xffff))) + + (let ([i (+integer 2 #false 'le)] + [ip (open-input-bytes (bytes 1 2 3 4))] + [op (open-output-bytes)]) + (check-equal? (decode i ip) 513) ;; 1000 0000 0100 0000 + (check-equal? (decode i ip) 1027) ;; 1100 0000 0010 0000 + (encode i 513 op) + (check-equal? (get-output-bytes op) (bytes 1 2)) + (encode i 1027 op) + (check-equal? (get-output-bytes op) (bytes 1 2 3 4))) + + (let ([i (+integer 2 #false 'be)] + [ip (open-input-bytes (bytes 1 2 3 4))] + [op (open-output-bytes)]) + (check-equal? (decode i ip) 258) ;; 0100 0000 1000 0000 + (check-equal? (decode i ip) 772) ;; 0010 0000 1100 0000 + (encode i 258 op) + (check-equal? (get-output-bytes op) (bytes 1 2)) + (encode i 772 op) + (check-equal? (get-output-bytes op) (bytes 1 2 3 4))) +#| + (check-equal? (size (+integer 1) ) 1) + (check-equal? (size (+integer)) 2) + (check-equal? (size (+integer 4)) 4) + (check-equal? (size (+integer 8)) 8) + + (check-equal? (size (+number 1)) 1) + (check-equal? (size (+number)) 2) + (check-equal? (size (+number 4)) 4) + (check-equal? (size (+number 8)) 8) +|# + ) \ No newline at end of file