ref: 600f28654b5823df16698863c2ff390326f284aa
dir: /otf.rkt/
#!/usr/bin/env racket
#lang racket
(require (for-syntax racket/format))
(require (for-syntax syntax/parse))
(require racket/generic)
(define types '())
(define cmplxs '())
(define (indent lst)
(map (λ (str) (string-append "\t" str)) lst))
(define (c-typedef? s)
(string-prefix? s "typedef"))
(define (format f)
(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) (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 unused)
#:transparent
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h f)
(list (~a (if (field-unused f) "// unused " "")
(super-c-type (field-type f))
" "
(field-name f)
";")))
(define (gen-c f)
(list (if (field-unused f)
(~a "if(skip(ctx, " (/ (type-bits (field-type f)) 8) ") < 0){")
(~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 (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 (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-for-syntax (autoparse bits ctype)
(λ (b [index 0])
(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 (<= bits 32) cast "") "(" (f index bits) ")")))
(define-syntax (mktype stx)
(syntax-parse stx
[(_ typ:id bits:nat c:id) #'(mktype typ bits c #'(autoparse bits c))]
[(_ typ:id bits:nat c:id parse:expr)
#'(begin
(define typ (make-type `typ bits `typ parse))
(set! types (append types (list typ))))]))
(define-syntax (mkcmplx stx)
(syntax-parse stx
[(_ typ:id fields:expr tag:string)
#'(begin
(define typ (make-cmplx `typ fields tag))
(set! cmplxs (append cmplxs (list typ))))]
[(_ typ:id fields:expr) #'(mkcmplx typ fields "")]))
(define-syntax (mkfield stx)
(syntax-parse stx
[(_ {~literal unused} type:id name:id)
#'(field type
`name
#t)]
[(_ type:id name:id [count:id]) #'(fieldarr type `name #f `count)]
[(_ type:id name:id)
#'(field type
`name
#f)]))
(define-syntax (mkfields stx)
(syntax-parse stx
[(_ x ...) #'(list (mkfield {~@ . x}) ...)]))
(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)
(define 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}
{unused LONGDATETIME created}
{unused 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))