ref: d5c519ab9f221b899180a0def079c64888c82af6
parent: b966ea03f7564a47816728d323adc942a0651c2f
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Tue Jun 11 16:47:31 EDT 2024
read bigger chunks, deserialize simple types inline
--- a/otf.rkt
+++ b/otf.rkt
@@ -33,7 +33,7 @@
(define-generics code
(gen-h code) ; generates code for the C header
- (gen-c code) ; generates code for the C source file
+ (gen-c code b index) ; generates code for the C source file
(c-type code)) ; type name to be used in C
(define-struct type (name bits c parse)
@@ -40,9 +40,9 @@
#:transparent
#:methods gen:code
[(define (gen-h t)
- (list (~a "int read_" (type-name t) "(Ctx *ctx, " (type-c t) " *v);")))
- (define (gen-c t)
- '())
+ empty)
+ (define (gen-c t b index)
+ empty)
(define (c-type t)
(type-c t))])
@@ -67,13 +67,13 @@
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h f)
- (list (~a (if (field-unused? f) "// unused " "")
+ (list (~a (if (field-unused? f) "// " "")
(super-c-type (field-type f))
" "
(field-ptr f)
(field-name f)
";")))
- (define (gen-c f)
+ (define (gen-c f b index)
(define (size t)
(if (type? t) (type-size t) 0))
(define (name t)
@@ -81,33 +81,41 @@
(define ref (~a (if (field-unused? f) "" "v->") (field-name f)))
(define declared (and (field-unused? f) (field-values f)))
(define (format-number x)
- (if (and (>= x -32767) (<= x 32768)) (~r x) (~r x #:base 16 #:sign '("0x" "" "-0x"))))- (list* (if declared (list (~a (name (field-type f)) " " ref ";")) empty)
- (match (field-count f)
- [#f
- (if (or declared (not (field-unused? f)))
- (~a "if(read_" (name (field-type f)) "(ctx, &" ref ") < 0){")- (~a "if(skip_bytes(ctx, " (size (field-type f)) ") < 0){"))]- [count
- (~a "if(read_array(ctx, &"
- ref
- ", read_"
- (super-c-type (field-type f))
- ", v->"
- (cadr count)
- ") < 0){")])- (~a "\twerror(\"%s: %r\", \"" (field-name f) "\");")
- (~a "\tgoto err;")
- (match (field-values f)
- [(list '= a ...)
- (list (~a "}")
- (~a "if("- (string-join (map (λ (v) (~a ref " != " (format-number v))) a) " && ")
- "){")- (~a "\twerror(\"%s: invalid value: %d\", \"" (field-name f) "\", " ref ");")
- (~a "\tgoto err;")
- (~a "}"))]
- [#f (list (~a "}"))])))])
+ (if (<= x 32768) (~r x) (~r x #:base 16 #:sign '("0x" "" "-0x"))))+ (define (parse-if-error read)
+ (match (field-count f)
+ [#f
+ (if (or declared (not (field-unused? f)))
+ (if index
+ (~a (if declared (~a (name (field-type f)) " ") "")
+ ref
+ " = "
+ ((type-parse (field-type f)) b index)
+ ";")
+ (list (if declared (~a (name (field-type f)) " " ref ";") empty)
+ (~a "if(read_" (name (field-type f)) "(ctx, &" ref ") < 0){")))+ (if index empty (~a "if(skip_bytes(ctx, " (size (field-type f)) ") < 0){")))]+ [count
+ (~a "if(read_array(ctx, &"
+ ref
+ ", read_"
+ (super-c-type (field-type f))
+ ", v->"
+ (cadr count)
+ ") < 0){")]))+ (list*
+ (parse-if-error #t)
+ (if index
+ empty
+ (list (~a "\twerror(\"%s: %r\", \"" (field-name f) "\");") (~a "\tgoto err;") (~a "}")))
+ (match (field-values f)
+ [(list '= a ...)
+ (list
+ (~a "if(" (string-join (map (λ (v) (~a ref " != " (format-number v))) a) " && ") "){")+ (~a "\twerror(\"%s: invalid value: %d\", \"" (field-name f) "\", " ref ");")
+ (~a "\tgoto err;")
+ (~a "}"))]
+ [#f empty])))])
(define-struct cmplx (name fields tag)
#:transparent
@@ -120,11 +128,27 @@
(indent (flatten (map super-gen-h (cmplx-fields c))))
(list (~a "};")
(~a "int read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v);")))))
- (define (gen-c c)
+ (define (gen-c c b index)
+ (define field-groups (group-by (λ (f) (cmplx? (field-type f))) (cmplx-fields c)))
+ (define (parse-group g)
+ (define (p fs index)
+ (if (pair? fs)
+ (cons (super-gen-c (car fs) "b" index)
+ (p (cdr fs) (+ index (type-size (field-type (car fs))))))
+ empty))
+ (p g 0))
+ (define (gen-group-c fields)
+ (if (cmplx? (field-type (car fields)))
+ (map (λ (f) (super-gen-c f #f #f)) fields)
+ (let ([sum (apply + (map (λ (f) (type-size (field-type f))) fields))])
+ (list* (~a "if((b = ctxreadn(ctx, " sum ")) == nil)")
+ (~a "\tgoto err;")
+ (parse-group fields)))))
(flatten (append (list (~a "int")
(~a "read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v)")
- (~a "{"))- (indent (flatten (map super-gen-c (cmplx-fields c))))
+ (~a "{")+ (~a "\tu8int *b;"))
+ (indent (flatten (map gen-group-c field-groups)))
(list (~a "\treturn 0;")
(~a "err:")
(~a "\twerrstr(\"%s: %r\", \"" (cmplx-name c) "\");")
@@ -133,20 +157,22 @@
(define (c-type c)
(cmplx-name c))])
-(begin-for-syntax
- (define/contract (autoparse bits ctype)
- (-> positive? symbol? (listof string?))
- (λ (b [index 0])
- (define cast (~a "(" ctype ")"))- (define (f index bits)
- (define sh (- bits 8))
- (define tail (if (positive? sh) (~a "<<" sh " | " (f (add1 index) sh)) ""))
- (~a (if (> sh 24) cast "") b "[" index "]" tail))
- (~a (if (<= bits 32) cast "") "(" (f index bits) ")"))))+(define/contract (autoparse bits ctype)
+ (-> positive? symbol? procedure?)
+ (λ (b [index 0])
+ (define cast (~a "(" ctype ")"))+ (define (f index bits)
+ (define sh (- bits 8))
+ (define tail (if (positive? sh) (~a "<<" sh " | " (f (add1 index) sh)) ""))
+ (~a (if (> sh 24) cast "") b "[" index "]" tail))
+ (f index bits)))
(define-syntax (mktype stx)
(syntax-parse stx
- [(_ typ:id bits:nat c:id) #'(mktype typ bits c #'(autoparse bits c))]
+ [(_ typ:id bits c:id)
+ #'(begin
+ (define parse (autoparse bits `c))
+ (mktype typ bits c parse))]
[(_ typ:id bits c:id parse:expr)
#:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
#'(begin
@@ -262,4 +288,4 @@
"head")
(printf (format gen-h))
-(printf (format gen-c))
+(printf (format (λ (c) (gen-c c #f #f))))
--
⑨