ref: 0ce46014a12024d7a7815916b84b96011e7138a1
parent: 63f6a9277db89582f0a247e55e781f8c64871ed0
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Thu Jun 20 18:17:40 EDT 2024
split definitions out into otf.rkt
--- /dev/null
+++ b/gen.rkt
@@ -1,0 +1,694 @@
+#!/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
+(define tagged '()) ; complex types set that also have a defined tag
+
+(define size-in-bits/c
+ (make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 64)))))
+
+(define tag/c
+ (make-contract #:name 'tag/c #:first-order (λ (x) (and (string? x) (= 4 (string-length x))))))
+
+(define/contract (indent lst)
+ (-> (listof any/c) (listof string?))
+ (map (λ (str) (string-append "\t" str)) (flatten 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 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 verb 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 (block stmt lst)
+ (if (= (length lst) 1) (list* stmt lst) (list (string-append stmt "{") lst "}")))+
+(define (wrap-cond-c cond lst)
+ (match cond
+ [#f lst]
+ [(list op ref n ...)
+ (block (~a "if(" (string-join (map (λ (n) (~a "v->" ref " " op " " n)) n) " || ") ")")+ (indent lst))]))
+
+(define (invert-c op)
+ (match op
+ ['== '!=]
+ ['<= '>]
+ ['>= '<]
+ ['< '>=]
+ ['> '<=]))
+
+(define-struct field (type name attrs)
+ #:transparent
+ #:methods gen:code
+ [(define/generic super-c-type c-type)
+ (define (gen-h f)
+ (define cnt (field-count f))
+ (define fixed-array (number? cnt))
+ (define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
+ (list (~a (if (field-unused? f) "// " "")
+ (super-c-type (field-type f))
+ " "
+ (if (or is-ptr (and cnt (not fixed-array))) "*" "")
+ (field-name f)
+ (if fixed-array (~a "[" cnt "];") ";"))))
+ (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) (not (empty? (field-test f)))))
+ (define (format-number x)
+ (if (<= x 32768) (~r x) (~r x #:base 16 #:sign '("0x" "" "-0x"))))+ (define (parse-if-error read)
+ (define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
+ (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 ";")
+ (if is-ptr (~a ref " = calloc(1, sizeof(*" ref "));") empty))
+ (~a "if(read_" (name (field-type f)) "(o, " (if is-ptr "" "&") ref ") < 0){")))+ (if index empty (~a "if(otfreadn(o, " (size (field-type f)) ") == nil){")))]+ [count
+ #:when (type? (field-type f))
+ (if (field-unused? f)
+ empty
+ (list (if (number? count) empty (~a ref " = malloc(" count "*sizeof(*" ref "));"))+ (~a "for(int i = 0; i < " count "; i++)")
+ (~a "\t"
+ ref
+ "[i] = "
+ ((type-parse (field-type f)) b index (~a "i*" (size (field-type f))))
+ ";")))]
+ [count
+ (~a "if(otfarray(o, &"
+ ref
+ ", read_"
+ (super-c-type (field-type f))
+ ", sizeof("+ (super-c-type (field-type f))
+ "), "
+ count
+ ") < 0){")]))+ (define (test-cond ts)
+ (map (λ (t)
+ (match t
+ [(list 'test op a ...)
+ (string-join (map (λ (v) (~a ref " " (invert-c op) " " (format-number v))) a)
+ " && ")]))
+ ts))
+ (define (at lst)
+ (define at (field-offset f))
+ (if (not at)
+ lst
+ (list (~a "if(v->" at " != 0){")+ (~a "\tif(otfpushrange(o, v->" at ", -1) < 0)")
+ (~a "\t\tgoto err;")
+ (indent lst)
+ (~a "\tif(otfpoprange(o) < 0)")
+ (~a "\t\tgoto err;")
+ (~a "}"))))
+ (at (list* (parse-if-error #t)
+ (if index
+ empty
+ (list (~a "\twerrstr(\"%s: %r\", \"" (field-name f) "\");")
+ (~a "\tgoto err;")
+ (~a "}")))
+ (match (test-cond (field-test f))
+ [(list) empty]
+ [(list a ...)
+ (list (~a "if(" (string-join a " || ") "){")+ (~a "\twerrstr(\"%s: invalid value: %d (0x%ux)\", \""
+ (field-name f)
+ "\", "
+ ref
+ ", "
+ ref
+ ");")
+ (~a "\tgoto err;")
+ (~a "}"))]))))])
+
+(define/contract (field-attr f a)
+ (-> field? symbol? any)
+ (define v (assoc a (field-attrs f)))
+ (and v (cadr v)))
+
+(define (field-unused? f)
+ (field-attr f 'unused))
+
+(define (field-verb f)
+ (field-attr f 'verb))
+
+(define (field-offset f)
+ (field-attr f 'at))
+
+(define (field-cond f)
+ (define v (assoc 'cond (field-attrs f)))
+ (and v (rest v)))
+
+(define/contract (field-count f)
+ (-> field? (or/c false/c number? string?))
+ (define (fmt-expr e)
+ (cond
+ [(number? e) e]
+ [(list? e)
+ (match e
+ [(list op x y) (~a (fmt-expr x) op (fmt-expr y))])]
+ [(symbol? e) (~a "v->" e)]))
+ (define e (field-attr f 'count))
+ (and e (fmt-expr e)))
+
+(define (field-test f)
+ (filter (λ (t) (eq? (car t) 'test)) (field-attrs f)))
+
+(define (field-print-c f)
+ (define t (field-type f))
+ (define cnt (field-count f))
+ (define basic-array (and cnt (type? t)))
+ (define fixed-array (and basic-array (number? cnt)))
+ (define array-index (if cnt "[i]" ""))
+ (define verb (if (type? t) (or (field-verb f) (type-verb t)) ""))
+ (define print-index
+ (if basic-array
+ (~a "Bprint(f, \"%*s%s[%d]: "
+ verb
+ "\\n\", indent, \"\", \""
+ (field-name f)
+ "\", i, v->"
+ (field-name f)
+ array-index
+ ");")
+ (~a "Bprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
+ (define array-loop
+ (if cnt
+ (λ (lst)
+ (block (~a "for(int i = 0; i < " cnt "; i++)")
+ (indent (list* print-index (if basic-array empty lst)))))
+ identity))
+ (define is-ptr (and (cmplx? t) (field-offset f) (not cnt)))
+ (define lst
+ (flatten
+ (list
+ (if (type? t)
+ (~a "Bprint(f, \"%*s%s: "
+ verb
+ "\\n\", indent, \"\", \""
+ (field-name f)
+ "\", v->"
+ (field-name f)
+ array-index
+ ");")
+ (list (if cnt empty (~a "Bprint(f, \"%*s%s:\\n\", indent, \"\", \"" (field-name f) "\");"))
+ (if is-ptr (~a "if(v->" (field-name f) " != nil)") empty)
+ (~a (if is-ptr "\t" "")
+ "print_"
+ (cmplx-name t)
+ "(f, indent+indentΔ, "
+ (if is-ptr "" "&")
+ "v->"
+ (field-name f)
+ array-index
+ ");"))))))
+ (if (field-unused? f) empty (wrap-cond-c (field-cond f) (array-loop lst))))
+
+(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)
+ (define/generic super-gen-c gen-c)
+ (define (gen-h c)
+ (flatten
+ (append
+ (list (~a "typedef struct " (cmplx-name c) " " (cmplx-name c) ";")
+ (~a "")
+ (~a "struct " (cmplx-name c) " {"))+ (indent (map super-gen-h (cmplx-fields c)))
+ (indent (filter-extra (cmplx-extra c) 'field))
+ (list (~a "};")
+ (~a "")
+ (~a "int read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v);")
+ (~a "void print_" (cmplx-name c) "(Biobuf *f, int indent, " (cmplx-name c) " *v);")))))
+ (define (gen-c c b index)
+ (define (no-vla? f)
+ (define cnt (field-count f))
+ (or (not cnt) (number? cnt)))
+ ; group fields to minimize number of reads
+ ; complex types are always alone
+ ; simple types can be combined unless versioned
+ ; versioned simple types are combined if the check is the same
+ (define (group-fields fields)
+ (define (combine? f g)
+ (or (empty? g)
+ (and (type? (field-type f))
+ (type? (field-type (car g)))
+ (no-vla? f)
+ (no-vla? (car g))
+ (equal? (field-cond f) (field-cond (car g))))))
+ (define (group- g fields)
+ (match fields
+ [(list-rest f tail)
+ (if (combine? f g) (group- (cons f g) tail) (cons (reverse g) (group- (list f) tail)))]
+ [_ (list (reverse g))]))
+ (group- empty fields))
+ (define (field-size f)
+ (match (field-count f)
+ [#f (type-size (field-type f))]
+ [count
+ #:when (type? (field-type f))
+ ((if (number? count) (λ (sz) (* count sz)) (λ (sz) (~a count "*" sz)))
+ (type-size (field-type f)))]))
+ (define (add x y)
+ (match (list x y)
+ [(list _ 0) x]
+ [(list 0 _) y]
+ [_ (if (and (number? x) (number? y)) (+ x y) (~a x "+" y))]))
+ (define (parse-group g)
+ (define (p fs index)
+ (if (pair? fs)
+ (cons (super-gen-c (car fs) "b" index) (p (cdr fs) (add index (field-size (car fs)))))
+ empty))
+ (p g 0))
+ (define (gen-group-c fields)
+ (define unused (andmap field-unused? fields))
+ (wrap-cond-c (field-cond (car fields))
+ (if (cmplx? (field-type (car fields)))
+ (map (λ (f) (super-gen-c f #f #f)) fields)
+ (let* ([sum (foldr (λ (f accu) (add (field-size f) accu)) 0 fields)]
+ [lst (flatten (list* (~a "if((b = otfreadn(o, " sum ")) == nil)")
+ (~a "\tgoto err;")
+ (if unused "USED(b);" empty)
+ (parse-group fields)))])
+ lst))))
+ (flatten
+ (append (list (~a "")
+ (~a "int")
+ (~a "read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v)")
+ (~a "{")+ (~a "\tu8int *b;"))
+ (indent (map gen-group-c (group-fields (cmplx-fields c))))
+ (indent (filter-extra (cmplx-extra c) 'read))
+ (list (~a "\treturn 0;")
+ (~a "err:")
+ (~a "\twerrstr(\"%s: %r\", \"" (cmplx-name c) "\");")
+ (~a "\treturn -1;")
+ (~a "}"))
+ (list (~a "")
+ (~a "void")
+ (~a "print_" (cmplx-name c) "(Biobuf *f, int indent, " (cmplx-name c) " *v)")
+ (~a "{")+ (indent (map field-print-c (cmplx-fields c)))
+ (indent (filter-extra (cmplx-extra c) 'print))
+ (~a "}")))))
+ (define (c-type c)
+ (cmplx-name c))])
+
+(define/contract (autoparse bits ctype)
+ (-> positive? symbol? procedure?)
+ (λ (b [index 0] [offset #f])
+ (define off (if offset (~a "+" offset) ""))
+ (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 off "]" tail))
+ (f index bits)))
+
+(define-for-syntax typenames '())
+
+(define-syntax (mktype stx)
+ (syntax-parse stx
+ [(_ typ:id bits c:id verb:string) #'(mktype typ bits c verb (autoparse bits `c))]
+ [(_ typ:id bits c:id verb:string parse:expr)
+ #:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
+ (begin
+ (set! typenames (cons (syntax-e #`typ) typenames))
+ #'(begin
+ (define typ (make-type `typ bits.c `c verb parse))
+ (set! types (append types (list typ)))))]))
+
+(define-syntax (mkcmplx stx)
+ (syntax-parse stx
+ [(_ typ:id fields:expr ...+ (~optional (~seq #:tag tag)) (~optional (~seq #:extra extra:expr)))
+ #:declare tag (expr/c #'tag/c #:name "table tag")
+ (begin
+ (set! typenames (cons (syntax-e #`typ) typenames))
+ #'(begin
+ (define tag- (~? (~@ tag.c) #f))
+ (define typ (make-cmplx `typ (mkfields [~@ fields] ...) tag- (~? (~@ extra) empty)))
+ (set! cmplxs (append cmplxs (list typ)))
+ (when tag-
+ (set! tagged (append tagged (list typ))))))]))
+
+(define-for-syntax fields '())
+
+(define-syntax (mkattr stx)
+ (define-syntax-class compop
+ #:description "comparison operator"
+ (pattern op:id
+ #:when (member (syntax-e #'op) '(== != < > <= >=))))
+
+ (define-syntax-class arithop
+ #:description "arithmetical operator"
+ (pattern op:id
+ #:when (member (syntax-e #'op) '(+ - / *))))
+
+ (define-syntax-class ref
+ #:description "field reference"
+ (pattern ref:id
+ #:fail-when (not (assoc (syntax-e #'ref) fields)) "no such field"
+ #:with type (cadr (assoc (syntax-e #'ref) fields))))
+
+ (syntax-parse stx
+ [(_ _ ({~literal at} ref:ref))+ #:fail-when (not (type-offset? (syntax-e #'ref.type))) "can't be used as an offset"
+ #''(at ref)]
+ [(_ type {~literal hex})+ #:fail-when (not (type-number? (syntax-e #'type))) "not a number type"
+ #''(verb "%#ux")]
+ [(_ type (p:compop vs:number ...+))
+ #:fail-when (not (type-comparable? (syntax-e #'type))) "type can't be used in a comparison"
+ #''(test p vs ...)]
+ [(_ _ (p:compop ref:ref vs:number ...+))
+ #''(cond
+ p
+ ref
+ vs ...)]
+ [(_ _ {~literal unused}) #''(unused #t)]+ [(_ _ (ref:ref))
+ #:fail-when (not (type-index? (syntax-e #'ref.type))) "can't be used as index to an array"
+ #''(count ref)]
+ [(_ _ (n:number)) #''(count n)]
+ [(_ _ (p:arithop e:expr ...+)) #''(count (p e ...))])) ; FIXME - check fields and ops/numbers
+
+(define-syntax (mkfield stx)
+ (define-syntax-class name
+ #:description "field name"
+ (pattern name:id
+ #:fail-when (assoc (syntax-e #'name) fields) "duplicate field name"))
+
+ (define-syntax-class type
+ #:description "field type"
+ (pattern type:id
+ #:fail-when (not (member (syntax-e #'type) typenames)) "unknown field type"))
+
+ (syntax-parse stx
+ [(_ type:type name:name attrs ...)
+ (begin
+ (set! fields (cons (syntax->datum #'(name type)) fields))
+ #'(field type
+ `name
+ (list (mkattr type [~@ attrs]) ...)))]))
+
+(define-syntax (mkfields stx)
+ (syntax-parse stx
+ [(_ x ...+)
+ (begin
+ (set! fields '())
+ #'(list (mkfield [~@ . x]) ...))]))
+
+(require racket/include)
+(include "otf.rkt")
+
+(define (out path f)
+ (call-with-output-file path
+ #:exists 'truncate/replace
+ (λ (p)
+ (begin
+ (current-output-port p)
+ (f)))))
+
+(out "otf.h"
+ (λ ()
+ (printf #<<EOF
+/* this file is generated. do not modify. */
+typedef struct Otf Otf;
+#pragma incomplete Otf
+
+EOF
+ )
+ (printf (format gen-h))
+ (printf #<<EOF
+
+extern int indentΔ;
+
+#pragma varargck type "T" s64int
+#pragma varargck type "t" u32int
+#pragma varargck type "V" u32int
+
+void otfinit(void);
+Otf *otfopen(char *path);
+void otfclose(Otf *o);
+
+EOF
+ )))
+
+(out "otf.c"
+ (λ ()
+ (printf #<<EOF
+/* this file is generated. do not modify. */
+#include <u.h>
+#include <libc.h>
+#include <bio.h>
+#include "otf.h"
+
+typedef struct Range Range;
+
+struct Otf {+ Biobuf *f;
+ Range *r;
+ u8int *buf;
+ int bufsz;
+ int off;
+};
+
+struct Range {+ int start;
+ int len;
+ int prevoff;
+ Range *par;
+};
+
+Otf *
+otfopen(char *path)
+{+ Otf *o;
+ Biobuf *f;
+
+ if((f = Bopen(path, OREAD)) == nil)
+ return nil;
+ if((o = calloc(1, sizeof(*o))) == nil){+ werrstr("no memory");+ Bterm(f);
+ }else{+ o->f = f;
+ }
+ return o;
+}
+
+void
+otfclose(Otf *o)
+{+ if(o == nil)
+ return;
+ // FIXME traverse and free everything
+ free(o);
+}
+
+static int
+otfpushrange(Otf *o, int off, int len)
+{+ Range *r;
+ int x;
+
+ r = nil;
+ if(o->r != nil){+ if(len < 0)
+ len = o->r->len - off;
+ if(len < 0 || off+len > o->r->len){+ werrstr("range overflow (len %d) by %d bytes", len, off+len - o->r->len);+ goto err;
+ }
+ off += o->r->start;
+ }else if(len < 0){+ len = 0x7fffffff;
+ }
+ if((r = malloc(sizeof(*r))) == nil){+ werrstr("no memory");+ goto err;
+ }
+ r->par = o->r;
+ r->start = off;
+ r->len = len;
+ r->prevoff = o->off;
+ if((x = Bseek(o->f, off, 0)) != off){+ werrstr("seek offset: need %d, got %d", off, x);+ goto err;
+ }
+ o->off = off;
+ o->r = r;
+ return 0;
+err:
+ free(r);
+ return -1;
+}
+
+static int
+otfpoprange(Otf *o)
+{+ Range *r;
+ int x;
+
+ r = o->r;
+ if(r == nil){+ werrstr("pop without push");+ goto err;
+ }
+ if((x = Bseek(o->f, r->prevoff, 0)) != r->prevoff){+ werrstr("seek offset: need %d, got %d", r->prevoff, x);+ goto err;
+ }
+ o->off = r->prevoff;
+ o->r = r->par;
+ free(r);
+ return 0;
+err:
+ return -1;
+}
+
+static u8int *
+otfreadn(Otf *o, int n)
+{+ Range *r;
+ u8int *b;
+ int x;
+
+ r = o->r;
+ if(r != nil && o->off+n > r->start+r->len){+ werrstr("need %d at %d, have %d at %d", n, o->off, r->len, r->start);+ goto err;
+ }
+ if(n > o->bufsz){+ if((b = realloc(o->buf, n)) == nil){+ werrstr("no memory");+ goto err;
+ }
+ o->buf = b;
+ o->bufsz = n;
+ }
+ if((x = Bread(o->f, o->buf, n)) != n){+ werrstr("need %d, got %d; off %d", n, x, o->off);+ goto err;
+ }
+ o->off += n;
+
+ return o->buf;
+err:
+ return nil;
+}
+
+static int
+otfarray(Otf *o, void **arr_, void *fun_, int elsz, int num)
+{+ int i;
+ int (*fun)(Otf*, void*);
+ u8int *arr;
+
+ if((arr = calloc(num, elsz)) == nil){+ werrstr("no memory");+ goto err;
+ }
+ fun = fun_;
+ for(i = 0; i < num; i++){+ if(fun(o, arr + i*elsz) < 0)
+ goto err;
+ }
+ *arr_ = arr;
+ return 0;
+err:
+ free(arr);
+ return -1;
+}
+
+EOF
+ )
+ (printf (format (λ (c) (gen-c c #f #f))))
+ (printf #<<EOF
+
+int indentΔ = 2;
+
+static int
+Tfmt(Fmt *f)
+{+ Tm t;
+ s64int v = va_arg(f->args, s64int);
+ return fmtprint(f, "%τ", tmfmt(tmtime(&t, v, nil), nil));
+}
+
+static int
+Vfmt(Fmt *f)
+{+ u32int v = va_arg(f->args, u32int);
+ return fmtprint(f, "%d.%d", v>>16, v&0xffff);
+}
+
+static int
+tfmt(Fmt *f)
+{+ u32int v = va_arg(f->args, u32int);
+ return fmtprint(f, "%c%c%c%c", v>>24, v>>16, v>>8, v>>0);
+}
+
+void
+otfinit(void)
+{+ tmfmtinstall();
+ fmtinstall('V', Vfmt);+ fmtinstall('T', Tfmt);+ fmtinstall('t', tfmt);+}
+
+EOF
+ )))
--- a/otf.c
+++ b/otf.c
@@ -3088,6 +3088,17 @@
if(otfpoprange(o) < 0)
goto err;
}
+ if(v->extendedShapeCoverageOffset != 0){+ if(otfpushrange(o, v->extendedShapeCoverageOffset, -1) < 0)
+ goto err;
+ v->extendedShapeCoverage = calloc(1, sizeof(*v->extendedShapeCoverage));
+ if(read_Coverage(o, v->extendedShapeCoverage) < 0){+ werrstr("%s: %r", "extendedShapeCoverage");+ goto err;
+ }
+ if(otfpoprange(o) < 0)
+ goto err;
+ }
return 0;
err:
werrstr("%s: %r", "MathGlyphInfo");@@ -3110,6 +3121,9 @@
Bprint(f, "%*s%s:\n", indent, "", "mathKernInfo");
if(v->mathKernInfo != nil)
print_MathKernInfo(f, indent+indentΔ, v->mathKernInfo);
+ Bprint(f, "%*s%s:\n", indent, "", "extendedShapeCoverage");
+ if(v->extendedShapeCoverage != nil)
+ print_Coverage(f, indent+indentΔ, v->extendedShapeCoverage);
}
int
--- a/otf.h
+++ b/otf.h
@@ -899,6 +899,7 @@
MathItalicsCorrectionInfo *mathItalicsCorrectionInfo;
MathTopAccentAttachment *mathTopAccentAttachment;
MathKernInfo *mathKernInfo;
+ Coverage *extendedShapeCoverage;
};
int read_MathGlyphInfo(Otf *o, MathGlyphInfo *v);
--- a/otf.rkt
+++ b/otf.rkt
@@ -1,387 +1,18 @@
-#!/usr/bin/env racket
-#lang racket
+; types allowed to be used as index
+(define-for-syntax (type-index? type) (member type '(uint16 uint32)))
-(require (for-syntax racket/format))
-(require (for-syntax syntax/parse))
-(require (for-syntax racket/contract))
+; types allowed to be used as offset
+(define-for-syntax (type-offset? type) (member type '(Offset16 Offset24 Offset32)))
-(require racket/contract)
-(require racket/generic)
+; types allowed to be used in comparisons
+(define-for-syntax (type-comparable? type)
+ (member type '(uint8 int8 uint16 int16 uint24 uint32 int32 Version16Dot16)))
-(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 in comparisons
+(define-for-syntax (type-number? type)
+ (member type
+ '(uint8 int8 uint16 int16 uint24 uint32 int32 Version16Dot16 Offset16 Offset24 Offset32)))
-(define size-in-bits/c
- (make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 64)))))
-
-(define tag/c
- (make-contract #:name 'tag/c #:first-order (λ (x) (and (string? x) (= 4 (string-length x))))))
-
-(define/contract (indent lst)
- (-> (listof any/c) (listof string?))
- (map (λ (str) (string-append "\t" str)) (flatten 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 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 verb 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 (block stmt lst)
- (if (= (length lst) 1) (list* stmt lst) (list (string-append stmt "{") lst "}")))-
-(define (wrap-cond-c cond lst)
- (match cond
- [#f lst]
- [(list op ref n ...)
- (block (~a "if(" (string-join (map (λ (n) (~a "v->" ref " " op " " n)) n) " || ") ")")- (indent lst))]))
-
-(define (invert-c op)
- (match op
- ['== '!=]
- ['<= '>]
- ['>= '<]
- ['< '>=]
- ['> '<=]))
-
-(define-struct field (type name attrs)
- #:transparent
- #:methods gen:code
- [(define/generic super-c-type c-type)
- (define (gen-h f)
- (define cnt (field-count f))
- (define fixed-array (number? cnt))
- (define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
- (list (~a (if (field-unused? f) "// " "")
- (super-c-type (field-type f))
- " "
- (if (or is-ptr (and cnt (not fixed-array))) "*" "")
- (field-name f)
- (if fixed-array (~a "[" cnt "];") ";"))))
- (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) (not (empty? (field-test f)))))
- (define (format-number x)
- (if (<= x 32768) (~r x) (~r x #:base 16 #:sign '("0x" "" "-0x"))))- (define (parse-if-error read)
- (define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
- (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 ";")
- (if is-ptr (~a ref " = calloc(1, sizeof(*" ref "));") empty))
- (~a "if(read_" (name (field-type f)) "(o, " (if is-ptr "" "&") ref ") < 0){")))- (if index empty (~a "if(otfreadn(o, " (size (field-type f)) ") == nil){")))]- [count
- #:when (type? (field-type f))
- (if (field-unused? f)
- empty
- (list (if (number? count) empty (~a ref " = malloc(" count "*sizeof(*" ref "));"))- (~a "for(int i = 0; i < " count "; i++)")
- (~a "\t"
- ref
- "[i] = "
- ((type-parse (field-type f)) b index (~a "i*" (size (field-type f))))
- ";")))]
- [count
- (~a "if(otfarray(o, &"
- ref
- ", read_"
- (super-c-type (field-type f))
- ", sizeof("- (super-c-type (field-type f))
- "), "
- count
- ") < 0){")]))- (define (test-cond ts)
- (map (λ (t)
- (match t
- [(list 'test op a ...)
- (string-join (map (λ (v) (~a ref " " (invert-c op) " " (format-number v))) a)
- " && ")]))
- ts))
- (define (at lst)
- (define at (field-offset f))
- (if (not at)
- lst
- (list (~a "if(v->" at " != 0){")- (~a "\tif(otfpushrange(o, v->" at ", -1) < 0)")
- (~a "\t\tgoto err;")
- (indent lst)
- (~a "\tif(otfpoprange(o) < 0)")
- (~a "\t\tgoto err;")
- (~a "}"))))
- (at (list* (parse-if-error #t)
- (if index
- empty
- (list (~a "\twerrstr(\"%s: %r\", \"" (field-name f) "\");")
- (~a "\tgoto err;")
- (~a "}")))
- (match (test-cond (field-test f))
- [(list) empty]
- [(list a ...)
- (list (~a "if(" (string-join a " || ") "){")- (~a "\twerrstr(\"%s: invalid value: %d (0x%ux)\", \""
- (field-name f)
- "\", "
- ref
- ", "
- ref
- ");")
- (~a "\tgoto err;")
- (~a "}"))]))))])
-
-(define/contract (field-attr f a)
- (-> field? symbol? any)
- (define v (assoc a (field-attrs f)))
- (and v (cadr v)))
-
-(define (field-unused? f)
- (field-attr f 'unused))
-
-(define (field-verb f)
- (field-attr f 'verb))
-
-(define (field-offset f)
- (field-attr f 'at))
-
-(define (field-cond f)
- (define v (assoc 'cond (field-attrs f)))
- (and v (rest v)))
-
-(define/contract (field-count f)
- (-> field? (or/c false/c number? string?))
- (define (fmt-expr e)
- (cond
- [(number? e) e]
- [(list? e)
- (match e
- [(list op x y) (~a (fmt-expr x) op (fmt-expr y))])]
- [(symbol? e) (~a "v->" e)]))
- (define e (field-attr f 'count))
- (and e (fmt-expr e)))
-
-(define (field-test f)
- (filter (λ (t) (eq? (car t) 'test)) (field-attrs f)))
-
-(define (field-print-c f)
- (define t (field-type f))
- (define cnt (field-count f))
- (define basic-array (and cnt (type? t)))
- (define fixed-array (and basic-array (number? cnt)))
- (define array-index (if cnt "[i]" ""))
- (define verb (if (type? t) (or (field-verb f) (type-verb t)) ""))
- (define print-index
- (if basic-array
- (~a "Bprint(f, \"%*s%s[%d]: "
- verb
- "\\n\", indent, \"\", \""
- (field-name f)
- "\", i, v->"
- (field-name f)
- array-index
- ");")
- (~a "Bprint(f, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
- (define array-loop
- (if cnt
- (λ (lst)
- (block (~a "for(int i = 0; i < " cnt "; i++)")
- (indent (list* print-index (if basic-array empty lst)))))
- identity))
- (define is-ptr (and (cmplx? t) (field-offset f) (not cnt)))
- (define lst
- (flatten
- (list
- (if (type? t)
- (~a "Bprint(f, \"%*s%s: "
- verb
- "\\n\", indent, \"\", \""
- (field-name f)
- "\", v->"
- (field-name f)
- array-index
- ");")
- (list (if cnt empty (~a "Bprint(f, \"%*s%s:\\n\", indent, \"\", \"" (field-name f) "\");"))
- (if is-ptr (~a "if(v->" (field-name f) " != nil)") empty)
- (~a (if is-ptr "\t" "")
- "print_"
- (cmplx-name t)
- "(f, indent+indentΔ, "
- (if is-ptr "" "&")
- "v->"
- (field-name f)
- array-index
- ");"))))))
- (if (field-unused? f) empty (wrap-cond-c (field-cond f) (array-loop lst))))
-
-(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)
- (define/generic super-gen-c gen-c)
- (define (gen-h c)
- (flatten
- (append
- (list (~a "typedef struct " (cmplx-name c) " " (cmplx-name c) ";")
- (~a "")
- (~a "struct " (cmplx-name c) " {"))- (indent (map super-gen-h (cmplx-fields c)))
- (indent (filter-extra (cmplx-extra c) 'field))
- (list (~a "};")
- (~a "")
- (~a "int read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v);")
- (~a "void print_" (cmplx-name c) "(Biobuf *f, int indent, " (cmplx-name c) " *v);")))))
- (define (gen-c c b index)
- (define (no-vla? f)
- (define cnt (field-count f))
- (or (not cnt) (number? cnt)))
- ; group fields to minimize number of reads
- ; complex types are always alone
- ; simple types can be combined unless versioned
- ; versioned simple types are combined if the check is the same
- (define (group-fields fields)
- (define (combine? f g)
- (or (empty? g)
- (and (type? (field-type f))
- (type? (field-type (car g)))
- (no-vla? f)
- (no-vla? (car g))
- (equal? (field-cond f) (field-cond (car g))))))
- (define (group- g fields)
- (match fields
- [(list-rest f tail)
- (if (combine? f g) (group- (cons f g) tail) (cons (reverse g) (group- (list f) tail)))]
- [_ (list (reverse g))]))
- (group- empty fields))
- (define (field-size f)
- (match (field-count f)
- [#f (type-size (field-type f))]
- [count
- #:when (type? (field-type f))
- ((if (number? count) (λ (sz) (* count sz)) (λ (sz) (~a count "*" sz)))
- (type-size (field-type f)))]))
- (define (add x y)
- (match (list x y)
- [(list _ 0) x]
- [(list 0 _) y]
- [_ (if (and (number? x) (number? y)) (+ x y) (~a x "+" y))]))
- (define (parse-group g)
- (define (p fs index)
- (if (pair? fs)
- (cons (super-gen-c (car fs) "b" index) (p (cdr fs) (add index (field-size (car fs)))))
- empty))
- (p g 0))
- (define (gen-group-c fields)
- (define unused (andmap field-unused? fields))
- (wrap-cond-c (field-cond (car fields))
- (if (cmplx? (field-type (car fields)))
- (map (λ (f) (super-gen-c f #f #f)) fields)
- (let* ([sum (foldr (λ (f accu) (add (field-size f) accu)) 0 fields)]
- [lst (flatten (list* (~a "if((b = otfreadn(o, " sum ")) == nil)")
- (~a "\tgoto err;")
- (if unused "USED(b);" empty)
- (parse-group fields)))])
- lst))))
- (flatten
- (append (list (~a "")
- (~a "int")
- (~a "read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v)")
- (~a "{")- (~a "\tu8int *b;"))
- (indent (map gen-group-c (group-fields (cmplx-fields c))))
- (indent (filter-extra (cmplx-extra c) 'read))
- (list (~a "\treturn 0;")
- (~a "err:")
- (~a "\twerrstr(\"%s: %r\", \"" (cmplx-name c) "\");")
- (~a "\treturn -1;")
- (~a "}"))
- (list (~a "")
- (~a "void")
- (~a "print_" (cmplx-name c) "(Biobuf *f, int indent, " (cmplx-name c) " *v)")
- (~a "{")- (indent (map field-print-c (cmplx-fields c)))
- (indent (filter-extra (cmplx-extra c) 'print))
- (~a "}")))))
- (define (c-type c)
- (cmplx-name c))])
-
-(define/contract (autoparse bits ctype)
- (-> positive? symbol? procedure?)
- (λ (b [index 0] [offset #f])
- (define off (if offset (~a "+" offset) ""))
- (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 off "]" tail))
- (f index bits)))
-
-(define-for-syntax typenames '())
-
-(define-syntax (mktype stx)
- (syntax-parse stx
- [(_ typ:id bits c:id verb:string) #'(mktype typ bits c verb (autoparse bits `c))]
- [(_ typ:id bits c:id verb:string parse:expr)
- #:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
- (begin
- (set! typenames (cons (syntax-e #`typ) typenames))
- #'(begin
- (define typ (make-type `typ bits.c `c verb parse))
- (set! types (append types (list typ)))))]))
-
-(define-syntax (mkcmplx stx)
- (syntax-parse stx
- [(_ typ:id fields:expr ...+ (~optional (~seq #:tag tag)) (~optional (~seq #:extra extra:expr)))
- #:declare tag (expr/c #'tag/c #:name "table tag")
- (begin
- (set! typenames (cons (syntax-e #`typ) typenames))
- #'(begin
- (define tag- (~? (~@ tag.c) #f))
- (define typ (make-cmplx `typ (mkfields [~@ fields] ...) tag- (~? (~@ extra) empty)))
- (set! cmplxs (append cmplxs (list typ)))
- (when tag-
- (set! tagged (append tagged (list typ))))))]))
-
(mktype uint8 8 u8int "%ud")
(mktype int8 8 s8int "%d")
(mktype uint16 16 u16int "%ud")
@@ -410,88 +41,6 @@
(define x (~a ((type-parse int16) b index)))
(~a "(" x ">>14)+(" x "&((1<<14)-1))/16384.0")))-; types allowed to be used as index
-(define-for-syntax (type-index? type) (member type '(uint16 uint32)))
-
-; types allowed to be used as offset
-(define-for-syntax (type-offset? type) (member type '(Offset16 Offset24 Offset32)))
-
-; types allowed to be used in comparisons
-(define-for-syntax (type-comparable? type)
- (member type '(uint8 int8 uint16 int16 uint24 uint32 int32 Version16Dot16)))
-
-; types allowed to be used in comparisons
-(define-for-syntax (type-number? type)
- (member type
- '(uint8 int8 uint16 int16 uint24 uint32 int32 Version16Dot16 Offset16 Offset24 Offset32)))
-
-(define-for-syntax fields '())
-
-(define-syntax (mkattr stx)
- (define-syntax-class compop
- #:description "comparison operator"
- (pattern op:id
- #:when (member (syntax-e #'op) '(== != < > <= >=))))
-
- (define-syntax-class arithop
- #:description "arithmetical operator"
- (pattern op:id
- #:when (member (syntax-e #'op) '(+ - / *))))
-
- (define-syntax-class ref
- #:description "field reference"
- (pattern ref:id
- #:fail-when (not (assoc (syntax-e #'ref) fields)) "no such field"
- #:with type (cadr (assoc (syntax-e #'ref) fields))))
-
- (syntax-parse stx
- [(_ _ ({~literal at} ref:ref))- #:fail-when (not (type-offset? (syntax-e #'ref.type))) "can't be used as an offset"
- #''(at ref)]
- [(_ type {~literal hex})- #:fail-when (not (type-number? (syntax-e #'type))) "not a number type"
- #''(verb "%#ux")]
- [(_ type (p:compop vs:number ...+))
- #:fail-when (not (type-comparable? (syntax-e #'type))) "type can't be used in a comparison"
- #''(test p vs ...)]
- [(_ _ (p:compop ref:ref vs:number ...+))
- #''(cond
- p
- ref
- vs ...)]
- [(_ _ {~literal unused}) #''(unused #t)]- [(_ _ (ref:ref))
- #:fail-when (not (type-index? (syntax-e #'ref.type))) "can't be used as index to an array"
- #''(count ref)]
- [(_ _ (n:number)) #''(count n)]
- [(_ _ (p:arithop e:expr ...+)) #''(count (p e ...))])) ; FIXME - check fields and ops/numbers
-
-(define-syntax (mkfield stx)
- (define-syntax-class name
- #:description "field name"
- (pattern name:id
- #:fail-when (assoc (syntax-e #'name) fields) "duplicate field name"))
-
- (define-syntax-class type
- #:description "field type"
- (pattern type:id
- #:fail-when (not (member (syntax-e #'type) typenames)) "unknown field type"))
-
- (syntax-parse stx
- [(_ type:type name:name attrs ...)
- (begin
- (set! fields (cons (syntax->datum #'(name type)) fields))
- #'(field type
- `name
- (list (mkattr type [~@ attrs]) ...)))]))
-
-(define-syntax (mkfields stx)
- (syntax-parse stx
- [(_ x ...+)
- (begin
- (set! fields '())
- #'(list (mkfield [~@ . x]) ...))]))
-
(mkcmplx SubHeader {uint16 firstCode} {uint16 entryCode} {int16 idDelta} {uint16 idRangeOffset}); same type for Sequential and Constant
@@ -982,11 +531,12 @@
(mkcmplx MathGlyphInfo
{Offset16 mathItalicsCorrectionInfoOffset} {Offset16 mathTopAccentAttachmentOffset}- {Offset16 extendedShapeCoverageOffset} ; FIXME WHERE is this shit defined???+ {Offset16 extendedShapeCoverageOffset} {Offset16 mathKernInfoOffset} {MathItalicsCorrectionInfo mathItalicsCorrectionInfo (at mathItalicsCorrectionInfoOffset)} {MathTopAccentAttachment mathTopAccentAttachment (at mathTopAccentAttachmentOffset)}- {MathKernInfo mathKernInfo (at mathKernInfoOffset)})+ {MathKernInfo mathKernInfo (at mathKernInfoOffset)}+ {Coverage extendedShapeCoverage (at extendedShapeCoverageOffset)}) (mkcmplx MathGlyphVariantRecord {uint16 variantGlyph} {UFWORD advanceMeasurement})@@ -1116,244 +666,3 @@
{uint16 rangeShift} {TableRecord tableRecords [numTables]}#:extra (tagged-tables-fields tagged))
-
-(define (out path f)
- (call-with-output-file path
- #:exists 'truncate/replace
- (λ (p)
- (begin
- (current-output-port p)
- (f)))))
-
-(out "otf.h"
- (λ ()
- (printf #<<EOF
-/* this file is generated. do not modify. */
-typedef struct Otf Otf;
-#pragma incomplete Otf
-
-EOF
- )
- (printf (format gen-h))
- (printf #<<EOF
-
-extern int indentΔ;
-
-#pragma varargck type "T" s64int
-#pragma varargck type "t" u32int
-#pragma varargck type "V" u32int
-
-void otfinit(void);
-Otf *otfopen(char *path);
-void otfclose(Otf *o);
-
-EOF
- )))
-
-(out "otf.c"
- (λ ()
- (printf #<<EOF
-/* this file is generated. do not modify. */
-#include <u.h>
-#include <libc.h>
-#include <bio.h>
-#include "otf.h"
-
-typedef struct Range Range;
-
-struct Otf {- Biobuf *f;
- Range *r;
- u8int *buf;
- int bufsz;
- int off;
-};
-
-struct Range {- int start;
- int len;
- int prevoff;
- Range *par;
-};
-
-Otf *
-otfopen(char *path)
-{- Otf *o;
- Biobuf *f;
-
- if((f = Bopen(path, OREAD)) == nil)
- return nil;
- if((o = calloc(1, sizeof(*o))) == nil){- werrstr("no memory");- Bterm(f);
- }else{- o->f = f;
- }
- return o;
-}
-
-void
-otfclose(Otf *o)
-{- if(o == nil)
- return;
- // FIXME traverse and free everything
- free(o);
-}
-
-static int
-otfpushrange(Otf *o, int off, int len)
-{- Range *r;
- int x;
-
- r = nil;
- if(o->r != nil){- if(len < 0)
- len = o->r->len - off;
- if(len < 0 || off+len > o->r->len){- werrstr("range overflow (len %d) by %d bytes", len, off+len - o->r->len);- goto err;
- }
- off += o->r->start;
- }else if(len < 0){- len = 0x7fffffff;
- }
- if((r = malloc(sizeof(*r))) == nil){- werrstr("no memory");- goto err;
- }
- r->par = o->r;
- r->start = off;
- r->len = len;
- r->prevoff = o->off;
- if((x = Bseek(o->f, off, 0)) != off){- werrstr("seek offset: need %d, got %d", off, x);- goto err;
- }
- o->off = off;
- o->r = r;
- return 0;
-err:
- free(r);
- return -1;
-}
-
-static int
-otfpoprange(Otf *o)
-{- Range *r;
- int x;
-
- r = o->r;
- if(r == nil){- werrstr("pop without push");- goto err;
- }
- if((x = Bseek(o->f, r->prevoff, 0)) != r->prevoff){- werrstr("seek offset: need %d, got %d", r->prevoff, x);- goto err;
- }
- o->off = r->prevoff;
- o->r = r->par;
- free(r);
- return 0;
-err:
- return -1;
-}
-
-static u8int *
-otfreadn(Otf *o, int n)
-{- Range *r;
- u8int *b;
- int x;
-
- r = o->r;
- if(r != nil && o->off+n > r->start+r->len){- werrstr("need %d at %d, have %d at %d", n, o->off, r->len, r->start);- goto err;
- }
- if(n > o->bufsz){- if((b = realloc(o->buf, n)) == nil){- werrstr("no memory");- goto err;
- }
- o->buf = b;
- o->bufsz = n;
- }
- if((x = Bread(o->f, o->buf, n)) != n){- werrstr("need %d, got %d; off %d", n, x, o->off);- goto err;
- }
- o->off += n;
-
- return o->buf;
-err:
- return nil;
-}
-
-static int
-otfarray(Otf *o, void **arr_, void *fun_, int elsz, int num)
-{- int i;
- int (*fun)(Otf*, void*);
- u8int *arr;
-
- if((arr = calloc(num, elsz)) == nil){- werrstr("no memory");- goto err;
- }
- fun = fun_;
- for(i = 0; i < num; i++){- if(fun(o, arr + i*elsz) < 0)
- goto err;
- }
- *arr_ = arr;
- return 0;
-err:
- free(arr);
- return -1;
-}
-
-EOF
- )
- (printf (format (λ (c) (gen-c c #f #f))))
- (printf #<<EOF
-
-int indentΔ = 2;
-
-static int
-Tfmt(Fmt *f)
-{- Tm t;
- s64int v = va_arg(f->args, s64int);
- return fmtprint(f, "%τ", tmfmt(tmtime(&t, v, nil), nil));
-}
-
-static int
-Vfmt(Fmt *f)
-{- u32int v = va_arg(f->args, u32int);
- return fmtprint(f, "%d.%d", v>>16, v&0xffff);
-}
-
-static int
-tfmt(Fmt *f)
-{- u32int v = va_arg(f->args, u32int);
- return fmtprint(f, "%c%c%c%c", v>>24, v>>16, v>>8, v>>0);
-}
-
-void
-otfinit(void)
-{- tmfmtinstall();
- fmtinstall('V', Vfmt);- fmtinstall('T', Tfmt);- fmtinstall('t', tfmt);-}
-
-EOF
- )))