cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS cells-gtk3/gtk-ffi
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv5005/gtk-ffi Added Files: Makefile Makefile.win32 gdk-other.lisp gtk-adds.c gtk-button.lisp gtk-core.lisp gtk-ffi-impl.lisp gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-gl-ext.lisp gtk-list-tree.lisp gtk-menu.lisp gtk-other.lisp gtk-threads.lisp gtk-tool.lisp gtk-utilities.lisp libcellsgtk-solaris.so libcellsgtk.so package.lisp specs.new Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile 2008/04/13 10:59:23 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.so FOR LINUX AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.so # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # In order to compile the library you will need to have on hand the C header files # corresponding the libgtk.so you are using. # See http://developer.gnome.org/doc/API/2.4/gtk/gtk-building.html # On linux, it is a matter of installing 4 or 5 .rpms and typing "make" # Or at least that is how it worked for me. # # Once built, place the library in the directory containing libgtk. all: gcc -fPIC -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` gcc -shared -o libcellsgtk.so gtk-adds.o `pkg-config --cflags --libs gtk+-2.0` solaris: gcc -fPIC -R/opt/csw/lib -L/opt/csw/lib -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0 glib-2.0` gcc -fPIC -R/opt/csw/lib -L/opt/csw/lib -shared -o libcellsgtk.so gtk-adds.o `pkg-config --cflags --libs gtk+-2.0 glib-2.0` --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile.win32 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/Makefile.win32 2008/04/13 10:59:23 1.1 # # Purpose: build libcellsgtk.so # # NOTE THAT THERE IS A libcellsgtk.dll FOR WIN32 AT: # ftp://common-lisp.net/pub/project/cells-gtk/libcellsgtk.dll # If you try it, I'd be interested to know if you have problems due to # version mismatch with your GTK+ installation # # You don't need libCellsGtk.so to run the demo, but you will to: # - add an entry text widget to a dialog # - add menu items using populate-popup (see GTK textview). # - Use a TreeModel (hierarchical arrangment of items) in a ComboBox. # - Use GTK text iters (used for marking text in text-buffers). # - Use the drawing function: setting colors, getting the window of a widget # # As of this writing, those are the only situations where it is needed. # But this list is getting longer with each release. # See FAQ.txt for more of the motivation. # # I build libcellsgtk.dll under cygwin. I use the win32 development directories from the site # ftp://ftp.gtk.org/pub/gtk/v2.8/win32 and also ftp://ftp.gtk.org/pub/gtk/v2.8/dependencies # I tried also the gtk-devel stuff you can get directly # with cygwin setup.exe, but it doesn't seem to have everything you need. When you get it all # downloaded, modify the '.pc' files in /local/win32/gtk/lib/pkgconfig so that prefix= # is set to wherever you placed the stuff. # Here is a list of the pc (package config) files.... # # -rwx------ 1 pdenno users 267 2005-11-13 15:02 atk.pc # -rwx------ 1 pdenno users 267 2005-11-13 15:02 cairo.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-2.0.pc # -rwx------ 1 pdenno users 287 2005-11-13 15:03 gdk-pixbuf-2.0.pc # -rwx------ 1 pdenno users 336 2005-11-13 15:03 gdk-win32-2.0.pc # -rwx------ 1 pdenno users 355 2005-11-13 15:03 glib-2.0.pc # -rwx------ 1 pdenno users 260 2005-11-13 15:04 gmodule-2.0.pc # -rwx------ 1 pdenno users 259 2005-11-13 15:04 gmodule-no-export-2.0.pc # -rwx------ 1 pdenno users 251 2005-11-13 15:04 gobject-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:05 gthread-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-2.0.pc # -rwx------ 1 pdenno users 362 2005-11-13 15:05 gtk+-win32-2.0.pc # -rwx------ 1 pdenno users 229 2005-11-13 15:07 libpng.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng12.pc # -rwx------ 1 pdenno users 229 2005-11-13 14:20 libpng13.pc # -rwx------ 1 pdenno users 322 2005-11-13 15:07 pango.pc # -rwx------ 1 pdenno users 315 2005-11-13 15:07 pangocairo.pc # -rwx------ 1 pdenno users 403 2005-11-13 15:08 pangoft2.pc # -rwx------ 1 pdenno users 276 2005-11-13 15:08 pangowin32.pc # # ...and where is what the first line of one looks like on my machine: # prefix=/local/win32/gtk # Some like libpng have prefix=/usr ... because that is where it is (cygwin default). # # Once built, place the library in the directory containing libgtk. all: gcc -mno-cygwin -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` dlltool -e exports.o -z cellsgtk.def -l cellsgtk.lib gtk-adds.o gcc -mno-cygwin -mwindows -mdll -L/usr/lib/mingw gtk-adds.o exports.o -o libcellsgtk.dll `pkg-config --cflags --libs gtk+-2.0` -specs=specs.new --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gdk-other.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gdk-other.lisp 2008/04/13 10:59:23 1.1 (in-package :gtk-ffi) (def-gtk-lib-functions :gdk (gdk-gc-new ((drawable c-pointer)) c-pointer) (gdk-draw-line ((drawable c-pointer) (gc c-pointer) (x1 int) (y1 int) (x2 int) (y2 int))) (gdk-pixmap-new ((drawable c-pointer) (width int) (height int) (depth int)) c-pointer) (gdk-draw-drawable ((drawable c-pointer) (gc c-pointer) (src c-pointer) (xsrc int) (ysrc int) (xdest int) (ydest int) (width int) (height int))) (gdk-draw-rectangle ((drawable c-pointer) (gc c-pointer) (filled boolean) (x int) (y int) (width int) (height int))) (gdk-gc-set-rgb-fg-color ((gc c-pointer) (color c-pointer))) (gdk-gc-set-rgb-bg-color ((gc c-pointer) (color c-pointer))) (gdk-color-parse ((spec c-string) (color c-pointer)) int) (gdk-draw-layout ((drawable c-pointer) (gc c-pointer) (x int) (y int) (pango-layout c-pointer))) (gdk-gc-set-line-attributes ((gc c-pointer) (line-width int) (line-style int) (cap-style int) (join-style int)))) --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-adds.c 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-adds.c 2008/04/13 10:59:23 1.1 #include <gtk/gtk.h> #include <glib.h> asm (".section .drectve"); asm (".ascii \"-export:gtk_adds_text_iter_new\""); asm (".ascii \" -export:gtk_adds_text_view_popup_menu\""); asm (".ascii \" -export:gtk_adds_dialog_vbox\""); asm (".ascii \" -export:gtk_adds_tree_iter_new\""); asm (".ascii \" -export:gtk_adds_widget_mapped_p\""); asm (".ascii \" -export:gtk_adds_widget_visible_p\""); asm (".ascii \" -export:gtk_adds_widget_window\""); asm (".ascii \" -export:gtk_adds_color_new\""); asm (".ascii \" -export:gtk_adds_color_set_rgb\""); asm (".ascii \" -export:gtk_adds_ok\""); asm (".ascii \" -export:gtk_adds_g_thread_supported\""); /* Return a pointer to the vbox of a dialog. * Useful for adding widgets to dialogs. For example, * if you need a dialog with text entry capability. */ GtkWidget * gtk_adds_dialog_vbox (GtkWidget *dialog) { return GTK_DIALOG(dialog)->vbox; } /* Return a pointer to the popup_menu of a textview. * Useful if you need to add to the default textview menu * on a populate-popup event. */ GtkWidget * gtk_adds_text_view_popup_menu (GtkWidget *text_view) { return GTK_TEXT_VIEW(text_view)->popup_menu; } /* C programmers allocate iters on the stack. We use this. Free it with gtk-text-iter-free */ GtkTextIter * gtk_adds_text_iter_new () { GtkTextIter example; return gtk_text_iter_copy(&example); } /* C programmers allocate iters on the stack. We use this. Free it with gtk-tree-iter-free */ GtkTreeIter * gtk_adds_tree_iter_new () { GtkTreeIter example; return gtk_tree_iter_copy(&example); } int gtk_adds_widget_mapped_p (GtkWidget *wid) { return ((GTK_WIDGET_FLAGS (wid) & GTK_MAPPED) != 0) ? 1 : 0; } int gtk_adds_widget_visible_p (GtkWidget *wid) { return ((GTK_WIDGET_FLAGS (wid) & GTK_VISIBLE) != 0) ? 1 : 0; } GdkWindow * gtk_adds_widget_window (GtkWidget *wid) { return wid->window; } GdkColor * gtk_adds_color_new () { return ((GdkColor *)malloc(sizeof(GdkColor))); } void gtk_adds_color_set_rgb (GdkColor* color, guint r, guint g, guint b) { color->red = r; color->green = g; color->blue = b; } /* You can run this one without having gtk running, to be sure the library was loaded. */ int gtk_adds_ok () { return 1; } /* This macro tells us whether g_thread_init has already been called from this session This is important to avoid double initialization, which kills the current lisp session */ int gtk_adds_g_thread_supported () { return g_thread_supported (); } --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-button.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-button.lisp 2008/04/13 10:59:23 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 :gtk-ffi) (def-gtk-lib-functions :gtk (gtk-button-new :pointer ()) (gtk-button-set-label :void ((button :pointer) (label :gtk-string))) (gtk-button-set-relief :void ((button :pointer) (style :int))) (gtk-button-set-use-stock :void ((button :pointer) (use-stock :gtk-boolean))) (gtk-toggle-button-new :pointer ()) (gtk-toggle-button-set-mode :void ((button :pointer) (draw-indicator :gtk-boolean))) (gtk-toggle-button-set-active :void ((button :pointer) (active :gtk-boolean))) (gtk-toggle-button-get-active :gtk-boolean ((button :pointer))) (gtk-check-button-new :pointer ()) (gtk-radio-button-new :pointer ((gslist :pointer))) (gtk-radio-button-new-from-widget :pointer ((radio-group :pointer))) (gtk-spin-button-new :pointer ((adjustment :pointer) (climb-rate :double) (digits :unsigned-int))) (gtk-spin-button-new-with-range :pointer ((minval :double) (maxval :double) (step :double))) (gtk-spin-button-set-value :void ((spin-button :pointer) (value :double))) (gtk-spin-button-get-value :double ((spin-button :pointer))) (gtk-spin-button-get-value-as-int :int ((spin-button :pointer))) (gtk-spin-button-set-wrap :void ((spin-button :pointer) (wrap :gtk-boolean)))) #+debugthis (gtk-toggle-button-get-active ((button c-pointer)) boolean) #+not (DEF-GTK-FUNCTION :GTK GTK-TOGGLE-BUTTON-GET-ACTIVE :ARGUMENTS ((BUTTON C-POINTER)) :RETURN-TYPE BOOLEAN :CALL-DIRECT T) --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-core.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-core.lisp 2008/04/13 10:59:23 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 :gtk-ffi) (def-gtk-lib-functions :glib (g-free :void ((data :pointer))) (g-slist-free :void ((lst :pointer))) (g-timeout-add :unsigned-int ((milliseconds :unsigned-int) (func :pointer) (data :pointer))) (g-locale-from-utf8 :gtk-string ((utf8-string :pointer) (len :int) (bytes-read :pointer) (bytes-written :pointer) (gerror :pointer))) (g-locale-to-utf8 :pointer ((local-string :gtk-string) (len :int) (bytes-read :pointer) (bytes-written :pointer) (gerror :pointer)))) (def-gtk-lib-functions :gthread (g-thread-init :void ((vtable :pointer)))) (def-gtk-lib-functions :gdk (gdk-threads-init :void ()) (gdk-threads-enter :void ()) (gdk-threads-leave :void ()) (gdk-flush :void ())) (uffi:def-union g-value-data (v-int :int) (v-uint :unsigned-int) (v-long :long) (v-ulong :unsigned-long) (v-int64-lo :int) (v-int64-hi :int) (v-uint64-lo :unsigned-int) (v-uint64-hi :unsigned-int) (v-float :float) (v-double :double) (v-pointer :pointer-void)) (uffi:def-struct g-value (g-type (:array :int 16))) (defmacro with-g-value ((var) &body body) [61 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi-impl.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi-impl.lisp 2008/04/13 10:59:23 1.1 [97 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.asd 2008/04/13 10:59:23 1.1 [131 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lisp 2008/04/13 10:59:23 1.1 [578 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lpr 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-ffi.lpr 2008/04/13 10:59:23 1.1 [618 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-gl-ext.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-gl-ext.lisp 2008/04/13 10:59:23 1.1 [725 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-list-tree.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-list-tree.lisp 2008/04/13 10:59:23 1.1 [946 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-menu.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-menu.lisp 2008/04/13 10:59:23 1.1 [1052 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-other.lisp 2008/04/13 10:59:23 1.1 [1971 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-threads.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-threads.lisp 2008/04/13 10:59:23 1.1 [2022 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-tool.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-tool.lisp 2008/04/13 10:59:23 1.1 [2131 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-utilities.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/gtk-utilities.lisp 2008/04/13 10:59:23 1.1 [2388 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk-solaris.so 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk-solaris.so 2008/04/13 10:59:23 1.1 [2441 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk.so 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/libcellsgtk.so 2008/04/13 10:59:23 1.1 [2486 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/package.lisp 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/package.lisp 2008/04/13 10:59:23 1.1 [2567 lines skipped] --- /project/cells/cvsroot/cells-gtk3/gtk-ffi/specs.new 2008/04/13 10:59:23 NONE +++ /project/cells/cvsroot/cells-gtk3/gtk-ffi/specs.new 2008/04/13 10:59:23 1.1 [2654 lines skipped]

