[MIT-Scheme-devel] GTk+ in MIT-Scheme?

[Matt Birkholz]

> From: Matt Birkholz <address@hidden>
> Date: Wed, 30 Mar 2005 21:50:37 +0100
> 
> > [...]
> 
> I heard a rumor someone was working on a Foreign Function Interface.
> Does anyone want to 'fess up?  How about just a Foreign Struct
> Interface?

Whoa.  Did you just see 6 months go by... ?  Anyway, it is well nigh
time to expose myself to my fellow MIT-Scheme developers...  weee.

So the FFI is coming along well, thanks for asking. :)

I had a simple GTk+ hello world program working, without callbacks.
Shouldda tooka snapshot.  I could not help fiddling with the callback
support.  My asynchronous callbacks were tiresome -- a C struct for
the C args, a callback trampoline to enqueue the "request", a
marshaller to cons the C args in the Scheme heap...  And what about
toolkits that depend on intelligent return values from the callback
(e.g. a callback that will be a predicate in a sort process)?

The siren of synchronous callbacks calls to me.

> Wrapping up GdkRectangle in 5 or 6 primitives was so much fun I had
> to stop and consider writing a simple Foreign Struct Interface. [...]
> I just want a few primitives that take a foreign pointer and a member
> offset and burp up a string/integer/float/pointer.

That got done.  I hope I do not find out why Elk, Scheme->C, many
others, were shy of member offset forecasting.  They generated a pair
of reader/writer primitives for each member of a struct and let the C
compiler figure the offsets.  Are there many systems where the layout
of struct members is too subtle for Mere Mortals to predict?

Perhaps if they had the prospect of open-coding these primitives, they
would have lead the way.

Here is my evolving "Hello, world!" program.  It stays REALLY close to
the metal.  All pointers into non-heap memory are encapsulated in
"aliens".  No C-array->list-like utilities are provided, but you can
walk the C array by incrementing an alien.  I would rather write a
C-array->list utility in Scheme, not generate it in C.  So this is a
little ugly without the fairings and nacelles.  Once wrapped up, this
can be just as tight as it was 6 months ago.

(load-option 'FFI)
(C-include "prhello" "hello-cdecl")
(C-generate-trampolines)

(define (hello)
  (let* ((window (let ((alien (make-alien '|GtkWidget|)))
                   (C-call "gtk_window_new" alien
                           (C-enum "GtkWindowType GTK_WINDOW_TOPLEVEL"))
                   alien))
         (button (let ((alien (make-alien '|GtkWidget|)))
                   (C-call "gtk_button_new" alien)
                   alien))
         (label (let ((alien (make-alien '|GtkWidget|)))
                  (C-call "gtk_label_new" alien "Hello, world!")
                  alien)))
    (C-call "gtk_container_add" button label)
    (C-call "gtk_container_add" window button)
    (C-call "gtk_window_set_title" window "Hello")
    (C-call "gtk_container_set_border_width" button 10)
    (C-call "g_signal_connect" window "delete_event" 
            (C-callback "delete_event") ;trampoline
            (C-callback                 ;callback ID
             (lambda (window event)
               event
               (C-call "gtk_widget_destroy" window))))
    (C-call "g_signal_connect" button "clicked"
            (C-callback "clicked")      ;trampoline
            (C-callback                 ;callback ID
             (lambda (widget)
              (let ((text (C-call "gtk_label_get_text" widget)))
                (C-call "gtk_label_set_text" widget
                        (list->string (reverse! (string->list text))))))))
    (C-call "gtk_widget_show_all" window))
  unspecific)

The C declarations are separate, e.g. in this case-sensitive Scheme
file.

(typedef gchar char)
(typedef gint int)
(typedef guint uint)
(typedef gpointer (* mumble))

(extern (* GtkWidget)                   ;gtk+-2.4.0/gtk/gtkwindow.h
        gtk_window_new
        (type GtkWindowType))

(typedef GtkWindowType                  ;gtk+-2.4.0/gtk/gtkenums.h
         (enum
          (GTK_WINDOW_TOPLEVEL)
          (GTK_WINDOW_POPUP)))

(extern (* GtkWidget)                   ;gtk+-2.4.0/gtk/gtkbutton.h
        gtk_button_new)

(extern (* GtkWidget)                   ;gtk+-2.4.0/gtk/gtklabel.h
        gtk_label_new
        (text (* char)))

(extern void                            ;gtk+-2.4.0/gtk/gtkcontainer.h
        gtk_container_add
        (container (* GtkContainer))
        (widget    (* GtkWidget)))

(extern void                            ;gtk+-2.4.0/gtk/gtkwindow.h
        gtk_window_set_title
        (window (* GtkWindow))
        (title  (* char)))

(extern void                            ;gtk+-2.4.0/gtk/gtkcontainer.h
        gtk_container_set_border_width
        (container (* GtkContainer))
        (border_width guint))

(extern void                            ;gtk+-2.4.0/gtk/gtkwidget.h
        gtk_widget_show_all
        (widget (* GtkWidget)))

(extern void                            ;glib-2.6.3/gobject/gsignal.h
        g_signal_connect
        (object (* GtkObject))
        (name (* gchar))
        (CALLBACK GtkSignalFunc)
        (ID gpointer))

(typedef GtkSignalFunc (* mumble))

(callback gint
          delete_event
          (window (* GtkWidget))
          (event (* GdkEventAny))
          (ID gpointer))

(callback void
          clicked
          (widget (* GtkWidget))
          (ID gpointer))

(extern void                            ;gtk+-2.4.0/gtk/gtkwidget.h
        gtk_widget_destroy
        (widget (* GtkWidget)))

(extern (* gchar)                       ;gtk+-2.4.0/gtk/gtklabel.h
        gtk_label_get_text
        (label (* GtkLabel)))

(extern void                            ;gtk+-2.4.0/gtk/gtklabel.h
        gtk_label_set_text
        (label (* GtkLabel))
        (str (* char)))