Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv13216/cells-gtk
Modified Files:
addon.lisp buttons.lisp callback.lisp cells-gtk.lisp
dialogs.lisp display.lisp entry.lisp gtk-app.lisp layout.lisp
menus.lisp textview.lisp tree-view.lisp widgets.lisp
Log Message:
Port to AllegroCl and Lispworks on win32 using UFFI
Date: Sun Dec 5 07:33:23 2004
Author: ktilton
Index: root/cells-gtk/addon.lisp
diff -u root/cells-gtk/addon.lisp:1.1 root/cells-gtk/addon.lisp:1.2
--- root/cells-gtk/addon.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/addon.lisp Sun Dec 5 07:33:22 2004
@@ -16,6 +16,7 @@
|#
+
(in-package :cgtk)
(def-widget calendar ()
@@ -25,19 +26,18 @@
:on-day-selected (callback (widg signal data)
(setf (md-value self) (get-date self))))
+
(defmethod get-date ((self calendar))
- (with-c-var (year 'uint)
- (with-c-var (month 'uint)
- (with-c-var (day 'uint)
- (gtk-calendar-get-date (id self)
- (ffi:c-var-address year)
- (ffi:c-var-address month)
- (ffi:c-var-address day))
- (encode-universal-time 0 0 0 day (1+ month) year)))))
+ (with-foreign-objects ((year :int)(month :int)(day :int))
+ (gtk-calendar-get-date (id self) year month day)
+ (encode-universal-time 0 0 0 (deref-pointer day :int)
+ (1+ (deref-pointer month :int)) (deref-pointer year :int))))
(def-c-output init ((self calendar))
(when new-value
(multiple-value-bind (sec min hour day month year) (decode-universal-time new-value)
+
+ (declare (ignorable sec min hour))
(gtk-calendar-select-month (id self) (1- month) year)
(gtk-calendar-select-day (id self) day))
(setf (md-value self) new-value)))
Index: root/cells-gtk/buttons.lisp
diff -u root/cells-gtk/buttons.lisp:1.1 root/cells-gtk/buttons.lisp:1.2
--- root/cells-gtk/buttons.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/buttons.lisp Sun Dec 5 07:33:22 2004
@@ -28,8 +28,7 @@
(def-c-output label ((self button))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-button-set-label (id self) str))))
+ (gtk-button-set-label (id self) new-value)))
(def-c-output markup ((self button))
(when new-value
@@ -38,24 +37,22 @@
(def-c-output .kids ((self button))
(assert-bin self)
(dolist (kid (kids self))
- (gtk-container-add (id self) (id kid)))
- (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-c-output stock ((self button))
(when new-value
(setf (label self) (string-downcase (format nil "gtk-~a" new-value)))
- (trc (label self)) (force-output)
+ (trc "stock" (label self)) (force-output)
(setf (use-stock self) t)))
-
(def-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))))
+ :on-toggled (callback (widget event data)
+ (let ((state (gtk-toggle-button-get-active widget)))
+ (setf (md-value self) state))))
(def-c-output init ((self toggle-button))
(setf (active self) new-value)
@@ -73,13 +70,12 @@
:new-args (c? (and (upper self box)
(list
(if (eql (first (kids (fm-parent self))) self)
- nil
+ 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))))
+ (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))
- (setf (md-value (upper self box)) (md-name self)))
- (call-next-method))
+ (setf (md-value (upper self box)) (md-name self))))
Index: root/cells-gtk/callback.lisp
diff -u root/cells-gtk/callback.lisp:1.1 root/cells-gtk/callback.lisp:1.2
--- root/cells-gtk/callback.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/callback.lisp Sun Dec 5 07:33:22 2004
@@ -4,7 +4,7 @@
(let ((id (intern (string-upcase
(format nil "~a.~a" (id self) callback-id)))))
(trc "registering callback" self :id id)
- (setf (gethash id (callbacks .gtk-app)) (cons fun self))
+ (setf (gethash id (callbacks (nearest self gtk-app))) (cons fun self))
id))
(defun dispatch-callback (gtk-app callback)
Index: root/cells-gtk/cells-gtk.lisp
diff -u root/cells-gtk/cells-gtk.lisp:1.1 root/cells-gtk/cells-gtk.lisp:1.2
--- root/cells-gtk/cells-gtk.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/cells-gtk.lisp Sun Dec 5 07:33:22 2004
@@ -18,8 +18,26 @@
(defpackage :cells-gtk
(:nicknames :cgtk)
- (:use :common-lisp :utils-kt :cells :gtk-ffi :ffi))
+ (:use :common-lisp :utils-kt :cells :gtk-ffi
+ #+clisp :ffi #-clisp :uffi #-clisp #:ffx))
(in-package :cgtk)
-(defvar *gtk-debug* nil)
+
+(defun gtk-tree-store-set-kids (model val-tree par-iter index column-types items-factory &optional path)
+ (with-foreign-object (iter 'gtk-tree-iter)
+ (setf (get-slot-value iter 'gtk-tree-iter 'stamp) 0)
+ (setf (get-slot-value iter 'gtk-tree-iter 'user-data) 0)
+ (setf (get-slot-value iter 'gtk-tree-iter 'user-data2) 0)
+ (setf (get-slot-value iter 'gtk-tree-iter 'user-data3) 0)
+ (gtk-ffi::gtk-tree-store-append model iter par-iter)
+ (gtk-ffi::gtk-tree-store-set model iter
+ column-types
+ (append
+ (funcall items-factory val-tree)
+ (list (format nil "(~{~d ~})" (reverse (cons index path))))))
+ (when (subtypep (class-name (class-of val-tree)) 'cells:family)
+ (loop for sub-tree in (cells:kids val-tree)
+ for pos from 0 do
+ (gtk-tree-store-set-kids model sub-tree iter
+ pos column-types items-factory (cons index path))))))
\ No newline at end of file
Index: root/cells-gtk/dialogs.lisp
diff -u root/cells-gtk/dialogs.lisp:1.1 root/cells-gtk/dialogs.lisp:1.2
--- root/cells-gtk/dialogs.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/dialogs.lisp Sun Dec 5 07:33:22 2004
@@ -27,7 +27,7 @@
(markup)
()
:position :mouse
- :new-args (c? (list nil
+ :new-args (c? (list c-null
2
(ecase (message-type self)
(:info 0)
@@ -74,24 +74,24 @@
(gtk-file-filter-add-pattern (id self) pattern)))
(def-object file-chooser ()
- ((action :accessor action :initarg :action :initform nil)
- (action-id :accessor action-id
- :initform (c? (ecase (action self)
- (:open 0)
- (:save 1)
- (:select-folder 2)
- (:create-folder 3))))
- (filters :accessor filters :initarg :filters :initform nil)
- (filters-ids :accessor filters-ids
- :initform (c? (loop for filter in (filters self) collect
- (id (make-be 'file-filter :name (first filter) :patterns (rest filter)))))))
- (local-only select-multiple current-name filename
+ ((action :accessor action :initarg :action :initform nil)
+ (action-id :accessor action-id
+ :initform (c? (ecase (action self)
+ (:open 0)
+ (:save 1)
+ (:select-folder 2)
+ (:create-folder 3))))
+ (filters :accessor filters :initarg :filters :initform nil)
+ (filters-ids :accessor filters-ids
+ :initform (c? (loop for filter in (filters self) collect
+ (id (make-be 'file-filter :name (first filter) :patterns (rest filter)))))))
+ (local-only select-multiple current-name filename
current-folder uri current-folder-uri use-preview-label filter)
- (selection-changed)
- :on-selection-changed (callback (widget signal data)
- (if (select-multiple self)
- (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self)))
- (setf (md-value self) (gtk-file-chooser-get-filename (id self))))))
+ (selection-changed)
+ :on-selection-changed (callback (widget signal data)
+ (if (select-multiple self)
+ (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self)))
+ (setf (md-value self) (gtk-file-chooser-get-filename (id self))))))
(def-c-output filters-ids ((self file-chooser))
(dolist (filter-id new-value)
@@ -113,7 +113,7 @@
()
:on-selection-changed nil
:position :mouse
- :new-args (c? (list (title self) nil (action-id self)
+ :new-args (c? (list (title self) c-null (action-id self)
"gtk-cancel" -6 ;;response-cancel
(format nil "gtk-~a"
(string-downcase
@@ -138,4 +138,5 @@
(let ((dialog (to-be (apply #'mk-file-chooser-dialog inits))))
(md-value dialog)))
-(export '(show-message file-chooser))
\ No newline at end of file
+(eval-when (compile load eval)
+ (export '(show-message file-chooser)))
\ No newline at end of file
Index: root/cells-gtk/display.lisp
diff -u root/cells-gtk/display.lisp:1.1 root/cells-gtk/display.lisp:1.2
--- root/cells-gtk/display.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/display.lisp Sun Dec 5 07:33:22 2004
@@ -60,20 +60,17 @@
(def-c-output text ((self label))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-label-set-text-with-mnemonic (id self) str))))
+ (gtk-label-set-text-with-mnemonic (id self) new-value)))
(def-c-output markup ((self label))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-label-set-markup-with-mnemonic (id self) str))))
+ (gtk-label-set-markup-with-mnemonic (id self) new-value)))
(def-widget accel-label ()
((text :accessor text :initarg :text :initform nil))
()
()
- :id (c? (with-gtk-string (str (text self))
- (gtk-accel-label-new str))))
+ :id (c? (gtk-accel-label-new (text self))))
(def-widget image ()
((filename :accessor filename :initarg :filename :initform nil)
@@ -110,14 +107,13 @@
:has-resize-grip t)
(defmethod new-context ((self statusbar) context)
- (let ((cid (gtk-statusbar-get-context-id (id self) (format nil "~a" context))))
- (setf (gethash context (contexts self)) cid)))
+ (setf (gethash context (contexts self))
+ (gtk-statusbar-get-context-id (id self) (format nil "~a" context))))
(defmethod push-message ((self statusbar) message &optional (context 'main))
(let ((id (gethash context (contexts self))))
(when id
- (with-gtk-string (str message)
- (gtk-statusbar-push (id self) id str)))))
+ (gtk-statusbar-push (id self) id message))))
(defmethod pop-message ((self statusbar) &optional (context 'main))
(let ((id (gethash context (contexts self))))
@@ -156,4 +152,5 @@
(:bottom 3)
(t 0)))))
-(export '(with-markup push-message pop-message pulse))
\ No newline at end of file
+(eval-when (compile load eval)
+ (export '(with-markup push-message pop-message pulse)))
\ No newline at end of file
Index: root/cells-gtk/entry.lisp
diff -u root/cells-gtk/entry.lisp:1.1 root/cells-gtk/entry.lisp:1.2
--- root/cells-gtk/entry.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/entry.lisp Sun Dec 5 07:33:22 2004
@@ -29,34 +29,37 @@
(text :accessor text :initarg :text :initform (c-in nil))
(init :accessor init :initarg :init :initform nil))
(editable has-frame max-length)
- (changed activate)
- :on-changed (callback-if (auto-update self)
- (widget event data)
- (let ((txt (get-gtk-string (gtk-entry-get-text widget))))
- (trc nil "ENTRY (ON-CHANGED)" txt) (force-output)
- (setf (md-value self) txt)))
- :on-activate (callback-if (not (auto-update self))
- (widget event data)
- (let ((txt (get-gtk-string (gtk-entry-get-text widget))))
- (trc nil "ENTRY (ON-ACTIVATE)" txt) (force-output)
- (setf (md-value self) (if (equal txt "") nil txt)))))
+ (changed activate))
+;;; :on-changed (callback-if (auto-update self)
+;;; (widget event data)
+;;; (let ((txt (get-gtk-string (gtk-entry-get-text widget))))
+;;; (trc nil "ENTRY (ON-CHANGED)" txt) (force-output)
+;;; (setf (md-value self) txt)))
+;;; :on-activate (callback-if (not (auto-update self))
+;;; (widget event data)
+;;; (let ((txt (get-gtk-string (gtk-entry-get-text widget))))
+;;; (trc nil "ENTRY (ON-ACTIVATE)" txt) (force-output)
+;;; (setf (md-value self) (if (equal txt "") nil txt)))))
(def-c-output text ((self entry))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-entry-set-text (id self) str))))
+ (gtk-entry-set-text (id self) new-value)))
(def-c-output init ((self entry))
- (setf (text self) (or new-value ""))
- (setf (md-value self) (or new-value "")))
+ (when (stringp new-value) ;; could be null or numeric for spin button
+ (setf (text self) new-value)
+ (setf (md-value self) new-value)))
(def-c-output completion ((self entry))
(when new-value
- (let ((store (make-instance 'list-store :item-types (list :string))))
+ (gvi :pre-mk-store)
+ (let ((store (make-be 'list-store :item-types (list :string))))
+ (gvi :post-mk-store)
(gtk-list-store-set-items (id store) (list :string) (mapcar #'list new-value))
+ (gvi :post-set-items)
(let ((completion (make-be 'entry-completion :model (id store))))
- (gtk-entry-completion-set-text-column (id completion) 0)
- (gtk-entry-set-completion (id self) (id completion))))))
+ (gtk-entry-completion-set-text-column (id completion) 0)
+ (gtk-entry-set-completion (id self) (id completion))))))
;; (def-widget adjustment ()
;; () () ())
Index: root/cells-gtk/gtk-app.lisp
diff -u root/cells-gtk/gtk-app.lisp:1.1 root/cells-gtk/gtk-app.lisp:1.2
--- root/cells-gtk/gtk-app.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/gtk-app.lisp Sun Dec 5 07:33:22 2004
@@ -20,18 +20,19 @@
(defmodel gtk-app (window)
((splash-screen-image :accessor splash-screen-image :initarg :splash-screen-image :initform nil)
- (tooltips :accessor tooltips :initform (make-be 'tooltips))
+ (tooltips :initarg :tooltips :accessor tooltips :initform (make-be 'tooltips))
(tooltips-enable :accessor tooltips-enable :initarg :tooltips-enable :initform (c-in t))
(tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil)))
(:default-initargs
- :on-delete-event (lambda (widget event data)
- (declare (ignore widget event data))
+ :on-delete-event (lambda (self widget event data)
+ (declare (ignore self widget event data))
(gtk-main-quit))))
(def-c-output tooltips-enable ((self gtk-app))
- (if new-value
- (gtk-tooltips-enable (id (tooltips self)))
- (gtk-tooltips-disable (id (tooltips self)))))
+ (when (tooltips self)
+ (if new-value
+ (gtk-tooltips-enable (id (tooltips self)))
+ (gtk-tooltips-disable (id (tooltips self))))))
(def-c-output tooltips-delay ((self gtk-app))
(when new-value
@@ -52,35 +53,62 @@
(let ((*gtk-debug* debug))
(when (not *gtk-initialized*)
(when *gtk-debug*
- (trc "GTK INITIALIZATION") (force-output))
- (g-thread-init nil)
+ (trc "GTK INITIALIZATION") (force-output))
+ (g-thread-init c-null)
(gdk-threads-init)
- (assert (gtk-init-check nil nil))
+ (assert (gtk-init-check c-null c-null))
(setf *gtk-initialized* t))
-
+
(with-gdk-threads
- (let ((app (make-instance app-name :visible (c-in nil)))
- (splash))
- (when (splash-screen-image app)
- (setf splash (make-instance 'splash-screen :image-path (splash-screen-image app)
- :visible (c-in nil)))
- (gtk-window-set-auto-startup-notification nil)
- (to-be splash)
- (setf (visible splash) t)
- (loop while (gtk-events-pending) do
- (gtk-main-iteration)))
-
- (to-be app)
-
- (when splash
- (not-to-be splash)
- (gtk-window-set-auto-startup-notification t))
-
- (setf (visible app) t)
-
- (when *gtk-debug*
- (trc "STARTING GTK-MAIN") (force-output))
- (gtk-main)))))
-
-(export '(gtk-app title icon tooltips tooltips-enable tooltips-delay
- start-app))
\ No newline at end of file
+ ;(gvi :withread)
+ (let ((app (make-instance app-name :visible (c-in nil)))
+ (splash))
+ (when (splash-screen-image app)
+ (setf splash (make-instance 'splash-screen :image-path (splash-screen-image app)
+ :visible (c-in nil)))
+ (gtk-window-set-auto-startup-notification nil)
+ (to-be splash)
+ (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)
+
+ (when *gtk-debug*
+ (trc "STARTING GTK-MAIN") (force-output))
+ (gtk-main)))))
+
+(defvar *gtk-global-callbacks* nil)
+(defvar *gtk-loaded* nil)
+
+(defun gtk-reset ()
+ (cell-reset)
+ (gtk-objects-init)
+ (setf *gtk-global-callbacks*
+ (make-array 128 :adjustable t :fill-pointer 0)))
+
+(defun gtk-global-callback-register (callback)
+ (vector-push-extend callback
+ *gtk-global-callbacks* 16))
+
+(defun gtk-global-callback-funcall (n)
+ (funcall (aref *gtk-global-callbacks* n)))
+
+(defun cells-gtk-init ()
+ (gtk-reset)
+ (unless *gtk-loaded*
+ (loop for lib in '(:gthread :glib :gobject :gdk :gtk)
+ do (assert (uffi:load-foreign-library (gtk-ffi::libname lib)
+ :force-load #+lispworks t #-lispworks nil
+ :module (string lib)))
+ finally (setf *gtk-loaded* t))))
+
+(eval-when (compile load eval)
+ (export '(gtk-app gtk-reset cells-gtk-init title icon tooltips tooltips-enable tooltips-delay
+ start-app gtk-global-callback-register gtk-global-callback-funcall)))
\ No newline at end of file
Index: root/cells-gtk/layout.lisp
diff -u root/cells-gtk/layout.lisp:1.1 root/cells-gtk/layout.lisp:1.2
--- root/cells-gtk/layout.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/layout.lisp Sun Dec 5 07:33:22 2004
@@ -30,8 +30,7 @@
(when new-value
(dolist (kid new-value)
(gtk-box-pack-start (id self) (id kid)
- (expand? kid) (fill? kid) (padding? kid)))
- (call-next-method)))
+ (expand? kid) (fill? kid) (padding? kid)))))
(def-widget hbox (box)
() () ()
@@ -84,8 +83,7 @@
(and (cadr new-value)
(gtk-paned-add2 (id self) (id (make-be 'frame
:shadow 'in
- :kids (list (cadr new-value)))))))
- (call-next-method))
+ :kids (list (cadr new-value))))))))
(def-widget vpaned ()
() () ())
@@ -98,8 +96,7 @@
(and (cadr new-value)
(gtk-paned-add2 (id self) (id (make-be 'frame
:shadow 'in
- :kids (list (cadr new-value)))))))
- (call-next-method))
+ :kids (list (cadr new-value))))))))
(def-widget frame ()
@@ -112,8 +109,7 @@
(def-c-output label ((self frame))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-frame-set-label (id self) str))))
+ (gtk-frame-set-label (id self) new-value)))
(def-c-output shadow ((self frame))
(when new-value
@@ -128,8 +124,7 @@
(def-c-output .kids ((self frame))
(assert-bin self)
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid)))
- (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-widget aspect-frame (frame)
((xalign :accessor xalign :initarg :xalign :initform 0.5)
@@ -158,14 +153,12 @@
(def-c-output label ((self expander))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-expander-set-label (id self) str))))
+ (gtk-expander-set-label (id self) new-value)))
(def-c-output .kids ((self expander))
(assert-bin self)
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid)))
- (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-widget scrolled-window ()
()
@@ -173,15 +166,14 @@
()
:expand t :fill t
:policy (list 1 1)
- :new-args (list nil nil))
+ :new-args (list c-null c-null))
(def-c-output .kids ((self scrolled-window))
(assert-bin self)
(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))))
- (call-next-method))
+ (gtk-scrolled-window-add-with-viewport (id self) (id kid)))))
(def-widget notebook ()
((tab-labels :accessor tab-labels :initarg :tab-labels :initform nil)
@@ -221,8 +213,7 @@
(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)))
- (call-next-method))
+ (setf (current-page self) (show-page self))))
(def-widget alignment ()
((xalign :accessor xalign :initarg :xalign :initform 0.5)
@@ -273,5 +264,4 @@
(def-c-output .kids ((self alignment))
(assert-bin self)
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid)))
- (call-next-method))
+ (gtk-container-add (id self) (id kid))))
Index: root/cells-gtk/menus.lisp
diff -u root/cells-gtk/menus.lisp:1.1 root/cells-gtk/menus.lisp:1.2
--- root/cells-gtk/menus.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/menus.lisp Sun Dec 5 07:33:22 2004
@@ -26,9 +26,9 @@
(changed)
:new-tail '-text
:on-changed (callback (widget event data)
- (let ((pos (gtk-combo-box-get-active (id self))))
- (setf (md-value self) (and (not (= pos -1))
- (nth pos (items self)))))))
+ (let ((pos (gtk-combo-box-get-active (id self))))
+ (setf (md-value self) (and (not (= pos -1))
+ (nth pos (items self)))))))
(def-c-output items ((self combo-box))
(when old-value
@@ -36,8 +36,7 @@
(gtk-combo-box-remove-text (id self) 0)))
(when new-value
(dolist (item (items self))
- (with-gtk-string (str (funcall (items-factory self) item))
- (gtk-combo-box-append-text (id self) str)))
+ (gtk-combo-box-append-text (id self) (funcall (items-factory self) item)))
(when (init self)
(let ((index (position (init self) (items self))))
(when index
@@ -58,8 +57,7 @@
(when new-value
(loop for item in new-value
for pos from 0 do
- (gtk-toolbar-insert (id self) (id item) pos)))
- (call-next-method))
+ (gtk-toolbar-insert (id self) (id item) pos))))
(def-c-output orientation ((self toolbar))
(when new-value
@@ -88,8 +86,7 @@
(assert-bin self)
(when new-value
(dolist (kid new-value)
- (gtk-container-add (id self) (id kid))))
- (call-next-method))
+ (gtk-container-add (id self) (id kid)))))
(def-widget separator-tool-item (tool-item)
()
@@ -103,7 +100,7 @@
(label-widget :accessor label-widget :initarg :label-widget :initform (c-in nil)))
(use-underline stock-id)
(clicked)
- :new-args (list nil nil))
+ :new-args (list c-null c-null))
(def-c-output icon-widget ((self tool-button))
(when old-value
@@ -119,8 +116,7 @@
(def-c-output label ((self tool-button))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-tool-button-set-label (id self) str))))
+ (gtk-tool-button-set-label (id self) new-value)))
(def-c-output stock ((self tool-button))
(when new-value
@@ -133,8 +129,7 @@
(def-c-output .kids ((self menu-shell))
(when new-value
(dolist (kid new-value)
- (gtk-menu-shell-append (id self) (id kid))))
- (call-next-method))
+ (gtk-menu-shell-append (id self) (id kid)))))
(def-widget menu-bar (menu-shell)
() () ())
@@ -196,8 +191,8 @@
(toggled)
:active (c-in nil)
:on-toggled (callback (widget event data)
- (let ((state (gtk-check-menu-item-get-active widget)))
- (setf (md-value self) state))))
+ (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)
@@ -214,12 +209,11 @@
(not-first-p (not (eql (first (kids (fm-parent self))) self))))
(if (and in-group-p not-first-p)
(list (id (first (kids (fm-parent self)))))
- (list nil)))))
+ (list c-null)))))
(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)))
- (call-next-method))
+ (setf (md-value (upper self menu-item)) (md-name self))))
(def-widget image-menu-item (menu-item)
((stock :accessor stock :initarg :stock :initform nil)
Index: root/cells-gtk/textview.lisp
diff -u root/cells-gtk/textview.lisp:1.1 root/cells-gtk/textview.lisp:1.2
--- root/cells-gtk/textview.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/textview.lisp Sun Dec 5 07:33:23 2004
@@ -22,13 +22,12 @@
((text :accessor text :initarg :text :initform nil))
()
()
- :new-args (c? (list nil)))
+ :new-args (c? (list c-null)))
(def-c-output text ((self text-buffer))
- (with-gtk-string (txt (or new-value ""))
- (gtk-text-buffer-set-text (id self)
- txt
- -1)))
+ (gtk-text-buffer-set-text (id self)
+ (or new-value "")
+ -1))
(def-widget text-view ()
((buffer :accessor buffer :initarg :buffer :initform (mk-text-buffer)))
Index: root/cells-gtk/tree-view.lisp
diff -u root/cells-gtk/tree-view.lisp:1.1 root/cells-gtk/tree-view.lisp:1.2
--- root/cells-gtk/tree-view.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/tree-view.lisp Sun Dec 5 07:33:23 2004
@@ -37,16 +37,18 @@
(column-types :accessor column-types :initform (c? (mapcar #'first (columns-def self))))
(column-inits :accessor column-inits :initform (c? (mapcar #'second (columns-def self))))
(column-render :accessor column-render
- :initform (c? (loop for col-def in (columns-def self)
- for pos from 0 append
- (when (third col-def)
- (list pos (third col-def))))))
+ :initform (c? (loop for col-def in (columns-def self)
+ for pos from 0 append
+ (when (third col-def)
+ (list pos (third col-def))))))
(columns :accessor columns
- :initform (c? (mapcar #'(lambda (col-init)
- (apply #'make-be 'tree-view-column col-init))
- (column-inits self))))
+ :initform (c? (mapcar #'(lambda (col-init)
+ (apply #'make-be 'tree-view-column
+ :container self
+ col-init))
+ (column-inits self))))
(select-if :unchanged-if #'fail
- :accessor select-if :initarg :select-if :initform (c-in nil))
+ :accessor select-if :initarg :select-if :initform (c-in nil))
(items :accessor items :initarg :items :initform nil)
(items-factory :accessor items-factory :initarg :items-factory :initform #'identity)
(selection-mode :accessor selection-mode :initarg :selection-mode :initform :single)
@@ -54,8 +56,9 @@
(tree-model :accessor tree-model :initarg :tree-model :initform nil))
()
()
- :on-select (callback (widget event data)
- (setf (md-value self) (get-selection self))))
+ :on-select (lambda (self widget event data)
+ (declare (ignore widget event data))
+ (setf (md-value self) (get-selection self))))
(def-c-output tree-model ((self tree-view))
(when new-value
@@ -75,16 +78,17 @@
(let ((selection (gtk-tree-view-get-selection (id self))))
(let (sel)
(gtk-tree-selection-selected-foreach selection
- #'(lambda (model path iter data)
- (push (item-from-path
- (items self)
- (read-from-string
- (gtk-tree-model-get-cell model iter (length (column-types self)) :string)))
- sel))
- nil)
+ #'(lambda (model path iter data)
+ (declare (ignore data path))
+ (push (item-from-path
+ (items self)
+ (read-from-string
+ (gtk-tree-model-get-cell model iter (length (column-types self)) :string)))
+ sel))
+ nil)
(if (equal (gtk-tree-selection-get-mode selection) 3) ;;multiple
- sel
- (first sel)))))
+ sel
+ (first sel)))))
(def-c-output selection-mode ((self tree-view))
(when new-value
@@ -96,10 +100,25 @@
(:browse 2)
(:multiple 3))))))
+(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 ((cb (callback-recover tree-view :on-select)))
+ (funcall cb tree-view column-widget event data))))
+
(def-c-output on-select ((self tree-view))
(when new-value
- (let ((sel (gtk-tree-view-get-selection (id self))))
- (gtk-signal-connect sel "changed" (on-select self)))))
+ (trc "output on-select" self new-value)
+ (let* ((selected-widget (gtk-tree-view-get-selection (id self)))
+ (selected-clos (gtk-object-find selected-widget nil)))
+ (unless selected-clos
+ (trc "whoa!!! no clos for selected" self selected-widget))
+ (when selected-clos
+ (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))))))
(defmodel listbox (tree-view)
()
@@ -139,7 +158,7 @@
(def-c-output select-if ((self treebox))
(when new-value
(setf (md-value self) (mapcan (lambda (item) (fm-collect-if item new-value))
- (items self)))))
+ (items self)))))
(def-c-output items ((self treebox))
(when old-value
@@ -147,27 +166,38 @@
(when new-value
(loop for sub-tree in new-value
for index from 0 do
- (gtk-tree-store-set-kids (id (tree-model self)) sub-tree nil index
+ (gtk-tree-store-set-kids (id (tree-model self)) sub-tree c-null index
(append (column-types self) (list :string))
(items-factory self)))))
+(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))))
+
(def-c-output columns ((self tree-view))
(when new-value
(loop for col in new-value
- for pos from 0
- for renderer = (case (nth pos (column-types self))
- (:boolean (gtk-cell-renderer-toggle-new))
- (:icon (gtk-cell-renderer-pixbuf-new))
- (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
- (gtk-tree-view-render-cell pos
- (nth pos (column-types self))
- (getf (column-render self) pos))
- nil
- nil)
- (gtk-tree-view-column-set-sort-column-id (id col) pos)
- (gtk-tree-view-insert-column (id self) (id col) pos))))
+ for pos from 0
+ for renderer = (case (nth pos (column-types self))
+ (:boolean (gtk-cell-renderer-toggle-new))
+ (:icon (gtk-cell-renderer-pixbuf-new))
+ (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
+ (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))
+ nil nil)
+ (gtk-tree-view-column-set-sort-column-id (id col) pos)
+ (gtk-tree-view-insert-column (id self) (id col) pos))))
(def-object tree-view-column ()
((title :accessor title :initarg :title :initform nil)
@@ -184,11 +214,11 @@
(def-c-output title ((self tree-view-column))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-tree-view-column-set-title (id self) str))))
+ (gtk-tree-view-column-set-title (id self) new-value)))
(defmacro def-columns (&rest args)
`(list ,@(loop for (type inits renderer) in args collect
`(list ,type ',inits ,renderer))))
-(export '(mk-listbox mk-treebox def-columns))
\ No newline at end of file
+(eval-when (compile load eval)
+ (export '(mk-listbox mk-treebox def-columns)))
\ No newline at end of file
Index: root/cells-gtk/widgets.lisp
diff -u root/cells-gtk/widgets.lisp:1.1 root/cells-gtk/widgets.lisp:1.2
--- root/cells-gtk/widgets.lisp:1.1 Fri Nov 19 00:39:53 2004
+++ root/cells-gtk/widgets.lisp Sun Dec 5 07:33:23 2004
@@ -18,23 +18,84 @@
(in-package :cgtk)
+
(defmodel gtk-object (family)
- ((def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil)
+ ((container :cell nil :initarg :container :accessor container)
+ (def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil)
(new-function-name :accessor new-function-name :initarg :new-function-name
- :initform (c? (intern (format nil "GTK-~a-NEW~a"
- (def-gtk-class-name self)
- (or (new-tail self) ""))
- :gtk-ffi)))
+ :initform (c? (intern (format nil "GTK-~a-NEW~a"
+ (def-gtk-class-name self)
+ (or (new-tail self) ""))
+ :gtk-ffi)))
(new-args :accessor new-args :initarg :new-args :initform nil)
(new-tail :accessor new-tail :initarg :new-tail :initform nil)
(id :initarg :id :accessor id
- :initform (c? (without-c-dependency
- (when *gtk-debug*
- (trc "NEW" (new-function-name self) (new-args self)) (force-output))
- (apply (symbol-function (new-function-name self)) (new-args self))))))
+ :initform (c? (without-c-dependency
+ (when *gtk-debug*
+ (trc "NEW ID" (new-function-name self) (new-args self)) (force-output))
+ (let ((id (apply (symbol-function (new-function-name self))
+ (new-args self))))
+ (gtk-object-store id self)
+ id))))
+
+ (callbacks :cell nil :accessor callbacks
+ :initform nil
+ :documentation "assoc of event-name, callback closures to handle widget events"))
(:default-initargs
- :md-name (c-in nil)
- :md-value (c-in nil)))
+ :md-name nil ;; kwt: was (c-in nil), but this is not a cell
+ :md-value (c-in nil)))
+
+;; --------- provide id-to-clos lookup ------
+
+(defvar *gtk-objects* nil)
+
+(defun gtk-objects-init ()
+ (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100)))
+
+(defun gtk-object-store (id gtk-object)
+ (unless *gtk-objects*
+ (gtk-objects-init))
+ (let ((known (gethash id *gtk-objects*)))
+ (cond
+ ((not known)
+ (setf (gethash 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)))))
+
+(defun gtk-object-forget (id gtk-object)
+ (assert *gtk-objects*)
+ (let ((known (gethash id *gtk-objects*)))
+ (cond
+ ((not known))
+ ((eql known gtk-object)
+ (setf (gethash id *gtk-objects*) nil))
+ (t
+ (break "gtk-object-store id ~a known as ~a, not forgettable ~a"
+ id known gtk-object)))))
+
+#+shhh
+(maphash (lambda (k v) (print (list k v))) *gtk-objects*)
+
+(defun gtk-object-find (id &optional must-find-p)
+ (when *gtk-objects*
+ (let ((clos-widget (gethash id *gtk-objects*)))
+ (when must-find-p
+ (assert clos-widget))
+ clos-widget)))
+
+;; ----- fake callbackable closures ------------
+
+(defun callback-register (self callback-key closure)
+ (let ((x (assoc callback-key (callbacks self))))
+ (if x (rplacd x closure)
+ (push (cons callback-key closure) (callbacks self)))))
+
+(defun callback-recover (self callback-key)
+ (cdr (assoc callback-key (callbacks self))))
+
+; ------------------------------------------
(defmethod configure ((self gtk-object) gtk-function value)
(apply gtk-function (id self) (if (consp value) value (list value))))
@@ -49,79 +110,124 @@
;;; --- widget --------------------
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(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)))))
+
+(def-gtk-event-handler clicked)
+(def-gtk-event-handler toggled)
+(def-gtk-event-handler delete-event)
+
+(defparameter *widget-callbacks*
+ (list (cons 'clicked (ff-register-callable 'clicked-handler))
+ (cons 'toggled (ff-register-callable 'toggled-handler))
+ (cons 'delete-event (ff-register-callable 'delete-event-handler))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
(defmacro def-object (&rest args)
`(def-gtk gtk-object ,@args))
(defmacro def-widget (&rest args)
`(def-gtk widget ,@args))
(defmacro def-gtk (gtk-superclass class
- superclasses
- (&rest std-slots)
- (&rest gtk-slots) (&rest gtk-signals) &rest defclass-options)
- (multiple-value-bind (slots outputs)
- (loop for gtk-option-def in gtk-slots
- for slot-name = (if (atom gtk-option-def)
- gtk-option-def (car gtk-option-def))
- collecting `(,slot-name :initform (c-in nil)
- :initarg ,(intern (string slot-name) :keyword)
- :accessor ,slot-name)
- into slot-defs
- collecting `(def-c-output ,slot-name ((self ,class))
- (when (or new-value old-value)
- (when *gtk-debug* (TRC ,(format nil "~a-~a" class slot-name) new-value) (force-output))
- (configure self #',(gtk-function-name class gtk-option-def)
- new-value))
- (call-next-method))
-
- into outputs
- finally (return (values slot-defs outputs)))
- (multiple-value-bind (signals-slots signals-outputs)
- (loop for signal-slot in gtk-signals
+ superclasses
+ (&rest std-slots)
+ (&rest gtk-slots) (&rest gtk-signals) &rest defclass-options)
+ (multiple-value-bind (slots outputs)
+ (loop for gtk-option-def in gtk-slots
+ for slot-name = (if (atom gtk-option-def)
+ gtk-option-def (car gtk-option-def))
+ collecting `(,slot-name :initform (c-in nil)
+ :initarg ,(intern (string slot-name) :keyword)
+ :accessor ,slot-name)
+ into slot-defs
+ collecting `(def-c-output ,slot-name ((self ,class))
+ (when (or new-value old-value)
+ #+shhh (when *gtk-debug*
+ (TRC ,(format nil "output before ~a-~a" class slot-name) new-value) (force-output))
+ (configure self #',(gtk-function-name class gtk-option-def)
+ 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)
+ (loop for signal-slot in gtk-signals
for slot-name = (intern (format nil "ON-~a" signal-slot))
collecting `(,slot-name :initform nil
- :initarg ,(intern (string slot-name) :keyword)
- :accessor ,slot-name)
+ :initarg ,(intern (string slot-name) :keyword)
+ :accessor ,slot-name)
into signals-slots-defs
collecting `(def-c-output ,slot-name ((self ,class))
(when new-value
- (gtk-signal-connect (id self) ,(string-downcase (string signal-slot)) new-value))
- (call-next-method))
+ #+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*))))))
into signals-outputs-defs
finally (return (values signals-slots-defs signals-outputs-defs)))
`(progn
- (defmodel ,class ,(or superclasses (list gtk-superclass))
- (,@(append std-slots slots signals-slots))
- (:default-initargs
- :def-gtk-class-name ',class
- ,@defclass-options))
- (export ',class)
- (export ',(mapcar #'first (append std-slots slots signals-slots)))
-
- (defun ,(intern (format nil "MK-~a" class)) (&rest inits)
- (when *gtk-debug* (trc "MAKE-INSTANCE" ',class) (force-output))
- (apply 'make-instance ',class inits))
- (export ',(intern (format nil "MK-~a" class)))
- ,@outputs
- ,@signals-outputs)))))
+ (defmodel ,class ,(or superclasses (list gtk-superclass))
+ (,@(append std-slots slots signals-slots))
+ (:default-initargs
+ :def-gtk-class-name ',class
+ ,@defclass-options))
+ (eval-when (compile load eval)
+ (export ',class))
+ (eval-when (compile load eval)
+ (export ',(mapcar #'first (append std-slots slots signals-slots))))
+
+ (defun ,(intern (format nil "MK-~a" class)) (&rest inits)
+ (when *gtk-debug* (trc "MAKE-INSTANCE" ',class) (force-output))
+ (apply 'make-instance ',class inits))
+ (eval-when (compile load eval)
+ (export ',(intern (format nil "MK-~a" class))))
+ ,@outputs
+ ,@signals-outputs)))))
(defmacro callback ((widg event data) &body body)
+ #+clisp
`(c? (without-c-dependency #'(lambda (,widg ,event ,data)
- (declare (ignorable ,widg ,event ,data))
- ,@body t))))
+ (declare (ignorable ,widg ,event ,data))
+ ,@body t)))
+ #-clisp
+ `(lambda (self ,widg ,event ,data)
+ (declare (ignorable self ,widg ,event ,data))
+ ,@body t))
+
(defmacro callback-if (condition (widg event data) &body body)
`(c? (and ,condition
- (without-c-dependency #'(lambda (,widg ,event ,data)
- (declare (ignorable ,widg ,event ,data))
- ,@body t)))))
+ #+clisp (without-c-dependency #'(lambda (,widg ,event ,data)
+ (declare (ignorable ,widg ,event ,data))
+ ,@body t))
+ #-clisp (lambda (self ,widg ,event ,data)
+ (declare (ignorable self ,widg ,event ,data))
+ ,@body t))))
+
+(ff-defun-callable :cdecl :int timeout-handler-callback
+ ((data (* :void)))
+ (let ((id (elti data 0)))
+ (gtk-global-callback-funcall id)))
(defun timeout-add (milliseconds function)
- (g-timeout-add milliseconds
- #'(lambda (x)
- (declare (ignore x))
+ (let ((id (gtk-global-callback-register
+ (lambda ()
(with-gdk-threads
- (funcall function)))
- nil))
+ (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)))
(def-object widget ()
((tooltip :accessor tooltip :initarg :tooltip :initform (c-in nil))
@@ -175,14 +281,12 @@
(def-c-output tooltip ((self widget))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-tooltips-set-tip (id (tooltips (upper self gtk-app)))
- (id self)
- str
- ""))))
+ (gtk-tooltips-set-tip (id (tooltips (upper self gtk-app)))
+ (id self) new-value "")))
(defmethod not-to-be :after ((self widget))
(when *gtk-debug* (trc "WIDGET DESTROY" (md-name self)) (force-output))
+ (gtk-object-forget (id self) self)
(gtk-widget-destroy (id self)))
(defun assert-bin (container)
@@ -192,7 +296,8 @@
(def-widget window ()
((wintype :accessor wintype :initarg wintype :initform 0)
- (title :accessor title :initarg :title :initform (c? (string (class-name (class-of self)))))
+ (title :accessor title :initarg :title
+ :initform (c? (string (class-name (class-of self)))))
(icon :initarg :icon :accessor icon :initform nil)
(decorated :accessor decorated :initarg :decorated :initform (c-in t))
(position :accessor set-position :initarg :position :initform (c-in nil))
@@ -221,12 +326,11 @@
(def-c-output title ((self window))
(when new-value
- (with-gtk-string (str new-value)
- (gtk-window-set-title (id self) str))))
+ (gtk-window-set-title (id self) new-value)))
(def-c-output icon ((self window))
(when new-value
- (gtk-window-set-icon-from-file (id self) new-value nil)))
+ (gtk-window-set-icon-from-file (id self) new-value c-null)))
(def-c-output decorated ((self window))
(gtk-window-set-decorated (id self) new-value))
@@ -245,8 +349,7 @@
(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)))
- (call-next-method))
+ (gtk-container-add (id self) (id kid))))
(def-widget event-box ()
((visible-window :accessor visible-window :initarg :visible-window :initform nil))
@@ -260,8 +363,7 @@
(def-c-output .kids ((self event-box))
(assert-bin self)
(when new-value
- (gtk-container-add (id self) (id (first new-value))))
- (call-next-method))
-
+ (gtk-container-add (id self) (id (first new-value)))))
-(export '(callback callback-if timeout-add focus))
+(eval-when (compile load eval)
+ (export '(callback callback-if timeout-add focus)))
