- cells-gtk-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp
by pdenno＠common-lisp.net 16 Feb '05

16 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv24931/cells-gtk Modified Files: gtk-app.lisp Log Message: A initialize-instance :after method to create user-defined stock icons -- these do not involve clos objects or cells, just gtk (that's why its a i-i on gtk-app). Date: Wed Feb 16 23:20:37 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.11 root/cells-gtk/gtk-app.lisp:1.12 --- root/cells-gtk/gtk-app.lisp:1.11 Sun Feb 13 18:25:13 2005 +++ root/cells-gtk/gtk-app.lisp Wed Feb 16 23:20:37 2005 @@ -22,13 +22,23 @@ ((splash-screen-image :accessor splash-screen-image :initarg :splash-screen-image :initform nil) (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))) + (tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil)) + (stock-icons :cell nil :accessor stock-icons :initarg :stock-icons :initform nil)) (:default-initargs :on-delete-event (lambda (self widget event data) (declare (ignore self widget event data)) (gtk-main-quit) 0))) +(defmethod initialize-instance :after ((self gtk-app) &key stock-icons) + (loop for (name pathname) in stock-icons do + (let* ((image (gtk-image-new-from-file pathname)) + (pixbuf (gtk-image-get-pixbuf image)) + (icon-set (gtk-icon-set-new-from-pixbuf pixbuf)) + (factory (gtk-icon-factory-new))) + (gtk-icon-factory-add factory (format nil "gtk-~A" (string-downcase (string name))) icon-set) + (gtk-icon-factory-add-default factory)))) + (def-c-output tooltips-enable ((self gtk-app)) (when (tooltips self) (if new-value @@ -78,7 +88,7 @@ (not-to-be splash) (gtk-window-set-auto-startup-notification t)) (setf (visible app) t) - + (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) #-lispworks(gtk-main)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/display.lisp
by pdenno＠common-lisp.net 16 Feb '05

16 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv24903/cells-gtk Modified Files: display.lisp Log Message: One line of documentation Date: Wed Feb 16 23:18:06 2005 Author: pdenno Index: root/cells-gtk/display.lisp diff -u root/cells-gtk/display.lisp:1.2 root/cells-gtk/display.lisp:1.3 --- root/cells-gtk/display.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/display.lisp Wed Feb 16 23:18:05 2005 @@ -97,6 +97,7 @@ (list (or (filename self) ""))))) (def-c-output stock ((self image)) + "Set the image of a stock icon" (when new-value (gtk-image-set-from-stock (id self) (stock-id self) (icon-size-id self))))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp
by pdenno＠common-lisp.net 14 Feb '05

14 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv2871/cells-gtk Modified Files: widgets.lisp Log Message: def-c-output on event-box, slot popup should have been wrapped in a (when new-value ...) Date: Mon Feb 14 23:46:20 2005 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.8 root/cells-gtk/widgets.lisp:1.9 --- root/cells-gtk/widgets.lisp:1.8 Sat Feb 12 16:02:56 2005 +++ root/cells-gtk/widgets.lisp Mon Feb 14 23:46:19 2005 @@ -392,7 +392,8 @@ :above-child t) (def-c-output popup ((self event-box)) - (setf (fm-parent new-value) self)) + (when new-value + (setf (fm-parent new-value) self))) (def-c-output visible-window ((self event-box)) (gtk-event-box-set-visible-window (id self) new-value))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp
by pdenno＠common-lisp.net 13 Feb '05

13 Feb '05

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv10004/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: non-printing characters in cut-and-paste of Andras's patch Date: Sun Feb 13 19:21:29 2005 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.10 root/gtk-ffi/gtk-utilities.lisp:1.11 --- root/gtk-ffi/gtk-utilities.lisp:1.10 Sun Feb 13 18:28:02 2005 +++ root/gtk-ffi/gtk-utilities.lisp Sun Feb 13 19:21:29 2005 @@ -190,11 +190,11 @@ (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) #-(or lispworks cmu allegro) (cast item (as-gtk-type-name cell-type)) - #+allegro - (case cell-type - (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) - (t (cast item (as-gtk-type-name cell-type)))) - #+lispworks + #+allegro + (case cell-type + (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) + (t (cast item (as-gtk-type-name cell-type)))) + #+lispworks (case cell-type (:string (fli:convert-from-foreign-string (fli:dereference item))) (t (fli:dereference item)))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp
by pdenno＠common-lisp.net 13 Feb '05

13 Feb '05

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv6967/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: Andras's #+allegro patch for tree selection Date: Sun Feb 13 18:28:02 2005 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.9 root/gtk-ffi/gtk-utilities.lisp:1.10 --- root/gtk-ffi/gtk-utilities.lisp:1.9 Sat Feb 12 16:09:52 2005 +++ root/gtk-ffi/gtk-utilities.lisp Sun Feb 13 18:28:02 2005 @@ -180,7 +180,7 @@ (g-value-unset value)))) ;;; todo: The deref-pointer-runtime-typed used by case needs work if -;;; it is going to be used for lispworks and cmu. +;;; it is going to be used for lispworks, cmu and allegro. ;;; (needs someone who knows how ffi-to-uffi-type maps types for those lisps.) ;;; Even better, eliminate it. It is ill-conceived. (defun gtk-tree-model-get-cell (model iter column-no cell-type) @@ -189,15 +189,19 @@ column-no = num-columns. (See gtk-tree-store-set-kids)." (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) - #-(or lispworks cmu) (cast item (as-gtk-type-name cell-type)) - #+lispworks - (case cell-type - (:string (fli:convert-from-foreign-string (fli:dereference item))) - (t (fli:dereference item))) - #+cmu - (case cell-type - (:string (alien:cast (alien:deref item) c-call:c-string)) - (t (alien:deref item))))) + #-(or lispworks cmu allegro) (cast item (as-gtk-type-name cell-type)) + #+allegro + (case cell-type + (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) + (t (cast item (as-gtk-type-name cell-type)))) + #+lispworks + (case cell-type + (:string (fli:convert-from-foreign-string (fli:dereference item))) + (t (fli:dereference item))) + #+cmu + (case cell-type + (:string (alien:cast (alien:deref item) c-call:c-string)) + (t (alien:deref item))))) (defun parse-cell-attrib (attribs) (loop for (attrib val) on attribs by #'cddr collect

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp
by pdenno＠common-lisp.net 13 Feb '05

