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

Modified Files: actions.lisp buttons.lisp cells-gtk.asd entry.lisp gtk-app.lisp layout.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:01:51 2004 Author: ktilton

Index: root/cells-gtk/actions.lisp diff -u root/cells-gtk/actions.lisp:1.1 root/cells-gtk/actions.lisp:1.2 --- root/cells-gtk/actions.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/actions.lisp Tue Dec 14 05:01:51 2004 @@ -48,7 +48,7 @@ (gtk-ffi::gtk-action-group-remove-action (id self) (id kid))) (dolist (kid new-value) (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid))) - (call-next-method)) + #+clisp (call-next-method))

(def-object ui-manager () ((action-groups :accessor action-groups :initform (c-in nil))

Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.3 root/cells-gtk/buttons.lisp:1.4 --- root/cells-gtk/buttons.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/buttons.lisp Tue Dec 14 05:01:51 2004 @@ -37,7 +37,8 @@ (def-c-output .kids ((self button)) (assert-bin self) (dolist (kid (kids self)) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method))

(def-c-output stock ((self button)) (when new-value @@ -93,4 +94,5 @@

(def-c-output .md-value ((self radio-button)) (when (and new-value (upper self box)) - (setf (md-value (upper self box)) (md-name self)))) + (setf (md-value (upper self box)) (md-name self))) + #+clisp (call-next-method))

Index: root/cells-gtk/cells-gtk.asd diff -u root/cells-gtk/cells-gtk.asd:1.1 root/cells-gtk/cells-gtk.asd:1.2 --- root/cells-gtk/cells-gtk.asd:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/cells-gtk.asd Tue Dec 14 05:01:51 2004 @@ -5,14 +5,14 @@ :components ((:file "cells-gtk") (:file "widgets") - (:file "layout") - (:file "display") - (:file "buttons") - (:file "entry") - (:file "tree-view") - (:file "menus") - (:file "dialogs") - (:file "textview") - (:file "addon") + (:file "layout" :depends-on ("widgets")) + (:file "display" :depends-on ("widgets")) + (:file "buttons" :depends-on ("widgets")) + (:file "entry" :depends-on ("widgets")) + (:file "tree-view" :depends-on ("widgets")) + (:file "menus" :depends-on ("widgets")) + (:file "dialogs" :depends-on ("widgets")) + (:file "textview" :depends-on ("widgets")) + (:file "addon" :depends-on ("widgets")) (:file "gtk-app") -)) + ))

Index: root/cells-gtk/entry.lisp diff -u root/cells-gtk/entry.lisp:1.2 root/cells-gtk/entry.lisp:1.3 --- root/cells-gtk/entry.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/entry.lisp Tue Dec 14 05:01:51 2004 @@ -23,6 +23,14 @@ (model) ())

+#+no +(def-gtk widget entry nil + ((auto-update :accessor auto-update :initarg :auto-aupdate :initform nil) + (completion :accessor completion :initarg :completion :initform nil) + (text :accessor text :initarg :text :initform (c-in nil)) + (init :accessor init :initarg :init :initform nil)) + (editable has-frame max-length) (changed activate)) + (def-widget entry () ((auto-update :accessor auto-update :initarg :auto-aupdate :initform nil) (completion :accessor completion :initarg :completion :initform nil)

Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.3 root/cells-gtk/gtk-app.lisp:1.4 --- root/cells-gtk/gtk-app.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/gtk-app.lisp Tue Dec 14 05:01:51 2004 @@ -97,6 +97,9 @@ *gtk-global-callbacks* 16))

(defun gtk-global-callback-funcall (n) + (trc nil "gtk-global-callback-funcall >" n + *gtk-global-callbacks* + (when n (aref *gtk-global-callbacks* n))) (funcall (aref *gtk-global-callbacks* n)))

(defun cells-gtk-init ()

Index: root/cells-gtk/layout.lisp diff -u root/cells-gtk/layout.lisp:1.2 root/cells-gtk/layout.lisp:1.3 --- root/cells-gtk/layout.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/layout.lisp Tue Dec 14 05:01:51 2004 @@ -30,7 +30,8 @@ (when new-value (dolist (kid new-value) (gtk-box-pack-start (id self) (id kid) - (expand? kid) (fill? kid) (padding? kid))))) + (expand? kid) (fill? kid) (padding? kid))) + #+clisp (call-next-method)))

(def-widget hbox (box) () () () @@ -83,7 +84,8 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value)))))))) + :kids (list (cadr new-value))))))) + #+clisp (call-next-method))

(def-widget vpaned () () () ()) @@ -96,7 +98,8 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value)))))))) + :kids (list (cadr new-value))))))) + #+clisp (call-next-method))

