ref: 5f2d73e0f7149c12aeab5c7d06bc9c91de044df6
parent: a24a5759afa209af707c750660236f0719ad8b71
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sun Jun 16 19:02:52 EDT 2024
implement conditional fields
--- a/otf.rkt
+++ b/otf.rkt
@@ -66,6 +66,17 @@
(define (field-verb f)
(assoc 'verb (field-attrs f)))
+(define (field-cond f)
+ (assoc 'cond (field-attrs f)))
+
+(define (block stmt lst)
+ (if (= (length lst) 1) (list* stmt lst) (list (string-append stmt "{") lst "}")))+
+(define (wrap-cond-c cond lst)
+ (match cond
+ [#f lst]
+ [(list 'cond op ref n) (block (~a "if(v->" ref " " op " " n ")") (indent lst))]))
+
(define (field-fprint-c f)
(define t (field-type f))
(define count (field-count f))
@@ -75,7 +86,7 @@
(define verb (if (type? t) (if (field-verb f) (cadr (field-verb f)) (type-verb t)) ""))
(define fprint-index
(if fixed-array
- (~a "\tfprint(f, \"%*s%s[%d]: "
+ (~a "fprint(f, \"%*s%s[%d]: "
verb
"\\n\", indent, \"\", \""
(field-name f)
@@ -83,34 +94,26 @@
(field-name f)
array-index
");")
- (~a "\tfprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
+ (~a "fprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
(define array-loop
(if count
(λ (lst)
- (if fixed-array
- (list (~a "for(int i = 0; i < " (cadr count) "; i++)") fprint-index)
- (list (~a "for(int i = 0; i < v->" (cadr count) "; i++){")- fprint-index
- (indent lst)
- (~a "}"))))
+ (block (~a "for(int i = 0; i < " (if fixed-array "" "v->") (cadr count) "; i++)")
+ (indent (list* fprint-index (if fixed-array empty lst)))))
identity))
- (if (field-unused? f)
- empty
- (array-loop (list (if (type? t)
- (~a "fprint(f, \"%*s%s: "
- verb
- "\\n\", indent, \"\", \""
- (field-name f)
- "\", v->"
- (field-name f)
- array-index
- ");")
- (~a "fprint_"
- (cmplx-name t)
- "(f, indent+indentΔ, &v->"
- (field-name f)
- array-index
- ");"))))))
+ (define lst
+ (list
+ (if (type? t)
+ (~a "fprint(f, \"%*s%s: "
+ verb
+ "\\n\", indent, \"\", \""
+ (field-name f)
+ "\", v->"
+ (field-name f)
+ array-index
+ ");")
+ (~a "fprint_" (cmplx-name t) "(f, indent+indentΔ, &v->" (field-name f) array-index ");"))))
+ (if (field-unused? f) empty (wrap-cond-c (field-cond f) (array-loop lst))))
(define-struct field (type name attrs)
#:transparent
@@ -198,33 +201,48 @@
(list (~a "};")
(~a "int read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v);")))))
(define (gen-c c b index)
- (define field-groups (group-by (λ (f) (cmplx? (field-type f))) (cmplx-fields c)))
+ ; group fields to minimize number of reads
+ ; complex types are always alone
+ ; simple types can be combined unless versioned
+ ; versioned simple types are combined if the check is the same
+ (define (group-fields fields)
+ (define (combine? f g)
+ (or (empty? g)
+ (and (type? (field-type f))
+ (type? (field-type (car g)))
+ (equal? (field-cond f) (field-cond (car g))))))
+ (define (group- g fields)
+ (match fields
+ [(list-rest f tail)
+ (if (combine? f g) (group- (cons f g) tail) (cons (reverse g) (group- (list f) tail)))]
+ [_ (list (reverse g))]))
+ (group- empty fields))
+ (define (field-size f)
+ (match (field-count f)
+ [#f (type-size (field-type f))]
+ [count
+ #:when (type? (field-type f))
+ (* (cadr count) (type-size (field-type f)))]))
(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))))))
+ (cons (super-gen-c (car fs) "b" index) (p (cdr fs) (+ index (field-size (car fs)))))
empty))
(p g 0))
(define (gen-group-c fields)
- (define (field-size f)
- (match (field-count f)
- [#f (type-size (field-type f))]
- [count
- #:when (type? (field-type f))
- (* (cadr count) (type-size (field-type f)))]))
(if (cmplx? (field-type (car fields)))
(map (λ (f) (super-gen-c f #f #f)) fields)
- (let ([sum (apply + (map (λ (f) (field-size f)) fields))])
- (list* (~a "if((b = ctxreadn(ctx, " sum ")) == nil)")
- (~a "\tgoto err;")
- (parse-group fields)))))
+ (let* ([sum (apply + (map (λ (f) (field-size f)) fields))]
+ [lst (flatten (list* (~a "if((b = ctxreadn(ctx, " sum ")) == nil)")
+ (~a "\tgoto err;")
+ (parse-group fields)))])
+ (wrap-cond-c (field-cond (car fields)) lst))))
(flatten
(append (list (~a "int")
(~a "read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v)")
(~a "{")(~a "\tu8int *b;"))
- (indent (flatten (map gen-group-c field-groups)))
+ (indent (flatten (map gen-group-c (group-fields (cmplx-fields c)))))
(indent (filter-extra (cmplx-extra c) 'read))
(list (~a "\treturn 0;")
(~a "err:")
@@ -281,6 +299,11 @@
[(_ (n:number)) #''(count n)]
[(_ {~literal hex}) #''(verb "%#ux")] [(_ ({~literal =} vs:number ...+)) #''(= vs ...)]+ [(_ (p:expr ref:id n:number))
+ #''(cond
+ p
+ ref
+ n)]
[(_ ({~literal count} n:id))(begin
(define counter (assoc (syntax->datum #`n) fields))
@@ -308,7 +331,7 @@
(define-syntax (mkfields stx)
(syntax-parse stx
- [(_ x ...)
+ [(_ x ...+)
(begin
(set! fields '())
#'(list (mkfield [~@ . x]) ...))]))
@@ -408,8 +431,15 @@
{FWORD sTypoLineGap} {UFWORD usWinAscent} {UFWORD usWinDescent}- ; FIXME more fields depending on version
- )
+ {uint32 ulCodePageRange1 (>= version 1) hex}+ {uint32 ulCodePageRange2 (>= version 1) hex}+ {FWORD sxHeight (>= version 2)}+ {FWORD sCapHeight (>= version 2)}+ {uint16 usDefaultChar (>= version 2) hex}+ {uint16 usBreakChar (>= version 2) hex}+ {uint16 usMaxContext (>= version 2)}+ {uint16 usLowerOpticalPointSize (>= version 5)}+ {uint16 usUpperOpticalPointSize (>= version 5)})#:tag "OS/2")
(mkcmplx TableRecord