-;;; Type Generation
-
-(define-syntax define-type
- (lambda (x)
- (define (mk-string . args)
- (string-concatenate
- (map (lambda (a)
- (if (string? a)
- a
- (symbol->string (syntax->datum a))))
- args)))
- (define (mk-symbol . args)
- (datum->syntax x
- (string->symbol
- (apply mk-string args))))
- (syntax-case x ()
- ((_ name (field field-proc) ...)
- (with-syntax ((type? (mk-symbol #'name "?"))
- (wrap-type (mk-symbol "wrap-" #'name))
- (unwrap-type (mk-symbol "unwrap-" #'name))
- (output-string (mk-string "#<" #'name " ~x>"))
- (type-contents (mk-symbol #'name "-contents")))
- #'(begin
- (define-wrapped-pointer-type name
- type?
- wrap-type unwrap-type
- (lambda (x p)
- (format p output-string
- (pointer-address (unwrap-type x)))))
- (define (type-contents wrapped)
- (let ((unwrapped (unwrap-type wrapped)))
- (cond ((= (pointer-address unwrapped) 0)
- '())
- (else
- (filter
- (lambda (f)
- (not (null? (cdr f))))
- (list (cons 'field (field-proc unwrapped))
- ...))))))))))))
-
-
-(define (bv-uint-ref pointer index)
- (bytevector-uint-ref
- (pointer->bytevector pointer 4 index)
- 0
- (native-endianness)
- 4))
-
-(define* (get-pointer-of-pointers-procedure num-index root-index #:optional wrap-proc)
- (lambda (pointer)
- (let* ((num (bv-uint-ref pointer num-index))
- (rootp (make-pointer (bv-uint-ref pointer root-index))))
- (let loop ((i 0))
- (cond ((= i num)
- '())
- (else
- (let* ((p (make-pointer (bv-uint-ref rootp (* 4 i))))
- (wp (if wrap-proc (wrap-proc p) p)))
- (cons wp (loop (+ i 1))))))))))
-