ref: d5c519ab9f221b899180a0def079c64888c82af6
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 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 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-ptr f)
(if (field-count f) "*" ""))
(define (field-values f)
(assoc '= (field-attrs 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) "// " "")
(super-c-type (field-type f))
" "
(field-ptr f)
(field-name f)
";")))
(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) (field-values 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
(~a "if(read_array(ctx, &"
ref
", read_"
(super-c-type (field-type f))
", v->"
(cadr count)
") < 0){")]))
(list*
(parse-if-error #t)
(if index
empty
(list (~a "\twerror(\"%s: %r\", \"" (field-name f) "\");") (~a "\tgoto err;") (~a "}")))
(match (field-values f)
[(list '= a ...)
(list
(~a "if(" (string-join (map (λ (v) (~a ref " != " (format-number v))) a) " && ") "){")
(~a "\twerror(\"%s: invalid value: %d\", \"" (field-name f) "\", " ref ");")
(~a "\tgoto err;")
(~a "}"))]
[#f empty])))])
(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 b index)
(define field-groups (group-by (λ (f) (cmplx? (field-type f))) (cmplx-fields c)))
(define (parse-group g)
(define (p fs index)
(if (pair? fs)
(cons (super-gen-c (car fs) "b" index)
(p (cdr fs) (+ index (type-size (field-type (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) (type-size (field-type f))) fields))])
(list* (~a "if((b = ctxreadn(ctx, " sum ")) == nil)")
(~a "\tgoto err;")
(parse-group fields)))))
(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 field-groups)))
(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/contract (autoparse bits ctype)
(-> positive? symbol? procedure?)
(λ (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))
(f index bits)))
(define-syntax (mktype stx)
(syntax-parse stx
[(_ typ:id bits c:id)
#'(begin
(define parse (autoparse bits `c))
(mktype typ bits c parse))]
[(_ 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 `c 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 unused (= 0)}
{uint16 numTables}
{EncodingRecord encodingRecords (count numTables)})
"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 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 unused (= 0)})
"head")
(printf (format gen-h))
(printf (format (λ (c) (gen-c c #f #f))))