Hello!
I’ve used the macro below in a couple of projects. It allows the
creation of disjoint Scheme types for disjoint C pointer types, and
takes care of preserving eq?-ness for equal C pointers.
Example:
--8<---------------cut here---------------start------------->8---
;; Create a wrapped pointer type `class?'.
(define-wrapped-pointer-type class?
wrap-class unwrap-class print-class)
(define lookup-class
(let ((f (libchop-function '* "class_lookup" ('*))))
(lambda (name)
(let ((ptr (f (string->pointer name))))
(if (null-pointer? ptr)
#f
;; Wrap the object pointer so that it appears as an object
;; that matches `class?' at the Scheme level.
(wrap-class ptr))))))
(define (class-name c)
;; C is a `class?' object, so unwrap it to get the underlying
;; pointer.
(let ((ptr (make-pointer (+ (pointer-address (unwrap-class c))
%offset-of-name))))
(pointer->string (dereference-pointer ptr))))
--8<---------------cut here---------------end--------------->8---
Code:
--8<---------------cut here---------------start------------->8---
(define-syntax define-wrapped-pointer-type
(lambda (stx)
(syntax-case stx ()
((_ pred wrap unwrap print) ;; hygiene
(with-syntax ((type-name (datum->syntax #'pred (gensym)))
(%wrap (datum->syntax #'wrap (gensym))))
#'(begin
(define-record-type type-name
(%wrap pointer)
pred
(pointer unwrap))
(define wrap
;; Use a weak hash table to preserve pointer identity, i.e.,
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table)))
(lambda (ptr)
(or (hash-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
o)))))
(set-record-type-printer! type-name print))))
((_ type-name print) ;; lazyness
(let* ((type-name* (syntax->datum #'type-name))
(pred-name (datum->syntax #'type-name
(symbol-append type-name* '?)))
(wrap-name (datum->syntax #'type-name
(symbol-append 'wrap- type-name*)))
(%wrap-name (datum->syntax #'type-name
(symbol-append '%wrap- type-name*)))
(unwrap-name (datum->syntax #'type-name
(symbol-append 'unwrap-
type-name*))))
(with-syntax ((pred pred-name)
(wrap wrap-name)
(%wrap %wrap-name)
(unwrap unwrap-name))
#'(define-wrapped-pointer-type pred wrap unwrap print)))))))
--8<---------------cut here---------------end--------------->8---
The second pattern in the macro is convenient but unhygienic, so I’m
inclined to remove it.
Thoughts?
What about adding it to (system foreign), along with documentation?
Thanks,
Ludo’.