1 0

[cells-cvs] CVS cells-gtk3/cells-gtk
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv5005/cells-gtk Added Files: #cells-gtk.asd# #tree-view.lisp# actions.lisp addon.lisp buttons.lisp cairo-drawing-area.lisp callback.lisp cells-gtk.asd cells-gtk.lpr cells3-porting-notes.lisp compat.lisp conditions.lisp dialogs.lisp display.lisp drawing-area.lisp drawing.lisp entry.lisp gl-drawing-area.lisp gtk-app.lisp layout.lisp menus.lisp packages.lisp textview.lisp tree-view.lisp widgets.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/#cells-gtk.asd# 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/#cells-gtk.asd# 2008/04/13 10:59:18 1.1 (in-package :common-lisp-user) (defpackage #:cells-gtk-asd (:use :cl :asdf)) (in-package :cells-gtk-asd) ;;; ;;; features ;;; ;;; run gtk in its own thread (requires bordeaux-threads) b(pushnew :cells-gtk-threads *features*) ;;; drawing-area widget using cairo (requires cl-cairo2) (pushnew :cells-gtk-cairo *features*) ;;; drawing-area widget using OpenGL (requires libgtkglext1) ;(pushnew :cells-gtk-opengl *features*) (asdf:defsystem :cells-gtk :name "cells-gtk" :depends-on (:cells :utils-kt :pod-utils :gtk-ffi :ph-maths #+cells-gtk-cairo :cl-cairo2 #+cells-gtk-threads :bordeaux-threads) :serial t :components ((:file "packages") (:file "conditions") (:file "compat") (:file "cells3-porting-notes" :depends-on ("packages")) (:file "widgets" :depends-on ("conditions")) (:file "layout" :depends-on ("widgets")) (:file "display" :depends-on ("widgets")) (:file "drawing-area" :depends-on ("widgets")) #+cells-gtk-cairo (:file "cairo-drawing-area" :depends-on ("widgets")) #+cells-gtk-opengl (:file "gl-drawing-area" :depends-on ("widgets")) (:file "buttons" :depends-on ("widgets")) (:file "entry" :depends-on ("widgets")) (:file "tree-view" :depends-on ("widgets")) (:file "menus" :depends-on ("widgets")) (:file "dialogs" :depends-on ("widgets")) (:file "textview" :depends-on ("widgets")) (:file "addon" :depends-on ("widgets")) (:file "gtk-app") )) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/#tree-view.lisp# 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/#tree-view.lisp# 2008/04/13 10:59:18 1.1 #| Cells Gtk 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. |# ;;; Todo: separate tree-model/tree-store stuff into another file (used by combo box too). ;;; BTW Tree-store implements the tree-model interface, among other things. (in-package :cgtk) (def-object list-store () ((item-types :accessor item-types :initarg :item-types :initform nil) (of-tree :accessor of-tree :initform (c-in nil))) () () :new-args (c_1 (list (item-types self)))) (def-object tree-store () ((item-types :accessor item-types :initarg :item-types :initform nil) (of-tree :accessor of-tree :initform (c-in nil))) () () :new-args (c_1 (list (item-types self)))) (defun tv-fail (&rest args) (declare (ignore args))) (defgeneric get-selection (none)) (def-widget tree-view (container) ((columns-def :accessor columns-def :initarg :columns :initform nil) (column-types :accessor column-types :initform (c? (mapcar #'first (columns-def self)))) (column-inits :accessor column-inits :initform (c? (mapcar #'second (columns-def self)))) (column-render :accessor column-render :initform (c? (loop for col-def in (columns-def self) for pos from 0 append (when (third col-def) (list pos (third col-def)))))) (node-render :accessor node-render :initform (c? (loop for col-def in (columns-def self) for pos from 0 append (when (fourth col-def) (list pos (fourth col-def)))))) (columns :accessor columns :initform (c? (mapcar #'(lambda (col-init) (apply #'make-be 'tree-view-column :container self col-init)) (column-inits self)))) (select-if :unchanged-if #'tv-fail :accessor select-if :initarg :select-if :initform (c-in nil)) (roots :accessor roots :initarg :roots :initform nil) (print-fn :accessor print-fn :initarg :print-fn :initform #'identity) (children-fn :accessor children-fn :initarg :children-fn :initform #'(lambda (x) (declare (ignore x)) nil)) (selected-items-cache :cell nil :accessor selected-items-cache :initform nil) (selection-mode :accessor selection-mode :initarg :selection-mode :initform :single) (expand-all :accessor expand-all :initarg :expand-all :initform (c-in nil)) (on-select :accessor on-select :initarg :on-select :initform nil) (on-edit :accessor on-edit :initarg :on-edit :initform nil) (tree-model :owning t :accessor tree-model :initarg :tree-model :initform nil)) () ; gtk-slots () ; signal-slots :on-select (lambda (self widget event data) (declare (ignore widget event data)) (with-integrity (:change 'tree-view-select-cb) (setf (value self) (get-selection self))))) (defobserver tree-model ((self tree-view)) (when new-value (gtk-tree-view-set-model (id self) (id new-value)) (with-integrity (:change 'tv-tree-model) (setf (of-tree new-value) self)))) (defobserver expand-all ((self tree-view)) (when new-value (gtk-tree-view-expand-all (id self)))) ;;; Used by combo-box also, when it is using a tree model. (cffi:defcallback tree-view-items-selector :void ((model :pointer) (path :pointer) (iter :pointer) (data :pointer)) (declare (ignore path data)) (let ((tree (of-tree (gtk-object-find model)))) (push (item-from-path (children-fn tree) (roots tree) (read-from-string (gtk-tree-model-get-cell model iter (length (column-types tree)) :string))) (selected-items-cache tree))) 0) (defmethod get-selection ((self tree-view)) (let ((selection (gtk-tree-view-get-selection (id self))) (cb (cffi:get-callback 'tree-view-items-selector))) (setf (selected-items-cache self) nil) (gtk-tree-selection-selected-foreach selection cb +c-null+) (if (equal (gtk-tree-selection-get-mode selection) 3) ;;multiple (copy-list (selected-items-cache self)) (first (selected-items-cache self))))) (defobserver selection-mode ((self tree-view)) (when new-value (let ((sel (gtk-tree-view-get-selection (id self)))) (gtk-tree-selection-set-mode sel (ecase (selection-mode self) (:none 0) (:single 1) (:browse 2) (:multiple 3)))))) (cffi:defcallback tree-view-select-handler :void ((column-widget :pointer) (event :pointer) (data :pointer)) (if-bind (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) (trc "Clean up old widgets after runs" column-widget)) 0) ;;; The check that previously was performed here (for a clos object) caused the handler ;;; not to be registered (a problem of execution ordering?). Anyway, do we need such a check? (defobserver on-select ((self tree-view)) (when new-value (let ((selected-widget (gtk-tree-view-get-selection (id self)))) (gtk-object-store selected-widget self) ;; tie column widget to clos tree-view (callback-register self :on-select new-value) (let ((cb (cffi:get-callback 'tree-view-select-handler))) ;(trc nil "tree-view on-select pcb:" cb selected-widget "changed") (gtk-signal-connect selected-widget "changed" cb))))) ;;; ;;; Listbox submodel ;;; (defmodel listbox (tree-view) ((roots :initarg :items)) ; alternate initarg for inherited slot (:default-initargs :tree-model (c? (make-instance 'list-store :item-types (append (column-types self) (list :string)))))) (defmethod items ((self listbox)) (roots self)) (defmethod (setf items) (val (self listbox)) (setf (roots self) val)) (defun mk-listbox (&rest inits) (assert *parent*) (let ((self (apply 'make-instance 'listbox (append inits (list :fm-parent *parent*))))) (with-integrity (:change 'mk-listbox-of-tree) (setf (of-tree (tree-model self)) self)) self)) (defobserver select-if ((self listbox)) (when new-value (with-integrity (:change 'listbox-select-if-observer) (setf (value self) (remove-if-not new-value (roots self)))))) (defobserver roots ((self listbox)) (when old-value (gtk-list-store-clear (id (tree-model self)))) (when new-value (gtk-list-store-set-items (id (tree-model self)) (append (column-types self) (list :string)) (loop for item in new-value for index from 0 collect (let ((i (funcall (print-fn self) item))) ;(ukt:trc nil "items output: old,new" item i) (append i (list (format nil "(~d)" index)))))))) ;;; ;;; Treebox submodel ;;; (defmodel treebox (tree-view) () (:default-initargs :tree-model (c? (mk-tree-store :item-types (append (column-types self) (list :string)))))) (defun mk-treebox (&rest inits) (assert *parent*) (let ((self (apply 'make-instance 'treebox (append inits (list :fm-parent *parent*))))) (with-integrity (:change 'mk-treebox-of-tree) (setf (of-tree (tree-model self)) self)) self)) (defobserver select-if ((self treebox)) (when new-value (with-integrity (:change 'treebox-obs-select-if) (setf (value self) (mapcan (lambda (item) (fm-collect-if item new-value)) (roots self)))))) (defobserver roots ((self treebox)) (when old-value (gtk-tree-store-clear (id (tree-model self)))) (when new-value (loop for root in new-value for index from 0 do (gtk-tree-store-set-kids (id (tree-model self)) root +c-null+ index (append (column-types self) (list :string)) (print-fn self) (children-fn self))) (when (expand-all self) (gtk-tree-view-expand-all (id self))))) ;;; These look like ("Trimmed Text" "(0 0 )") for example where menu structure is "Text --> Trimmed Text" ;;; Column-types is a list of :string, :float etc. used to reference g-value-set-string etc. (defun gtk-tree-store-set-kids (model val-tree parent-iter index column-types print-fn children-fn &optional path) (with-tree-iter (iter) (gtk-tree-store-append model iter parent-iter) ; sets iter (gtk-tree-store-set model iter ; Not a gtk function! column-types (append (funcall print-fn val-tree) (list (format nil "(~{~d ~})" (reverse (cons index path)))))) (loop for sub-tree in (funcall children-fn val-tree) for pos from 0 do (gtk-tree-store-set-kids model sub-tree iter pos column-types print-fn children-fn (cons index path))))) ;;; ;;; Cell rendering ;;; (cffi:defcallback tree-view-render-cell-callback :int ((tree-column :pointer) (cell-renderer :pointer) (tree-model :pointer) (iter :pointer) (data :pointer)) (if-bind (self (gtk-object-find tree-column)) (let ((cb (callback-recover self :render-cell))) (assert cb nil "no :render-cell callback for ~a" self) (funcall cb tree-column cell-renderer tree-model iter data)) (trc nil "Clean up old widgets from prior runs." tree-column)) 1) (defun item-from-path (child-fn roots path) (loop for index in path for node = (nth index roots) then (nth index (if node (funcall child-fn node) (return nil))) finally (return node))) (declaim (optimize (debug 3))) (defun gtk-tree-view-render-cell (col col-type cell-attrib-f &optional node-attrib-f) (trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f) (flet ((node-from-iter (model iter) (when-bind* ((tree-model (gtk-object-find model)) (tree-view (of-tree tree-model)) (path (gtk-tree-model-get-cell model iter (length (column-types tree-view)) :string))) (item-from-path (children-fn tree-view) (roots tree-view) (read-from-string path))))) (lambda (tree-column cell-renderer model iter data) (DECLARE (ignorable tree-column data)) (trc nil "gtv-render-cell (callback)> entry" tree-column cell-renderer model iter data) (let ((item-value (gtk-tree-model-get-typed-item-value model iter col col-type)) (node (node-from-iter model iter))) (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 (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 (if item-value (get-gtk-string item-value) "")) (otherwise (format nil "~a" item-value))))))) (when cell-attrib-f (gtk-cell-renderer-set-attribs cell-renderer (funcall cell-attrib-f item-value))) (when (and node node-attrib-f) (gtk-cell-renderer-set-attribs cell-renderer (funcall node-attrib-f node)))) 1))) ;;; ;;; Editable cells ;;; (defstruct renderer tree-view col) ;;; a hash table to keep track of the renderer objects (let ((renderers (make-hash-table))) (defun register-renderer-data (renderer data) (setf (gethash (cffi-sys:pointer-address renderer) renderers) data)) (defun recover-renderer-data (renderer) (gethash (cffi-sys:pointer-address renderer) renderers))) ;;; generic callback -- update treestore and call on-edit func (defun gtk-path-to-list (path) "converts \"1:2\" to (1 2)" (read-from-string (format nil "(~a)" (map 'string #'(lambda (c) (if (eql c #\:) #\space c)) path)))) (defun tree-view-edit-cell-callback (renderer path new-value) (if-bind (data (recover-renderer-data renderer)) (let* ((tree (renderer-tree-view data)) (model (id (tree-model tree))) (col (renderer-col data)) (col-type (nth col (column-types tree))) (fn (on-edit tree)) (path (cffi:foreign-string-to-lisp path)) (node (item-from-path #'kids (roots tree) (gtk-path-to-list path)))) #+msg (format t "~&Edited path ~a --> node ~a~%" (gtk-path-to-list path) (when node (md-name node))) (when node (with-tree-iter (iter) (gtk-tree-model-get-iter-from-string (id (tree-model tree)) iter path) (let ((new-val (case col-type (:boolean (= 0 (gtk-tree-model-get-cell model iter col :boolean))) ; toggle boolean cell, (t new-value)))) #+msg (format t "~&Setting value for ~a to ~a ..." node new-val) (gtk-tree-store-set-cell model iter col col-type new-val) (funcall fn node col new-val))) ; call setf function #+msg (format t " done.~%") (force-output))) (warn (format nil "No callback registered ")))) ;;; a tribute to static typing (cffi:defcallback tree-view-edit-cell-callback-string :int ((renderer :pointer) (path :pointer) (new-value :gtk-string)) (tree-view-edit-cell-callback renderer path new-value) 1) [423 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:18 1.1 [504 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:18 1.1 [578 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:18 1.1 [681 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:18 1.1 [1459 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:18 1.1 [1498 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:18 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:18 1.1 [1550 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.lpr 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.lpr 2008/04/13 10:59:19 1.1 [1597 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells3-porting-notes.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells3-porting-notes.lisp 2008/04/13 10:59:19 1.1 [1631 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/compat.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/compat.lisp 2008/04/13 10:59:19 1.1 [1675 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/conditions.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/conditions.lisp 2008/04/13 10:59:19 1.1 [1713 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:19 1.1 [1881 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:19 1.1 [2036 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:19 1.1 [2168 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing.lisp 2008/04/13 10:59:19 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing.lisp 2008/04/13 10:59:19 1.1 [2389 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:20 1.1 [2542 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:20 1.1 [2552 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:20 1.1 [2897 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:20 1.1 [3205 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:20 1.1 [3525 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:20 1.1 [3670 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:20 1.1 [3843 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:20 1.1 [4614 lines skipped] --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:20 NONE +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:20 1.1 [5078 lines skipped]

