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)))
