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