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 "~&gtk-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 @@ ,@body t))) #-clisp `(lambda (self ,widg ,event ,data) - (declare (ignorable self ,widg ,event ,data)) - ,@body t)) + (declare (ignorable self ,widg ,event ,data)) + (print (list :callback self ,widg ,event ,data)) + (prog1 + (progn + ,@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 @@ ,@body t)) #-clisp (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - ,@body t)))) + (print (list :callback 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)))

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