1 0

[cells-cvs] CVS cells-gtk3
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3 In directory clnet:/tmp/cvs-serv5005 Added Files: INSTALL.TXT asdf.lisp config.lisp Log Message: cells-gtk3 initial. --- /project/cells/cvsroot/cells-gtk3/INSTALL.TXT 2008/04/13 10:59:16 NONE +++ /project/cells/cvsroot/cells-gtk3/INSTALL.TXT 2008/04/13 10:59:16 1.1 You don't need to read this file if you are installing from a snapshot tarball. This only concerns the situation where you get the pieces cells, hello-c, cells-gtk etc, individually. ############################################################################################################# The notes below apply to the UFFI port of Cells-gtk done by Ken Tilton. (Actually I have forked UFFI and call it Hello-C, but the idea is the same: portable FFI.) For the original version by Vasilis Margioulas, which uses native CLisp FFI to good advantage, grab this: http://common-lisp.net/cgi-bin/viewcvs.cgi/cells-gtk/clisp-cgtk/clisp-cgtk.… ...and follow the INSTALL.TXT in that. ############################################################################################################## Dependencies: Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.… Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.ta… Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz… On windows install Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zi… Add the gtk libs to your PATH variable: Start>Settings>Control Panel>System>Advanced>Environment Variables> Then select PATH and hit "Edit". Append to existing value: "C:\Program Files\Common Files\GTK\2.0\bin"; ..prior values... Edit load.lisp and follow the instructions there. No, you cannot just load it. Note: On windows under emacs with slime, the gtk window does not popup. You must start the application from a dos prompt. Tested on: Windows xp with gtk 2.4.10 and clisp 2.33, using AllegroCL 6.2 Enterprise and Lispworks 4.3 Personal Known bugs: On Windows: Clisp crash if [My Computer]-> [Properties]-> [Advanced]-> [Perfomance Settings]-> [Show windows contents while dragging] is set and resize the window while viewing a listbox or treebox. --- /project/cells/cvsroot/cells-gtk3/asdf.lisp 2008/04/13 10:59:16 NONE +++ /project/cells/cvsroot/cells-gtk3/asdf.lisp 2008/04/13 10:59:16 1.1 ;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list(a)lists.sf.net>. But note first that the canonical ;;; source for asdf is presently the cCLan CVS repository at ;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/> ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting ;;; bugs. There are usually two "supported" revisions - the CVS HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' ;;; Copyright (c) 2001-2003 Daniel Barlow and contributors ;;; ;;; 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. ;;; the problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous #:hyperdocumentation #:hyperdoc #:compile-op #:load-op #:load-source-op #:test-system-version #:test-op #:operation ; operations #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:input-files #:output-files #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file #:static-file #:doc-file #:html-file #:text-file #:source-file-type #:module ; components #:system #:unix-dso #:module-components ; component accessors #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-property #:component-system #:component-depends-on #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:operation-on-warnings #:operation-on-failure ;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error #:system-definition-error #:missing-component #:missing-dependency #:circular-dependency ; errors #:retry #:accept ; restarts ) (:use :cl)) #+nil (error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") (in-package #:asdf) (defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot (list (parse-integer v :start (1+ colon) :junk-allowed t) (parse-integer v :start (1+ dot) :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) (defvar *verbose-out* nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (defun pathname-sans-name+type (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) (define-modify-macro appendf (&rest args) append "Append onto list") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons (define-condition system-definition-error (error) () ;; [this use of :report should be redundant, but unfortunately it's not. ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function ;; over print-object; this is always conditions::%print-condition for ;; condition objects, which in turn does inheritance of :report options at ;; run-time. fortunately, inheritance means we only need this kludge here in ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] #+cmu (:report print-object)) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply #'format s (format-control c) (format-arguments c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) (format s "~@<erred while invoking ~A on ~A~@:>" (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to) ;;; XXX crap name (do-first :initform nil :initarg :do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated (inline-methods :accessor component-inline-methods :initform nil) (parent :initarg :parent :initform nil :reader component-parent) ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) (operation-times :initform (make-hash-table ) :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) ;;;; methods: components (defmethod print-object ((c missing-component) s) (format s "~@<component ~S not found~ ~@[ or does not match version ~A~]~ ~@[ in ~A~]~@:>" (missing-requires c) (missing-version c) (when (missing-parent c) (component-name (missing-parent c))))) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity t) (ignore-errors (prin1 (component-name c) stream)))) (defclass module (component) ((components :initform nil :accessor module-components :initarg :components) ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail :accessor module-if-component-dep-fails :initarg :if-component-dep-fails) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) (defgeneric component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) (defun component-parent-pathname (component) (aif (component-parent component) (component-pathname it) *default-pathname-defaults*)) (defgeneric component-relative-pathname (component) (:documentation "Extracts the relative pathname applicable for a particular component.")) (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname :directory `(:relative ,(component-name component)) :host (pathname-host (component-parent-pathname component))))) (defmethod component-pathname ((component component)) (let ((*default-pathname-defaults* (component-parent-pathname component))) (merge-pathnames (component-relative-pathname component)))) (defgeneric component-property (component property)) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) (defgeneric (setf component-property) (new-value component property)) (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a (setf (cdr a) new-value) (setf (slot-value c 'properties) (acons property new-value (slot-value c 'properties)))))) (defclass system (module) ((description :accessor system-description :initarg :description) (long-description :accessor system-long-description :initarg :long-description) (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence))) ;;; version-satisfies ;;; with apologies to christophe rhodes ... (defun split (string &optional max (ws '(#\Space #\Tab))) (flet ((is-ws (char) (find char ws))) (nreverse (let ((list nil) (start 0) (words 0) end) (loop (when (and max (>= words (1- max))) (return (cons (subseq string start) list))) (setf end (position-if #'is-ws string :start start)) (push (subseq string start end) list) (incf words) (unless end (return list)) (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (let ((x (mapcar #'parse-integer (split (component-version c) nil '(#\.)))) (y (mapcar #'parse-integer (split version nil '(#\.))))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems (defvar *defined-systems* (make-hash-table :test 'equal)) (defun coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error "~@<invalid component designator ~A~@:>" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- (defvar *system-definition-search-functions* '(sysdef-central-registry-search)) (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) *system-definition-search-functions*)) (defvar *central-registry* '(*default-pathname-defaults* #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" #+nil "telent:asdf;systems;")) (defun sysdef-central-registry-search (system) (let ((name (coerce-name system))) (block nil (dolist (dir *central-registry*) (let* ((defaults (eval dir)) (file (and defaults (make-pathname :defaults defaults :version :newest :name name :type "asd" :case :local)))) (if (and file (probe-file file)) [755 lines skipped] --- /project/cells/cvsroot/cells-gtk3/config.lisp 2008/04/13 10:59:16 NONE +++ /project/cells/cvsroot/cells-gtk3/config.lisp 2008/04/13 10:59:16 1.1 [799 lines skipped]

