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.
typesetting/pitfall/restructure/pointer.rkt

90 lines
3.9 KiB
Racket

#lang restructure/racket
(provide (all-defined-out))
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
|#
(define (resolve-void-pointer type val)
(cond
[type (values type val)]
[(VoidPointer? val) (values (· val type) (· val value))]
[else (raise-argument-error 'Pointer:size "VoidPointer" val)]))
(define (find-top-ctx ctx)
(cond
[(· ctx parent) => find-top-ctx]
[else ctx]))
(define-subclass object% (Pointer offset-type type-in [options (mhasheq)])
(field [type (and (not (eq? type-in 'void)) type-in)])
(define pointer-style (or (· options type) 'local))
(define allow-null (or (· options allowNull) #t))
(define null-value (or (· options nullValue) 0))
(define lazy (· options lazy))
(define relative-getter-or-0 (or (· 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
[(and allow-null (= offset null-value)) #f] ; handle null pointers
[else
(define relative (+ (caseq pointer-style
[(local) (· ctx _startOffset)]
[(immediate) (- (· stream pos) (send offset-type size))]
[(parent) (· ctx parent _startOffset)]
[(global) (or (· (find-top-ctx ctx) _startOffset) 0)]
[else (error 'unknown-pointer-style)])
(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 #f])
(let*-values ([(parent) ctx]
[(ctx) (caseq pointer-style
[(local immediate) ctx]
[(parent) (· ctx parent)]
[(global) (find-top-ctx ctx)]
[else (error 'unknown-pointer-style)])]
[(type val) (resolve-void-pointer type val)])
(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])
(if (not val)
(send offset-type encode stream null-value)
(let* ([parent ctx]
[ctx (caseq pointer-style
[(local immediate) ctx]
[(parent) (· ctx parent)]
[(global) (find-top-ctx ctx)]
[else (error 'unknown-pointer-style)])]
[relative (+ (caseq pointer-style
[(local parent) (· ctx startOffset)]
[(immediate) (+ (· stream pos) (send offset-type size val parent))]
[(global) 0])
(relative-getter-or-0 (· parent val)))])
(send offset-type encode stream (- (· ctx pointerOffset) relative))
(let-values ([(type val) (resolve-void-pointer type val)])
(ref-set! ctx 'pointers (append (· ctx pointers) (list (mhasheq 'type type
'val val
'parent parent))))
(ref-set! ctx 'pointerOffset (+ (· ctx pointerOffset) (send type size val parent))))))))
;; A pointer whose type is determined at decode time
(define-subclass object% (VoidPointer type value))