1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
#|
This file of "demostuff", used by the demo scripts, loads Gtk
and defines gapp, window, box, button, text, xtext, and xlabel.
gapp Establishes a Gtk app. Its arguments are the app name
and the code to be executed in the app.
window Establishes a window. Its arguments are the name of
the window object, the name of the app the window is
used in, the window title, and the default width and
height of the window.
box Establishes a box to place Gtk objects in. Its three
arguments are, first, h or v, for whether the contents
of the box are to be organized horizontally or
vertically, second, what box to establish, and third,
what object the box is to be placed in.
button Establishes a button. Its arguments are, what button
to establish, the initial label text on the button,
the object the button is to be placed in, and the code
to be executed when the button is pressed.
mbutton Is like button, except the button label text will be
left-aligned instead of centered. It's for use in a
column of buttons, such as a menu, where it might look
neater to not center the button labels.
text Establishes a text display object, which Gtk calls a
label. Its arguments are the name of the text object,
the initial text, and what object to place the text
object in.
xtext Is a function to display some text in a text object.
Its arguments are what text object to display the text
in, and what text to display.
xlabel Is a function to update a button label. Its arguments
are the button and the new text.
|#
(load-shared-object "libgtk-3.so.0")
; Gtk relies on being able to divide by zero. To prevent it from
; being an error, the following line changes the floating point
; errors to just overflow and invalid, and not division-by-zero.
; This isn't needed in most programming languages, because most
; of them default to having it not be an error.
(sb-int:set-floating-point-modes :traps '(:overflow :invalid))
; Gtk function prototypes: each has a code, such as xx or vxs. The
; first letter of the code is the return value type, and the rest are
; the argument types:
; v = void
; x = void*
; i = int
; l = long
; f = float
; d = double
; s = c-string
; y = vxx function
(loop as (gfunc xx) in
'((gtk_application_window_new xx)
(gtk_window_set_title vxs)
(gtk_window_set_default_size vxii)
(gtk_button_box_new xi)
(gtk_size_group_new xi)
(gtk_bin_get_child xx)
(gtk_label_set_xalign vxf)
(gtk_container_add vxx)
(gtk_label_new xs)
(gtk_label_set_text vxs)
(gtk_button_set_label vxs)
(gtk_button_get_label sx)
(gtk_button_new_with_label xs)
(gtk_widget_destroy xx)
(gtk_application_new xsi)
(g_application_run ixix)
(g_object_unref vx)
(gtk_widget_show_all vx)
(g_signal_connect_data lxsyxxi))
as types = (loop as x across (string xx)
collect (ecase (char-downcase x)
(#\v 'void)
(#\x '(* t))
(#\i 'int)
(#\l 'long)
(#\f 'float)
(#\d 'double)
(#\s 'c-string)
(#\y '(function void (* t) (* t)))))
as rv = (car types)
as args = (loop as argname in '(a b c d e f g h i j k l m)
as argtype in (cdr types)
collect (list argname argtype))
do (eval `(define-alien-routine ,gfunc ,rv ,@args)))
; callbackname makes a callback name from an object name.
; The eval-when makes it usable during macro expansions.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun callbackname (object)
(intern (concatenate 'string (symbol-name object) "-CALLBACK"))))
; 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)
(eval `(defparameter ,awin nil))
`(progn
(setf ,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)
(eval `(defparameter ,abox nil))
(let ((horizvert (case hv (h 0) (v 1) (t (error
"The first argument to box should be h or v, not ~a" hv)))))
`(progn
(setf ,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 body)
(eval `(defparameter ,abutton nil))
(let ((cb (callbackname abutton)))
(eval `(sb-alien::define-alien-callback
,cb void ((a (* t)) (b (* t)))
(declare (ignore a b))
,@body))
`(progn
(setf ,abutton (gtk_button_new_with_label ,buttonlabel))
(g_signal_connect_data ,abutton "clicked" ,cb nil nil 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 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)
(eval `(defparameter ,atext nil))
`(progn
(setf ,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 body)
(eval `(defparameter ,theapp nil))
(let ((cb (callbackname theapp)))
(eval `(sb-alien::define-alien-callback
,cb void ((a (* t)) (b (* t)))
(declare (ignore a b))
,@body))
`(progn
(setf ,theapp (gtk_application_new nil 0))
(g_signal_connect_data ,theapp "activate" ,cb nil nil 0))))
; End of the demostuff file, which gets loaded by each demo script.
|
