diff --git a/pitfall/pitfall/binparser/gif-parse.rkt b/pitfall/pitfall/binparser/gif-parse.rkt index 2781a230..09513694 100644 --- a/pitfall/pitfall/binparser/gif-parse.rkt +++ b/pitfall/pitfall/binparser/gif-parse.rkt @@ -9,7 +9,11 @@ (define-macro-cases :atomic [(N COUNT) #'(N COUNT identity)] - [(N COUNT PROC) #'(λ () (PROC (read-bytes COUNT)))]) + [(N COUNT PROC) #'(λ () + (define bs (read-bytes COUNT)) + (when (< (bytes-length bs) COUNT) + (error 'not-enough-bytes (format "~a needs ~a" 'N COUNT))) + (PROC bs))]) (define (seq->hash xs) (make-hasheq xs)) @@ -22,12 +26,12 @@ (PROC (map (λ(f) (f)) (list SEQ ...)))))] [(N SEQ ...) #'(N SEQ ... (:bidi identity))]) -(define-macro-cases :element +(struct elem (name val bidi) #:transparent) + +(define-macro-cases define-rule [(N ID WHAT) #'(N ID WHAT (:bidi identity))] [(N ID WHAT (:bidi PROC)) - #'(define ID (λ () (if (unparse-val) - (PROC (unparse-val)) - (PROC (cons 'ID (WHAT))))))]) + #'(define ID (λ () (elem 'ID (WHAT) PROC)))]) (define-macro (:bidi X) #'X) @@ -49,21 +53,28 @@ (define (bytes->string bs) (bytes->string/latin-1 bs)) -(:element gif (:seq signature version logical-screen-descriptor (:bidi seq->hash)) (:bidi val->hash)) -(:element signature (:atomic 3 (:bidi bytes->string))) -(:element version (:atomic 3 (:bidi bytes->string))) +(define-rule gif (:seq signature version logical-screen-descriptor (:bidi seq->hash))) +(define-rule signature (:atomic 3 (:bidi bytes->string))) +(define-rule version (:atomic 3 (:bidi bytes->string))) + +(define-rule logical-screen-descriptor (:seq width height packed bgcolor-idx aspect (:bidi seq->list))) +(define-rule width (:atomic 2 (:bidi bytes->int))) +(define-rule height (:atomic 2 (:bidi bytes->int))) +(define-rule packed (:atomic 1 (:bidi bytes->bitfield))) +(define-rule bgcolor-idx (:atomic 1 (:bidi bytes->int))) +(define-rule aspect (:atomic 1 (:bidi bytes->int))) -(:element logical-screen-descriptor (:seq width height packed bgcolor-idx aspect (:bidi seq->list))) -(:element width (:atomic 2 (:bidi bytes->int))) -(:element height (:atomic 2 (:bidi bytes->int))) -(:element packed (:atomic 1 (:bidi bytes->bitfield))) -(:element bgcolor-idx (:atomic 1 (:bidi bytes->int))) -(:element aspect (:atomic 1 (:bidi bytes->int))) +(define (make-byte-parser rule) + (λ (x) (parse-with-template x rule))) -(define (parse-with-template file template) - (parameterize ([current-input-port (open-input-file file)]) +(define (parse-with-template in template) + (parameterize ([current-input-port (cond + [(bytes? in) (open-input-bytes in)] + [(path-string? in) (open-input-file in)] + [(input-port? in) in] + [else (error 'unknown-parse-input-type)])]) (template))) (define (unparse-with-template val template) @@ -71,11 +82,14 @@ (template))) (require rackunit) -(check-equal? (parse-with-template "test.gif" gif) - (make-hasheq (list - (cons 'gif - (make-hasheq (list (cons 'logical-screen-descriptor '(162 162 (#f #t #f #f #f #t #f #t) 0 0)) - '(signature . "GIF") - '(version . "87a"))))))) - -(unparse-with-template (parse-with-template "test.gif" gif) gif) +#;(check-equal? (parse-with-template "test.gif" gif) + (cons 'gif + (make-hasheq (list (cons 'logical-screen-descriptor '(162 162 (#f #t #f #f #f #t #f #t) 0 0)) + '(signature . "GIF") + '(version . "87a"))))) + +#;(define parse-width-bytes (make-byte-parser width)) +(define-rule foo (:atomic 2)) +(define parse-foo-bytes (make-byte-parser foo)) +(define in (open-input-bytes #"12")) +(parse-foo-bytes in)