shithub: fnt

--- a/otf.rkt

+++ b/otf.rkt

@@ -10,6 +10,7 @@

 (define types '()) ; base types set

 (define cmplxs '()) ; complex types set

+(define tagged '()) ; complex types set that also have a defined tag

 ; types allowed to be used as index

 (define-for-syntax (type-index? type) (member type '(uint16)))

@@ -17,6 +18,9 @@

 (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 tag/c

+  (make-contract #:name 'tag/c #:first-order (λ (x) (and (string? x) (= 4 (string-length x))))))

 (define/contract (indent lst)

   (-> (listof string?) (listof string?))

   (map (λ (str) (string-append "\t" str)) lst))

@@ -71,7 +75,7 @@

     (if (field-count f)

         (λ (lst)

           (list (~a "for(int i = 0; i < v->" (cadr (field-count f)) "; i++){")

-                (~a "\tfprint(f, \"%s[%d]:\\n\", \"" (field-name f) "\", i);")

+                (~a "\tfprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")

                 (indent lst)

                 (~a "}")))

         identity))

@@ -82,7 +86,7 @@

       (array-loop (list (if (type? t)

                             (~a "fprint(f, \"%*s%s: "

                                 verb

-                                "\\n\", ident, \"\", \""

+                                "\\n\", indent, \"\", \""

                                 (field-name f)

                                 "\", v->"

                                 (field-name f)

@@ -90,7 +94,7 @@

                                 ");")

                             (~a "fprint_"

                                 (cmplx-name t)

-                                "(f, ident+identΔ, &v->"

+                                "(f, indent+indentΔ, &v->"

                                 (field-name f)

                                 array-index

                                 ");"))))))

@@ -158,7 +162,10 @@

           (~a "}"))]

         [#f empty])))])

-(define-struct cmplx (name fields tag)

+(define (filter-extra extra key)

+  (flatten (filter-map (λ (e) (and (eq? (car e) key) (cdr e))) extra)))

+(define-struct cmplx (name fields tag extra)

   #:transparent

   #:methods gen:code

   [(define/generic super-gen-h gen-h)

@@ -167,6 +174,7 @@

      (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))))

+                      (indent (filter-extra (cmplx-extra c) 'field))

                       (list (~a "};")

                             (~a "int read_" (cmplx-name c) "(Ctx *ctx, " (cmplx-name c) " *v);")))))

    (define (gen-c c b index)

@@ -191,6 +199,7 @@

                     (~a "{")

                     (~a "\tu8int *b;"))

               (indent (flatten (map gen-group-c field-groups)))

+              (indent (filter-extra (cmplx-extra c) 'read))

               (list (~a "\treturn 0;")

                     (~a "err:")

                     (~a "\twerrstr(\"%s: %r\", \"" (cmplx-name c) "\");")

@@ -197,9 +206,10 @@

                     (~a "\treturn -1;")

                     (~a "}"))

               (list (~a "void")

-                    (~a "fprint_" (cmplx-name c) "(int f, int ident, " (cmplx-name c) " *v)")

+                    (~a "fprint_" (cmplx-name c) "(int f, int indent, " (cmplx-name c) " *v)")

                     (~a "{")

                     (indent (flatten (map field-fprint-c (cmplx-fields c))))

+                    (indent (filter-extra (cmplx-extra c) 'fprint))

                     (~a "}")))))

    (define (c-type c)

      (cmplx-name c))])

@@ -228,11 +238,14 @@

 (define-syntax (mkcmplx stx)

   (syntax-parse stx

-    [(_ typ:id fields:expr tag:string)

+    [(_ typ:id fields:expr (~optional (~seq #:tag tag)) (~optional (~seq #:extra extra:expr)))

+     #:declare tag (expr/c #'tag/c #:name "table tag")

      #'(begin

-         (define typ (make-cmplx `typ fields tag))

-         (set! cmplxs (append cmplxs (list typ))))]

-    [(_ typ:id fields:expr) #'(mkcmplx typ fields "")]))

+         (define tag- (~? (~@ tag.c) #f))

+         (define typ (make-cmplx `typ fields tag- (~? (~@ extra) empty)))

+         (set! cmplxs (append cmplxs (list typ)))

+         (when tag-

+           (set! tagged (append tagged (list typ)))))]))

 (define-for-syntax fields '())

@@ -300,17 +313,6 @@

           (define x (~a ((type-parse int16) b index)))

           (~a "(" x ">>14)+(" x "&((1<<14)-1))/16384.0")))

-(mkcmplx TableRecord

-         (mkfields {Tag tableTag} {uint32 checksum hex} {Offset32 offset} {uint32 length}))

-(mkcmplx TableDirectory

-         (mkfields {uint32 sfntVersion (= #x00010000 #x4f54544f) hex}

-                   {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}))

@@ -318,7 +320,7 @@

          (mkfields {uint16 version unused (= 0)}

                    {uint16 numTables}

                    {EncodingRecord encodingRecords (count numTables)})

-         "cmap")

+         #:tag "cmap")

 (mkcmplx TableHead

          (mkfields {uint16 majorVersion unused (= 1)}

@@ -339,28 +341,66 @@

                    {int16 fontDirectionHint unused (= -2 -1 0 1 2)}

                    {int16 indexToLocFormat (= 0 1)}

                    {int16 glyphDataFormat unused (= 0)})

-         "head")

+         #:tag "head")

-(define (cmplx-tagged? c)

-  (non-empty-string? (cmplx-tag c)))

+(define record-fields

+  (list (cons 'field

+              (list (~a "void *parsed;") (~a "void (*fprint)(int f, int indent, void *parsed);")))

+        (cons 'fprint

+              (list (~a "if(v->fprint != nil && v->parsed != nil)")

+                    (~a "\tv->fprint(f, indent+indentΔ, v->parsed);")))))

-(printf (format gen-h))

-(printf (~a "\nenum{NumParseTagged = " (count (λ (c) (cmplx-tagged? c)) cmplxs) "};\n"))

-(printf #<<EOF

+(mkcmplx TableRecord

+         (mkfields {Tag tableTag} {uint32 checksum hex} {Offset32 offset} {uint32 length})

+         #:extra record-fields)

-typedef struct ParseTagged ParseTagged;

+(define c-friendly-name identity)

-struct ParseTagged {

-	u32int tag;

-	int (*parse)(Ctx *ctx, void *dest);

-};

+(define (tagged-tables-fields tagged)

+  (define (ptr c)

+    (c-friendly-name (cmplx-tag c)))

+  (define (case-statement c)

+    (define tag (cmplx-tag c))

+    (define (ft t i)

+      (~a "'" (string-ref t i) "'" (if (< i 3) (~a "<<" (* 8 (- 3 i))) "")))

+    (define case-tag (~a "(u32int)(" (string-join (map (λ (i) (ft tag i)) (range 4)) "|") ")"))

+    (list (~a "\tcase " case-tag ":")

+          (~a "\t\tv->" (ptr c) " = malloc(sizeof(" (cmplx-name c) "));")

+          (~a "\t\tif(read_" (cmplx-name c) "(ctx, v->" (ptr c) ") < 0){")

+          (~a "\t\t\twerrstr(\"%s: %r\", \"" tag "\");")

+          (~a "\t\t\tfree(v->" (ptr c) ");")

+          (~a "\t\t\tgoto err;")

+          (~a "\t\t}")

+          (~a "\t\trec->parsed = v->" (ptr c) ";")

+          (~a "\t\trec->fprint = (void*)fprint_" (cmplx-name c) ";")

+          (~a "\t\tbreak;")))

+  (list (cons 'field (map (λ (c) (~a (cmplx-name c) " *" (ptr c) ";")) tagged))

+        (cons 'read

+              (list (~a "for(int i = 0; i < v->numTables; i++){")

+                    (~a "\tTableRecord *rec = &v->tableRecords[i];")

+                    (~a "\tif(rec->length == 0)") ; skip all empty tables

+                    (~a "\t\tcontinue;")

+                    (~a "\tif(ctxpushrange(ctx, rec->offset, rec->length) < 0)")

+                    (~a "\t\tgoto err;")

+                    (~a "\tswitch(rec->tableTag){")

+                    (map case-statement tagged)

+                    (~a "\t}")

+                    (~a "\tctxpoprange(ctx);")

+                    (~a "}")))))

-extern ParseTagged parsetagged[NumParseTagged];

-EOF

-        )

+(mkcmplx TableDirectory

+         (mkfields {uint32 sfntVersion (= #x00010000 #x4f54544f) hex}

+                   {uint16 numTables}

+                   {uint16 searchRange}

+                   {uint16 entrySelector}

+                   {uint16 rangeShift}

+                   {TableRecord tableRecords (count numTables)})

+         #:extra (tagged-tables-fields tagged))

+(printf (format gen-h))

 (printf #<<EOF

-extern int identΔ;

+extern int indentΔ;

 #pragma varargck type "T" s64int

 #pragma varargck type "t" u32int

@@ -371,33 +411,9 @@

 (printf (format (λ (c) (gen-c c #f #f))))

-(define (ft t i)

-  (~a "'" (string-ref t i) "'<<" (* 8 (- 3 i))))

-(printf "ParseTagged parsetagged[NumParseTagged] = {\n")

-(for ([s (in-list (filter-map (λ (c)

-                                (match (cmplx-tag c)

-                                  ["" #f]

-                                  [tag

-                                   (~a "\t{"

-                                       (ft tag 0)

-                                       "|"

-                                       (ft tag 1)

-                                       "|"

-                                       (ft tag 2)

-                                       "|"

-                                       (ft tag 3)

-                                       ", (void*)read_"

-                                       (cmplx-name c)

-                                       "},\n")]))

-                              cmplxs))])

-  (printf s))

-(printf "};\n")

 (printf #<<EOF

-int identΔ = 2;

+int indentΔ = 2;

 static int

 Tfmt(Fmt *f)

@@ -429,5 +445,6 @@

 	fmtinstall('T', Tfmt);

 	fmtinstall('t', tfmt);

EOF

--- a/test.c

+++ b/test.c

@@ -9,6 +9,24 @@

 	Biobuf *f;

};

+int

+ctxpushrange(Ctx *ctx, int offset, int len)

+{

+	int r;

+	USED(len);

+	if((r = Bseek(ctx->f, offset, 0)) != offset){

+		werrstr("seek offset: need %d, got %d", offset, r);

+		return -1;

+	}

+	return 0;

+}

+void

+ctxpoprange(Ctx *ctx)

+{

+	Bseek(ctx->f, 0, 0);

+}

 u8int *

 ctxreadn(Ctx *ctx, int n)