[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
Kenny Tilton
ktilton at common-lisp.net
Sun Dec 5 05:11:41 UTC 2004
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))
+ , at 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 , at 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 , at arguments)))
+ (:return-type ,return-type ,return-type-allocation)
+ (:language :stdc))
+ (eval-when (compile load eval)
+ (print `(exporting ,name))
+ (export ',name)))
+ #-clisp
+ (let ((arg-info
+ (loop for arg in arguments
+ for gsym = (gensym)
+ 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 , at 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 , at 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)
- , at 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)
- , at body)
- (gdk-threads-leave)))
-
-
+ `(let ((,var ,string))
+ , at body)
+ #+not
+ `(let ((,var (to-gtk-string ,string)))
+ (unwind-protect
+ (progn , at 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)))
More information about the Cells-gtk-cvs
mailing list