Hello World (FFI 1.0)

7 Hello World

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)