ref: 62d35d45d158769cefe5545c1fa5c46643cbe9ad
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
; 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/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) ; generates code for the C source file
(c-type code)) ; type name to be used in C
(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/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-ptr f)
(if (field-count f) "*" ""))
(define-struct field (type name attrs)
#: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-ptr f)
(field-name f)
";")))
(define (gen-c f)
(define (size t)
(if (type? t) (type-size t) 0))
(define (name t)
(if (type? t) (type-name t) (cmplx-name t)))
(list (match (field-count f)
[#f
(if (field-unused? f)
(~a "if(skip_bytes(ctx, " (size (field-type f)) ") < 0){")
(~a "if(read_" (name (field-type f)) "(ctx, &v->" (field-name f) ") < 0){"))]
[count
(~a "if(read_array(ctx, &v->"
(field-name f)
", read_"
(super-c-type (field-type f))
", v->"
(cadr count)
") < 0){")])
(~a "\twerror(\"%s: %r\", \"" (field-name f) "\");")
(~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))])
(begin-for-syntax
(define/contract (autoparse bits ctype)
(-> positive? symbol? (listof string?))
(λ (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 c:id parse:expr)
#:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
#'(begin
(define typ (make-type `typ bits.c `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-for-syntax fields '())
(define-syntax (mkattr stx)
(syntax-parse stx
[(_ ({~literal =} vs:number ...+)) #''(= 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 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)
(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 (= #x000100000 #x4f54544f)}
{uint16 numTables}
{uint16 searchRange}
{uint16 entrySelector}
{uint16 rangeShift}
{TableRecord tableRecords (count numTables)}))
(mkcmplx EncodingRecord
(mkfields {uint16 platformID (= 0 1 2 3 4)} {uint16 encodingID} {Offset32 subtableOffset}))
(mkcmplx TableCmap
(mkfields {uint16 version (= 0)}
{uint16 numTables}
{EncodingRecord encodingRecords (count numTables)})
"cmap")
(mkcmplx TableHead
(mkfields {uint16 majorVersion (= 1)}
{uint16 minorVersion (= 0)}
{Fixed fontRevision}
{uint32 checksumAdjustment}
{uint32 magicNumber (= #x5f0f3cf5)}
{uint16 flags}
{uint16 unitsPerEm}
{LONGDATETIME created unused}
{LONGDATETIME modified unused}
{int16 xMin}
{int16 yMin}
{int16 xMax}
{int16 yMax}
{uint16 macStyle}
{uint16 lowestRecPPEM}
{int16 fontDirectionHint unused (= -2 -1 0 1 2)}
{int16 indexToLocFormat (= 0 1)}
{int16 glyphDataFormat (= 0)})
"head")
(printf (format gen-h))
(printf (format gen-c))