January 2005 - cells-gtk-cvs@common-lisp.net

[cells-gtk-cvs] CVS update: root/config.lisp root/load.lisp
by ktilton＠common-lisp.net 25 Jan '05

25 Jan '05

Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv23336 Modified Files: load.lisp Added Files: config.lisp Log Message: Apply Andras SImon's patches from Jan 6, 2004 to get things working on CMU and ACL/Linux Date: Tue Jan 25 07:57:31 2005 Author: ktilton Index: root/load.lisp diff -u root/load.lisp:1.4 root/load.lisp:1.5 --- root/load.lisp:1.4 Thu Dec 16 08:36:25 2004 +++ root/load.lisp Tue Jan 25 07:57:31 2005 @@ -11,48 +11,17 @@ #-asdf (eval-when (compile load eval) - (load (make-pathname :directory '(:absolute "00" "root") - :name "asdf" :type "lisp"))) + (load (merge-pathnames + (make-pathname :name "asdf" :type "lisp") + *load-pathname*))) -#| Step Two: Tell ASDF where to find stuff +;;;; Step 2: Modify config.lisp, then load: - Again, adjust pathnames to match the locations of the various bits of source - -|# - -(progn - #+lispworks - (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) - - (push (make-pathname :directory '(:absolute "cell-cultures" "utils-kt")) - asdf:*central-registry*) - - (push (make-pathname :directory '(:absolute "cell-cultures" "cells")) - asdf:*central-registry*) - - (push (make-pathname :directory '(:absolute "cell-cultures" "hello-c")) - asdf:*central-registry*) - - (defparameter *cells-gtk-root* - (make-pathname :directory '(:absolute "00" "root"))) - - (push (merge-pathnames - (make-pathname :directory '(:relative "gtk-ffi")) - *cells-gtk-root*) - asdf:*central-registry*) - - (push (merge-pathnames - (make-pathname :directory '(:relative "cells-gtk")) - *cells-gtk-root*) - asdf:*central-registry*) - - (push (merge-pathnames - (make-pathname :directory '(:relative "cells-gtk" "test-gtk")) - *cells-gtk-root*) - asdf:*central-registry*)) - -#| Step 3: Compile and load via ASDF +(load (merge-pathnames + (make-pathname :name "config" :type "lisp") + *load-pathname*)) +;;;; Step 3: Compile and load via ASDF ; these are handy when one is first working up to getting things to build at all ; but the "test-gtk" ASDF has dependencies which will load everything else, so ; you can just execute that. @@ -62,11 +31,10 @@ ;(Asdf:operate 'asdf:load-op :hello-c :force nil) ;(Asdf:operate 'asdf:load-op :gtk-ffi :force t) ;(Asdf:operate 'asdf:load-op :cells-gtk :force nil) -|# (Asdf:operate 'asdf:load-op :test-gtk :force nil) -#+Step-4: +#+Step-4 (test-gtk::gtk-demo)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-display.lisp root/cells-gtk/test-gtk/test-gtk.lisp
by ktilton＠common-lisp.net 25 Jan '05

