ref: 1e9612c4e55535ffc097e5d44c1b5509ee894e4c
dir: /otf.rkt/
#!/usr/bin/env racket
#lang racket
(require racket/format)
(require racket/generic)
(define types '())
(define cmplxs '())
(define (indent x lst)
(let ([ind (make-string x #\tab)]) (map (λ (str) (string-append ind str)) lst)))
(define (format-lines lst)
(string-join (append lst '("")) "\n"))
(define-generics code (gen-h code) (gen-c code) (c-type code))
(define-struct type (name bits c parse)
#: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)
'())
(define (c-type t)
(type-c t))])
(define-struct field (type name)
#:transparent
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h f)
(list (~a (super-c-type (field-type f)) " " (field-name f) ";")))
(define (gen-c f)
(list (~a "if(read_" (type-name (field-type f)) "(ctx, &v->" (field-name f) ") < 0){")
(~a "\twerror(\"%s: %r\", \"" (field-name f) "\");")
(~a "\tgoto err;")
(~a "}")))])
(struct fieldarr field (count)
#:transparent
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h a)
(list (~a (super-c-type (field-type a)) " *" (field-name a) ";")))
(define (gen-c a)
(list (~a "if(read_array(ctx, &v->"
(field-name a)
", read_"
(super-c-type (field-type a))
", v->"
(fieldarr-count a)
") < 0){")
(~a "\twerror(\"%s: %r\", \"" (field-name a) "\");")
(~a "\tgoto err;")
(~a "}")))])
(define-struct cmplx (name fields tag)
#: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 1 (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)
(flatten (append (list (~a "int") (~a "read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v)") (~a "{"))
(indent 1 (flatten (map super-gen-c (cmplx-fields c))))
(list (~a "\treturn 0;")
(~a "err:")
(~a "\twerrstr(\"%s: %r\", \"" (cmplx-name c) "\");")
(~a "\treturn -1;")
(~a "}")))))
(define (c-type c)
(cmplx-name c))])
(define (autoparse bits ctype)
(λ (b [index 0])
(letrec ([f (λ (index shift)
(let* ([x (- shift 8)] [next (if (positive? x) (~a " | " (f (add1 index) x)) "")])
(~a "(" ctype ")" b "[" index "]<<" x next)))])
(~a "(" (f index bits) ")"))))
(define-syntax mktype
(syntax-rules ()
[(_ typ bits c)
(begin
(define typ (make-type `typ bits `c (autoparse bits `c)))
(set! types (append types (list typ))))]
[(_ typ bits c parse)
(begin
(define typ (make-type `typ bits `typ parse))
(set! types (append types (list typ))))]))
(define-syntax mkcmplx
(syntax-rules ()
[(_ typ fields tag)
(begin
(define typ (make-cmplx `typ fields tag))
(set! cmplxs (append cmplxs (list typ))))]
[(_ typ fields)
(begin
(define typ (make-cmplx `typ fields ""))
(set! cmplxs (append cmplxs (list typ))))]))
(define-syntax mkfields
(syntax-rules ()
[(_ (type name [count])) (list (fieldarr type `name `count))]
[(_ (type name))
(list (field type
`name))]
[(_ x y ...) (append (mkfields x) (mkfields y ...))]))
(define (c-typedef? s)
(string-prefix? s "typedef"))
(define (format f)
(string-join (append (list "/* this file is generated. do not modify. */\n\n")
(map (λ (c) (format-lines (filter c-typedef? (f c)))) cmplxs)
(map (λ (c) (format-lines (filter (negate c-typedef?) (f c)))) cmplxs)
(map (λ (t) (format-lines (f t))) types))
""))
(mktype uint8 8 u8int)
(mktype int8 8 s8int)
(mktype uint16 16 u16int)
(mktype int16 16 s16int)
(mktype uint24 24 u32int)
(mktype uint32 32 u32int)
(mktype int32 32 s32int)
(mktype FWORD 16 s16int)
(mktype UFWORD 16 u16int)
(mktype LONGDATETIME 64 u64int)
(mktype Tag 32 u32int)
(mktype Offset16 16 u16int)
(mktype Offset24 24 u32int)
(mktype Offset32 32 u32int)
(mktype Version16Dot16 32 u32int)
(mktype Fixed 32 float (λ (b index) (~a ((type-parse int32) b index) "/65536.0f")))
(mktype F2DOT14
16
float
(λ (b index) (let ([x (~a ((type-parse int16) b index))]) (~a "(" x ">>14)+(" x "&((1<<14)-1))/16384.0"))))
(mkcmplx TableRecord (mkfields {Tag tableTag} {uint32 checksum} {Offset32 offset} {uint32 length}))
(mkcmplx TableDirectory
(mkfields {uint32 sfntVersion}
{uint16 numTables}
{uint16 searchRange}
{uint16 entrySelector}
{uint16 rangeShift}
{TableRecord tableRecords [numTables]}))
(mkcmplx EncodingRecord (mkfields {uint16 platformID} {uint16 encodingID} {Offset32 subtableOffset}))
(mkcmplx TableCmap (mkfields {uint16 version} {uint16 numTables} {EncodingRecord encodingRecords [numTables]}) "cmap")
(mkcmplx TableHead
(mkfields {uint16 majorVersion}
{uint16 minorVersion}
{Fixed fontRevision}
{uint32 checksumAdjustment}
{uint32 magicNumber}
{uint16 flags}
{uint16 unitsPerEm}
{LONGDATETIME created}
{LONGDATETIME modified}
{int16 xMin}
{int16 yMin}
{int16 xMax}
{int16 yMax}
{uint16 macStyle}
{uint16 lowestRecPPEM}
{int16 fontDirectionHint}
{int16 indexToLocFormat}
{int16 glyphDataFormat})
"head")
(printf (format gen-h))
(printf (format gen-c))