[Openmcl-devel] Gtk "Hello, world" example in OpenMCL

[Andrew P. Lentvorski, Jr.]

Folks,

Here is a sample program which creates a button inside a Gtk window an 
responds to button presses with "Hello, world."  It uses only the 
standard foreign function call interfaces.

Please critique this as I would like to get it added to the 
documentation, but I don't know enough to be able to validate whether I 
am doing things well/correctly.

Thanks,
-a

;; File "hello-gtk.lisp"
;;
;; To execute, do a (load "hello-gtk.lisp) at the mcl prompt.

;; Open required libraries
;; Change this to whatever path is required for your machine

(open-shared-library "/home/devel/lib/libgtk-x11-2.0.0.dylib")


;; Helper functions for heap allocation

;; The ivector functions should be placed into a library

;; make-heap-ivector courtesy of Gary Byers
(defun make-heap-ivector (element-count element-type)
   (let* ((subtag (ccl::element-type-subtype element-type)))
     (unless (= (logand subtag target::fulltagmask)
                target::fulltag-immheader)
       (error "~s is not an ivector subtype." element-type))
     (let* ((size-in-bytes (ccl::subtag-bytes subtag element-count)))
       (ccl::%make-heap-ivector subtag size-in-bytes element-count))))

;; dispose-heap-ivector created for symmetry
(defmacro dispose-heap-ivector (a mp)
   `(progn
      (ccl::%dispose-heap-ivector ,a)
      ;; Demolish the arguments for safety
      (setf ,a nil)
      (setf ,mp nil)))

(defun make-string-ivector (s)
   (let ((slen (length s)))
     (multiple-value-bind (sa sap)
	(make-heap-ivector (+ slen 1) 'character)
       (dotimes (i slen)
	(setf (aref sa i) (aref s i)))
       (setf (aref sa slen) '#\Null)
       (values sa sap))))

(defun gtk-init ()
   ;; Do argc and argv need to be (declare (dynamic-extent argc)) ?

   ;; There has *got* to be a better way to do this
   (multiple-value-bind (argc argc-ptr)
       (make-heap-ivector 1 '(unsigned-byte 32))
     ;; This allocates the character (To be set to null)
     (multiple-value-bind (argv argv-ptr)
	(make-heap-ivector 1 '(unsigned-byte 8))
       ;; This allocates the pointer to the character
       (multiple-value-bind (argvp argvp-ptr)
	  (make-heap-ivector 1 '(unsigned-byte 32))
	;; Set call for no incoming arguments
	(setf (aref argc 0) 0)
	;; Set incoming string to null character
	(setf (aref argv 0) 0)
	;; Set pointer to incoming string
	(setf (aref argvp 0) (ccl::%ptr-to-int argv-ptr))

	;; Finally.  Call the function.
	(external-call "_gtk_init" :address argc-ptr :address argvp-ptr :void)

	;; Check the returns and do something with them if you want

	;; Deallocate memory
	(dispose-heap-ivector argvp argvp-ptr))
       (dispose-heap-ivector argv argv-ptr))
     (dispose-heap-ivector argc argc-ptr)))

(defun gtk-poll ()
   (do* ()
       ((eql (external-call "_gtk_events_pending" :signed-long) 0) nil)
     (external-call "_gtk_main_iteration" :signed-long)))

;; This is an enum from the gtkenums.h file
(setq *gtk-window-toplevel* 0)

(gtk-init)
(setq window (external-call "_gtk_window_new" :signed-int 
*gtk-window-toplevel* :address))

(setq button-label '"Hello")

(multiple-value-bind (la lap)
     (make-string-ivector button-label)
   (setq bla la)
   (setq blap lap))

(setq button (external-call "_gtk_button_new_with_label" :address blap 
:address))

(external-call "_gtk_container_add" :address window :address button 
:void)

(external-call "_gtk_widget_show" :address button :void)
(external-call "_gtk_widget_show" :address window :void)

(defcallback hello-callback (:address widget :address data :void)
   (format t "Hello, world."))

(setq clicked-string '"clicked")

(multiple-value-bind (la lap)
     (make-string-ivector clicked-string)
   (setq clicked-array la)
   (setq clicked-pointer lap))

(setq null (ccl:%int-to-ptr 0))

;; g_signal_connect is a C preprocessor macro so use
;; the underlying "_g_signal_connect_data" call
(external-call "_g_signal_connect_data"
	       :address button :address clicked-pointer
	       :address hello-callback :address null
	       :address null :signed 0 :unsigned)

(ccl::%install-periodic-task 'gtk-task #'gtk-poll 10)