ref: a24a5759afa209af707c750660236f0719ad8b71
parent: 3e799de72f01ff3c4b17417da080f4a6901fc59f
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Thu Jun 13 23:47:30 EDT 2024
support weird table tags -> C field mapping; add fixed arrays
--- a/otf.rkt
+++ b/otf.rkt
@@ -60,9 +60,6 @@
(define (field-count f)
(assoc 'count (field-attrs f)))
-(define (field-ptr f)
- (if (field-count f) "*" ""))
-
(define (field-values f)
(assoc '= (field-attrs f)))
@@ -71,16 +68,32 @@
(define (field-fprint-c f)
(define t (field-type f))
+ (define count (field-count f))
+ (define end (and count (if (cmplx? t) (~a "v->" (cadr count)) (cadr count))))
+ (define fixed-array (and (type? t) (number? end)))
+ (define array-index (if (field-count f) "[i]" ""))
+ (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]: "
+ verb
+ "\\n\", indent, \"\", \""
+ (field-name f)
+ "\", i, v->"
+ (field-name f)
+ array-index
+ ");")
+ (~a "\tfprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
(define array-loop
- (if (field-count f)
+ (if count
(λ (lst)
- (list (~a "for(int i = 0; i < v->" (cadr (field-count f)) "; i++){")- (~a "\tfprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")
- (indent lst)
- (~a "}")))
+ (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 "}"))))
identity))
- (define array-index (if (field-count f) "[i]" ""))
- (define verb (if (type? t) (if (field-verb f) (cadr (field-verb f)) (type-verb t)) ""))
(if (field-unused? f)
empty
(array-loop (list (if (type? t)
@@ -104,11 +117,14 @@
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h f)
+ (define cnt (field-count f))
+ (define fixed-array (and cnt (number? (cadr cnt))))
(list (~a (if (field-unused? f) "// " "")
(super-c-type (field-type f))
" "
- (field-ptr f)
+ (if (and cnt (not fixed-array)) "*" "")
(field-name f)
+ (if fixed-array (~a "[" (cadr cnt) "]") "")
";")))
(define (gen-c f b index)
(define (size t)
@@ -133,6 +149,10 @@
(~a "if(read_" (name (field-type f)) "(ctx, &" ref ") < 0){"))) (if index empty (~a "if(skip_bytes(ctx, " (size (field-type f)) ") < 0){")))][count
+ #:when (and (number? (cadr count)) (type? (field-type f)))
+ (list (~a "for(int i = 0; i < " (cadr count) "; i++)")
+ (~a "\t" ref "[i] = " ((type-parse (field-type f)) b index "i") ";"))]
+ [count
(~a "if(ctxarray(ctx, &"
ref
", read_"
@@ -187,9 +207,15 @@
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) (type-size (field-type 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)))))
@@ -216,12 +242,13 @@
(define/contract (autoparse bits ctype)
(-> positive? symbol? procedure?)
- (λ (b [index 0])
+ (λ (b [index 0] [offset #f])
+ (define off (if offset (~a "+" offset) ""))
(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 (> sh 24) cast "") b "[" index off "]" tail))
(f index bits)))
(define-syntax (mktype stx)
@@ -251,6 +278,7 @@
(define-syntax (mkattr stx)
(syntax-parse stx
+ [(_ (n:number)) #''(count n)]
[(_ {~literal hex}) #''(verb "%#ux")] [(_ ({~literal =} vs:number ...+)) #''(= vs ...)] [(_ ({~literal count} n:id))@@ -344,13 +372,48 @@
#:tag "head")
(mkcmplx TableMaxp
- (mkfields {Version16Dot16 version hex (= #x05000 #x10000)}+ (mkfields {Version16Dot16 version (= #x05000 #x10000)} {uint16 numGlyphs} ; FIXME there are more fields here, depending on the version)
#:tag "maxp")
+(mkcmplx TableOS∕2
+ (mkfields {uint16 version (= 0 1 2 3 4 5)}+ {FWORD xAvgCharWidth}+ {uint16 usWeightClass}+ {uint16 usWidthClass}+ {uint16 fsType}+ {FWORD ySubscriptXSize}+ {FWORD ySubscriptYSize}+ {FWORD ySubscriptXOffset}+ {FWORD ySubscriptYOffset}+ {FWORD ySuperscriptXSize}+ {FWORD ySuperscriptYSize}+ {FWORD ySuperscriptXOffset}+ {FWORD ySuperscriptYOffset}+ {FWORD yStrikeoutSize}+ {FWORD yStrikeoutPosition}+ {int16 sFamilyClass}+ {uint8 panose [10]}+ {uint32 ulUnicodeRange1 hex}+ {uint32 ulUnicodeRange2 hex}+ {uint32 ulUnicodeRange3 hex}+ {uint32 ulUnicodeRange4 hex}+ {Tag achVendID}+ {uint16 fsSelection}+ {uint16 usFirstCharIndex}+ {uint16 usLastCharIndex}+ {FWORD sTypoAscender}+ {FWORD sTypoDescender}+ {FWORD sTypoLineGap}+ {UFWORD usWinAscent}+ {UFWORD usWinDescent}+ ; FIXME more fields depending on version
+ )
+ #:tag "OS/2")
+
(mkcmplx TableRecord
- (mkfields {Tag tableTag} {uint32 checksum hex} {Offset32 offset} {uint32 length})+ (mkfields {Tag tableTag} {uint32 checksum unused hex} {Offset32 offset} {uint32 length})#:extra (list (cons 'field
(list (~a "void *parsed;")
(~a "void (*fprint)(int f, int indent, void *parsed);")))
@@ -358,7 +421,8 @@
(list (~a "if(v->fprint != nil && v->parsed != nil)")
(~a "\tv->fprint(f, indent+indentΔ, v->parsed);")))))
-(define c-friendly-name identity)
+(define (c-friendly-name t)
+ (string-replace (string-trim (string-downcase t)) "/" "∕"))
(define (tagged-tables-fields tagged)
(define (ptr c)