ref: 9fa76896ce8ec96f3f6e76a0b23732be660b71bb
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
; types allowed to be used as index
(define-for-syntax (type-index? type) (member type '(uint16)))
(define size-in-bits/c
(make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 40 48 64)))))
(define tag/c
(make-contract #:name 'tag/c #:first-order (λ (x) (and (string? x) (= 4 (string-length x))))))
(define/contract (indent lst)
(-> (listof string?) (listof string?))
(map (λ (str) (string-append "\t" str)) 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 "/* this file is generated. do not modify. */\n" 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 (field-unused? f)
(assoc 'unused (field-attrs f)))
(define (field-count f)
(assoc 'count (field-attrs f)))
(define (field-test f)
(filter (λ (t) (eq? (car t) 'test)) (field-attrs f)))
(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))
(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 "fprint(f, \"%*s%s[%d]: "
verb
"\\n\", indent, \"\", \""
(field-name f)
"\", i, v->"
(field-name f)
array-index
");")
(~a "fprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
(define array-loop
(if count
(λ (lst)
(block (~a "for(int i = 0; i < " (if fixed-array "" "v->") (cadr count) "; i++)")
(indent (list* fprint-index (if fixed-array empty lst)))))
identity))
(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 (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 (and cnt (number? (cadr cnt))))
(list (~a (if (field-unused? f) "// " "")
(super-c-type (field-type 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)
(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)
(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
#: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_"
(super-c-type (field-type f))
", sizeof("
(super-c-type (field-type f))
"), v->"
(cadr 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))
(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 (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 "struct " (cmplx-name c) " {"))
(indent (flatten (map super-gen-h (cmplx-fields c))))
(indent (filter-extra (cmplx-extra c) 'field))
(list (~a "};")
(~a "int read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v);")))))
(define (gen-c c b index)
; 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 (field-size (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) (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 (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 "void")
(~a "fprint_" (cmplx-name c) "(int f, int indent, " (cmplx-name c) " *v)")
(~a "{")
(indent (flatten (map field-fprint-c (cmplx-fields c))))
(indent (filter-extra (cmplx-extra c) 'fprint))
(~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)))))]))
(define-for-syntax fields '())
(define-syntax (mkattr stx)
(syntax-parse stx
[(_ (n:number)) #''(count n)]
[(_ {~literal hex}) #''(verb "%#ux")]
[(_ (p:expr vs:number ...+)) #''(test p vs ...)]
[(_ (p:expr ref:id n:number))
#''(cond
p
ref
n)]
[(_ ({~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 unused}) #''(unused #t)]))
(define-syntax (mkfield stx)
(syntax-parse stx
[(_ type:id name:id attrs ...)
(begin
(let ([f #'(field type
`name
(list (mkattr [~@ attrs]) ...))])
(begin
(set! fields (append fields (list (syntax->datum #'(name type)))))
f)))]))
(define-syntax (mkfields stx)
(syntax-parse stx
[(_ x ...+)
(begin
(set! fields '())
#'(list (mkfield [~@ . x]) ...))]))
(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")))
(mkcmplx EncodingRecord
(mkfields {uint16 platformID (<= 4)} {uint16 encodingID} {Offset32 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}
{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 TableMaxp
(mkfields {Version16Dot16 version (= #x05000 #x10000) hex}
{uint16 numGlyphs} ; FIXME there are more fields here, depending on the version
)
#:tag "maxp")
(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 (*fprint)(int f, int indent, void *parsed);")))
(cons 'fprint
(list (~a "if(v->fprint != nil && v->parsed != nil)")
(~a "\tv->fprint(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) " = malloc(sizeof(" (cmplx-name c) "));")
(~a "\t\tif(read_" (cmplx-name c) "(ctx, v->" (ptr c) ") < 0){")
(~a "\t\t\twerrstr(\"%s: %r\", \"" tag "\");")
(~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->fprint = (void*)fprint_" (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(ctxpushrange(ctx, rec->offset, rec->length) < 0)")
(~a "\t\tgoto err;")
(~a "\tswitch(rec->tableTag){")
(map case-statement tagged)
(~a "\t}")
(~a "\tctxpoprange(ctx);")
(~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))
(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);
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
)