From ee21fdd131b73b227dfa569fd35f9c635271d986 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 30 Apr 2019 13:05:33 -0700 Subject: [PATCH] leniency --- xenomorph/xenomorph/bitfield.rkt | 8 ++--- .../xenomorph/scribblings/xenomorph.scrbl | 8 ++--- xenomorph/xenomorph/test/bitfield-test.rkt | 30 ++++++++++++------- 3 files changed, 26 insertions(+), 20 deletions(-) diff --git a/xenomorph/xenomorph/bitfield.rkt b/xenomorph/xenomorph/bitfield.rkt index 4427c86c..bb54f809 100644 --- a/xenomorph/xenomorph/bitfield.rkt +++ b/xenomorph/xenomorph/bitfield.rkt @@ -28,7 +28,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee (define/augment (x:decode port parent) (define val (send @type x:decode port)) - (define flag-hash (mhasheq)) + (define flag-hash (mhash)) (for ([(flag idx) (in-indexed @flags)] #:when flag) (hash-set! flag-hash flag (bitwise-bit-set? val idx))) @@ -55,9 +55,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee #:base-class [base-class x:bitfield%]) (() ((or/c x:int? #false) - (listof (or/c symbol? #false)) + (listof any/c) #:type (or/c x:int? #false) - #:flags (listof (or/c symbol? #false)) + #:flags (listof any/c) #:pre-encode (or/c (any/c . -> . any/c) #false) #:post-decode (or/c (any/c . -> . any/c) #false) #:base-class (λ (c) (subclass? c x:bitfield%))) @@ -65,8 +65,6 @@ https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee x:bitfield?) (define type (or type-arg type-kwarg)) (define flags (or flag-arg flag-kwarg)) - (unless (andmap (λ (f) (or (symbol? f) (not f))) flags) - (raise-argument-error 'x:bitfield "list containing symbols or #false values" flags)) (new (generate-subclass base-class pre-proc post-proc) [type type] [flags flags])) diff --git a/xenomorph/xenomorph/scribblings/xenomorph.scrbl b/xenomorph/xenomorph/scribblings/xenomorph.scrbl index a223a2d5..c10607c4 100644 --- a/xenomorph/xenomorph/scribblings/xenomorph.scrbl +++ b/xenomorph/xenomorph/scribblings/xenomorph.scrbl @@ -1105,7 +1105,7 @@ Create class instance that represents a bitfield format. See @racket[x:bitfield] (x:decode [input-port input-port?] [parent (or/c xenomorphic? #false)]) -hash-eq?]{ +hash?]{ Returns a hash whose keys are the names of the flags, and whose values are Booleans. } @@ -1131,9 +1131,9 @@ Whether @racket[x] is an object of type @racket[x:bitfield%]. @defproc[ (x:bitfield [type-arg (or/c x:int? #false) #false] -[flags-arg (listof (or/c symbol? #false))] +[flags-arg (listof any/c)] [#:type type-kw (or/c x:int? #false) uint8] -[#:flags flags-kw (listof (or/c symbol? #false)) null] +[#:flags flags-kw (listof any/c) null] [#:pre-encode pre-encode-proc (or/c (any/c . -> . any/c) #false) #false] [#:post-decode post-decode-proc (or/c (any/c . -> . any/c) #false) #false] [#:base-class base-class (λ (c) (subclass? c x:bitfield%)) x:bitfield%] @@ -1143,7 +1143,7 @@ Generate an instance of @racket[x:bitfield%] (or a subclass of @racket[x:bitfiel @racket[type-arg] or @racket[type-kw] (whichever is provided, though @racket[type-arg] takes precedence) controls the type of the bitfield value itself, which must be an @racket[x:int?]. Default is @racket[uint8]. -@racket[flags-arg] or @racket[flags-kw] (whichever is provided, though @racket[flags-arg] takes precedence) is a list of flag names corresponding to each bit. The number of names must be fewer than the number of bits in @racket[_type]. No name can be duplicated. Each name must be either a symbol or @racket[#false] (to indicate a skipped bit). Default is @racket[null]. +@racket[flags-arg] or @racket[flags-kw] (whichever is provided, though @racket[flags-arg] takes precedence) is a list of flag names corresponding to each bit. The number of names must be fewer than the number of bits in @racket[_type]. No name can be duplicated. Each flag name can be any value, but @racket[#false] indicates a skipped bit. Default is @racket[null]. @racket[pre-encode-proc] and @racket[post-decode-proc] control the pre-encoding and post-decoding procedures, respectively. Each takes as input the value to be processed and returns a new value. diff --git a/xenomorph/xenomorph/test/bitfield-test.rkt b/xenomorph/xenomorph/test/bitfield-test.rkt index 1c01b065..1b54b2cb 100644 --- a/xenomorph/xenomorph/test/bitfield-test.rkt +++ b/xenomorph/xenomorph/test/bitfield-test.rkt @@ -13,7 +13,7 @@ approximates https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee |# -(define bitfield (x:bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack))) +(define bitfield (x:bitfield uint8 '(Jack Kack "Lack" Mack Nack Oack Pack Quack))) (match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK) (map (λ (x) (arithmetic-shift 1 x)) (range 8))) @@ -21,12 +21,20 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee "bitfield: should have the right size" (check-equal? (size bitfield) 1)) +(test-case + "bitfield: should reject too many flags" + (check-exn exn:fail? (λ () (x:bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack Zack Wack))))) + +(test-case + "bitfield: should reject duplicate flags" + (check-exn exn:fail? (λ () (x:bitfield uint8 '(Jack Jack Jack Jack Jack))))) + (test-case "bitfield: should decode" (parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))]) - (check-equal? (decode bitfield) (mhasheq 'Quack #t + (check-equal? (decode bitfield) (mhash 'Quack #t 'Nack #t - 'Lack #f + "Lack" #f 'Oack #f 'Pack #t 'Mack #t @@ -36,10 +44,10 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee (test-case "bitfield: should decode with post-decode" (parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))]) - (define bitfield (x:bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) #:post-decode (λ (fh) (hash-set! fh 'foo 42) fh))) - (check-equal? (decode bitfield) (mhasheq 'Quack #t + (define bitfield (x:bitfield uint8 '(Jack Kack "Lack" Mack Nack Oack Pack Quack) #:post-decode (λ (fh) (hash-set! fh 'foo 42) fh))) + (check-equal? (decode bitfield) (mhash 'Quack #t 'Nack #t - 'Lack #f + "Lack" #f 'Oack #f 'Pack #t 'Mack #t @@ -49,9 +57,9 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee (test-case "bitfield: should encode" - (check-equal? (encode bitfield (mhasheq 'Quack #t + (check-equal? (encode bitfield (mhash 'Quack #t 'Nack #t - 'Lack #f + "Lack" #f 'Oack #f 'Pack #t 'Mack #t @@ -61,15 +69,15 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee (test-case "bitfield: should encode with pre-encode" - (define bitfield (x:bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack) + (define bitfield (x:bitfield uint8 '(Jack Kack "Lack" Mack Nack Oack Pack Quack) #:pre-encode (λ (fh) (hash-set! fh 'Jack #f) (hash-set! fh 'Mack #f) (hash-set! fh 'Pack #f) fh))) - (check-equal? (encode bitfield (mhasheq 'Quack #t + (check-equal? (encode bitfield (mhash 'Quack #t 'Nack #t - 'Lack #f + "Lack" #f 'Oack #f 'Pack #t 'Mack #t