From pdenno at common-lisp.net Tue Jan 3 18:55:17 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 19:55:17 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.asd Message-ID: <20060103185517.9186D88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv29184/root/cells-gtk Modified Files: cells-gtk.asd Log Message: Don't load drawing.lisp, it is not ready. Date: Tue Jan 3 19:55:17 2006 Author: pdenno Index: root/cells-gtk/cells-gtk.asd diff -u root/cells-gtk/cells-gtk.asd:1.5 root/cells-gtk/cells-gtk.asd:1.6 --- root/cells-gtk/cells-gtk.asd:1.5 Sat Oct 8 16:29:28 2005 +++ root/cells-gtk/cells-gtk.asd Tue Jan 3 19:55:16 2006 @@ -11,7 +11,7 @@ (:file "widgets" :depends-on ("conditions")) (:file "layout" :depends-on ("widgets")) (:file "display" :depends-on ("widgets")) - (:file "drawing" :depends-on ("widgets")) +#+notyet(:file "drawing" :depends-on ("widgets")) ; not ready yet. (:file "buttons" :depends-on ("widgets")) (:file "entry" :depends-on ("widgets")) (:file "tree-view" :depends-on ("widgets")) From pdenno at common-lisp.net Tue Jan 3 18:57:42 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 19:57:42 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp Message-ID: <20060103185742.3E35288161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv29218/root/cells-gtk Modified Files: gtk-app.lisp Log Message: Quit out of as many main loops as necessary. Date: Tue Jan 3 19:57:41 2006 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.14 root/cells-gtk/gtk-app.lisp:1.15 --- root/cells-gtk/gtk-app.lisp:1.14 Sun May 29 23:06:47 2005 +++ root/cells-gtk/gtk-app.lisp Tue Jan 3 19:57:41 2006 @@ -91,13 +91,13 @@ (not-to-be splash) (gtk-window-set-auto-startup-notification t)) (setf (visible app) t) - (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) #-lispworks (gtk-main) #+lispworks - (flet ((do-gtk () (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)))) + (flet ((do-gtk () (loop while (gtk-events-pending) do + (gtk-main-iteration-do nil)))) (unwind-protect (catch 'try-again (handler-case @@ -109,11 +109,11 @@ (show-message (format nil "Cells-GTK Error: ~a" err) :message-type :error :title "Cells-GTK Error") (throw 'try-again nil)) ; This doesn't really work. u-p cleanup forms invoked. - (gtk-user-signals-quit (c) - (declare (ignore c)) - (return-from start-app nil)))) + (gtk-user-signals-quit () + (loop while (> (gtk-main-level) 0) do (gtk-main-quit)) + (return-from start-app)))) (not-to-be app) - (gtk-main-quit) + (loop while (> (gtk-main-level) 0) do (gtk-main-quit)) (do-gtk))))))) From pdenno at common-lisp.net Tue Jan 3 18:58:55 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 19:58:55 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/layout.lisp Message-ID: <20060103185855.A938688161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv29248/root/cells-gtk Modified Files: layout.lisp Log Message: Stuff for divider position and checking whether page already is displayed (or something like that). Date: Tue Jan 3 19:58:55 2006 Author: pdenno Index: root/cells-gtk/layout.lisp diff -u root/cells-gtk/layout.lisp:1.5 root/cells-gtk/layout.lisp:1.6 --- root/cells-gtk/layout.lisp:1.5 Sun May 29 23:08:22 2005 +++ root/cells-gtk/layout.lisp Tue Jan 3 19:58:54 2006 @@ -76,7 +76,13 @@ (y-pad kid)))))) (def-widget hpaned () - () () ()) + ((divider-pos :accessor divider-pos :initarg :divider-pos :initform (c-in 0))) + () + ()) + +(def-c-output divider-pos ((self hpaned)) + (when new-value + (gtk-paned-set-position (id self) new-value))) (def-c-output .kids ((self hpaned)) (when new-value @@ -90,7 +96,13 @@ #+clisp (call-next-method)) (def-widget vpaned () - () () ()) + ((divider-pos :accessor divider-pos :initarg :divider-pos :initform (c-in 0))) + () + ()) + +(def-c-output divider-pos ((self vpaned)) + (when new-value + (gtk-paned-set-position (id self) new-value))) (def-c-output .kids ((self vpaned)) (when new-value @@ -184,7 +196,7 @@ #+clisp (call-next-method)) (def-widget notebook () - ((tab-labels :accessor tab-labels :initarg :tab-labels :initform nil) + ((tab-labels :accessor tab-labels :initarg :tab-labels :initform (c-in nil)) (tab-labels-widgets :accessor tab-labels-widgets :initform (c-in nil)) (show-page :accessor show-page :initarg :show-page :initform (c-in 0)) (tab-pos :accessor tab-pos :initarg :tab-pos :initform (c-in nil))) @@ -205,16 +217,22 @@ (:bottom 3) (t 2))))) +(defun notebook-contains-page-p (notebook widget &aux (wid (pointer-address (id widget)))) + (loop for i from 1 to (gtk-notebook-get-n-pages (id notebook)) + for page = (gtk-notebook-get-nth-page (id notebook) (1- i)) + when (= wid (pointer-address page)) return t)) + (def-c-output show-page ((self notebook)) (when (and new-value (>= new-value 0) (< new-value (length (kids self)))) (setf (current-page self) new-value))) (def-c-output .kids ((self notebook)) - (dolist (widget (tab-labels-widgets self)) - (not-to-be widget)) + ;(dolist (widget (tab-labels-widgets self)) ;; This was from the original code. + ; (not-to-be widget)) ;; It causes errors. (loop for kid in new-value for pos from 0 - for label = (nth pos (tab-labels self)) do + for label = (nth pos (tab-labels self)) + unless (notebook-contains-page-p self kid) do (let ((lbl (and label (make-be 'label :text label)))) (when lbl (push lbl (tab-labels-widgets self))) (gtk-notebook-append-page (id self) (id kid) (and lbl (id lbl))))) From pdenno at common-lisp.net Tue Jan 3 18:59:58 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 19:59:58 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/packages.lisp Message-ID: <20060103185958.D6C1F88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv29272/root/cells-gtk Modified Files: packages.lisp Log Message: CFFI : No need for #+clisp stuff Date: Tue Jan 3 19:59:58 2006 Author: pdenno Index: root/cells-gtk/packages.lisp diff -u root/cells-gtk/packages.lisp:1.1 root/cells-gtk/packages.lisp:1.2 --- root/cells-gtk/packages.lisp:1.1 Sun May 29 23:01:21 2005 +++ root/cells-gtk/packages.lisp Tue Jan 3 19:59:58 2006 @@ -19,7 +19,7 @@ (defpackage :cells-gtk (:nicknames :cgtk) (:use :common-lisp :utils-kt :cells :gtk-ffi - #+clisp :ffi #-clisp :uffi #-clisp #:ffx)) + :uffi #:ffx)) From pdenno at common-lisp.net Tue Jan 3 19:01:21 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:01:21 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/textview.lisp Message-ID: <20060103190121.B502D88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30350/root/cells-gtk Modified Files: textview.lisp Log Message: Misplaced declare ignore makes clisp and cmucl error. Date: Tue Jan 3 20:01:20 2006 Author: pdenno Index: root/cells-gtk/textview.lisp diff -u root/cells-gtk/textview.lisp:1.5 root/cells-gtk/textview.lisp:1.6 --- root/cells-gtk/textview.lisp:1.5 Sat Oct 8 16:31:24 2005 +++ root/cells-gtk/textview.lisp Tue Jan 3 20:01:20 2006 @@ -71,7 +71,6 @@ (ff-defun-callable :cdecl :void text-view-populate-popup-handler ((widget :pointer-void) (signal :pointer-void) (data :pointer-void)) - (declare (ignorable signal data)) (let ((popup-menu (gtk-adds-text-view-popup-menu widget))) (bwhen (text-view (gtk-object-find widget)) (bwhen (cb (callback-recover text-view :populate-popup)) From pdenno at common-lisp.net Tue Jan 3 19:02:00 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:02:00 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/tree-view.lisp Message-ID: <20060103190200.271E388161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30370/root/cells-gtk Modified Files: tree-view.lisp Log Message: Misplaced declare ignore makes clisp and cmucl error. Date: Tue Jan 3 20:01:59 2006 Author: pdenno Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.11 root/cells-gtk/tree-view.lisp:1.12 --- root/cells-gtk/tree-view.lisp:1.11 Sun May 29 23:13:06 2005 +++ root/cells-gtk/tree-view.lisp Tue Jan 3 20:01:59 2006 @@ -84,7 +84,6 @@ ;;; Used by combo-box also, when it is using a tree model. (ff-defun-callable :cdecl :void tree-view-items-selector ((model :pointer-void) (path :pointer-void) (iter :pointer-void) (data :pointer-void)) - (declare (ignore path data)) (let ((tree (of-tree (gtk-object-find model)))) (push (item-from-path (children-fn tree) From pdenno at common-lisp.net Tue Jan 3 19:03:03 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:03:03 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp Message-ID: <20060103190303.4542B88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30390/root/cells-gtk Modified Files: widgets.lisp Log Message: CFFI : removed #+clisp stuff Date: Tue Jan 3 20:03:02 2006 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.14 root/cells-gtk/widgets.lisp:1.15 --- root/cells-gtk/widgets.lisp:1.14 Sat Oct 8 16:33:19 2005 +++ root/cells-gtk/widgets.lisp Tue Jan 3 20:03:02 2006 @@ -209,11 +209,6 @@ , at signals-outputs))))) (defmacro callback ((widg event data) &body body) - #+clisp - `(c? (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - , at body t))) - #-clisp `(lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) ;(print (list :anon-callback self ,widg ,event ,data)) @@ -225,10 +220,7 @@ (defmacro callback-if (condition (widg event data) &body body) `(c? (and ,condition - #+clisp (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - , at body t)) - #-clisp (lambda (self ,widg ,event ,data) + (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) ;(print (list :anon-callback-if self ,widg ,event ,data)) , at body @@ -298,7 +290,7 @@ (not-to-be old-value)) (when new-value (gtk-widget-set-popup (id self) (id (to-be new-value))))) - + (def-c-output visible ((self widget)) (if new-value (gtk-widget-show (id self)) @@ -393,6 +385,7 @@ (gtk-container-add (id self) (id (first new-value)))) #+clisp (call-next-method)) +(declaim (inline widget-id)) (defun widget-id (widget) (id widget)) From pdenno at common-lisp.net Tue Jan 3 19:03:33 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:03:33 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/drawing.lisp Message-ID: <20060103190333.DF36288161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv30407/root/cells-gtk Modified Files: drawing.lisp Log Message: trivial Date: Tue Jan 3 20:03:33 2006 Author: pdenno Index: root/cells-gtk/drawing.lisp diff -u root/cells-gtk/drawing.lisp:1.2 root/cells-gtk/drawing.lisp:1.3 --- root/cells-gtk/drawing.lisp:1.2 Fri Nov 4 16:02:05 2005 +++ root/cells-gtk/drawing.lisp Tue Jan 3 20:03:33 2006 @@ -56,7 +56,6 @@ (gdk-draw-drawable cgtk::*window* cgtk::*gcontext* drawable 0 0 dx dy -1 -1))))) 0) -;;; data is not used, AFAIK. (defun gtk-drawing-set-handlers (widget data) (gtk-signal-connect-swap widget "button-press-event" (ffx:ff-register-callable 'drawing-button-events-handler) @@ -70,7 +69,6 @@ (gtk-signal-connect-swap widget "expose-event" (ffx:ff-register-callable 'drawing-expose-event-handler) :data data)) - (export '(gtk-drawing-set-handlers)) ;;;============================================================================ From pdenno at common-lisp.net Tue Jan 3 19:05:20 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:05:20 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-core.lisp Message-ID: <20060103190520.F25AE88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30441/root/gtk-ffi Modified Files: gtk-core.lisp Log Message: CFFI : removed various ifdefs. Date: Tue Jan 3 20:05:18 2006 Author: pdenno Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.4 root/gtk-ffi/gtk-core.lisp:1.5 --- root/gtk-ffi/gtk-core.lisp:1.4 Sat Oct 8 16:44:40 2005 +++ root/gtk-ffi/gtk-core.lisp Tue Jan 3 20:05:17 2006 @@ -67,33 +67,18 @@ (defmacro with-g-value ((var) &body body) `(call-with-g-value (lambda (,var) , at body))) -#+cmu -(ffx:def-type g-value-type - (* (alien:struct gtk-ffi::g-value - (gtk-ffi::g-type (array (alien:signed 32) 16))))) - -#+sbcl -(ffx:def-type g-value-type - (* (sb-alien:struct gtk-ffi::g-value - (gtk-ffi::g-type (array (sb-alien:signed 32) 16))))) - - (defun call-with-g-value (fn) (declare (optimize (speed 3) (safety 0) (space 0))) (let ((gva (ffx:fgn-alloc 'g-value 1 :with-g-value))) - #+(or cmu sbcl) (declare (type g-value-type gva)) (unwind-protect - (progn - (dotimes (n 16) - (let ((gv (ff-elt gva 'g-value 0))) + (dotimes (n 16) + (let ((gv (ffx:ff-elt gva 'g-value 0))) (let ((ns (get-slot-pointer gv 'g-value 'g-type))) - #+lispworks (setf (fli:foreign-aref ns n) 0) - #-lispworks (setf (deref-array ns '(:array :int) n) 0)))) - (funcall fn gva)) + (setf (deref-array ns '(:array :int) n) 0)))) + (funcall fn gva) (ffx:fgn-free gva)))) (eval-when (compile load eval) (export 'with-g-value)) - #+test (def-gtk-lib-functions :gobject From pdenno at common-lisp.net Tue Jan 3 19:06:23 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:06:23 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.asd Message-ID: <20060103190623.12BA088161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30470/root/gtk-ffi Modified Files: gtk-ffi.asd Log Message: CFFI: load cffi not hello-c, use *gtk-lib-path* on cmucl (STILL unresolved!). Date: Tue Jan 3 20:06:22 2006 Author: pdenno Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.9 root/gtk-ffi/gtk-ffi.asd:1.10 --- root/gtk-ffi/gtk-ffi.asd:1.9 Thu Nov 3 23:39:59 2005 +++ root/gtk-ffi/gtk-ffi.asd Tue Jan 3 20:06:22 2006 @@ -9,30 +9,25 @@ ;;; Step 1 -- If you are not using Linux nor BSD and the GTK libs are not ;;; in the places specified below, adjust these. -#+macosx (setf *gtk-lib-path* "/sw/lib/") -#+(or win32 mswindows) (setf *gtk-lib-path* "C:/Program Files/Common Files/GTK/2.0/bin/") +;;; Specify for Lispworks (definitely), other maybe. +#+macosx(setf *gtk-lib-path* "/sw/lib/") +#+(or win32 mswindows)(setf *gtk-lib-path* "E:/GTK/bin/") +;#-(or macosx win32 mswindows)(setf *gtk-lib-path* "/usr/lib/") +#-(or macosx win32 mswindows)(setf *gtk-lib-path* "/opt/gnome/lib/") ; For my SuSE machine -;;; This need not be specified for cmucl (leave as a null string). -#+cmu(setf *gtk-lib-path* "/usr/lib/") -;#+(OR cmu sbcl)(setf *gtk-lib-path* "/opt/gnome/lib/") ; For my Suse machine - -;;; Specify for Lispworks. -#-(or macosx win32 mswindows cmu) (setf *gtk-lib-path* "/usr/lib/") -;#-(or macosx win32 mswindows cmu) (setf *gtk-lib-path* "/opt/gnome/lib/") ; For my Suse machine - -;;; Step 2 -- If you built libcellsgtk.so, uncomment the next line. -;(pushnew :libcellsgtk *features*) +;;; Step 2 -- If you built or downloaded the libcellsgtk library, uncomment the next line. +(pushnew :libcellsgtk *features*) (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells :hello-c) + :depends-on (:cells :cffi :cffi-uffi-compat) :components - ((:file "gtk-ffi") + ((:file "ffx") ; Novikov Leonid's compatibility stuff from hello-c + (:file "gtk-ffi" :depends-on ("ffx")) (:file "gtk-core" :depends-on ("gtk-ffi")) (:file "gtk-other" :depends-on ("gtk-ffi")) - (:file "gdk-other" :depends-on ("gtk-ffi")) (:file "gtk-button" :depends-on ("gtk-ffi")) (:file "gtk-tool" :depends-on ("gtk-ffi")) (:file "gtk-menu" :depends-on ("gtk-ffi")) (:file "gtk-list-tree" :depends-on ("gtk-ffi")) - (:file "gtk-utilities" :depends-on ("gtk-core" "gtk-other")))) \ No newline at end of file + (:file "gtk-utilities" :depends-on ("gtk-core" "gtk-other")))) From pdenno at common-lisp.net Tue Jan 3 19:07:40 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:07:40 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp Message-ID: <20060103190740.ADB3888161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30493/root/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: CFFI : removed lots of ifdefs. Date: Tue Jan 3 20:07:40 2006 Author: pdenno Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.13 root/gtk-ffi/gtk-ffi.lisp:1.14 --- root/gtk-ffi/gtk-ffi.lisp:1.13 Sat Oct 8 16:48:03 2005 +++ root/gtk-ffi/gtk-ffi.lisp Tue Jan 3 20:07:39 2006 @@ -17,19 +17,16 @@ |# -(defpackage :gtk-ffi (:use #-sbcl :lisp #+sbcl :cl :utils-kt #-clisp :ffx #+clisp :ffi #-clisp :uffi)) +(defpackage :gtk-ffi (:use :lisp :ffx + :uffi)) (in-package :gtk-ffi) -(defconstant c-null #+clisp nil #-clisp (make-null-pointer '(* :void))) -(defconstant c-null-int #+clisp nil #-clisp (make-null-pointer :int)) +(defconstant c-null (make-null-pointer '(* :void))) +(defconstant c-null-int (make-null-pointer :int)) (defvar *gtk-debug* nil) -#+clisp -(defmacro with-cstring ((var str) &body body) - `(let ((,var ,str)) - , at body)) (defun int-slot-indexed (obj obj-type slot index) (declare (ignorable obj-type)) @@ -49,6 +46,15 @@ (export '(c-null c-null-int int-slot-indexed load-gtk-libs)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) + (defun libname (lib) + (ecase lib + (:gobject #+win32 "libgobject-2.0-0.dll" + #-win32 "libgobject-2.0.so") + (:glib #+win32 "libglib-2.0-0.dll") + (:gthread #+win32 "libgthread-2.0-0.dll") + (:gdk #+win32 "libgdk-win32-2.0-0.dll") + (:gtk #+win32 "libgtk-win32-2.0-0.dll") + #+libcellsgtk (:cgtk "libcellsgtk.dll"))) (defun load-gtk-libs () (macrolet ((loadit (libname module) `(uffi:load-foreign-library @@ -79,10 +85,11 @@ (loadit "libgdk-x11-2.0.so" :gdk) (loadit "libgtk-x11-2.0.so" :gtk) #+libcellsgtk(loadit "libcellsgtk.so" :cgtk)))) - #+(or cmu sbcl)(load-gtk-libs) + #+cmu(load-gtk-libs) + #+clisp(load-gtk-libs) (defun ffi-to-uffi-type (clisp-type) - #+clisp clisp-type - #-clisp (if (consp clisp-type) + + (if (consp clisp-type) (mapcar 'ffi-to-uffi-type clisp-type) (case clisp-type ((nil) :void) @@ -103,7 +110,7 @@ (single-float :float) (double-float :double) (otherwise clisp-type)))) - #-clisp + (defun ffi-to-native-type (ffi-type) (uffi::convert-from-uffi-type (ffi-to-uffi-type ffi-type) :type))) ;; END eval-when @@ -111,22 +118,10 @@ (defmacro def-gtk-function (library name &key arguments return-type (return-type-allocation :none) (call-direct t)) - (declare (ignore #+clisp call-direct #-clisp return-type-allocation)) + (declare (ignore return-type-allocation call-direct)) (let* ((gtk-name$ (gtk-function-name (string-downcase (symbol-name name)))) (gtk-name (intern (string-upcase gtk-name$)))) - #+clisp - `(progn - (def-call-out ,name - (:name ,gtk-name$) - (:library ,(libname library)) - ,@(when arguments `((:arguments , at arguments))) - (:return-type ,return-type ,return-type-allocation) - (:language :stdc)) - (eval-when (compile load eval) - (print `(exporting ,name)) - (export ',name))) - #-clisp (let ((arg-info (loop for arg in arguments for gsym = (gensym) @@ -148,7 +143,6 @@ (list name (ffi-to-uffi-type type)))) arguments) :module ,(string library) - :call-direct ,call-direct :returning ,(ffi-to-uffi-type return-type)) (defun ,name ,(mapcar 'car arguments) (when *gtk-debug* @@ -161,7 +155,11 @@ (,gtk-name ,@(cadr arg-info))))) (if (eql return-type 'boolean) `(not (zerop ,bodyform)) - bodyform)) + (if (eql return-type 'c-string) + `(convert-from-cstring ,bodyform) + bodyform) + )) + (when *gtk-debug* ,(unless (or (string= (symbol-name name) "GTK-EVENTS-PENDING") (string= (symbol-name name) "GTK-MAIN-ITERATION-DO")) @@ -186,15 +184,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro callback-function ((&rest arguments) &optional return-type) - (declare (ignore #-clisp arguments #-clisp return-type)) - #+clisp `'(c-function - ,@(when arguments `((:arguments , at arguments))) - (:return-type ,(ffi-to-uffi-type return-type)) - (:language :stdc)) - #-clisp `'c-pointer)) + (declare (ignore arguments return-type)) + `'c-pointer)) + -#-clisp (defmacro def-c-struct (struct-name &rest fields) (let ((slot-defs (loop for field in fields collecting (destructuring-bind (name type) field @@ -319,7 +313,7 @@ (32 :window_state) (33 :setting))) -#-clisp + (uffi:def-struct list-boolean (value :unsigned-int) (end :pointer-void)) @@ -367,7 +361,7 @@ (user-data3 c-pointer)) (defmacro with-tree-iter ((iter-var) &body body) - `(with-foreign-object (,iter-var 'gtk-tree-iter) + `(uffi:with-foreign-object (,iter-var 'gtk-tree-iter) (setf (get-slot-value ,iter-var 'gtk-tree-iter 'stamp) 0) (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data) c-null) (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data2) c-null) @@ -397,8 +391,6 @@ (:double (* 15 4)) (:boolean (* 5 4))))) - - (defun col-type-to-ffi-type (col-type) (cdr (assoc col-type '((:string . c-string) ;;2004:12:15-00:17 was c-pointer (:icon . c-pointer) @@ -412,14 +404,7 @@ (defmacro deref-pointer-runtime-typed (ptr type) "Returns a object pointed" (declare (ignorable type)) - #+(or cmu sbcl lispworks scl) (declare (ignore type)) - #+scl `(alien:deref ,ptr) - #+cmu `(alien:deref ,ptr) - #+sbcl `(sb-alien:deref ,ptr) - #+lispworks `(fli:dereference ,ptr) - #+allegro `(ff:fslot-value-typed (uffi::convert-from-uffi-type ,type :deref) :c ,ptr) - #+mcl `(ccl:pref ,ptr (uffi::convert-from-uffi-type ,type :deref)) - ) + `(deref-pointer ,ptr ,type)) (defun cast (ptr type) (deref-pointer-runtime-typed ptr (ffi-to-uffi-type type))) From pdenno at common-lisp.net Tue Jan 3 19:08:55 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:08:55 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-list-tree.lisp Message-ID: <20060103190855.0DA2C88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30518/root/gtk-ffi Modified Files: gtk-list-tree.lisp Log Message: CFFI : tree-store use c-pointer not array pointer Date: Tue Jan 3 20:08:51 2006 Author: pdenno Index: root/gtk-ffi/gtk-list-tree.lisp diff -u root/gtk-ffi/gtk-list-tree.lisp:1.3 root/gtk-ffi/gtk-list-tree.lisp:1.4 --- root/gtk-ffi/gtk-list-tree.lisp:1.3 Sun May 29 23:21:00 2005 +++ root/gtk-ffi/gtk-list-tree.lisp Tue Jan 3 20:08:51 2006 @@ -36,7 +36,7 @@ ;;tree-store (gtk-tree-store-newv ((n-columns int) - (col-types (c-array-ptr int))) + (col-types c-pointer)) c-pointer) (gtk-tree-store-set-valist ((store c-pointer) (iter c-pointer) From pdenno at common-lisp.net Tue Jan 3 19:09:41 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:09:41 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-other.lisp Message-ID: <20060103190941.99FDF88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30538/root/gtk-ffi Modified Files: gtk-other.lisp Log Message: Added gtk-main-level. Date: Tue Jan 3 20:09:41 2006 Author: pdenno Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.10 root/gtk-ffi/gtk-other.lisp:1.11 --- root/gtk-ffi/gtk-other.lisp:1.10 Fri Nov 18 05:35:32 2005 +++ root/gtk-ffi/gtk-other.lisp Tue Jan 3 20:09:41 2006 @@ -34,6 +34,7 @@ boolean nil nil) (gtk-main ()) (gtk-main-quit ()) + (gtk-main-level () int) (gtk-get-current-event-time () uint32) From pdenno at common-lisp.net Tue Jan 3 19:10:45 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:10:45 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp Message-ID: <20060103191045.D4BFD88161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30569/root/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: CFFI : removed lots of ifdef'ed stuff. Date: Tue Jan 3 20:10:45 2006 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.15 root/gtk-ffi/gtk-utilities.lisp:1.16 --- root/gtk-ffi/gtk-utilities.lisp:1.15 Sat Oct 8 16:50:26 2005 +++ root/gtk-ffi/gtk-utilities.lisp Tue Jan 3 20:10:45 2006 @@ -25,7 +25,7 @@ (g-signal-connect-data widget signal fun data destroy-data after)) (defun g-signal-connect-data (self detailed-signal c-handler data destroy-data after) - (with-cstrings ((c-detailed-signal detailed-signal)) + (uffi:with-cstrings ((c-detailed-signal detailed-signal)) (let ((p4 (or data c-null))) (g_signal_connect_data self @@ -38,7 +38,7 @@ (uffi:def-function ("g_signal_connect_data" g_signal_connect_data) ((instance :pointer-void) (detailed-signal :cstring) (c-handler :pointer-void) (data :pointer-void)(destroy-data :pointer-void) (after :int)) - :returning :unsigned-long :call-direct nil) + :returning :unsigned-long) (defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. (or func-address 0)) @@ -84,7 +84,6 @@ (ffx:ff-defun-callable :cdecl :int button-press-event-handler ((widget :pointer-void) (signal (* gdk-event-button)) (data :pointer-void)) - (declare (ignorable data)) (let ((event (gdk-event-button-type signal))) (when (or (eql (event-type event) :button_press) (eql (event-type event) :button_release)) @@ -193,23 +192,9 @@ column-no = num-columns. (See gtk-tree-store-set-kids)." (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) - #-(or lispworks cmu sbcl allegro) (cast item (as-gtk-type-name cell-type)) - #+allegro (case cell-type (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) - (t (cast item (as-gtk-type-name cell-type)))) - #+lispworks - (case cell-type - (:string (fli:convert-from-foreign-string (deref-pointer item))) - (t (deref-pointer item))) - #+cmu - (case cell-type - (:string (alien:cast (alien:deref item) c-call:c-string)) - (t (alien:deref item))) - #+sbcl - (case cell-type - (:string (sb-alien:cast (sb-alien:deref item) sb-c-call:c-string)) - (t (sb-alien:deref item))))) + (t (cast item (as-gtk-type-name cell-type)))))) (defun parse-cell-attrib (attribs) (loop for (attrib val) on attribs by #'cddr collect @@ -220,32 +205,6 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) -#+cmu -(alien:def-alien-type all-types - (alien:struct c-struct - (:string (* t)) - (:icon (* t)) - (:boolean boolean) - (:int integer) - (:long c-call:long) - (:date single-float) - (:float single-float) - (:double double-float))) - -#+sbcl -(sb-alien:def-alien-type all-types - (sb-alien:struct c-struct - (:string (* t)) - (:icon (* t)) - (:boolean boolean) - (:int integer) - (:long sb-c-call:long) - (:date single-float) - (:float single-float) - (:double double-float))) - - -#-cmu (progn (defun alloc-col-type-buffer (col-type) (ecase col-type @@ -269,37 +228,6 @@ (:float (deref-array buffer '(:array :float) 0)) (:double (deref-array buffer '(:array :double) 0))))) - -#+worksforallegroclbutnotlispworks -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - (lambda (tree-column cell-renderer model iter data) - (DECLARE (ignorable tree-column data)) - (let ((wvar (alloc-col-type-buffer col-type))) - (gtk-tree-model-get model iter col wvar -1) - (let ((item-value (deref-col-type-buffer col-type wvar))) - (with-gtk-string (str (format nil "~a" - (if (eql col-type :date) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (truncate item-value)) - (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" - day month year hour min sec)) - item-value))) - (ukt:trc nil "gtv-render-cell (callback11)> rendering value" - col col-type item-value) - (apply #'gtk-object-set-property cell-renderer - (case col-type - (:boolean (list "active" 'boolean item-value)) - (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) - (t (list "text" 'c-pointer str))))) - (when cell-attrib-f - (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do - (apply #'gtk-object-set-property cell-renderer property))) - #-(or allegro lispworks) - (when (find col-type '(:icon :string)) - (free-foreign-object item-value))) - (free-foreign-object wvar)))) - -#-cmu (defun gtk-tree-view-render-cell (col col-type cell-attrib-f) (ukt:trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f) (lambda (tree-column cell-renderer model iter data) @@ -313,11 +241,9 @@ (ffi-to-uffi-type (col-type-to-ffi-type col-type)))) (ret$ (when (find col-type '(:string :icon)) - (make-pointer returned-value :cstring))) - (item-value (cond - (ret$ #-lispworks (convert-from-cstring ret$) - #+lispworks (convert-from-foreign-string ret$ - :null-terminated-p t)) + returned-value)) + (item-value (cond + (ret$ (convert-from-cstring ret$)) ((eq col-type :boolean) (not (zerop returned-value))) (t returned-value)))) @@ -345,111 +271,6 @@ (uffi:free-foreign-object ret$)) (ffx:fgn-free return-buffer))) 1)) - -#+cmu -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - #'(lambda (tree-column cell-renderer model iter data) - (alien:with-alien ((struct all-types)) - (gtk-tree-model-get model iter col - (alien:addr (alien:slot struct col-type)) - -1) - (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) - (get-gtk-string (alien:slot struct col-type)) - (alien:slot struct col-type)))) - (with-gtk-string (str (format nil "~a" - (if (eql col-type :date) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (truncate item-value)) - (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" - day month year hour min sec)) - item-value))) - (ukt:trc nil "gtv-render-cell (callback11)> rendering value" - col col-type item-value) - (apply #'gtk-object-set-property cell-renderer - (case col-type - (:boolean (list "active" 'boolean item-value)) - (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) - (t (list "text" 'c-pointer str))))) - (when cell-attrib-f - (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do - (apply #'gtk-object-set-property cell-renderer property)))) - (when (eql col-type :string) - (g-free (alien:slot struct :string)))))) - -#+sbcl -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - #'(lambda (tree-column cell-renderer model iter data) - (sb-alien:with-alien ((struct all-types)) - (gtk-tree-model-get model iter col - (sb-alien:addr (sb-alien:slot struct col-type)) - -1) - (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) - (get-gtk-string (sb-alien:slot struct col-type)) - (sb-alien:slot struct col-type)))) - (with-gtk-string (str (format nil "~a" - (if (eql col-type :date) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (truncate item-value)) - (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" - day month year hour min sec)) - item-value))) - (ukt:trc nil "gtv-render-cell (callback11)> rendering value" - col col-type item-value) - (apply #'gtk-object-set-property cell-renderer - (case col-type - (:boolean (list "active" 'boolean item-value)) - (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) - (t (list "text" 'c-pointer str))))) - (when cell-attrib-f - (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do - (apply #'gtk-object-set-property cell-renderer property)))) - (when (eql col-type :string) - (g-free (sb-alien:slot struct :string)))))) - - - -#+clisp - -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - #'(lambda (tree-column cell-renderer model iter data) - (declare (ignore data)) - (with-c-var - (struct '(c-struct list - (:string c-pointer) - (:icon c-pointer) - (:boolean boolean) - (:int int) - (:long long) - (:date single-float) - (:float single-float) - (:double double-float)) - (list nil nil nil 0 0 (coerce 0 'single-float) (coerce 0 'single-float) (coerce 0 'double-float))) - (gtk-tree-model-get model iter col - (c-var-address (slot struct col-type)) - -1) - (let ((item-value (if (or (eql col-type :string) (eql col-type :icon)) - (get-gtk-string (slot struct col-type)) - (slot struct col-type)))) - (ukt:trc nil "tv-render-cell: " - :col-type col-type - :item item-value) - (with-gtk-string (str (format nil "~a" - (if (eql col-type :date) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (truncate item-value)) - (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D" - day month year hour min sec)) - item-value))) - (apply #'gtk-object-set-property cell-renderer - (case col-type - (:boolean (list "active" 'boolean item-value)) - (:icon (list "stock-id" 'c-string (string-downcase (format nil "gtk-~a" item-value)))) - (t (list "text" 'c-pointer str))))) - (when cell-attrib-f - (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) do - (apply #'gtk-object-set-property cell-renderer property)))) - (when (eql col-type :string) - (g-free (slot struct :string)))))) (defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser))) From pdenno at common-lisp.net Tue Jan 3 19:11:07 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:11:07 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/Makefile Message-ID: <20060103191107.6DA1488161@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv30584/root/gtk-ffi Modified Files: Makefile Log Message: trivial Date: Tue Jan 3 20:11:06 2006 Author: pdenno Index: root/gtk-ffi/Makefile diff -u root/gtk-ffi/Makefile:1.3 root/gtk-ffi/Makefile:1.4 --- root/gtk-ffi/Makefile:1.3 Wed Nov 16 02:42:47 2005 +++ root/gtk-ffi/Makefile Tue Jan 3 20:11:06 2006 @@ -27,4 +27,4 @@ all: gcc -c gtk-adds.c `pkg-config --cflags --libs gtk+-2.0` - gcc -shared -o libcellsgtk.so gtk-adds.o \ No newline at end of file + gcc -shared -o libcellsgtk.so gtk-adds.o `pkg-config --cflags --libs gtk+-2.0` \ No newline at end of file From pdenno at common-lisp.net Tue Jan 3 19:13:50 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 20:13:50 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: /INSTALL.TXT /load.lisp Message-ID: <20060103191350.E138688161@common-lisp.net> Update of /project/cells-gtk/cvsroot In directory common-lisp.net:/tmp/cvs-serv30638 Added Files: INSTALL.TXT load.lisp Log Message: added install.txt and load.lisp Date: Tue Jan 3 20:13:50 2006 Author: pdenno =================================================================== File: no file /INSTALL.TXT Status: Needs Checkout Working revision: No entry for /INSTALL.TXT Repository revision: 1.1 /project/cells-gtk/cvsroot//INSTALL.TXT,v =================================================================== File: no file /load.lisp Status: Needs Checkout Working revision: No entry for /load.lisp Repository revision: 1.1 /project/cells-gtk/cvsroot//load.lisp,v From pdenno at common-lisp.net Tue Jan 3 20:12:01 2006 From: pdenno at common-lisp.net (Peter Denno) Date: Tue, 3 Jan 2006 21:12:01 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: public_html/index.html Message-ID: <20060103201201.B3E0588161@common-lisp.net> Update of /project/cells-gtk/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv2912/public_html Modified Files: index.html Log Message: News about CFFI. Date: Tue Jan 3 21:12:00 2006 Author: pdenno Index: public_html/index.html diff -u public_html/index.html:1.11 public_html/index.html:1.12 --- public_html/index.html:1.11 Wed Nov 16 03:00:27 2005 +++ public_html/index.html Tue Jan 3 21:11:59 2006 @@ -74,12 +74,17 @@

News