1#| -*-Scheme-*-
2
3This is Havoc Pennington's Hello World example from GGAD, in the raw
4FFI.  Note that no arrangements have been made to de-register the
5callbacks. |#
6
7(declare (usual-integrations))
8
9(C-include "prhello")
10
11(define (hello)
12  (C-call "gtk_init" 0 null-alien)
13  (let ((window (let ((alien (make-alien '|GtkWidget|)))
14		  (C-call "gtk_window_new" alien
15			  (C-enum "GTK_WINDOW_TOPLEVEL"))
16		  (if (alien-null? alien) (error "Could not create window."))
17		  alien))
18	(button (let ((alien (make-alien '|GtkWidget|)))
19		  (C-call "gtk_button_new" alien)
20		  (if (alien-null? alien) (error "Could not create button."))
21		  alien))
22	(label (let ((alien (make-alien '|GtkWidget|)))
23		 (C-call "gtk_label_new" alien "Hello, World!")
24		 (if (alien-null? alien) (error "Could not create label."))
25		 alien)))
26    (C-call "gtk_container_add" button label)
27    (C-call "gtk_container_add" window button)
28    (C-call "gtk_window_set_title" window "Hello")
29    (C-call "gtk_container_set_border_width" button 10)
30    (let ((counter 0))
31      (C-call "g_signal_connect" window "delete_event"
32	      (C-callback "delete_event")	;trampoline
33	      (C-callback			;callback ID
34	       (lambda (w e)
35		 (outf-error ";Delete me "(- 2 counter)" times.\n")
36		 (set! counter (1+ counter))
37		 ;; Three or more is the charm.
38		 (if (> counter 2)
39		     (begin
40		       (C-call "gtk_main_quit")
41		       0)
42		     1))))
43      (C-call "g_signal_connect" button "clicked"
44	      (C-callback "clicked")	;trampoline
45	      (C-callback			;callback ID
46	       (lambda (w)
47		 (let ((gstring (make-alien '(* |gchar|))))
48		   (C-call "gtk_label_get_text" gstring label)
49		   (let ((text (c-peek-cstring gstring)))
50		     (C-call "gtk_label_set_text" label
51			     (list->string (reverse! (string->list text))))))
52		 unspecific))))
53    (C-call "gtk_widget_show_all" window)
54    (C-call "gtk_main")
55    window))