conflicts between ctx and ctx res

pitfall/fontkit/GPOS-test.coffee

@@ -2,6 +2,7 @@ fontkit = require '../pdfkit/node_modules/fontkit'
 
 fira_path = "../pitfall/test/assets/fira.ttf"
 f = fontkit.openSync(fira_path)
+console.log "*************************** start decode"
 thing = f.GPOS.lookupList.get(0)
 console.log thing
 

pitfall/fontkit/GPOS-test.rkt

@@ -5,4 +5,4 @@
 (define f (openSync fira-path))
 (report 'start-decode)
 (define gpos (send GPOS decode (send f _getTableStream 'GPOS)))
-;gpos
+gpos

pitfall/fontkit/GPOS.rkt

@@ -20,7 +20,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/GPOS.js
    'xAdvDevice uint16be ;; pointer
    'yAdvDevice uint16be)) ;; pointer
 
-(define-subclass RestructureBase (ValueRecord [key 'valueFormat])
+(define-subclass object% (ValueRecord [key 'valueFormat])
   (define/public (buildStruct parent)
     ;; set `struct` to the first Struct object in the chain of ancestors
     ;; with the target key
@@ -40,15 +40,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/GPOS.js
                 (cons key (dict-ref types key)))))
            (+Struct fields))))
 
-  (define/override (size val ctx)
+  (define/public (size val ctx)
     (send (buildStruct ctx) size val ctx))
 
-  (define/augride (decode stream parent)
+  (define/public (decode stream parent)
     (define res (send (buildStruct parent) decode stream parent))
     (hash-remove! res 'rel)
     res)
 
-  (define/override (encode . args)
+  (define/public (encode . args)
     (error 'GPOS-encode-not-implemented)))
 
 (define PairValueRecord (+Struct
@@ -190,8 +190,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/GPOS.js
                                   'lookupList (+Pointer uint16be (LookupList GPOSLookup))
                                   ))
 
-(define-subclass VersionedStruct (GPOS-VersionedStruct))
-(define GPOS (+GPOS-VersionedStruct uint32be
+(define-subclass VersionedStruct (GPOS-MainVersionedStruct))
+(define GPOS (+GPOS-MainVersionedStruct uint32be
                                     (dictify
                                      #x00010000 gpos-common-dict
                                      ;; ignore variations

pitfall/fontkit/opentype.rkt

@@ -6,25 +6,31 @@
 ;; Scripts and Languages #
 ;;########################
 
+(define-subclass Array (FeatIdxArray))
+
 (define LangSysTable (+Struct
                       (dictify 'reserved uint16be
                                'reqFeatureIndex uint16be
                                'featureCount uint16be
-                               'featureIndexes (+Array uint16be 'featureCount))))
+                               'featureIndexes (+FeatIdxArray uint16be 'featureCount))))
 
+(define-subclass Pointer (LSR-Pointer))
 (define LangSysRecord (+Struct
                        (dictify 'tag (+String 4)
-                                'langSys (+Pointer uint16be LangSysTable 'parent))))
+                                'langSys (+LSR-Pointer uint16be LangSysTable 'parent))))
 
+(define-subclass Pointer (DLS-Pointer))
+(define-subclass Array (DLS-Array))
 (define Script (+Struct
-                (dictify 'defaultLangSys (+Pointer uint16be LangSysTable)
+                (dictify 'defaultLangSys (+DLS-Pointer uint16be LangSysTable)
                          'count uint16be
-                         'langSysRecords (+Array LangSysRecord 'count))))
+                         'langSysRecords (+DLS-Array LangSysRecord 'count))))
 
 (define-subclass Struct (ScriptRecord-Struct))
+(define-subclass Pointer (ScriptRecord-Pointer))
 (define ScriptRecord (+ScriptRecord-Struct
                       (dictify 'tag (+String 4)
-                               'script (+Pointer uint16be Script 'parent))))
+                               'script (+ScriptRecord-Pointer uint16be Script 'parent))))
 
 (define ScriptList (+Array ScriptRecord uint16be))
 
@@ -38,9 +44,11 @@
                           'lookupCount uint16be
                           'lookupListIndexes (+Array uint16be 'lookupCount))))
 
-(define FeatureRecord (+Struct (dictify
+(define-subclass Struct (FeatureRec))
+(define-subclass Pointer (FeatureRec-Pointer))
+(define FeatureRecord (+FeatureRec (dictify
                                 'tag (+String 4)
-                                'feature (+Pointer uint16be Feature 'parent))))
+                                'feature (+FeatureRec-Pointer uint16be Feature 'parent))))
 
 (define FeatureList (+Array FeatureRecord uint16be))
 

pitfall/restructure/array.rkt

@@ -21,7 +21,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
                    (unless (andmap (λ (x) (and x (number? x))) (list num denom))
                      (raise-argument-error 'Array:decode "valid length and size" (list num denom)))
                    (floor (/ (send stream length) (send type size)))]))
