Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv11104/gtk-ffi

Modified Files: gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-menu.lisp gtk-other.lisp gtk-utilities.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:02:05 2004 Author: ktilton

Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.4 root/gtk-ffi/gtk-ffi.asd:1.5 --- root/gtk-ffi/gtk-ffi.asd:1.4 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.asd Tue Dec 14 05:02:05 2004 @@ -1,6 +1,6 @@ (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells :uffi :ffi-extender) + :depends-on (:cells :hello-c) :components ((:file "gtk-ffi") (:file "gtk-core" :depends-on ("gtk-ffi"))

Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.4 root/gtk-ffi/gtk-ffi.lisp:1.5 --- root/gtk-ffi/gtk-ffi.lisp:1.4 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.lisp Tue Dec 14 05:02:05 2004 @@ -126,8 +126,7 @@ collect `(if ,(car arg) 1 0) into pass-args else if (eql 'c-pointer (cadr arg)) collect `(or ,(car arg) c-null) into pass-args - else - collect (car arg) into pass-args + else collect (car arg) into pass-args finally (return (list (mapcar 'list gsyms arg$s) pass-args))))) `(progn @@ -149,8 +148,9 @@ (if (eql return-type 'boolean) `(not (zerop ,bodyform)) bodyform)) - (print (list ,(symbol-name name) :after - ,@(mapcar 'car arguments))))) + (when *gtk-debug* + (print (list ,(symbol-name name) :after + ,@(mapcar 'car arguments)))))) (eval-when (compile load eval) (export ',name))))))

@@ -305,6 +305,10 @@ (type long) (val double-float) (val2 double-float)) + +(def-c-struct gslist + (data c-pointer) + (next c-pointer))

(def-c-struct gtk-tree-iter (stamp int)

Index: root/gtk-ffi/gtk-ffi.lpr diff -u root/gtk-ffi/gtk-ffi.lpr:1.2 root/gtk-ffi/gtk-ffi.lpr:1.3 --- root/gtk-ffi/gtk-ffi.lpr:1.2 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.lpr Tue Dec 14 05:02:05 2004 @@ -7,13 +7,15 @@ (define-project :name :gtk-ffi :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "gtk-ffi.lisp") - (make-instance 'module :name "gtk-definitions.lisp") - (make-instance 'module :name "gtk-lib-gtk.lisp") + (make-instance 'module :name "gtk-core.lisp") + (make-instance 'module :name "gtk-button.lisp") + (make-instance 'module :name "gtk-list-tree.lisp") + (make-instance 'module :name "gtk-menu.lisp") + (make-instance 'module :name "gtk-tool.lisp") + (make-instance 'module :name "gtk-other.lisp") (make-instance 'module :name "gtk-utilities.lisp")) :projects (list (make-instance 'project-module :name - "c:\000000\uffi\uffi") - (make-instance 'project-module :name - "c:\cell-cultures\ffi-extender\ffi-extender")) + "c:\cell-cultures\hello-c\hello-c")) :libraries nil :distributed-files nil :project-package-name :gtk-ffi

Index: root/gtk-ffi/gtk-menu.lisp diff -u root/gtk-ffi/gtk-menu.lisp:1.1 root/gtk-ffi/gtk-menu.lisp:1.2 --- root/gtk-ffi/gtk-menu.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-menu.lisp Tue Dec 14 05:02:05 2004 @@ -18,6 +18,17 @@

(in-package :gtk-ffi)

+(def-gtk-function :gtk gtk-check-menu-item-set-active :arguments + ((check-menu c-pointer) (active boolean)) + :return-type nil :call-direct t) + +#+test +(def-gtk-lib-functions :gtk + (gtk-check-menu-item-set-active ((check-menu c-pointer) + (active boolean)))) + + + (def-gtk-lib-functions :gtk ;;menu (gtk-menu-shell-append ((menu-shell c-pointer) @@ -76,7 +87,7 @@ c-pointer) (gtk-check-menu-item-new-with-label ((label c-string)) c-pointer) - (gtk-check-menu-item-set-active ((check-menu c-pointer) + #+above (gtk-check-menu-item-set-active ((check-menu c-pointer) (active boolean))) (gtk-check-menu-item-get-active ((check-menu c-pointer)) boolean)

Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.1 root/gtk-ffi/gtk-other.lisp:1.2 --- root/gtk-ffi/gtk-other.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-other.lisp Tue Dec 14 05:02:05 2004 @@ -18,6 +18,7 @@

(in-package :gtk-ffi)

+ (def-gtk-lib-functions :gtk ;; main-loop (gtk-init ((argc (c-ptr-null int))

Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.2 root/gtk-ffi/gtk-utilities.lisp:1.3 --- root/gtk-ffi/gtk-utilities.lisp:1.2 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-utilities.lisp Tue Dec 14 05:02:05 2004 @@ -20,6 +20,7 @@ (in-package :gtk-ffi)

(defun gtk-signal-connect (widget signal fun &key (after t) data destroy-data) + #+shhtk (print (list "passing fun to gtk-signal-connect" signal fun)) (g-signal-connect-data widget signal fun data destroy-data after))

(defun g-signal-connect-data (self detailed-signal c-handler data destroy-data after) @@ -28,9 +29,7 @@ (g_signal_connect_data self c-detailed-signal - (if c-handler - (uffi:make-pointer c-handler '(* :void)) - c-null) + (wrap-func c-handler) p4 (or destroy-data c-null) (if after 1 0))))) @@ -40,9 +39,17 @@ (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil)

+(defun wrap-func (func-address) + (or func-address 0) + ;;(assert (or (null func-address) (numberp func-address))) + #+nahh + (if func-address + (uffi:make-pointer func-address '(* :void)) + c-null)) + (defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data) (g-signal-connect-closure widget signal - (g-cclosure-new-swap fun data destroy-data) after)) + (g-cclosure-new-swap (wrap-func fun) data destroy-data) after))

(defun gtk-object-set-property (obj property val-type val) (with-g-value (value) @@ -85,7 +92,9 @@

(defun gtk-widget-set-popup (widget menu) (gtk-signal-connect-swap widget "button-press-event" - (ffx:ff-register-callable 'button-press-event-handler) + (let ((cbl (ffx:ff-register-callable 'button-press-event-handler))) + #+shhtk (print (list "gtk-widget-set-popup connecting callable" widget cbl)) + cbl) :data menu))

(defun gtk-list-store-new (col-types) @@ -160,7 +169,7 @@ for type in types-lst for str-ptr = (when (find type '(:string :icon)) (to-gtk-string data)) - do (print (list value type (as-gtk-type type))) + do (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type (:date 'float)