ref: 032f6a6361e18b6f47e9e8fe5d8267c43bd6b2dd
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Mon May 27 21:24:35 EDT 2024
the very little basics
--- /dev/null
+++ b/README.md
@@ -1,0 +1,7 @@
+# fnt
+
+WIP.
+
+A try-out project of generating a parser of [OpenType](https://en.wikipedia.org/wiki/OpenType) in C
+from [human-readable specifications](https://learn.microsoft.com/en-us/typography/opentype/spec/otff)
+with as little/small declarative definitions as possible.
--- /dev/null
+++ b/otf.rkt
@@ -1,0 +1,202 @@
+#!/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)
+ (letrec ([f (λ (index shift)
+ (let ([x (- shift 8)])
+ (~a "("ctype")"b"["index"]<<"x (if (positive? x)+ (~a " | " (f (add1 index) x))
+ ""))))])
+ (~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))