June 2006 - cells-gtk-cvs@common-lisp.net

[cells-gtk-cvs] CVS public_html
by pdenno 30 Jun '06

30 Jun '06

Update of /project/cells-gtk/cvsroot/public_html In directory clnet:/tmp/cvs-serv20417/public_html Modified Files: index.html Log Message: Announce new tarballs --- /project/cells-gtk/cvsroot/public_html/index.html 2006/06/07 17:20:10 1.28 +++ /project/cells-gtk/cvsroot/public_html/index.html 2006/06/30 15:45:25 1.29 @@ -74,6 +74,7 @@ <h1 id='news'>News</h1> <ul> + <li> <strong>2006-06-30</strong> New tarballs. See below. <li> <strong>2006-06-07</strong> <ul> <li>Patches from Andras Simon allow Cells-GTK to load without complaints under @@ -134,6 +135,16 @@ snapshots of the CVS repository, and contain all the ancillary modules (cells, cffi, etc). Here are a few: <ul> + <li><a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-06-30.tgz">cells-gtk-2006-06-30.tgz</a> and <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-06-30.zip">cells-gtk-2006-06-30.zip</a> and + <ul> + <li>Uses 2006-06-26 version of CFFI. + <li>Cleaner load with sbcl. (Thanks, Andras Simon.) + <li>Tested with LINUX: LW/Pro, sbcl, clisp; WIN32: clisp. + <li>Seems to have problems loading libraries with cmucl (not investigated much). + <li>I (Peter Denno) had problems with LW/Win32. But others seem ok. -- If this form:<br> + <tt>(fli:register-module "libgdk-win32-2.0-0.dll" :connection-style :immediate)</tt><br> + -- returns OK (once you've installed GTK libs) then you should be OK. + </ul> <li><a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">cells-gtk-2006-02-16.tgz</a> <ul> <li>Native CFFI. That is, not Hello-C to UFFI, to CFFI-UFFI-COMPAT (yuk!).</li>

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 30 Jun '06

30 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv16532/root/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: Use cffi-features. --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/06/07 17:00:25 1.21 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/06/30 15:26:54 1.22 @@ -82,63 +82,57 @@ (setf (cffi:mem-aref (cffi:foreign-slot-value obj obj-type slot) :int index) new-value)) -(cffi:define-foreign-library 'gobject - (:linux "libgobject-2.0.so") - (:win32 "libgobject-2.0-0.dll") - (:macosx "libgobject-2.0-0.dylib")) +(eval-when (:compile-toplevel :load-toplevel :execute) +(cffi:define-foreign-library :gobject + (cffi-features:unix "libgobject-2.0.so") + (cffi-features:windows "libgobject-2.0-0.dll") + (cffi-features:darwin "libgobject-2.0-0.dylib")) (cffi:define-foreign-library :glib - (:linux "libglib-2.0.so") - (:win32 "libglib-2.0-0.dll") - (:macosx "libglib-2.0-0.dylib")) + (cffi-features:unix "libglib-2.0.so") + (cffi-features:windows "libglib-2.0-0.dll") + (cffi-features:darwin "libglib-2.0-0.dylib")) (cffi:define-foreign-library :gthread - (:linux "libgthread-2.0.so") - (:win32 "libgthread-2.0-0.dll") - (:macosx "libgthread-2.0-0.dylib")) + (cffi-features:unix "libgthread-2.0.so") + (cffi-features:windows "libgthread-2.0-0.dll") + (cffi-features:darwin "libgthread-2.0-0.dylib")) (cffi:define-foreign-library :gdk - (:linux "libgdk-x11-2.0.so") - (:win32 "libgdk-win32-2.0-0.dll") - (:macosx "libgdk-win32-2.0-0.dylib")) ; pod ??? + (cffi-features:unix "libgdk-x11-2.0.so") + (cffi-features:windows "libgdk-win32-2.0-0.dll") + (cffi-features:darwin "libgdk-win32-2.0-0.dylib")) ; pod ??? (cffi:define-foreign-library :gtk - (:linux "libgtk-x11-2.0.so") - (:win32 "libgtk-win32-2.0-0.dll") - (:macosx "libgtk-win32-2.0-0.dylib")) ; pod ??? + (cffi-features:unix "libgtk-x11-2.0.so") + (cffi-features:windows "libgtk-win32-2.0-0.dll") + (cffi-features:darwin "libgtk-win32-2.0-0.dylib")) ; pod ??? #+libcellsgtk (cffi:define-foreign-library :cgtk - (:linux "libcellsgtk.so") - (:win32 "libcellsgtk.dll") - (:macosx "libcellsgtk.dylib")) + (cffi-features:unix "libcellsgtk.so") + (cffi-features:windows "libcellsgtk.dll") + (cffi-features:darwin "libcellsgtk.dylib")) +) ;eval-when ;;; After doing this, should be able to do (g-thread-init c-null) ;;; The above define-foreigh-library appears to be useless (doesn't ;;; work through the symbols) use the names. + +;;; LW Win32 is hanging on POD's machine only: +;;; (fli:register-module "libgdk-win32-2.0-0.dll" :connection-style :immediate) +;;; (fli:register-module "c:\\Program Files\\Common Files\\GTK\\2.0\\bin\\libgdk-win32-2.0-0.dll" +;;; :connection-style :immediate) (eval-when (:compile-toplevel :load-toplevel :execute) (defun load-gtk-libs () (handler-bind ((style-warning #'muffle-warning)) - (cffi:load-foreign-library #+cffi-features:unix "libgobject-2.0.so" - #+win32 "libgobject-2.0-0.dll" - #+macosx "libgobject-2.0-0.dylib") - (cffi:load-foreign-library #+cffi-features:unix "libglib-2.0.so" - #+win32 "libglib-2.0-0.dll" - #+macosx "libglib-2.0-0.dylib") - (cffi:load-foreign-library #+cffi-features:unix "libgthread-2.0.so" - #+win32 "libgthread-2.0-0.dll" - #+macosx "libgthread-2.0-0.dylib") - (cffi:load-foreign-library #+cffi-features:unix "libgdk-x11-2.0.so" - #+win32 "libgdk-win32-2.0-0.dll" - #+macosx "libgdk-win32-2.0-0.dylib") - (cffi:load-foreign-library #+cffi-features:unix "libgtk-x11-2.0.so" - #+win32 "libgtk-win32-2.0-0.dll" - #+macosx "libgtk-win32-2.0-0.dylib") + (cffi:load-foreign-library :gobject) + (cffi:load-foreign-library :glib) + (cffi:load-foreign-library :gthread) + (cffi:load-foreign-library :gdk) + (cffi:load-foreign-library :gtk) #+libcellsgtk - (cffi:load-foreign-library #+cffi-features:unix - (merge-pathnames "libcellsgtk.so" #.*compile-file-pathname*) - #+win32 "libcellsgtk.dll" - #+macosx "libcellsgtk.dylib"))) + (cffi:load-foreign-library :cgtk))) ) ; eval (eval-when (:compile-toplevel :load-toplevel :execute)

1 0

[cells-gtk-cvs] CVS root/cells-gtk/test-gtk
by pdenno 30 Jun '06

30 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv16486/root/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: export gtk-demo --- /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk/test-gtk.lisp 2006/02/19 20:19:13 1.13 +++ /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk/test-gtk.lisp 2006/06/30 15:25:11 1.14 @@ -1,5 +1,6 @@ (defpackage :test-gtk - (:use :common-lisp :pod :cells :gtk-ffi :cells-gtk)) + (:use :common-lisp :pod :cells :gtk-ffi :cells-gtk) + (:export gtk-demo)) (in-package :test-gtk)

