Next: GNU Free Documentation License, Previous: Compiling and Linking, Up: FFI
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 (instance gpointer) (name (* gchar)) (CALLBACK GCallback) (ID gpointer)) (typedef GCallback (* 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)
Next: GNU Free Documentation License, Previous: Compiling and Linking, Up: FFI