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

[cells-gtk-cvs] CVS update: Directory change: clisp-cgtk/cells-gtk
by ktilton＠common-lisp.net 06 Dec '04

06 Dec '04

Update of /project/cells-gtk/cvsroot/clisp-cgtk/cells-gtk In directory common-lisp.net:/tmp/cvs-serv26517/cells-gtk Log Message: Directory /project/cells-gtk/cvsroot/clisp-cgtk/cells-gtk added to the repository Date: Mon Dec 6 21:21:25 2004 Author: ktilton New directory clisp-cgtk/cells-gtk added

1 0

[cells-gtk-cvs] CVS update: Module imported: clisp-cgtk
by ktilton＠common-lisp.net 06 Dec '04

06 Dec '04

Update of /project/cells-gtk/cvsroot/clisp-cgtk In directory common-lisp.net:/tmp/cvs-serv25811 Log Message: Vasilis Margioulas's original cells-gtk for clisp, using the clisp FFI. Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import Date: Mon Dec 6 21:11:08 2004 Author: ktilton New module clisp-cgtk added

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-buttons.lisp root/cells-gtk/test-gtk/test-gtk.lisp
by ktilton＠common-lisp.net 06 Dec '04

06 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv25746/cells-gtk/test-gtk Modified Files: test-buttons.lisp test-gtk.lisp Log Message: Ongoing port to Lispworks Date: Mon Dec 6 21:04:18 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-buttons.lisp diff -u root/cells-gtk/test-gtk/test-buttons.lisp:1.2 root/cells-gtk/test-gtk/test-buttons.lisp:1.3 --- root/cells-gtk/test-gtk/test-buttons.lisp:1.2 Sun Dec 5 07:33:31 2004 +++ root/cells-gtk/test-gtk/test-buttons.lisp Mon Dec 6 21:04:17 2004 @@ -1,10 +1,5 @@ (in-package :test-gtk) -;;;(ff-defun-callable :cdecl :void button-toggled-cb (self event data) -;;; (declare (ignorable event data)) -;;; (let ((state (gtk-toggle-button-get-active self))) -;;; (setf (md-value self) state))) - (defmodel test-buttons (vbox) ((nclics :accessor nclics :initform (c-in 0))) (:default-initargs Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.2 root/cells-gtk/test-gtk/test-gtk.lisp:1.3 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.2 Sun Dec 5 07:33:31 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Mon Dec 6 21:04:17 2004 @@ -13,10 +13,10 @@ :position :center :splash-screen-image "/000000/root/test-images/splash.png" :width 550 :height 550 - :kids (let ((tabs '("Buttons" "Display" "Layout" "Menus" - "Entry" - "Textview" "Dialogs" "Addon" - "Tree-view" + :kids (let ((tabs '("Buttons" ;"Display" "Layout" "Menus" + ;"Entry" + ;"Textview" "Dialogs" "Addon" + ;"Tree-view" ))) (list (mk-notebook :tab-labels nil #+not '("Buttons") @@ -31,8 +31,8 @@ #+clisp (ext:exit)) -(defun gtk-demo () +(defun gtk-demo (&optional dbg) (cells-gtk-init) - (cells-gtk:start-app 'test-gtk::test-gtk :debug nil)) + (cells-gtk:start-app 'test-gtk::test-gtk :debug dbg)) ;(ext:saveinitmem "test-gtk.mem" :init-function 'test-gtk::test-gtk-app)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/addon.lisp root/cells-gtk/buttons.lisp root/cells-gtk/callback.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp
by ktilton＠common-lisp.net 06 Dec '04

06 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv25746/cells-gtk Modified Files: addon.lisp buttons.lisp callback.lisp gtk-app.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: Ongoing port to Lispworks Date: Mon Dec 6 21:04:13 2004 Author: ktilton Index: root/cells-gtk/addon.lisp diff -u root/cells-gtk/addon.lisp:1.2 root/cells-gtk/addon.lisp:1.3 --- root/cells-gtk/addon.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/addon.lisp Mon Dec 6 21:04:12 2004 @@ -24,8 +24,7 @@ () (day-selected) :on-day-selected (callback (widg signal data) - (setf (md-value self) (get-date self)))) - + (setf (md-value self) (get-date self)))) (defmethod get-date ((self calendar)) (with-foreign-objects ((year :int)(month :int)(day :int)) Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.2 root/cells-gtk/buttons.lisp:1.3 --- root/cells-gtk/buttons.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/buttons.lisp Mon Dec 6 21:04:12 2004 @@ -51,9 +51,23 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) + (print (list :toggle-button :on-toggled-cb widget)) (let ((state (gtk-toggle-button-get-active widget))) + (print (list :toggledstate state)) (setf (md-value self) state)))) +#+test +(DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) + (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED + (CALLBACK (WIDGET EVENT DATA) + (LET ((STATE (GTK-TOGGLE-BUTTON-GET-ACTIVE WIDGET))) + (SETF (MD-VALUE SELF) STATE)))) + +#+test +(DEF-C-OUTPUT ACTIVE ((SELF TOGGLE-BUTTON)) + (WHEN (OR NEW-VALUE OLD-VALUE) + (CONFIGURE SELF #'GTK-TOGGLE-BUTTON-SET-ACTIVE NEW-VALUE))) + (def-c-output init ((self toggle-button)) (setf (active self) new-value) (setf (md-value self) new-value)) @@ -73,8 +87,9 @@ c-null (id (first (kids (fm-parent self)))))))) :on-toggled (callback (widget event data) - (let ((state (gtk-toggle-button-get-active widget))) - (setf (md-value self) state)))) + (print (list :radio-button widget event data)) + (let ((state (gtk-toggle-button-get-active widget))) + (setf (md-value self) state)))) (def-c-output .md-value ((self radio-button)) (when (and new-value (upper self box)) Index: root/cells-gtk/callback.lisp diff -u root/cells-gtk/callback.lisp:1.2 root/cells-gtk/callback.lisp:1.3 --- root/cells-gtk/callback.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/callback.lisp Mon Dec 6 21:04:12 2004 @@ -13,15 +13,15 @@ ;(format t "sym:~S fun:~A~%" sym func-self) ;(force-output) (when (not func-self) - (when *gtk-debug* - (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" - callback-id (type-of callback-id) (when (typep callback-id 'symbol) - (symbol-package callback-id))) - (maphash (lambda (key func-self) - (declare (ignore func-self)) - (format t "~&known callback key ~a, type ~a, pkg ~a" - key (type-of key)(when (typep key 'symbol) (symbol-package key)))) - (callbacks gtk-app)))) + (when *gtk-debug* + (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" + callback-id (type-of callback-id) (when (typep callback-id 'symbol) + (symbol-package callback-id))) + (maphash (lambda (key func-self) + (declare (ignore func-self)) + (format t "~&known callback key ~a, type ~a, pkg ~a" + key (type-of key)(when (typep key 'symbol) (symbol-package key)))) + (callbacks gtk-app)))) (when (car func-self) (apply (car func-self) (cdr func-self) callback callback-args))))) Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.2 root/cells-gtk/gtk-app.lisp:1.3 --- root/cells-gtk/gtk-app.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/gtk-app.lisp Mon Dec 6 21:04:12 2004 @@ -25,8 +25,9 @@ (tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil))) (:default-initargs :on-delete-event (lambda (self widget event data) - (declare (ignore self widget event data)) - (gtk-main-quit)))) + (declare (ignore self widget event data)) + (gtk-main-quit) + 0))) (def-c-output tooltips-enable ((self gtk-app)) (when (tooltips self) @@ -56,11 +57,10 @@ (trc "GTK INITIALIZATION") (force-output)) (g-thread-init c-null) (gdk-threads-init) - (assert (gtk-init-check c-null c-null)) + (assert (gtk-init-check c-null-int c-null)) (setf *gtk-initialized* t)) (with-gdk-threads - ;(gvi :withread) (let ((app (make-instance app-name :visible (c-in nil))) (splash)) (when (splash-screen-image app) @@ -71,12 +71,11 @@ (setf (visible splash) t) (loop while (gtk-events-pending) do (gtk-main-iteration))) - (gvi :splashup) + (to-be app) - (gvi :appup) + (when splash (not-to-be splash) - (gvi :splashdown) (gtk-window-set-auto-startup-notification t)) (setf (visible app) t) Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.2 root/cells-gtk/menus.lisp:1.3 --- root/cells-gtk/menus.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/menus.lisp Mon Dec 6 21:04:12 2004 @@ -20,7 +20,8 @@ (def-widget combo-box () ((items :accessor items :initarg :items :initform nil) - (items-factory :accessor items-factory :initarg :items-factory :initform #'(lambda (item) (format nil "~a" item))) + (items-factory :accessor items-factory :initarg :items-factory + :initform #'(lambda (item) (format nil "~a" item))) (init :accessor init :initarg :init :initform nil)) (active) (changed) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.2 root/cells-gtk/tree-view.lisp:1.3 --- root/cells-gtk/tree-view.lisp:1.2 Sun Dec 5 07:33:23 2004 +++ root/cells-gtk/tree-view.lisp Mon Dec 6 21:04:12 2004 @@ -102,7 +102,7 @@ (ff-defun-callable :cdecl :int tree-view-select-handler ((column-widget (* :void)) (event (* :void)) (data (* :void))) - (let ((tree-view (gtk-object-find column-widget))) + (let ((tree-view (gtk-object-find column-widget t))) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)))) @@ -173,11 +173,10 @@ (ff-defun-callable :cdecl :int tree-view-render-call-callback ((tree-column (* :void)) (cell-renderer (* :void)) (tree-model (* :void)) (iter (* :void)) (data (* :void))) - (let ((self (gtk-object-find tree-column))) - (assert self) - (let ((cb (callback-recover self :render-cell))) - (assert cb () "No :render-cell callback for ~a" self) - (funcall cb tree-column cell-renderer tree-model iter data)))) + (let* ((self (gtk-object-find tree-column t)) + (cb (callback-recover self :render-cell))) + (assert cb () "No :render-cell callback for ~a" self) + (funcall cb tree-column cell-renderer tree-model iter data))) (def-c-output columns ((self tree-view)) (when new-value Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.2 root/cells-gtk/widgets.lisp:1.3 --- root/cells-gtk/widgets.lisp:1.2 Sun Dec 5 07:33:23 2004 +++ root/cells-gtk/widgets.lisp Mon Dec 6 21:04:12 2004 @@ -52,37 +52,41 @@ (defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100))) -(defun gtk-object-store (id gtk-object) +(defun gtk-object-store (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) - (let ((known (gethash id *gtk-objects*))) + (let ((known (gethash hash-id *gtk-objects*))) (cond ((not known) - (setf (gethash id *gtk-objects*) gtk-object)) + (setf (gethash hash-id *gtk-objects*) gtk-object)) ((eql known gtk-object)) (t (break "gtk-object-store id ~a already known as ~a, not ~a" - id known gtk-object))))) + hash-id known gtk-object))))) -(defun gtk-object-forget (id gtk-object) +(defun gtk-object-forget (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id))) (assert *gtk-objects*) - (let ((known (gethash id *gtk-objects*))) + (let ((known (gethash hash-id *gtk-objects*))) (cond ((not known)) ((eql known gtk-object) - (setf (gethash id *gtk-objects*) nil)) + (setf (gethash hash-id *gtk-objects*) nil)) (t (break "gtk-object-store id ~a known as ~a, not forgettable ~a" - id known gtk-object))))) + hash-id known gtk-object))))) #+shhh (maphash (lambda (k v) (print (list k v))) *gtk-objects*) -(defun gtk-object-find (id &optional must-find-p) +(defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) (when *gtk-objects* - (let ((clos-widget (gethash id *gtk-objects*))) - (when must-find-p - (assert clos-widget)) + (let ((clos-widget (gethash hash-id *gtk-objects*))) + (when (and must-find-p (not clos-widget)) + (format t "~&gtk-object-find> ID ~a not found!!!!!!!" hash-id) + (maphash (lambda (key value) + (format t "~& known: ~a | ~a" key value)) + *gtk-objects*) + (break "gtk-object-find ID not found ~a" hash-id)) clos-widget))) ;; ----- fake callbackable closures ------------ @@ -112,11 +116,11 @@ (defmacro def-gtk-event-handler (event) `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) - ((widget (* :void)) (event (* :void)) (data (* :void))) - (let ((self (gtk-object-find widget))) - (assert self) - (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) - (funcall cb self widget event data))))) + ((widget (* :void)) (event (* :void)) (data (* :void))) + (print (list :def-gtk-event-handler ,(symbol-name event))) + (let ((self (gtk-object-find widget t))) + (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) + (funcall cb self widget event data))))) (def-gtk-event-handler clicked) (def-gtk-event-handler toggled) @@ -203,8 +207,13 @@ ,@body t))) #-clisp `(lambda (self ,widg ,event ,data) - (declare (ignorable self ,widg ,event ,data)) - ,@body t)) + (declare (ignorable self ,widg ,event ,data)) + (print (list :callback self ,widg ,event ,data)) + (prog1 + (progn + ,@body + 1) ;; a boolean which indicates, IIRC, "handled" + #+shhh (print (list :callback-finis self ,widg ,event ,data))))) (defmacro callback-if (condition (widg event data) &body body) `(c? (and ,condition @@ -213,18 +222,22 @@ ,@body t)) #-clisp (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - ,@body t)))) + (print (list :callback self ,widg ,event ,data)) + ,@body + 1)))) (ff-defun-callable :cdecl :int timeout-handler-callback ((data (* :void))) + (print :timeout-handler-callback) (let ((id (elti data 0))) (gtk-global-callback-funcall id))) (defun timeout-add (milliseconds function) (let ((id (gtk-global-callback-register (lambda () - (with-gdk-threads - (funcall function))))) + (print :timeout-add-global) + (with-gdk-threads + (funcall function))))) (c-id (fgn-alloc :int 1))) (setf (elti c-id 0) id) (g-timeout-add milliseconds (ff-register-callable 'timeout-handler-callback) c-id)))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-button.lisp root/gtk-ffi/gtk-core.lisp root/gtk-ffi/gtk-list-tree.lisp root/gtk-ffi/gtk-menu.lisp root/gtk-ffi/gtk-other.lisp root/gtk-ffi/gtk-tool.lisp root/gtk-ffi/gtk-ffi.asd root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-ffi.lpr root/gtk-ffi/gtk-utilities.lisp root/gtk-ffi/gtk-lib-gtk.lisp
by ktilton＠common-lisp.net 06 Dec '04

06 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv25707/gtk-ffi Modified Files: gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-utilities.lisp Added Files: gtk-button.lisp gtk-core.lisp gtk-list-tree.lisp gtk-menu.lisp gtk-other.lisp gtk-tool.lisp Removed Files: gtk-lib-gtk.lisp Log Message: Ongoing port to Lispworks Date: Mon Dec 6 21:03:00 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.3 root/gtk-ffi/gtk-ffi.asd:1.4 --- root/gtk-ffi/gtk-ffi.asd:1.3 Sun Dec 5 07:31:14 2004 +++ root/gtk-ffi/gtk-ffi.asd Mon Dec 6 21:03:00 2004 @@ -3,6 +3,10 @@ :depends-on (:cells :uffi :ffi-extender) :components ((:file "gtk-ffi") - (:file "gtk-definitions" :depends-on ("gtk-ffi")) - (:file "gtk-lib-gtk" :depends-on ("gtk-ffi")) - (:file "gtk-utilities" :depends-on ("gtk-definitions" "gtk-lib-gtk")))) \ No newline at end of file + (:file "gtk-core" :depends-on ("gtk-ffi")) + (:file "gtk-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 Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.3 root/gtk-ffi/gtk-ffi.lisp:1.4 --- root/gtk-ffi/gtk-ffi.lisp:1.3 Sun Dec 5 07:31:14 2004 +++ root/gtk-ffi/gtk-ffi.lisp Mon Dec 6 21:03:00 2004 @@ -23,6 +23,7 @@ (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)) (defvar *gtk-debug* nil) @@ -45,7 +46,7 @@ new-value)) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(c-null int-slot-indexed)) + (export '(c-null c-null-int int-slot-indexed)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) @@ -77,7 +78,7 @@ (c-ptr-null '*) (c-array-ptr '*) (c-ptr '*) - (c-string :pointer-void) + (c-string :cstring) (sint32 :int) (uint32 :unsigned-int) (uint8 :unsigned-byte) @@ -148,7 +149,7 @@ (if (eql return-type 'boolean) `(not (zerop ,bodyform)) bodyform)) - #+shhhh (print (list ,(symbol-name name) :after + (print (list ,(symbol-name name) :after ,@(mapcar 'car arguments))))) (eval-when (compile load eval) (export ',name)))))) Index: root/gtk-ffi/gtk-ffi.lpr diff -u root/gtk-ffi/gtk-ffi.lpr:1.1 root/gtk-ffi/gtk-ffi.lpr:1.2 --- root/gtk-ffi/gtk-ffi.lpr:1.1 Sun Dec 5 06:11:38 2004 +++ root/gtk-ffi/gtk-ffi.lpr Mon Dec 6 21:03:00 2004 @@ -8,6 +8,7 @@ :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "gtk-ffi.lisp") (make-instance 'module :name "gtk-definitions.lisp") + (make-instance 'module :name "gtk-lib-gtk.lisp") (make-instance 'module :name "gtk-utilities.lisp")) :projects (list (make-instance 'project-module :name "c:\\000000\\uffi\\uffi") Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.1 root/gtk-ffi/gtk-utilities.lisp:1.2 --- root/gtk-ffi/gtk-utilities.lisp:1.1 Sun Dec 5 06:11:38 2004 +++ root/gtk-ffi/gtk-utilities.lisp Mon Dec 6 21:03:00 2004 @@ -16,9 +16,10 @@ |# + (in-package :gtk-ffi) -(defun gtk-signal-connect (widget signal fun &key (after t) data (destroy-data 0)) +(defun gtk-signal-connect (widget signal fun &key (after t) data destroy-data) (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) @@ -27,14 +28,16 @@ (g_signal_connect_data self c-detailed-signal - (or c-handler c-null) + (if c-handler + (uffi:make-pointer c-handler '(* :void)) + c-null) p4 (or destroy-data c-null) (if after 1 0))))) (uffi:def-function ("g_signal_connect_data" g_signal_connect_data) - ((instance (* :void)) (detailed-signal (* :void)) - (c-handler :long) (data (* :void))(destroy-data (* :void)) (after :int)) + ((instance (* :void)) (detailed-signal :cstring) + (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil) (defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-addon.lisp root/cells-gtk/test-gtk/test-buttons.lisp root/cells-gtk/test-gtk/test-display.lisp root/cells-gtk/test-gtk/test-entry.lisp root/cells-gtk/test-gtk/test-gtk.asd root/cells-gtk/test-gtk/test-gtk.lisp root/cells-gtk/test-gtk/test-tree-view.lisp
by ktilton＠common-lisp.net 05 Dec '04

05 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv13216/cells-gtk/test-gtk Modified Files: test-addon.lisp test-buttons.lisp test-display.lisp test-entry.lisp test-gtk.asd test-gtk.lisp test-tree-view.lisp Log Message: Port to AllegroCl and Lispworks on win32 using UFFI Date: Sun Dec 5 07:33:34 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-addon.lisp diff -u root/cells-gtk/test-gtk/test-addon.lisp:1.1 root/cells-gtk/test-gtk/test-addon.lisp:1.2 --- root/cells-gtk/test-gtk/test-addon.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-addon.lisp Sun Dec 5 07:33:31 2004 @@ -3,28 +3,29 @@ (defmodel test-addon (notebook) () (:default-initargs - :tab-labels (list "Calendar" "Arrows") - :kids (list - (mk-vbox - :kids (list - (mk-calendar :md-name :calendar - :init (encode-universal-time 0 0 0 6 3 1971)) - (mk-label - :text (c? (when (md-value (fm^ :calendar)) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (md-value (fm^ :calendar))) - (format nil "Day selected ~a/~a/~a" day month year))))))) - (mk-vbox - :kids (list - (mk-arrow - :type (c? (md-value (fm^ :type)))) - (mk-frame - :label "Arrow type" - :kids (list - (mk-hbox - :md-name :type - :kids (list - (mk-radio-button :md-name :up :label "Up") - (mk-radio-button :md-name :down :label "Down") - (mk-radio-button :md-name :left :label "Left") - (mk-radio-button :md-name :right :label "Right" :init t)))))))))) \ No newline at end of file + :tab-labels (list "Calendar" "Arrows") + :kids (list + (mk-vbox + :kids (list + (mk-calendar :md-name :calendar + :init (encode-universal-time 0 0 0 6 3 1971)) + (mk-label + :text (c? (when (md-value (fm^ :calendar)) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (md-value (fm^ :calendar))) + (declare (ignorable sec min hour)) + (format nil "Day selected ~a/~a/~a" day month year))))))) + (mk-vbox + :kids (list + (mk-arrow + :type (c? (md-value (fm^ :type)))) + (mk-frame + :label "Arrow type" + :kids (list + (mk-hbox + :md-name :type + :kids (list + (mk-radio-button :md-name :up :label "Up") + (mk-radio-button :md-name :down :label "Down") + (mk-radio-button :md-name :left :label "Left") + (mk-radio-button :md-name :right :label "Right" :init t)))))))))) \ No newline at end of file Index: root/cells-gtk/test-gtk/test-buttons.lisp diff -u root/cells-gtk/test-gtk/test-buttons.lisp:1.1 root/cells-gtk/test-gtk/test-buttons.lisp:1.2 --- root/cells-gtk/test-gtk/test-buttons.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-buttons.lisp Sun Dec 5 07:33:31 2004 @@ -1,5 +1,10 @@ (in-package :test-gtk) +;;;(ff-defun-callable :cdecl :void button-toggled-cb (self event data) +;;; (declare (ignorable event data)) +;;; (let ((state (gtk-toggle-button-get-active self))) +;;; (setf (md-value self) state))) + (defmodel test-buttons (vbox) ((nclics :accessor nclics :initform (c-in 0))) (:default-initargs Index: root/cells-gtk/test-gtk/test-display.lisp diff -u root/cells-gtk/test-gtk/test-display.lisp:1.1 root/cells-gtk/test-gtk/test-display.lisp:1.2 --- root/cells-gtk/test-gtk/test-display.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-display.lisp Sun Dec 5 07:33:31 2004 @@ -4,57 +4,59 @@ () (:default-initargs :md-value (c? (when (md-value (fm-other :pulse)) - (timeout-add (md-value (fm-other :timeout)) - (lambda () - (pulse (fm-other :pbar2)) - (md-value (fm-other :pulse)))))) - :expand t :fill t - :kids (list - (mk-hbox - :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect - (mk-image :stock :harddisk :icon-size icon-size))) - (mk-hseparator) - (mk-aspect-frame - :ratio 1 - :kids (list - (mk-image :width 200 :height 250 :filename "test-images/tst.gif"))) - (mk-hseparator) - (mk-hbox - :kids (list - (mk-progress-bar :md-name :pbar - :fraction (c? (md-value (fm^ :fraction-value)))) - (mk-hscale :md-name :fraction-value - :value-type 'single-float - :min 0 :max 1 - :step 0.01 - :init 0.5) - (mk-button :label "Show in status bar" - :on-clicked - (callback (widget event data) - (push-message (fm-other :statusbar) - (format nil "~a" (fraction (fm-other :pbar)))))))) - (mk-hbox - :kids (list - (mk-progress-bar :md-name :pbar2 - :pulse-step (c? (md-value (fm^ :step))) - :fraction (c-in 0)) - (mk-toggle-button :md-name :pulse - :label "Pulse") - (mk-label :text "Timeout") - (mk-spin-button :md-name :timeout - :sensitive (c? (not (md-value (fm^ :pulse)))) - :min 10 :max 1000 - :init 100) - (mk-label :text "Pulse step") - (mk-spin-button :md-name :step - :value-type 'single-float - :min 0.01 :max 1 :step 0.01 - :init 0.1) - (mk-image :md-name :pulse-image - :stock (c? (if (md-value (fm^ :pulse)) :yes :no))))) - (mk-alignment - :expand t :fill t - :xalign 0 :yalign 1 - :xscale 1 - :kids (list - (mk-statusbar :md-name :statusbar)))))) + (timeout-add (md-value (fm-other :timeout)) + (lambda () + (pulse (fm-other :pbar2)) + (md-value (fm-other :pulse)))))) + :expand t :fill t + :kids (list + (mk-hbox + :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect + (mk-image :stock :harddisk :icon-size icon-size))) + (mk-hseparator) + (mk-aspect-frame + :ratio 1 + :kids (list + (mk-image :width 200 :height 250 + :filename "/000000/root/test-images/tst.gif"))) + (mk-hseparator) + (mk-hbox + :kids (list + (mk-progress-bar :md-name :pbar + :fraction (c? (md-value (fm^ :fraction-value)))) + (mk-hscale :md-name :fraction-value + :value-type 'single-float + :min 0 :max 1 + :step 0.01 + :init 0.5) + (mk-button :label "Show in status bar" + :on-clicked + (callback (widget event data) + (format t "fraction is ~a" (fraction (fm-other :pbar))) + (push-message (fm-other :statusbar) + (format nil "~a" (fraction (fm-other :pbar)))))))) + (mk-hbox + :kids (list + (mk-progress-bar :md-name :pbar2 + :pulse-step (c? (md-value (fm^ :step))) + :fraction (c-in 0)) + (mk-toggle-button :md-name :pulse + :label "Pulse") + (mk-label :text "Timeout") + (mk-spin-button :md-name :timeout + :sensitive (c? (not (md-value (fm^ :pulse)))) + :min 10 :max 1000 + :init 100) + (mk-label :text "Pulse step") + (mk-spin-button :md-name :step + :value-type 'single-float + :min 0.01 :max 1 :step 0.01 + :init 0.1) + (mk-image :md-name :pulse-image + :stock (c? (if (md-value (fm^ :pulse)) :yes :no))))) + (mk-alignment + :expand t :fill t + :xalign 0 :yalign 1 + :xscale 1 + :kids (list + (mk-statusbar :md-name :statusbar)))))) Index: root/cells-gtk/test-gtk/test-entry.lisp diff -u root/cells-gtk/test-gtk/test-entry.lisp:1.1 root/cells-gtk/test-gtk/test-entry.lisp:1.2 --- root/cells-gtk/test-gtk/test-entry.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-entry.lisp Sun Dec 5 07:33:31 2004 @@ -4,59 +4,65 @@ () (:default-initargs :kids (list - (mk-vbox - :kids (list - (mk-label - :expand t :fill t - :markup (c? (with-markup (:font-desc "24") - (with-markup (:foreground :blue - :font-family "Arial" - :font-desc (if (md-value (fm-other :spin)) - (truncate (md-value (fm-other :spin))) - 10)) - (md-value (fm-other :entry))) - (with-markup (:underline :double - :weight :bold - :foreground :red - :font-desc (if (md-value (fm-other :hscale)) - (truncate (md-value (fm-other :hscale))) - 10)) - "is") - (with-markup (:strikethrough (md-value (fm^ :cool))) - "boring") - (with-markup (:strikethrough (not (md-value (fm^ :cool)))) - "cool!"))) - :selectable t) - (mk-entry :md-name :entry :auto-aupdate t :init "Testing"))) + (mk-vbox + :kids (test-entry-1)) + + (mk-check-button :md-name :cool + :init t + :label "Cool") + (mk-frame + :kids (test-entry-2)) + (mk-hbox + :kids (list + (mk-spin-button :md-name :spin + :init 10))) + (mk-hbox + :kids (list + (mk-label :text "Entry completion test (press i)") + (mk-entry + :max-length 20 + :completion (loop for i from 1 to 10 collect + (format nil "Item ~d" i)))))))) - (mk-check-button :md-name :cool - :init t - :label "Cool") - (mk-frame - :kids (list - (mk-vbox - :kids (list - (mk-hbox - :kids (list - (mk-check-button :md-name :sensitive - :label "Sensitive") - (mk-check-button :md-name :visible - :init t - :label "Visible"))) - (mk-hscale :md-name :hscale - :visible (c? (md-value (fm^ :visible))) - :sensitive (c? (md-value (fm^ :sensitive))) - :expand t :fill t - :min 0 :max 100 - :init 10))))) - (mk-hbox - :kids (list - (mk-spin-button :md-name :spin - :init 10))) - (mk-hbox - :kids (list - (mk-label :text "Entry completion test (press i)") - (mk-entry - :max-length 20 - :completion (loop for i from 1 to 10 collect - (format nil "Item ~d" i)))))))) +(defun test-entry-1 () + (c? (list + (mk-label + :expand t :fill t + :markup (c? (with-markup (:font-desc "24") + (with-markup (:foreground :blue + :font-family "Arial" + :font-desc (if (md-value (fm-other :spin)) + (truncate (md-value (fm-other :spin))) + 10)) + (md-value (fm-other :entry))) + (with-markup (:underline :double + :weight :bold + :foreground :red + :font-desc (if (md-value (fm-other :hscale)) + (truncate (md-value (fm-other :hscale))) + 10)) + "is") + (with-markup (:strikethrough (md-value (fm^ :cool))) + "boring") + (with-markup (:strikethrough (not (md-value (fm^ :cool)))) + "cool!"))) + :selectable t) + (mk-entry :md-name :entry :auto-aupdate t :init "Testing")))) + +(defun test-entry-2 () + (c? (list + (mk-vbox + :kids (c? (list + (mk-hbox + :kids (list + (mk-check-button :md-name :sensitive + :label "Sensitive") + (mk-check-button :md-name :visible + :init t + :label "Visible"))) + (mk-hscale :md-name :hscale + :visible (c? (md-value (fm^ :visible))) + :sensitive (c? (md-value (fm^ :sensitive))) + :expand t :fill t + :min 0 :max 100 + :init 10))))))) \ No newline at end of file Index: root/cells-gtk/test-gtk/test-gtk.asd diff -u root/cells-gtk/test-gtk/test-gtk.asd:1.1 root/cells-gtk/test-gtk/test-gtk.asd:1.2 --- root/cells-gtk/test-gtk/test-gtk.asd:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-gtk.asd Sun Dec 5 07:33:31 2004 @@ -1,6 +1,6 @@ (asdf:defsystem :test-gtk :name "test-gtk" - :depends-on (:cells :cells-gtk) + :depends-on (:cells-gtk) :serial t :components ((:file "test-gtk") Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.1 root/cells-gtk/test-gtk/test-gtk.lisp:1.2 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Sun Dec 5 07:33:31 2004 @@ -1,26 +1,38 @@ (defpackage :test-gtk - (:use :common-lisp :utils-kt :cells :cells-gtk)) + (:use :common-lisp :utils-kt :cells :gtk-ffi :cells-gtk #-clisp :ffx)) (in-package :test-gtk) (defmodel test-gtk (gtk-app) () (:default-initargs - :title "GTK Testing" + :title "GTK Testing" + ;;:tooltips nil ;;dkwt + ;;:tooltips-enable nil ;;dkwt :icon "test-images/small.png" :position :center - :splash-screen-image "test-images/splash.png" + :splash-screen-image "/000000/root/test-images/splash.png" :width 550 :height 550 - :kids (list - (mk-notebook - :tab-labels '("Buttons" "Entry" "Display" "Layout" "Menus" - "Tree view" "Text view" "Dialogs" "Addons") - :kids (loop for test-name in '(test-buttons test-entry test-display test-layout test-menus - test-tree-view test-textview test-dialogs test-addon) - collect (make-instance test-name)))))) + :kids (let ((tabs '("Buttons" "Display" "Layout" "Menus" + "Entry" + "Textview" "Dialogs" "Addon" + "Tree-view" + ))) + (list (mk-notebook + :tab-labels nil #+not '("Buttons") + :kids (loop for test-name in tabs + collect (make-instance + (intern (string-upcase + (format nil "test-~a" test-name)) + :test-gtk)))))))) (defun test-gtk-app () (start-app 'test-gtk) #+clisp (ext:exit)) + + +(defun gtk-demo () + (cells-gtk-init) + (cells-gtk:start-app 'test-gtk::test-gtk :debug nil)) ;(ext:saveinitmem "test-gtk.mem" :init-function 'test-gtk::test-gtk-app) Index: root/cells-gtk/test-gtk/test-tree-view.lisp diff -u root/cells-gtk/test-gtk/test-tree-view.lisp:1.1 root/cells-gtk/test-gtk/test-tree-view.lisp:1.2 --- root/cells-gtk/test-gtk/test-tree-view.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-tree-view.lisp Sun Dec 5 07:33:31 2004 @@ -15,165 +15,176 @@ (defmodel test-tree-view (notebook) ((items :accessor items :initarg :items - :initform (c? (and (md-value (fm-other :hscale)) - (loop for i from 1 to (md-value (fm-other :hscale)) collect - (make-be 'listbox-test-item - :string (format nil "Item ~d" i) - :icon (nth (random 5) (list "home" "open" "save" "ok" "cancel")) - :int i - :float (coerce (* (+ i 1) (/ 1 (1+ (random 100)))) 'single-float) - :double (coerce (* (+ i 2) (/ 1 (1+ (random 1000)))) 'double-float) - :boolean (oddp i) - :date (- (get-universal-time) (random 10000000)))))))) + :initform (c? (and (md-value (fm-other :hscale)) + (loop for i from 1 to (md-value (fm-other :hscale)) collect + (make-be 'listbox-test-item + :string (format nil "Item ~d" i) + :icon (nth (random 5) (list "home" "open" "save" "ok" "cancel")) + :int i + :float (coerce (* (+ i 1) (/ 1 (1+ (random 100)))) 'single-float) + :double (coerce (* (+ i 2) (/ 1 (1+ (random 1000)))) 'double-float) + :boolean (oddp i) + :date (- (get-universal-time) (random 10000000)))))))) (:default-initargs :tab-labels (list "Listbox" "Treebox") - :kids (list - (mk-vbox - :homogeneous nil - :kids (list - (mk-scrolled-window - :kids (list - (mk-listbox - :columns (def-columns - (:string (:title "Selection"))) - :items (c? (let ((sel (md-value (fm-other :listbox)))) - (if (listp sel) sel (list sel)))) - :items-factory (lambda (item) - (list (format nil "~a" item)))))) - (mk-frame - :label "Selection mode" - :kids (list - (mk-hbox - :md-name :selection-mode - :kids (list - (mk-radio-button :md-name :none :label "None" - :md-value (c-in t)) - (mk-radio-button :md-name :single :label "Single") - (mk-radio-button :md-name :browse :label "Browse") - (mk-radio-button :md-name :multiple :label "Multiple"))))) - - (mk-hbox - :kids (list - (mk-label :text "Select") - (mk-combo-box - :md-name :selection-predicate - :init (c? (first (items self))) - :items (list - #'null - #'(lambda (itm) t) - #'(lambda (itm) (not (null (boolean$ itm)))) - #'(lambda (itm) - (multiple-value-bind (sec min hour day month year) - (decode-universal-time (get-universal-time)) - (multiple-value-bind (itm-sec itm-min itm-hour itm-day itm-month itm-year) - (decode-universal-time (date$ itm)) - (= month itm-month)))) - #'(lambda (itm) (oddp (int$ itm))) - #'(lambda (itm) (evenp (int$ itm)))) - :items-factory (c? - #'(lambda (item) - (case (position item (items self)) - (0 "None") - (1 "All") - (2 "True") - (3 "This month") - (4 "Odd") - (5 "Even"))))) - (mk-label :text "Items in Listbox") - (mk-hscale - :md-name :hscale - :expand t :fill t - :min 0 :max 200 - :init 100))) - (mk-scrolled-window - :kids (list - (mk-listbox - :md-name :listbox - :selection-mode (c? (md-value (fm-other :selection-mode))) - :columns (def-columns - (:string (:title "String") #'(lambda (val) '(:font "courier"))) - (:icon (:title "Icon")) - (:int (:title "Int") #'(lambda (val) - (if (oddp val) - '(:foreground "red" :size 14) - '(:foreground "blue" :size 6)))) - (:float (:title "Float" :expand nil)) - (:double (:title "Double") #'(lambda (val) - (if (> val 0.5) - '(:foreground "cyan" :strikethrough nil) - '(:foreground "navy" :strikethrough t)))) - (:boolean (:title "Boolean")) - (:date (:title "Date"))) - :select-if (c? (md-value (fm^ :selection-predicate))) - :items (c? (items (upper self test-tree-view))) - :items-factory (lambda (item) - (list (string$ item) (icon$ item) (int$ item) (float$ item) - (double$ item) (boolean$ item) (date$ item)))))))) - (mk-vbox - :homogeneous nil - :kids (list - (mk-scrolled-window - :kids (list - (mk-listbox - :columns (def-columns - (:string (:title "Selection"))) - :items (c? (let ((sel (md-value (fm-other :treebox)))) - (mapcar #'(lambda (item) - (list (format nil "~a" (class-name (class-of item))))) - (if (listp sel) sel (list sel)))))))) - (mk-frame - :label "Selection mode" - :kids (list - (mk-hbox - :md-name :tree-selection-mode - :kids (list - (mk-radio-button :md-name :none :label "None" - :md-value (c-in t)) - (mk-radio-button :md-name :single :label "Single") - (mk-radio-button :md-name :browse :label "Browse") - (mk-radio-button :md-name :multiple :label "Multiple"))))) - (mk-hbox - :kids (list - (mk-label :text "Select") - (mk-combo-box - :md-name :tree-selection-predicate - :init (c? (first (items self))) - :items (list - #'null - #'(lambda (itm) (subtypep (class-name (class-of itm)) 'vbox)) - #'(lambda (itm) (subtypep (class-name (class-of itm)) 'button)) - #'(lambda (itm) (subtypep (class-name (class-of itm)) 'notebook))) - :items-factory (c? - #'(lambda (item) - (case (position item (items self)) - (0 "None") - (1 "VBoxes") - (2 "Buttons") - (3 "Notebooks"))))))) - (mk-scrolled-window - :kids (list - (mk-treebox - :md-name :treebox - :selection-mode (c? (md-value (fm^ :tree-selection-mode))) - :select-if (c? (md-value (fm^ :tree-selection-predicate))) - :columns (def-columns - (:string (:title "Widget class") #'(lambda (val) '(:font "courier"))) - (:icon (:title "Icon")) - (:int (:title "Number of kids") - #'(lambda (val) - (list :foreground (if (> val 5) "red" "blue")))) - (:string (:title "Gtk address"))) - :items (c? (list (upper self gtk-app))) - :items-factory #'(lambda (item) - (list - (format nil "~a" (class-name (class-of item))) - (case (class-name (class-of item)) - (gtk-app "home") - (vbox "open") - (hbox "open") - (window "index") - (t "jump-to")) - (length (kids item)) - (format nil "~a" - (when (subtypep (class-name (class-of item)) 'cells-gtk::gtk-object) - (cells-gtk::id item))))))))))))) \ No newline at end of file + :kids (list + (mk-vbox + :homogeneous nil + :kids (list + (mk-scrolled-window + :kids (list + (mk-listbox + :columns (def-columns + (:string (:title "Selection"))) + :items (c? (let ((sel (md-value (fm-other :listbox)))) + (if (listp sel) sel (list sel)))) + :items-factory (lambda (item) + (list (format nil "~a" item)))))) + (mk-frame + :label "Selection mode" + :kids (list + (mk-hbox + :md-name :selection-mode + :kids (list + (mk-radio-button :md-name :none :label "None" + :md-value (c-in t)) + (mk-radio-button :md-name :single :label "Single") + (mk-radio-button :md-name :browse :label "Browse") + (mk-radio-button :md-name :multiple :label "Multiple"))))) + + (mk-hbox + :kids (list + (mk-label :text "Select") + (mk-combo-box + :md-name :selection-predicate + :init (c? (first (items self))) + :items (list + #'null + #'(lambda (itm) + (declare (ignore itm)) + t) + #'(lambda (itm) (not (null (boolean$ itm)))) + #'(lambda (itm) + (multiple-value-bind (sec min hour day month year) + (decode-universal-time (get-universal-time)) + (declare (ignore sec min hour day year)) + + (multiple-value-bind (itm-sec itm-min itm-hour itm-day itm-month itm-year) + (decode-universal-time (date$ itm)) + (declare (ignore itm-sec itm-min itm-hour itm-day itm-year)) + (= month itm-month)))) + #'(lambda (itm) (oddp (int$ itm))) + #'(lambda (itm) (evenp (int$ itm)))) + :items-factory (c? + #'(lambda (item) + (case (position item (items self)) + (0 "None") + (1 "All") + (2 "True") + (3 "This month") + (4 "Odd") + (5 "Even"))))) + (mk-label :text "Items in Listbox") + (mk-hscale + :md-name :hscale + :expand t :fill t + :min 0 :max 200 + :init 100))) + (mk-scrolled-window + :kids (list + (mk-listbox + :md-name :listbox + :selection-mode (c? (md-value (fm-other :selection-mode))) + :columns (def-columns + (:string (:title "String") + #'(lambda (val) + (declare (ignore val)) + '(:font "courier"))) + (:icon (:title "Icon")) + (:int (:title "Int") #'(lambda (val) + (if (oddp val) + '(:foreground "red" :size 14) + '(:foreground "blue" :size 6)))) + (:float (:title "Float" :expand nil)) + (:double (:title "Double") #'(lambda (val) + (if (> val 0.5) + '(:foreground "cyan" :strikethrough nil) + '(:foreground "navy" :strikethrough t)))) + (:boolean (:title "Boolean")) + (:date (:title "Date"))) + :select-if (c? (md-value (fm^ :selection-predicate))) + :items (c? (items (upper self test-tree-view))) + :items-factory (lambda (item) + (list (string$ item) (icon$ item) (int$ item) (float$ item) + (double$ item) (boolean$ item) (date$ item)))))))) + (mk-vbox + :homogeneous nil + :kids (list + (mk-scrolled-window + :kids (list + (mk-listbox + :columns (def-columns + (:string (:title "Selection"))) + :items (c? (let ((sel (md-value (fm-other :treebox)))) + (mapcar #'(lambda (item) + (list (format nil "~a" (class-name (class-of item))))) + (if (listp sel) sel (list sel)))))))) + (mk-frame + :label "Selection mode" + :kids (list + (mk-hbox + :md-name :tree-selection-mode + :kids (list + (mk-radio-button :md-name :none :label "None" + :md-value (c-in t)) + (mk-radio-button :md-name :single :label "Single") + (mk-radio-button :md-name :browse :label "Browse") + (mk-radio-button :md-name :multiple :label "Multiple"))))) + (mk-hbox + :kids (list + (mk-label :text "Select") + (mk-combo-box + :md-name :tree-selection-predicate + :init (c? (first (items self))) + :items (list + #'null + #'(lambda (itm) (subtypep (class-name (class-of itm)) 'vbox)) + #'(lambda (itm) (subtypep (class-name (class-of itm)) 'button)) + #'(lambda (itm) (subtypep (class-name (class-of itm)) 'notebook))) + :items-factory (c? + #'(lambda (item) + (case (position item (items self)) + (0 "None") + (1 "VBoxes") + (2 "Buttons") + (3 "Notebooks"))))))) + (mk-scrolled-window + :kids (list + (mk-treebox + :md-name :treebox + :selection-mode (c? (md-value (fm^ :tree-selection-mode))) + :select-if (c? (md-value (fm^ :tree-selection-predicate))) + :columns (def-columns + (:string (:title "Widget class") + #'(lambda (val) + (declare (ignore val)) + '(:font "courier"))) + (:icon (:title "Icon")) + (:int (:title "Number of kids") + #'(lambda (val) + (list :foreground (if (> val 5) "red" "blue")))) + (:string (:title "Gtk address"))) + :items (c? (list (upper self gtk-app))) + :items-factory #'(lambda (item) + (list + (format nil "~a" (class-name (class-of item))) + (case (class-name (class-of item)) + (gtk-app "home") + (vbox "open") + (hbox "open") + (window "index") + (t "jump-to")) + (length (kids item)) + (format nil "~a" + (when (subtypep (class-name (class-of item)) 'cells-gtk::gtk-object) + (cells-gtk::id item))))))))))))) \ No newline at end of file

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/addon.lisp root/cells-gtk/buttons.lisp root/cells-gtk/callback.lisp root/cells-gtk/cells-gtk.lisp root/cells-gtk/dialogs.lisp root/cells-gtk/display.lisp root/cells-gtk/entry.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/layout.lisp root/cells-gtk/menus.lisp root/cells-gtk/textview.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp
by ktilton＠common-lisp.net 05 Dec '04

05 Dec '04

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv13216/cells-gtk Modified Files: addon.lisp buttons.lisp callback.lisp cells-gtk.lisp dialogs.lisp display.lisp entry.lisp gtk-app.lisp layout.lisp menus.lisp textview.lisp tree-view.lisp widgets.lisp Log Message: Port to AllegroCl and Lispworks on win32 using UFFI Date: Sun Dec 5 07:33:23 2004 Author: ktilton Index: root/cells-gtk/addon.lisp diff -u root/cells-gtk/addon.lisp:1.1 root/cells-gtk/addon.lisp:1.2 --- root/cells-gtk/addon.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/addon.lisp Sun Dec 5 07:33:22 2004 @@ -16,6 +16,7 @@ |# + (in-package :cgtk) (def-widget calendar () @@ -25,19 +26,18 @@ :on-day-selected (callback (widg signal data) (setf (md-value self) (get-date self)))) + (defmethod get-date ((self calendar)) - (with-c-var (year 'uint) - (with-c-var (month 'uint) - (with-c-var (day 'uint) - (gtk-calendar-get-date (id self) - (ffi:c-var-address year) - (ffi:c-var-address month) - (ffi:c-var-address day)) - (encode-universal-time 0 0 0 day (1+ month) year))))) + (with-foreign-objects ((year :int)(month :int)(day :int)) + (gtk-calendar-get-date (id self) year month day) + (encode-universal-time 0 0 0 (deref-pointer day :int) + (1+ (deref-pointer month :int)) (deref-pointer year :int)))) (def-c-output init ((self calendar)) (when new-value (multiple-value-bind (sec min hour day month year) (decode-universal-time new-value) + + (declare (ignorable sec min hour)) (gtk-calendar-select-month (id self) (1- month) year) (gtk-calendar-select-day (id self) day)) (setf (md-value self) new-value))) Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.1 root/cells-gtk/buttons.lisp:1.2 --- root/cells-gtk/buttons.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/buttons.lisp Sun Dec 5 07:33:22 2004 @@ -28,8 +28,7 @@ (def-c-output label ((self button)) (when new-value - (with-gtk-string (str new-value) - (gtk-button-set-label (id self) str)))) + (gtk-button-set-label (id self) new-value))) (def-c-output markup ((self button)) (when new-value @@ -38,24 +37,22 @@ (def-c-output .kids ((self button)) (assert-bin self) (dolist (kid (kids self)) - (gtk-container-add (id self) (id kid))) - (call-next-method)) + (gtk-container-add (id self) (id kid)))) (def-c-output stock ((self button)) (when new-value (setf (label self) (string-downcase (format nil "gtk-~a" new-value))) - (trc (label self)) (force-output) + (trc "stock" (label self)) (force-output) (setf (use-stock self) t))) - (def-widget toggle-button (button) ((init :accessor init :initarg :init :initform nil)) (mode active) (toggled) :active (c-in nil) - :on-toggled (callback (widget event data) - (let ((state (gtk-toggle-button-get-active widget))) - (setf (md-value self) state)))) + :on-toggled (callback (widget event data) + (let ((state (gtk-toggle-button-get-active widget))) + (setf (md-value self) state)))) (def-c-output init ((self toggle-button)) (setf (active self) new-value) @@ -73,13 +70,12 @@ :new-args (c? (and (upper self box) (list (if (eql (first (kids (fm-parent self))) self) - nil + c-null (id (first (kids (fm-parent self)))))))) :on-toggled (callback (widget event data) - (let ((state (gtk-toggle-button-get-active widget))) - (setf (md-value self) state)))) + (let ((state (gtk-toggle-button-get-active widget))) + (setf (md-value self) state)))) (def-c-output .md-value ((self radio-button)) (when (and new-value (upper self box)) - (setf (md-value (upper self box)) (md-name self))) - (call-next-method)) + (setf (md-value (upper self box)) (md-name self)))) Index: root/cells-gtk/callback.lisp diff -u root/cells-gtk/callback.lisp:1.1 root/cells-gtk/callback.lisp:1.2 --- root/cells-gtk/callback.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/callback.lisp Sun Dec 5 07:33:22 2004 @@ -4,7 +4,7 @@ (let ((id (intern (string-upcase (format nil "~a.~a" (id self) callback-id))))) (trc "registering callback" self :id id) - (setf (gethash id (callbacks .gtk-app)) (cons fun self)) + (setf (gethash id (callbacks (nearest self gtk-app))) (cons fun self)) id)) (defun dispatch-callback (gtk-app callback) Index: root/cells-gtk/cells-gtk.lisp diff -u root/cells-gtk/cells-gtk.lisp:1.1 root/cells-gtk/cells-gtk.lisp:1.2 --- root/cells-gtk/cells-gtk.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/cells-gtk.lisp Sun Dec 5 07:33:22 2004 @@ -18,8 +18,26 @@ (defpackage :cells-gtk (:nicknames :cgtk) - (:use :common-lisp :utils-kt :cells :gtk-ffi :ffi)) + (:use :common-lisp :utils-kt :cells :gtk-ffi + #+clisp :ffi #-clisp :uffi #-clisp #:ffx)) (in-package :cgtk) -(defvar *gtk-debug* nil) + +(defun gtk-tree-store-set-kids (model val-tree par-iter index column-types items-factory &optional path) + (with-foreign-object (iter 'gtk-tree-iter) + (setf (get-slot-value iter 'gtk-tree-iter 'stamp) 0) + (setf (get-slot-value iter 'gtk-tree-iter 'user-data) 0) + (setf (get-slot-value iter 'gtk-tree-iter 'user-data2) 0) + (setf (get-slot-value iter 'gtk-tree-iter 'user-data3) 0) + (gtk-ffi::gtk-tree-store-append model iter par-iter) + (gtk-ffi::gtk-tree-store-set model iter + column-types + (append + (funcall items-factory val-tree) + (list (format nil "(~{~d ~})" (reverse (cons index path)))))) + (when (subtypep (class-name (class-of val-tree)) 'cells:family) + (loop for sub-tree in (cells:kids val-tree) + for pos from 0 do + (gtk-tree-store-set-kids model sub-tree iter + pos column-types items-factory (cons index path)))))) \ No newline at end of file Index: root/cells-gtk/dialogs.lisp diff -u root/cells-gtk/dialogs.lisp:1.1 root/cells-gtk/dialogs.lisp:1.2 --- root/cells-gtk/dialogs.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/dialogs.lisp Sun Dec 5 07:33:22 2004 @@ -27,7 +27,7 @@ (markup) () :position :mouse - :new-args (c? (list nil + :new-args (c? (list c-null 2 (ecase (message-type self) (:info 0) @@ -74,24 +74,24 @@ (gtk-file-filter-add-pattern (id self) pattern))) (def-object file-chooser () - ((action :accessor action :initarg :action :initform nil) - (action-id :accessor action-id - :initform (c? (ecase (action self) - (:open 0) - (:save 1) - (:select-folder 2) - (:create-folder 3)))) - (filters :accessor filters :initarg :filters :initform nil) - (filters-ids :accessor filters-ids - :initform (c? (loop for filter in (filters self) collect - (id (make-be 'file-filter :name (first filter) :patterns (rest filter))))))) - (local-only select-multiple current-name filename + ((action :accessor action :initarg :action :initform nil) + (action-id :accessor action-id + :initform (c? (ecase (action self) + (:open 0) + (:save 1) + (:select-folder 2) + (:create-folder 3)))) + (filters :accessor filters :initarg :filters :initform nil) + (filters-ids :accessor filters-ids + :initform (c? (loop for filter in (filters self) collect + (id (make-be 'file-filter :name (first filter) :patterns (rest filter))))))) + (local-only select-multiple current-name filename current-folder uri current-folder-uri use-preview-label filter) - (selection-changed) - :on-selection-changed (callback (widget signal data) - (if (select-multiple self) - (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self))) - (setf (md-value self) (gtk-file-chooser-get-filename (id self)))))) + (selection-changed) + :on-selection-changed (callback (widget signal data) + (if (select-multiple self) + (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self))) + (setf (md-value self) (gtk-file-chooser-get-filename (id self)))))) (def-c-output filters-ids ((self file-chooser)) (dolist (filter-id new-value) @@ -113,7 +113,7 @@ () :on-selection-changed nil :position :mouse - :new-args (c? (list (title self) nil (action-id self) + :new-args (c? (list (title self) c-null (action-id self) "gtk-cancel" -6 ;;response-cancel (format nil "gtk-~a" (string-downcase @@ -138,4 +138,5 @@ (let ((dialog (to-be (apply #'mk-file-chooser-dialog inits)))) (md-value dialog))) -(export '(show-message file-chooser)) \ No newline at end of file +(eval-when (compile load eval) + (export '(show-message file-chooser))) \ No newline at end of file Index: root/cells-gtk/display.lisp diff -u root/cells-gtk/display.lisp:1.1 root/cells-gtk/display.lisp:1.2 --- root/cells-gtk/display.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/display.lisp Sun Dec 5 07:33:22 2004 @@ -60,20 +60,17 @@ (def-c-output text ((self label)) (when new-value - (with-gtk-string (str new-value) - (gtk-label-set-text-with-mnemonic (id self) str)))) + (gtk-label-set-text-with-mnemonic (id self) new-value))) (def-c-output markup ((self label)) (when new-value - (with-gtk-string (str new-value) - (gtk-label-set-markup-with-mnemonic (id self) str)))) + (gtk-label-set-markup-with-mnemonic (id self) new-value))) (def-widget accel-label () ((text :accessor text :initarg :text :initform nil)) () () - :id (c? (with-gtk-string (str (text self)) - (gtk-accel-label-new str)))) + :id (c? (gtk-accel-label-new (text self)))) (def-widget image () ((filename :accessor filename :initarg :filename :initform nil) @@ -110,14 +107,13 @@ :has-resize-grip t) (defmethod new-context ((self statusbar) context) - (let ((cid (gtk-statusbar-get-context-id (id self) (format nil "~a" context)))) - (setf (gethash context (contexts self)) cid))) + (setf (gethash context (contexts self)) + (gtk-statusbar-get-context-id (id self) (format nil "~a" context)))) (defmethod push-message ((self statusbar) message &optional (context 'main)) (let ((id (gethash context (contexts self)))) (when id - (with-gtk-string (str message) - (gtk-statusbar-push (id self) id str))))) + (gtk-statusbar-push (id self) id message)))) (defmethod pop-message ((self statusbar) &optional (context 'main)) (let ((id (gethash context (contexts self)))) @@ -156,4 +152,5 @@ (:bottom 3) (t 0))))) -(export '(with-markup push-message pop-message pulse)) \ No newline at end of file +(eval-when (compile load eval) + (export '(with-markup push-message pop-message pulse))) \ No newline at end of file Index: root/cells-gtk/entry.lisp diff -u root/cells-gtk/entry.lisp:1.1 root/cells-gtk/entry.lisp:1.2 --- root/cells-gtk/entry.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/entry.lisp Sun Dec 5 07:33:22 2004 @@ -29,34 +29,37 @@ (text :accessor text :initarg :text :initform (c-in nil)) (init :accessor init :initarg :init :initform nil)) (editable has-frame max-length) - (changed activate) - :on-changed (callback-if (auto-update self) - (widget event data) - (let ((txt (get-gtk-string (gtk-entry-get-text widget)))) - (trc nil "ENTRY (ON-CHANGED)" txt) (force-output) - (setf (md-value self) txt))) - :on-activate (callback-if (not (auto-update self)) - (widget event data) - (let ((txt (get-gtk-string (gtk-entry-get-text widget)))) - (trc nil "ENTRY (ON-ACTIVATE)" txt) (force-output) - (setf (md-value self) (if (equal txt "") nil txt))))) + (changed activate)) +;;; :on-changed (callback-if (auto-update self) +;;; (widget event data) +;;; (let ((txt (get-gtk-string (gtk-entry-get-text widget)))) +;;; (trc nil "ENTRY (ON-CHANGED)" txt) (force-output) +;;; (setf (md-value self) txt))) +;;; :on-activate (callback-if (not (auto-update self)) +;;; (widget event data) +;;; (let ((txt (get-gtk-string (gtk-entry-get-text widget)))) +;;; (trc nil "ENTRY (ON-ACTIVATE)" txt) (force-output) +;;; (setf (md-value self) (if (equal txt "") nil txt))))) (def-c-output text ((self entry)) (when new-value - (with-gtk-string (str new-value) - (gtk-entry-set-text (id self) str)))) + (gtk-entry-set-text (id self) new-value))) (def-c-output init ((self entry)) - (setf (text self) (or new-value "")) - (setf (md-value self) (or new-value ""))) + (when (stringp new-value) ;; could be null or numeric for spin button + (setf (text self) new-value) + (setf (md-value self) new-value))) (def-c-output completion ((self entry)) (when new-value - (let ((store (make-instance 'list-store :item-types (list :string)))) + (gvi :pre-mk-store) + (let ((store (make-be 'list-store :item-types (list :string)))) + (gvi :post-mk-store) (gtk-list-store-set-items (id store) (list :string) (mapcar #'list new-value)) + (gvi :post-set-items) (let ((completion (make-be 'entry-completion :model (id store)))) - (gtk-entry-completion-set-text-column (id completion) 0) - (gtk-entry-set-completion (id self) (id completion)))))) + (gtk-entry-completion-set-text-column (id completion) 0) + (gtk-entry-set-completion (id self) (id completion)))))) ;; (def-widget adjustment () ;; () () ()) Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.1 root/cells-gtk/gtk-app.lisp:1.2 --- root/cells-gtk/gtk-app.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/gtk-app.lisp Sun Dec 5 07:33:22 2004 @@ -20,18 +20,19 @@ (defmodel gtk-app (window) ((splash-screen-image :accessor splash-screen-image :initarg :splash-screen-image :initform nil) - (tooltips :accessor tooltips :initform (make-be 'tooltips)) + (tooltips :initarg :tooltips :accessor tooltips :initform (make-be 'tooltips)) (tooltips-enable :accessor tooltips-enable :initarg :tooltips-enable :initform (c-in t)) (tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil))) (:default-initargs - :on-delete-event (lambda (widget event data) - (declare (ignore widget event data)) + :on-delete-event (lambda (self widget event data) + (declare (ignore self widget event data)) (gtk-main-quit)))) (def-c-output tooltips-enable ((self gtk-app)) - (if new-value - (gtk-tooltips-enable (id (tooltips self))) - (gtk-tooltips-disable (id (tooltips self))))) + (when (tooltips self) + (if new-value + (gtk-tooltips-enable (id (tooltips self))) + (gtk-tooltips-disable (id (tooltips self)))))) (def-c-output tooltips-delay ((self gtk-app)) (when new-value @@ -52,35 +53,62 @@ (let ((*gtk-debug* debug)) (when (not *gtk-initialized*) (when *gtk-debug* - (trc "GTK INITIALIZATION") (force-output)) - (g-thread-init nil) + (trc "GTK INITIALIZATION") (force-output)) + (g-thread-init c-null) (gdk-threads-init) - (assert (gtk-init-check nil nil)) + (assert (gtk-init-check c-null c-null)) (setf *gtk-initialized* t)) - + (with-gdk-threads - (let ((app (make-instance app-name :visible (c-in nil))) - (splash)) - (when (splash-screen-image app) - (setf splash (make-instance 'splash-screen :image-path (splash-screen-image app) - :visible (c-in nil))) - (gtk-window-set-auto-startup-notification nil) - (to-be splash) - (setf (visible splash) t) - (loop while (gtk-events-pending) do - (gtk-main-iteration))) - - (to-be app) - - (when splash - (not-to-be splash) - (gtk-window-set-auto-startup-notification t)) - - (setf (visible app) t) - - (when *gtk-debug* - (trc "STARTING GTK-MAIN") (force-output)) - (gtk-main))))) - -(export '(gtk-app title icon tooltips tooltips-enable tooltips-delay - start-app)) \ No newline at end of file + ;(gvi :withread) + (let ((app (make-instance app-name :visible (c-in nil))) + (splash)) + (when (splash-screen-image app) + (setf splash (make-instance 'splash-screen :image-path (splash-screen-image app) + :visible (c-in nil))) + (gtk-window-set-auto-startup-notification nil) + (to-be splash) + (setf (visible splash) t) + (loop while (gtk-events-pending) do + (gtk-main-iteration))) + (gvi :splashup) + (to-be app) + (gvi :appup) + (when splash + (not-to-be splash) + (gvi :splashdown) + (gtk-window-set-auto-startup-notification t)) + (setf (visible app) t) + + (when *gtk-debug* + (trc "STARTING GTK-MAIN") (force-output)) + (gtk-main))))) + +(defvar *gtk-global-callbacks* nil) +(defvar *gtk-loaded* nil) + +(defun gtk-reset () + (cell-reset) + (gtk-objects-init) + (setf *gtk-global-callbacks* + (make-array 128 :adjustable t :fill-pointer 0))) + +(defun gtk-global-callback-register (callback) + (vector-push-extend callback + *gtk-global-callbacks* 16)) + +(defun gtk-global-callback-funcall (n) + (funcall (aref *gtk-global-callbacks* n))) + +(defun cells-gtk-init () + (gtk-reset) + (unless *gtk-loaded* + (loop for lib in '(:gthread :glib :gobject :gdk :gtk) + do (assert (uffi:load-foreign-library (gtk-ffi::libname lib) + :force-load #+lispworks t #-lispworks nil + :module (string lib))) + finally (setf *gtk-loaded* t)))) + +(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))) \ No newline at end of file Index: root/cells-gtk/layout.lisp diff -u root/cells-gtk/layout.lisp:1.1 root/cells-gtk/layout.lisp:1.2 --- root/cells-gtk/layout.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/layout.lisp Sun Dec 5 07:33:22 2004 @@ -30,8 +30,7 @@ (when new-value (dolist (kid new-value) (gtk-box-pack-start (id self) (id kid) - (expand? kid) (fill? kid) (padding? kid))) - (call-next-method))) + (expand? kid) (fill? kid) (padding? kid))))) (def-widget hbox (box) () () () @@ -84,8 +83,7 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value))))))) - (call-next-method)) + :kids (list (cadr new-value)))))))) (def-widget vpaned () () () ()) @@ -98,8 +96,7 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value))))))) - (call-next-method)) + :kids (list (cadr new-value)))))))) (def-widget frame () @@ -112,8 +109,7 @@ (def-c-output label ((self frame)) (when new-value - (with-gtk-string (str new-value) - (gtk-frame-set-label (id self) str)))) + (gtk-frame-set-label (id self) new-value))) (def-c-output shadow ((self frame)) (when new-value @@ -128,8 +124,7 @@ (def-c-output .kids ((self frame)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid))) - (call-next-method)) + (gtk-container-add (id self) (id kid)))) (def-widget aspect-frame (frame) ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -158,14 +153,12 @@ (def-c-output label ((self expander)) (when new-value - (with-gtk-string (str new-value) - (gtk-expander-set-label (id self) str)))) + (gtk-expander-set-label (id self) new-value))) (def-c-output .kids ((self expander)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid))) - (call-next-method)) + (gtk-container-add (id self) (id kid)))) (def-widget scrolled-window () () @@ -173,15 +166,14 @@ () :expand t :fill t :policy (list 1 1) - :new-args (list nil nil)) + :new-args (list c-null c-null)) (def-c-output .kids ((self scrolled-window)) (assert-bin self) (dolist (kid new-value) (if (member (class-name (class-of kid)) '(listbox treebox tree-view text-view layout) :test #'equal) (gtk-container-add (id self) (id kid)) - (gtk-scrolled-window-add-with-viewport (id self) (id kid)))) - (call-next-method)) + (gtk-scrolled-window-add-with-viewport (id self) (id kid))))) (def-widget notebook () ((tab-labels :accessor tab-labels :initarg :tab-labels :initform nil) @@ -221,8 +213,7 @@ (loop for page from 0 to (length new-value) do (setf (current-page self) page)) (when (and (show-page self) (>= (show-page self) 0) (< (show-page self) (length new-value))) - (setf (current-page self) (show-page self))) - (call-next-method)) + (setf (current-page self) (show-page self)))) (def-widget alignment () ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -273,5 +264,4 @@ (def-c-output .kids ((self alignment)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid))) - (call-next-method)) + (gtk-container-add (id self) (id kid)))) Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.1 root/cells-gtk/menus.lisp:1.2 --- root/cells-gtk/menus.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/menus.lisp Sun Dec 5 07:33:22 2004 @@ -26,9 +26,9 @@ (changed) :new-tail '-text :on-changed (callback (widget event data) - (let ((pos (gtk-combo-box-get-active (id self)))) - (setf (md-value self) (and (not (= pos -1)) - (nth pos (items self))))))) + (let ((pos (gtk-combo-box-get-active (id self)))) + (setf (md-value self) (and (not (= pos -1)) + (nth pos (items self))))))) (def-c-output items ((self combo-box)) (when old-value @@ -36,8 +36,7 @@ (gtk-combo-box-remove-text (id self) 0))) (when new-value (dolist (item (items self)) - (with-gtk-string (str (funcall (items-factory self) item)) - (gtk-combo-box-append-text (id self) str))) + (gtk-combo-box-append-text (id self) (funcall (items-factory self) item))) (when (init self) (let ((index (position (init self) (items self)))) (when index @@ -58,8 +57,7 @@ (when new-value (loop for item in new-value for pos from 0 do - (gtk-toolbar-insert (id self) (id item) pos))) - (call-next-method)) + (gtk-toolbar-insert (id self) (id item) pos)))) (def-c-output orientation ((self toolbar)) (when new-value @@ -88,8 +86,7 @@ (assert-bin self) (when new-value (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) - (call-next-method)) + (gtk-container-add (id self) (id kid))))) (def-widget separator-tool-item (tool-item) () @@ -103,7 +100,7 @@ (label-widget :accessor label-widget :initarg :label-widget :initform (c-in nil))) (use-underline stock-id) (clicked) - :new-args (list nil nil)) + :new-args (list c-null c-null)) (def-c-output icon-widget ((self tool-button)) (when old-value @@ -119,8 +116,7 @@ (def-c-output label ((self tool-button)) (when new-value - (with-gtk-string (str new-value) - (gtk-tool-button-set-label (id self) str)))) + (gtk-tool-button-set-label (id self) new-value))) (def-c-output stock ((self tool-button)) (when new-value @@ -133,8 +129,7 @@ (def-c-output .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid)))) - (call-next-method)) + (gtk-menu-shell-append (id self) (id kid))))) (def-widget menu-bar (menu-shell) () () ()) @@ -196,8 +191,8 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) - (let ((state (gtk-check-menu-item-get-active widget))) - (setf (md-value self) state)))) + (let ((state (gtk-check-menu-item-get-active widget))) + (setf (md-value self) state)))) (def-c-output init ((self check-menu-item)) (setf (active self) new-value) @@ -214,12 +209,11 @@ (not-first-p (not (eql (first (kids (fm-parent self))) self)))) (if (and in-group-p not-first-p) (list (id (first (kids (fm-parent self))))) - (list nil))))) + (list c-null))))) (def-c-output .md-value ((self radio-menu-item)) (when (and new-value (upper self menu-item)) - (setf (md-value (upper self menu-item)) (md-name self))) - (call-next-method)) + (setf (md-value (upper self menu-item)) (md-name self)))) (def-widget image-menu-item (menu-item) ((stock :accessor stock :initarg :stock :initform nil) Index: root/cells-gtk/textview.lisp diff -u root/cells-gtk/textview.lisp:1.1 root/cells-gtk/textview.lisp:1.2 --- root/cells-gtk/textview.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/textview.lisp Sun Dec 5 07:33:23 2004 @@ -22,13 +22,12 @@ ((text :accessor text :initarg :text :initform nil)) () () - :new-args (c? (list nil))) + :new-args (c? (list c-null))) (def-c-output text ((self text-buffer)) - (with-gtk-string (txt (or new-value "")) - (gtk-text-buffer-set-text (id self) - txt - -1))) + (gtk-text-buffer-set-text (id self) + (or new-value "") + -1)) (def-widget text-view () ((buffer :accessor buffer :initarg :buffer :initform (mk-text-buffer))) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.1 root/cells-gtk/tree-view.lisp:1.2 --- root/cells-gtk/tree-view.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/tree-view.lisp Sun Dec 5 07:33:23 2004 @@ -37,16 +37,18 @@ (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)))))) + :initform (c? (loop for col-def in (columns-def self) + for pos from 0 append + (when (third col-def) + (list pos (third col-def)))))) (columns :accessor columns - :initform (c? (mapcar #'(lambda (col-init) - (apply #'make-be 'tree-view-column col-init)) - (column-inits self)))) + :initform (c? (mapcar #'(lambda (col-init) + (apply #'make-be 'tree-view-column + :container self + col-init)) + (column-inits self)))) (select-if :unchanged-if #'fail - :accessor select-if :initarg :select-if :initform (c-in nil)) + :accessor select-if :initarg :select-if :initform (c-in nil)) (items :accessor items :initarg :items :initform nil) (items-factory :accessor items-factory :initarg :items-factory :initform #'identity) (selection-mode :accessor selection-mode :initarg :selection-mode :initform :single) @@ -54,8 +56,9 @@ (tree-model :accessor tree-model :initarg :tree-model :initform nil)) () () - :on-select (callback (widget event data) - (setf (md-value self) (get-selection self)))) + :on-select (lambda (self widget event data) + (declare (ignore widget event data)) + (setf (md-value self) (get-selection self)))) (def-c-output tree-model ((self tree-view)) (when new-value @@ -75,16 +78,17 @@ (let ((selection (gtk-tree-view-get-selection (id self)))) (let (sel) (gtk-tree-selection-selected-foreach selection - #'(lambda (model path iter data) - (push (item-from-path - (items self) - (read-from-string - (gtk-tree-model-get-cell model iter (length (column-types self)) :string))) - sel)) - nil) + #'(lambda (model path iter data) + (declare (ignore data path)) + (push (item-from-path + (items self) + (read-from-string + (gtk-tree-model-get-cell model iter (length (column-types self)) :string))) + sel)) + nil) (if (equal (gtk-tree-selection-get-mode selection) 3) ;;multiple - sel - (first sel))))) + sel + (first sel))))) (def-c-output selection-mode ((self tree-view)) (when new-value @@ -96,10 +100,25 @@ (:browse 2) (:multiple 3)))))) +(ff-defun-callable :cdecl :int tree-view-select-handler + ((column-widget (* :void)) (event (* :void)) (data (* :void))) + (let ((tree-view (gtk-object-find column-widget))) + (let ((cb (callback-recover tree-view :on-select))) + (funcall cb tree-view column-widget event data)))) + (def-c-output on-select ((self tree-view)) (when new-value - (let ((sel (gtk-tree-view-get-selection (id self)))) - (gtk-signal-connect sel "changed" (on-select self))))) + (trc "output on-select" self new-value) + (let* ((selected-widget (gtk-tree-view-get-selection (id self))) + (selected-clos (gtk-object-find selected-widget nil))) + (unless selected-clos + (trc "whoa!!! no clos for selected" self selected-widget)) + (when selected-clos + (assert (eql self selected-clos)) + (gtk-object-store selected-widget self) ;; tie column widg to clos tree-view + (callback-register self :on-select new-value) + (gtk-signal-connect selected-widget "changed" + (ff-register-callable 'tree-view-select-handler)))))) (defmodel listbox (tree-view) () @@ -139,7 +158,7 @@ (def-c-output select-if ((self treebox)) (when new-value (setf (md-value self) (mapcan (lambda (item) (fm-collect-if item new-value)) - (items self))))) + (items self))))) (def-c-output items ((self treebox)) (when old-value @@ -147,27 +166,38 @@ (when new-value (loop for sub-tree in new-value for index from 0 do - (gtk-tree-store-set-kids (id (tree-model self)) sub-tree nil index + (gtk-tree-store-set-kids (id (tree-model self)) sub-tree c-null index (append (column-types self) (list :string)) (items-factory self))))) +(ff-defun-callable :cdecl :int tree-view-render-call-callback + ((tree-column (* :void)) (cell-renderer (* :void)) + (tree-model (* :void)) (iter (* :void)) (data (* :void))) + (let ((self (gtk-object-find tree-column))) + (assert self) + (let ((cb (callback-recover self :render-cell))) + (assert cb () "No :render-cell callback for ~a" self) + (funcall cb tree-column cell-renderer tree-model iter data)))) + (def-c-output columns ((self tree-view)) (when new-value (loop for col in new-value - for pos from 0 - for renderer = (case (nth pos (column-types self)) - (:boolean (gtk-cell-renderer-toggle-new)) - (:icon (gtk-cell-renderer-pixbuf-new)) - (t (gtk-cell-renderer-text-new))) do - (gtk-tree-view-column-pack-start (id col) renderer t) - (gtk-tree-view-column-set-cell-data-func (id col) renderer - (gtk-tree-view-render-cell pos - (nth pos (column-types self)) - (getf (column-render self) pos)) - nil - nil) - (gtk-tree-view-column-set-sort-column-id (id col) pos) - (gtk-tree-view-insert-column (id self) (id col) pos)))) + for pos from 0 + for renderer = (case (nth pos (column-types self)) + (:boolean (gtk-cell-renderer-toggle-new)) + (:icon (gtk-cell-renderer-pixbuf-new)) + (t (gtk-cell-renderer-text-new))) do + (gtk-tree-view-column-pack-start (id col) renderer t) + (gtk-tree-view-column-set-cell-data-func (id col) renderer + (progn + (callback-register col :render-cell + (gtk-tree-view-render-cell pos + (nth pos (column-types self)) + (getf (column-render self) pos))) + (ff-register-callable 'tree-view-render-call-callback)) + nil nil) + (gtk-tree-view-column-set-sort-column-id (id col) pos) + (gtk-tree-view-insert-column (id self) (id col) pos)))) (def-object tree-view-column () ((title :accessor title :initarg :title :initform nil) @@ -184,11 +214,11 @@ (def-c-output title ((self tree-view-column)) (when new-value - (with-gtk-string (str new-value) - (gtk-tree-view-column-set-title (id self) str)))) + (gtk-tree-view-column-set-title (id self) new-value))) (defmacro def-columns (&rest args) `(list ,@(loop for (type inits renderer) in args collect `(list ,type ',inits ,renderer)))) -(export '(mk-listbox mk-treebox def-columns)) \ No newline at end of file +(eval-when (compile load eval) + (export '(mk-listbox mk-treebox def-columns))) \ No newline at end of file Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.1 root/cells-gtk/widgets.lisp:1.2 --- root/cells-gtk/widgets.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/widgets.lisp Sun Dec 5 07:33:23 2004 @@ -18,23 +18,84 @@ (in-package :cgtk) + (defmodel gtk-object (family) - ((def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil) + ((container :cell nil :initarg :container :accessor container) + (def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil) (new-function-name :accessor new-function-name :initarg :new-function-name - :initform (c? (intern (format nil "GTK-~a-NEW~a" - (def-gtk-class-name self) - (or (new-tail self) "")) - :gtk-ffi))) + :initform (c? (intern (format nil "GTK-~a-NEW~a" + (def-gtk-class-name self) + (or (new-tail self) "")) + :gtk-ffi))) (new-args :accessor new-args :initarg :new-args :initform nil) (new-tail :accessor new-tail :initarg :new-tail :initform nil) (id :initarg :id :accessor id - :initform (c? (without-c-dependency - (when *gtk-debug* - (trc "NEW" (new-function-name self) (new-args self)) (force-output)) - (apply (symbol-function (new-function-name self)) (new-args self)))))) + :initform (c? (without-c-dependency + (when *gtk-debug* + (trc "NEW ID" (new-function-name self) (new-args self)) (force-output)) + (let ((id (apply (symbol-function (new-function-name self)) + (new-args self)))) + (gtk-object-store id self) + id)))) + + (callbacks :cell nil :accessor callbacks + :initform nil + :documentation "assoc of event-name, callback closures to handle widget events")) (:default-initargs - :md-name (c-in nil) - :md-value (c-in nil))) + :md-name nil ;; kwt: was (c-in nil), but this is not a cell + :md-value (c-in nil))) + +;; --------- provide id-to-clos lookup ------ + +(defvar *gtk-objects* nil) + +(defun gtk-objects-init () + (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100))) + +(defun gtk-object-store (id gtk-object) + (unless *gtk-objects* + (gtk-objects-init)) + (let ((known (gethash id *gtk-objects*))) + (cond + ((not known) + (setf (gethash id *gtk-objects*) gtk-object)) + ((eql known gtk-object)) + (t + (break "gtk-object-store id ~a already known as ~a, not ~a" + id known gtk-object))))) + +(defun gtk-object-forget (id gtk-object) + (assert *gtk-objects*) + (let ((known (gethash id *gtk-objects*))) + (cond + ((not known)) + ((eql known gtk-object) + (setf (gethash id *gtk-objects*) nil)) + (t + (break "gtk-object-store id ~a known as ~a, not forgettable ~a" + id known gtk-object))))) + +#+shhh +(maphash (lambda (k v) (print (list k v))) *gtk-objects*) + +(defun gtk-object-find (id &optional must-find-p) + (when *gtk-objects* + (let ((clos-widget (gethash id *gtk-objects*))) + (when must-find-p + (assert clos-widget)) + clos-widget))) + +;; ----- fake callbackable closures ------------ + +(defun callback-register (self callback-key closure) + (let ((x (assoc callback-key (callbacks self)))) + (if x (rplacd x closure) + (push (cons callback-key closure) (callbacks self))))) + +(defun callback-recover (self callback-key) + (cdr (assoc callback-key (callbacks self)))) + +; ------------------------------------------ (defmethod configure ((self gtk-object) gtk-function value) (apply gtk-function (id self) (if (consp value) value (list value)))) @@ -49,79 +110,124 @@ ;;; --- widget -------------------- -(eval-when (:compile-toplevel :load-toplevel :execute) +(defmacro def-gtk-event-handler (event) + `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) + ((widget (* :void)) (event (* :void)) (data (* :void))) + (let ((self (gtk-object-find widget))) + (assert self) + (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) + (funcall cb self widget event data))))) + +(def-gtk-event-handler clicked) +(def-gtk-event-handler toggled) +(def-gtk-event-handler delete-event) + +(defparameter *widget-callbacks* + (list (cons 'clicked (ff-register-callable 'clicked-handler)) + (cons 'toggled (ff-register-callable 'toggled-handler)) + (cons 'delete-event (ff-register-callable 'delete-event-handler)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-object (&rest args) `(def-gtk gtk-object ,@args)) (defmacro def-widget (&rest args) `(def-gtk widget ,@args)) (defmacro def-gtk (gtk-superclass class - superclasses - (&rest std-slots) - (&rest gtk-slots) (&rest gtk-signals) &rest defclass-options) - (multiple-value-bind (slots outputs) - (loop for gtk-option-def in gtk-slots - for slot-name = (if (atom gtk-option-def) - gtk-option-def (car gtk-option-def)) - collecting `(,slot-name :initform (c-in nil) - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name) - into slot-defs - collecting `(def-c-output ,slot-name ((self ,class)) - (when (or new-value old-value) - (when *gtk-debug* (TRC ,(format nil "~a-~a" class slot-name) new-value) (force-output)) - (configure self #',(gtk-function-name class gtk-option-def) - new-value)) - (call-next-method)) - - into outputs - finally (return (values slot-defs outputs))) - (multiple-value-bind (signals-slots signals-outputs) - (loop for signal-slot in gtk-signals + superclasses + (&rest std-slots) + (&rest gtk-slots) (&rest gtk-signals) &rest defclass-options) + (multiple-value-bind (slots outputs) + (loop for gtk-option-def in gtk-slots + for slot-name = (if (atom gtk-option-def) + gtk-option-def (car gtk-option-def)) + collecting `(,slot-name :initform (c-in nil) + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) + into slot-defs + collecting `(def-c-output ,slot-name ((self ,class)) + (when (or new-value old-value) + #+shhh (when *gtk-debug* + (TRC ,(format nil "output before ~a-~a" class slot-name) new-value) (force-output)) + (configure self #',(gtk-function-name class gtk-option-def) + new-value) + #+shhh (when *gtk-debug* + (TRC ,(format nil "output after ~a-~a" class slot-name) new-value) (force-output)))) + + into outputs + finally (return (values slot-defs outputs))) + (multiple-value-bind (signals-slots signals-outputs) + (loop for signal-slot in gtk-signals for slot-name = (intern (format nil "ON-~a" signal-slot)) collecting `(,slot-name :initform nil - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name) + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name) into signals-slots-defs collecting `(def-c-output ,slot-name ((self ,class)) (when new-value - (gtk-signal-connect (id self) ,(string-downcase (string signal-slot)) new-value)) - (call-next-method)) + #+clisp (gtk-signal-connect (id self) + ,(string-downcase (string signal-slot)) + new-value) + #-clisp + (progn (callback-register self + ,(intern (string signal-slot) :keyword) + new-value) + (gtk-signal-connect (id self) + ,(string-downcase (string signal-slot)) + (cdr (assoc ',signal-slot *widget-callbacks*)))))) into signals-outputs-defs finally (return (values signals-slots-defs signals-outputs-defs))) `(progn - (defmodel ,class ,(or superclasses (list gtk-superclass)) - (,@(append std-slots slots signals-slots)) - (:default-initargs - :def-gtk-class-name ',class - ,@defclass-options)) - (export ',class) - (export ',(mapcar #'first (append std-slots slots signals-slots))) - - (defun ,(intern (format nil "MK-~a" class)) (&rest inits) - (when *gtk-debug* (trc "MAKE-INSTANCE" ',class) (force-output)) - (apply 'make-instance ',class inits)) - (export ',(intern (format nil "MK-~a" class))) - ,@outputs - ,@signals-outputs))))) + (defmodel ,class ,(or superclasses (list gtk-superclass)) + (,@(append std-slots slots signals-slots)) + (:default-initargs + :def-gtk-class-name ',class + ,@defclass-options)) + (eval-when (compile load eval) + (export ',class)) + (eval-when (compile load eval) + (export ',(mapcar #'first (append std-slots slots signals-slots)))) + + (defun ,(intern (format nil "MK-~a" class)) (&rest inits) + (when *gtk-debug* (trc "MAKE-INSTANCE" ',class) (force-output)) + (apply 'make-instance ',class inits)) + (eval-when (compile load eval) + (export ',(intern (format nil "MK-~a" class)))) + ,@outputs + ,@signals-outputs))))) (defmacro callback ((widg event data) &body body) + #+clisp `(c? (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - ,@body t)))) + (declare (ignorable ,widg ,event ,data)) + ,@body t))) + #-clisp + `(lambda (self ,widg ,event ,data) + (declare (ignorable self ,widg ,event ,data)) + ,@body t)) + (defmacro callback-if (condition (widg event data) &body body) `(c? (and ,condition - (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - ,@body t))))) + #+clisp (without-c-dependency #'(lambda (,widg ,event ,data) + (declare (ignorable ,widg ,event ,data)) + ,@body t)) + #-clisp (lambda (self ,widg ,event ,data) + (declare (ignorable self ,widg ,event ,data)) + ,@body t)))) + +(ff-defun-callable :cdecl :int timeout-handler-callback + ((data (* :void))) + (let ((id (elti data 0))) + (gtk-global-callback-funcall id))) (defun timeout-add (milliseconds function) - (g-timeout-add milliseconds - #'(lambda (x) - (declare (ignore x)) + (let ((id (gtk-global-callback-register + (lambda () (with-gdk-threads - (funcall function))) - nil)) + (funcall function))))) + (c-id (fgn-alloc :int 1))) + (setf (elti c-id 0) id) + (g-timeout-add milliseconds (ff-register-callable 'timeout-handler-callback) c-id))) (def-object widget () ((tooltip :accessor tooltip :initarg :tooltip :initform (c-in nil)) @@ -175,14 +281,12 @@ (def-c-output tooltip ((self widget)) (when new-value - (with-gtk-string (str new-value) - (gtk-tooltips-set-tip (id (tooltips (upper self gtk-app))) - (id self) - str - "")))) + (gtk-tooltips-set-tip (id (tooltips (upper self gtk-app))) + (id self) new-value ""))) (defmethod not-to-be :after ((self widget)) (when *gtk-debug* (trc "WIDGET DESTROY" (md-name self)) (force-output)) + (gtk-object-forget (id self) self) (gtk-widget-destroy (id self))) (defun assert-bin (container) @@ -192,7 +296,8 @@ (def-widget window () ((wintype :accessor wintype :initarg wintype :initform 0) - (title :accessor title :initarg :title :initform (c? (string (class-name (class-of self))))) + (title :accessor title :initarg :title + :initform (c? (string (class-name (class-of self))))) (icon :initarg :icon :accessor icon :initform nil) (decorated :accessor decorated :initarg :decorated :initform (c-in t)) (position :accessor set-position :initarg :position :initform (c-in nil)) @@ -221,12 +326,11 @@ (def-c-output title ((self window)) (when new-value - (with-gtk-string (str new-value) - (gtk-window-set-title (id self) str)))) + (gtk-window-set-title (id self) new-value))) (def-c-output icon ((self window)) (when new-value - (gtk-window-set-icon-from-file (id self) new-value nil))) + (gtk-window-set-icon-from-file (id self) new-value c-null))) (def-c-output decorated ((self window)) (gtk-window-set-decorated (id self) new-value)) @@ -245,8 +349,7 @@ (assert-bin self) (dolist (kid new-value) (when *gtk-debug* (trc "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) - (gtk-container-add (id self) (id kid))) - (call-next-method)) + (gtk-container-add (id self) (id kid)))) (def-widget event-box () ((visible-window :accessor visible-window :initarg :visible-window :initform nil)) @@ -260,8 +363,7 @@ (def-c-output .kids ((self event-box)) (assert-bin self) (when new-value - (gtk-container-add (id self) (id (first new-value)))) - (call-next-method)) - + (gtk-container-add (id self) (id (first new-value))))) -(export '(callback callback-if timeout-add focus)) +(eval-when (compile load eval) + (export '(callback callback-if timeout-add focus)))

1 0

[cells-gtk-cvs] CVS update: root/asdf.lisp root/load.lisp
by ktilton＠common-lisp.net 05 Dec '04

05 Dec '04

Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv13216 Modified Files: asdf.lisp load.lisp Log Message: Port to AllegroCl and Lispworks on win32 using UFFI Date: Sun Dec 5 07:33:21 2004 Author: ktilton Index: root/asdf.lisp diff -u root/asdf.lisp:1.1 root/asdf.lisp:1.2 --- root/asdf.lisp:1.1 Fri Nov 19 00:39:51 2004 +++ root/asdf.lisp Sun Dec 5 07:33:21 2004 @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.2 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; <cclan-list(a)lists.sf.net>. But note first that the canonical @@ -107,7 +107,7 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.2 $") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -794,6 +794,17 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations + +(defun opxx (operation-class system &rest args) + (let* ((op (apply #'make-instance operation-class + :original-initargs args args)) + (*verbose-out* + (if (getf args :verbose t) + *trace-output* + (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system))) + (steps (traverse op system))) + (print steps))) (defun operate (operation-class system &rest args) (let* ((op (apply #'make-instance operation-class Index: root/load.lisp diff -u root/load.lisp:1.1 root/load.lisp:1.2 --- root/load.lisp:1.1 Fri Nov 19 00:39:51 2004 +++ root/load.lisp Sun Dec 5 07:33:21 2004 @@ -1,16 +1,50 @@ -(defparameter *utils-kt-path* "../utils-kt/") -(defparameter *cells-path* "../cells/") +(in-package :cl-user) -#-asdf (load (make-pathname :name "asdf" :type "lisp")) +#-asdf +(eval-when (compile load eval) + #+lispworks + (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) -(pushnew *utils-kt-path* asdf:*central-registry*) -(pushnew *cells-path* asdf:*central-registry*) -(pushnew "./gtk-ffi/" asdf:*central-registry*) -(pushnew "./cells-gtk/" asdf:*central-registry*) -(pushnew "./cells-gtk/test-gtk/" asdf:*central-registry*) + (load (make-pathname :directory '(:absolute "000000" "root") + :name "asdf" :type "lisp"))) -(asdf:operate 'asdf:load-op :cells-gtk :force nil) -(asdf:operate 'asdf:load-op :test-gtk :force nil) +(progn ;; setup + (defparameter *utils-kt-path* "/cell-cultures/utils-kt/") + (defparameter *cells-path* "/cell-cultures/cells/") + (defparameter *cells-gtk-root* + (make-pathname :directory '(:absolute "000000" "root"))) + + (push (make-pathname :directory '(:absolute "000000" "uffi")) + asdf:*central-registry*) + + (push *utils-kt-path* asdf:*central-registry*) + (push *cells-path* asdf:*central-registry*) + (push (make-pathname :directory '(:absolute "cell-cultures" "ffi-extender")) + asdf:*central-registry*) + + (push (merge-pathnames + (make-pathname :directory '(:relative "gtk-ffi")) + *cells-gtk-root*) + asdf:*central-registry*) + + (push (merge-pathnames + (make-pathname :directory '(:relative "cells-gtk")) + *cells-gtk-root*) + asdf:*central-registry*) + + (push (merge-pathnames + (make-pathname :directory '(:relative "cells-gtk" "test-gtk")) + *cells-gtk-root*) + asdf:*central-registry*)) + +;(Asdf:operate 'asdf:load-op :utils-kt :force t) +;(Asdf:operate 'asdf:load-op :cells :force t) +;(Asdf:operate 'asdf:load-op :uffi :force t) +;(Asdf:operate 'asdf:load-op :ffi-extender :force t) +;(Asdf:operate 'asdf:load-op :gtk-ffi :force nil) +;(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +(Asdf:operate 'asdf:load-op :test-gtk :force nil) + +#+test +(test-gtk::gtk-demo) -(defun gtk-demo () - (cells-gtk:start-app 'test-gtk::test-gtk)) \ No newline at end of file

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-lib-gtk.lisp root/gtk-ffi/gtk-definitions.lisp root/gtk-ffi/gtk-ffi.asd root/gtk-ffi/gtk-ffi.lisp
by ktilton＠common-lisp.net 05 Dec '04

05 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv13191/gtk-ffi Modified Files: gtk-definitions.lisp gtk-ffi.asd gtk-ffi.lisp Added Files: gtk-lib-gtk.lisp Log Message: Divide gtk-ffi into smaller source files Date: Sun Dec 5 07:31:15 2004 Author: ktilton Index: root/gtk-ffi/gtk-definitions.lisp diff -u root/gtk-ffi/gtk-definitions.lisp:1.1 root/gtk-ffi/gtk-definitions.lisp:1.2 --- root/gtk-ffi/gtk-definitions.lisp:1.1 Sun Dec 5 06:11:38 2004 +++ root/gtk-ffi/gtk-definitions.lisp Sun Dec 5 07:31:14 2004 @@ -38,9 +38,9 @@ (bytes-written c-pointer) (gerror c-pointer)) c-pointer)) - + (def-gtk-lib-functions :gthread - (g-thread-init ((vtable c-pointer)))) + (g-thread-init ((vtable c-pointer)))) (def-gtk-lib-functions :gdk (gdk-threads-init ()) @@ -128,912 +128,5 @@ (g-value-set-double ((value c-pointer) (double double-float)))) -(def-gtk-lib-functions :gtk - ;; main-loop - (gtk-init ((argc (c-ptr-null int)) - (argv c-pointer))) - (gtk-init-check ((argc (c-ptr-null int)) - (argv c-pointer)) - boolean) - (gtk-events-pending () - boolean) - (gtk-main-iteration () - boolean) - (gtk-main-iteration-do ((blocking boolean)) - boolean nil nil) - (gtk-main ()) - (gtk-main-quit ()) - (gtk-get-current-event-time () - uint32) - - ;;container - (gtk-container-add ((container c-pointer) - (widget c-pointer)) - c-pointer) - (gtk-container-remove ((container c-pointer) - (widget c-pointer))) - - ;;box - (gtk-box-pack-start ((box c-pointer) - (widget c-pointer) - (expand boolean) - (fill boolean) - (padding int)) - nil nil nil) - (gtk-box-pack-start-defaults ((box c-pointer) - (widget c-pointer))) - (gtk-box-set-homogeneous ((box c-pointer) - (homogeneous boolean)) - nil nil nil) - (gtk-box-set-spacing ((box c-pointer) - (spacing int))) - (gtk-hbox-new ((homogeneous boolean) - (spacing int)) - c-pointer nil nil) - (gtk-vbox-new ((homogeneous boolean) - (spacing int)) - c-pointer nil nil) - - ;;table - (gtk-table-new ((rows uint) - (columns uint) - (homogeneous boolean)) - c-pointer nil nil) - (gtk-table-attach ((table c-pointer) - (child c-pointer) - (l-attach uint) - (r-attach uint) - (t-attach uint) - (b-attach uint) - (x-options int) - (y-options int) - (x-padding int) - (y-padding int))) - (gtk-table-attach-defaults ((table c-pointer) - (child c-pointer) - (l-attach uint) - (r-attach uint) - (t-attach uint) - (b-attach uint))) - (gtk-table-set-homogeneous ((table c-pointer) - (homogeneous boolean)) - nil nil nil) - - ;;paned - (gtk-paned-add1 ((paned c-pointer) - (child c-pointer))) - (gtk-paned-add2 ((paned c-pointer) - (child c-pointer))) - (gtk-hpaned-new () - c-pointer) - (gtk-vpaned-new () - c-pointer) - - ;;expander - (gtk-expander-new ((label c-string)) - c-pointer) - (gtk-expander-set-expanded ((expander c-pointer) - (expanded boolean))) - (gtk-expander-set-spacing ((expander c-pointer) - (spacing c-pointer))) - (gtk-expander-set-label ((expander c-pointer) - (label c-string))) - (gtk-expander-set-use-underline ((expander c-pointer) - (use-underline boolean))) - (gtk-expander-set-use-markup ((expander c-pointer) - (use-markup boolean))) - (gtk-expander-set-label-widget ((expander c-pointer) - (label-widget c-pointer))) - - ;;alignment - (gtk-alignment-new ((xalign single-float) - (yalign single-float) - (xscale single-float) - (yscale single-float)) - c-pointer) - (gtk-alignment-set ((alignment c-pointer) - (xalign single-float) - (yalign single-float) - (xscale single-float) - (yscale single-float))) - - ;;frame - (gtk-frame-new ((label c-string)) - c-pointer) - (gtk-frame-set-label ((frame c-pointer) - (label c-string))) - (gtk-frame-set-label-widget ((frame c-pointer) - (label-widget c-pointer))) - (gtk-frame-set-label-align ((frame c-pointer) - (xalign single-float) - (yalign single-float))) - (gtk-frame-set-shadow-type ((frame c-pointer) - (shadow-type int))) - - ;;aspect-frame - (gtk-aspect-frame-new ((label c-string) - (xalign single-float) - (yalign single-float) - (ratio single-float) - (obey_child boolean)) - c-pointer) - - ;;separetor - (gtk-hseparator-new () - c-pointer) - (gtk-vseparator-new () - c-pointer) - - ;;scrolling - (gtk-scrolled-window-new ((hadjustment c-pointer) - (vadjustment c-pointer)) - c-pointer) - (gtk-scrolled-window-set-policy ((scrolled-window c-pointer) - (h-policy int) - (v-policy int))) - (gtk-scrolled-window-add-with-viewport ((scrolled-window c-pointer) - (child c-pointer))) - (gtk-scrolled-window-set-placement ((scrolled-window c-pointer) - (placement int))) - (gtk-scrolled-window-set-shadow-type ((scrolled-window c-pointer) - (type int))) - - ;;notebook - (gtk-notebook-new () - c-pointer) - (gtk-notebook-append-page ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer)) - int) - (gtk-notebook-append-page-menu ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (menu-label c-pointer)) - int) - (gtk-notebook-prepend-page ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer)) - int) - (gtk-notebook-prepend-page-menu ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (menu-label c-pointer)) - int) - (gtk-notebook-insert-page ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (pos int)) - int) - (gtk-notebook-insert-page-menu ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (menu-label c-pointer) - (pos int)) - int) - (gtk-notebook-remove-page ((notebook c-pointer) - (page-num int))) - (gtk-notebook-set-current-page ((notebook c-pointer) - (page-num int))) - (gtk-notebook-set-tab-pos ((notebook c-pointer) - (pos int))) - (gtk-notebook-set-show-tabs ((notebook c-pointer) - (show-tabs boolean))) - (gtk-notebook-set-show-border ((notebook c-pointer) - (show-border boolean))) - (gtk-notebook-set-scrollable ((notebook c-pointer) - (scrollable boolean))) - (gtk-notebook-set-tab-border ((notebook c-pointer) - (border-width int))) - (gtk-notebook-popup-enable ((notebook c-pointer))) - (gtk-notebook-popup-disable ((notebook c-pointer))) - (gtk-notebook-set-homogeneous-tabs ((notebook c-pointer) - (homogeneous-tabs boolean))) - - ;;label - (gtk-label-new ((text c-string)) - c-pointer) - (gtk-label-set-text ((label c-pointer) - (text c-string))) - (gtk-label-set-text-with-mnemonic ((label c-pointer) - (text c-string))) - (gtk-label-set-line-wrap ((label c-pointer) - (wrap boolean))) - (gtk-label-set-selectable ((label c-pointer) - (selectable boolean))) - (gtk-label-set-use-markup ((label c-pointer) - (use-markup boolean))) - (gtk-label-set-markup ((label c-pointer) - (markup c-string))) - (gtk-label-set-markup-with-mnemonic ((label c-pointer) - (markup c-string))) - - (gtk-accel-label-new ((str c-string)) - c-pointer) - (gtk-accel-label-set-accel-widget ((label c-pointer) - (widget c-pointer))) - - ;;progress - (gtk-progress-bar-new () - c-pointer) - (gtk-progress-bar-pulse ((pbar c-pointer))) - (gtk-progress-bar-set-text ((pbar c-pointer) - (text c-string))) - (gtk-progress-bar-set-fraction ((pbar c-pointer) - (fraction double-float))) - (gtk-progress-bar-set-pulse-step ((pbar c-pointer) - (fraction double-float))) - (gtk-progress-bar-set-orientation ((pbar c-pointer) - (orientation int))) - (gtk-progress-bar-set-bar-style ((pbar c-pointer) - (style int))) - (gtk-progress-bar-set-discrete-blocks ((pbar c-pointer) - (blocks uint))) - (gtk-progress-bar-set-activity-step ((pbar c-pointer) - (step uint))) - (gtk-progress-bar-set-activity-blocks ((pbar c-pointer) - (blocks uint))) - (gtk-progress-bar-update ((pbar c-pointer) - (percentage double-float))) - - ;;image - (gtk-image-new-from-file ((filename c-string)) - c-pointer) - (gtk-image-new-from-stock ((stock c-string) - (icon-size int)) - c-pointer) - (gtk-image-set-from-stock ((image c-pointer) - (stock c-string) - (icon-size int))) - (gtk-image-get-pixbuf ((image c-pointer)) - c-pointer) - - ;;statusbar - (gtk-statusbar-new () - c-pointer) - (gtk-statusbar-get-context-id ((sbar c-pointer) - (description c-string)) - uint) - (gtk-statusbar-push ((sbar c-pointer) - (context-id uint) - (text c-string)) - uint) - (gtk-statusbar-pop ((sbar c-pointer) - (context-id uint))) - (gtk-statusbar-remove ((sbar c-pointer) - (context-id uint) - (message-id uint))) - (gtk-statusbar-set-has-resize-grip ((sbar c-pointer) - (setting boolean)) - nil nil nil) - - ;;widget - (gtk-widget-show ((widget c-pointer))) - (gtk-widget-show-all ((widget c-pointer))) - (gtk-widget-hide ((widget c-pointer))) - (gtk-widget-destroy ((widget c-pointer))) - (gtk-widget-set-sensitive ((widget c-pointer) - (sensitive boolean)) - nil nil nil) - (gtk-widget-set-size-request ((widget c-pointer) - (width int) - (height int))) - (gtk-widget-get-parent-window ((widget c-pointer)) - c-pointer) - (gtk-widget-add-accelerator ((widget c-pointer) - (gsignal c-string) - (accel-group c-pointer) - (key uint) - (mods int) - (flags int))) - (gtk-widget-grab-focus ((widget c-pointer))) - - ;;window - (gtk-window-new ((type int)) - c-pointer) - (gtk-window-set-title ((widget c-pointer) - (title c-string))) - (gtk-window-set-icon-from-file ((window c-pointer) - (filename c-string) - (err c-pointer)) - boolean) - (gtk-window-set-default-size ((widget c-pointer) - (width int) - (height int))) - (gtk-window-set-resizable ((widget c-pointer) - (resizable boolean))) - (gtk-window-set-decorated ((widget c-pointer) - (decorated boolean)) - nil nil nil) - (gtk-window-set-auto-startup-notification ((setting boolean)) nil nil nil) - (gtk-window-set-position ((widget c-pointer) - (position int))) - (gtk-window-maximize ((widget c-pointer))) - (gtk-window-unmaximize ((widget c-pointer))) - (gtk-window-iconify ((widget c-pointer))) - (gtk-window-deiconify ((widget c-pointer))) - (gtk-window-fullscreen ((widget c-pointer))) - (gtk-window-unfullscreen ((widget c-pointer))) - (gtk-window-add-accel-group ((window c-pointer) - (accel-group c-pointer))) - - ;;button - (gtk-button-new () - c-pointer) - (gtk-button-set-label ((button c-pointer) - (label c-string))) - (gtk-button-set-relief ((button c-pointer) - (style int))) - (gtk-button-set-use-stock ((button c-pointer) - (use-stock boolean))) - ;;toggle-button - (gtk-toggle-button-new () - c-pointer) - (gtk-toggle-button-set-mode ((button c-pointer) - (draw-indicator boolean))) - (gtk-toggle-button-set-active ((button c-pointer) - (active boolean))) - (gtk-toggle-button-get-active ((button c-pointer)) - boolean) - ;;check-button - (gtk-check-button-new () - c-pointer) - ;;radio-button - (gtk-radio-button-new ((gslist c-pointer)) - c-pointer) - (gtk-radio-button-new-from-widget ((radio-group c-pointer)) - c-pointer) - - ;;entry - (gtk-entry-new () - c-pointer) - (gtk-entry-set-text ((entry c-pointer) - (text c-string))) - (gtk-entry-get-text ((entry c-pointer)) - c-pointer) - (gtk-entry-set-max-length ((entry c-pointer) - (max-length int))) - (gtk-entry-set-editable ((entry c-pointer) - (editable boolean))) - (gtk-entry-set-completion ((entry c-pointer) - (completion c-pointer))) - (gtk-entry-set-has-frame ((entry c-pointer) - (has-frame boolean))) - - ;;entry-completion - (gtk-entry-completion-new () - c-pointer) - (gtk-entry-completion-set-model ((completion c-pointer) - (model c-pointer))) - (gtk-entry-completion-set-text-column ((completion c-pointer) - (column int))) - - ;;range - (gtk-range-set-range ((range c-pointer) - (minval double-float) - (maxval double-float))) - (gtk-range-set-value ((range c-pointer) - (val double-float))) - (gtk-range-set-inverted ((range c-pointer) - (inverted boolean))) - (gtk-range-set-increments ((range c-pointer) - (step double-float) - (page double-float))) - (gtk-range-set-update-policy ((range c-pointer) - (policy int))) - (gtk-range-get-value ((range c-pointer)) - double-float) - - ;;scale - (gtk-scale-set-draw-value ((scale c-pointer) - (draw-value boolean))) - (gtk-scale-set-value-pos ((scale c-pointer) - (pos-type int))) - (gtk-scale-set-digits ((scale c-pointer) - (digits int))) - - ;;hscale - (gtk-hscale-new ((adjustment c-pointer)) - c-pointer) - (gtk-hscale-new-with-range ((minval double-float) - (maxval double-float) - (step double-float)) - c-pointer) - - ;;vscale - (gtk-vscale-new ((adjustment c-pointer)) - c-pointer) - (gtk-vscale-new-with-range ((minval double-float) - (maxval double-float) - (step double-float)) - c-pointer) - - ;;spin-button - (gtk-spin-button-new ((adjustment c-pointer) - (climb-rate double-float) - (digits uint)) - c-pointer) - (gtk-spin-button-new-with-range ((minval double-float) - (maxval double-float) - (step double-float)) - c-pointer) - (gtk-spin-button-set-value ((spin-button c-pointer) - (value double-float))) - (gtk-spin-button-get-value ((spin-button c-pointer)) - double-float) - (gtk-spin-button-get-value-as-int ((spin-button c-pointer)) - int) - (gtk-spin-button-set-wrap ((spin-button c-pointer) - (wrap boolean))) - - ;;list-store - (gtk-list-store-newv ((n-columns int) - (col-types c-pointer)) - c-pointer) - (gtk-list-store-set-valist ((store c-pointer) - (iter c-pointer) - (data c-pointer))) - (gtk-list-store-set-value ((store c-pointer) - (iter c-pointer) - (column int) - (value c-pointer))) - (gtk-list-store-append ((list-store c-pointer) - (iter c-pointer))) - (gtk-list-store-clear ((list-store c-pointer))) - - ;;tree-store - (gtk-tree-store-newv ((n-columns int) - (col-types (c-array-ptr int))) - c-pointer) - (gtk-tree-store-set-valist ((store c-pointer) - (iter c-pointer) - (data c-pointer))) - (gtk-tree-store-set-value ((store c-pointer) - (iter c-pointer) - (column int) - (value c-pointer))) - (gtk-tree-store-append ((list-store c-pointer) - (iter c-pointer) - (parent c-pointer))) - (gtk-tree-store-clear ((list-store c-pointer))) - - ;;tree-view - (gtk-tree-view-new () - c-pointer) - (gtk-tree-view-set-model ((tree-view c-pointer) - (model c-pointer))) - (gtk-tree-view-insert-column ((tree-view c-pointer) - (column c-pointer) - (pos int)) - int) - (gtk-tree-view-get-selection ((tree-view c-pointer)) - c-pointer) - - ;;tree-model - (gtk-tree-model-get ((tree-model c-pointer) - (iter c-pointer) - (column int) - (data c-pointer) - (eof int))) - (gtk-tree-model-get-iter-from-string ((tree-model c-pointer) - (iter c-pointer) - (path c-string)) - boolean) - - ;;tree-path - (gtk-tree-path-new-from-string ((path c-string)) - c-pointer) - (gtk-tree-path-free ((path c-pointer))) - - ;;tree-selection - (gtk-tree-selection-set-mode ((sel c-pointer) - (mode int))) - (gtk-tree-selection-get-mode ((sel c-pointer)) - int) - (gtk-tree-selection-select-path ((sel c-pointer) - (path c-pointer))) - (gtk-tree-selection-get-selected ((sel c-pointer) - (model c-pointer) - (iter c-pointer)) - boolean) - (gtk-tree-selection-selected-foreach ((sel c-pointer) - (callback-f #.(callback-function ((model c-pointer) - (path c-pointer) - (iter c-pointer) - (data c-pointer)))) - (data c-pointer))) - ;;tree-view-column - (gtk-tree-view-column-new () - c-pointer) - (gtk-tree-view-column-pack-start ((tree-column c-pointer) - (renderer c-pointer) - (expand boolean)) - nil nil nil) - (gtk-tree-view-column-add-attribute ((tree-column c-pointer) - (renderer c-pointer) - (attribute c-string) - (column int))) - (gtk-tree-view-column-set-spacing ((tree-column c-pointer) - (spacing int))) - (gtk-tree-view-column-set-visible ((tree-column c-pointer) - (spacing boolean)) - nil nil nil) - (gtk-tree-view-column-set-reorderable ((tree-column c-pointer) - (resizable boolean))) - (gtk-tree-view-column-set-sort-column-id ((tree-column c-pointer) - (col-id int))) - (gtk-tree-view-column-set-sort-indicator ((tree-column c-pointer) - (resizable boolean))) - (gtk-tree-view-column-set-resizable ((tree-column c-pointer) - (resizable boolean))) - (gtk-tree-view-column-set-fixed-width ((tree-column c-pointer) - (fixed-width int))) - (gtk-tree-view-column-set-min-width ((tree-column c-pointer) - (min-width int))) - (gtk-tree-view-column-set-max-width ((tree-column c-pointer) - (max-width int))) - (gtk-tree-view-column-set-title ((tree-column c-pointer) - (title c-string))) - (gtk-tree-view-column-set-expand ((tree-column c-pointer) - (expand boolean))) - (gtk-tree-view-column-set-clickable ((tree-column c-pointer) - (clickable boolean))) - (gtk-tree-view-column-set-cell-data-func ((tree-column c-pointer) - (cell-renderer c-pointer) - (func #.(callback-function ((tree-column c-pointer) - (cell-renderer c-pointer) - (tree-model c-pointer) - (iter c-pointer) - (data c-pointer)))) - (data c-pointer) - (destroy c-pointer))) - ;;cell-renderers - (gtk-cell-renderer-text-new () - c-pointer) - (gtk-cell-renderer-toggle-new () - c-pointer) - (gtk-cell-renderer-pixbuf-new () - c-pointer) - - - ;;combo-box - (gtk-combo-box-new-text () - c-pointer) - (gtk-combo-box-append-text ((combo-box c-pointer) - (text c-string))) - (gtk-combo-box-remove-text ((combo-box c-pointer) - (position int))) - (gtk-combo-box-set-active ((combo-box c-pointer) - (index int))) - (gtk-combo-box-get-active ((combo-box c-pointer)) - int) - - ;;toolbar - (gtk-toolbar-new () - c-pointer) - (gtk-toolbar-insert ((toolbar c-pointer) - (item c-pointer) - (pos int))) - (gtk-toolbar-set-show-arrow ((toolbar c-pointer) - (show-arrow boolean))) - (gtk-toolbar-set-orientation ((toolbar c-pointer) - (orientation int))) - (gtk-toolbar-set-tooltips ((toolbar c-pointer) - (enable boolean))) - (gtk-toolbar-set-style ((toolbar c-pointer) - (style int))) - - ;;tooltips - (gtk-tooltips-new () - c-pointer) - (gtk-tooltips-set-tip ((tooltips c-pointer) - (widget c-pointer) - (tip-text c-string) - (tip-private c-string))) - (gtk-tooltips-enable ((tooltips c-pointer))) - (gtk-tooltips-disable ((tooltips c-pointer))) - (gtk-tooltips-set-delay ((tooltips c-pointer) - (delay uint))) - ;;tool-item - (gtk-tool-item-new () - c-pointer) - (gtk-tool-item-set-homogeneous ((tool-item c-pointer) - (homogeneous boolean))) - (gtk-tool-item-set-expand ((tool-item c-pointer) - (expand boolean))) - (gtk-tool-item-set-tooltip ((tool-item c-pointer) - (tooltips c-pointer) - (tip-text c-string) - (tip-private c-string))) - (gtk-tool-item-set-is-important ((tool-item c-pointer) - (is-important boolean))) - - (gtk-separator-tool-item-new () - c-pointer) - (gtk-separator-tool-item-set-draw ((item c-pointer) - (draw boolean))) - - ;;tool-button - (gtk-tool-button-new ((icon-widget c-pointer) - (label c-pointer)) - c-pointer) - (gtk-tool-button-new-from-stock ((stock-id c-string)) - c-pointer) - (gtk-tool-button-set-label ((tool-button c-pointer) - (label c-pointer))) - (gtk-tool-button-set-use-underline ((tool-button c-pointer) - (use-underline boolean))) - (gtk-tool-button-set-stock-id ((tool-button c-pointer) - (stock-id c-string))) - (gtk-tool-button-set-icon-widget ((tool-button c-pointer) - (icon-widget c-pointer))) - (gtk-tool-button-set-label-widget ((tool-button c-pointer) - (label-widget c-pointer))) - - ;;menu - (gtk-menu-shell-append ((menu-shell c-pointer) - (child c-pointer))) - (gtk-menu-shell-prepend ((menu-shell c-pointer) - (child c-pointer))) - (gtk-menu-shell-insert ((menu-shell c-pointer) - (child c-pointer) - (position int))) - (gtk-menu-bar-new () - c-pointer) - - (gtk-menu-new () - c-pointer) - (gtk-menu-set-title ((menu c-pointer) - (title c-string))) - (gtk-menu-attach ((menu c-pointer) - (child c-pointer) - (lattach uint) - (rattach uint) - (tattach uint) - (battach uint))) - (gtk-menu-attach-to-widget ((menu c-pointer) - (widget c-pointer) - (func #.(callback-function ((widget c-pointer) - (menu c-pointer)))))) - - (gtk-menu-popup ((menu c-pointer) - (p-menu-shell c-pointer) - (p-menu-item c-pointer) - (func #.(callback-function ((menu c-pointer) - (x (c-ptr int)) - (y (c-ptr int)) - (push-in (c-ptr boolean)) - (data c-pointer)))) - (data c-pointer) - (button uint) - (activate-time uint32))) - - (gtk-menu-item-new () - c-pointer) - (gtk-menu-item-new-with-label ((label c-string)) - c-pointer) - (gtk-menu-item-set-right-justified ((menu-item c-pointer) - (right-justified boolean))) - (gtk-menu-item-set-submenu ((menu-item c-pointer) - (submenu c-pointer))) - (gtk-menu-item-remove-submenu ((menu-item c-pointer))) - (gtk-menu-item-set-accel-path ((menu-item c-pointer) - (acell-path c-pointer))) - (gtk-accel-map-add-entry ((accel-path c-pointer) - (accel-key uint) - (accel-mods int))) - - (gtk-check-menu-item-new () - c-pointer) - (gtk-check-menu-item-new-with-label ((label c-string)) - c-pointer) - (gtk-check-menu-item-set-active ((check-menu c-pointer) - (active boolean))) - (gtk-check-menu-item-get-active ((check-menu c-pointer)) - boolean) - - (gtk-radio-menu-item-new ((group c-pointer)) - c-pointer) - (gtk-radio-menu-item-new-from-widget ((group c-pointer)) - c-pointer) - (gtk-radio-menu-item-new-with-label ((group c-pointer) - (label c-string)) - c-pointer) - (gtk-radio-menu-item-new-with-label-from-widget ((radio c-pointer) - (label c-string)) - c-pointer) - (gtk-radio-menu-item-get-group ((radio c-pointer)) - c-pointer) - - (gtk-image-menu-item-new () - c-pointer) - (gtk-image-menu-item-new-with-label ((label c-string)) - c-pointer) - (gtk-image-menu-item-new-from-stock ((stock-id c-string) - (accel-group c-pointer)) - c-pointer) - (gtk-image-menu-item-set-image ((menu-item c-pointer) - (image c-pointer))) - - - (gtk-separator-menu-item-new () - c-pointer) - (gtk-tearoff-menu-item-new () - c-pointer) - - ;;calendar - (gtk-calendar-new () - c-pointer) - (gtk-calendar-get-date ((cal c-pointer) - (year c-pointer) - (month c-pointer) - (day c-pointer))) - (gtk-calendar-select-month ((cal c-pointer) - (month uint) - (year uint)) - int) - (gtk-calendar-select-day ((cal c-pointer) - (day uint))) - - ;;arrow - (gtk-arrow-new ((arrow-type int) - (shadow-type int)) - c-pointer) - (gtk-arrow-set ((arrow c-pointer) - (arrow-type int) - (shadow-type int))) - - ;;dialog - (gtk-dialog-new () - c-pointer) - (gtk-dialog-run ((dialog c-pointer)) - int) - (gtk-dialog-response ((dialog c-pointer) - (response-id int))) - (gtk-dialog-add-button ((dialog c-pointer) - (button-text c-string) - (response-id int)) - c-pointer) - (gtk-dialog-add-action-widget ((dialog c-pointer) - (child c-pointer) - (response-id c-pointer))) - (gtk-dialog-set-has-separator ((dialog c-pointer) - (has-separator boolean))) - (gtk-dialog-set-default-response ((dialog c-pointer) - (response-id int))) - ;;message-dialog - (gtk-message-dialog-new ((parent c-pointer) - (flags int) - (type int) - (buttons int) - (message c-string)) - c-pointer) - (gtk-message-dialog-set-markup ((dialog c-pointer) - (str c-string))) - ;;file-chooser - (gtk-file-chooser-set-action ((chooser c-pointer) - (action int))) - (gtk-file-chooser-set-local-only ((chooser c-pointer) - (local-only boolean))) - (gtk-file-chooser-set-select-multiple ((chooser c-pointer) - (select-multiple boolean))) - (gtk-file-chooser-set-current-name ((chooser c-pointer) - (name c-string))) - (gtk-file-chooser-set-filename ((chooser c-pointer) - (filename c-string)) - boolean) - (gtk-file-chooser-get-filename ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-get-filenames ((chooser c-pointer)) - c-pointer) - (gtk-file-chooser-set-current-folder ((chooser c-pointer) - (folder c-string)) - boolean) - (gtk-file-chooser-get-current-folder ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-set-uri ((chooser c-pointer) - (uri c-string)) - boolean) - (gtk-file-chooser-get-uri ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-select-uri ((chooser c-pointer)) - boolean) - (gtk-file-chooser-get-uris ((chooser c-pointer)) - c-pointer) - (gtk-file-chooser-set-current-folder-uri ((chooser c-pointer) - (folder c-string)) - boolean) - (gtk-file-chooser-get-current-folder-uri ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-set-use-preview-label ((chooser c-pointer) - (use-label boolean))) - (gtk-file-chooser-add-filter ((chooser c-pointer) - (filter c-pointer))) - (gtk-file-chooser-set-filter ((chooser c-pointer) - (filter c-pointer))) - ;;file-chooser-widget - (gtk-file-chooser-widget-new ((action int)) - c-pointer) - ;;file-chooser-dialog - (gtk-file-chooser-dialog-new ((title c-string) - (parent c-pointer) - (action int) - (cancel-text c-string) - (cancel-response-id int) - (accept-text c-string) - (accept-response-id int) - (null c-pointer)) - c-pointer) - - ;;file-filter - (gtk-file-filter-new () - c-pointer) - (gtk-file-filter-set-name ((filter c-pointer) - (name c-string))) - (gtk-file-filter-add-mime-type ((filter c-pointer) - (mime-type c-string))) - (gtk-file-filter-add-pattern ((filter c-pointer) - (pattern c-string))) - - ;;text-view - (gtk-text-view-new () - c-pointer) - (gtk-text-view-set-buffer ((text-view c-pointer) - (buffer c-pointer))) - - ;;text-buffer - (gtk-text-buffer-new ((table c-pointer)) - c-pointer) - (gtk-text-buffer-set-text ((buffer c-pointer) - (text c-string) - (len int))) - - ;;text-tag-table - (gtk-text-tag-table-new () - c-pointer) - - ;;accel-group - (gtk-accel-group-new () - c-pointer) - - ;;ui-manager - (gtk-ui-manager-new () - c-pointer) - (gtk-ui-manager-set-add-tearoffs ((ui-manager c-pointer) - (add-tearoffs boolean))) - (gtk-ui-manager-insert-action-group ((ui-manager c-pointer) - (action-group c-pointer) - (pos int))) - (gtk-ui-manager-get-toplevels ((ui-manager c-pointer) - (types int)) - c-pointer) - - ;;action-group - (gtk-action-group-new ((name c-string)) - c-pointer) - (gtk-action-group-set-sensitive ((action-group c-pointer) - (sensitive boolean))) - (gtk-action-group-set-visible ((action-group c-pointer) - (visible boolean))) - (gtk-action-group-add-action ((action-group c-pointer) - (action c-pointer))) - (gtk-action-group-remove-action ((action-group c-pointer) - (action c-pointer))) - (gtk-action-group-add-action-with-accel ((action-group c-pointer) - (action c-pointer) - (accel c-string))) - ;;action - (gtk-action-new ((name c-string) - (label c-pointer) - (tooltip c-pointer) - (stock-id c-string)) - c-pointer) - - (gtk-event-box-new () - c-pointer) - (gtk-event-box-set-above-child ((event-box c-pointer) - (above boolean))) - (gtk-event-box-set-visible-window ((event-box c-pointer) - (visible-window boolean)) - nil nil nil)) Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.2 root/gtk-ffi/gtk-ffi.asd:1.3 --- root/gtk-ffi/gtk-ffi.asd:1.2 Sun Dec 5 06:11:38 2004 +++ root/gtk-ffi/gtk-ffi.asd Sun Dec 5 07:31:14 2004 @@ -1,8 +1,8 @@ (asdf:defsystem :gtk-ffi :name "gtk-ffi" :depends-on (:cells :uffi :ffi-extender) - :serial t :components ((:file "gtk-ffi") - (:file "gtk-definitions") - (:file "gtk-utilities"))) \ No newline at end of file + (:file "gtk-definitions" :depends-on ("gtk-ffi")) + (:file "gtk-lib-gtk" :depends-on ("gtk-ffi")) + (:file "gtk-utilities" :depends-on ("gtk-definitions" "gtk-lib-gtk")))) \ No newline at end of file Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.2 root/gtk-ffi/gtk-ffi.lisp:1.3 --- root/gtk-ffi/gtk-ffi.lisp:1.2 Sun Dec 5 06:11:38 2004 +++ root/gtk-ffi/gtk-ffi.lisp Sun Dec 5 07:31:14 2004 @@ -135,7 +135,7 @@ (destructuring-bind (name type) name-type (list name (ffi-to-uffi-type type)))) arguments) - :module ,library + :module ,(string library) :call-direct ,call-direct :returning ,(ffi-to-uffi-type return-type)) (defun ,name ,(mapcar 'car arguments)

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-definitions.lisp root/gtk-ffi/gtk-ffi.lpr root/gtk-ffi/gtk-utilities.lisp root/gtk-ffi/gtk-ffi.asd root/gtk-ffi/gtk-ffi.lisp
by ktilton＠common-lisp.net 05 Dec '04

05 Dec '04

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv8843/gtk-ffi Modified Files: gtk-ffi.asd gtk-ffi.lisp Added Files: gtk-definitions.lisp gtk-ffi.lpr gtk-utilities.lisp Log Message: Divide gtk-ffi into smaller source files Date: Sun Dec 5 06:11:38 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.1 root/gtk-ffi/gtk-ffi.asd:1.2 --- root/gtk-ffi/gtk-ffi.asd:1.1 Fri Nov 19 00:40:28 2004 +++ root/gtk-ffi/gtk-ffi.asd Sun Dec 5 06:11:38 2004 @@ -1,6 +1,8 @@ (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells) + :depends-on (:cells :uffi :ffi-extender) :serial t :components - ((:file "gtk-ffi"))) + ((:file "gtk-ffi") + (:file "gtk-definitions") + (:file "gtk-utilities"))) \ No newline at end of file Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.1 root/gtk-ffi/gtk-ffi.lisp:1.2 --- root/gtk-ffi/gtk-ffi.lisp:1.1 Fri Nov 19 00:40:28 2004 +++ root/gtk-ffi/gtk-ffi.lisp Sun Dec 5 06:11:38 2004 @@ -16,1035 +16,202 @@ |# -(defpackage :gtk-ffi (:use :lisp :ffi)) + +(defpackage :gtk-ffi (:use :lisp #-clisp :ffx + #+clisp :ffi #-clisp :uffi)) (in-package :gtk-ffi) +(defconstant c-null #+clisp nil #-clisp (make-null-pointer '(* void))) + +(defvar *gtk-debug* nil) + +#+clisp +(defmacro with-cstring ((var str) &body body) + `(let ((,var ,str)) + ,@body)) + +(defun int-slot-indexed (obj obj-type slot index) + (declare (ignorable obj-type)) + (deref-array + (get-slot-pointer obj obj-type slot) + '(:array :int) index)) + +(defun (setf int-slot-indexed) (new-value obj obj-type slot index) + (declare (ignorable obj-type)) + (setf (deref-array + (get-slot-pointer obj obj-type slot) + '(:array :int) index) + new-value)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (export '(c-null int-slot-indexed)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) (defun libname (lib) + #+(or win32 mswindows) + (concatenate 'string + "/Program Files/Common Files/GTK/2.0/bin/" + (ecase lib + (:gobject "libgobject-2.0-0.dll") + (:glib "libglib-2.0-0.dll") + (:gthread "libgthread-2.0-0.dll") + (:gdk "libgdk-win32-2.0-0.dll") + (:gtk "libgtk-win32-2.0-0.dll"))) + #-(or win32 mswindows) (ecase lib - (:gobject #+win32 "libgobject-2.0-0.dll" - #-win32 "libgobject-2.0.so") - (:glib #+win32 "libglib-2.0-0.dll" - #-win32 "libglib-2.0.so") - (:gthread #+win32 "libgthread-2.0-0.dll" - #-win32 "libgthread-2.0.so") - (:gdk #+win32 "libgdk-win32-2.0-0.dll" - #-win32 "libgdk-x11-2.0.so") - (:gtk #+win32 "libgtk-win32-2.0-0.dll" - #-win32 "libgtk-x11-2.0.so")))) - -(defmacro def-gtk-function (library name &key arguments return-type (return-type-allocation :none)) - `(progn - (def-call-out ,name - (:name ,(gtk-function-name (string-downcase (symbol-name name)))) - (:library ,(libname library)) - ,@(when arguments `((:arguments ,@arguments))) - (:return-type ,return-type ,return-type-allocation) - (:language :stdc)) - (export ',name))) + (:gobject "libgobject-2.0.so") + (:glib "libglib-2.0.so") + (:gthread "libgthread-2.0.so") + (:gdk "libgdk-x11-2.0.so") + (:gtk "libgtk-x11-2.0.so"))) + + (defun ffi-to-uffi-type (clisp-type) + #+clisp clisp-type + #-clisp (if (consp clisp-type) + (mapcar 'ffi-to-uffi-type clisp-type) + (case clisp-type + (uint :UNSIGNED-INT) + (c-pointer :pointer-void) + (c-ptr-null '*) + (c-array-ptr '*) + (c-ptr '*) + (c-string :pointer-void) + (sint32 :int) + (uint32 :unsigned-int) + (uint8 :unsigned-byte) + (boolean :unsigned-int) + (ulong :unsigned-long) + (int :int) + (long :long) + (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))) + + +(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)) + + (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 ,@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) + if (eql 'c-string (cadr arg)) + collect (car arg) into arg$s + and collect gsym into gsyms + and collect gsym into pass-args + else if (eql 'boolean (cadr arg)) + collect `(if ,(car arg) 1 0) into pass-args + else if (eql 'c-pointer (cadr arg)) + collect `(or ,(car arg) c-null) into pass-args + else + collect (car arg) into pass-args + finally (return (list (mapcar 'list gsyms arg$s) + pass-args))))) + `(progn + (uffi:def-function (,gtk-name$ ,gtk-name) + ,(mapcar (lambda (name-type) + (destructuring-bind (name type) name-type + (list name (ffi-to-uffi-type type)))) + arguments) + :module ,library + :call-direct ,call-direct + :returning ,(ffi-to-uffi-type return-type)) + (defun ,name ,(mapcar 'car arguments) + (when *gtk-debug* + (print (list ,(symbol-name name) :before ,@(mapcar 'car arguments)))) + (prog1 + ,(let ((bodyform `(with-cstrings + ,(car arg-info) + (,gtk-name ,@(cadr arg-info))))) + (if (eql return-type 'boolean) + `(not (zerop ,bodyform)) + bodyform)) + #+shhhh (print (list ,(symbol-name name) :after + ,@(mapcar 'car arguments))))) + (eval-when (compile load eval) + (export ',name)))))) (defmacro def-gtk-lib-functions (library &rest functions) `(progn - ,@(loop for function in functions collect - (destructuring-bind (name (&rest args) &optional return-type return-type-allocation) function - `(def-gtk-function ,library ,name - ,@(when args `(:arguments ,args)) - :return-type ,return-type - ,@(when return-type-allocation `(:return-type-allocation ,return-type-allocation))))))) + ,@(loop for function in functions collect + (destructuring-bind (name (&rest args) + &optional return-type + return-type-allocation + (call-direct t)) function + `(def-gtk-function ,library ,name + ,@(when args `(:arguments ,args)) + :return-type ,return-type + ,@(when return-type-allocation + `(:return-type-allocation ,return-type-allocation)) + :call-direct ,call-direct))))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro callback-function ((&rest arguments) &optional return-type) - `'(c-function - ,@(when arguments `((:arguments ,@arguments))) - (:return-type ,return-type) - (:language :stdc)))) - -(def-gtk-lib-functions :glib - (g-free ((data c-pointer))) - (g-slist-free ((lst c-pointer))) - (g-timeout-add ((milliseconds uint) - (func #.(callback-function ((data c-pointer)) - boolean)) - (data c-pointer)) - uint) - (g-locale-from-utf8 ((utf8-string c-pointer) - (len sint32) - (bytes-read c-pointer) - (bytes-writen c-pointer) - (gerror c-pointer)) - c-string :malloc-free) - (g-locale-to-utf8 ((local-string c-string) - (len sint32) - (bytes-read c-pointer) - (bytes-writen c-pointer) - (gerror c-pointer)) - c-pointer)) - -(def-gtk-lib-functions :gthread - (g-thread-init ((vtable c-pointer)))) - -(def-gtk-lib-functions :gdk - (gdk-threads-init ()) - (gdk-threads-enter ()) - (gdk-threads-leave ()) - (gdk-flush ())) - -(def-gtk-lib-functions :gobject - ;; callbacks - (g-cclosure-new ((callback-f #.(callback-function ((widget c-pointer) - (event c-pointer) - (data c-pointer)) - boolean)) - (user-data c-pointer) - (destroy-data c-pointer)) - c-pointer) - (g-cclosure-new-swap ((callback-f #.(callback-function ((widget c-pointer) - (event c-pointer) - (data c-pointer)) - boolean)) - (user-data c-pointer) - (destroy-data c-pointer)) - c-pointer) - (g-signal-connect-closure ((instance c-pointer) - (detailed-signal c-string) - (closure c-pointer) - (after boolean)) - ulong) - (g-object-set-valist ((object c-pointer) - (first-prop c-string) - (varargs c-pointer))) - (g-value-init ((value c-pointer) - (type int)) - c-pointer) - (g-value-unset ((value c-pointer))) - (g-value-set-string ((value c-pointer) - (str c-pointer))) - (g-value-set-int ((value c-pointer) - (int int))) - (g-value-set-long ((value c-pointer) - (long long))) - (g-value-set-boolean ((value c-pointer) - (bool boolean))) - (g-value-set-float ((value c-pointer) - (float single-float))) - (g-value-set-double ((value c-pointer) - (double double-float)))) - -(def-c-struct gslist - (data c-pointer) - (next c-pointer)) - -(def-c-struct gtk-tree-iter - (stamp int) - (user-data c-pointer) - (user-data2 c-pointer) - (user_data3 c-pointer)) - -(def-gtk-lib-functions :gtk - ;; main-loop - (gtk-init ((argc (c-ptr-null int)) - (argv c-pointer))) - (gtk-init-check ((argc (c-ptr-null int)) - (argv c-pointer)) - boolean) - (gtk-events-pending () - boolean) - (gtk-main-iteration () - boolean) - (gtk-main-iteration-do ((blocking boolean)) - boolean) - (gtk-main ()) - (gtk-main-quit ()) - (gtk-get-current-event-time () - uint32) - - ;;container - (gtk-container-add ((container c-pointer) - (widget c-pointer)) - c-pointer) - (gtk-container-remove ((container c-pointer) - (widget c-pointer))) - - ;;box - (gtk-box-pack-start ((box c-pointer) - (widget c-pointer) - (expand boolean) - (fill boolean) - (padding int))) - (gtk-box-pack-start-defaults ((box c-pointer) - (widget c-pointer))) - (gtk-box-set-homogeneous ((box c-pointer) - (homogeneous boolean))) - (gtk-box-set-spacing ((box c-pointer) - (spacing int))) - (gtk-hbox-new ((homogeneous boolean) - (spacing int)) - c-pointer) - (gtk-vbox-new ((homogeneous boolean) - (spacing int)) - c-pointer) - - ;;table - (gtk-table-new ((rows uint) - (columns uint) - (homogeneous boolean)) - c-pointer) - (gtk-table-attach ((table c-pointer) - (child c-pointer) - (l-attach uint) - (r-attach uint) - (t-attach uint) - (b-attach uint) - (x-options int) - (y-options int) - (x-padding int) - (y-padding int))) - (gtk-table-attach-defaults ((table c-pointer) - (child c-pointer) - (l-attach uint) - (r-attach uint) - (t-attach uint) - (b-attach uint))) - (gtk-table-set-homogeneous ((table c-pointer) - (homogeneous boolean))) - - ;;paned - (gtk-paned-add1 ((paned c-pointer) - (child c-pointer))) - (gtk-paned-add2 ((paned c-pointer) - (child c-pointer))) - (gtk-hpaned-new () - c-pointer) - (gtk-vpaned-new () - c-pointer) - - ;;expander - (gtk-expander-new ((label c-string)) - c-pointer) - (gtk-expander-set-expanded ((expander c-pointer) - (expanded boolean))) - (gtk-expander-set-spacing ((expander c-pointer) - (spacing c-pointer))) - (gtk-expander-set-label ((expander c-pointer) - (label c-pointer))) - (gtk-expander-set-use-underline ((expander c-pointer) - (use-underline boolean))) - (gtk-expander-set-use-markup ((expander c-pointer) - (use-markup boolean))) - (gtk-expander-set-label-widget ((expander c-pointer) - (label-widget c-pointer))) - - ;;alignment - (gtk-alignment-new ((xalign single-float) - (yalign single-float) - (xscale single-float) - (yscale single-float)) - c-pointer) - (gtk-alignment-set ((alignment c-pointer) - (xalign single-float) - (yalign single-float) - (xscale single-float) - (yscale single-float))) - - ;;frame - (gtk-frame-new ((label c-string)) - c-pointer) - (gtk-frame-set-label ((frame c-pointer) - (label c-pointer))) - (gtk-frame-set-label-widget ((frame c-pointer) - (label-widget c-pointer))) - (gtk-frame-set-label-align ((frame c-pointer) - (xalign single-float) - (yalign single-float))) - (gtk-frame-set-shadow-type ((frame c-pointer) - (shadow-type int))) - - ;;aspect-frame - (gtk-aspect-frame-new ((label c-string) - (xalign single-float) - (yalign single-float) - (ratio single-float) - (obey_child boolean)) - c-pointer) - - ;;separetor - (gtk-hseparator-new () - c-pointer) - (gtk-vseparator-new () - c-pointer) - - ;;scrolling - (gtk-scrolled-window-new ((hadjustment c-pointer) - (vadjustment c-pointer)) - c-pointer) - (gtk-scrolled-window-set-policy ((scrolled-window c-pointer) - (h-policy int) - (v-policy int))) - (gtk-scrolled-window-add-with-viewport ((scrolled-window c-pointer) - (child c-pointer))) - (gtk-scrolled-window-set-placement ((scrolled-window c-pointer) - (placement int))) - (gtk-scrolled-window-set-shadow-type ((scrolled-window c-pointer) - (type int))) - - ;;notebook - (gtk-notebook-new () - c-pointer) - (gtk-notebook-append-page ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer)) - int) - (gtk-notebook-append-page-menu ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (menu-label c-pointer)) - int) - (gtk-notebook-prepend-page ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer)) - int) - (gtk-notebook-prepend-page-menu ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (menu-label c-pointer)) - int) - (gtk-notebook-insert-page ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (pos int)) - int) - (gtk-notebook-insert-page-menu ((notebook c-pointer) - (child c-pointer) - (tab-label c-pointer) - (menu-label c-pointer) - (pos int)) - int) - (gtk-notebook-remove-page ((notebook c-pointer) - (page-num int))) - (gtk-notebook-set-current-page ((notebook c-pointer) - (page-num int))) - (gtk-notebook-set-tab-pos ((notebook c-pointer) - (pos int))) - (gtk-notebook-set-show-tabs ((notebook c-pointer) - (show-tabs boolean))) - (gtk-notebook-set-show-border ((notebook c-pointer) - (show-border boolean))) - (gtk-notebook-set-scrollable ((notebook c-pointer) - (scrollable boolean))) - (gtk-notebook-set-tab-border ((notebook c-pointer) - (border-width int))) - (gtk-notebook-popup-enable ((notebook c-pointer))) - (gtk-notebook-popup-disable ((notebook c-pointer))) - (gtk-notebook-set-homogeneous-tabs ((notebook c-pointer) - (homogeneous-tabs boolean))) - - ;;label - (gtk-label-new ((text c-pointer)) - c-pointer) - (gtk-label-set-text ((label c-pointer) - (text c-pointer))) - (gtk-label-set-text-with-mnemonic ((label c-pointer) - (text c-pointer))) - (gtk-label-set-line-wrap ((label c-pointer) - (wrap boolean))) - (gtk-label-set-selectable ((label c-pointer) - (selectable boolean))) - (gtk-label-set-use-markup ((label c-pointer) - (use-markup boolean))) - (gtk-label-set-markup ((label c-pointer) - (markup c-pointer))) - (gtk-label-set-markup-with-mnemonic ((label c-pointer) - (markup c-pointer))) - - (gtk-accel-label-new ((str c-pointer)) - c-pointer) - (gtk-accel-label-set-accel-widget ((label c-pointer) - (widget c-pointer))) - - ;;progress - (gtk-progress-bar-new () - c-pointer) - (gtk-progress-bar-pulse ((pbar c-pointer))) - (gtk-progress-bar-set-text ((pbar c-pointer) - (text c-string))) - (gtk-progress-bar-set-fraction ((pbar c-pointer) - (fraction double-float))) - (gtk-progress-bar-set-pulse-step ((pbar c-pointer) - (fraction double-float))) - (gtk-progress-bar-set-orientation ((pbar c-pointer) - (orientation int))) - (gtk-progress-bar-set-bar-style ((pbar c-pointer) - (style int))) - (gtk-progress-bar-set-discrete-blocks ((pbar c-pointer) - (blocks uint))) - (gtk-progress-bar-set-activity-step ((pbar c-pointer) - (step uint))) - (gtk-progress-bar-set-activity-blocks ((pbar c-pointer) - (blocks uint))) - (gtk-progress-bar-update ((pbar c-pointer) - (percentage double-float))) - - ;;image - (gtk-image-new-from-file ((filename c-string)) - c-pointer) - (gtk-image-new-from-stock ((stock c-string) - (icon-size int)) - c-pointer) - (gtk-image-set-from-stock ((image c-pointer) - (stock c-string) - (icon-size int))) - (gtk-image-get-pixbuf ((image c-pointer)) - c-pointer) - - ;;statusbar - (gtk-statusbar-new () - c-pointer) - (gtk-statusbar-get-context-id ((sbar c-pointer) - (description c-string)) - uint) - (gtk-statusbar-push ((sbar c-pointer) - (context-id uint) - (text c-pointer)) - uint) - (gtk-statusbar-pop ((sbar c-pointer) - (context-id uint))) - (gtk-statusbar-remove ((sbar c-pointer) - (context-id uint) - (message-id uint))) - (gtk-statusbar-set-has-resize-grip ((sbar c-pointer) - (setting boolean))) - - ;;widget - (gtk-widget-show ((widget c-pointer))) - (gtk-widget-show-all ((widget c-pointer))) - (gtk-widget-hide ((widget c-pointer))) - (gtk-widget-destroy ((widget c-pointer))) - (gtk-widget-set-sensitive ((widget c-pointer) - (sensitive boolean))) - (gtk-widget-set-size-request ((widget c-pointer) - (width int) - (height int))) - (gtk-widget-get-parent-window ((widget c-pointer)) - c-pointer) - (gtk-widget-add-accelerator ((widget c-pointer) - (gsignal c-string) - (accel-group c-pointer) - (key uint) - (mods int) - (flags int))) - (gtk-widget-grab-focus ((widget c-pointer))) - - ;;window - (gtk-window-new ((type int)) - c-pointer) - (gtk-window-set-title ((widget c-pointer) - (title c-pointer))) - (gtk-window-set-icon-from-file ((window c-pointer) - (filename c-string) - (err c-pointer)) - boolean) - (gtk-window-set-default-size ((widget c-pointer) - (width int) - (height int))) - (gtk-window-set-resizable ((widget c-pointer) - (resizable boolean))) - (gtk-window-set-decorated ((widget c-pointer) - (decorated boolean))) - (gtk-window-set-auto-startup-notification ((setting boolean))) - (gtk-window-set-position ((widget c-pointer) - (position int))) - (gtk-window-maximize ((widget c-pointer))) - (gtk-window-unmaximize ((widget c-pointer))) - (gtk-window-iconify ((widget c-pointer))) - (gtk-window-deiconify ((widget c-pointer))) - (gtk-window-fullscreen ((widget c-pointer))) - (gtk-window-unfullscreen ((widget c-pointer))) - (gtk-window-add-accel-group ((window c-pointer) - (accel-group c-pointer))) - - ;;button - (gtk-button-new () - c-pointer) - (gtk-button-set-label ((button c-pointer) - (label c-pointer))) - (gtk-button-set-relief ((button c-pointer) - (style int))) - (gtk-button-set-use-stock ((button c-pointer) - (use-stock boolean))) - ;;toggle-button - (gtk-toggle-button-new () - c-pointer) - (gtk-toggle-button-set-mode ((button c-pointer) - (draw-indicator boolean))) - (gtk-toggle-button-set-active ((button c-pointer) - (active boolean))) - (gtk-toggle-button-get-active ((button c-pointer)) - boolean) - ;;check-button - (gtk-check-button-new () - c-pointer) - ;;radio-button - (gtk-radio-button-new ((gslist c-pointer)) - c-pointer) - (gtk-radio-button-new-from-widget ((radio-group c-pointer)) - c-pointer) - - ;;entry - (gtk-entry-new () - c-pointer) - (gtk-entry-set-text ((entry c-pointer) - (text c-pointer))) - (gtk-entry-get-text ((entry c-pointer)) - c-pointer) - (gtk-entry-set-max-length ((entry c-pointer) - (max-length int))) - (gtk-entry-set-editable ((entry c-pointer) - (editable boolean))) - (gtk-entry-set-completion ((entry c-pointer) - (completion c-pointer))) - (gtk-entry-set-has-frame ((entry c-pointer) - (has-frame boolean))) - - ;;entry-completion - (gtk-entry-completion-new () - c-pointer) - (gtk-entry-completion-set-model ((completion c-pointer) - (model c-pointer))) - (gtk-entry-completion-set-text-column ((completion c-pointer) - (column int))) - - ;;range - (gtk-range-set-range ((range c-pointer) - (minval double-float) - (maxval double-float))) - (gtk-range-set-value ((range c-pointer) - (val double-float))) - (gtk-range-set-inverted ((range c-pointer) - (inverted boolean))) - (gtk-range-set-increments ((range c-pointer) - (step double-float) - (page double-float))) - (gtk-range-set-update-policy ((range c-pointer) - (policy int))) - (gtk-range-get-value ((range c-pointer)) - double-float) - - ;;scale - (gtk-scale-set-draw-value ((scale c-pointer) - (draw-value boolean))) - (gtk-scale-set-value-pos ((scale c-pointer) - (pos-type int))) - (gtk-scale-set-digits ((scale c-pointer) - (digits int))) - - ;;hscale - (gtk-hscale-new ((adjustment c-pointer)) - c-pointer) - (gtk-hscale-new-with-range ((minval double-float) - (maxval double-float) - (step double-float)) - c-pointer) - - ;;vscale - (gtk-vscale-new ((adjustment c-pointer)) - c-pointer) - (gtk-vscale-new-with-range ((minval double-float) - (maxval double-float) - (step double-float)) - c-pointer) - - ;;spin-button - (gtk-spin-button-new ((adjustment c-pointer) - (climb-rate double-float) - (digits uint)) - c-pointer) - (gtk-spin-button-new-with-range ((minval double-float) - (maxval double-float) - (step double-float)) - c-pointer) - (gtk-spin-button-set-value ((spin-button c-pointer) - (value double-float))) - (gtk-spin-button-get-value ((spin-button c-pointer)) - double-float) - (gtk-spin-button-get-value-as-int ((spin-button c-pointer)) - int) - (gtk-spin-button-set-wrap ((spin-button c-pointer) - (wrap boolean))) - - ;;list-store - (gtk-list-store-newv ((n-columns int) - (col-types (c-array-ptr int))) - c-pointer) - (gtk-list-store-set-valist ((store c-pointer) - (iter c-pointer) - (data c-pointer))) - (gtk-list-store-set-value ((store c-pointer) - (iter c-pointer) - (column int) - (value c-pointer))) - (gtk-list-store-append ((list-store c-pointer) - (iter c-pointer))) - (gtk-list-store-clear ((list-store c-pointer))) - - ;;tree-store - (gtk-tree-store-newv ((n-columns int) - (col-types (c-array-ptr int))) - c-pointer) - (gtk-tree-store-set-valist ((store c-pointer) - (iter c-pointer) - (data c-pointer))) - (gtk-tree-store-set-value ((store c-pointer) - (iter c-pointer) - (column int) - (value c-pointer))) - (gtk-tree-store-append ((list-store c-pointer) - (iter c-pointer) - (parent c-pointer))) - (gtk-tree-store-clear ((list-store c-pointer))) - - ;;tree-view - (gtk-tree-view-new () - c-pointer) - (gtk-tree-view-set-model ((tree-view c-pointer) - (model c-pointer))) - (gtk-tree-view-insert-column ((tree-view c-pointer) - (column c-pointer) - (pos int)) - int) - (gtk-tree-view-get-selection ((tree-view c-pointer)) - c-pointer) - - ;;tree-model - (gtk-tree-model-get ((tree-model c-pointer) - (iter c-pointer) - (column int) - (data c-pointer) - (eof int))) - (gtk-tree-model-get-iter-from-string ((tree-model c-pointer) - (iter c-pointer) - (path c-string)) - boolean) - - ;;tree-path - (gtk-tree-path-new-from-string ((path c-string)) - c-pointer) - (gtk-tree-path-free ((path c-pointer))) - - ;;tree-selection - (gtk-tree-selection-set-mode ((sel c-pointer) - (mode int))) - (gtk-tree-selection-get-mode ((sel c-pointer)) - int) - (gtk-tree-selection-select-path ((sel c-pointer) - (path c-pointer))) - (gtk-tree-selection-get-selected ((sel c-pointer) - (model c-pointer) - (iter c-pointer)) - boolean) - (gtk-tree-selection-selected-foreach ((sel c-pointer) - (callback-f #.(callback-function ((model c-pointer) - (path c-pointer) - (iter c-pointer) - (data c-pointer)))) - (data c-pointer))) - ;;tree-view-column - (gtk-tree-view-column-new () - c-pointer) - (gtk-tree-view-column-pack-start ((tree-column c-pointer) - (renderer c-pointer) - (expand boolean))) - (gtk-tree-view-column-add-attribute ((tree-column c-pointer) - (renderer c-pointer) - (attribute c-string) - (column int))) - (gtk-tree-view-column-set-spacing ((tree-column c-pointer) - (spacing int))) - (gtk-tree-view-column-set-visible ((tree-column c-pointer) - (spacing boolean))) - (gtk-tree-view-column-set-reorderable ((tree-column c-pointer) - (resizable boolean))) - (gtk-tree-view-column-set-sort-column-id ((tree-column c-pointer) - (col-id int))) - (gtk-tree-view-column-set-sort-indicator ((tree-column c-pointer) - (resizable boolean))) - (gtk-tree-view-column-set-resizable ((tree-column c-pointer) - (resizable boolean))) - (gtk-tree-view-column-set-fixed-width ((tree-column c-pointer) - (fixed-width int))) - (gtk-tree-view-column-set-min-width ((tree-column c-pointer) - (min-width int))) - (gtk-tree-view-column-set-max-width ((tree-column c-pointer) - (max-width int))) - (gtk-tree-view-column-set-title ((tree-column c-pointer) - (title c-pointer))) - (gtk-tree-view-column-set-expand ((tree-column c-pointer) - (expand boolean))) - (gtk-tree-view-column-set-clickable ((tree-column c-pointer) - (clickable boolean))) - (gtk-tree-view-column-set-cell-data-func ((tree-column c-pointer) - (cell-renderer c-pointer) - (func #.(callback-function ((tree-column c-pointer) - (cell-renderer c-pointer) - (tree-model c-pointer) - (iter c-pointer) - (data c-pointer)))) - (data c-pointer) - (destroy c-pointer))) - ;;cell-renderers - (gtk-cell-renderer-text-new () - c-pointer) - (gtk-cell-renderer-toggle-new () - c-pointer) - (gtk-cell-renderer-pixbuf-new () - c-pointer) - - - ;;combo-box - (gtk-combo-box-new-text () - c-pointer) - (gtk-combo-box-append-text ((combo-box c-pointer) - (text c-pointer))) - (gtk-combo-box-remove-text ((combo-box c-pointer) - (position int))) - (gtk-combo-box-set-active ((combo-box c-pointer) - (index int))) - (gtk-combo-box-get-active ((combo-box c-pointer)) - int) - - ;;toolbar - (gtk-toolbar-new () - c-pointer) - (gtk-toolbar-insert ((toolbar c-pointer) - (item c-pointer) - (pos int))) - (gtk-toolbar-set-show-arrow ((toolbar c-pointer) - (show-arrow boolean))) - (gtk-toolbar-set-orientation ((toolbar c-pointer) - (orientation int))) - (gtk-toolbar-set-tooltips ((toolbar c-pointer) - (enable boolean))) - (gtk-toolbar-set-style ((toolbar c-pointer) - (style int))) - - ;;tooltips - (gtk-tooltips-new () - c-pointer) - (gtk-tooltips-set-tip ((tooltips c-pointer) - (widget c-pointer) - (tip-text c-pointer) - (tip-private c-string))) - (gtk-tooltips-enable ((tooltips c-pointer))) - (gtk-tooltips-disable ((tooltips c-pointer))) - (gtk-tooltips-set-delay ((tooltips c-pointer) - (delay uint))) - ;;tool-item - (gtk-tool-item-new () - c-pointer) - (gtk-tool-item-set-homogeneous ((tool-item c-pointer) - (homogeneous boolean))) - (gtk-tool-item-set-expand ((tool-item c-pointer) - (expand boolean))) - (gtk-tool-item-set-tooltip ((tool-item c-pointer) - (tooltips c-pointer) - (tip-text c-string) - (tip-private c-string))) - (gtk-tool-item-set-is-important ((tool-item c-pointer) - (is-important boolean))) - - (gtk-separator-tool-item-new () - c-pointer) - (gtk-separator-tool-item-set-draw ((item c-pointer) - (draw boolean))) - - ;;tool-button - (gtk-tool-button-new ((icon-widget c-pointer) - (label c-pointer)) - c-pointer) - (gtk-tool-button-new-from-stock ((stock-id c-string)) - c-pointer) - (gtk-tool-button-set-label ((tool-button c-pointer) - (label c-pointer))) - (gtk-tool-button-set-use-underline ((tool-button c-pointer) - (use-underline boolean))) - (gtk-tool-button-set-stock-id ((tool-button c-pointer) - (stock-id c-string))) - (gtk-tool-button-set-icon-widget ((tool-button c-pointer) - (icon-widget c-pointer))) - (gtk-tool-button-set-label-widget ((tool-button c-pointer) - (label-widget c-pointer))) - - ;;menu - (gtk-menu-shell-append ((menu-shell c-pointer) - (child c-pointer))) - (gtk-menu-shell-prepend ((menu-shell c-pointer) - (child c-pointer))) - (gtk-menu-shell-insert ((menu-shell c-pointer) - (child c-pointer) - (position int))) - - (gtk-menu-bar-new () - c-pointer) - - (gtk-menu-new () - c-pointer) - (gtk-menu-set-title ((menu c-pointer) - (title c-string))) - (gtk-menu-attach ((menu c-pointer) - (child c-pointer) - (lattach uint) - (rattach uint) - (tattach uint) - (battach uint))) - (gtk-menu-attach-to-widget ((menu c-pointer) - (widget c-pointer) - (func #.(callback-function ((widget c-pointer) - (menu c-pointer)))))) - - (gtk-menu-popup ((menu c-pointer) - (p-menu-shell c-pointer) - (p-menu-item c-pointer) - (func #.(callback-function ((menu c-pointer) - (x (c-ptr int)) - (y (c-ptr int)) - (push-in (c-ptr boolean)) - (data c-pointer)))) - (data c-pointer) - (button uint) - (activate-time uint32))) - - (gtk-menu-item-new () - c-pointer) - (gtk-menu-item-new-with-label ((label c-string)) - c-pointer) - (gtk-menu-item-set-right-justified ((menu-item c-pointer) - (right-justified boolean))) - (gtk-menu-item-set-submenu ((menu-item c-pointer) - (submenu c-pointer))) - (gtk-menu-item-remove-submenu ((menu-item c-pointer))) - (gtk-menu-item-set-accel-path ((menu-item c-pointer) - (acell-path c-pointer))) - (gtk-accel-map-add-entry ((accel-path c-pointer) - (accel-key uint) - (accel-mods int))) - - (gtk-check-menu-item-new () - c-pointer) - (gtk-check-menu-item-new-with-label ((label c-string)) - c-pointer) - (gtk-check-menu-item-set-active ((check-menu c-pointer) - (active boolean))) - (gtk-check-menu-item-get-active ((check-menu c-pointer)) - boolean) - - (gtk-radio-menu-item-new ((group c-pointer)) - c-pointer) - (gtk-radio-menu-item-new-from-widget ((group c-pointer)) - c-pointer) - (gtk-radio-menu-item-new-with-label ((group c-pointer) - (label c-string)) - c-pointer) - (gtk-radio-menu-item-new-with-label-from-widget ((radio c-pointer) - (label c-string)) - c-pointer) - (gtk-radio-menu-item-get-group ((radio c-pointer)) - c-pointer) - - (gtk-image-menu-item-new () - c-pointer) - (gtk-image-menu-item-new-with-label ((label c-string)) - c-pointer) - (gtk-image-menu-item-new-from-stock ((stock-id c-string) - (accel-group c-pointer)) - c-pointer) - (gtk-image-menu-item-set-image ((menu-item c-pointer) - (image c-pointer))) - - - (gtk-separator-menu-item-new () - c-pointer) - (gtk-tearoff-menu-item-new () - c-pointer) - - ;;calendar - (gtk-calendar-new () - c-pointer) - (gtk-calendar-get-date ((cal c-pointer) - (year c-pointer) - (month c-pointer) - (day c-pointer))) - (gtk-calendar-select-month ((cal c-pointer) - (month uint) - (year uint)) - int) - (gtk-calendar-select-day ((cal c-pointer) - (day uint))) - - ;;arrow - (gtk-arrow-new ((arrow-type int) - (shadow-type int)) - c-pointer) - (gtk-arrow-set ((arrow c-pointer) - (arrow-type int) - (shadow-type int))) - - ;;dialog - (gtk-dialog-new () - c-pointer) - (gtk-dialog-run ((dialog c-pointer)) - int) - (gtk-dialog-response ((dialog c-pointer) - (response-id int))) - (gtk-dialog-add-button ((dialog c-pointer) - (button-text c-string) - (response-id int)) - c-pointer) - (gtk-dialog-add-action-widget ((dialog c-pointer) - (child c-pointer) - (response-id c-pointer))) - (gtk-dialog-set-has-separator ((dialog c-pointer) - (has-separator boolean))) - (gtk-dialog-set-default-response ((dialog c-pointer) - (response-id int))) - ;;message-dialog - (gtk-message-dialog-new ((parent c-pointer) - (flags int) - (type int) - (buttons int) - (message c-string)) - c-pointer) - (gtk-message-dialog-set-markup ((dialog c-pointer) - (str c-string))) - ;;file-chooser - (gtk-file-chooser-set-action ((chooser c-pointer) - (action int))) - (gtk-file-chooser-set-local-only ((chooser c-pointer) - (local-only boolean))) - (gtk-file-chooser-set-select-multiple ((chooser c-pointer) - (select-multiple boolean))) - (gtk-file-chooser-set-current-name ((chooser c-pointer) - (name c-string))) - (gtk-file-chooser-set-filename ((chooser c-pointer) - (filename c-string)) - boolean) - (gtk-file-chooser-get-filename ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-get-filenames ((chooser c-pointer)) - c-pointer) - (gtk-file-chooser-set-current-folder ((chooser c-pointer) - (folder c-string)) - boolean) - (gtk-file-chooser-get-current-folder ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-set-uri ((chooser c-pointer) - (uri c-string)) - boolean) - (gtk-file-chooser-get-uri ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-select-uri ((chooser c-pointer)) - boolean) - (gtk-file-chooser-get-uris ((chooser c-pointer)) - c-pointer) - (gtk-file-chooser-set-current-folder-uri ((chooser c-pointer) - (folder c-string)) - boolean) - (gtk-file-chooser-get-current-folder-uri ((chooser c-pointer)) - c-string :malloc-free) - (gtk-file-chooser-set-use-preview-label ((chooser c-pointer) - (use-label boolean))) - (gtk-file-chooser-add-filter ((chooser c-pointer) - (filter c-pointer))) - (gtk-file-chooser-set-filter ((chooser c-pointer) - (filter c-pointer))) - ;;file-chooser-widget - (gtk-file-chooser-widget-new ((action int)) - c-pointer) - ;;file-chooser-dialog - (gtk-file-chooser-dialog-new ((title c-string) - (parent c-pointer) - (action int) - (cancel-text c-string) - (cancel-response-id int) - (accept-text c-string) - (accept-response-id int) - (null c-pointer)) - c-pointer) - - ;;file-filter - (gtk-file-filter-new () - c-pointer) - (gtk-file-filter-set-name ((filter c-pointer) - (name c-string))) - (gtk-file-filter-add-mime-type ((filter c-pointer) - (mime-type c-string))) - (gtk-file-filter-add-pattern ((filter c-pointer) - (pattern c-string))) - - ;;text-view - (gtk-text-view-new () - c-pointer) - (gtk-text-view-set-buffer ((text-view c-pointer) - (buffer c-pointer))) - - ;;text-buffer - (gtk-text-buffer-new ((table c-pointer)) - c-pointer) - (gtk-text-buffer-set-text ((buffer c-pointer) - (text c-pointer) - (len int))) - - ;;text-tag-table - (gtk-text-tag-table-new () - c-pointer) - - ;;accel-group - (gtk-accel-group-new () - c-pointer) - - ;;ui-manager - (gtk-ui-manager-new () - c-pointer) - (gtk-ui-manager-set-add-tearoffs ((ui-manager c-pointer) - (add-tearoffs boolean))) - (gtk-ui-manager-insert-action-group ((ui-manager c-pointer) - (action-group c-pointer) - (pos int))) - (gtk-ui-manager-get-toplevels ((ui-manager c-pointer) - (types int)) - c-pointer) - - ;;action-group - (gtk-action-group-new ((name c-string)) - c-pointer) - (gtk-action-group-set-sensitive ((action-group c-pointer) - (sensitive boolean))) - (gtk-action-group-set-visible ((action-group c-pointer) - (visible boolean))) - (gtk-action-group-add-action ((action-group c-pointer) - (action c-pointer))) - (gtk-action-group-remove-action ((action-group c-pointer) - (action c-pointer))) - (gtk-action-group-add-action-with-accel ((action-group c-pointer) - (action c-pointer) - (accel c-string))) - ;;action - (gtk-action-new ((name c-string) - (label c-pointer) - (tooltip c-pointer) - (stock-id c-string)) - c-pointer) - - (gtk-event-box-new () - c-pointer) - (gtk-event-box-set-above-child ((event-box c-pointer) - (above boolean))) - (gtk-event-box-set-visible-window ((event-box c-pointer) - (visible-window boolean))) - -) + (declare (ignore #-clisp arguments #-clisp return-type)) + #+clisp `'(c-function + ,@(when arguments `((:arguments ,@arguments))) + (:return-type ,(ffi-to-uffi-type return-type)) + (:language :stdc)) + #-clisp `'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 + (list name + (intern (string-upcase + (format nil "~a-supplied-p" name))) + (ffi-to-uffi-type type)))))) + `(progn + (uffi:def-struct ,struct-name + ,@(loop for (name nil type) in slot-defs + collecting (list name type))) + ;; --- make-<struct-name> --- + ,(let ((obj (gensym))) + `(defun ,(intern (string-upcase (format nil "make-~a" struct-name))) + (&key ,@(loop for (name supplied nil) in slot-defs + collecting (list name nil supplied))) + (let ((,obj (allocate-foreign-object ',struct-name))) + ,@(loop for (name supplied nil) in slot-defs + collecting `(when ,supplied + (setf (get-slot-value ,obj ',struct-name ',name) ,name))) + ,obj))) + + ;; --- accessors --- + ,@(mapcar (lambda (slot-def &aux + (slot-name (car slot-def)) + (accessor (intern (format nil "~a-~a" struct-name slot-name)))) + `(progn + (defun ,accessor (self) + (get-slot-value self ',struct-name ',slot-name)) + (defun (setf ,accessor) (new-value self) + (setf (get-slot-value self ',struct-name ',slot-name) + new-value)))) + slot-defs)))) (def-c-struct gdk-event-button (type int) @@ -1098,43 +265,52 @@ (32 :window_state) (33 :setting))) -(defun gtk-signal-connect (widget signal fun &key (after t) data destroy-data) - (g-signal-connect-closure widget signal (g-cclosure-new fun data destroy-data) after)) -(defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data) - (g-signal-connect-closure widget signal (g-cclosure-new-swap fun data destroy-data) after)) -(defun gtk-object-set-property (obj property val-type val) - (let ((varargs-def - `(c-struct list - (value ,val-type) - (end c-pointer)))) - (with-c-var (vec varargs-def (list val nil)) - (g-object-set-valist obj property (c-var-address (slot vec 'value)))))) +#-clisp +(uffi:def-struct list-boolean + (value :unsigned-int) + (end :pointer-void)) + (defmacro with-gtk-string ((var string) &rest body) - (let ((char-count (gensym)) - (byte-count (gensym))) - `(ffi:with-foreign-string (,var ,char-count ,byte-count ,string :encoding charset:utf-8) - ,@body))) - -(defun get-gtk-string (pointer) - (with-c-var (bytes-writen 'uint 0) - (g-locale-from-utf8 pointer -1 nil (c-var-address bytes-writen) nil))) - -(defun to-gtk-string (str) - "!!!! remember to free returned str pointer" - (with-c-var (bytes-writen 'uint 0) - (g-locale-to-utf8 str -1 nil (c-var-address bytes-writen) nil))) - -(defmacro with-gdk-threads (&rest body) - `(unwind-protect - (progn - (gdk-threads-enter) - ,@body) - (gdk-threads-leave))) - - + `(let ((,var ,string)) + ,@body) + #+not + `(let ((,var (to-gtk-string ,string))) + (unwind-protect + (progn ,@body) + (g-free ,var)))) + +(defun value-set-function (type) + (ecase type + (c-string #'g-value-set-string) + (c-pointer #'g-value-set-string) ;; string-pointer + (integer #'g-value-set-int) + (single-float #'g-value-set-float) + (double-float #'g-value-set-double) + (boolean #'g-value-set-boolean))) + +(defun value-type-as-int (type) + (ecase type + (c-string (* 16 4)) + (c-pointer (* 16 4)) ;; string-pointer + (integer (* 6 4)) + (single-float (* 14 4)) + (double-float (* 15 4)) + (boolean (* 5 4)))) + +(def-c-struct type-val + (type long) + (val double-float) + (val2 double-float)) + +(def-c-struct gtk-tree-iter + (stamp int) + (user-data c-pointer) + (user-data2 c-pointer) + (user-data3 c-pointer)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defun as-gtk-type-name (type) @@ -1158,155 +334,33 @@ (:double (* 15 4)) (:boolean (* 5 4))))) -(defun gtk-widget-set-popup (widget menu) - (gtk-signal-connect-swap widget "button-press-event" - #'(lambda (widg signal data) - (with-c-var (event 'c-pointer signal) - (when (eql (event-type (cast event '(c-ptr int))) :button_press) - (let ((event-button (cast event '(c-ptr gdk-event-button)))) - (when (= (gdk-event-button-button event-button) 3) - (gtk-menu-popup widg nil nil nil nil - (gdk-event-button-button event-button) - (gdk-event-button-time event-button))))))) - :data menu)) - -(defun gtk-list-store-new (col-types) - (gtk-list-store-newv (length col-types) (apply #'vector (mapcar #'as-gtk-type col-types)))) - -(defun gtk-list-store-set (lstore iter types-lst data-lst) - (with-c-var (value '(c-struct list (type c-pointer) (val c-pointer)) (list nil nil)) - (loop for col from 0 - for data in data-lst - for type in types-lst - for str-ptr = (when (or (eql type :string) (eql type :icon)) (to-gtk-string data)) do - (g-value-init (c-var-address value) (as-gtk-type type)) - (funcall (intern (format nil "G-VALUE-SET-~a" (case type - (:date 'float) - (:icon 'string) - (t type))) - :gtk-ffi) - (c-var-address value) - (or str-ptr (and (eql type :date) (coerce data 'single-float)) data)) - (gtk-list-store-set-value lstore iter col (c-var-address value)) - (g-value-unset (c-var-address value)) - (when str-ptr (g-free str-ptr))))) - -(defun gtk-list-store-set-items (store types-lst data-lst) - (with-c-var (iter 'gtk-tree-iter (make-gtk-tree-iter :stamp 0)) - (dolist (item data-lst) - (gtk-list-store-append store (c-var-address iter)) - (gtk-list-store-set store (c-var-address iter) types-lst item)))) - -(defun gtk-tree-store-new (col-types) - (gtk-tree-store-newv (length col-types) (apply #'vector (mapcar #'as-gtk-type col-types)))) - -(defun gtk-tree-store-set (tstore iter types-lst data-lst) - (with-c-var (value '(c-struct list (type c-pointer) (val c-pointer)) (list nil nil)) - (loop for col from 0 - for data in data-lst - for type in types-lst - for str-ptr = (when (or (eql type :string) (eql type :icon)) (to-gtk-string data)) do - (g-value-init (c-var-address value) (as-gtk-type type)) - (funcall (intern (format nil "G-VALUE-SET-~a" (case type - (:date 'float) - (:icon 'string) - (t type))) - :gtk-ffi) - (c-var-address value) - (or str-ptr (and (eql type :date) (coerce data 'single-float)) data)) - (gtk-tree-store-set-value tstore iter col (c-var-address value)) - (g-value-unset (c-var-address value)) - (when str-ptr (g-free str-ptr))))) - -(defun gtk-tree-store-set-kids (model val-tree par-iter index column-types items-factory &optional path) - (with-c-var (iter 'gtk-ffi::gtk-tree-iter (gtk-ffi::make-gtk-tree-iter :stamp 0)) - (gtk-ffi::gtk-tree-store-append model (c-var-address iter) par-iter) - (gtk-ffi::gtk-tree-store-set model (c-var-address iter) - column-types - (append - (funcall items-factory val-tree) - (list (format nil "(~{~d ~})" (reverse (cons index path)))))) - (when (subtypep (class-name (class-of val-tree)) 'cells:family) - (loop for sub-tree in (cells:kids val-tree) - for pos from 0 do - (gtk-tree-store-set-kids - model sub-tree (c-var-address iter) pos column-types items-factory (cons index path)))))) - -(defun gtk-tree-model-get-cell (model iter column-no cell-type) - (with-c-var (item 'c-pointer) - (gtk-tree-model-get model iter - column-no - (c-var-address item) -1) - (prog1 - (cast item (as-gtk-type-name cell-type)) - (g-free (c-var-address item))))) - -(defun parse-cell-attrib (attribs) - (loop for (attrib val) on attribs by #'cddr collect - (ecase attrib - (:foreground (list "foreground" 'c-string val)) - (:background (list "background" 'c-string val)) - (:font (list "font" 'c-string val)) - (:size (list "size-points" 'double-float (coerce val 'double-float))) - (:strikethrough (list "strikethrough" 'boolean val))))) - -(defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - #'(lambda (tree-column cell-renderer model iter 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)))) - (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)) - (strs)) - (loop with lst-address = glist - while (not (null lst-address)) do - (with-c-var (lst-struct-pointer 'c-pointer lst-address) - (let ((lst-struct (cast lst-struct-pointer '(c-ptr gslist)))) - (with-c-var (lst-data-pointer 'c-pointer (slot-value lst-struct 'data)) - (let ((lst-data (cast lst-data-pointer 'c-string))) - (push lst-data strs) - (g-free lst-data-pointer)) - (setf lst-address (slot-value lst-struct 'next)))))) - (g-slist-free glist) - (nreverse strs))) - -(export '(gtk-signal-connect gtk-signal-connect-swap gtk-object-set-property - with-gtk-string get-gtk-string to-gtk-string with-gdk-threads - gtk-widget-set-popup - 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)) + + +(defun col-type-to-ffi-type (col-type) + (cdr (assoc col-type '((:string . c-pointer) + (:icon . c-pointer) + (:boolean . boolean) + (:int . int) + (:long . long) + (:date . single-float) + (:float . single-float) + (:double . double-float))))) + +(defmacro deref-pointer-runtime-typed (ptr type) + "Returns a object pointed" + (declare (ignorable type)) + #+(or cmu sbcl lispworks scl) (declare (ignore type)) + #+(or cmu scl) `(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)) + ) + +(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* + col-type-to-ffi-type deref-pointer-runtime-typed gtk-tree-iter)))

1 0