Hello World (FFI 1.0)

Next: GNU Free Documentation License, Previous: Compiling and Linking, Up: FFI

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

Next: GNU Free Documentation License, Previous: Compiling and Linking, Up: FFI