First cut at TXR Lisp port.

5 files changed, 144 insertions, 7 deletions

diff --git a/demo2 b/demo2
index f199075..cd757ce 100755
--- a/demo2
+++ b/demo2
@@ -17,13 +17,13 @@
 (defparameter numar 'a)  ;  'r = I II II IV V.  'a = 1 2 3 4 5.
 
 ; Button number (bn) and button number text (bnt):
-(defun bn (n) (nth (1- n) '(11 22 33 44 55)))
+(defun bn (n) (nth (pred n) '(11 22 33 44 55)))
 (defun bnt (n) (format nil (if (eq numar 'a) "~d" "~@R") (bn n)))
 
 (defun togglenumar ()
-  (setq numar (if (eq numar 'a) 'r 'a))
-  (loop as button in (list b21 b22 b23 b24 b25)
-        as n from 1 to 5
-        do (xlabel button (bnt n))))
+  (set numar (if (eq numar 'a) 'r 'a))
+  (each ((button (list b21 b22 b23 b24 b25))
+         (n (range 1 5)))
+    (xlabel button (bnt n))))
 
 (defun xnum (n) (xtext num2 (format nil "~R" n)))
diff --git a/demo3 b/demo3
index 760857c..d2ec257 100755
--- a/demo3
+++ b/demo3
@@ -13,6 +13,6 @@
 
 (defun relabel (button number)
   (let* ((old (gtk_button_get_label button))
-         (isdigits (<= 0 (- (char-int (aref old 0)) (char-int #\0)) 9))
+         (isdigits (<= 0 (- (chr-int [old 0]) (chr-int #\0)) 9))
          (new (format nil (if isdigits "~@R" "~d") number)))
     (xlabel button new)))
diff --git a/demostuff.tl b/demostuff.tl
new file mode 100644
index 0000000..4ec23ab
--- /dev/null
+++ b/demostuff.tl
@@ -0,0 +1,124 @@
+(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))))
+
+(defmacro defparameter (name val) ^(defparm ,name ,val))
diff --git a/makesans.tl b/makesans.tl
new file mode 100755
index 0000000..bef6fc3
--- /dev/null
+++ b/makesans.tl
@@ -0,0 +1,13 @@
+#!/usr/bin/env txr
+
+; This script, makesans, uses sbcl to make sanssbcl, which can then
+; be copied to a Linux PC that doesn't have sbcl.
+
+(defun load-and-go ()
+  (load "demostuff.tl")
+  (load "menu")
+  (each ((i (range 1 9)))
+    (load `demo@i`))
+  (menu))
+
+(load-and-go)
diff --git a/menu b/menu
index 946ee42..a0d3dff 100755
--- a/menu
+++ b/menu
@@ -15,5 +15,5 @@
     (mbutton dodemo8 "de minimis"       mainbox (demo8))
     (mbutton dodemo9 "de minimis"       mainbox (demo9))
     (gtk_widget_show_all win))
-  (g_application_run demos 0 nil)
+  (g_application_run demos 0 null)
   (g_object_unref demos))