1 0

[cells-gtk-cvs] CVS
by pdenno 30 Jun '06

30 Jun '06

Update of /project/cells-gtk/cvsroot In directory clnet:/tmp/cvs-serv16383 Modified Files: load.lisp Log Message: gtk-demo now exported, so no :: --- /project/cells-gtk/cvsroot/load.lisp 2006/02/19 20:07:06 1.2 +++ /project/cells-gtk/cvsroot/load.lisp 2006/06/30 15:24:21 1.3 @@ -38,7 +38,7 @@ (asdf:oos 'asdf:load-op :cells-gtk) (asdf:oos 'asdf:load-op :test-gtk)) -(format t "~3% Done! Now try (test-gtk::gtk-demo)") +(format t "~3% Done! Now try (test-gtk:gtk-demo) or if problems, (test-gtk:gtk-demo t)")

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by asimon 20 Jun '06

20 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv30553/cells-gtk Modified Files: drawing.lisp Log Message: Move export to the package def --- /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp 2006/06/07 16:40:06 1.7 +++ /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp 2006/06/20 14:45:59 1.8 @@ -69,7 +69,6 @@ (gtk-signal-connect-swap widget "expose-event" (cffi:get-callback 'drawing-expose-event-handler) :data data)) -(export '(gtk-drawing-set-handlers)) ;;;============================================================================ (in-package :cgtk)

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by asimon 20 Jun '06

20 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv30524/cells-gtk Modified Files: packages.lisp Log Message: Move export to the package def --- /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/06/07 16:43:08 1.6 +++ /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/06/20 14:45:47 1.7 @@ -32,7 +32,6 @@ #:push-message #:pop-message #:pulse - #:gtk-drawing-set-handlers #:*gcontext* #:with-pixmap #:with-gc

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by asimon 20 Jun '06

20 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv28938/gtk-ffi Modified Files: package.lisp Log Message: Move export to the package def --- /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp 2006/06/08 14:58:24 1.1 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp 2006/06/20 14:44:42 1.2 @@ -64,5 +64,6 @@ #:gtk-tree-store-set-kids #:gtk-tree-model-get-cell #:gtk-tree-view-render-cell - #:gtk-file-chooser-get-filenames-strs)) + #:gtk-file-chooser-get-filenames-strs + #:gtk-drawing-set-handlers))

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 08 Jun '06

08 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv16868 Added Files: package.lisp Log Message: new file --- /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp 2006/06/08 14:58:24 NONE +++ /project/cells-gtk/cvsroot/root/gtk-ffi/package.lisp 2006/06/08 14:58:24 1.1 #| Gtk ffi Copyright (c) 2004 by Vasilis Margioulas <vasilism(a)sch.gr> You have the right to distribute and use this software as governed by the terms of the Lisp Lesser GNU Public License (LLGPL): (http://opensource.franz.com/preamble.html) This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cl-user) (defpackage :gtk-ffi (:use :common-lisp :pod) (:export #:+c-null+ #:int-slot-indexed #:load-gtk-libs #:uint #:c-pointer #:c-ptr-null #:c-array-ptr #:c-ptr #:c-string #:sint32 #:uint32 #:uint8 #:boolean #:ulong #:int #:long #:single-float #:double-float #:otherwise #:*gtk-debug* #:load-gtk-libs #:col-type-to-ffi-type #:deref-pointer-runtime-typed #:gtk-tree-iter #:with-g-value #:gtk-signal-connect #:gtk-signal-connect-swap #:gtk-object-set-property #:with-gtk-string #:get-gtk-string #:to-gtk-string #:with-gdk-threads #:make-gtk-tree-iter #:with-tree-iter #:gtk-widget-set-popup #:gvi #:gtk-list-store-new #:gtk-list-store-set #:gtk-list-store-set-items #:gtk-tree-store-new #:gtk-tree-store-set #:gtk-tree-store-set-kids #:gtk-tree-model-get-cell #:gtk-tree-view-render-cell #:gtk-file-chooser-get-filenames-strs))

1 0

[cells-gtk-cvs] CVS public_html
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/public_html In directory clnet:/tmp/cvs-serv7775/public_html Modified Files: index.html Log Message: Announce in NEWS adds to CVS. --- /project/cells-gtk/cvsroot/public_html/index.html 2006/06/01 14:14:21 1.27 +++ /project/cells-gtk/cvsroot/public_html/index.html 2006/06/07 17:20:10 1.28 @@ -74,13 +74,22 @@ <h1 id='news'>News</h1> <ul> + <li> <strong>2006-06-07</strong> + <ul> + <li>Patches from Andras Simon allow Cells-GTK to load without complaints under + SBCL. (Tested under SBCL 0.9.12).</li> + <li>The patch also allows libcellsgtk.so to be located wherever it + was built, rather than having to copy it to /usr/lib, etc.</li> + <li>A version of Cells (What was called "Cells 2" at some point) was added to CVS. + Having our own copy should help keep things stable as Cells evolves.</li> + </ul> <li> <strong>2006-06-01</strong> Patches from Marco Gidde make Cells-GTK work better under SBCL. These patches were applied to the CVS repository, but are not in any snapshot yet. See the repository versions of gtk-ffi/gtk-utilities.lisp pod-utils/utils.lisp and gtk-ffi/gtk-ffi.lisp for the fixes, or read the <a href='http://common-lisp.net/pipermail/cells-gtk-devel/2006-May/000171.html'> - mail</a> from Marco. It includes the patches. + mail</a> from Marco. It includes the patches.</li> <li> <strong>2006-02-16</strong> Native CFFI now used in most of the code. There is a - <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">snapshot release</a>. + <a href="ftp://common-lisp.net/pub/project/cells-gtk/cells-gtk-2006-02-16.tgz">snapshot release</a>.</li> <li> <strong>2006-01-03</strong> BIG NEWS! cells-gtk now runs under <a href="http://clisp.cons.org">CLISP</a> and uses <a href="http://common-lisp.net/project/cffi/">CFFI</a>, not Hello-c for its foreign function interface. The 2006-01-03 tarball reflects these changes. Especial thanks to Novikov Leonid, who did the CLISP port @@ -94,7 +103,7 @@ <a href="http://common-lisp.net/pipermail/cells-gtk-devel/2006-January.txt">note</a> in the cells-gtk-devel archive for January 2006. </ul> - If I didn't break anything, it also works with CLISP/PC and Lispworks/PC.</li> + If I didn't break anything, it also works with CLISP/Win32 and Lispworks/Win32.</li> <li> <strong>2005-11-15</strong> We now provide the win32 .dll and linux .so for libcellsgtk. They are: <a href="ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.so">this for linux</a> and

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv5703/root/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp 2006/06/01 14:18:22 1.20 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-utilities.lisp 2006/06/07 17:02:06 1.21 @@ -210,7 +210,7 @@ (ecase col-type ((:string :icon) (get-gtk-string - (cffi:make-pointer (cffi:mem-aref buffer :pointer 0) :cstring))) + (cffi:make-pointer (cffi:mem-aref buffer :pointer 0)))) (:boolean (not (zerop (cffi:mem-aref buffer :unsigned-char 0)))) (:date (cffi:mem-aref buffer :FLOAT 0)) (:int (cffi:mem-aref buffer :int 0)) @@ -268,15 +268,4 @@ collect (cffi:foreign-slot-value lst-address 'gslist 'data) finally (g-slist-free glist)))) -(eval-when (compile load eval) - (export '(gtk-signal-connect gtk-signal-connect-swap gtk-object-set-property - with-gtk-string get-gtk-string to-gtk-string - with-gdk-threads make-gtk-tree-iter with-tree-iter - gtk-widget-set-popup gvi - gtk-list-store-new gtk-list-store-set gtk-list-store-set-items - gtk-tree-store-new gtk-tree-store-set gtk-tree-store-set-kids - gtk-tree-model-get-cell - gtk-tree-view-render-cell - gtk-file-chooser-get-filenames-strs - )))

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv5638/root/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/06/01 14:16:28 1.20 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.lisp 2006/06/07 17:00:25 1.21 @@ -16,11 +16,6 @@ |# -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package :gtk-ffi) - (defpackage :gtk-ffi - (:use :common-lisp :pod)))) - (in-package :gtk-ffi) ;;; POD throw-away utility to convert hello-c/uffi to cffi @@ -50,8 +45,12 @@ funcs)) *standard-output*)))) +;;keep SBCL happy +(defconstant +c-null+ + (if (boundp '+c-null+) + (symbol-value '+c-null+) + (cffi:null-pointer))) -(defconstant +c-null+ (cffi:null-pointer)) (defvar *gtk-debug* nil) ;;; ============== Define CFFI types, and their translations.... @@ -136,13 +135,13 @@ #+win32 "libgtk-win32-2.0-0.dll" #+macosx "libgtk-win32-2.0-0.dylib") #+libcellsgtk - (cffi:load-foreign-library #+cffi-features:unix "libcellsgtk.so" + (cffi:load-foreign-library #+cffi-features:unix + (merge-pathnames "libcellsgtk.so" #.*compile-file-pathname*) #+win32 "libcellsgtk.dll" #+macosx "libcellsgtk.dylib"))) ) ; eval (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(+c-null+ int-slot-indexed load-gtk-libs)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) @@ -425,9 +424,5 @@ (defun cast (ptr type) (deref-pointer-runtime-typed ptr (ffi-to-uffi-type type))) -(eval-when (compile load eval) - (export '(uint c-pointer c-ptr-null c-array-ptr c-ptr c-string sint32 uint32 uint8 boolean - ulong int long single-float double-float otherwise *gtk-debug* load-gtk-libs - col-type-to-ffi-type deref-pointer-runtime-typed gtk-tree-iter +c-null+)))

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv4089/root/gtk-ffi Modified Files: gtk-ffi.asd Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.asd 2006/02/19 20:16:57 1.13 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-ffi.asd 2006/06/07 16:57:38 1.14 @@ -13,7 +13,8 @@ :name "gtk-ffi" :depends-on (:cells :pod-utils :cffi :cffi-uffi-compat) :components - ((:file "gtk-ffi") + ((:file "package") + (:file "gtk-ffi" :depends-on ("package")) (:file "gtk-core" :depends-on ("gtk-ffi")) (:file "gtk-other" :depends-on ("gtk-ffi")) (:file "gtk-button" :depends-on ("gtk-ffi"))

1 0

[cells-gtk-cvs] CVS root/gtk-ffi
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory clnet:/tmp/cvs-serv3884/root/gtk-ffi Modified Files: gtk-core.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-core.lisp 2006/02/19 20:15:07 1.8 +++ /project/cells-gtk/cvsroot/root/gtk-ffi/gtk-core.lisp 2006/06/07 16:51:34 1.9 @@ -77,8 +77,6 @@ (funcall fn gva) (cffi:foreign-free gva))) -(eval-when (compile load eval) (export 'with-g-value)) - #+test (def-gtk-lib-functions :gobject (g-value-set-string ((value c-pointer)

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv3844/root/cells-gtk Modified Files: widgets.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp 2006/02/19 20:14:26 1.18 +++ /project/cells-gtk/cvsroot/root/cells-gtk/widgets.lisp 2006/06/07 16:50:15 1.19 @@ -387,5 +387,3 @@ (defun widget-id (widget) (id widget)) -(eval-when (compile load eval) - (export '(callback callback-if timeout-add focus widget-id)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv3724/root/cells-gtk Modified Files: tree-view.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp 2006/02/19 20:13:51 1.15 +++ /project/cells-gtk/cvsroot/root/cells-gtk/tree-view.lisp 2006/06/07 16:48:59 1.16 @@ -260,5 +260,3 @@ `(list ,@(loop for (type inits renderer) in args collect `(list ,type ',inits ,renderer)))) -(eval-when (compile load eval) - (export '(mk-listbox mk-treebox def-columns)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv2155/root/cells-gtk Modified Files: textview.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp 2006/02/19 20:13:26 1.9 +++ /project/cells-gtk/cvsroot/root/cells-gtk/textview.lisp 2006/06/07 16:44:23 1.10 @@ -150,12 +150,6 @@ (gtk-text-buffer-set-modified (id buffer) val)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(def-populate-adds populate-adds with-text-iters text-buffer-get-text - text-buffer-delete-text text-buffer-insert-text text-buffer-modified-p - text-view-scroll-to-position gtk-text-buffer-get-iter-at-offset - gtk-text-buffer-create-mark gtk-text-view-set-wrap-mode gtk-text-view-set-editable - gtk-text-buffer-move-mark gtk-text-view-scroll-mark-onscreen)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv2107/root/cells-gtk Modified Files: packages.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/02/19 20:12:58 1.5 +++ /project/cells-gtk/cvsroot/root/cells-gtk/packages.lisp 2006/06/07 16:43:08 1.6 @@ -16,10 +16,61 @@ |# +(in-package :cl-user) + (defpackage :cells-gtk (:nicknames :cgtk) - (:use :common-lisp :pod :cells :gtk-ffi)) - - - - + (:use :common-lisp :pod :cells :gtk-ffi) + (:export #:gtk-user-signals-quit + #:gtk-continuable-error + #:gtk-report-error + #:cgtk-set-active-item-by-path + #:gtk-combo-box-set-active + #:show-message + #:file-chooser + #:with-markup + #:push-message + #:pop-message + #:pulse + #:gtk-drawing-set-handlers + #:*gcontext* + #:with-pixmap + #:with-gc + #:draw-line + #:draw-text + #:draw-rectangle + #:insert-pixmap + #:register-gobject + #:gtk-app + #:gtk-reset + #:cells-gtk-init + #:title + #:icon + #:tooltips + #:tooltips-enable + #:tooltips-delay + #:start-app + #:gtk-global-callback-register + #:gtk-global-callback-funcall + #:def-populate-adds + #:populate-adds + #:with-text-iters + #:text-buffer-get-text + #:text-buffer-delete-text + #:text-buffer-insert-text + #:text-buffer-modified-p + #:text-view-scroll-to-position + #:gtk-text-buffer-get-iter-at-offset + #:gtk-text-buffer-create-mark + #:gtk-text-view-set-wrap-mode + #:gtk-text-view-set-editable + #:gtk-text-buffer-move-mark + #:gtk-text-view-scroll-mark-onscreen + #:mk-listbox + #:mk-treebox + #:def-columns + #:callback + #:callback-if + #:timeout-add + #:focus + #:widget-id))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv2058/root/cells-gtk Modified Files: menus.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp 2006/02/19 20:12:16 1.13 +++ /project/cells-gtk/cvsroot/root/cells-gtk/menus.lisp 2006/06/07 16:41:38 1.14 @@ -18,8 +18,6 @@ (in-package :cgtk) -(export '(cgtk-set-active-item-by-path)) - (defmacro with-tree-iters (vars &body body) `(let (,@(loop for var in vars collect `(,var (gtk-adds-tree-iter-new)))) (unwind-protect @@ -305,4 +303,3 @@ (def-widget tearoff-menu-item (menu-item) () () ()) -(export '(gtk-combo-box-set-active)) \ No newline at end of file

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv2016/root/cells-gtk Modified Files: drawing.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp 2006/02/19 20:11:03 1.6 +++ /project/cells-gtk/cvsroot/root/cells-gtk/drawing.lisp 2006/06/07 16:40:06 1.7 @@ -220,5 +220,3 @@ (defvar *my-pixmap* nil) -(export '(*gcontext* with-pixmap with-gc draw-line draw-text draw-rectangle insert-pixmap - register-gobject)) \ No newline at end of file

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv1881/root/cells-gtk Modified Files: gtk-app.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/gtk-app.lisp 2006/02/16 21:56:17 1.17 +++ /project/cells-gtk/cvsroot/root/cells-gtk/gtk-app.lisp 2006/06/07 16:38:52 1.18 @@ -152,7 +152,4 @@ (setf *gtk-loaded* t)) (gtk-reset)) -(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)))

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv1814/root/cells-gtk Modified Files: display.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/display.lisp 2005/02/16 22:18:05 1.3 +++ /project/cells-gtk/cvsroot/root/cells-gtk/display.lisp 2006/06/07 16:36:17 1.4 @@ -153,5 +153,3 @@ (:bottom 3) (t 0))))) -(eval-when (compile load eval) - (export '(with-markup push-message pop-message pulse))) \ No newline at end of file

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv1752/root/cells-gtk Modified Files: dialogs.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/dialogs.lisp 2006/02/16 18:12:54 1.6 +++ /project/cells-gtk/cvsroot/root/cells-gtk/dialogs.lisp 2006/06/07 16:35:03 1.7 @@ -151,5 +151,3 @@ (let ((dialog (to-be (apply #'mk-file-chooser-dialog inits)))) (md-value dialog))) -(eval-when (compile load eval) - (export '(show-message file-chooser))) \ No newline at end of file

1 0

[cells-gtk-cvs] CVS root/cells-gtk
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory clnet:/tmp/cvs-serv1632/root/cells-gtk Modified Files: conditions.lisp Log Message: Applied patches from Andras Simon --- /project/cells-gtk/cvsroot/root/cells-gtk/conditions.lisp 2006/02/16 18:12:15 1.3 +++ /project/cells-gtk/cvsroot/root/cells-gtk/conditions.lisp 2006/06/07 16:32:41 1.4 @@ -34,5 +34,5 @@ (define-condition gtk-user-signals-quit (condition) ()) -(export '(gtk-user-signals-quit gtk-continuable-error gtk-report-error)) +

1 0

[cells-gtk-cvs] CVS cells/doc
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv32368/doc Added Files: 01-Cell-basics.lisp cell-doc.lisp hw.lisp Log Message: new files --- /project/cells-gtk/cvsroot/cells/doc/01-Cell-basics.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/doc/01-Cell-basics.lisp 2006/06/07 16:28:58 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cellsS -*- ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :cells) #| here is a minimal primer on cells, just enough for you to keep up with the next tutorial. that will be a substantial project in which we develop a clos object inspector. the inspector project will give you a feel for what it is like to program with cells and cello /after/ you are fluent in the technology. the intent is not to teach you cello, rather to motivate your learning it. so why the primer on cells? if things like c? and cv and def-c-output do not mean anything to you, the hunh? factor will be overwhelming. cells ----- think of a clos slot as a cell in a paper spreadsheet, a financial modeling tool popular enough to make visi-calc the first business killer app for microcomputers. as a child i watched my father toil at home for hours over paper spreadsheets with pencil and slide rule. after he changed one value, he had to propagate that change to other cells by first remembering which other ones included the changed cell in their computation. then he had to do the calculations for those, erase, enter... and then repeating that process to propagate those changes in a cascade across the paper. visi-calc let my father take the formula he had in mind and put it in (declare it to) the electronic spreadsheet. then visi-calc could do the tedious work: recalculating, knowing what to recalculate, and knowing in what order to recalculate. cells do for programmers what electronic spreadsheets did for my father. without cells, clos slots are like cells of a paper spreadsheet. a single key-down event can cause a cascade of change throughout an application. the programmer has to arrange for it all to happen, all in the right order: delete any selected text, insert the new character, re-wrap the text, update the undo mechanism, revisit the menu statuses ("cut" is no longer enabled), update the scroll bars, possibly scroll the window, flag the file as unsaved... with cells, the programmer looks at program state differently. one asks, "how could i compute, at any point of runtime, a value for a given slot of an arbitrary instance, based only on other runtime state (other slots of other instances)." great fun, by the way, as well as enforcing good programming practices like encapsulation. an example will help. consider indeed the state of the "cut" menu item. in some applications, programmers have a dozen places in their code where they tend to the status of the cut menu item. one might be: (defun do-clear (edit-structure) (when (selected-range edit-structure) <set up undo> <toss selected text> <etc><etc> (menu-item-enable *edit-cut* nil) (menu-item-enable *edit-copy* nil) (menu-item-enable *edit-clear* nil))) other programmers wait until the user clicks on the edit menu, then decide just-in-time from program state whether the cut item should be enabled: (defmethod prep-for-display ((m edit-menu)) <lotsa other stuff> (when (typep (focus *app*) 'text-edit-widget) (menu-item-enable (find :cut (items m) :key #'item-name) (not (null (selected-range (focus *app*))))))) this latter programmer is ready for cells, because they have already shifted from imperative to declarative thinking; they have learned to write code that works based not on what has happened lately, but instead only on the current program state (however it got that way). the cell programmer writes: (make-instance 'menu-item :name :cut :label "cut" :cmd-key +control-x+ :actor #'do-cut :enabled (c? (when (typep (focus *app*) 'text-edit-widget) (not (null (selected-range (focus *app*))))))) ...and now they can forget the menu item exists as they work on the rest of the application. the menu-item enabled status will stay current (correct) as the selected-range changes and as the focus itself changes as the user moves from field to field. that covers the spirit of cells. now let's look at the syntax and mechanics, with examples you can execute once you have loaded the cells package. see the read-me.txt file in the root directory into which the cello software was unzipped. we'll model a falling stone, where the distance fallen is half the product of the acceleration (due to gravity) and the square of the time falling. |# (in-package :cells) (defmodel stone () ((accel :cell t :initarg :accel :initform 0 :accessor accel) (time-elapsed :cell t :initarg :time-elapsed :initform (c-in 0) :accessor time-elapsed) (distance :cell t :initarg :distance :initform 0 :accessor distance)) (:default-initargs :distance (c? (/ (* (accel self) (expt (time-elapsed self) 2)) 2)))) (def-c-output accel ((self stone) new old old-bound-p) (trc "echo accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics (def-c-output time-elapsed ((self stone)) ;; short form (I'm lazy) (trc "echo time-elapsed" :new new-value :old old-value :oldp old-value-boundp)) (def-c-output distance ((self stone)) (format t "~&echo distance fallen: ~d feet" new-value)) #| let's look at non-standard syntax found in the forms above, in the order in which they appear: (defmodel ... defmodel is just a defclass wrapper which also sets up plumbing for cells. ... :cell t ... without this option, a model instance slot cannot be powered by a cell (and cell slot access overhead is avoided). with this option, one can specify what kind of cell is to be defined: ephemeral, delta or t (normal). we'll leave those esoteric cell slot types for another tutorial and just specify t to get normal cells (the ones used 99% of the time). time-elapsed ... :initform (c-in 0)... (c-in <value>) allows the cellular slot (or "cell", for short) to be setf'ed. these are inputs to the dataflow, which usually flows from c? to c? but has to start somewhere. since modern interactve applications are event-driven, in real-world cello apps most cv dataflow inputs are slots closely corresponding to some system value, such as the position slots of a cell-powered mouse class. moving on... a naked value such as the 32 supplied for accel cannot be changed; a runtime error results from any such attempt. this makes cells faster, because some plumbing can be skipped: no dependency gets recorded between the distance traveled and the acceleration. on the other hand, a more elaborate model might have the acceleration varying according to the distance between the stone and earth (in which case we get into an advance topic for another day, namely how to handle circularity.) next: (:default-initargs :distance (c? (/ (* (accel self) (expt (time-elapsed self) 2)) 2) c? associates a rule with a cellular slot (or "cell", for short). any read operation on another cell (directly or during a function call) establishes a dependency of distance on that cell -- unless that cell can never change. why would a cell not be able to change? cell internals enforce a rule that a cell with a naked value (ie, not wrapped in cv or c?) cannot be changed by client code (ok, (setf slot-value) is a backdoor). cell internals enforce this, simply to make possible the optimization of leaving off the overhead of recording a pointless dependency. next: (def-c-output... here is the signature for the def-c-output macro: (defmacro def-c-output (slotname (&optional (self-arg 'self) (new-varg 'new-value) (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) &body echo-body) ....) def-c-output defines a generic method one can specialize on any of the four parameters. the method gets called when the slot value changes, and during initial processing by: (to-be....) to-be brings a new model instance to life, including calling any echos defined for cellular slots. why not just do this in initialize-instance? we build complex models in the form of a tree of many model instances, any of which may depend on some other model instance to calculate some part of its state. models find the one they are curious about by searching the tree. this means we cannot just bring a model instance to life at make-instance time; some cell rule may go looking for another model instance. we must wait until the instance is embedded in the larger model tree, then we can kick off to-be. likewise, when we yank an instance from the larger model we will call not-to-be on it. the good news is that unless i am doing little tutorial examples i never think about calling to-be. trees are implemented in part by a "kids" (short for "children") cell. the echo on that cell calls to-be on new kids and not-to-be on kids no longer in the list. now evaluate the following: |# (defparameter *s2* (make-instance 'stone :accel 32 ;; (constant) feet per second per second :time-elapsed (c-in 0))) #| ...and observe: 0> echo accel :new 32 :old nil :oldp nil 0> echo time-elapsed :new 0 :old nil :oldp nil echo distance fallen: 0 feet getting back to the output shown above, why echo output on a new instance? when we call to-be we want the instance to come to life. that means evaluating every rule so the dependencies get established, and propagating cell values outside the model (by calling the echo methods) to make sure the model and outside world (if only the system display) are consistent. ;----------------------------------------------------------- now let's get moving: |# (setf (time-elapsed *s2*) 1) #| ...and observe: 0> echo time-elapsed :new 1 :old 0 :oldp t echo distance fallen: 16 feet behind the scenes: - the slot value time-elapsed got changed from 0 to 1 - the time-elapsed echo was called - dependents on time-elapsed (here just distance) were recalculated - go to the first step, this time for the distance slot ;----------------------------------------------------------- to see some optimizations at work, set the cell time-elapsed to the same value it already has: |# (setf (time-elapsed *s2*) 1) #| observe: nothing, since the slot-value did not in fact change. ;----------------------------------------------------------- to test the enforcement of the cell stricture against modifying cells holding naked values: |# (handler-case (setf (accel *s2*) 10) (t (error) (trc "error is" error) error)) #| observe: c-setting-debug > constant accel in stone may not be altered..init to (c-in nil) 0> error is #<simple-error @ #x210925f2> ;----------------------------------------------------------- nor may ruled cells be modified arbitrarily: |# (handler-case (setf (distance *s2*) 42) (t (error) (trc "error is" error) error)) #| observe: c-setting-debug > ruled distance in stone may not be setf'ed 0> error is #<simple-error @ #x2123e392> ;----------------------------------------------------------- aside from c?, cv, and def-c-output, another thing you will see in cello code is how complex views are constructed using the family class and its slot kids. every model-object has a parent slot, which gets used along with a family's kids slot to form simple trees navigable up and down. model-objects also have slots for md-name and md-value (don't worry camelcase-haters, that is a declining feature of my code). md-name lets the family trees we build be treated as namespaces. md-value just turns out to be very handy for a lot of things. for example, a check-box instance needs some place to indicate its boolean state. now let's see family in action, using code from the handbook of silly examples. all i want to get across is that a lot happens when one changes the kids slot. it happens automatically, and it happens transparently, following the dataflow implicit in the rules we write, and the side-effects we specify via echo functions. the silly example below just shows the summer (that which sums) getting a new md-value as the kids change, along with some echo output. in real-world applications, where kids represent gui elements often dependent on each other, vastly more can transpire before a simple push into a kids slot has run its course. evaluate: |# (defmodel summer (family) () (:default-initargs :kids (c-in nil) ;; or we cannot add any addend kids later :md-value (c? (reduce #'+ (kids self) :initial-value 0 :key #'md-value)))) (def-c-output .md-value ((self summer)) (trc "the sum of the values of the kids is" new-value)) (def-c-output .kids ((self summer)) (trc "the values of the kids are" (mapcar #'md-value new-value))) ;----------------------------------------------------------- ; now just evaluate each of the following forms one by one, ; checking results after each to see what is going on ; (defparameter *f1* (make-instance 'summer)) #| observe: 0> the sum of the values of the kids is 0 0> the values of the kids are nil ;----------------------------------------------------------|# (push (make-instance 'model :md-value 1) (kids *f1*)) #| observe: 0> the values of the kids are (1) 0> the sum of the values of the kids is 1 ;----------------------------------------------------------|# (push (make-instance 'model :md-value 2) (kids *f1*)) #| observe: 0> the values of the kids are (2 1) 0> the sum of the values of the kids is 3 ;----------------------------------------------------------|# (setf (kids *f1*) nil) #| observe: 0> the values of the kids are nil 0> the sum of the values of the kids is 0 now before closing, it occurs to me you'll need a little [33 lines skipped] --- /project/cells-gtk/cvsroot/cells/doc/cell-doc.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/doc/cell-doc.lisp 2006/06/07 16:28:58 1.1 [215 lines skipped] --- /project/cells-gtk/cvsroot/cells/doc/hw.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/doc/hw.lisp 2006/06/07 16:28:58 1.1 [287 lines skipped]

1 0

[cells-gtk-cvs] CVS cells/utils-kt
by pdenno 07 Jun '06

07 Jun '06

Update of /project/cells-gtk/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv32368/utils-kt Added Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp quad.lisp strings.lisp utils-kt.asd Log Message: new files --- /project/cells-gtk/cvsroot/cells/utils-kt/debug.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/debug.lisp 2006/06/07 16:28:58 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- ;;; ;;; Copyright (c) 1995,2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :utils-kt) (defparameter *trcdepth* 0) (defvar *count* nil) (defvar *counting* nil) (defvar *dbg*) (defvar *stop* nil) (defun utils-kt-reset () (setf *count* nil *stop* nil *dbg* nil *trcdepth* 0)) ;----------- trc ------------------------------------------- (defun trcdepth-reset () (setf *trcdepth* 0)) (defmacro trc (tgt-form &rest os &aux (wrapper (if (macro-function 'without-c-dependency) 'without-c-dependency 'progn))) (if (eql tgt-form 'nil) '(progn) (if (stringp tgt-form) `(,wrapper (call-trc t ,tgt-form ,@os)) (let ((tgt (gensym))) `(,wrapper (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn (assert (stringp ,(car os))) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn ;;(break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) (defun call-trc (stream s &rest os) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) (format stream "~a" s) (let (pkwp) (dolist (o os) (format stream (if pkwp " ~s" " | ~s") o) (setf pkwp (keywordp o)))) (values)) (defun call-trc-to-string (fmt$ &rest fmt-args) (let ((o$ (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))) (with-output-to-string (os-stream o$) (apply 'call-trc os-stream fmt$ fmt-args)) o$)) #+findtrcevalnils (defmethod trcp :around (other) (unless (call-next-method other)(break))) (defmethod trcp (other) (eq other t)) (defmethod trcp (($ string)) t) (defun trcdepth-incf () (incf *trcdepth*)) (defun trcdepth-decf () (format t "decrementing trc depth ~d" *trcdepth*) (decf *trcdepth*)) (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) `(let ((*trcdepth* (if *trcdepth* (1+ *trcdepth*) 0))) ,(when banner `(when (>= *trcdepth* ,min) (if (< *trcdepth* ,max) (trc ,@banner) (progn (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) nil)))) (when (< *trcdepth* ,max) ,@body))) (defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) (declare (ignore min max banner)) `(progn ,@body)) ;------ eko -------------------------------------- (defmacro eko ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) ,result))) (defmacro eko-if ((test &rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) (when ,test (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))) ,result))) (defmacro ek (label &rest body) (let ((result (gensym))) `(let ((,result (,@body))) (when ,label (trc ,label ,result)) ,result))) ;------------- counting --------------------------- (defmacro with-counts ((onp &rest msg) &body body) `(if ,onp (let ((*counting* (cons t *counting*))) (prog2 (count-clear ,@msg) (progn ,@body) (show-count t ,@msg))) (progn ,@body))) (defun count-of (key) (cdr (assoc key *count* :key 'car))) (defun count-clear (&rest msg) (declare (ignorable msg)) (format t "~&count-clear > ~a" msg) (setf *count* nil)) (defmacro count-it (&rest keys) `(when *counting* (call-count-it ,@keys))) (defun call-count-it (&rest keys) (declare (ignorable keys)) ;;; (when (eql :TGTNILEVAL (car keys))(break)) (let ((entry (assoc keys *count* :test #'equal))) (if entry (setf (cdr entry) (1+ (cdr entry))) (push (cons keys 1) *count*)))) (defun show-count (clearp &rest msg) (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) (let ((res (sort (copy-list *count*) (lambda (v1 v2) (let ((v1$ (symbol-name (caar v1))) (v2$ (symbol-name (caar v2)))) (if (string= v1$ v2$) (< (cdr v1) (cdr v2)) (string< v1$ v2$)))))) ) (loop for entry in res for occs = (cdr entry) when (plusp occs) sum occs into running and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) (when clearp (count-clear "show-count"))) ;-------------------- timex --------------------------------- (eval-when (compile eval load) (export '(timex))) (defmacro timex ((onp &rest trcargs) &body body) `(if ,onp (prog1 (time (progn ,@body)) (trc "timing was of" ,@trcargs)) (progn ,@body))) #+save (defun dbg-time-report (cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes) (trc "cpu-gc-user" cpu-gc-user) (trc "cpu-gc-sys" cpu-gc-sys) (trc "cpu-tot-user" cpu-tot-user) (trc "cpu-tot-sys" cpu-tot-sys) (trc "<non-gc user cpu>" (- cpu-tot-user cpu-gc-user)) (trc "<non-gc sys cpu>" (- cpu-tot-sys cpu-gc-sys)) (trc "conses" conses) (trc "other-bytes" other-bytes) (trc "static-bytes" static-bytes) (excl::time-report cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes)) ;---------------- Metrics ------------------- (defmacro with-metrics ((countp timep &rest trcargs) form-measured &body postlude) `(with-counts (,countp ,@trcargs) (timex (,timep ,@trcargs) ,form-measured) ,@postlude)) --- /project/cells-gtk/cvsroot/cells/utils-kt/defpackage.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/defpackage.lisp 2006/06/07 16:28:58 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- ;;; ;;; Copyright (c) 1995,2004 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :cl-user) (defpackage :utils-kt (:nicknames #:ukt) (:use #:common-lisp #-(or cormanlisp cmu sbcl) #:clos #+sbcl #:sb-mop #+mcl #:ccl) (:export #:utils-kt-reset #:eko #:count-it #:count-of #:trc #:trcp #:wdbg #:maptimes #:bwhen #:bif #:xor #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics #:shortc #:intern$ #:define-constant #:*count* #:*stop* #:*dbg* #:*trcdepth* #:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo #:with-gensyms #:ensure-gethash #-(or lispworks mcl) #:true #+clisp #:slot-definition-name )) --- /project/cells-gtk/cvsroot/cells/utils-kt/detritus.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/detritus.lisp 2006/06/07 16:28:58 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :utils-kt) (defmacro wdbg (&body body) `(let ((*dbg* t)) ,@body)) #+mcl (defun class-slots (c) (nconc (copy-list (class-class-slots c)) (copy-list (class-instance-slots c)))) #-(or lispworks mcl) (defun true (it) (declare (ignore it)) t) (defun false (it) (declare (ignore it))) (defun xor (c1 c2) (if c1 (not c2) c2)) (defun make-fifo-queue () (cons nil nil)) (defun fifo-add (q new) (if (car q) (let ((last (cdr q)) (newlast (list new))) (rplacd last newlast) (rplacd q newlast)) (let ((newlist (list new))) (rplaca q newlist) (rplacd q newlist)))) (defun fifo-queue (q) (car q)) (defun fifo-empty (q) (not (car q))) (defun fifo-pop (q) (prog1 (caar q) (rplaca q (cdar q)))) (defun mapfifo (fn q) (loop until (fifo-empty q) do (funcall fn (fifo-pop q)))) #+test (let ((*print-circle* t)) (let ((q (make-fifo-queue))) (loop for n below 3 do (fifo-add q n)) (fifo-queue q) (loop until (fifo-empty q) do (print (fifo-pop q))))) (defmacro define-constant (name value &optional docstring) "Define a constant properly. If NAME is unbound, DEFCONSTANT it to VALUE. If it is already bound, and it is EQUAL to VALUE, reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, resulting in implementation-specific behavior." `(defconstant ,name (if (not (boundp ',name)) ,value (let ((value ,value)) (if (equal value (symbol-value ',name)) (symbol-value ',name) value))) ,@(when docstring (list docstring)))) (defmacro with-gensyms (syms &body body) "Paul Graham ON LISP pg 145. Used in macros to avoid variable capture." `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) ,@body)) (defmacro ensure-gethash (object ht default) "Sam Steingold: Just like GETHASH with the default argument, but DEFAULT is only evaluated when OBJECT is not found and in that case the value of DEFAULT is placed into (GETHASH OBJECT HT)." (with-gensyms (obj tab) `(let ((,obj ,object) (,tab ,ht)) (or (gethash ,obj ,tab) (setf (gethash ,obj ,tab) ,default))))) --- /project/cells-gtk/cvsroot/cells/utils-kt/flow-control.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/flow-control.lisp 2006/06/07 16:28:58 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*- ;;; ;;; ;;; Copyright (c) 1995,2003 by Kenneth William Tilton. ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. (in-package :utils-kt) (defun last1 (thing) (car (last thing))) (defun max-if (&rest values) (loop for x in values when x maximize x)) (defun min-max-of (v1 v2) (values (min-if v1 v2) (max-if v1 v2))) [100 lines skipped] --- /project/cells-gtk/cvsroot/cells/utils-kt/quad.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/quad.lisp 2006/06/07 16:28:58 1.1 [226 lines skipped] --- /project/cells-gtk/cvsroot/cells/utils-kt/strings.lisp 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/strings.lisp 2006/06/07 16:28:58 1.1 [434 lines skipped] --- /project/cells-gtk/cvsroot/cells/utils-kt/utils-kt.asd 2006/06/07 16:28:58 NONE +++ /project/cells-gtk/cvsroot/cells/utils-kt/utils-kt.asd 2006/06/07 16:28:58 1.1 [461 lines skipped]

1 0