(def-widget frame () @@ -124,7 +127,8 @@ (def-c-output .kids ((self frame)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method))

(def-widget aspect-frame (frame) ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -158,7 +162,8 @@ (def-c-output .kids ((self expander)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method))

(def-widget scrolled-window () () @@ -173,7 +178,8 @@ (dolist (kid new-value) (if (member (class-name (class-of kid)) '(listbox treebox tree-view text-view layout) :test #'equal) (gtk-container-add (id self) (id kid)) - (gtk-scrolled-window-add-with-viewport (id self) (id kid))))) + (gtk-scrolled-window-add-with-viewport (id self) (id kid)))) + #+clisp (call-next-method))

(def-widget notebook () ((tab-labels :accessor tab-labels :initarg :tab-labels :initform nil) @@ -213,7 +219,8 @@ (loop for page from 0 to (length new-value) do (setf (current-page self) page)) (when (and (show-page self) (>= (show-page self) 0) (< (show-page self) (length new-value))) - (setf (current-page self) (show-page self)))) + (setf (current-page self) (show-page self))) + #+clisp (call-next-method))

(def-widget alignment () ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -264,4 +271,5 @@ (def-c-output .kids ((self alignment)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method))

Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.3 root/cells-gtk/menus.lisp:1.4 --- root/cells-gtk/menus.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/menus.lisp Tue Dec 14 05:01:51 2004 @@ -27,7 +27,9 @@ (changed) :new-tail '-text :on-changed (callback (widget event data) + (trc "combo-box onchanged cb" widget event data (id self)) (let ((pos (gtk-combo-box-get-active (id self)))) + (trc "combo-box pos" pos) (setf (md-value self) (and (not (= pos -1)) (nth pos (items self)))))))

@@ -87,7 +89,8 @@ (assert-bin self) (when new-value (dolist (kid new-value) - (gtk-container-add (id self) (id kid))))) + (gtk-container-add (id self) (id kid)))) + #+clisp (call-next-method))

(def-widget separator-tool-item (tool-item) () @@ -130,7 +133,8 @@ (def-c-output .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid))))) + (gtk-menu-shell-append (id self) (id kid)))) + #+clisp (call-next-method))

(def-widget menu-bar (menu-shell) () () ()) @@ -192,9 +196,17 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) + (trc "on-toggled" self widget event data) (let ((state (gtk-check-menu-item-get-active widget))) (setf (md-value self) state))))

+#+not +(DEF-GTK WIDGET CHECK-MENU-ITEM (MENU-ITEM) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) + (ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED + (CALLBACK (WIDGET EVENT DATA) (TRC "on-toggled" SELF WIDGET EVENT DATA) + (LET ((STATE (GTK-CHECK-MENU-ITEM-GET-ACTIVE WIDGET))) + (SETF (MD-VALUE SELF) STATE)))) + (def-c-output init ((self check-menu-item)) (setf (active self) new-value) (setf (md-value self) new-value)) @@ -214,7 +226,8 @@

(def-c-output .md-value ((self radio-menu-item)) (when (and new-value (upper self menu-item)) - (setf (md-value (upper self menu-item)) (md-name self)))) + (setf (md-value (upper self menu-item)) (md-name self))) + #+clisp (call-next-method))

(def-widget image-menu-item (menu-item) ((stock :accessor stock :initarg :stock :initform nil)

Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.3 root/cells-gtk/tree-view.lisp:1.4 --- root/cells-gtk/tree-view.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/tree-view.lisp Tue Dec 14 05:01:51 2004 @@ -117,8 +117,9 @@ (assert (eql self selected-clos)) (gtk-object-store selected-widget self) ;; tie column widg to clos tree-view (callback-register self :on-select new-value) - (gtk-signal-connect selected-widget "changed" - (ff-register-callable 'tree-view-select-handler)))))) + (let ((cb (ff-register-callable 'tree-view-select-handler))) + (trc "tree-view on-select pcb:" cb selected-widget "changed") + (gtk-signal-connect selected-widget "changed" cb))))))

(defmodel listbox (tree-view) () @@ -188,12 +189,13 @@ (t (gtk-cell-renderer-text-new))) do (gtk-tree-view-column-pack-start (id col) renderer t) (gtk-tree-view-column-set-cell-data-func (id col) renderer - (progn + (let ((cb (ff-register-callable 'tree-view-render-call-callback))) + (trc "tree-view columns pcb:" cb (id col) :render-cell) (callback-register col :render-cell (gtk-tree-view-render-cell pos (nth pos (column-types self)) (getf (column-render self) pos))) - (ff-register-callable 'tree-view-render-call-callback)) + cb) nil nil) (gtk-tree-view-column-set-sort-column-id (id col) pos) (gtk-tree-view-insert-column (id self) (id col) pos))))

Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.3 root/cells-gtk/widgets.lisp:1.4 --- root/cells-gtk/widgets.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/widgets.lisp Tue Dec 14 05:01:51 2004 @@ -75,8 +75,6 @@ (break "gtk-object-store id ~a known as ~a, not forgettable ~a" hash-id known gtk-object)))))

-#+shhh -(maphash (lambda (k v) (print (list k v))) *gtk-objects*)

