ref: 604208afc7b6996bbd76a254859ab384319aa1b6
dir: /otf.rkt/
#!/usr/bin/env racket
#lang racket
(require (for-syntax racket/format))
(require (for-syntax syntax/parse))
(require (for-syntax racket/contract))
(require racket/contract)
(require racket/generic)
(define types '()) ; base types set
(define cmplxs '()) ; complex types set
(define tagged '()) ; complex types set that also have a defined tag
(define size-in-bits/c
(make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 64)))))
(define tag/c
(make-contract #:name 'tag/c #:first-order (λ (x) (and (string? x) (= 4 (string-length x))))))
(define/contract (indent lst)
(-> (listof any/c) (listof string?))
(map (λ (str) (string-append "\t" str)) (flatten lst)))
(define/contract (c-typedef? s)
(-> string? boolean?)
(string-prefix? s "typedef"))
(define/contract (format f)
(-> procedure? string?)
(define-values (a b) (partition c-typedef? (flatten (map f cmplxs))))
(define ps (list a b (map f types) ""))
(string-join (flatten ps) "\n"))
(define-generics code
(gen-h code) ; generates code for the C header
(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 verb parse)
#:transparent
#:methods gen:code
[(define (gen-h t)
empty)
(define (gen-c t b index)
empty)
(define (c-type t)
(type-c t))])
(define/contract (type-size t)
(-> type? positive?)
(/ (type-bits t) 8))
(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 op ref n ...)
(block (~a "if(" (string-join (map (λ (n) (~a "v->" ref " " op " " n)) n) " || ") ")")
(indent lst))]))
(define (invert-c op)
(match op
['== '!=]
['<= '>]
['>= '<]
['< '>=]
['> '<=]))
(define-struct field (type name attrs)
#:transparent
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h f)
(define cnt (field-count f))
(define fixed-array (number? cnt))
(define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
(list (~a (if (field-unused? f) "// " "")
(super-c-type (field-type f))
" "
(if (or is-ptr (and cnt (not fixed-array))) "*" "")
(field-name f)
(if fixed-array (~a "[" cnt "];") ";"))))
(define (gen-c f b index)
(define (size t)
(if (type? t) (type-size t) 0))
(define (name t)
(if (type? t) (super-c-type t) (cmplx-name t)))
(define ref (~a (if (field-unused? f) "" "v->") (field-name f)))
(define declared (and (field-unused? f) (not (empty? (field-test f)))))
(define (format-number x)
(if (<= x 32768) (~r x) (~r x #:base 16 #:sign '("0x" "" "-0x"))))
(define (parse-if-error read)
(define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
(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 ";")
(if is-ptr (~a ref " = calloc(1, sizeof(*" ref "));") empty))
(~a "if(read_" (name (field-type f)) "(o, " (if is-ptr "" "&") ref ") < 0){")))
(if index empty (~a "if(otfreadn(o, " (size (field-type f)) ") == nil){")))]
[count
#:when (type? (field-type f))
(if (field-unused? f)
empty
(list (if (number? count) empty (~a ref " = malloc(" count "*sizeof(*" ref "));"))
(~a "for(int i = 0; i < " count "; i++)")
(~a "\t"
ref
"[i] = "
((type-parse (field-type f)) b index (~a "i*" (size (field-type f))))
";")))]
[count
(~a "if(otfarray(o, &"
ref
", read_"
(super-c-type (field-type f))
", sizeof("
(super-c-type (field-type f))
"), "
count
") < 0){")]))
(define (test-cond ts)
(map (λ (t)
(match t
[(list 'test op a ...)
(string-join (map (λ (v) (~a ref " " (invert-c op) " " (format-number v))) a)
" && ")]))
ts))
(define (at lst)
(define at (field-offset f))
(if (not at)
lst
(list (~a "if(v->" at " != 0){")
(~a "\tif(otfpushrange(o, v->" at ", -1) < 0)")
(~a "\t\tgoto err;")
(indent lst)
(~a "\tif(otfpoprange(o) < 0)")
(~a "\t\tgoto err;")
(~a "}"))))
(at (list* (parse-if-error #t)
(if index
empty
(list (~a "\twerrstr(\"%s: %r\", \"" (field-name f) "\");")
(~a "\tgoto err;")
(~a "}")))
(match (test-cond (field-test f))
[(list) empty]
[(list a ...)
(list (~a "if(" (string-join a " || ") "){")
(~a "\twerrstr(\"%s: invalid value: %d (0x%ux)\", \""
(field-name f)
"\", "
ref
", "
ref
");")
(~a "\tgoto err;")
(~a "}"))]))))])
(define/contract (field-attr f a)
(-> field? symbol? any)
(define v (assoc a (field-attrs f)))
(and v (cadr v)))
(define (field-unused? f)
(field-attr f 'unused))
(define (field-verb f)
(field-attr f 'verb))
(define (field-offset f)
(field-attr f 'at))
(define (field-cond f)
(define v (assoc 'cond (field-attrs f)))
(and v (rest v)))
(define/contract (field-count f)
(-> field? (or/c false/c number? string?))
(define (fmt-expr e)
(cond
[(number? e) e]
[(list? e)
(match e
[(list op x y) (~a (fmt-expr x) op (fmt-expr y))])]
[(symbol? e) (~a "v->" e)]))
(define e (field-attr f 'count))
(and e (fmt-expr e)))
(define (field-test f)
(filter (λ (t) (eq? (car t) 'test)) (field-attrs f)))
(define (field-print-c f)
(define t (field-type f))
(define cnt (field-count f))
(define basic-array (and cnt (type? t)))
(define fixed-array (and basic-array (number? cnt)))
(define array-index (if cnt "[i]" ""))
(define verb (if (type? t) (or (field-verb f) (type-verb t)) ""))
(define print-index
(if basic-array
(~a "Bprint(f, \"%*s%s[%d]: "
verb
"\\n\", indent, \"\", \""
(field-name f)
"\", i, v->"
(field-name f)
array-index
");")
(~a "Bprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
(define array-loop
(if cnt
(λ (lst)
(block (~a "for(int i = 0; i < " cnt "; i++)")
(indent (list* print-index (if basic-array empty lst)))))
identity))
(define is-ptr (and (cmplx? t) (field-offset f) (not cnt)))
(define lst
(flatten
(list
(if (type? t)
(~a "Bprint(f, \"%*s%s: "
verb
"\\n\", indent, \"\", \""
(field-name f)
"\", v->"
(field-name f)
array-index
");")
(list (if cnt empty (~a "Bprint(f, \"%*s%s:\\n\", indent, \"\", \"" (field-name f) "\");"))
(if is-ptr (~a "if(v->" (field-name f) " != nil)") empty)
(~a (if is-ptr "\t" "")
"print_"
(cmplx-name t)
"(f, indent+indentΔ, "
(if is-ptr "" "&")
"v->"
(field-name f)
array-index
");"))))))
(if (field-unused? f) empty (wrap-cond-c (field-cond f) (array-loop lst))))
(define (filter-extra extra key)
(flatten (filter-map (λ (e) (and (eq? (car e) key) (cdr e))) extra)))
(define-struct cmplx (name fields tag extra)
#:transparent
#:methods gen:code
[(define/generic super-gen-h gen-h)
(define/generic super-gen-c gen-c)
(define (gen-h c)
(flatten
(append
(list (~a "typedef struct " (cmplx-name c) " " (cmplx-name c) ";")
(~a "")
(~a "struct " (cmplx-name c) " {"))
(indent (map super-gen-h (cmplx-fields c)))
(indent (filter-extra (cmplx-extra c) 'field))
(list (~a "};")
(~a "")
(~a "int read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v);")
(~a "void print_" (cmplx-name c) "(Biobuf *f, int indent, " (cmplx-name c) " *v);")))))
(define (gen-c c b index)
(define (no-vla? f)
(define cnt (field-count f))
(or (not cnt) (number? cnt)))
; 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)))
(no-vla? f)
(no-vla? (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))
((if (number? count) (λ (sz) (* count sz)) (λ (sz) (~a count "*" sz)))
(type-size (field-type f)))]))
(define (add x y)
(match (list x y)
[(list _ 0) x]
[(list 0 _) y]
[_ (if (and (number? x) (number? y)) (+ x y) (~a x "+" y))]))
(define (parse-group g)
(define (p fs index)
(if (pair? fs)
(cons (super-gen-c (car fs) "b" index) (p (cdr fs) (add index (field-size (car fs)))))
empty))
(p g 0))
(define (gen-group-c fields)
(define unused (andmap field-unused? fields))
(wrap-cond-c (field-cond (car fields))
(if (cmplx? (field-type (car fields)))
(map (λ (f) (super-gen-c f #f #f)) fields)
(let* ([sum (foldr (λ (f accu) (add (field-size f) accu)) 0 fields)]
[lst (flatten (list* (~a "if((b = otfreadn(o, " sum ")) == nil)")
(~a "\tgoto err;")
(if unused "USED(b);" empty)
(parse-group fields)))])
lst))))
(flatten
(append (list (~a "")
(~a "int")
(~a "read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v)")
(~a "{")
(~a "\tu8int *b;"))
(indent (map gen-group-c (group-fields (cmplx-fields c))))
(indent (filter-extra (cmplx-extra c) 'read))
(list (~a "\treturn 0;")
(~a "err:")
(~a "\twerrstr(\"%s: %r\", \"" (cmplx-name c) "\");")
(~a "\treturn -1;")
(~a "}"))
(list (~a "")
(~a "void")
(~a "print_" (cmplx-name c) "(Biobuf *f, int indent, " (cmplx-name c) " *v)")
(~a "{")
(indent (map field-print-c (cmplx-fields c)))
(indent (filter-extra (cmplx-extra c) 'print))
(~a "}")))))
(define (c-type c)
(cmplx-name c))])
(define/contract (autoparse bits ctype)
(-> positive? symbol? procedure?)
(λ (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 off "]" tail))
(f index bits)))
(define-syntax (mktype stx)
(syntax-parse stx
[(_ typ:id bits c:id verb:string)
#'(begin
(define parse (autoparse bits `c))
(mktype typ bits c verb parse))]
[(_ typ:id bits c:id verb:string parse:expr)
#:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
#'(begin
(define typ (make-type `typ bits.c `c verb parse))
(set! types (append types (list typ))))]))
(define-syntax (mkcmplx stx)
(syntax-parse stx
[(_ typ:id fields:expr (~optional (~seq #:tag tag)) (~optional (~seq #:extra extra:expr)))
#:declare tag (expr/c #'tag/c #:name "table tag")
#'(begin
(define tag- (~? (~@ tag.c) #f))
(define typ (make-cmplx `typ fields tag- (~? (~@ extra) empty)))
(set! cmplxs (append cmplxs (list typ)))
(when tag-
(set! tagged (append tagged (list typ)))))]))
(mktype uint8 8 u8int "%ud")
(mktype int8 8 s8int "%d")
(mktype uint16 16 u16int "%ud")
(mktype int16 16 s16int "%d")
(mktype uint24 24 u32int "%ud")
(mktype uint32 32 u32int "%ud")
(mktype int32 32 s32int "%d")
(mktype FWORD 16 s16int "%d")
(mktype UFWORD 16 u16int "%ud")
(mktype LONGDATETIME
64
s64int
"%T"
(λ (b index) (~a "(" ((autoparse 64 's64int) b index) ") - 2082844800LL")))
(mktype Tag 32 u32int "%t")
(mktype Offset16 16 u16int "%ud")
(mktype Offset24 24 u32int "%ud")
(mktype Offset32 32 u32int "%ud")
(mktype Version16Dot16 32 u32int "%V")
(mktype Fixed 32 float "%g" (λ (b index) (~a "(" ((type-parse int32) b index) ")/65536.0f")))
(mktype F2DOT14
16
float
"%g"
(λ (b index)
(define x (~a ((type-parse int16) b index)))
(~a "(" x ">>14)+(" x "&((1<<14)-1))/16384.0")))
; types allowed to be used as index
(define-for-syntax (type-index? type) (member type '(uint16 uint32)))
; types allowed to be used as offset
(define-for-syntax (type-offset? type) (member type '(Offset16 Offset24 Offset32)))
; types allowed to be used in comparisons
(define-for-syntax (type-comparable? type)
(member type '(uint8 int8 uint16 int16 uint24 uint32 int32 Version16Dot16)))
; types allowed to be used in comparisons
(define-for-syntax (type-number? type)
(member type
'(uint8 int8 uint16 int16 uint24 uint32 int32 Version16Dot16 Offset16 Offset24 Offset32)))
(define-for-syntax fields '())
(define-syntax (mkattr stx)
(syntax-parse stx
[(_ _ ({~literal at} ref:id))
(let ([rf (assoc (syntax->datum #`ref) fields)])
(begin
(when (not rf)
(raise-syntax-error #f "no such field" stx #'ref))
(when (not (type-offset? (cadr rf)))
(raise-syntax-error #f (~a (cadr rf) " can't be used as an offset") stx #'ref))
#''(at ref)))]
[(_ _ (n:number)) #''(count n)]
[(_ type {~literal hex})
(begin
(when (not (type-number? (syntax->datum #`type)))
(raise-syntax-error #f "not a number type" stx #'type))
#''(verb "%#ux"))]
[(_ type (p:expr vs:number ...+))
(begin
(when (not (type-comparable? (syntax->datum #`type)))
(raise-syntax-error #f "type can't be used in a comparison" stx #'type))
#''(test p vs ...))]
[(_ _ (p:expr ref:id vs:number ...+))
(begin
(when (not (assoc (syntax->datum #`ref) fields))
(raise-syntax-error #f "no such field" stx #'ref))
#''(cond
p
ref
vs ...))]
[(_ _ ({~literal count} n:id))
(begin
(define counter (assoc (syntax->datum #`n) fields))
(cond
[(pair? counter)
(if (type-index? (cadr counter))
#''(count n)
(raise-syntax-error #f
(~a "type " (cadr counter) " can't be used as index to the array")
stx
#'n))]
[else (raise-syntax-error #f "no such field" stx #'n)]))]
[(_ _ ({~literal count} e:expr)) #''(count e)] ; FIXME - check fields and ops/numbers
[(_ _ {~literal unused}) #''(unused #t)]))
(define-syntax (mkfield stx)
(syntax-parse stx
[(_ type:id name:id attrs ...)
(begin
(let ([f #'(field type
`name
(list (mkattr type [~@ attrs]) ...))])
(begin
(when (assoc (syntax->datum #`name) fields)
(raise-syntax-error #f "duplicate field" stx #'name))
(set! fields (cons (syntax->datum #'(name type)) fields))
f)))]))
(define-syntax (mkfields stx)
(syntax-parse stx
[(_ x ...+)
(begin
(set! fields '())
#'(list (mkfield [~@ . x]) ...))]))
(mkcmplx SubHeader
(mkfields {uint16 firstCode} {uint16 entryCode} {int16 idDelta} {uint16 idRangeOffset}))
; same type for Sequential and Constant
(mkcmplx MapGroup (mkfields {uint32 startCharCode} {uint32 endCharCode} {uint32 startGlyphID}))
(mkcmplx SubtableCmap0 (mkfields {uint16 length} {uint16 language} {uint8 glyphIdArray [256]}))
; FIXME
(mkcmplx SubtableCmap2 (mkfields {uint16 length} {uint16 language} {uint16 subHeaderKeys [256]}))
#| {SubHeader subHeaders (count ?)}
{uint16 glyphIdArray (count ?)}))|#
; FIXME
(mkcmplx SubtableCmap4
(mkfields {uint16 length}
{uint16 language}
{uint16 segCountX2}
{uint16 searchRange}
{uint16 entrySelector}
{uint16 rangeShift}
{uint16 endCode (count (/ segCountX2 2))}
{uint16 reservedPad unused}
{uint16 startCode (count (/ segCountX2 2))}
{int16 idDelta (count (/ segCountX2 2))}
{int16 idRangeOffset (count (/ segCountX2 2))}
#;{uint16 glyphIdArray (count ?)}))
(mkcmplx SubtableCmap6
(mkfields {uint16 length}
{uint16 language}
{uint16 firstCode}
{uint16 entryCount}
{uint16 glyphIdArray (count entryCount)}))
(mkcmplx SubtableCmap8
(mkfields {uint16 length}
{uint16 language}
{uint8 is32 [8192]}
{uint32 numGroups}
{MapGroup groups (count numGroups)}))
; FIXME
(mkcmplx SubtableCmap10
(mkfields {uint16 reserved}
{uint32 length}
{uint32 language}
{uint32 startCharCode}
{uint32 numChars}
#;{uint16 glyphIdArray (count ?)}))
(mkcmplx SubtableCmap12or13
(mkfields {uint16 reserved}
{uint32 length}
{uint32 language}
{uint32 numGroups}
{MapGroup groups (count numGroups)}))
(mkcmplx UnicodeRange (mkfields {uint24 startUnicodeValue} {uint8 additionalCount}))
(mkcmplx DefaultUVS
(mkfields {uint32 numUnicodeValueRanges}
{UnicodeRange ranges (count numUnicodeValueRanges)}))
(mkcmplx UVSMapping (mkfields {uint24 unicodeValue} {uint16 glyphID}))
(mkcmplx NonDefaultUVS
(mkfields {uint32 numUVSMappings} {UVSMapping uvsMappings (count numUVSMappings)}))
(mkcmplx VariationSelector
(mkfields {uint24 varSelector}
{Offset32 defaultUVSOffset}
{Offset32 nonDefaultUVSOffset}
{DefaultUVS defaultUVS (at defaultUVSOffset)}
{NonDefaultUVS nonDefaultUVS (at nonDefaultUVSOffset)}))
(mkcmplx SubtableCmap14
(mkfields {uint32 length}
{uint32 numVarSelectorRecords}
{VariationSelector varSelector (count numVarSelectorRecords)}))
(mkcmplx SubtableCmap
(mkfields {uint16 format (== 0 2 4 6 8 10 12 13 14)}
; FIXME these fields should be put into a union automatically
{SubtableCmap0 sub0 (== format 0)}
{SubtableCmap2 sub2 (== format 2)}
{SubtableCmap4 sub4 (== format 4)}
{SubtableCmap6 sub6 (== format 6)}
{SubtableCmap8 sub8 (== format 8)}
{SubtableCmap10 sub10 (== format 10)}
{SubtableCmap12or13 sub12or13 (== format 12 13)}
{SubtableCmap14 sub14 (== format 14)}))
(mkcmplx EncodingRecord
(mkfields {uint16 platformID (<= 4)}
{uint16 encodingID}
{Offset32 subtableOffset}
{SubtableCmap subtable (at subtableOffset)}))
(mkcmplx TableCmap
(mkfields {uint16 version unused (== 0)}
{uint16 numTables}
{EncodingRecord encodingRecords (count numTables)})
#:tag "cmap")
(mkcmplx TableHead
(mkfields {uint16 majorVersion unused (== 1)}
{uint16 minorVersion unused (== 0)}
{Fixed fontRevision unused}
{uint32 checksumAdjustment unused}
{uint32 magicNumber unused (== #x5f0f3cf5)}
{uint16 flags}
{uint16 unitsPerEm (>= 16) (<= 16384)}
{LONGDATETIME created}
{LONGDATETIME modified}
{int16 xMin}
{int16 yMin}
{int16 xMax}
{int16 yMax}
{uint16 macStyle}
{uint16 lowestRecPPEM}
{int16 fontDirectionHint unused (>= -2) (<= 2)}
{int16 indexToLocFormat (<= 1)}
{int16 glyphDataFormat unused (== 0)})
#:tag "head")
(mkcmplx TableHhea
(mkfields {uint16 majorVersion (== 1)}
{uint16 minorVersion (== 0)}
{FWORD ascender}
{FWORD descender}
{FWORD lineGap}
{UFWORD advanceWidthMax}
{FWORD minLeftSideBearing}
{FWORD minRightSideBearing}
{FWORD xMaxExtent}
{int16 caretSlopeRise}
{int16 caretSlopeRun}
{int16 caretOffset}
{int16 reserved [4] unused}
{int16 metricDataFormat (== 0)}
{uint16 numberOfHMetrics})
#:tag "hhea")
(mkcmplx LongHorMetric (mkfields {UFWORD advanceWidth} {FWORD lsb}))
#|
FIXME what. WHAT.
(mkcmplx TableHmtx
(mkfields {LongHorMetric hMetrics (count (TableHhea numberOfHMetrics))}
{FWORD leftSideBearings (count (- (TableMaxp numGlyphs) (TableHhea numberOfHMetrics)))}))
|#
(mkcmplx TableMaxp
(mkfields {Version16Dot16 version (== #x05000 #x10000) unused}
{uint16 numGlyphs}
; a bunch of fields ignored here
)
#:tag "maxp")
(mkcmplx TablePost
(mkfields {Version16Dot16 version (== #x10000 #x20000 #x25000 #x30000) unused}
{Fixed italicAngle}
{FWORD underlinePosition}
{FWORD underlineThickness}
{uint32 isFixedPitch}
; a bunch of fields ignored here
)
#:tag "post")
(mkcmplx NameRecord
(mkfields {uint16 platformID}
{uint16 encodingID}
{uint16 languageID}
{uint16 nameID}
{uint16 length}
{Offset16 stringOffset}))
(mkcmplx LangTagRecord (mkfields {uint16 length} {Offset16 langTagOffset}))
(mkcmplx TableName
(mkfields {uint16 version (== 0 1)}
{uint16 count}
{Offset16 storageOffset}
{NameRecord nameRecord (count count)}
{uint16 langTagCount (>= version 1)}
{LangTagRecord langTagRecord (count langTagCount) (>= version 1)})
#:tag "name")
(mkcmplx BigGlyphMetrics
(mkfields {uint8 height}
{uint8 width}
{int8 horiBearingX}
{int8 horiBearingY}
{uint8 horiAdvance}
{int8 vertBearingX}
{int8 vertBearingY}
{uint8 vertAdvance}))
(mkcmplx SmallGlyphMetrics
(mkfields {uint8 height} {uint8 width} {int8 bearingX} {int8 bearingY} {uint8 advance}))
(mkcmplx SbitLineMetrics
(mkfields {int8 ascender}
{int8 descender}
{uint8 widthMax}
{int8 caretSlopeNumerator}
{int8 caretSlopeDenumerator}
{int8 caretOffset}
{int8 minOriginSB}
{int8 minAdvanceSB}
{int8 maxBeforeBL}
{int8 minAfterBL}
{int8 pad [2] unused}))
(mkcmplx IndexSubtable1
(mkfields {Offset32 sbitOffsets} #;(count (+ (- lastGlyphIndex firstGlyphIndex) 2))))
(mkcmplx IndexSubtable2 (mkfields {uint32 imageSize} {BigGlyphMetrics bigMetrics}))
; FIXME
(mkcmplx IndexSubtable3
(mkfields {Offset16 sbitOffsets} #;(count (+ (- lastGlyphIndex firstGlyphIndex) 2))))
(mkcmplx GlyphIdOffsetPair (mkfields {uint16 glyphID} {Offset16 sbitOffset}))
(mkcmplx IndexSubtable4
(mkfields {uint32 numGlyphs} {GlyphIdOffsetPair glyphArray (count (+ numGlyphs 1))}))
(mkcmplx IndexSubtable5
(mkfields {uint32 imageSize}
{BigGlyphMetrics bigMetrics}
{uint32 numGlyphs}
{uint16 glyphIdArray (count numGlyphs)}))
(mkcmplx IndexSubtable
(mkfields {uint16 indexFormat (>= 1) (<= 5)}
{uint16 imageFormat}
{Offset32 imageDataOffset}
{IndexSubtable1 sub1 (== indexFormat 1)}
{IndexSubtable2 sub2 (== indexFormat 2)}
{IndexSubtable3 sub3 (== indexFormat 3)}
{IndexSubtable4 sub4 (== indexFormat 4)}
{IndexSubtable5 sub5 (== indexFormat 5)}))
(mkcmplx IndexSubtableRecord
(mkfields {uint16 firstGlyphIndex}
{uint16 lastGlyphIndex}
{Offset32 indexSubtableOffset}
{IndexSubtable indexSubtable (at indexSubtableOffset)}))
(mkcmplx BitmapSize
(mkfields {Offset32 indexSubtableListOffset}
{uint32 indexSubtableListSize}
{uint32 numberOfIndexSubtables}
{uint32 colorRef unused}
{SbitLineMetrics hori}
{SbitLineMetrics vert}
{uint16 startGlyphIndex}
{uint16 endGlyphIndex}
{uint8 ppemX}
{uint8 ppemY}
{uint8 bitDepth}
{int8 flags}
{IndexSubtableRecord
indexSubtableList
(count numberOfIndexSubtables)
(at indexSubtableListOffset)}))
(mkcmplx TableEBDT
(mkfields {uint16 majorVersion (== 2)} {uint16 minorVersion (== 0) unused})
#:tag "EBDT")
(mkcmplx TableEBLC
(mkfields {uint16 majorVersion (== 2) unused}
{uint16 minorVersion (== 0) unused}
{uint32 numSizes}
{BitmapSize bitmapSizes (count numSizes)})
#:tag "EBLC")
(mkcmplx AttachList
(mkfields {Offset16 coverageOffset}
{uint16 glyphCount}
{Offset16 attachPointOffsets (count glyphCount)}))
(mkcmplx AttachPoint (mkfields {uint16 pointCount} {uint16 pointIndices (count pointCount)}))
(mkcmplx LigCaretList
(mkfields {Offset16 coverageOffset}
{uint16 ligGlyphCount}
{Offset16 ligGlyphOffsets (count ligGlyphCount)}))
(mkcmplx LigGlyph (mkfields {uint16 caretCount} {Offset16 caretValueOffsets (count caretCount)}))
(mkcmplx CaretValue
(mkfields {uint16 format (>= 1) (<= 3)}
{int16 coordinate (== format 1 3)}
{uint16 caretValuePointIndex (== format 2)}
{Offset16 deviceOffset (== format 3)}))
(mkcmplx ValueRecord
(mkfields {int16 xPlacement}
{int16 yPlacement}
{int16 xAdvance}
{int16 yAdvance}
{Offset16 xPlaDeviceOffset}
{Offset16 yPlaDeviceOffset}
{Offset16 xAdvDeviceOffset}
{Offset16 yAdvDeviceOffset}))
(mkcmplx SinglePos
(mkfields {uint16 format (== 1 2)}
{Offset16 coverageOffset}
{uint16 valueFormat}
{ValueRecord valueRecord (== format 1)}
{uint16 valueCount (== format 2)}
{ValueRecord valueRecords (== format 2) (count valueCount)}))
(mkcmplx TableGDEF
(mkfields {uint16 majorVersion (== 1) unused}
{uint16 minorVersion (== 0 2 3)}
{Offset16 glyphClassDefOffset}
{Offset16 attachListOffset}
{Offset16 ligCaretListOffset}
{Offset16 markAttachClassDefOffset}
{Offset16 markGlyphSetsDefOffset (>= minorVersion 2)}
{Offset32 itemVarStoreOffset (>= minorVersion 3)})
#:tag "GDEF")
(mkcmplx LangSys
(mkfields {Offset16 lookupOrderOffset unused}
{uint16 requiredFeatureIndex}
{uint16 featureIndexCount}
{uint16 featureIndices (count featureIndexCount)}))
(mkcmplx LangSysRecord
(mkfields {Tag langSysTag} {Offset16 langSysOffset} {LangSys langSys (at langSysOffset)}))
(mkcmplx Script
(mkfields {Offset16 defaultLangSysOffset}
{uint16 langSysCount}
{LangSysRecord langSysRecords (count langSysCount)}
{LangSys defaultLangSys (at defaultLangSysOffset)}))
(mkcmplx ScriptRecord
(mkfields {Tag scriptTag} {Offset16 scriptOffset} {Script script (at scriptOffset)}))
(mkcmplx ScriptList (mkfields {uint16 scriptCount} {ScriptRecord scriptRecords (count scriptCount)}))
(mkcmplx Feature
(mkfields {Offset16 featureParamsOffset}
{uint16 lookupIndexCount}
{uint16 lookupListIndices (count lookupIndexCount)}))
(mkcmplx FeatureRecord
(mkfields {Tag featureTag} {Offset16 featureOffset} {Feature feature (at featureOffset)}))
(mkcmplx FeatureList
(mkfields {uint16 featureCount} {FeatureRecord featureRecords (count featureCount)}))
(mkcmplx Lookup
(mkfields {uint16 lookupType}
{uint16 lookupFlag}
{uint16 subTableCount}
{Offset16 subtableOffsets (count subTableCount)}
{uint16 markFilteringSet}))
(mkcmplx LookupList (mkfields {uint16 lookupCount} {Offset16 lookupOffsets (count lookupCount)}))
(mkcmplx TableGPOS
(mkfields {uint16 majorVersion (== 1) unused}
{uint16 minorVersion (<= 1)}
{Offset16 scriptListOffset}
{Offset16 featureListOffset}
{Offset16 lookupListOffset}
{Offset32 featureVariationsOffset (== minorVersion 1)}
{ScriptList scriptList (at scriptListOffset)}
{FeatureList featureList (at featureListOffset)}
{LookupList lookupList (at lookupListOffset)})
#:tag "GPOS")
(mkcmplx TableGSUB
(mkfields {uint16 majorVersion (== 1) unused}
{uint16 minorVersion (<= 1)}
{Offset16 scriptListOffset}
{Offset16 featureListOffset}
{Offset16 lookupListOffset}
{Offset32 featureVariationsOffset (== minorVersion 1)}
{ScriptList scriptList (at scriptListOffset)}
{FeatureList featureList (at featureListOffset)})
#:tag "GSUB")
(mkcmplx MathValueRecord (mkfields {FWORD value} {Offset16 deviceOffset}))
(mkcmplx MathConstants
(mkfields {int16 scriptPercentScaleDown}
{int16 scriptScriptPercentScaleDown}
{UFWORD delimitedSubFormulaMinHeight}
{UFWORD displayOperatorMinHeight}
{MathValueRecord mathLeading}
{MathValueRecord axisHeight}
{MathValueRecord accentBaseHeight}
{MathValueRecord flattenedAccentBaseHeight}
{MathValueRecord subscriptShiftDown}
{MathValueRecord subscriptTopMax}
{MathValueRecord subscriptBaselineDropMin}
{MathValueRecord superscriptShiftUp}
{MathValueRecord superscriptShiftUpCramped}
{MathValueRecord superscriptBottomMin}
{MathValueRecord superscriptBaselineDropMax}
{MathValueRecord subSuperscriptGapMin}
{MathValueRecord superscriptBottomMaxWithSubscript}
{MathValueRecord spaceAfterScript}
{MathValueRecord upperLimitGapMin}
{MathValueRecord upperLimitBaselineRiseMin}
{MathValueRecord lowerLimitGapMin}
{MathValueRecord lowerLimitBaselineDropMin}
{MathValueRecord stackTopShiftUp}
{MathValueRecord stackTopDisplayStyleShiftUp}
{MathValueRecord stackBottomShiftDown}
{MathValueRecord stackBottomDisplayStyleShiftDown}
{MathValueRecord stackGapMin}
{MathValueRecord stackDisplayStyleGapMin}
{MathValueRecord stretchStackTopShiftUp}
{MathValueRecord stretchStackBottomShiftDown}
{MathValueRecord stretchStackGapAboveMin}
{MathValueRecord stretchStackGapBelowMin}
{MathValueRecord fractionNumeratorShiftUp}
{MathValueRecord fractionNumeratorDisplayStyleShiftUp}
{MathValueRecord fractionDenominatorShiftDown}
{MathValueRecord fractionDenominatorDisplayStyleShiftDown}
{MathValueRecord fractionNumeratorGapMin}
{MathValueRecord fractionNumDisplayStyleGapMin}
{MathValueRecord fractionRuleThickness}
{MathValueRecord fractionDenominatorGapMin}
{MathValueRecord fractionDenomDisplayStyleGapMin}
{MathValueRecord skewedFractionHorizontalGap}
{MathValueRecord skewedFractionVerticalGap}
{MathValueRecord overbarVerticalGap}
{MathValueRecord overbarRuleThickness}
{MathValueRecord overbarExtraAscender}
{MathValueRecord underbarVerticalGap}
{MathValueRecord underbarRuleThickness}
{MathValueRecord underbarExtraDescender}
{MathValueRecord radicalVerticalGap}
{MathValueRecord radicalDisplayStyleVerticalGap}
{MathValueRecord radicalRuleThickness}
{MathValueRecord radicalExtraAscender}
{MathValueRecord radicalKernBeforeDegree}
{MathValueRecord radicalKernAfterDegree}
{int16 radicalDegreeBottomRaisePercent}))
(mkcmplx MathItalicsCorrectionInfo
(mkfields {Offset16 italicsCorrectionCoverageOffset}
{uint16 italicsCorrectionCount}
{MathValueRecord italicsCorrection (count italicsCorrectionCount)}))
(mkcmplx MathTopAccentAttachment
(mkfields {Offset16 topAccentCoverageOffset}
{uint16 topAccentAttachmentCount}
{MathValueRecord topAccentAttachment (count topAccentAttachmentCount)}))
(mkcmplx MathKernInfoRecord
(mkfields {Offset16 topRightMathKernOffset}
{Offset16 topLeftMathKernOffset}
{Offset16 bottomRightMathKernOffset}
{Offset16 bottomLeftMathKernOffset}))
(mkcmplx MathKernInfo
(mkfields {Offset16 mathKernCoverageOffset}
{uint16 mathKernCount}
{MathKernInfoRecord mathKernInfoRecords (count mathKernCount)}))
(mkcmplx MathKern
(mkfields {uint16 heightCount}
{MathValueRecord correctionHeight (count heightCount)}
{MathValueRecord kernValues (count heightCount)}))
(mkcmplx Coverage1 (mkfields {uint16 glyphCount} {uint16 glyphArray (count glyphCount)}))
(mkcmplx RangeRecord (mkfields {uint16 startGlyphID} {uint16 endGlyphID} {uint16 startCoverageIndex}))
(mkcmplx Coverage2 (mkfields {uint16 rangeCount} {RangeRecord rangeRecords (count rangeCount)}))
(mkcmplx
Coverage
(mkfields {uint16 format (== 1 2)} {Coverage1 cov1 (== format 1)} {Coverage2 cov2 (== format 2)}))
(mkcmplx MathVariants
(mkfields {UFWORD minConnectorOverlap}
{Offset16 vertGlyphCoverageOffset}
{Offset16 horizGlyphCoverageOffset}
{uint16 vertGlyphCount}
{uint16 horizGlyphCount}
{Offset16 vertGlyphConstructionOffsets (count vertGlyphCount)}
{Offset16 horizGlyphConstructionOffsets (count horizGlyphCount)}
{Coverage vertGlyphCoverage (at vertGlyphCoverageOffset)}
{Coverage horizGlyphCoverage (at horizGlyphCoverageOffset)}))
(mkcmplx MathGlyphInfo
(mkfields
{Offset16 mathItalicsCorrectionInfoOffset}
{Offset16 mathTopAccentAttachmentOffset}
{Offset16 extendedShapeCoverageOffset} ; FIXME WHERE is this shit defined???
{Offset16 mathKernInfoOffset}
{MathItalicsCorrectionInfo mathItalicsCorrectionInfo (at mathItalicsCorrectionInfoOffset)}
{MathTopAccentAttachment mathTopAccentAttachment (at mathTopAccentAttachmentOffset)}
{MathKernInfo mathKernInfo (at mathKernInfoOffset)}))
(mkcmplx MathGlyphVariantRecord (mkfields {uint16 variantGlyph} {UFWORD advanceMeasurement}))
(mkcmplx GlyphPart
(mkfields {uint16 glyphID}
{UFWORD startConnectorLength}
{UFWORD endConnectorLength}
{UFWORD fullAdvance}
{uint16 partFlags}))
(mkcmplx GlyphAssembly
(mkfields {MathValueRecord italicsCorrection}
{uint16 partCount}
{GlyphPart partRecords (count partCount)}))
(mkcmplx MathGlyphConstruction
(mkfields {Offset16 glyphAssemblyOffset}
{uint16 variantCount}
{MathGlyphVariantRecord mathGlyphVariantRecords (count variantCount)}
{GlyphAssembly glyphAssembly (at glyphAssemblyOffset)}))
(mkcmplx TableMATH
(mkfields {uint16 majorVersion (== 1) unused}
{uint16 minorVersion (== 0) unused}
{Offset16 mathConstantsOffset}
{Offset16 mathGlyphInfoOffset}
{Offset16 mathVariantsOffset}
{MathConstants mathConstants (at mathConstantsOffset)}
{MathGlyphInfo mathGlyphInfo (at mathGlyphInfoOffset)}
{MathVariants mathVariants (at mathVariantsOffset)})
#:tag "MATH")
(mkcmplx TableOS∕2
(mkfields {uint16 version (<= 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}
{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
(mkfields {Tag tableTag} {uint32 checksum unused hex} {Offset32 offset} {uint32 length})
#:extra (list (cons 'field
(list (~a "void *parsed;")
(~a "void (*print)(Biobuf *f, int indent, void *parsed);")))
(cons 'print
(list (~a "if(v->print != nil && v->parsed != nil)")
(~a "\tv->print(f, indent+indentΔ, v->parsed);")))))
(define (c-friendly-name t)
(string-replace (string-trim (string-downcase t)) "/" "∕"))
(define (tagged-tables-fields tagged)
(define (ptr c)
(c-friendly-name (cmplx-tag c)))
(define (case-statement c)
(define tag (cmplx-tag c))
(define (ft t i)
(~a "'" (string-ref t i) "'" (if (< i 3) (~a "<<" (* 8 (- 3 i))) "")))
(define case-tag (~a "(u32int)(" (string-join (map (λ (i) (ft tag i)) (range 4)) "|") ")"))
(list (~a "\tcase " case-tag ":")
(~a "\t\tv->" (ptr c) " = calloc(1, sizeof(" (cmplx-name c) "));")
(~a "\t\tif(read_" (cmplx-name c) "(o, v->" (ptr c) ") < 0){")
(~a "\t\t\tfree(v->" (ptr c) ");")
(~a "\t\t\tgoto err;")
(~a "\t\t}")
(~a "\t\trec->parsed = v->" (ptr c) ";")
(~a "\t\trec->print = (void*)print_" (cmplx-name c) ";")
(~a "\t\tbreak;")))
(list (cons 'field (map (λ (c) (~a (cmplx-name c) " *" (ptr c) ";")) tagged))
(cons 'read
(list (~a "for(int i = 0; i < v->numTables; i++){")
(~a "\tTableRecord *rec = &v->tableRecords[i];")
(~a "\tif(rec->length == 0)") ; skip all empty tables
(~a "\t\tcontinue;")
(~a "\tif(otfpushrange(o, rec->offset, rec->length) < 0)")
(~a "\t\tgoto err;")
(~a "\tswitch(rec->tableTag){")
(map case-statement tagged)
(~a "\t}")
(~a "\tif(otfpoprange(o) < 0)")
(~a "\t\tgoto err;")
(~a "}")))))
(mkcmplx TableDirectory
(mkfields {uint32 sfntVersion (== #x00010000 #x4f54544f) hex}
{uint16 numTables}
{uint16 searchRange}
{uint16 entrySelector}
{uint16 rangeShift}
{TableRecord tableRecords (count numTables)})
#:extra (tagged-tables-fields tagged))
(define (out path f)
(call-with-output-file path
#:exists 'truncate/replace
(λ (p)
(begin
(current-output-port p)
(f)))))
(out "otf.h"
(λ ()
(printf #<<EOF
/* this file is generated. do not modify. */
typedef struct Otf Otf;
#pragma incomplete Otf
EOF
)
(printf (format gen-h))
(printf #<<EOF
extern int indentΔ;
#pragma varargck type "T" s64int
#pragma varargck type "t" u32int
#pragma varargck type "V" u32int
void otfinit(void);
Otf *otfopen(char *path);
void otfclose(Otf *o);
EOF
)))
(out "otf.c"
(λ ()
(printf #<<EOF
/* this file is generated. do not modify. */
#include <u.h>
#include <libc.h>
#include <bio.h>
#include "otf.h"
typedef struct Range Range;
struct Otf {
Biobuf *f;
Range *r;
u8int *buf;
int bufsz;
int off;
};
struct Range {
int start;
int len;
int prevoff;
Range *par;
};
Otf *
otfopen(char *path)
{
Otf *o;
Biobuf *f;
if((f = Bopen(path, OREAD)) == nil)
return nil;
if((o = calloc(1, sizeof(*o))) == nil){
werrstr("no memory");
Bterm(f);
}else{
o->f = f;
}
return o;
}
void
otfclose(Otf *o)
{
if(o == nil)
return;
// FIXME traverse and free everything
free(o);
}
static int
otfpushrange(Otf *o, int off, int len)
{
Range *r;
int x;
r = nil;
if(o->r != nil){
if(len < 0)
len = o->r->len - off;
if(len < 0 || off+len > o->r->len){
werrstr("range overflow (len %d) by %d bytes", len, off+len - o->r->len);
goto err;
}
off += o->r->start;
}else if(len < 0){
len = 0x7fffffff;
}
if((r = malloc(sizeof(*r))) == nil){
werrstr("no memory");
goto err;
}
r->par = o->r;
r->start = off;
r->len = len;
r->prevoff = o->off;
if((x = Bseek(o->f, off, 0)) != off){
werrstr("seek offset: need %d, got %d", off, x);
goto err;
}
o->off = off;
o->r = r;
return 0;
err:
free(r);
return -1;
}
static int
otfpoprange(Otf *o)
{
Range *r;
int x;
r = o->r;
if(r == nil){
werrstr("pop without push");
goto err;
}
if((x = Bseek(o->f, r->prevoff, 0)) != r->prevoff){
werrstr("seek offset: need %d, got %d", r->prevoff, x);
goto err;
}
o->off = r->prevoff;
o->r = r->par;
free(r);
return 0;
err:
return -1;
}
static u8int *
otfreadn(Otf *o, int n)
{
Range *r;
u8int *b;
int x;
r = o->r;
if(r != nil && o->off+n > r->start+r->len){
werrstr("need %d at %d, have %d at %d", n, o->off, r->len, r->start);
goto err;
}
if(n > o->bufsz){
if((b = realloc(o->buf, n)) == nil){
werrstr("no memory");
goto err;
}
o->buf = b;
o->bufsz = n;
}
if((x = Bread(o->f, o->buf, n)) != n){
werrstr("need %d, got %d; off %d", n, x, o->off);
goto err;
}
o->off += n;
return o->buf;
err:
return nil;
}
static int
otfarray(Otf *o, void **arr_, void *fun_, int elsz, int num)
{
int i;
int (*fun)(Otf*, void*);
u8int *arr;
if((arr = calloc(num, elsz)) == nil){
werrstr("no memory");
goto err;
}
fun = fun_;
for(i = 0; i < num; i++){
if(fun(o, arr + i*elsz) < 0)
goto err;
}
*arr_ = arr;
return 0;
err:
free(arr);
return -1;
}
EOF
)
(printf (format (λ (c) (gen-c c #f #f))))
(printf #<<EOF
int indentΔ = 2;
static int
Tfmt(Fmt *f)
{
Tm t;
s64int v = va_arg(f->args, s64int);
return fmtprint(f, "%τ", tmfmt(tmtime(&t, v, nil), nil));
}
static int
Vfmt(Fmt *f)
{
u32int v = va_arg(f->args, u32int);
return fmtprint(f, "%d.%d", v>>16, v&0xffff);
}
static int
tfmt(Fmt *f)
{
u32int v = va_arg(f->args, u32int);
return fmtprint(f, "%c%c%c%c", v>>24, v>>16, v>>8, v>>0);
}
void
otfinit(void)
{
tmfmtinstall();
fmtinstall('V', Vfmt);
fmtinstall('T', Tfmt);
fmtinstall('t', tfmt);
}
EOF
)))