You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
103 lines
4.2 KiB
Racket
103 lines
4.2 KiB
Racket
#lang restructure/racket
|
|
(provide (all-defined-out))
|
|
|
|
#|
|
|
approximates
|
|
https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
|
|
|#
|
|
|
|
(define-subclass object% (Pointer offset-type type [options (mhash)])
|
|
(when (eq? type 'void) (set! type #f))
|
|
(hash-ref! options 'type 'local)
|
|
(hash-ref! options 'allowNull #t)
|
|
(hash-ref! options 'nullValue 0)
|
|
(hash-ref! options 'lazy #f)
|
|
(define relative-getter-or-0 (or (ref options 'relativeTo) (λ (ctx) 0))) ; changed this to a simple lambda
|
|
|
|
(define/public (decode stream [ctx #f])
|
|
(define offset (send offset-type decode stream ctx))
|
|
(cond
|
|
;; handle NULL pointers
|
|
[(and (ref options 'allowNull) (= offset (ref options 'nullValue))) #f]
|
|
[else
|
|
(define relative (+ (caseq (ref options 'type)
|
|
[(local) (ref ctx '_startOffset)]
|
|
[(immediate) (- (· stream pos) (send offset-type size))]
|
|
[(parent) (ref* ctx 'parent '_startOffset)]
|
|
[else (let loop ([ctx ctx])
|
|
(cond
|
|
[(· ctx parent) => loop]
|
|
[(ref ctx '_startOffset)]
|
|
[else 0]))])
|
|
(relative-getter-or-0 ctx)))
|
|
(define ptr (+ offset relative))
|
|
(cond
|
|
;; omitted: lazy pointer implementation
|
|
[type (define orig-pos (· stream pos))
|
|
(send stream pos ptr)
|
|
(define val (send type decode stream ctx))
|
|
(send stream pos orig-pos)
|
|
val]
|
|
[else ptr])]))
|
|
|
|
|
|
(define/public (size [val #f] [ctx-in #f])
|
|
(define parent ctx-in)
|
|
(define ctx (caseq (ref options 'type)
|
|
[(local immediate) ctx-in]
|
|
[(parent) (· ctx-in parent)]
|
|
[(global) (let loop ([ctx ctx-in])
|
|
(cond
|
|
[(· ctx parent) => loop]
|
|
[else ctx]))]
|
|
[else (error 'unknown-pointer-type)]))
|
|
(unless type
|
|
(unless (VoidPointer? val)
|
|
(raise-argument-error 'Pointer:size "VoidPointer" val))
|
|
(set! type (ref val 'type))
|
|
(set! val (ref val 'value)))
|
|
(when (and val ctx)
|
|
(ref-set! ctx 'pointerSize (and (· ctx pointerSize)
|
|
(+ (· ctx pointerSize) (send type size val parent)))))
|
|
(send offset-type size))
|
|
|
|
|
|
(define/public (encode stream val [ctx #f])
|
|
(define parent ctx)
|
|
(define relative #f)
|
|
(cond
|
|
[(not val)
|
|
(send offset-type encode stream (ref options 'nullValue))]
|
|
[else
|
|
(caseq (ref options 'type)
|
|
[(local) (set! relative (ref ctx 'startOffset))]
|
|
[(immediate) (set! relative (+ (· stream pos) (send offset-type size val parent)))]
|
|
[(parent) (set! ctx (ref ctx 'parent))
|
|
(set! relative (ref ctx 'startOffset))]
|
|
[(global) (set! relative 0)
|
|
(set! ctx (let loop ([ctx ctx])
|
|
(cond
|
|
[(ref ctx 'parent) => loop]
|
|
[else ctx])))]
|
|
[else (error 'unknown-pointer-type)])
|
|
|
|
(increment! relative (relative-getter-or-0 (ref parent 'val)))
|
|
(send offset-type encode stream (- (ref ctx 'pointerOffset) relative))
|
|
|
|
(define type_ type)
|
|
(unless type_
|
|
(unless (VoidPointer? val)
|
|
(raise-argument-error 'Pointer:encode "VoidPointer" val))
|
|
|
|
(set! type (ref val 'type))
|
|
(set! val (ref val 'value)))
|
|
|
|
(ref-set! ctx 'pointers (append (ref ctx 'pointers) (list (mhash 'type type
|
|
'val val
|
|
'parent parent))))
|
|
(ref-set! ctx 'pointerOffset (+ (ref ctx 'pointerOffset) (send type size val parent)))])))
|
|
|
|
|
|
;; A pointer whose type is determined at decode time
|
|
(define-subclass object% (VoidPointer type value))
|