Next: GNU Free Documentation License, Previous: Compiling and Linking, Up: Top
This
node
includes the C declarations and Scheme code required to implement
Havoc Pennington's Hello World example from
GGAD. For an extra,
Schemely treat, its delete_event callback is a Scheme procedure
closed over a binding of counter that is used to implement some
impertinent behavior.
#| -*-Scheme-*-
This is Havoc Pennington's Hello World example from GGAD, in the raw
FFI. Note that no arrangements have been made to de-register the
callbacks. |#
(declare (usual-integrations))
(C-include "prhello")
(define (hello)
(C-call "gtk_init" 0 null-alien)
(let ((window (let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_window_new" alien
(C-enum "GTK_WINDOW_TOPLEVEL"))
(if (alien-null? alien) (error "Could not create window."))
alien))
(button (let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_button_new" alien)
(if (alien-null? alien) (error "Could not create button."))
alien))
(label (let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_label_new" alien "Hello, World!")
(if (alien-null? alien) (error "Could not create label."))
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)
(let ((counter 0))
(C-call "g_signal_connect" window "delete_event"
(C-callback "delete_event") ;trampoline
(C-callback ;callback ID
(lambda (w e)
(outf-error ";Delete me "(- 2 counter)" times.\n")
(set! counter (1+ counter))
;; Three or more is the charm.
(if (> counter 2)
(begin
(C-call "gtk_main_quit")
0)
1))))
(C-call "g_signal_connect" button "clicked"
(C-callback "clicked") ;trampoline
(C-callback ;callback ID
(lambda (w)
(let ((gstring (make-alien '(* |gchar|))))
(C-call "gtk_label_get_text" gstring label)
(let ((text (c-peek-cstring gstring)))
(C-call "gtk_label_set_text" label
(list->string (reverse! (string->list text))))))
unspecific))))
(C-call "gtk_widget_show_all" window)
(C-call "gtk_main")
window))
Here are the C declarations.
#| -*-Scheme-*-
C declarations for prhello.scm. |#
(typedef gint int)
(typedef guint uint)
(typedef gchar char)
(typedef gboolean gint)
(typedef gpointer (* mumble))
(extern void
gtk_init
(argc (* int))
(argv (* (* (* char)))))
(extern (* GtkWidget)
gtk_window_new
(type GtkWindowType))
(typedef GtkWindowType
(enum
(GTK_WINDOW_TOPLEVEL)
(GTK_WINDOW_POPUP)))
(extern (* GtkWidget)
gtk_button_new)
(extern (* GtkWidget)
gtk_label_new
(str (* (const char))))
(extern void
gtk_container_add
(container (* GtkContainer))
(widget (* GtkWidget)))
(extern void
gtk_window_set_title
(window (* GtkWindow))
(title (* (const gchar))))
(extern void
gtk_container_set_border_width
(container (* GtkContainer))
(border_width guint))
(extern void
gtk_widget_show_all
(widget (* GtkWidget)))
(extern void
g_signal_connect
(object (* GtkObject))
(name (* gchar))
(CALLBACK GtkSignalFunc)
(ID gpointer))
(typedef GtkSignalFunc (* mumble))
(callback gboolean
delete_event
(window (* GtkWidget))
(event (* GdkEventAny))
(ID gpointer))
(callback void
clicked
(widget (* GtkWidget))
(ID gpointer))
(extern void
gtk_widget_destroy
(widget (* GtkWidget)))
(extern (* (const gchar))
gtk_label_get_text
(label (* GtkLabel)))
(extern void
gtk_label_set_text
(label (* GtkLabel))
(str (* (const char))))
(extern void gtk_main)
(extern void gtk_main_quit)