From ktilton at common-lisp.net Sun Dec 5 06:31:18 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 5 Dec 2004 07:31:18 +0100 (CET) Subject: [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 Message-ID: <20041205063118.BFD24884A9@common-lisp.net> 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) From ktilton at common-lisp.net Sun Dec 5 06:33:23 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 5 Dec 2004 07:33:23 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/asdf.lisp root/load.lisp Message-ID: <20041205063323.62324884A9@common-lisp.net> 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 ;;; . 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 From ktilton at common-lisp.net Sun Dec 5 06:33:38 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 5 Dec 2004 07:33:38 +0100 (CET) Subject: [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 Message-ID: <20041205063338.DD28C885F4@common-lisp.net> 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 From ktilton at common-lisp.net Sun Dec 5 05:11:41 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 5 Dec 2004 06:11:41 +0100 (CET) Subject: [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 Message-ID: <20041205051141.11BE6884A9@common-lisp.net> 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- --- + ,(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))) From ktilton at common-lisp.net Sun Dec 5 06:33:31 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 5 Dec 2004 07:33:31 +0100 (CET) Subject: [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 Message-ID: <20041205063331.C8B50884A9@common-lisp.net> 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 , at args)) (defmacro def-widget (&rest args) `(def-gtk widget , at 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 - , at 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))) - , at outputs - , at signals-outputs))))) + (defmodel ,class ,(or superclasses (list gtk-superclass)) + (,@(append std-slots slots signals-slots)) + (:default-initargs + :def-gtk-class-name ',class + , at 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)))) + , at outputs + , at signals-outputs))))) (defmacro callback ((widg event data) &body body) + #+clisp `(c? (without-c-dependency #'(lambda (,widg ,event ,data) - (declare (ignorable ,widg ,event ,data)) - , at body t)))) + (declare (ignorable ,widg ,event ,data)) + , at body t))) + #-clisp + `(lambda (self ,widg ,event ,data) + (declare (ignorable self ,widg ,event ,data)) + , at 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)) - , at body t))))) + #+clisp (without-c-dependency #'(lambda (,widg ,event ,data) + (declare (ignorable ,widg ,event ,data)) + , at body t)) + #-clisp (lambda (self ,widg ,event ,data) + (declare (ignorable self ,widg ,event ,data)) + , at 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))) From ktilton at common-lisp.net Mon Dec 6 20:03:09 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:03:09 +0100 (CET) Subject: [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 Message-ID: <20041206200309.5359E880A8@common-lisp.net> 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) From ktilton at common-lisp.net Mon Dec 6 20:04:17 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:04:17 +0100 (CET) Subject: [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 Message-ID: <20041206200417.5C8F6880A8@common-lisp.net> 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 "~>k-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 @@ , at body t))) #-clisp `(lambda (self ,widg ,event ,data) - (declare (ignorable self ,widg ,event ,data)) - , at body t)) + (declare (ignorable self ,widg ,event ,data)) + (print (list :callback self ,widg ,event ,data)) + (prog1 + (progn + , at 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 @@ , at body t)) #-clisp (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - , at body t)))) + (print (list :callback self ,widg ,event ,data)) + , at 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))) From ktilton at common-lisp.net Mon Dec 6 20:04:24 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:04:24 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-buttons.lisp root/cells-gtk/test-gtk/test-gtk.lisp Message-ID: <20041206200424.47873880A8@common-lisp.net> 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) From ktilton at common-lisp.net Mon Dec 6 20:11:09 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:11:09 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: Module imported: clisp-cgtk Message-ID: <20041206201109.9FF55880A8@common-lisp.net> 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 From ktilton at common-lisp.net Mon Dec 6 20:21:27 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:21:27 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: Directory change: clisp-cgtk/cells-gtk Message-ID: <20041206202127.4B723880A8@common-lisp.net> 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 From ktilton at common-lisp.net Mon Dec 6 20:21:32 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:21:32 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: Directory change: clisp-cgtk/gtk-ffi Message-ID: <20041206202132.AD8B2884F7@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv26517/gtk-ffi Log Message: Directory /project/cells-gtk/cvsroot/clisp-cgtk/gtk-ffi added to the repository Date: Mon Dec 6 21:21:30 2004 Author: ktilton New directory clisp-cgtk/gtk-ffi added From ktilton at common-lisp.net Mon Dec 6 20:21:38 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:21:38 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: Directory change: clisp-cgtk/test-images Message-ID: <20041206202138.3BFA0880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/test-images In directory common-lisp.net:/tmp/cvs-serv26517/test-images Log Message: Directory /project/cells-gtk/cvsroot/clisp-cgtk/test-images added to the repository Date: Mon Dec 6 21:21:34 2004 Author: ktilton New directory clisp-cgtk/test-images added From ktilton at common-lisp.net Mon Dec 6 20:21:51 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:21:51 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: Directory change: clisp-cgtk/cells-gtk/test-gtk Message-ID: <20041206202151.58F30880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv26550/test-gtk Log Message: Directory /project/cells-gtk/cvsroot/clisp-cgtk/cells-gtk/test-gtk added to the repository Date: Mon Dec 6 21:21:50 2004 Author: ktilton New directory clisp-cgtk/cells-gtk/test-gtk added From ktilton at common-lisp.net Mon Dec 6 20:23:20 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:23:20 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: clisp-cgtk/INSTALL.TXT clisp-cgtk/load.lisp Message-ID: <20041206202320.D7849880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk In directory common-lisp.net:/tmp/cvs-serv26581 Added Files: INSTALL.TXT load.lisp Log Message: Moving Vasilis's original for CLisp from Cells project to Cells-gtk Date: Mon Dec 6 21:23:19 2004 Author: ktilton From ktilton at common-lisp.net Mon Dec 6 20:23:36 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:23:36 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: clisp-cgtk/cells-gtk/actions.lisp clisp-cgtk/cells-gtk/addon.lisp clisp-cgtk/cells-gtk/buttons.lisp clisp-cgtk/cells-gtk/callback.lisp clisp-cgtk/cells-gtk/cells-gtk.asd clisp-cgtk/cells-gtk/cells-gtk.lisp clisp-cgtk/cells-gtk/dialogs.lisp clisp-cgtk/cells-gtk/display.lisp clisp-cgtk/cells-gtk/entry.lisp clisp-cgtk/cells-gtk/gtk-app.lisp clisp-cgtk/cells-gtk/layout.lisp clisp-cgtk/cells-gtk/menus.lisp clisp-cgtk/cells-gtk/textview.lisp clisp-cgtk/cells-gtk/tree-view.lisp clisp-cgtk/cells-gtk/widgets.lisp Message-ID: <20041206202336.0011E880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/cells-gtk In directory common-lisp.net:/tmp/cvs-serv26581/cells-gtk Added Files: actions.lisp addon.lisp buttons.lisp callback.lisp cells-gtk.asd 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: Moving Vasilis's original for CLisp from Cells project to Cells-gtk Date: Mon Dec 6 21:23:21 2004 Author: ktilton From ktilton at common-lisp.net Mon Dec 6 20:23:54 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:23:54 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: clisp-cgtk/cells-gtk/test-gtk/test-addon.lisp clisp-cgtk/cells-gtk/test-gtk/test-buttons.lisp clisp-cgtk/cells-gtk/test-gtk/test-dialogs.lisp clisp-cgtk/cells-gtk/test-gtk/test-display.lisp clisp-cgtk/cells-gtk/test-gtk/test-entry.lisp clisp-cgtk/cells-gtk/test-gtk/test-gtk.asd clisp-cgtk/cells-gtk/test-gtk/test-gtk.lisp clisp-cgtk/cells-gtk/test-gtk/test-layout.lisp clisp-cgtk/cells-gtk/test-gtk/test-menus.lisp clisp-cgtk/cells-gtk/test-gtk/test-textview.lisp clisp-cgtk/cells-gtk/test-gtk/test-tree-view.lisp Message-ID: <20041206202354.685AE880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv26581/cells-gtk/test-gtk Added Files: test-addon.lisp test-buttons.lisp test-dialogs.lisp test-display.lisp test-entry.lisp test-gtk.asd test-gtk.lisp test-layout.lisp test-menus.lisp test-textview.lisp test-tree-view.lisp Log Message: Moving Vasilis's original for CLisp from Cells project to Cells-gtk Date: Mon Dec 6 21:23:38 2004 Author: ktilton From ktilton at common-lisp.net Mon Dec 6 20:24:00 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:24:00 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: clisp-cgtk/gtk-ffi/gtk-ffi.asd clisp-cgtk/gtk-ffi/gtk-ffi.lisp Message-ID: <20041206202400.366B1880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv26581/gtk-ffi Added Files: gtk-ffi.asd gtk-ffi.lisp Log Message: Moving Vasilis's original for CLisp from Cells project to Cells-gtk Date: Mon Dec 6 21:23:55 2004 Author: ktilton From ktilton at common-lisp.net Mon Dec 6 20:24:07 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Mon, 6 Dec 2004 21:24:07 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: clisp-cgtk/test-images/Thumbs.db clisp-cgtk/test-images/small.png clisp-cgtk/test-images/splash.png clisp-cgtk/test-images/tst.gif Message-ID: <20041206202407.646B6880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/clisp-cgtk/test-images In directory common-lisp.net:/tmp/cvs-serv26581/test-images Added Files: Thumbs.db small.png splash.png tst.gif Log Message: Moving Vasilis's original for CLisp from Cells project to Cells-gtk Date: Mon Dec 6 21:24:01 2004 Author: ktilton From ktilton at common-lisp.net Tue Dec 7 21:01:05 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 7 Dec 2004 22:01:05 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lpr root/cells-gtk/test-gtk/test-gtk.lisp Message-ID: <20041207210105.EFB4F884F7@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv2510/cells-gtk/test-gtk Modified Files: test-gtk.lisp Added Files: test-gtk.lpr Log Message: Move cells-gtk from Cells project to Cells-gtk project on common-lisp.net Date: Tue Dec 7 22:00:59 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.3 root/cells-gtk/test-gtk/test-gtk.lisp:1.4 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.3 Mon Dec 6 21:04:17 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Tue Dec 7 22:00:57 2004 @@ -13,7 +13,7 @@ :position :center :splash-screen-image "/000000/root/test-images/splash.png" :width 550 :height 550 - :kids (let ((tabs '("Buttons" ;"Display" "Layout" "Menus" + :kids (let ((tabs '("Buttons" ;;"Display" "Layout" "Menus" ;"Entry" ;"Textview" "Dialogs" "Addon" ;"Tree-view" From ktilton at common-lisp.net Tue Dec 7 21:01:11 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 7 Dec 2004 22:01:11 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.lpr Message-ID: <20041207210111.13396884F9@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv2510/cells-gtk Added Files: cells-gtk.lpr Log Message: Move cells-gtk from Cells project to Cells-gtk project on common-lisp.net Date: Tue Dec 7 22:01:06 2004 Author: ktilton From ktilton at common-lisp.net Tue Dec 14 04:01:57 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 14 Dec 2004 05:01:57 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/actions.lisp root/cells-gtk/buttons.lisp root/cells-gtk/cells-gtk.asd root/cells-gtk/entry.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/layout.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp Message-ID: <20041214040157.E61FC8850A@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv11104/cells-gtk Modified Files: actions.lisp buttons.lisp cells-gtk.asd entry.lisp gtk-app.lisp layout.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:01:51 2004 Author: ktilton Index: root/cells-gtk/actions.lisp diff -u root/cells-gtk/actions.lisp:1.1 root/cells-gtk/actions.lisp:1.2 --- root/cells-gtk/actions.lisp:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/actions.lisp Tue Dec 14 05:01:51 2004 @@ -48,7 +48,7 @@ (gtk-ffi::gtk-action-group-remove-action (id self) (id kid))) (dolist (kid new-value) (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid))) - (call-next-method)) + #+clisp (call-next-method)) (def-object ui-manager () ((action-groups :accessor action-groups :initform (c-in nil)) Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.3 root/cells-gtk/buttons.lisp:1.4 --- root/cells-gtk/buttons.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/buttons.lisp Tue Dec 14 05:01:51 2004 @@ -37,7 +37,8 @@ (def-c-output .kids ((self button)) (assert-bin self) (dolist (kid (kids self)) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-c-output stock ((self button)) (when new-value @@ -93,4 +94,5 @@ (def-c-output .md-value ((self radio-button)) (when (and new-value (upper self box)) - (setf (md-value (upper self box)) (md-name self)))) + (setf (md-value (upper self box)) (md-name self))) + #+clisp (call-next-method)) Index: root/cells-gtk/cells-gtk.asd diff -u root/cells-gtk/cells-gtk.asd:1.1 root/cells-gtk/cells-gtk.asd:1.2 --- root/cells-gtk/cells-gtk.asd:1.1 Fri Nov 19 00:39:53 2004 +++ root/cells-gtk/cells-gtk.asd Tue Dec 14 05:01:51 2004 @@ -5,14 +5,14 @@ :components ((:file "cells-gtk") (:file "widgets") - (:file "layout") - (:file "display") - (:file "buttons") - (:file "entry") - (:file "tree-view") - (:file "menus") - (:file "dialogs") - (:file "textview") - (:file "addon") + (:file "layout" :depends-on ("widgets")) + (:file "display" :depends-on ("widgets")) + (:file "buttons" :depends-on ("widgets")) + (:file "entry" :depends-on ("widgets")) + (:file "tree-view" :depends-on ("widgets")) + (:file "menus" :depends-on ("widgets")) + (:file "dialogs" :depends-on ("widgets")) + (:file "textview" :depends-on ("widgets")) + (:file "addon" :depends-on ("widgets")) (:file "gtk-app") -)) + )) Index: root/cells-gtk/entry.lisp diff -u root/cells-gtk/entry.lisp:1.2 root/cells-gtk/entry.lisp:1.3 --- root/cells-gtk/entry.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/entry.lisp Tue Dec 14 05:01:51 2004 @@ -23,6 +23,14 @@ (model) ()) +#+no +(def-gtk widget entry nil + ((auto-update :accessor auto-update :initarg :auto-aupdate :initform nil) + (completion :accessor completion :initarg :completion :initform nil) + (text :accessor text :initarg :text :initform (c-in nil)) + (init :accessor init :initarg :init :initform nil)) + (editable has-frame max-length) (changed activate)) + (def-widget entry () ((auto-update :accessor auto-update :initarg :auto-aupdate :initform nil) (completion :accessor completion :initarg :completion :initform nil) Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.3 root/cells-gtk/gtk-app.lisp:1.4 --- root/cells-gtk/gtk-app.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/gtk-app.lisp Tue Dec 14 05:01:51 2004 @@ -97,6 +97,9 @@ *gtk-global-callbacks* 16)) (defun gtk-global-callback-funcall (n) + (trc nil "gtk-global-callback-funcall >" n + *gtk-global-callbacks* + (when n (aref *gtk-global-callbacks* n))) (funcall (aref *gtk-global-callbacks* n))) (defun cells-gtk-init () Index: root/cells-gtk/layout.lisp diff -u root/cells-gtk/layout.lisp:1.2 root/cells-gtk/layout.lisp:1.3 --- root/cells-gtk/layout.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/layout.lisp Tue Dec 14 05:01:51 2004 @@ -30,7 +30,8 @@ (when new-value (dolist (kid new-value) (gtk-box-pack-start (id self) (id kid) - (expand? kid) (fill? kid) (padding? kid))))) + (expand? kid) (fill? kid) (padding? kid))) + #+clisp (call-next-method))) (def-widget hbox (box) () () () @@ -83,7 +84,8 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value)))))))) + :kids (list (cadr new-value))))))) + #+clisp (call-next-method)) (def-widget vpaned () () () ()) @@ -96,7 +98,8 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (list (cadr new-value)))))))) + :kids (list (cadr new-value))))))) + #+clisp (call-next-method)) (def-widget frame () @@ -124,7 +127,8 @@ (def-c-output .kids ((self frame)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-widget aspect-frame (frame) ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -158,7 +162,8 @@ (def-c-output .kids ((self expander)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-widget scrolled-window () () @@ -173,7 +178,8 @@ (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))))) + (gtk-scrolled-window-add-with-viewport (id self) (id kid)))) + #+clisp (call-next-method)) (def-widget notebook () ((tab-labels :accessor tab-labels :initarg :tab-labels :initform nil) @@ -213,7 +219,8 @@ (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)))) + (setf (current-page self) (show-page self))) + #+clisp (call-next-method)) (def-widget alignment () ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -264,4 +271,5 @@ (def-c-output .kids ((self alignment)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.3 root/cells-gtk/menus.lisp:1.4 --- root/cells-gtk/menus.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/menus.lisp Tue Dec 14 05:01:51 2004 @@ -27,7 +27,9 @@ (changed) :new-tail '-text :on-changed (callback (widget event data) + (trc "combo-box onchanged cb" widget event data (id self)) (let ((pos (gtk-combo-box-get-active (id self)))) + (trc "combo-box pos" pos) (setf (md-value self) (and (not (= pos -1)) (nth pos (items self))))))) @@ -87,7 +89,8 @@ (assert-bin self) (when new-value (dolist (kid new-value) - (gtk-container-add (id self) (id kid))))) + (gtk-container-add (id self) (id kid)))) + #+clisp (call-next-method)) (def-widget separator-tool-item (tool-item) () @@ -130,7 +133,8 @@ (def-c-output .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid))))) + (gtk-menu-shell-append (id self) (id kid)))) + #+clisp (call-next-method)) (def-widget menu-bar (menu-shell) () () ()) @@ -192,9 +196,17 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) + (trc "on-toggled" self widget event data) (let ((state (gtk-check-menu-item-get-active widget))) (setf (md-value self) state)))) +#+not +(DEF-GTK WIDGET CHECK-MENU-ITEM (MENU-ITEM) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) + (ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED + (CALLBACK (WIDGET EVENT DATA) (TRC "on-toggled" SELF WIDGET EVENT DATA) + (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) (setf (md-value self) new-value)) @@ -214,7 +226,8 @@ (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)))) + (setf (md-value (upper self menu-item)) (md-name self))) + #+clisp (call-next-method)) (def-widget image-menu-item (menu-item) ((stock :accessor stock :initarg :stock :initform nil) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.3 root/cells-gtk/tree-view.lisp:1.4 --- root/cells-gtk/tree-view.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/tree-view.lisp Tue Dec 14 05:01:51 2004 @@ -117,8 +117,9 @@ (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)))))) + (let ((cb (ff-register-callable 'tree-view-select-handler))) + (trc "tree-view on-select pcb:" cb selected-widget "changed") + (gtk-signal-connect selected-widget "changed" cb)))))) (defmodel listbox (tree-view) () @@ -188,12 +189,13 @@ (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 + (let ((cb (ff-register-callable 'tree-view-render-call-callback))) + (trc "tree-view columns pcb:" cb (id col) :render-cell) (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)) + cb) nil nil) (gtk-tree-view-column-set-sort-column-id (id col) pos) (gtk-tree-view-insert-column (id self) (id col) pos)))) Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.3 root/cells-gtk/widgets.lisp:1.4 --- root/cells-gtk/widgets.lisp:1.3 Mon Dec 6 21:04:12 2004 +++ root/cells-gtk/widgets.lisp Tue Dec 14 05:01:51 2004 @@ -75,8 +75,6 @@ (break "gtk-object-store id ~a known as ~a, not forgettable ~a" hash-id known gtk-object))))) -#+shhh -(maphash (lambda (k v) (print (list k v))) *gtk-objects*) (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) (when *gtk-objects* @@ -102,7 +100,11 @@ ; ------------------------------------------ (defmethod configure ((self gtk-object) gtk-function value) - (apply gtk-function (id self) (if (consp value) value (list value)))) + (apply gtk-function + (id self) + (if (consp value) + value + (list value)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun gtk-function-name (class option) @@ -117,17 +119,27 @@ (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))) - (print (list :def-gtk-event-handler ,(symbol-name event))) + ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) (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 changed) +(def-gtk-event-handler activate) +(def-gtk-event-handler value-changed) +(def-gtk-event-handler day-selected) +(def-gtk-event-handler selection-changed) (def-gtk-event-handler toggled) (def-gtk-event-handler delete-event) - + (defparameter *widget-callbacks* (list (cons 'clicked (ff-register-callable 'clicked-handler)) + (cons 'changed (ff-register-callable 'changed-handler)) + (cons 'activate (ff-register-callable 'activate-handler)) + (cons 'value-changed (ff-register-callable 'value-changed-handler)) + (cons 'day-selected (ff-register-callable 'day-selected-handler)) + (cons 'selection-changed (ff-register-callable 'selection-changed-handler)) (cons 'toggled (ff-register-callable 'toggled-handler)) (cons 'delete-event (ff-register-callable 'delete-event-handler)))) @@ -157,7 +169,6 @@ 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) @@ -169,16 +180,15 @@ into signals-slots-defs collecting `(def-c-output ,slot-name ((self ,class)) (when new-value - #+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*)))))) + (callback-register self + ,(intern (string signal-slot) :keyword) + new-value) + (let ((cb (cdr (assoc ',signal-slot *widget-callbacks*)))) + (assert cb) + #+shhtk (trc "in def-c-output gtk-signal-connect pcb:" + cb ',slot-name (id self)) + (gtk-signal-connect (id self) + ,(string-downcase (string signal-slot)) cb)))) into signals-outputs-defs finally (return (values signals-slots-defs signals-outputs-defs))) `(progn @@ -208,7 +218,7 @@ #-clisp `(lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - (print (list :callback self ,widg ,event ,data)) + ;(print (list :anon-callback self ,widg ,event ,data)) (prog1 (progn , at body @@ -222,24 +232,31 @@ , at body t)) #-clisp (lambda (self ,widg ,event ,data) (declare (ignorable self ,widg ,event ,data)) - (print (list :callback self ,widg ,event ,data)) + ;(print (list :anon-callback-if self ,widg ,event ,data)) , at 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))) + +(ff-defun-callable :cdecl :boolean timeout-handler-callback + ((data (* :int))) + ;;(print (list :timeout-handler-callback data)) + (let* ((id (elti data 0)) + (r2 (gtk-global-callback-funcall id))) + (trc nil "timeout func really returning" r2) + r2)) + (defun timeout-add (milliseconds function) (let ((id (gtk-global-callback-register (lambda () - (print :timeout-add-global) - (with-gdk-threads - (funcall function))))) + ;;(print :timeout-add-global) + (let ((r (with-gdk-threads + (funcall function)))) + (trc nil "timeout func returning" r) + r)))) (c-id (fgn-alloc :int 1))) (setf (elti c-id 0) id) + (trc nil "timeout-add > passing cb data, *data" c-id (elti c-id 0)) (g-timeout-add milliseconds (ff-register-callable 'timeout-handler-callback) c-id))) (def-object widget () @@ -362,7 +379,8 @@ (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)))) + (gtk-container-add (id self) (id kid))) + #+clisp (call-next-method)) (def-widget event-box () ((visible-window :accessor visible-window :initarg :visible-window :initform nil)) @@ -376,7 +394,7 @@ (def-c-output .kids ((self event-box)) (assert-bin self) (when new-value - (gtk-container-add (id self) (id (first new-value))))) - + (gtk-container-add (id self) (id (first new-value)))) + #+clisp (call-next-method)) (eval-when (compile load eval) (export '(callback callback-if timeout-add focus))) From ktilton at common-lisp.net Tue Dec 14 04:02:04 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 14 Dec 2004 05:02:04 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-display.lisp root/cells-gtk/test-gtk/test-gtk.lisp root/cells-gtk/test-gtk/test-gtk.lpr Message-ID: <20041214040204.B6C6C8850A@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv11104/cells-gtk/test-gtk Modified Files: test-display.lisp test-gtk.lisp test-gtk.lpr Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:01:58 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-display.lisp diff -u root/cells-gtk/test-gtk/test-display.lisp:1.2 root/cells-gtk/test-gtk/test-display.lisp:1.3 --- root/cells-gtk/test-gtk/test-display.lisp:1.2 Sun Dec 5 07:33:31 2004 +++ root/cells-gtk/test-gtk/test-display.lisp Tue Dec 14 05:01:57 2004 @@ -1,5 +1,6 @@ (in-package :test-gtk) + (defmodel test-display (vbox) () (:default-initargs @@ -18,7 +19,7 @@ :ratio 1 :kids (list (mk-image :width 200 :height 250 - :filename "/000000/root/test-images/tst.gif"))) + :filename "/00/root/test-images/tst.gif"))) (mk-hseparator) (mk-hbox :kids (list @@ -32,7 +33,6 @@ (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 Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.4 root/cells-gtk/test-gtk/test-gtk.lisp:1.5 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.4 Tue Dec 7 22:00:57 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Tue Dec 14 05:01:57 2004 @@ -11,12 +11,13 @@ ;;:tooltips-enable nil ;;dkwt :icon "test-images/small.png" :position :center - :splash-screen-image "/000000/root/test-images/splash.png" + :splash-screen-image "/00/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" + "Textview" "Dialogs" "Addon" + "Entry" "Tree-view" ))) (list (mk-notebook :tab-labels nil #+not '("Buttons") Index: root/cells-gtk/test-gtk/test-gtk.lpr diff -u root/cells-gtk/test-gtk/test-gtk.lpr:1.1 root/cells-gtk/test-gtk/test-gtk.lpr:1.2 --- root/cells-gtk/test-gtk/test-gtk.lpr:1.1 Tue Dec 7 22:00:58 2004 +++ root/cells-gtk/test-gtk/test-gtk.lpr Tue Dec 14 05:01:57 2004 @@ -17,9 +17,7 @@ (make-instance 'module :name "test-textview.lisp") (make-instance 'module :name "test-addon.lisp")) :projects (list (make-instance 'project-module :name - "c:\\00\\root\\cells-gtk\\cells-gtk") - (make-instance 'project-module :name - "c:\\cell-cultures\\ffi-extender\\ffi-extender")) + "c:\\00\\root\\cells-gtk\\cells-gtk")) :libraries nil :distributed-files nil :project-package-name :test-gtk From ktilton at common-lisp.net Tue Dec 14 04:02:12 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 14 Dec 2004 05:02:12 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.asd root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-ffi.lpr root/gtk-ffi/gtk-menu.lisp root/gtk-ffi/gtk-other.lisp root/gtk-ffi/gtk-utilities.lisp Message-ID: <20041214040212.A610D885E3@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv11104/gtk-ffi Modified Files: gtk-ffi.asd gtk-ffi.lisp gtk-ffi.lpr gtk-menu.lisp gtk-other.lisp gtk-utilities.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:02:05 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.4 root/gtk-ffi/gtk-ffi.asd:1.5 --- root/gtk-ffi/gtk-ffi.asd:1.4 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.asd Tue Dec 14 05:02:05 2004 @@ -1,6 +1,6 @@ (asdf:defsystem :gtk-ffi :name "gtk-ffi" - :depends-on (:cells :uffi :ffi-extender) + :depends-on (:cells :hello-c) :components ((:file "gtk-ffi") (:file "gtk-core" :depends-on ("gtk-ffi")) Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.4 root/gtk-ffi/gtk-ffi.lisp:1.5 --- root/gtk-ffi/gtk-ffi.lisp:1.4 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.lisp Tue Dec 14 05:02:05 2004 @@ -126,8 +126,7 @@ 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 + else collect (car arg) into pass-args finally (return (list (mapcar 'list gsyms arg$s) pass-args))))) `(progn @@ -149,8 +148,9 @@ (if (eql return-type 'boolean) `(not (zerop ,bodyform)) bodyform)) - (print (list ,(symbol-name name) :after - ,@(mapcar 'car arguments))))) + (when *gtk-debug* + (print (list ,(symbol-name name) :after + ,@(mapcar 'car arguments)))))) (eval-when (compile load eval) (export ',name)))))) @@ -305,6 +305,10 @@ (type long) (val double-float) (val2 double-float)) + +(def-c-struct gslist + (data c-pointer) + (next c-pointer)) (def-c-struct gtk-tree-iter (stamp int) Index: root/gtk-ffi/gtk-ffi.lpr diff -u root/gtk-ffi/gtk-ffi.lpr:1.2 root/gtk-ffi/gtk-ffi.lpr:1.3 --- root/gtk-ffi/gtk-ffi.lpr:1.2 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-ffi.lpr Tue Dec 14 05:02:05 2004 @@ -7,13 +7,15 @@ (define-project :name :gtk-ffi :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-core.lisp") + (make-instance 'module :name "gtk-button.lisp") + (make-instance 'module :name "gtk-list-tree.lisp") + (make-instance 'module :name "gtk-menu.lisp") + (make-instance 'module :name "gtk-tool.lisp") + (make-instance 'module :name "gtk-other.lisp") (make-instance 'module :name "gtk-utilities.lisp")) :projects (list (make-instance 'project-module :name - "c:\\000000\\uffi\\uffi") - (make-instance 'project-module :name - "c:\\cell-cultures\\ffi-extender\\ffi-extender")) + "c:\\cell-cultures\\hello-c\\hello-c")) :libraries nil :distributed-files nil :project-package-name :gtk-ffi Index: root/gtk-ffi/gtk-menu.lisp diff -u root/gtk-ffi/gtk-menu.lisp:1.1 root/gtk-ffi/gtk-menu.lisp:1.2 --- root/gtk-ffi/gtk-menu.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-menu.lisp Tue Dec 14 05:02:05 2004 @@ -18,6 +18,17 @@ (in-package :gtk-ffi) +(def-gtk-function :gtk gtk-check-menu-item-set-active :arguments + ((check-menu c-pointer) (active boolean)) + :return-type nil :call-direct t) + +#+test +(def-gtk-lib-functions :gtk + (gtk-check-menu-item-set-active ((check-menu c-pointer) + (active boolean)))) + + + (def-gtk-lib-functions :gtk ;;menu (gtk-menu-shell-append ((menu-shell c-pointer) @@ -76,7 +87,7 @@ c-pointer) (gtk-check-menu-item-new-with-label ((label c-string)) c-pointer) - (gtk-check-menu-item-set-active ((check-menu c-pointer) + #+above (gtk-check-menu-item-set-active ((check-menu c-pointer) (active boolean))) (gtk-check-menu-item-get-active ((check-menu c-pointer)) boolean) Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.1 root/gtk-ffi/gtk-other.lisp:1.2 --- root/gtk-ffi/gtk-other.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-other.lisp Tue Dec 14 05:02:05 2004 @@ -18,6 +18,7 @@ (in-package :gtk-ffi) + (def-gtk-lib-functions :gtk ;; main-loop (gtk-init ((argc (c-ptr-null int)) Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.2 root/gtk-ffi/gtk-utilities.lisp:1.3 --- root/gtk-ffi/gtk-utilities.lisp:1.2 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-utilities.lisp Tue Dec 14 05:02:05 2004 @@ -20,6 +20,7 @@ (in-package :gtk-ffi) (defun gtk-signal-connect (widget signal fun &key (after t) data destroy-data) + #+shhtk (print (list "passing fun to gtk-signal-connect" signal fun)) (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) @@ -28,9 +29,7 @@ (g_signal_connect_data self c-detailed-signal - (if c-handler - (uffi:make-pointer c-handler '(* :void)) - c-null) + (wrap-func c-handler) p4 (or destroy-data c-null) (if after 1 0))))) @@ -40,9 +39,17 @@ (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil) +(defun wrap-func (func-address) + (or func-address 0) + ;;(assert (or (null func-address) (numberp func-address))) + #+nahh + (if func-address + (uffi:make-pointer func-address '(* :void)) + c-null)) + (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)) + (g-cclosure-new-swap (wrap-func fun) data destroy-data) after)) (defun gtk-object-set-property (obj property val-type val) (with-g-value (value) @@ -85,7 +92,9 @@ (defun gtk-widget-set-popup (widget menu) (gtk-signal-connect-swap widget "button-press-event" - (ffx:ff-register-callable 'button-press-event-handler) + (let ((cbl (ffx:ff-register-callable 'button-press-event-handler))) + #+shhtk (print (list "gtk-widget-set-popup connecting callable" widget cbl)) + cbl) :data menu)) (defun gtk-list-store-new (col-types) @@ -160,7 +169,7 @@ for type in types-lst for str-ptr = (when (find type '(:string :icon)) (to-gtk-string data)) - do (print (list value type (as-gtk-type type))) + do (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type (:date 'float) From ktilton at common-lisp.net Tue Dec 14 04:02:14 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 14 Dec 2004 05:02:14 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/load.lisp Message-ID: <20041214040214.BEB108850A@common-lisp.net> Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv11104 Modified Files: load.lisp Log Message: Locking in fixes which make AllegroCL and Lispworks largely work OK before trashing code again. Date: Tue Dec 14 05:02:12 2004 Author: ktilton Index: root/load.lisp diff -u root/load.lisp:1.2 root/load.lisp:1.3 --- root/load.lisp:1.2 Sun Dec 5 07:33:21 2004 +++ root/load.lisp Tue Dec 14 05:02:12 2004 @@ -5,23 +5,22 @@ #+lispworks (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) - (load (make-pathname :directory '(:absolute "000000" "root") + (load (make-pathname :directory '(:absolute "00" "root") :name "asdf" :type "lisp"))) (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")) + (push (make-pathname :directory '(:absolute "cell-cultures" "utils-kt")) + asdf:*central-registry*) + + (push (make-pathname :directory '(:absolute "cell-cultures" "cells")) 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")) + (push (make-pathname :directory '(:absolute "cell-cultures" "hello-c")) asdf:*central-registry*) + (defparameter *cells-gtk-root* + (make-pathname :directory '(:absolute "00" "root"))) + (push (merge-pathnames (make-pathname :directory '(:relative "gtk-ffi")) *cells-gtk-root*) @@ -37,12 +36,11 @@ *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 :utils-kt :force nil) +(Asdf:operate 'asdf:load-op :cells :force nil) +(Asdf:operate 'asdf:load-op :hello-c :force nil) +(Asdf:operate 'asdf:load-op :gtk-ffi :force t) +(Asdf:operate 'asdf:load-op :cells-gtk :force nil) (Asdf:operate 'asdf:load-op :test-gtk :force nil) #+test From ktilton at common-lisp.net Thu Dec 16 04:51:15 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 16 Dec 2004 05:51:15 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp Message-ID: <20041216045115.593F888649@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv27365/cells-gtk Modified Files: cells-gtk.lisp tree-view.lisp widgets.lisp Log Message: Both AllegroCL and Lispworks now run Cells-gtk on win32. Pretty much. All of Vasilis's examples work, with one known fault in Lispworks and bigger problems in AllegroCL in a couple of examples. This means a huge amount works, because vasilis did an extraordinary coverage of Gtk2 in his examples. I be moving on to see if I can score OS/X. Date: Thu Dec 16 05:51:11 2004 Author: ktilton Index: root/cells-gtk/cells-gtk.lisp diff -u root/cells-gtk/cells-gtk.lisp:1.2 root/cells-gtk/cells-gtk.lisp:1.3 --- root/cells-gtk/cells-gtk.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/cells-gtk.lisp Thu Dec 16 05:51:11 2004 @@ -25,11 +25,7 @@ (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) + (with-tree-iter (iter) (gtk-ffi::gtk-tree-store-append model iter par-iter) (gtk-ffi::gtk-tree-store-set model iter column-types Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.4 root/cells-gtk/tree-view.lisp:1.5 --- root/cells-gtk/tree-view.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/tree-view.lisp Thu Dec 16 05:51:11 2004 @@ -102,24 +102,25 @@ (ff-defun-callable :cdecl :int tree-view-select-handler ((column-widget (* :void)) (event (* :void)) (data (* :void))) - (let ((tree-view (gtk-object-find column-widget t))) + (bif (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) - (funcall cb tree-view column-widget event data)))) + (funcall cb tree-view column-widget event data)) + (trc "dude, clean up old widgets after runs" column-widget))) (def-c-output on-select ((self tree-view)) (when new-value (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) - (let ((cb (ff-register-callable 'tree-view-select-handler))) - (trc "tree-view on-select pcb:" cb selected-widget "changed") - (gtk-signal-connect selected-widget "changed" cb)))))) + (selected-clos (gtk-object-find selected-widget))) + (if (not 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) + (let ((cb (ff-register-callable 'tree-view-select-handler))) + (trc "tree-view on-select pcb:" cb selected-widget "changed") + (gtk-signal-connect selected-widget "changed" cb))))))) (defmodel listbox (tree-view) () @@ -171,13 +172,15 @@ (append (column-types self) (list :string)) (items-factory self))))) -(ff-defun-callable :cdecl :int tree-view-render-call-callback +(ff-defun-callable :cdecl :int tree-view-render-cell-callback ((tree-column (* :void)) (cell-renderer (* :void)) (tree-model (* :void)) (iter (* :void)) (data (* :void))) - (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))) + (bif (self (gtk-object-find tree-column)) + (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)) + (trc "dude, clean up old widgets from prior runs" tree-column)) + 1) (def-c-output columns ((self tree-view)) (when new-value @@ -189,7 +192,7 @@ (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 - (let ((cb (ff-register-callable 'tree-view-render-call-callback))) + (let ((cb (ff-register-callable 'tree-view-render-cell-callback))) (trc "tree-view columns pcb:" cb (id col) :render-cell) (callback-register col :render-cell (gtk-tree-view-render-cell pos Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.4 root/cells-gtk/widgets.lisp:1.5 --- root/cells-gtk/widgets.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/widgets.lisp Thu Dec 16 05:51:11 2004 @@ -80,11 +80,11 @@ (when *gtk-objects* (let ((clos-widget (gethash hash-id *gtk-objects*))) (when (and must-find-p (not clos-widget)) - (format t "~>k-object-find> ID ~a not found!!!!!!!" hash-id) + (format t "~>k.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)) + (break "gtk.object.find ID not found ~a" hash-id)) clos-widget))) ;; ----- fake callbackable closures ------------ @@ -120,9 +120,10 @@ `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) ((widget (* :void)) (event (* :void)) (data (* :void))) ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) - (let ((self (gtk-object-find widget t))) + (bif (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) - (funcall cb self widget event data))))) + (funcall cb self widget event data)) + (trc "unknown widget. from prior run. clean up on errors" widget)))) (def-gtk-event-handler clicked) (def-gtk-event-handler changed) From ktilton at common-lisp.net Thu Dec 16 04:51:17 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 16 Dec 2004 05:51:17 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lisp Message-ID: <20041216045117.7CE158864A@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv27365/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: Both AllegroCL and Lispworks now run Cells-gtk on win32. Pretty much. All of Vasilis's examples work, with one known fault in Lispworks and bigger problems in AllegroCL in a couple of examples. This means a huge amount works, because vasilis did an extraordinary coverage of Gtk2 in his examples. I be moving on to see if I can score OS/X. Date: Thu Dec 16 05:51:15 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.5 root/cells-gtk/test-gtk/test-gtk.lisp:1.6 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.5 Tue Dec 14 05:01:57 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Thu Dec 16 05:51:14 2004 @@ -17,7 +17,8 @@ "Display" "Layout" "Menus" "Textview" "Dialogs" "Addon" - "Entry" "Tree-view" + "Entry" + "Tree-view" ))) (list (mk-notebook :tab-labels nil #+not '("Buttons") From ktilton at common-lisp.net Thu Dec 16 04:51:43 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 16 Dec 2004 05:51:43 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-core.lisp root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-utilities.lisp Message-ID: <20041216045143.09B1588649@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv27365/gtk-ffi Modified Files: gtk-core.lisp gtk-ffi.lisp gtk-utilities.lisp Log Message: Both AllegroCL and Lispworks now run Cells-gtk on win32. Pretty much. All of Vasilis's examples work, with one known fault in Lispworks and bigger problems in AllegroCL in a couple of examples. This means a huge amount works, because vasilis did an extraordinary coverage of Gtk2 in his examples. I be moving on to see if I can score OS/X. Date: Thu Dec 16 05:51:18 2004 Author: ktilton Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.1 root/gtk-ffi/gtk-core.lisp:1.2 --- root/gtk-ffi/gtk-core.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-core.lisp Thu Dec 16 05:51:17 2004 @@ -65,22 +65,33 @@ (g-type (:array :int 16))) (defmacro with-g-value ((var) &body body) - `(let ((,var (ffx:fgn-alloc 'g-value 1 :with-g-value ',var))) - (unwind-protect - (progn - (dotimes (n 16) - (setf (int-slot-indexed ,var 'g-value 'g-type n) 0)) - , at body) - (ffx:fgn-free ,var)))) + `(call-with-g-value (lambda (,var) , at body))) + +(defun call-with-g-value (fn) + (let ((gva (ffx:fgn-alloc 'g-value 1 :with-g-value))) + (unwind-protect + (progn + (dotimes (n 16) + ;; (setf (int-slot-indexed ,var 'g-value 'g-type n) 0) + (let ((gv (ff-elt gva 'g-value 0))) + (let ((ns (get-slot-pointer gv 'g-value 'g-type))) + #+lispworks (setf (fli:foreign-aref ns n) 0) + #-lispworks (setf (deref-array ns '(:array :int) n) 0)))) + (funcall fn gva)) + (ffx:fgn-free gva)))) (eval-when (compile load eval) (export 'with-g-value)) -(progn - (def-function ("g_value_init" g_value_init) ((value :pointer-void) (type :unsigned-long)) - :module :glib :call-direct t :returning :pointer-void) - (defun g-value-init (value type) - (g_value_init (or value c-null) type)) - (eval-when (compile load eval) (export 'g-value-init))) + +#+test +(def-gtk-lib-functions :gobject + (g-value-set-string ((value c-pointer) + (str c-string)))) + +#+test +(def-gtk-function :gobject g-value-set-string + :arguments ((value c-pointer) (str c-string)) + :return-type nil :call-direct t) (def-gtk-lib-functions :gobject ;; callbacks @@ -110,12 +121,12 @@ (g-object-set-property ((object c-pointer) (property-name c-string) (value c-pointer))) - #+above (g-value-init ((value c-pointer) + (g-value-init ((value c-pointer) (type ulong)) c-pointer) (g-value-unset ((value c-pointer))) (g-value-set-string ((value c-pointer) - (str c-pointer))) + (str c-string))) (g-value-set-int ((value c-pointer) (int int))) (g-value-set-long ((value c-pointer) Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.5 root/gtk-ffi/gtk-ffi.lisp:1.6 --- root/gtk-ffi/gtk-ffi.lisp:1.5 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-ffi.lisp Thu Dec 16 05:51:17 2004 @@ -316,6 +316,14 @@ (user-data2 c-pointer) (user-data3 c-pointer)) +(defmacro with-tree-iter ((iter-var) &body body) + `(with-foreign-object (,iter-var 'gtk-tree-iter) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'stamp) 0) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data) c-null) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data2) c-null) + (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data3) c-null) + , at body)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defun as-gtk-type-name (type) @@ -342,7 +350,7 @@ (defun col-type-to-ffi-type (col-type) - (cdr (assoc col-type '((:string . c-pointer) + (cdr (assoc col-type '((:string . c-string) ;;2004:12:15-00:17 was c-pointer (:icon . c-pointer) (:boolean . boolean) (:int . int) @@ -369,3 +377,5 @@ (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))) + + Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.3 root/gtk-ffi/gtk-utilities.lisp:1.4 --- root/gtk-ffi/gtk-utilities.lisp:1.3 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-utilities.lisp Thu Dec 16 05:51:17 2004 @@ -39,13 +39,9 @@ (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) :returning :unsigned-long :call-direct nil) -(defun wrap-func (func-address) - (or func-address 0) - ;;(assert (or (null func-address) (numberp func-address))) - #+nahh - (if func-address - (uffi:make-pointer func-address '(* :void)) - c-null)) +(defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. + (or func-address 0)) + (defun gtk-signal-connect-swap (widget signal fun &key (after t) data destroy-data) (g-signal-connect-closure widget signal @@ -53,16 +49,13 @@ (defun gtk-object-set-property (obj property val-type val) (with-g-value (value) - (let ((str-ptr (and (eql val-type 'c-string) (to-gtk-string val)))) (g-value-init value (value-type-as-int val-type)) (funcall (value-set-function val-type) - value - (or str-ptr val)) + value val) (g-object-set-property obj property value) - (g-value-unset value) - (when str-ptr (g-free str-ptr))))) + (g-value-unset value))) (defun get-gtk-string (pointer) (with-foreign-object (bytes-written :int) @@ -144,16 +137,13 @@ (when str-ptr (free-cstring str-ptr))))) (defun gtk-list-store-set-items (store types-lst data-lst) - (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) + (with-tree-iter (iter) (dolist (item data-lst) (gvi :pre-append) (gtk-list-store-append store iter) (gvi :pre-set) - (gtk-list-store-set store iter types-lst item)))) + (gtk-list-store-set store iter types-lst item) + (gvi :post-set)))) (defun gtk-tree-store-new (col-types) (let ((gtk-types (ffx:fgn-alloc :int (length col-types)))) @@ -167,8 +157,6 @@ (loop for col from 0 for data in data-lst for type in types-lst - for str-ptr = (when (find type '(:string :icon)) - (to-gtk-string data)) do (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type @@ -177,10 +165,11 @@ (t type))) :gtk-ffi) value - (or str-ptr (and (eql type :date) (coerce data 'single-float)) data)) + (if (eql type :date) + (coerce data 'single-float) + data)) (gtk-tree-store-set-value tstore iter col value) - (g-value-unset value) - (when str-ptr (g-free str-ptr))))) + (g-value-unset value)))) (defun gtk-tree-model-get-cell (model iter column-no cell-type) (with-foreign-object (item :pointer-void) @@ -198,41 +187,95 @@ (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) +(defun make-address-pointer (addr type) + #+(or allegro mcl) (declare (ignore type)) + (assert (or (null addr) (numberp addr))) + (if addr + (progn + #+(or cmu scl) + (alien:sap-alien (system:int-sap addr) + (* (convert-from-uffi-type type :type))) + #+sbcl + (sb-alien:sap-alien (sb-sys:int-sap addr) + (* (convert-from-uffi-type type :type))) + #+lispworks + (fli:make-pointer + :address addr + :type (convert-from-uffi-type type :type)) + #+allegro addr + #+mcl + (ccl:%int-to-ptr addr) + ) + c-null)) + +(uffi:def-struct all-types + (:string :cstring) + (:icon :cstring) + (:boolean :unsigned-int) + (:int :int) + (:long :long) + (:date :float) + (:float :float) + (:double :double)) + +(defmacro with-all-types ((var) &body body) + `(uffi:with-foreign-object (,var 'all-types) + (setf (get-slot-value ,var 'all-types :string) c-null + (get-slot-value ,var 'all-types :icon) c-null + (get-slot-value ,var 'all-types :boolean) 0 + (get-slot-value ,var 'all-types :int) 0 + (get-slot-value ,var 'all-types :long) 0 + (get-slot-value ,var 'all-types :date) 0f0 + (get-slot-value ,var 'all-types :float) 0f0 + (get-slot-value ,var 'all-types :double) 0d0) + , at body)) + (defun gtk-tree-view-render-cell (col col-type cell-attrib-f) - (declare (ignore col)) - #'(lambda (tree-column cell-renderer model iter data) - (DECLARE (ignore data)) - - (let ((return-buffer (ffx:fgn-alloc :int 16))) - (gtk-tree-model-get model iter tree-column - return-buffer -1) - (let* ((returned-value (deref-pointer-runtime-typed return-buffer - (ffi-to-uffi-type - (col-type-to-ffi-type col-type)))) - (item-value (case col-type - ((:string :icon) (convert-from-cstring returned-value)) - (:boolean (not (zerop returned-value))) - (otherwise returned-value)))) - (with-cstring (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 (and (eql col-type :string) - (not (zerop returned-value))) - (uffi:free-foreign-object returned-value)) - (ffx:fgn-free return-buffer))))) + (lambda (tree-column cell-renderer model iter data) + (DECLARE (ignorable tree-column data)) + (ukt:trc nil "entering render cell callback" tree-column model) + (let ((return-buffer (ffx:fgn-alloc :int 16))) + (gtk-tree-model-get model iter col + return-buffer -1) + (let* ((returned-value (deref-pointer-runtime-typed return-buffer + (ffi-to-uffi-type + (col-type-to-ffi-type col-type)))) + (ret$ (when (find col-type '(:string :icon)) + (make-pointer returned-value :cstring))) + (item-value (case col-type + ((:string :icon) + #-lispworks (convert-from-cstring ret$) + #+lispworks (convert-from-foreign-string ret$ + :null-terminated-p t)) + (:boolean (not (zerop returned-value))) + (otherwise returned-value)))) + (ukt:trc nil "tv-render-cell: types, ret-value, item-value" + (List col-type (col-type-to-ffi-type col-type) (ffi-to-uffi-type + (col-type-to-ffi-type col-type))) + returned-value ret$ item-value) + (apply #'gtk-object-set-property cell-renderer + (case col-type + (:boolean (list "active" 'boolean item-value)) + (:icon (list "stock-id" 'c-string + (string-downcase (format nil "gtk-~a" item-value)))) + (t (list "text" 'c-string (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)) + (format nil "~a" item-value)))))) + (when cell-attrib-f + (ukt:trc nil "got cell-attrib-f" cell-attrib-f item-value) + (loop for property in (parse-cell-attrib (funcall cell-attrib-f item-value)) + do (apply #'gtk-object-set-property cell-renderer property))) + (when ret$ + (ukt:trc nil "frreeing ret$" ret$) + (uffi:free-foreign-object ret$)) + (ukt:trc nil "frreeing return-buffer" return-buffer) + (ffx:fgn-free return-buffer))) + (ukt:trc nil "exiting render cell callback" tree-column model) + 1)) (defun gtk-file-chooser-get-filenames-strs (file-chooser) (let ((glist (gtk-file-chooser-get-filenames file-chooser))) @@ -244,7 +287,7 @@ (eval-when (compile load eval) (export '(gtk-signal-connect gtk-signal-connect-swap gtk-object-set-property with-gtk-string get-gtk-string to-gtk-string - with-gdk-threads make-gtk-tree-iter + with-gdk-threads make-gtk-tree-iter with-tree-iter gtk-widget-set-popup gvi 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 From ktilton at common-lisp.net Thu Dec 16 16:36:27 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 16 Dec 2004 17:36:27 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/INSTALL.TXT root/load.lisp Message-ID: <20041216163627.7F66E880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv30140 Modified Files: INSTALL.TXT load.lisp Log Message: Adjust INSTALL.TXT and Load.lisp in UFFI version to conform with UFFI version Date: Thu Dec 16 17:36:26 2004 Author: ktilton Index: root/INSTALL.TXT diff -u root/INSTALL.TXT:1.1 root/INSTALL.TXT:1.2 --- root/INSTALL.TXT:1.1 Fri Nov 19 00:39:51 2004 +++ root/INSTALL.TXT Thu Dec 16 17:36:25 2004 @@ -1,36 +1,39 @@ +############################################################################################################# +The notes below apply to the UFFI port of Cells-gtk done by Ken Tilton. (Actually I have forked UFFI and +call it Hello-C, but the idea is the same: portable FFI.) + +For the original version by Vasilis Margioulas, which uses native CLisp FFI to +good advantage, grab this: + + http://common-lisp.net/cgi-bin/viewcvs.cgi/cells-gtk/clisp-cgtk/clisp-cgtk.tar.gz?tarball=1&cvsroot=cells-gtk + +...and follow the INSTALL.TXT in that. + +############################################################################################################## + Dependencies: Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.tar.gz?tarball=1&cvsroot=cells +Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.tar.gz?tarball=1&cvsroot=cells Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz?tarball=1&cvsroot=cells On windows install Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zip?download -[kenny says: I had to add the gtk libs to my path variable: +Add the gtk libs to your PATH variable: Start>Settings>Control Panel>System>Advanced>Environment Variables> Then select PATH and hit "Edit". Append to existing value: "C:\Program Files\Common Files\GTK\2.0\bin"; ..prior values... -// eokenny] - -Edit load.lisp and adjust the paths. - -CL> (load "load.lisp") - -For a sample application - -CL> (cells-gtk:start-app 'test-gtk::test-gtk) -[kenny says: I added to load.lisp a defun of GTK-DEMO which does the above -//eokenny] +Edit load.lisp and follow the instructions there. No, you cannot just load it. -Note: On windows under emacs with slime, gtk window dont popups. You must start the application from a dos prompt. +Note: On windows under emacs with slime, the gtk window does not popup. You must start the application from a dos prompt. Tested on: - Windows xp with gtk 2.4.10 and clisp 2.33 - Linux (fedora 2) with clisp 2.33 + Windows xp with gtk 2.4.10 and clisp 2.33, using AllegroCL 6.2 Enterprise and Lispworks 4.3 Personal Known bugs: On Windows: Clisp crash if Index: root/load.lisp diff -u root/load.lisp:1.3 root/load.lisp:1.4 --- root/load.lisp:1.3 Tue Dec 14 05:02:12 2004 +++ root/load.lisp Thu Dec 16 17:36:25 2004 @@ -1,14 +1,29 @@ (in-package :cl-user) +#| Step One: Get ASDF into the game. + + Obviously not necessary if you always have that + loaded. Note that you will have to adjust the pathname to point to where you + have ASDF.lisp. + +|# + #-asdf -(eval-when (compile load eval) - #+lispworks - (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) +(eval-when (compile load eval) (load (make-pathname :directory '(:absolute "00" "root") :name "asdf" :type "lisp"))) -(progn ;; setup +#| Step Two: Tell ASDF where to find stuff + + Again, adjust pathnames to match the locations of the various bits of source + +|# + +(progn + #+lispworks + (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify)) + (push (make-pathname :directory '(:absolute "cell-cultures" "utils-kt")) asdf:*central-registry*) @@ -36,13 +51,22 @@ *cells-gtk-root*) asdf:*central-registry*)) -(Asdf:operate 'asdf:load-op :utils-kt :force nil) -(Asdf:operate 'asdf:load-op :cells :force nil) -(Asdf:operate 'asdf:load-op :hello-c :force nil) -(Asdf:operate 'asdf:load-op :gtk-ffi :force t) -(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +#| Step 3: Compile and load via ASDF + +; these are handy when one is first working up to getting things to build at all +; but the "test-gtk" ASDF has dependencies which will load everything else, so +; you can just execute that. +; +;(Asdf:operate 'asdf:load-op :utils-kt :force nil) +;(Asdf:operate 'asdf:load-op :cells :force nil) +;(Asdf:operate 'asdf:load-op :hello-c :force nil) +;(Asdf:operate 'asdf:load-op :gtk-ffi :force t) +;(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +|# + (Asdf:operate 'asdf:load-op :test-gtk :force nil) -#+test +#+Step-4: + (test-gtk::gtk-demo) From ktilton at common-lisp.net Wed Dec 22 16:23:53 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 22 Dec 2004 17:23:53 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/buttons.lisp root/cells-gtk/gtk-app.lisp root/cells-gtk/menus.lisp root/cells-gtk/tree-view.lisp Message-ID: <20041222162353.C32D0880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv13131/cells-gtk Modified Files: buttons.lisp gtk-app.lisp menus.lisp tree-view.lisp Log Message: Fix for Lispworks for, inter alia, GDK-BUTTON-EVENT-HANDLER Date: Wed Dec 22 17:23:50 2004 Author: ktilton Index: root/cells-gtk/buttons.lisp diff -u root/cells-gtk/buttons.lisp:1.4 root/cells-gtk/buttons.lisp:1.5 --- root/cells-gtk/buttons.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/buttons.lisp Wed Dec 22 17:23:50 2004 @@ -43,7 +43,7 @@ (def-c-output stock ((self button)) (when new-value (setf (label self) (string-downcase (format nil "gtk-~a" new-value))) - (trc "stock" (label self)) (force-output) + (trc nil "c-outputting stock" (label self)) (force-output) (setf (use-stock self) t))) (def-widget toggle-button (button) @@ -52,9 +52,9 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) - (print (list :toggle-button :on-toggled-cb widget)) + ;;(print (list :toggle-button :on-toggled-cb widget)) (let ((state (gtk-toggle-button-get-active widget))) - (print (list :toggledstate state)) + ;;(print (list :toggledstate state)) (setf (md-value self) state)))) #+test @@ -88,7 +88,7 @@ c-null (id (first (kids (fm-parent self)))))))) :on-toggled (callback (widget event data) - (print (list :radio-button widget event data)) + ;;(print (list :radio-button widget event data)) (let ((state (gtk-toggle-button-get-active widget))) (setf (md-value self) state)))) Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.4 root/cells-gtk/gtk-app.lisp:1.5 --- root/cells-gtk/gtk-app.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/gtk-app.lisp Wed Dec 22 17:23:50 2004 @@ -84,7 +84,7 @@ (gtk-main))))) (defvar *gtk-global-callbacks* nil) -(defvar *gtk-loaded* nil) +(defvar *gtk-loaded* #+clisp t #-clisp nil) ;; kt: looks like CLisp does this on its own (defun gtk-reset () (cell-reset) @@ -104,12 +104,20 @@ (defun cells-gtk-init () (gtk-reset) + #-cmu (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)))) + +#+cmu +(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 Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.4 root/cells-gtk/menus.lisp:1.5 --- root/cells-gtk/menus.lisp:1.4 Tue Dec 14 05:01:51 2004 +++ root/cells-gtk/menus.lisp Wed Dec 22 17:23:50 2004 @@ -196,16 +196,9 @@ (toggled) :active (c-in nil) :on-toggled (callback (widget event data) - (trc "on-toggled" self widget event data) + (trc nil "on-toggled" self widget event data) (let ((state (gtk-check-menu-item-get-active widget))) (setf (md-value self) state)))) - -#+not -(DEF-GTK WIDGET CHECK-MENU-ITEM (MENU-ITEM) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) - (ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED - (CALLBACK (WIDGET EVENT DATA) (TRC "on-toggled" SELF WIDGET EVENT DATA) - (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) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.5 root/cells-gtk/tree-view.lisp:1.6 --- root/cells-gtk/tree-view.lisp:1.5 Thu Dec 16 05:51:11 2004 +++ root/cells-gtk/tree-view.lisp Wed Dec 22 17:23:50 2004 @@ -109,11 +109,11 @@ (def-c-output on-select ((self tree-view)) (when new-value - (trc "output on-select" self new-value) + (trc nil "output on-select" self new-value) (let* ((selected-widget (gtk-tree-view-get-selection (id self))) (selected-clos (gtk-object-find selected-widget))) (if (not selected-clos) - (trc "whoa!!! no clos for selected" self selected-widget) + (trc nil "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 @@ -193,7 +193,7 @@ (gtk-tree-view-column-pack-start (id col) renderer t) (gtk-tree-view-column-set-cell-data-func (id col) renderer (let ((cb (ff-register-callable 'tree-view-render-cell-callback))) - (trc "tree-view columns pcb:" cb (id col) :render-cell) + (trc nil "tree-view columns pcb:" cb (id col) :render-cell) (callback-register col :render-cell (gtk-tree-view-render-cell pos (nth pos (column-types self)) From ktilton at common-lisp.net Wed Dec 22 16:23:57 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Wed, 22 Dec 2004 17:23:57 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-utilities.lisp Message-ID: <20041222162357.8A1FD880A8@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv13131/gtk-ffi Modified Files: gtk-ffi.lisp gtk-utilities.lisp Log Message: Fix for Lispworks for, inter alia, GDK-BUTTON-EVENT-HANDLER Date: Wed Dec 22 17:23:54 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.6 root/gtk-ffi/gtk-ffi.lisp:1.7 --- root/gtk-ffi/gtk-ffi.lisp:1.6 Thu Dec 16 05:51:17 2004 +++ root/gtk-ffi/gtk-ffi.lisp Wed Dec 22 17:23:53 2004 @@ -22,7 +22,7 @@ (in-package :gtk-ffi) -(defconstant c-null #+clisp nil #-clisp (make-null-pointer '(* void))) +(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) @@ -61,34 +61,37 @@ (:gdk "libgdk-win32-2.0-0.dll") (:gtk "libgtk-win32-2.0-0.dll"))) #-(or win32 mswindows) - (ecase lib - (: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"))) + (concatenate 'string + "/usr/lib" + (ecase lib + (: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 :cstring) - (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)))) + ((nil) :void) + (uint :UNSIGNED-INT) + (c-pointer :pointer-void) + (c-ptr-null '*) + (c-array-ptr '*) + (c-ptr '*) + (c-string :cstring) + (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) Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.4 root/gtk-ffi/gtk-utilities.lisp:1.5 --- root/gtk-ffi/gtk-utilities.lisp:1.4 Thu Dec 16 05:51:17 2004 +++ root/gtk-ffi/gtk-utilities.lisp Wed Dec 22 17:23:53 2004 @@ -74,14 +74,14 @@ (gdk-threads-leave))) (ffx:ff-defun-callable :cdecl :int button-press-event-handler - ((widget (* :void)) (signal (* :void)) (data (* :void))) - (declare (ignore data)) - (let ((event (uffi:deref-pointer signal :int))) + ((widget (* :void)) (signal (* gdk-event-button)) (data (* :void))) + (declare (ignorable data)) + (let ((event (gdk-event-button-type signal))) (when (eql (event-type event) :button_press) (when (= (gdk-event-button-button signal) 3) - (gtk-menu-popup widget nil nil nil nil - (gdk-event-button-button signal) - (gdk-event-button-time signal)))))) + (gtk-menu-popup widget nil nil nil nil 3 + (gdk-event-button-time signal))))) + 1) (defun gtk-widget-set-popup (widget menu) (gtk-signal-connect-swap widget "button-press-event" @@ -157,7 +157,7 @@ (loop for col from 0 for data in data-lst for type in types-lst - do (print (list :tree-store-set value type (as-gtk-type type))) + do ;; (print (list :tree-store-set value type (as-gtk-type type))) (g-value-init value (as-gtk-type type)) (funcall (intern (format nil "G-VALUE-SET-~a" (case type (:date 'float) @@ -186,27 +186,6 @@ (:font (list "font" 'c-string val)) (:size (list "size-points" 'double-float (coerce val 'double-float))) (:strikethrough (list "strikethrough" 'boolean val))))) - -(defun make-address-pointer (addr type) - #+(or allegro mcl) (declare (ignore type)) - (assert (or (null addr) (numberp addr))) - (if addr - (progn - #+(or cmu scl) - (alien:sap-alien (system:int-sap addr) - (* (convert-from-uffi-type type :type))) - #+sbcl - (sb-alien:sap-alien (sb-sys:int-sap addr) - (* (convert-from-uffi-type type :type))) - #+lispworks - (fli:make-pointer - :address addr - :type (convert-from-uffi-type type :type)) - #+allegro addr - #+mcl - (ccl:%int-to-ptr addr) - ) - c-null)) (uffi:def-struct all-types (:string :cstring) From ktilton at common-lisp.net Thu Dec 23 16:34:51 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 23 Dec 2004 17:34:51 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp root/cells-gtk/tree-view.lisp root/cells-gtk/widgets.lisp Message-ID: <20041223163451.F03EC884A9@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv22788/cells-gtk Modified Files: gtk-app.lisp tree-view.lisp widgets.lisp Log Message: Merge brave but incomplete attempt at adding OS/X. Date: Thu Dec 23 17:34:45 2004 Author: ktilton Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.5 root/cells-gtk/gtk-app.lisp:1.6 --- root/cells-gtk/gtk-app.lisp:1.5 Wed Dec 22 17:23:50 2004 +++ root/cells-gtk/gtk-app.lisp Thu Dec 23 17:34:42 2004 @@ -112,13 +112,6 @@ :module (string lib))) finally (setf *gtk-loaded* t)))) -#+cmu -(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))) Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.6 root/cells-gtk/tree-view.lisp:1.7 --- root/cells-gtk/tree-view.lisp:1.6 Wed Dec 22 17:23:50 2004 +++ root/cells-gtk/tree-view.lisp Thu Dec 23 17:34:42 2004 @@ -101,7 +101,7 @@ (:multiple 3)))))) (ff-defun-callable :cdecl :int tree-view-select-handler - ((column-widget (* :void)) (event (* :void)) (data (* :void))) + ((column-widget :pointer-void) (event :pointer-void) (data :pointer-void)) (bif (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) @@ -173,8 +173,8 @@ (items-factory self))))) (ff-defun-callable :cdecl :int tree-view-render-cell-callback - ((tree-column (* :void)) (cell-renderer (* :void)) - (tree-model (* :void)) (iter (* :void)) (data (* :void))) + ((tree-column :pointer-void) (cell-renderer :pointer-void) + (tree-model :pointer-void) (iter :pointer-void) (data :pointer-void)) (bif (self (gtk-object-find tree-column)) (let ((cb (callback-recover self :render-cell))) (assert cb () "No :render-cell callback for ~a" self) @@ -225,4 +225,4 @@ `(list ,type ',inits ,renderer)))) (eval-when (compile load eval) - (export '(mk-listbox mk-treebox def-columns))) \ No newline at end of file + (export '(mk-listbox mk-treebox def-columns))) Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.5 root/cells-gtk/widgets.lisp:1.6 --- root/cells-gtk/widgets.lisp:1.5 Thu Dec 16 05:51:11 2004 +++ root/cells-gtk/widgets.lisp Thu Dec 23 17:34:42 2004 @@ -118,7 +118,7 @@ (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))) + ((widget :pointer-void) (event :pointer-void) (data :pointer-void)) ;(print (list :entered-gtk-event-handler-cb ,(symbol-name event) widget)) (bif (self (gtk-object-find widget)) (let ((cb (callback-recover self ,(intern (symbol-name event) :keyword)))) @@ -238,6 +238,7 @@ 1)))) +#-cmu (ff-defun-callable :cdecl :boolean timeout-handler-callback ((data (* :int))) ;;(print (list :timeout-handler-callback data)) From ktilton at common-lisp.net Thu Dec 23 16:35:06 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Thu, 23 Dec 2004 17:35:06 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp root/gtk-ffi/gtk-utilities.lisp Message-ID: <20041223163506.0C500884A9@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv22788/gtk-ffi Modified Files: gtk-ffi.lisp gtk-utilities.lisp Log Message: Merge brave but incomplete attempt at adding OS/X. Date: Thu Dec 23 17:34:52 2004 Author: ktilton Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.7 root/gtk-ffi/gtk-ffi.lisp:1.8 --- root/gtk-ffi/gtk-ffi.lisp:1.7 Wed Dec 22 17:23:53 2004 +++ root/gtk-ffi/gtk-ffi.lisp Thu Dec 23 17:34:51 2004 @@ -60,15 +60,29 @@ (:gthread "libgthread-2.0-0.dll") (:gdk "libgdk-win32-2.0-0.dll") (:gtk "libgtk-win32-2.0-0.dll"))) - #-(or win32 mswindows) + #+macosx (concatenate 'string - "/usr/lib" + "/sw/lib/" (ecase lib - (: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")))) + (:gobject "libgobject-2.0.0.dylib") + (:glib "libglib-2.0.0.dylib") + (:gthread "libgthread-2.0.0.dylib") + (:gdk "libgdk-x11-2.0.0.dylib") + (:gtk "libgtk-x11-2.0.0.dylib"))) + #-(or macosx win32 mswindows) + (ecase lib + (: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"))) + #+cmu + (loop for lib in '(:gthread :glib :gobject :gdk :gtk) + do (assert (uffi:load-foreign-library ;;simon + (hic:find-foreign-library (gtk-ffi::libname lib) "/usr/lib/") + :force-load #+lispworks t #-lispworks nil + :module (string lib))) + ) (defun ffi-to-uffi-type (clisp-type) #+clisp clisp-type Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.5 root/gtk-ffi/gtk-utilities.lisp:1.6 --- root/gtk-ffi/gtk-utilities.lisp:1.5 Wed Dec 22 17:23:53 2004 +++ root/gtk-ffi/gtk-utilities.lisp Thu Dec 23 17:34:51 2004 @@ -35,8 +35,8 @@ (if after 1 0))))) (uffi:def-function ("g_signal_connect_data" g_signal_connect_data) - ((instance (* :void)) (detailed-signal :cstring) - (c-handler (* :void)) (data (* :void))(destroy-data (* :void)) (after :int)) + ((instance :pointer-void) (detailed-signal :cstring) + (c-handler :pointer-void) (data :pointer-void)(destroy-data :pointer-void) (after :int)) :returning :unsigned-long :call-direct nil) (defun wrap-func (func-address) ;; vestigial. func would never be nil. i think. From ktilton at common-lisp.net Fri Dec 24 02:04:01 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 24 Dec 2004 03:04:01 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lisp Message-ID: <20041224020401.98CD2884A9@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv19976/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: (Andras's) fix for with-g-value to pump up CMU handling of tree-view demo Date: Fri Dec 24 03:03:58 2004 Author: ktilton Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.6 root/cells-gtk/test-gtk/test-gtk.lisp:1.7 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.6 Thu Dec 16 05:51:14 2004 +++ root/cells-gtk/test-gtk/test-gtk.lisp Fri Dec 24 03:03:57 2004 @@ -18,10 +18,10 @@ "Menus" "Textview" "Dialogs" "Addon" "Entry" - "Tree-view" + #-cmu "Tree-view" ))) (list (mk-notebook - :tab-labels nil #+not '("Buttons") + :tab-labels tabs :kids (loop for test-name in tabs collect (make-instance (intern (string-upcase From ktilton at common-lisp.net Fri Dec 24 02:04:06 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 24 Dec 2004 03:04:06 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-core.lisp Message-ID: <20041224020406.996C0885E5@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv19976/gtk-ffi Modified Files: gtk-core.lisp Log Message: (Andras's) fix for with-g-value to pump up CMU handling of tree-view demo Date: Fri Dec 24 03:04:03 2004 Author: ktilton Index: root/gtk-ffi/gtk-core.lisp diff -u root/gtk-ffi/gtk-core.lisp:1.2 root/gtk-ffi/gtk-core.lisp:1.3 --- root/gtk-ffi/gtk-core.lisp:1.2 Thu Dec 16 05:51:17 2004 +++ root/gtk-ffi/gtk-core.lisp Fri Dec 24 03:04:00 2004 @@ -67,18 +67,24 @@ (defmacro with-g-value ((var) &body body) `(call-with-g-value (lambda (,var) , at body))) +#+cmu +(ffx:def-type g-value-type + (* (alien:struct gtk-ffi::g-value + (gtk-ffi::g-type (array (alien:signed 32) 16))))) + (defun call-with-g-value (fn) + (declare (optimize (speed 3) (safety 0) (space 0))) (let ((gva (ffx:fgn-alloc 'g-value 1 :with-g-value))) + #+cmu (declare (type g-value-type gva)) (unwind-protect (progn (dotimes (n 16) - ;; (setf (int-slot-indexed ,var 'g-value 'g-type n) 0) (let ((gv (ff-elt gva 'g-value 0))) (let ((ns (get-slot-pointer gv 'g-value 'g-type))) #+lispworks (setf (fli:foreign-aref ns n) 0) #-lispworks (setf (deref-array ns '(:array :int) n) 0)))) (funcall fn gva)) - (ffx:fgn-free gva)))) + (ffx:fgn-free gva)))) (eval-when (compile load eval) (export 'with-g-value)) From ktilton at common-lisp.net Fri Dec 24 15:35:12 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 24 Dec 2004 16:35:12 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp Message-ID: <20041224153512.42CD1884FE@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv29363/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: us pointer void in button-press-event-handler arglist Date: Fri Dec 24 16:35:11 2004 Author: ktilton Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.6 root/gtk-ffi/gtk-utilities.lisp:1.7 --- root/gtk-ffi/gtk-utilities.lisp:1.6 Thu Dec 23 17:34:51 2004 +++ root/gtk-ffi/gtk-utilities.lisp Fri Dec 24 16:35:10 2004 @@ -74,7 +74,7 @@ (gdk-threads-leave))) (ffx:ff-defun-callable :cdecl :int button-press-event-handler - ((widget (* :void)) (signal (* gdk-event-button)) (data (* :void))) + ((widget :pointer-void) (signal (* gdk-event-button)) (data :pointer-void)) (declare (ignorable data)) (let ((event (gdk-event-button-type signal))) (when (eql (event-type event) :button_press)