You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/pitfall/restructure/number.rkt

173 lines
7.3 KiB
Racket

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

#lang restructure/racket
(require "stream.rkt" "sizes.rkt" (for-syntax "sizes.rkt" racket/match))
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
|#
(define (ends-with-8? type)
(define str (symbol->string type))
(equal? (substring str (sub1 (string-length str))) "8"))
(define (signed-type? type)
(not (equal? "u" (substring (symbol->string type) 0 1))))
(test-module
(check-false (signed-type? 'uint16))
(check-true (signed-type? 'int16)))
(define-subclass Streamcoder (Number [type 'uint16] [endian (if (system-big-endian?) 'be 'le)])
(getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))])
(define _signed? (signed-type? type))
;; `get-type-size` will raise error if number-type is invalid: use this as check of input
;; size of a number doesn't change, so we can stash it as `_size`
(define _size (with-handlers ([exn:fail:contract?
(λ (exn)
(raise-argument-error 'Number "valid type and endian" (format "~v ~v" type endian)))])
(get-type-size number-type)))
(define bits (* _size 8))
(define/override (size . args) _size)
(define-values (bound-min bound-max)
;; 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)))]
[signed-min (sub1 (- signed-max))])
(if _signed?
(values signed-min signed-max)
(values (- signed-min signed-min) (- signed-max signed-min)))))
(define (unsigned->signed uint)
(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)
(bitwise-and sint (arithmetic-shift 1 bits)))
(define/augride (decode stream . args)
(define bstr (send stream read _size))
(define system-endian (if (system-big-endian?) 'be 'le))
(define bs ((if (eq? endian system-endian) identity reverse) (bytes->list bstr)))
(define unsigned-int (for/sum ([(b i) (in-indexed bs)])
(arithmetic-shift b (* 8 i))))
((if _signed? unsigned->signed identity) unsigned-int))
(define/augride (encode stream val-in)
(define val ((if (integer? val-in) inexact->exact identity) val-in))
;; todo: better bounds checking
(unless (<= bound-min val bound-max)
(raise-argument-error 'Number:encode (format "value within range of ~a ~a-byte int (~a to ~a)" (if _signed? "signed" "unsigned") _size bound-min bound-max) val))
(define-values (bs _) (for/fold ([bs empty] [n val])
([i (in-range _size)])
(values (cons (bitwise-and n #xff) bs) (arithmetic-shift n -8))))
(send stream write (apply bytes ((if (eq? endian 'be) identity reverse) bs)))))
(define-subclass* Number (Fixed size [fixed-endian (if (system-big-endian?) 'be 'le)] [fracBits (floor (/ size 2))])
(super-make-object (string->symbol (format "int~a" size)) fixed-endian)
(field [_point (expt 2 fracBits)])
(define/override (decode stream . args)
(define result (/ (super decode stream args) _point 1.0))
(if (integer? result) (inexact->exact result) result))
(define/override (encode stream val)
(super encode stream (floor (* val _point)))))
(define-macro (define-subclass+provide ID (BASE-CLASS . ARGS))
(with-pattern ([ID-CLASS (prefix-id #'BASE-CLASS ":" #'ID)])
#'(define+provide ID (let ([ID-CLASS (class BASE-CLASS (super-new))])
(make-object ID-CLASS . ARGS)))))
(define-subclass+provide fixed16 (Fixed 16))
(define-subclass+provide fixed16be (Fixed 16 'be))
(define-subclass+provide fixed16le (Fixed 16 'le))
(define-subclass+provide fixed32 (Fixed 32))
(define-subclass+provide fixed32be (Fixed 32 'be))
(define-subclass+provide fixed32le (Fixed 32 'le))
(test-module
(check-exn exn:fail:contract? (λ () (+Number 'not-a-valid-type)))
(check-exn exn:fail:contract? (λ () (send uint8 encode (+EncodeStream) 256)))
(check-not-exn (λ () (send uint8 encode (+EncodeStream) 255)))
(check-exn exn:fail:contract? (λ () (send int8 encode (+EncodeStream) 256)))
(check-exn exn:fail:contract? (λ () (send int8 encode (+EncodeStream) 255)))
(check-not-exn (λ () (send int8 encode (+EncodeStream) 127)))
(check-not-exn (λ () (send int8 encode (+EncodeStream) -128)))
(check-exn exn:fail:contract? (λ () (send int8 encode (+EncodeStream) -129)))
(check-exn exn:fail:contract? (λ () (send uint16 encode (+EncodeStream) (add1 #xffff))))
(check-not-exn (λ () (send uint16 encode (+EncodeStream) #xffff)))
(let ([o (+Number 'uint16 'le)]
[ip (+DecodeStream (bytes 1 2 3 4))]
[op (open-output-bytes)])
(check-equal? (send o decode ip) 513) ;; 1000 0000 0100 0000
(check-equal? (send o decode ip) 1027) ;; 1100 0000 0010 0000
(send o encode op 513)
(check-equal? (get-output-bytes op) (bytes 1 2))
(send o encode op 1027)
(check-equal? (get-output-bytes op) (bytes 1 2 3 4)))
(let ([o (+Number 'uint16 'be)]
[ip (+DecodeStream (bytes 1 2 3 4))]
[op (open-output-bytes)])
(check-equal? (send o decode ip) 258) ;; 0100 0000 1000 0000
(check-equal? (send o decode ip) 772) ;; 0010 0000 1100 0000
(send o encode op 258)
(check-equal? (get-output-bytes op) (bytes 1 2))
(send o encode op 772)
(check-equal? (get-output-bytes op) (bytes 1 2 3 4))))
(test-module
(check-equal? (send (+Number 'uint8) size) 1)
(check-equal? (send (+Number) size) 2)
(check-equal? (send (+Number 'uint32) size) 4)
(check-equal? (send (+Number 'double) size) 8))
;; use keys of type-sizes hash to generate corresponding number definitions
(define-macro (make-int-types)
(with-pattern ([((ID BASE ENDIAN) ...) (for/list ([k (in-hash-keys type-sizes)])
(define kstr (format "~a" k))
(match-define (list* prefix suffix _)
(regexp-split #rx"(?=[bl]e|$)" kstr))
(map string->symbol
(list (string-downcase kstr)
prefix
(if (positive? (string-length suffix))
suffix
(if (system-big-endian?) "be" "le")))))]
[(ID ...) (suffix-id #'(ID ...) #:context caller-stx)])
#'(begin (define-subclass+provide ID (Number 'BASE 'ENDIAN)) ...)))
(make-int-types)
(test-module
(check-equal? (send uint8 size) 1)
(check-equal? (send uint16 size) 2)
(check-equal? (send uint32 size) 4)
(check-equal? (send double size) 8)
(define es (+EncodeStream))
(send fixed16be encode es 123.45)
(check-equal? (send es dump) #"{s")
(define ds (+DecodeStream (send es dump)))
#;(check-equal? (ceiling (* (send fixed16be decode ds) 100)) 12345.0)
(check-equal? (send int8 decode (bytes 127)) 127)
(check-equal? (send int8 decode (bytes 255)) -1)
(check-equal? (send int8 encode #f -1) (bytes 255))
(check-equal? (send int8 encode #f 127) (bytes 127))
)