[cells-gtk-cvs] CVS update: root/cells-gtk/addon.lisp root/cells-gtk/buttons.lisp root/cells-gtk/callback.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp
Kenny Tilton
ktilton at common-lisp.net
Mon Dec 6 20:04:17 UTC 2004
Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv25746/cells-gtk
Modified Files:
addon.lisp buttons.lisp callback.lisp gtk-app.lisp menus.lisp
tree-view.lisp widgets.lisp
Log Message:
Ongoing port to Lispworks
Date: Mon Dec 6 21:04:13 2004
Author: ktilton
Index: root/cells-gtk/addon.lisp
diff -u root/cells-gtk/addon.lisp:1.2 root/cells-gtk/addon.lisp:1.3
--- root/cells-gtk/addon.lisp:1.2 Sun Dec 5 07:33:22 2004
+++ root/cells-gtk/addon.lisp Mon Dec 6 21:04:12 2004
@@ -24,8 +24,7 @@
()
(day-selected)
:on-day-selected (callback (widg signal data)
- (setf (md-value self) (get-date self))))
-
+ (setf (md-value self) (get-date self))))
(defmethod get-date ((self calendar))
(with-foreign-objects ((year :int)(month :int)(day :int))
Index: root/cells-gtk/buttons.lisp
diff -u root/cells-gtk/buttons.lisp:1.2 root/cells-gtk/buttons.lisp:1.3
--- root/cells-gtk/buttons.lisp:1.2 Sun Dec 5 07:33:22 2004
+++ root/cells-gtk/buttons.lisp Mon Dec 6 21:04:12 2004
@@ -51,9 +51,23 @@
(toggled)
:active (c-in nil)
:on-toggled (callback (widget event data)
+ (print (list :toggle-button :on-toggled-cb widget))
(let ((state (gtk-toggle-button-get-active widget)))
+ (print (list :toggledstate state))
(setf (md-value self) state))))
+#+test
+(DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL))
+ (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED
+ (CALLBACK (WIDGET EVENT DATA)
+ (LET ((STATE (GTK-TOGGLE-BUTTON-GET-ACTIVE WIDGET)))
+ (SETF (MD-VALUE SELF) STATE))))
+
+#+test
+(DEF-C-OUTPUT ACTIVE ((SELF TOGGLE-BUTTON))
+ (WHEN (OR NEW-VALUE OLD-VALUE)
+ (CONFIGURE SELF #'GTK-TOGGLE-BUTTON-SET-ACTIVE NEW-VALUE)))
+
(def-c-output init ((self toggle-button))
(setf (active self) new-value)
(setf (md-value self) new-value))
@@ -73,8 +87,9 @@
c-null
(id (first (kids (fm-parent self))))))))
:on-toggled (callback (widget event data)
- (let ((state (gtk-toggle-button-get-active widget)))
- (setf (md-value self) state))))
+ (print (list :radio-button widget event data))
+ (let ((state (gtk-toggle-button-get-active widget)))
+ (setf (md-value self) state))))
(def-c-output .md-value ((self radio-button))
(when (and new-value (upper self box))
Index: root/cells-gtk/callback.lisp
diff -u root/cells-gtk/callback.lisp:1.2 root/cells-gtk/callback.lisp:1.3
--- root/cells-gtk/callback.lisp:1.2 Sun Dec 5 07:33:22 2004
+++ root/cells-gtk/callback.lisp Mon Dec 6 21:04:12 2004
@@ -13,15 +13,15 @@
;(format t "sym:~S fun:~A~%" sym func-self)
;(force-output)
(when (not func-self)
- (when *gtk-debug*
- (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:"
- callback-id (type-of callback-id) (when (typep callback-id 'symbol)
- (symbol-package callback-id)))
- (maphash (lambda (key func-self)
- (declare (ignore func-self))
- (format t "~&known callback key ~a, type ~a, pkg ~a"
- key (type-of key)(when (typep key 'symbol) (symbol-package key))))
- (callbacks gtk-app))))
+ (when *gtk-debug*
+ (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:"
+ callback-id (type-of callback-id) (when (typep callback-id 'symbol)
+ (symbol-package callback-id)))
+ (maphash (lambda (key func-self)
+ (declare (ignore func-self))
+ (format t "~&known callback key ~a, type ~a, pkg ~a"
+ key (type-of key)(when (typep key 'symbol) (symbol-package key))))
+ (callbacks gtk-app))))
(when (car func-self)
(apply (car func-self) (cdr func-self) callback callback-args)))))
Index: root/cells-gtk/gtk-app.lisp
diff -u root/cells-gtk/gtk-app.lisp:1.2 root/cells-gtk/gtk-app.lisp:1.3
--- root/cells-gtk/gtk-app.lisp:1.2 Sun Dec 5 07:33:22 2004
+++ root/cells-gtk/gtk-app.lisp Mon Dec 6 21:04:12 2004
@@ -25,8 +25,9 @@
(tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil)))
(:default-initargs
:on-delete-event (lambda (self widget event data)
- (declare (ignore self widget event data))
- (gtk-main-quit))))
+ (declare (ignore self widget event data))
+ (gtk-main-quit)
+ 0)))
(def-c-output tooltips-enable ((self gtk-app))
(when (tooltips self)
@@ -56,11 +57,10 @@
(trc "GTK INITIALIZATION") (force-output))
(g-thread-init c-null)
(gdk-threads-init)
- (assert (gtk-init-check c-null c-null))
+ (assert (gtk-init-check c-null-int c-null))
(setf *gtk-initialized* t))
(with-gdk-threads
- ;(gvi :withread)
(let ((app (make-instance app-name :visible (c-in nil)))
(splash))
(when (splash-screen-image app)
@@ -71,12 +71,11 @@
(setf (visible splash) t)
(loop while (gtk-events-pending) do
(gtk-main-iteration)))
- (gvi :splashup)
+
(to-be app)
- (gvi :appup)
+
(when splash
(not-to-be splash)
- (gvi :splashdown)
(gtk-window-set-auto-startup-notification t))
(setf (visible app) t)
Index: root/cells-gtk/menus.lisp
diff -u root/cells-gtk/menus.lisp:1.2 root/cells-gtk/menus.lisp:1.3
--- root/cells-gtk/menus.lisp:1.2 Sun Dec 5 07:33:22 2004
+++ root/cells-gtk/menus.lisp Mon Dec 6 21:04:12 2004
@@ -20,7 +20,8 @@
(def-widget combo-box ()
((items :accessor items :initarg :items :initform nil)
- (items-factory :accessor items-factory :initarg :items-factory :initform #'(lambda (item) (format nil "~a" item)))
+ (items-factory :accessor items-factory :initarg :items-factory
+ :initform #'(lambda (item) (format nil "~a" item)))
(init :accessor init :initarg :init :initform nil))
(active)
(changed)
Index: root/cells-gtk/tree-view.lisp
diff -u root/cells-gtk/tree-view.lisp:1.2 root/cells-gtk/tree-view.lisp:1.3
--- root/cells-gtk/tree-view.lisp:1.2 Sun Dec 5 07:33:23 2004
+++ root/cells-gtk/tree-view.lisp Mon Dec 6 21:04:12 2004
@@ -102,7 +102,7 @@
(ff-defun-callable :cdecl :int tree-view-select-handler
((column-widget (* :void)) (event (* :void)) (data (* :void)))
- (let ((tree-view (gtk-object-find column-widget)))
+ (let ((tree-view (gtk-object-find column-widget t)))
(let ((cb (callback-recover tree-view :on-select)))
(funcall cb tree-view column-widget event data))))
@@ -173,11 +173,10 @@
(ff-defun-callable :cdecl :int tree-view-render-call-callback
((tree-column (* :void)) (cell-renderer (* :void))
(tree-model (* :void)) (iter (* :void)) (data (* :void)))
- (let ((self (gtk-object-find tree-column)))
- (assert self)
- (let ((cb (callback-recover self :render-cell)))
- (assert cb () "No :render-cell callback for ~a" self)
- (funcall cb tree-column cell-renderer tree-model iter data))))
+ (let* ((self (gtk-object-find tree-column t))
+ (cb (callback-recover self :render-cell)))
+ (assert cb () "No :render-cell callback for ~a" self)
+ (funcall cb tree-column cell-renderer tree-model iter data)))
(def-c-output columns ((self tree-view))
(when new-value
Index: root/cells-gtk/widgets.lisp
diff -u root/cells-gtk/widgets.lisp:1.2 root/cells-gtk/widgets.lisp:1.3
--- root/cells-gtk/widgets.lisp:1.2 Sun Dec 5 07:33:23 2004
+++ root/cells-gtk/widgets.lisp Mon Dec 6 21:04:12 2004
@@ -52,37 +52,41 @@
(defun gtk-objects-init ()
(setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100)))
-(defun gtk-object-store (id gtk-object)
+(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id)))
(unless *gtk-objects*
(gtk-objects-init))
- (let ((known (gethash id *gtk-objects*)))
+ (let ((known (gethash hash-id *gtk-objects*)))
(cond
((not known)
- (setf (gethash id *gtk-objects*) gtk-object))
+ (setf (gethash hash-id *gtk-objects*) gtk-object))
((eql known gtk-object))
(t
(break "gtk-object-store id ~a already known as ~a, not ~a"
- id known gtk-object)))))
+ hash-id known gtk-object)))))
-(defun gtk-object-forget (id gtk-object)
+(defun gtk-object-forget (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id)))
(assert *gtk-objects*)
- (let ((known (gethash id *gtk-objects*)))
+ (let ((known (gethash hash-id *gtk-objects*)))
(cond
((not known))
((eql known gtk-object)
- (setf (gethash id *gtk-objects*) nil))
+ (setf (gethash hash-id *gtk-objects*) nil))
(t
(break "gtk-object-store id ~a known as ~a, not forgettable ~a"
- id known gtk-object)))))
+ hash-id known gtk-object)))))
#+shhh
(maphash (lambda (k v) (print (list k v))) *gtk-objects*)
-(defun gtk-object-find (id &optional must-find-p)
+(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id)))
(when *gtk-objects*
- (let ((clos-widget (gethash id *gtk-objects*)))
- (when must-find-p
- (assert clos-widget))
+ (let ((clos-widget (gethash hash-id *gtk-objects*)))
+ (when (and must-find-p (not clos-widget))
+ (format t "~>k-object-find> ID ~a not found!!!!!!!" hash-id)
+ (maphash (lambda (key value)
+ (format t "~& known: ~a | ~a" key value))
+ *gtk-objects*)
+ (break "gtk-object-find ID not found ~a" hash-id))
clos-widget)))
;; ----- fake callbackable closures ------------
@@ -112,11 +116,11 @@
(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)))
- (let ((self (gtk-object-find widget)))
- (assert self)
- (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword))))
- (funcall cb self widget event data)))))
+ ((widget (* :void)) (event (* :void)) (data (* :void)))
+ (print (list :def-gtk-event-handler ,(symbol-name event)))
+ (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 toggled)
@@ -203,8 +207,13 @@
, at body t)))
#-clisp
`(lambda (self ,widg ,event ,data)
- (declare (ignorable self ,widg ,event ,data))
- , at body t))
+ (declare (ignorable self ,widg ,event ,data))
+ (print (list :callback self ,widg ,event ,data))
+ (prog1
+ (progn
+ , at body
+ 1) ;; a boolean which indicates, IIRC, "handled"
+ #+shhh (print (list :callback-finis self ,widg ,event ,data)))))
(defmacro callback-if (condition (widg event data) &body body)
`(c? (and ,condition
@@ -213,18 +222,22 @@
, at body t))
#-clisp (lambda (self ,widg ,event ,data)
(declare (ignorable self ,widg ,event ,data))
- , at body t))))
+ (print (list :callback self ,widg ,event ,data))
+ , at 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)))
(defun timeout-add (milliseconds function)
(let ((id (gtk-global-callback-register
(lambda ()
- (with-gdk-threads
- (funcall function)))))
+ (print :timeout-add-global)
+ (with-gdk-threads
+ (funcall function)))))
(c-id (fgn-alloc :int 1)))
(setf (elti c-id 0) id)
(g-timeout-add milliseconds (ff-register-callable 'timeout-handler-callback) c-id)))
More information about the Cells-gtk-cvs
mailing list