-    (report* length_ (Number? length_))
+    
     (when (Number? length_)
       (set-field! parent ctx parent)
       (set-field! _startOffset ctx pos)

pitfall/restructure/base.rkt

@@ -9,10 +9,10 @@
            [_currentOffset #f]
            [_length #f]
            [parent #f])
-    (define/pubment (decode stream . args)
+    (define/public (decode stream . args)
       (set! _startOffset (and (object? stream) (send stream pos)))
       (set! parent (and (pair? args) (is-a? (car args) RestructureBase) (car args)))
-      (inner (void) decode stream . args))
+      #;(inner (void) decode stream . args))
     (define/public (encode . xs) (void))
     (define/public (size . xs) (void))
     (define/public (process . args) (void))

pitfall/restructure/buffer.rkt

@@ -8,7 +8,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
 |#
 
 (define-subclass RestructureBase (Buffer [length_ #xffff])
-  (define/augride (decode stream [parent #f])
+  (define/override (decode stream [parent #f])
     (define len (resolveLength length_ stream parent))
     (send stream readBuffer len))
 

pitfall/restructure/pointer-test.rkt

@@ -9,39 +9,40 @@ https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
 ;; it 'should handle null pointers', ->
 (let ([stream (+DecodeStream (bytes 0))]
       [pointer (+Pointer uint8 uint8)])
-  (define ctx (make-object RestructureBase))
-  (set-field! _startOffset ctx 50)
-  (check-exn exn:fail? (λ () (send pointer decode stream ctx))))
+  (check-exn exn:fail? (λ () (send pointer decode stream (mhash '_startOffset 50)))))
 
 ;; it 'should use local offsets from start of parent by default', ->
 (let ([stream (+DecodeStream (bytes 1 53))]
       [pointer (+Pointer uint8 uint8)])
-  (define ctx (make-object RestructureBase))
-  (set-field! _startOffset ctx 0)
-  (check-equal? (send pointer decode stream ctx) 53))
+  (check-equal? (send pointer decode stream (mhash '_startOffset 0)) 53))
 
-;; todo
 ;; it 'should support immediate offsets', ->
-#;(let ([stream (+DecodeStream (bytes 1 53))]
-        [pointer (+Pointer uint8 uint8 'immediate)])
-    (check-equal? (send pointer decode stream) 53))
+(let ([stream (+DecodeStream (bytes 1 53))]
+      [pointer (+Pointer uint8 uint8 'immediate)])
+  (check-equal? (send pointer decode stream) 53))
 
 ;; it 'should support offsets relative to the parent', ->
 (let ([stream (+DecodeStream (bytes 0 0 1 53))]
       [pointer (+Pointer uint8 uint8 'parent)])
   (send stream pos 2)
-  (define ctx-parent (make-object RestructureBase))
-  (set-field! _startOffset ctx-parent 2)
-  (define ctx (make-object RestructureBase))
-  (set-field! parent ctx ctx-parent)
-  (check-equal? (send pointer decode stream ctx) 53))
+  (check-equal? (send pointer decode stream (mhash 'parent (mhash '_startOffset 2))) 53))
 
 ;; it 'should support global offsets', ->
-#;(let ([stream (+DecodeStream (bytes 1 2 4 0 0 0 53))]
+(let ([stream (+DecodeStream (bytes 1 2 4 0 0 0 53))]
       [pointer (+Pointer uint8 uint8 'global)])
   (send stream pos 2)
-  (define ctx-parent (make-object RestructureBase))
-  (set-field! _startOffset ctx-parent 2)
-  (define ctx (make-object RestructureBase))
-  (set-field! parent ctx ctx-parent)
-  (check-equal? (send pointer decode stream ctx) 53))
+  (check-equal? (send pointer decode stream (mhash 'parent (mhash 'parent (mhash '_startOffset 2)))) 53))
+
+;; todo
+#|
+    it 'should support offsets relative to a property on the parent', ->
+      stream = new DecodeStream new Buffer [1, 0, 0, 0, 0, 53]
+      pointer = new Pointer uint8, uint8, relativeTo: 'parent.ptr'
+      pointer.decode(stream, _startOffset: 0, parent: ptr: 4).should.equal 53
+|#
+
+;; it 'should support returning pointer if there is no decode type', ->
+(let ([stream (+DecodeStream (bytes 4))]
+      [pointer (+Pointer uint8 'void)])
+  (check-equal? (send pointer decode stream (mhash '_startOffset 0)) 4))
+

pitfall/restructure/pointer.rkt

@@ -6,24 +6,31 @@ approximates
 https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
 |#
 
-(define-subclass RestructureBase (Pointer offsetType type [scope 'local])
+(define-subclass object% (Pointer offsetType type [scope 'local])
+  (when (eq? type 'void) (set! type #f))
+  
   (and (symbol? scope) (caseq scope
                               [(local parent immediate global) 'yay]
                               [else (raise-argument-error 'Pointer "local or parent or immediate" scope)]))
 
-  (define/augride (decode stream [ctx #f])
+  (define/public (decode stream [ctx #f])
     (define offset (send offsetType decode stream ctx))
     (report scope 'pointer-scope)
     (define relative (caseq scope
-                            [(local) (· ctx _startOffset)]
+                            [(local) (or (· ctx res _startOffset) (· ctx _startOffset))]
                             [(parent) (· ctx parent _startOffset)]
                             [(immediate) (- (· stream pos) (send offsetType size))]
                             [(global) 
-                                  (let loop ([c ctx])
-                                    (cond
-                                      [(· c parent) => loop]
-                                      [else (or (· c starting-offset) 0)]))]))
-    (report* (· this _startOffset) (and ctx (· ctx _startOffset)))
+                             (let loop ([c ctx])
+                               (cond
+                                 [(· c parent) => loop]
+                                 [(· c _startOffset)]
+                                 [else 0]))]))
+    (report* this (· this _startOffset)
+             (and (· this res) (· this res _startOffset))
+             ctx (and ctx (· ctx _startOffset))
+             (and (· ctx res) (· ctx res _startOffset))) 
+    (when (and ctx (· ctx _startOffset) (= (· ctx _startOffset) 1012)) (error 'stop))
     (report* offset relative)
     (define ptr (+ offset relative))
     (report* ptr)
@@ -37,10 +44,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
       [else ptr]))
             
 
-  (define/override (encode stream val)
+  (define/public (encode stream val)
     (error 'Pointer-encode-not-done))
 
-  (define/override (size [val #f] [ctx #f])
+  (define/public (size [val #f] [ctx #f])
     (error 'Pointer-size-not-done)
     (report* this offsetType type (send type size)))
 

pitfall/restructure/stream.rkt

@@ -113,7 +113,7 @@ https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee
 ;; Streamcoder is a helper class that checks / converts stream arguments before decode / encode
 ;; not a subclass of DecodeStream or EncodeStream, however.
 (define-subclass RestructureBase (Streamcoder)
-  (define/augment (decode x . args)
+  (define/overment (decode x . args)
     (define stream (if (bytes? x) (+DecodeStream x) x))
     (unless (DecodeStream? stream)
       (raise-argument-error 'Streamcoder:decode "bytes or DecodeStream" x))

pitfall/restructure/struct.rkt

@@ -36,7 +36,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
       [else (send fields encode stream input-hash parent)]))
 
   (define/public-final (_setup stream parent length)
-    (mhasheq))
+    (define res (mhasheq))
+    (hash-set*! res 'parent parent
+                '_startOffset (· stream pos)
+                '_currentOffset 0
+                '_length length)
+    res)
 
   (define/public-final (_parseFields stream res fields)
     (unless (assocs? fields)
@@ -113,12 +118,14 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
   
   (define/override (decode stream [parent #f] [length 0])
     (set! res (send this _setup stream parent length))
+    (report res 'versioned-struct-res)
     (define version (resolve-version stream parent))
     (hash-set! res 'version version)
     (define fields (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions))))))
     (cond
       [(VersionedStruct? fields) (send fields decode stream parent)]
       [else
+       (report res 'whatigot)
        (send this _parseFields stream res fields)
        (send this process res stream)
        res]))

pitfall/sugar/js.rkt

@@ -40,15 +40,40 @@
   (check-equal? (number -4) "-4"))
 
 
+(define-syntax-rule (send-or-false X REF)
+  (with-handlers ([exn:fail:object? (λ (exn) #f)])
+    (send X REF)))
+
+(define-syntax-rule (get-or-false X REF)
+  (with-handlers ([exn:fail:object? (λ (exn) #f)])
+    (get-field REF X)))
+
+(require sugar/debug)
 (define-macro-cases ·
   [(_ X REF)
-   #'(cond
-       [(object? X) (with-handlers ([exn:fail:object? (λ (exn) (send X REF))])
-                      (get-field REF X))]
-       [(hash? X) (hash-ref X 'REF #f)]
-       [else (raise-argument-error '· (format "~a must be object or hash" 'X) X)])]
+   #'(let loop ([x X])
+       (cond
+         [(and (object? x) (or (get-or-false x REF) (send-or-false x REF)))]
+         [(and (object? x) (get-or-false x res)) => loop]
+         [(and (object? x) (send-or-false x res)) => loop]
+         [(object? x) #f]
+         [(and (hash? x) (hash-ref x 'res #f)) => loop]
+         [(and (hash? x) (hash-ref x 'REF #f))]
+         [(hash? x) #f]
+         [else (raise-argument-error '· (format "~a must be object or hash" 'X) x)]))]
   [(_ X REF0 . REFS) #'(· (· X REF0) . REFS)])
 
+(module+ test
+  (define c (class object%
+              (super-new)
+              (field [a 42])
+              (define/public (res) (hash 'res (hash 'b 43)))))
+  (define co (make-object c))
+  (define h2 (hash 'a 42 'res co))
+  (check-equal? (· h2 a) 42)
+  (check-equal? (· h2 b) 43)
+  (check-equal? (· co a) 42)
+  (check-equal? (· co b) 43))
 
 (define-macro (·map REF XS)
   #'(for/list ([x (in-list XS)]) (· x REF)))