1 0

[cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv4893/cells-gtk/test-gtk Log Message: Directory /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk added to the repository

1 0

[cells-cvs] CVS cells-gtk3/gtk-ffi
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/gtk-ffi In directory clnet:/tmp/cvs-serv4765/gtk-ffi Log Message: Directory /project/cells/cvsroot/cells-gtk3/gtk-ffi added to the repository

1 0

[cells-cvs] CVS cells-gtk3/cells-gtk
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv4765/cells-gtk Log Message: Directory /project/cells/cvsroot/cells-gtk3/cells-gtk added to the repository

1 0

[cells-cvs] CVS cells-gtk3/ph-maths
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/ph-maths In directory clnet:/tmp/cvs-serv4765/ph-maths Log Message: Directory /project/cells/cvsroot/cells-gtk3/ph-maths added to the repository

1 0

[cells-cvs] CVS cells-gtk3/pod-utils
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/pod-utils In directory clnet:/tmp/cvs-serv4765/pod-utils Log Message: Directory /project/cells/cvsroot/cells-gtk3/pod-utils added to the repository

1 0

[cells-cvs] CVS cells-gtk3/test-images
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/test-images In directory clnet:/tmp/cvs-serv4765/test-images Log Message: Directory /project/cells/cvsroot/cells-gtk3/test-images added to the repository

1 0

[cells-cvs] CVS cells
by phildebrandt 13 Apr '08

13 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30090 Modified Files: md-slot-value.lisp Log Message: Fixed ensure-value-is-current, now works with my code. --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/12 22:53:26 1.42 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/13 10:22:03 1.43 @@ -79,7 +79,7 @@ ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) (when *not-to-be* - (return-from ensure-value-is-current t)) + (return-from ensure-value-is-current (c-value c))) (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c))

1 0

← Newer
1
...
6
7
8
9
10
11
12
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs