FFI support for disjoint types

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

Re: FFI support for disjoint types

[Andy Wingo]

On Thu 11 Nov 2010 17:24, ludo@gnu.org (Ludovic Courtès) writes:

> (define-wrapped-pointer-type class?
>   wrap-class unwrap-class print-class)

Looks great! Would be a great addition to system foreign.

>        (with-syntax ((type-name (datum->syntax #'pred (gensym)))
>                      (%wrap     (datum->syntax #'wrap (gensym))))
>          #'(begin
>              (define-record-type type-name
>                (%wrap pointer)
>                pred
>                (pointer unwrap))

You wouldn't need to do the gensym dance if we fixed Andreas' bug
(https://savannah.gnu.org/bugs/?31472), I don't think...

Andy
-- 
http://wingolog.org/

Re: FFI support for disjoint types

[Ludovic Courtès]

Hi,

Andy Wingo <wingo@pobox.com> writes:

> On Thu 11 Nov 2010 17:24, ludo@gnu.org (Ludovic Courtès) writes:
>
>> (define-wrapped-pointer-type class?
>>   wrap-class unwrap-class print-class)
>
> Looks great! Would be a great addition to system foreign.

Though I realized that some people might want a similar thing that uses
GOOPS objects instead of raw structs.  Should we leave that to a
different macro or module?

Thanks,
Ludo’.

Re: FFI support for disjoint types

[Ludovic Courtès]

Hello!

ludo@gnu.org (Ludovic Courtès) writes:

> (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)))))))

I finally added the macro in (system foreign).

People looking for something similar with GOOPS capabilities can roll
their own.

Thanks,
Ludo’.