25 Jan '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv23336/cells-gtk/test-gtk Modified Files: test-display.lisp test-gtk.lisp Log Message: Apply Andras SImon's patches from Jan 6, 2004 to get things working on CMU and ACL/Linux Date: Tue Jan 25 07:57:28 2005 Author: ktilton Index: root/cells-gtk/test-gtk/test-display.lisp diff -u root/cells-gtk/test-gtk/test-display.lisp:1.3 root/cells-gtk/test-gtk/test-display.lisp:1.4 --- root/cells-gtk/test-gtk/test-display.lisp:1.3 Mon Dec 13 20:01:57 2004 +++ root/cells-gtk/test-gtk/test-display.lisp Tue Jan 25 07:57:28 2005 @@ -19,7 +19,7 @@ :ratio 1 :kids (list (mk-image :width 200 :height 250 - :filename "/00/root/test-images/tst.gif"))) + :filename (namestring cl-user::*tst-image*)))) (mk-hseparator) (mk-hbox :kids (list Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.8 root/cells-gtk/test-gtk/test-gtk.lisp:1.9 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.8 Mon Jan 3 14:33:20 2005 +++ root/cells-gtk/test-gtk/test-gtk.lisp Tue Jan 25 07:57:28 2005 @@ -9,9 +9,9 @@ :title "GTK Testing" ;;:tooltips nil ;;dkwt ;;:tooltips-enable nil ;;dkwt - :icon "test-images/small.png" + :icon (namestring cl-user::*small-image*) :position :center - :splash-screen-image "/00/root/test-images/splash.png" + :splash-screen-image (namestring cl-user::*splash-image*) :width 550 :height 550 :kids (let ((tabs '("Buttons" "Display" "Layout"

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp
by ktilton＠common-lisp.net 25 Jan '05

25 Jan '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv23336/cells-gtk Modified Files: gtk-app.lisp Log Message: Apply Andras SImon's patches from Jan 6, 2004 to get things working on CMU and ACL/Linux Date: Tue Jan 25 07:57:27 2005 Author: ktilton Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.7 root/cells-gtk/gtk-app.lisp:1.8 --- root/cells-gtk/gtk-app.lisp:1.7 Mon Jan 3 14:33:16 2005 +++ root/cells-gtk/gtk-app.lisp Tue Jan 25 07:57:27 2005 @@ -107,9 +107,12 @@ #-cmu (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))) + for libname = (gtk-ffi::libname lib) + do #-mswindows ;; probably have to refine this for diff implementations + (setq libname (uffi:find-foreign-library (gtk-ffi::libname lib) "/usr/lib/")) + (assert (uffi:load-foreign-library libname + :force-load #+lispworks t #-lispworks nil + :module (string lib))) finally (setf *gtk-loaded* t)))) (eval-when (compile load eval)

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lpr root/gtk-ffi/gtk-utilities.lisp
by ktilton＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv10915/gtk-ffi Modified Files: gtk-ffi.lpr gtk-utilities.lisp Log Message: us pointer void in button-press-event-handler arglist Date: Mon Jan 3 23:33:25 2005 Author: ktilton Index: root/gtk-ffi/gtk-ffi.lpr diff -u root/gtk-ffi/gtk-ffi.lpr:1.3 root/gtk-ffi/gtk-ffi.lpr:1.4 --- root/gtk-ffi/gtk-ffi.lpr:1.3 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-ffi.lpr Mon Jan 3 23:33:24 2005 @@ -1,11 +1,10 @@ -;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- -(in-package :common-graphics-user) +(in-package :cg-user) -(defpackage :gtk-ffi (:export)) +(defpackage :GTK-FFI) (define-project :name :gtk-ffi - :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "gtk-ffi.lisp") (make-instance 'module :name "gtk-core.lisp") (make-instance 'module :name "gtk-button.lisp") @@ -18,21 +17,12 @@ "c:\\cell-cultures\\hello-c\\hello-c")) :libraries nil :distributed-files nil + :internally-loaded-files nil :project-package-name :gtk-ffi :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg :drag-and-drop :lisp-widget - :multi-picture-button :common-control - :edit-in-place :outline :grid :group-box - :header-control :progress-indicator-control - :common-status-bar :tab-control :trackbar-control - :up-down-control :dde :mci :carets :hotspots - :menu-selection :choose-list :directory-list - :color-dialog :find-dialog :font-dialog - :string-dialog :yes-no-list-dialog - :list-view-control :rich-edit :drawable :ole :www - :aclwin302) + :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:compiler :top-level :local-name-info) @@ -40,6 +30,7 @@ :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" + :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.7 root/gtk-ffi/gtk-utilities.lisp:1.8 --- root/gtk-ffi/gtk-utilities.lisp:1.7 Fri Dec 24 16:35:10 2004 +++ root/gtk-ffi/gtk-utilities.lisp Mon Jan 3 23:33:24 2005 @@ -58,8 +58,16 @@ (g-value-unset value))) (defun get-gtk-string (pointer) - (with-foreign-object (bytes-written :int) - (g-locale-from-utf8 pointer -1 nil bytes-written nil))) + (typecase pointer + (string pointer) + (otherwise + (ukt:trc nil "get-gtk-string sees" pointer (type-of pointer)) + #+allegro (convert-from-cstring pointer) + #+lispworks (convert-from-foreign-string pointer + :null-terminated-p t) + #-(or allegro lispworks) + (with-foreign-object (bytes-written :int) + (g-locale-from-utf8 pointer -1 nil bytes-written nil))))) (defun to-gtk-string (str) "!!!! remember to free returned str pointer" @@ -102,7 +110,7 @@ (defun gvi (&optional (key :anon)) key -;;; (ukt:trc "gvi> " keY) +;;; (ukt:trc nil "gvi> " keY) ;;; (let ((tv (ffx:fgn-alloc :int 32))) ;;; (dotimes (n 32) (setf (ffx:elti tv n) 0)) ;;; (loop for type in '(:string :icon :int :string) @@ -187,33 +195,80 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) -(uffi:def-struct all-types - (:string :cstring) - (:icon :cstring) - (:boolean :unsigned-int) - (:int :int) - (:long :long) - (:date :float) - (:float :float) - (:double :double)) - -(defmacro with-all-types ((var) &body body) - `(uffi:with-foreign-object (,var 'all-types) - (setf (get-slot-value ,var 'all-types :string) c-null - (get-slot-value ,var 'all-types :icon) c-null - (get-slot-value ,var 'all-types :boolean) 0 - (get-slot-value ,var 'all-types :int) 0 - (get-slot-value ,var 'all-types :long) 0 - (get-slot-value ,var 'all-types :date) 0f0 - (get-slot-value ,var 'all-types :float) 0f0 - (get-slot-value ,var 'all-types :double) 0d0) - ,@body)) +#+cmu +(alien:def-alien-type all-types + (alien:struct c-struct + (:string (* t)) + (:icon (* t)) + (:boolean boolean) + (:int integer) + (:long c-call:long) + (:date single-float) + (:float single-float) + (:double double-float))) + +#-cmu +(progn + (defun alloc-col-type-buffer (col-type) + (ecase col-type + ((:string :icon) (allocate-foreign-object '(:array :cstring) 1)) + (:boolean (allocate-foreign-object '(:array :unsigned-byte) 1)) ;;guess + (:date (allocate-foreign-object '(:array :float) 1)) + (:int (allocate-foreign-object '(:array :int) 1)) + (:long (allocate-foreign-object '(:array :long) 1)) + (:float (allocate-foreign-object '(:array :float) 1)) + (:double (allocate-foreign-object '(:array :double) 1)))) + + (defun deref-col-type-buffer (col-type buffer) + (ecase col-type + ((:string :icon) + (get-gtk-string + (make-pointer (deref-array buffer '(:array :cstring) 0) :cstring))) + (:boolean (not (zerop (deref-array buffer '(:array :unsigned-byte) 0)))) ;;guess + (:date (deref-array buffer '(:array :float) 0)) + (:int (deref-array buffer '(:array :int) 0)) + (:long (deref-array buffer '(:array :long) 0)) + (:float (deref-array buffer '(:array :float) 0)) + (:double (deref-array buffer '(:array :double) 0))))) + + +#+worksforallegroclbutnotlispworks +(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + (lambda (tree-column cell-renderer model iter data) + (DECLARE (ignorable tree-column data)) + (let ((wvar (alloc-col-type-buffer col-type))) + (gtk-tree-model-get model iter col wvar -1) + (let ((item-value (deref-col-type-buffer col-type wvar))) + (with-gtk-string (str (format nil "~a" + (if (eql col-type :date) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (truncate item-value)) + (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" + day month year hour min sec)) + item-value))) + (ukt:trc nil "gtv-render-cell (callback11)> rendering value" + col col-type item-value) + (apply #'gtk-object-set-property cell-renderer + (case col-type + (:boolean (list "active" 'boolean item-value)) + (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) + (t (list "text" 'c-pointer str))))) + (when cell-attrib-f + (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do + (apply #'gtk-object-set-property cell-renderer property))) + #-(or allegro lispworks) + (when (find col-type '(:icon :string)) + (free-foreign-object item-value))) + (free-foreign-object wvar)))) +#-cmu (defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + (ukt:trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f) (lambda (tree-column cell-renderer model iter data) (DECLARE (ignorable tree-column data)) - (ukt:trc nil "entering render cell callback" tree-column model) + (ukt:trc nil "gtv-render-cell (callback)> entry" + tree-column cell-renderer model iter data) (let ((return-buffer (ffx:fgn-alloc :int 16))) (gtk-tree-model-get model iter col return-buffer -1) @@ -222,39 +277,111 @@ (col-type-to-ffi-type col-type)))) (ret$ (when (find col-type '(:string :icon)) (make-pointer returned-value :cstring))) - (item-value (case col-type - ((:string :icon) - #-lispworks (convert-from-cstring ret$) + (item-value (cond + (ret$ #-lispworks (convert-from-cstring ret$) #+lispworks (convert-from-foreign-string ret$ :null-terminated-p t)) - (:boolean (not (zerop returned-value))) - (otherwise returned-value)))) - (ukt:trc nil "tv-render-cell: types, ret-value, item-value" - (List col-type (col-type-to-ffi-type col-type) (ffi-to-uffi-type - (col-type-to-ffi-type col-type))) - returned-value ret$ item-value) + ((eq col-type :boolean) + (not (zerop returned-value))) + (t returned-value)))) + (ukt:trc nil "gtv-render-cell (callback)>> rendering value" + col col-type ret$ item-value) + (apply #'gtk-object-set-property cell-renderer (case col-type (:boolean (list "active" 'boolean item-value)) (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) - (t (list "text" 'c-string (if (eql col-type :date) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (truncate item-value)) - (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" - day month year hour min sec)) - (format nil "~a" item-value)))))) + (t (list "text" 'c-string + (case col-type + (:date (multiple-value-bind (sec min hour day month year) + (decode-universal-time (truncate item-value)) + (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" + day month year hour min sec))) + (:string (get-gtk-string item-value)) + (otherwise (format nil "~a" item-value))))))) + (when cell-attrib-f - (ukt:trc nil "got cell-attrib-f" cell-attrib-f item-value) (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do (apply #'gtk-object-set-property cell-renderer property))) (when ret$ - (ukt:trc nil "frreeing ret$" ret$) (uffi:free-foreign-object ret$)) - (ukt:trc nil "frreeing return-buffer" return-buffer) (ffx:fgn-free return-buffer))) - (ukt:trc nil "exiting render cell callback" tree-column model) 1)) + +#+cmu +(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + #'(lambda (tree-column cell-renderer model iter data) + (alien:with-alien ((struct all-types)) + (gtk-tree-model-get model iter col + (alien:addr (alien:slot struct col-type)) + -1) + (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) + (get-gtk-string (alien:slot struct col-type)) + (alien:slot struct col-type)))) + (with-gtk-string (str (format nil "~a" + (if (eql col-type :date) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (truncate item-value)) + (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" + day month year hour min sec)) + item-value))) + (ukt:trc nil "gtv-render-cell (callback11)> rendering value" + col col-type item-value) + (apply #'gtk-object-set-property cell-renderer + (case col-type + (:boolean (list "active" 'boolean item-value)) + (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) + (t (list "text" 'c-pointer str))))) + (when cell-attrib-f + (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do + (apply #'gtk-object-set-property cell-renderer property)))) + (when (eql col-type :string) + (g-free (alien:slot struct :string)))))) + + +#+clisp + +(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) + #'(lambda (tree-column cell-renderer model iter data) + (declare (ignore data)) + (with-c-var + (struct '(c-struct list + (:string c-pointer) + (:icon c-pointer) + (:boolean boolean) + (:int int) + (:long long) + (:date single-float) + (:float single-float) + (:double double-float)) + (list nil nil nil 0 0 (coerce 0 'single-float) (coerce 0 'single-float) (coerce 0 'double-float))) + (gtk-tree-model-get model iter col + (c-var-address (slot struct col-type)) + -1) + (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) + (get-gtk-string (slot struct col-type)) + (slot struct col-type)))) + (ukt:trc nil "tv-render-cell: " + :col-type col-type + :item item-value) + (with-gtk-string (str (format nil "~a" + (if (eql col-type :date) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (truncate item-value)) + (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" + day month year hour min sec)) + item-value))) + (apply #'gtk-object-set-property cell-renderer + (case col-type + (:boolean (list "active" 'boolean item-value)) + (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) + (t (list "text" 'c-pointer str))))) + (when cell-attrib-f + (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do + (apply #'gtk-object-set-property cell-renderer property)))) + (when (eql col-type :string) + (g-free (slot struct :string)))))) (defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser)))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lisp root/cells-gtk/test-gtk/test-gtk.lpr root/cells-gtk/test-gtk/test-menus.lisp root/cells-gtk/test-gtk/test-tree-view.lisp
by ktilton＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv10915/cells-gtk/test-gtk Modified Files: test-gtk.lisp test-gtk.lpr test-menus.lisp test-tree-view.lisp Log Message: us pointer void in button-press-event-handler arglist Date: Mon Jan 3 23:33:22 2005 Author: ktilton Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.7 root/cells-gtk/test-gtk/test-gtk.lisp:1.8 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.7 Fri Dec 24 03:03:57 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Mon Jan 3 23:33:20 2005 @@ -18,7 +18,7 @@ "Menus" "Textview" "Dialogs" "Addon" "Entry" - #-cmu "Tree-view" + "Tree-view" ))) (list (mk-notebook :tab-labels tabs Index: root/cells-gtk/test-gtk/test-gtk.lpr diff -u root/cells-gtk/test-gtk/test-gtk.lpr:1.2 root/cells-gtk/test-gtk/test-gtk.lpr:1.3 --- root/cells-gtk/test-gtk/test-gtk.lpr:1.2 Tue Dec 14 05:01:57 2004 +++ root/cells-gtk/test-gtk/test-gtk.lpr Mon Jan 3 23:33:20 2005 @@ -1,11 +1,10 @@ -;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- -(in-package :common-graphics-user) +(in-package :cg-user) -(defpackage :test-gtk (:export)) +(defpackage :TEST-GTK) (define-project :name :test-gtk - :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "test-gtk.lisp") (make-instance 'module :name "test-layout.lisp") (make-instance 'module :name "test-display.lisp") @@ -20,28 +19,21 @@ "c:\\00\\root\\cells-gtk\\cells-gtk")) :libraries nil :distributed-files nil + :internally-loaded-files nil :project-package-name :test-gtk :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg :drag-and-drop :lisp-widget - :multi-picture-button :common-control - :edit-in-place :outline :grid :group-box - :header-control :progress-indicator-control - :common-status-bar :tab-control :trackbar-control - :up-down-control :dde :mci :carets :hotspots - :menu-selection :choose-list :directory-list - :color-dialog :find-dialog :font-dialog - :string-dialog :yes-no-list-dialog - :list-view-control :rich-edit :drawable :ole :www - :aclwin302) + :runtime-modules '(:cg-dde-utils :cg.base :cg.dialog-item :cg.timer + :cg.tooltip) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:compiler :top-level :local-name-info) + :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" + :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard Index: root/cells-gtk/test-gtk/test-menus.lisp diff -u root/cells-gtk/test-gtk/test-menus.lisp:1.1 root/cells-gtk/test-gtk/test-menus.lisp:1.2 --- root/cells-gtk/test-gtk/test-menus.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-menus.lisp Mon Jan 3 23:33:20 2005 @@ -14,7 +14,7 @@ :accel '(#\s :control :shift :alt) :image (mk-image :stock :save :icon-size :menu) :on-activate (callback (widget event data) - (trc "TST") (force-output))) + (trc nil "TST") (force-output))) (mk-menu-item :label "Submenu" :kids (list @@ -24,7 +24,7 @@ (mk-image-menu-item :stock :harddisk :on-activate (callback (widget event data) - (trc "HARDDISK") (force-output))) + (trc nil "HARDDISK") (force-output))) (mk-image-menu-item :image (mk-image :stock :dialog-info :icon-size :menu) :label-widget (mk-label :markup (with-markup (:foreground :blue) Index: root/cells-gtk/test-gtk/test-tree-view.lisp diff -u root/cells-gtk/test-gtk/test-tree-view.lisp:1.2 root/cells-gtk/test-gtk/test-tree-view.lisp:1.3 --- root/cells-gtk/test-gtk/test-tree-view.lisp:1.2 Sun Dec 5 07:33:31 2004 +++ root/cells-gtk/test-gtk/test-tree-view.lisp Mon Jan 3 23:33:20 2005 @@ -89,7 +89,7 @@ :md-name :hscale :expand t :fill t :min 0 :max 200 - :init 100))) + :init 5))) (mk-scrolled-window :kids (list (mk-listbox

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/actions.lisp root/cells-gtk/callback.lisp root/cells-gtk/cells-gtk.lpr root/cells-gtk/gtk-app.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp
by ktilton＠common-lisp.net 03 Jan '05

03 Jan '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv10915/cells-gtk Modified Files: actions.lisp callback.lisp cells-gtk.lpr gtk-app.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: us pointer void in button-press-event-handler arglist Date: Mon Jan 3 23:33:17 2005 Author: ktilton Index: root/cells-gtk/actions.lisp diff -u root/cells-gtk/actions.lisp:1.2 root/cells-gtk/actions.lisp:1.3 --- root/cells-gtk/actions.lisp:1.2 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/actions.lisp Mon Jan 3 23:33:16 2005 @@ -61,7 +61,7 @@ (defmethod add-action-group ((self ui-manager) (group action-group) &optional pos) (let ((grp (to-be group))) - (trc "ADD-ACTION-GROUP" grp) (force-output) + (trc nil "ADD-ACTION-GROUP" grp) (force-output) (gtk-ffi::gtk-ui-manager-insert-action-group (id self) (id group) (or pos (length (action-groups self)))) (push grp (action-groups self)))) Index: root/cells-gtk/callback.lisp diff -u root/cells-gtk/callback.lisp:1.3 root/cells-gtk/callback.lisp:1.4 --- root/cells-gtk/callback.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/callback.lisp Mon Jan 3 23:33:16 2005 @@ -3,7 +3,7 @@ (defun register-callback (self callback-id fun) (let ((id (intern (string-upcase (format nil "~a.~a" (id self) callback-id))))) - (trc "registering callback" self :id id) + (trc nil "registering callback" self :id id) (setf (gethash id (callbacks (nearest self gtk-app))) (cons fun self)) id)) Index: root/cells-gtk/cells-gtk.lpr diff -u root/cells-gtk/cells-gtk.lpr:1.1 root/cells-gtk/cells-gtk.lpr:1.2 --- root/cells-gtk/cells-gtk.lpr:1.1 Tue Dec 7 22:01:05 2004 +++ root/cells-gtk/cells-gtk.lpr Mon Jan 3 23:33:16 2005 @@ -1,11 +1,10 @@ -;; -*- lisp-version: "6.2 [Windows] (Sep 3, 2004 12:04)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*- -(in-package :common-graphics-user) +(in-package :cg-user) -(defpackage :cells-gtk (:export)) +(defpackage :CELLS-GTK) (define-project :name :cells-gtk - :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "cells-gtk.lisp") (make-instance 'module :name "widgets.lisp") (make-instance 'module :name "layout.lisp") @@ -19,28 +18,18 @@ (make-instance 'module :name "addon.lisp") (make-instance 'module :name "gtk-app.lisp")) :projects (list (make-instance 'project-module :name - "c:\\cell-cultures\\utils-kt\\utils-kt") - (make-instance 'project-module :name "c:\\cell-cultures\\cells\\cells") (make-instance 'project-module :name "c:\\00\\root\\gtk-ffi\\gtk-ffi")) :libraries nil :distributed-files nil + :internally-loaded-files nil :project-package-name :cells-gtk :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg :drag-and-drop :lisp-widget - :multi-picture-button :common-control - :edit-in-place :outline :grid :group-box - :header-control :progress-indicator-control - :common-status-bar :tab-control :trackbar-control - :up-down-control :dde :mci :carets :hotspots - :menu-selection :choose-list :directory-list - :color-dialog :find-dialog :font-dialog - :string-dialog :yes-no-list-dialog - :list-view-control :rich-edit :drawable :ole :www - :aclwin302) + :runtime-modules '(:cg-dde-utils :cg.base :cg.dialog-item :cg.timer + :cg.tooltip) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") :include-flags '(:compiler :top-level :local-name-info) @@ -48,6 +37,7 @@ :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t \"Initializing\"" + :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.6 root/cells-gtk/gtk-app.lisp:1.7 --- root/cells-gtk/gtk-app.lisp:1.6 Thu Dec 23 17:34:42 2004 +++ root/cells-gtk/gtk-app.lisp Mon Jan 3 23:33:16 2005 @@ -54,7 +54,7 @@ (let ((*gtk-debug* debug)) (when (not *gtk-initialized*) (when *gtk-debug* - (trc "GTK INITIALIZATION") (force-output)) + (trc nil "GTK INITIALIZATION") (force-output)) (g-thread-init c-null) (gdk-threads-init) (assert (gtk-init-check c-null-int c-null)) @@ -80,7 +80,7 @@ (setf (visible app) t) (when *gtk-debug* - (trc "STARTING GTK-MAIN") (force-output)) + (trc nil "STARTING GTK-MAIN") (force-output)) (gtk-main))))) (defvar *gtk-global-callbacks* nil) Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.5 root/cells-gtk/menus.lisp:1.6 --- root/cells-gtk/menus.lisp:1.5 Wed Dec 22 17:23:50 2004 +++ root/cells-gtk/menus.lisp Mon Jan 3 23:33:16 2005 @@ -27,9 +27,9 @@ (changed) :new-tail '-text :on-changed (callback (widget event data) - (trc "combo-box onchanged cb" widget event data (id self)) + (trc nil "combo-box onchanged cb" widget event data (id self)) (let ((pos (gtk-combo-box-get-active (id self)))) - (trc "combo-box pos" pos) + (trc nil "combo-box pos" pos) (setf (md-value self) (and (not (= pos -1)) (nth pos (items self))))))) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.7 root/cells-gtk/tree-view.lisp:1.8 --- root/cells-gtk/tree-view.lisp:1.7 Thu Dec 23 17:34:42 2004 +++ root/cells-gtk/tree-view.lisp Mon Jan 3 23:33:16 2005 @@ -105,7 +105,7 @@ (bif (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) - (trc "dude, clean up old widgets after runs" column-widget))) + (trc nil "dude, clean up old widgets after runs" column-widget))) (def-c-output on-select ((self tree-view)) (when new-value @@ -119,7 +119,7 @@ (gtk-object-store selected-widget self) ;; tie column widg to clos tree-view (callback-register self :on-select new-value) (let ((cb (ff-register-callable 'tree-view-select-handler))) - (trc "tree-view on-select pcb:" cb selected-widget "changed") + (trc nil "tree-view on-select pcb:" cb selected-widget "changed") (gtk-signal-connect selected-widget "changed" cb))))))) (defmodel listbox (tree-view) @@ -143,10 +143,11 @@ (id (tree-model self)) (append (column-types self) (list :string)) (loop for item in new-value - for index from 0 collect - (append - (funcall (items-factory self) item) - (list (format nil "(~d)" index))))))) + for index from 0 + collect (let ((i (funcall (items-factory self) item))) + (ukt:trc nil "items output: old,new" item i) + (append i + (list (format nil "(~d)" index)))))))) (defmodel treebox (tree-view) () @@ -179,7 +180,7 @@ (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)) - (trc "dude, clean up old widgets from prior runs" tree-column)) + (trc nil "dude, clean up old widgets from prior runs" tree-column)) 1) (def-c-output columns ((self tree-view)) Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.6 root/cells-gtk/widgets.lisp:1.7 --- root/cells-gtk/widgets.lisp:1.6 Thu Dec 23 17:34:42 2004 +++ root/cells-gtk/widgets.lisp Mon Jan 3 23:33:16 2005 @@ -32,7 +32,7 @@ (id :initarg :id :accessor id :initform (c? (without-c-dependency (when *gtk-debug* - (trc "NEW ID" (new-function-name self) (new-args self)) (force-output)) + (trc nil "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) @@ -123,7 +123,7 @@ (bif (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) (funcall cb self widget event data)) - (trc "unknown widget. from prior run. clean up on errors" widget)))) + (trc nil "unknown widget. from prior run. clean up on errors" widget)))) (def-gtk-event-handler clicked) (def-gtk-event-handler changed) @@ -186,7 +186,7 @@ new-value) (let ((cb (cdr (assoc ',signal-slot *widget-callbacks*)))) (assert cb) - #+shhtk (trc "in def-c-output gtk-signal-connect pcb:" + #+shhtk (trc nil "in def-c-output gtk-signal-connect pcb:" cb ',slot-name (id self)) (gtk-signal-connect (id self) ,(string-downcase (string signal-slot)) cb)))) @@ -204,7 +204,7 @@ (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)) + (when *gtk-debug* (trc nil "MAKE-INSTANCE" ',class) (force-output)) (apply 'make-instance ',class inits)) (eval-when (compile load eval) (export ',(intern (format nil "MK-~a" class)))) @@ -306,7 +306,7 @@ (def-c-output visible ((self widget)) (when *gtk-debug* - (trc "VISIBLE" (md-name self) new-value) (force-output)) + (trc nil "VISIBLE" (md-name self) new-value) (force-output)) (if new-value (gtk-widget-show (id self)) (gtk-widget-hide (id self)))) @@ -317,7 +317,7 @@ (id self) new-value ""))) (defmethod not-to-be :after ((self widget)) - (when *gtk-debug* (trc "WIDGET DESTROY" (md-name self)) (force-output)) + (when *gtk-debug* (trc nil "WIDGET DESTROY" (md-name self)) (force-output)) (gtk-object-forget (id self) self) (gtk-widget-destroy (id self))) @@ -380,7 +380,7 @@ (def-c-output .kids ((self window)) (assert-bin self) (dolist (kid new-value) - (when *gtk-debug* (trc "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) + (when *gtk-debug* (trc nil "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) (gtk-container-add (id self) (id kid))) #+clisp (call-next-method))

1 0