diff --git a/fontland/fontland/table/cff/cff-pointer.rkt b/fontland/fontland/table/cff/cff-pointer.rkt index 8bdbbc64..506c4e8b 100644 --- a/fontland/fontland/table/cff/cff-pointer.rkt +++ b/fontland/fontland/table/cff/cff-pointer.rkt @@ -1,10 +1,38 @@ #lang racket/base -(require racket/class xenomorph) -(provide (all-defined-out)) +(require racket/class racket/list xenomorph) +(provide CFFPointer) #| approximates https://github.com/mbutterick/fontkit/blob/master/src/cff/CFFPointer.js |# -(define \ No newline at end of file +(define CFFPointer + (class x:pointer% + (super-new) + + (inherit-field offset-type) + (define ptr #false) + + (define/override (:decode stream parent operands) + (set! offset-type (class xenobase% + (super-new) + (define/augment (:decode . args) (first operands)) + ;; compute the size (so ctx.pointerSize is correct) + (define/augment (:size . args) 0) + (define/augment (:encode stream val) (set! ptr val)))) + + (super :decode stream parent operands)) + + (define/override (:encode stream value ctx) + (cond + [(not stream) + (send this :size value ctx) + (Ptr 0)] + [else + (super :encode stream value ctx) + (Ptr ptr)])))) + +(struct Ptr (val [forceLarge #:auto]) #:transparent #:mutable #:auto-value #true + ;; use prop:procedure instead of JS `valueOf` + #:property prop:procedure (λ (ptr) (Ptr-val ptr))) \ No newline at end of file diff --git a/fontland/fontland/table/cff/cff-top.rkt b/fontland/fontland/table/cff/cff-top.rkt index faa2e321..4ccd6940 100644 --- a/fontland/fontland/table/cff/cff-top.rkt +++ b/fontland/fontland/table/cff/cff-top.rkt @@ -1,8 +1,9 @@ #lang debug racket/base -(require xenomorph sugar/unstable/dict +(require xenomorph sugar/unstable/dict racket/class "cff-index.rkt" "cff-dict.rkt" - "cff-charsets.rkt") + "cff-charsets.rkt" + "cff-pointer.rkt") (provide CFFTop) #| @@ -10,6 +11,53 @@ approximates https://github.com/mbutterick/fontkit/blob/master/src/cff/CFFTop.js |# +(define PredefinedOp + (class xenobase% + (super-new) + (init-field [(@predefinedOps predefinedOps)] + [(@type type) #f]))) + +(define Range1 + (x:struct + 'first uint16be + 'nLeft uint8)) + +(define Range2 + (x:struct + 'first uint16be + 'nLeft uint16be)) + +;; Decodes an array of ranges until the total +;; length is equal to the provided length. + +(define RangeArray + (class x:array% + (inherit-field [@len len] [@type type]) + (define (:decode stream parent) + (define length (resolve-length @len stream parent)) + (for/fold ([res null] + [count 0] + #:result (reverse res)) + ([i (in-naturals)] + #:break (not (< count length))) + (define range (decode @type stream parent)) + (hash-set! range 'offset count) + (values (cons range res) (+ count (hash-ref range 'nLeft) 1)))))) + + +(define CFFCustomCharset + (let ([tproc (λ (t) (sub1 (length (hash-ref (hash-ref t 'parent) 'CharStrings))))]) + (x:versioned-struct + uint8 + (dictify + 0 (dictify 'glyphs (x:array uint16be tproc)) + 1 (dictify 'ranges (RangeArray Range1 tproc)) + 2 (dictify 'ranges (RangeArray Range2 tproc)))))) + +(define CFFCharset (make-object PredefinedOp + (list ISOAdobeCharset ExpertCharset ExpertSubsetCharset) + (CFFPointer CFFCustomCharset #:lazy #true))) + (define CFFTopDict (CFFDict ;; key name type(s) default