ref: 0cbe9b4217052015b2a1d979dbe4ede82410070d
parent: d5c519ab9f221b899180a0def079c64888c82af6
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Tue Jun 11 21:09:05 EDT 2024
generate pretty-printing logic
--- a/otf.rkt
+++ b/otf.rkt
@@ -36,7 +36,7 @@
(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)
+(define-struct type (name bits c verb parse)
#:transparent
#:methods gen:code
[(define (gen-h t)
@@ -62,6 +62,39 @@
(define (field-values f)
(assoc '= (field-attrs f)))
+(define (field-verb f)
+ (assoc 'verb (field-attrs f)))
+
+(define (field-fprint-c f)
+ (define t (field-type f))
+ (define array-loop
+ (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);")
+ (indent lst)
+ (~a "}")))
+ identity))
+ (define array-index (if (field-count f) "[i]" ""))
+ (define verb (if (type? t) (if (field-verb f) (cadr (field-verb f)) (type-verb t)) ""))
+ (if (field-unused? f)
+ empty
+ (array-loop (list (if (type? t)
+ (~a "fprint(f, \"%*s%s: "
+ verb
+ "\\n\", ident, \"\", \""
+ (field-name f)
+ "\", v->"
+ (field-name f)
+ array-index
+ ");")
+ (~a "fprint_"
+ (cmplx-name t)
+ "(f, ident+identΔ, &v->"
+ (field-name f)
+ array-index
+ ");"))))))
+
(define-struct field (type name attrs)
#:transparent
#:methods gen:code
@@ -96,11 +129,13 @@
(~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, &"
+ (~a "if(ctxarray(ctx, &"
ref
", read_"
(super-c-type (field-type f))
- ", v->"
+ ", sizeof("+ (super-c-type (field-type f))
+ "), v->"
(cadr count)
") < 0){")]))(list*
@@ -107,12 +142,18 @@
(parse-if-error #t)
(if index
empty
- (list (~a "\twerror(\"%s: %r\", \"" (field-name f) "\");") (~a "\tgoto err;") (~a "}")))
+ (list (~a "\twerrstr(\"%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 "\twerrstr(\"%s: invalid value: %d (0x%ux)\", \""
+ (field-name f)
+ "\", "
+ ref
+ ", "
+ ref
+ ");")
(~a "\tgoto err;")
(~a "}"))]
[#f empty])))])
@@ -144,16 +185,22 @@
(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 "}")))))
+ (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 "}"))
+ (list (~a "void")
+ (~a "fprint_" (cmplx-name c) "(int f, int ident, " (cmplx-name c) " *v)")
+ (~a "{")+ (indent (flatten (map field-fprint-c (cmplx-fields c))))
+ (~a "}")))))
(define (c-type c)
(cmplx-name c))])
@@ -169,14 +216,14 @@
(define-syntax (mktype stx)
(syntax-parse stx
- [(_ typ:id bits c:id)
+ [(_ typ:id bits c:id verb:string)
#'(begin
(define parse (autoparse bits `c))
- (mktype typ bits c parse))]
- [(_ typ:id bits c:id parse:expr)
+ (mktype typ bits c verb parse))]
+ [(_ typ:id bits c:id verb:string parse:expr)
#:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
#'(begin
- (define typ (make-type `typ bits.c `c parse))
+ (define typ (make-type `typ bits.c `c verb parse))
(set! types (append types (list typ))))]))
(define-syntax (mkcmplx stx)
@@ -191,6 +238,7 @@
(define-syntax (mkattr stx)
(syntax-parse stx
+ [(_ {~literal hex}) #''(verb "%#ux")] [(_ ({~literal =} vs:number ...+)) #''(= vs ...)] [(_ ({~literal count} n:id))(begin
@@ -224,33 +272,39 @@
(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 uint8 8 u8int "%ud")
+(mktype int8 8 s8int "%d")
+(mktype uint16 16 u16int "%ud")
+(mktype int16 16 s16int "%d")
+(mktype uint24 24 u32int "%ud")
+(mktype uint32 32 u32int "%ud")
+(mktype int32 32 s32int "%d")
+(mktype FWORD 16 s16int "%d")
+(mktype UFWORD 16 u16int "%ud")
+(mktype LONGDATETIME
+ 64
+ s64int
+ "%T"
+ (λ (b index) (~a "(" ((autoparse 64 's64int) b index) ") - 2082844800LL")))+(mktype Tag 32 u32int "%t")
+(mktype Offset16 16 u16int "%ud")
+(mktype Offset24 24 u32int "%ud")
+(mktype Offset32 32 u32int "%ud")
+(mktype Version16Dot16 32 u32int "%V")
+(mktype Fixed 32 float "%g" (λ (b index) (~a ((type-parse int32) b index) "/65536.0f")))
(mktype F2DOT14
16
float
+ "%g"
(λ (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 TableRecord
+ (mkfields {Tag tableTag} {uint32 checksum hex} {Offset32 offset} {uint32 length}))(mkcmplx TableDirectory
- (mkfields {uint32 sfntVersion (= #x000100000 #x4f54544f)}+ (mkfields {uint32 sfntVersion (= #x00010000 #x4f54544f) hex} {uint16 numTables} {uint16 searchRange} {uint16 entrySelector}@@ -274,8 +328,8 @@
{uint32 magicNumber unused (= #x5f0f3cf5)} {uint16 flags} {uint16 unitsPerEm}- {LONGDATETIME created unused}- {LONGDATETIME modified unused}+ {LONGDATETIME created}+ {LONGDATETIME modified} {int16 xMin} {int16 yMin} {int16 xMax}@@ -288,4 +342,48 @@
"head")
(printf (format gen-h))
+(printf #<<EOF
+extern int identΔ;
+
+#pragma varargck type "T" s64int
+#pragma varargck type "t" u32int
+#pragma varargck type "V" u32int
+EOF
+ )
+
(printf (format (λ (c) (gen-c c #f #f))))
+(printf #<<EOF
+
+int identΔ = 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
+ )