13 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv6944/cells-gtk Modified Files: gtk-app.lisp Log Message: better error message Date: Sun Feb 13 18:25:14 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.10 root/cells-gtk/gtk-app.lisp:1.11 --- root/cells-gtk/gtk-app.lisp:1.10 Sat Feb 12 20:11:55 2005 +++ root/cells-gtk/gtk-app.lisp Sun Feb 13 18:25:13 2005 @@ -90,7 +90,7 @@ do (gtk-main-iteration-do nil)) (process-wait-with-timeout .01 "GTK event loop waiting")) (gtk-cells-error (err) - (show-message (format nil "Error: ~a" err) :message-type :error) + (show-message (format nil "Cells-GTK Error: ~a" err) :message-type :error) (process-wait "Acknowledge error" #'gtk-events-pending) (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)) (throw 'try-again nil))))))))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/dialogs.lisp
by pdenno＠common-lisp.net 13 Feb '05

13 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv6914/cells-gtk Modified Files: dialogs.lisp Log Message: Without the gtk-object-forget, with frequent use of the file-chooser, you will get an error: Error: gtk-object-store id 136368864 already known as #<FILE-CHOOSER-DIALOG 239AA2A4>, not #<FILE-CHOOSER-DIALOG 206F656C> There are probably other places where widgets are destroyed but the hash-table not cleaned up, but this is the only one so far where I have seen an error. Date: Sun Feb 13 18:24:02 2005 Author: pdenno Index: root/cells-gtk/dialogs.lisp diff -u root/cells-gtk/dialogs.lisp:1.2 root/cells-gtk/dialogs.lisp:1.3 --- root/cells-gtk/dialogs.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/dialogs.lisp Sun Feb 13 18:24:02 2005 @@ -132,7 +132,8 @@ (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))))) - (gtk-widget-destroy (id self)))) + (gtk-widget-destroy (id self)) + (gtk-object-forget (id self) self))) (defun file-chooser (&rest inits) (let ((dialog (to-be (apply #'mk-file-chooser-dialog inits))))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp
by pdenno＠common-lisp.net 12 Feb '05

12 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv1611/cells-gtk Modified Files: gtk-app.lisp Log Message: The wait loop approach that works for lispworks doesn't really work for cmucl (uses too much processor). Nor does simple process-wait with gtk-event-pending work, which is unfortunate. Date: Sat Feb 12 20:11:56 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.9 root/cells-gtk/gtk-app.lisp:1.10 --- root/cells-gtk/gtk-app.lisp:1.9 Sat Feb 12 15:50:29 2005 +++ root/cells-gtk/gtk-app.lisp Sat Feb 12 20:11:55 2005 @@ -81,14 +81,14 @@ (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) - #+clisp(gtk-main) - #-clisp + #-lispworks(gtk-main) + #+lispworks (catch 'try-again (handler-case (loop (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting" #'(lambda () t))) + (process-wait-with-timeout .01 "GTK event loop waiting")) (gtk-cells-error (err) (show-message (format nil "Error: ~a" err) :message-type :error) (process-wait "Acknowledge error" #'gtk-events-pending)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/compat.lisp
by pdenno＠common-lisp.net 12 Feb '05

12 Feb '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv1581/cells-gtk Modified Files: compat.lisp Log Message: in lispworks, when process-wait-with-timeout is supplied with a predicate, event if #'(lambda () t) it has much different characteristics, than when it isn't supplied with one at all. So why isn't this just mp:sleep? I don't know. Date: Sat Feb 12 20:09:24 2005 Author: pdenno Index: root/cells-gtk/compat.lisp diff -u root/cells-gtk/compat.lisp:1.1 root/cells-gtk/compat.lisp:1.2 --- root/cells-gtk/compat.lisp:1.1 Sat Feb 12 15:38:37 2005 +++ root/cells-gtk/compat.lisp Sat Feb 12 20:09:24 2005 @@ -28,13 +28,16 @@ #+CMU (mp:process-wait whostate (lambda () (apply predicate args))) #+LispWorks (apply #'mp:process-wait whostate predicate args)) -;;; From clocc port -(defun process-wait-with-timeout (timeout whostate predicate &rest args) - "Sleep until PREDICATE becomes true, or for TIMEOUT seconds, -whichever comes first." +;;; From clocc port, but with additions and deletions +(defun process-wait-with-timeout (timeout whostate + &optional (predicate #'(lambda () t) pred-supplied-p) + &rest args) + "Sleep until PREDICATE becomes true, or for TIMEOUT seconds, whichever comes first." #+Allegro (apply #'mp:process-wait-with-timeout whostate timeout predicate args) #+CMU (mp:process-wait-with-timeout whostate timeout (lambda () (apply predicate args))) #+LispWorks - (apply #'mp:process-wait-with-timeout whostate timeout predicate args)) + (if pred-supplied-p + (apply #'mp:process-wait-with-timeout whostate timeout predicate args) + (mp:process-wait-with-timeout whostate timeout)))

1 0

[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