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)))