1 files changed, 122 insertions, 0 deletions
diff --git a/gtkffi.tl b/gtkffi.tl
new file mode 100644
index 0000000..faad59f
--- /dev/null
+++ b/gtkffi.tl
@@ -0,0 +1,122 @@
+(defun letter-to-type (ch)
+  (caseql ch
+    (#\v 'void)
+    (#\x 'cptr)
+    (#\i 'int)
+    (#\l 'long)
+    (#\f 'float)
+    (#\d 'double)
+    (#\s 'str)
+    (#\y 'closure)))
+
+(defmacro df (name sig)
+  (let ((si (list-str (symbol-name sig))))
+    ^(deffi ,name ,(symbol-name name) ,(letter-to-type (car si))
+       ,[mapcar letter-to-type (cdr si)])))
+
+(with-dyn-lib "libgtk-3.so.0"
+  (df gtk_application_window_new  xx)
+  (df gtk_window_set_title        vxs)
+  (df gtk_window_set_default_size vxii)
+  (df gtk_button_box_new          xi)
+  (df gtk_size_group_new          xi)
+  (df gtk_bin_get_child           xx)
+  #;(df gtk_label_set_xalign        vxf)
+  (df gtk_container_add           vxx)
+  (df gtk_label_new               xs)
+  (df gtk_label_set_text          vxs)
+  (df gtk_button_set_label        vxs)
+  (df gtk_button_get_label        sx)
+  (df gtk_button_new_with_label   xs)
+  (df gtk_widget_destroy          xx)
+  (df gtk_application_new         xsi)
+  (df g_application_run           ixix)
+  (df g_object_unref              vx)
+  (df gtk_widget_show_all         vx)
+  (df g_signal_connect_data       lxsyxxi))
+
+(deffi-cb button-cb void (cptr cptr))
+
+(deffi-cb app-cb void (cptr cptr))
+
+(defsymacro null cptr-null)
+
+(defun callbackname (object)
+  (make-sym `@object-cb`))
+
+; window establishes a Gtk window object.
+; The arguments are, what window object to establish, what
+; application the window is used in, the window title, and
+; the width and height of the window.
+(defmacro window (awin app title wid ht)
+  ^(progn
+     (defparm ,awin (gtk_application_window_new ,app))
+     (gtk_window_set_title ,awin ,title)
+     (gtk_window_set_default_size ,awin ,wid ,ht)))
+
+; box establishes a box object.  The arguments are, whether the box
+; contents are organized horizontally or vertically (h or v), what
+; box is to be established, and what object to place the box in.
+(defmacro box (hv abox placement)
+  (let ((horizvert (caseql hv
+                     (h 0) (v 1)
+                     (t (error "The first argument to box should \
+                               \ be h or v, not ~a" hv)))))
+    ^(progn
+       (defparm ,abox nil)
+       (progn
+         (set ,abox (gtk_button_box_new ,horizvert))
+         (gtk_container_add ,placement ,abox)))))
+
+; button establishes a Gtk button object.  The arguments are,
+; the name of the button object, the text shown on the button,
+; what object to place the button in, and the action of the
+; button, which can be any sequence of code.
+(defmacro button (abutton buttonlabel placement . body)
+  (let ((cb (callbackname abutton)))
+    ^(progn
+       (defparm ,abutton nil)
+       (defun ,cb (a b)
+         ,*body)
+       (set ,abutton (gtk_button_new_with_label ,buttonlabel))
+       (g_signal_connect_data ,abutton "clicked" [button-cb ,cb]
+                              null null 0)
+       (gtk_container_add ,placement ,abutton))))
+
+; mbutton is like button, except that the button label text will be
+; left aligned instead of centered, to make it neater in a column of
+; buttons, such as for a menu.
+(defmacro mbutton (abutton buttonlabel placement . body)
+  ^(progn
+     (button ,abutton ,buttonlabel ,placement ,*body)
+     (let ((thelabel (gtk_bin_get_child ,abutton)))
+       #;(gtk_label_set_xalign thelabel 0.0))))
+
+; text establishes a Gtk "label" object which is actually a text
+; display object.  The arguments are, what text object to
+; establish, the initial text to display, and what object to
+; place this text object in.
+(defmacro text (atext text0 placement)
+  ^(progn
+     (defparm ,atext (gtk_label_new ,text0))
+     (gtk_container_add ,placement ,atext)))
+
+; xtext changes the text in a text object.
+(defun xtext (textobject newtext)
+  (gtk_label_set_text textobject newtext))
+
+; xlabel changes the text label on a button.
+(defun xlabel (button newtext)
+  (gtk_button_set_label button newtext))
+
+; gapp establishes a Gtk application.  The arguments are,
+; the name of the application object, and the code to be
+; executed by the application.
+(defmacro gapp (theapp . body)
+  (let ((cb (callbackname theapp)))
+    ^(progn
+       (defparm ,theapp nil)
+       (defun ,cb (a b)
+         ,*body)
+       (set ,theapp (gtk_application_new nil 0))
+       (g_signal_connect_data ,theapp "activate" [app-cb ,cb] null null 0))))