shithub: fnt

Info  •  Files  •  Log  •  Branches

mkattr: ptr for Offset* handling (unimplemented); protect against uncomparable types used in tests

--- a/otf.rkt

+++ b/otf.rkt

@@ -12,9 +12,6 @@

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

-

 (define size-in-bits/c

   (make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 64)))))

@@ -334,15 +331,62 @@

          (when tag-

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

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

+

+; 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)))

+

 (define-for-syntax fields '())

 (define-syntax (mkattr stx)

   (syntax-parse stx

-    [(_ (n:number)) #''(count n)]

-    [(_ {~literal hex}) #''(verb "%#ux")]

-    [(_ (p:expr vs:number ...+)) #''(test p vs ...)]

-    [(_ (p:expr ref:id vs:number ...+))

+    [(_ offType:id ({~literal ptr} type:id name:id))

      (begin

+       (when (not (type-offset? (syntax->datum #`offType)))

+         (raise-syntax-error #f "can't be used as an offset" stx #'offType))

+       #''(ptr type name))]

+    [(_ _ (n:number)) #''(count n)]

+    [(_ _ {~literal hex}) #''(verb "%#ux")]

+    [(_ type (p:expr vs:number ...+))

+     (begin

+       (when (not (type-comparable? (syntax->datum #`type)))

+         (raise-syntax-error #f "type can't be used in a comparison" stx #'type))

+       #''(test p vs ...))]

+    [(_ _ (p:expr ref:id vs:number ...+))

+     (begin

        (when (not (assoc (syntax->datum #`ref) fields))

          (raise-syntax-error #f "no such field" stx #'ref))

        #''(cond

@@ -349,7 +393,7 @@

             p

             ref

             vs ...))]

-    [(_ ({~literal count} n:id))

+    [(_ _ ({~literal count} n:id))

      (begin

        (define counter (assoc (syntax->datum #`n) fields))

        (cond

@@ -361,7 +405,7 @@

                                   stx

                                   #'n))]

          [else (raise-syntax-error #f "no such field" stx #'n)]))]

-    [(_ {~literal unused}) #''(unused #t)]))

+    [(_ _ {~literal unused}) #''(unused #t)]))

 (define-syntax (mkfield stx)

   (syntax-parse stx

@@ -369,7 +413,7 @@

      (begin

        (let ([f #'(field type

                          `name

-                         (list (mkattr [~@ attrs]) ...))])

+                         (list (mkattr type [~@ attrs]) ...))])

          (begin

            (when (assoc (syntax->datum #`name) fields)

              (raise-syntax-error #f "duplicate field" stx #'name))

@@ -383,36 +427,10 @@

        (set! fields '())

        #'(list (mkfield [~@ . x]) ...))]))

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

-         (mkfields {uint16 platformID (<= 4)} {uint16 encodingID} {Offset32 subtableOffset}))

+         (mkfields {uint16 platformID (<= 4)}

+                   {uint16 encodingID}

+                   {Offset32 subtableOffset (ptr SubTableCmap subtable)}))

 (mkcmplx SubHeader

          (mkfields {uint16 firstCode} {uint16 entryCode} {int16 idDelta} {uint16 idRangeOffset}))