FFI support for disjoint types

[Ludovic Courtès]

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’.