(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) (when *gtk-objects* @@ -102,7 +100,11 @@ ; ------------------------------------------

(defmethod configure ((self gtk-object) gtk-function value) - (apply gtk-function (id self) (if (consp value) value (list value)))) + (apply gtk-function + (id self) + (if (consp value) + value + (list value))))

(eval-when (:compile-toplevel :load-toplevel :execute) (defun gtk-function-name (class option) @@ -117,17 +119,27 @@ (defmacro def-gtk-event-handler (event) `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) ((widget (* :void)) (event (* :void)) (data (* :void))) - (print (list :def-gtk-event-handler ,(symbol-name event))) + ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) (let ((self (gtk-object-find widget t))) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) (funcall cb self widget event data)))))

(def-gtk-event-handler clicked) +(def-gtk-event-handler changed) +(def-gtk-event-handler activate) +(def-gtk-event-handler value-changed) +(def-gtk-event-handler day-selected) +(def-gtk-event-handler selection-changed) (def-gtk-event-handler toggled) (def-gtk-event-handler delete-event) - + (defparameter *widget-callbacks* (list (cons 'clicked (ff-register-callable 'clicked-handler)) + (cons 'changed (ff-register-callable 'changed-handler)) + (cons 'activate (ff-register-callable 'activate-handler)) + (cons 'value-changed (ff-register-callable 'value-changed-handler)) + (cons 'day-selected (ff-register-callable 'day-selected-handler)) + (cons 'selection-changed (ff-register-callable 'selection-changed-handler)) (cons 'toggled (ff-register-callable 'toggled-handler)) (cons 'delete-event (ff-register-callable 'delete-event-handler))))

@@ -157,7 +169,6 @@ new-value) #+shhh (when *gtk-debug* (TRC ,(format nil "output after ~a-~a" class slot-name) new-value) (force-output)))) - into outputs finally (return (values slot-defs outputs))) (multiple-value-bind (signals-slots signals-outputs) @@ -169,16 +180,15 @@ into signals-slots-defs collecting `(def-c-output ,slot-name ((self ,class)) (when new-value - #+clisp (gtk-signal-connect (id self) - ,(string-downcase (string signal-slot)) - new-value) - #-clisp - (progn (callback-register self - ,(intern (string signal-slot) :keyword) - new-value) - (gtk-signal-connect (id self) - ,(string-downcase (string signal-slot)) - (cdr (assoc ',signal-slot *widget-callbacks*)))))) + (callback-register self + ,(intern (string signal-slot) :keyword) + new-value) + (let ((cb (cdr (assoc ',signal-slot *widget-callbacks*)))) + (assert cb) + #+shhtk (trc "in def-c-output gtk-signal-connect pcb:" + cb ',slot-name (id self)) + (gtk-signal-connect (id self) + ,(string-downcase (string signal-slot)) cb)))) into signals-outputs-defs finally (return (values signals-slots-defs signals-outputs-defs))) `(progn @@ -208,7 +218,7 @@ #-clisp `(lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - (print (list :callback self ,widg ,event ,data)) + ;(print (list :anon-callback self ,widg ,event ,data)) (prog1 (progn ,@body @@ -222,24 +232,31 @@ ,@body t)) #-clisp (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - (print (list :callback self ,widg ,event ,data)) + ;(print (list :anon-callback-if self ,widg ,event ,data)) ,@body 1))))

-(ff-defun-callable :cdecl :int timeout-handler-callback - ((data (* :void))) - (print :timeout-handler-callback) - (let ((id (elti data 0))) - (gtk-global-callback-funcall id))) + +(ff-defun-callable :cdecl :boolean timeout-handler-callback + ((data (* :int))) + ;;(print (list :timeout-handler-callback data)) + (let* ((id (elti data 0)) + (r2 (gtk-global-callback-funcall id))) + (trc nil "timeout func really returning" r2) + r2)) +

(defun timeout-add (milliseconds function) (let ((id (gtk-global-callback-register (lambda () - (print :timeout-add-global) - (with-gdk-threads - (funcall function))))) + ;;(print :timeout-add-global) + (let ((r (with-gdk-threads + (funcall function)))) + (trc nil "timeout func returning" r) + r)))) (c-id (fgn-alloc :int 1))) (setf (elti c-id 0) id) + (trc nil "timeout-add > passing cb data, *data" c-id (elti c-id 0)) (g-timeout-add milliseconds (ff-register-callable 'timeout-handler-callback) c-id)))

(def-object widget () @@ -362,7 +379,8 @@ (assert-bin self) (dolist (kid new-value) (when *gtk-debug* (trc "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method))

(def-widget event-box () ((visible-window :accessor visible-window :initarg :visible-window :initform nil)) @@ -376,7 +394,7 @@ (def-c-output .kids ((self event-box)) (assert-bin self) (when new-value - (gtk-container-add (id self) (id (first new-value))))) - + (gtk-container-add (id self) (id (first new-value)))) + #+clisp (call-next-method)) (eval-when (compile load eval) (export '(callback callback-if timeout-add focus)))