From: David Pirotte <david@altosw.be>
To: bug-guile@gnu.org
Subject: vm-error: guile-gnome-2 / treeview / 'button-press-event
Date: Sat, 9 Jul 2011 03:51:14 -0300 [thread overview]
Message-ID: <20110709035114.31446e40@rascar> (raw)
[-- Attachment #1: Type: text/plain, Size: 1722 bytes --]
Hello,
GNU Guile 2.0.2.7-ae88d
g-wrap / git-clone / v1.9.13-13-geeb1aae
guile-cairo / bzr-clone
guile-gnome-platform / git-clone / 0.8.0-9-gb3ae01e
The attached code [which worked under guile-1.8 and guile-gnome .deb packages]
gives me the following error when 'right clicking' a row:
Backtrace:
In ice-9/boot-9.scm:
170: 10 [catch #t #<catch-closure 90d54f0> ...]
In unknown file:
?: 9 [catch-closure]
In ice-9/boot-9.scm:
62: 8 [call-with-prompt prompt0 ...]
In ice-9/eval.scm:
389: 7 [eval # #]
In ice-9/boot-9.scm:
2103: 6 [save-module-excursion #<procedure 90db760 at ice-9/boot-9.scm:3547:3 ()>]
3554: 5 [#<procedure 90db760 at ice-9/boot-9.scm:3547:3 ()>]
In unknown file:
?: 4 [load-compiled/vm "/usr/alto/staff/david/.cache/guile/ccache/2.0-LE-4-2.0/usr/local/share/guile/alto/gtk-examples/gslice-auto-crash-attempt.scm.go"]
?: 3 [%gw:dynamic-procedure]
In ice-9/boot-9.scm:
170: 2 [catch #t #<catch-closure 9463aa0> ...]
In unknown file:
?: 1 [catch-closure]
In alto/gtk-examples/gslice-auto-crash-attempt.scm:
302: 0 [#<procedure 979d6a8 at alto/gtk-examples/gslice-auto-crash-attempt.scm:290:15 (w ev)> # ...]
alto/gtk-examples/gslice-auto-crash-attempt.scm:302:25: In procedure #<procedure 979d6a8 at alto/gtk-examples/gslice-auto-crash-attempt.scm:290:15 (w ev)>:
alto/gtk-examples/gslice-auto-crash-attempt.scm:302:25: Throw to key `vm-error' with
args `(vm-run "Too few values returned to continuation" ())'.
Cheers,
David
For info:
david@rascar:/usr/local/src/guile-gnome/git-clone 12 $ git describe
fatal: No annotated tags can describe 'b3ae01eb831d90b60c82b82f185185d116aee8a1'.
david@rascar:/usr/local/src/guile-gnome/git-clone 14 $ git describe --tags
0.8.0-9-gb3ae01e
[-- Attachment #2: gslice-auto-crash-attempt.scm --]
[-- Type: text/x-scheme, Size: 10855 bytes --]
#! /bin/sh
# -*- scheme -*-
hn=`hostname`
if [[ "$hn" == "tabu" ]]
then exec guile-gnome-0 -s $0 "$@"
else exec guile-gnome-2 -s $0 "$@"
fi
!#
;; guile-gnome
;; Copyright (C) 2003,2004 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
(read-set! keywords 'prefix)
(use-modules (ice-9 receive)
(oop goops)
(gnome gobject)
(gnome gtk)
(gnome gtk gdk-event))
(define *model* #f)
(define *selection* #f)
(define (pack-tv-column tv column renderer pos)
(pack-start column renderer #t)
(add-attribute column renderer "text" pos)
(append-column tv column))
(define (add-columns treeview)
(let* ((renderer1 (make <gtk-cell-renderer-text>))
(column1 (make <gtk-tree-view-column>
:title "Column 1"
:sizing 'fixed
:fixed-width 65
;:clickable #f
;:resizable #f
;:reorderable #f
:alignment .5
))
(renderer2 (make <gtk-cell-renderer-text>))
(column2 (make <gtk-tree-view-column>
:title "Column 2"
:sizing 'fixed
:fixed-width 65
;:clickable #f
;:resizable #f
;:reorderable #f
:alignment .5
))
(renderer3 (make <gtk-cell-renderer-text>))
(column3 (make <gtk-tree-view-column>
:title "Column 3"
:expand #t
:alignment .5
))
;; ROW BACKGROUND COLOUR
(renderer4 (make <gtk-cell-renderer-text>
:xalign 1))
(column4 (make <gtk-tree-view-column>
:visible #f
))
;; ROW FOREGROUND COLOUR
(renderer5 (make <gtk-cell-renderer-text>
:xalign 1))
(column5 (make <gtk-tree-view-column>
:visible #f
)))
(pack-tv-column treeview column1 renderer1 0)
(pack-tv-column treeview column2 renderer2 1)
(pack-tv-column treeview column3 renderer3 2)
(pack-tv-column treeview column4 renderer4 3)
(pack-tv-column treeview column5 renderer5 4)
;; background colour
(add-attribute column1 renderer1 "cell-background" 3)
(add-attribute column2 renderer2 "cell-background" 3)
(add-attribute column3 renderer3 "cell-background" 3)
;; foreground colour
(add-attribute column1 renderer1 "foreground" 4)
(add-attribute column2 renderer2 "foreground" 4)
(add-attribute column3 renderer3 "foreground" 4)
(set-search-column treeview 2)
))
(define (ocs/add-model treeview)
(let* ((column-types (list <gchararray>
<gchararray>
<gchararray>
<gchararray>
<gchararray>))
(model (gtk-list-store-new column-types)))
(set-model treeview model)
(values model
(get-selection treeview))
))
(define (setup-treeview treeview)
(add-columns treeview)
(receive (model selection)
(ocs/add-model treeview)
(set-mode selection 'single)
(values model selection)))
(define (populate-model model)
(for-each (lambda (row)
(let ((iter (gtk-list-store-append model)))
(set-value model iter 0 (car row))
(set-value model iter 1 (cadr row))
(set-value model iter 2 (caddr row))))
'(("r1c1" "r1c2" "r1c3")
("r2c1" "r2c2" "r2c3")
("r3c1" "r3c2" "r3c3"))
))
(define (make-simple-popup-menu entries)
(let ((menu (make <gtk-menu>)))
(for-each (lambda (entry)
(if (pair? entry)
(let* ((label (car entry))
(callback (cdr entry))
(menu-item (gtk-menu-item-new-with-label label)))
(connect menu-item
'activate
(lambda (widget)
(callback)))
(gtk-menu-shell-append menu menu-item)
(show menu-item))
(let ((menu-item (gtk-separator-menu-item-new)))
(gtk-menu-shell-append menu menu-item)
(show menu-item))))
entries)
menu))
(define (gtku/status-push status-bar message source)
(let ((context-id (gtk-statusbar-get-context-id status-bar source)))
(gtk-statusbar-push status-bar context-id message)))
(define (gtku/status-pop status-bar source)
(let ((context-id (gtk-statusbar-get-context-id status-bar source)))
(gtk-statusbar-pop status-bar context-id)))
(define (make-popup-menu)
(make-simple-popup-menu `(("popup option 1" . ,(lambda () (display "popup option 1\n")))
("popup option 2" . ,(lambda () (display "popup option 2\n")))
separator
("popup option 3" . ,(lambda () (display "popup option 3\n"))))
))
(define (test-suite-1 treeview model selection popup-menu)
(let ((i 0)
(nb-rows -1)
(bgcolours '("Black" "grey20" "grey40"))
(fgcolours '("white" "wheat" "royalblue")))
(while (< i 1000)
(let* ((sibling (get-iter model 2))
;; (iter (gtk-list-store-append model))
(iter (insert-after model sibling))
)
(set-value model iter 0 (symbol->string (gensym "gs-")))
(set-value model iter 1 (symbol->string (gensym "gs-")))
(set-value model iter 2 (symbol->string (gensym "gs-")))
(set-value model iter 3 (list-ref bgcolours (modulo i 3)))
(set-value model iter 4 (list-ref fgcolours (modulo i 3)))
)
(select-path selection (list (modulo i 100)))
(set! i (1+ i)))
(select-path selection (list 0))
(set! i 0)
(while (< i 500)
(let ((iter (get-iter model (list i))))
(set-value model iter 3 "grey20")
(set-value model iter 4 "Royalnavy1")
(remove model iter))
(set! i (1+ i)))
(set! nb-rows (gtk-tree-model-iter-n-children model #f))
;; (gtk-menu-popup popup-menu #f #f #f 3 0)
(select-path selection (list 2))
(set! i 0)
(while (< i nb-rows)
(gtk-tree-view-scroll-to-cell treeview (list i) #f #t 0.3)
(set! i (1+ i)))
))
(define (test-suite-2 treeview model selection first next)
(let ((nb-rows (gtk-tree-model-iter-n-children model #f))
(i 0))
(emit first 'clicked)
(while (< i nb-rows)
;; (select-path selection (list i))
;; (gtk-tree-view-scroll-to-cell treeview (list i) #f #t 0.3)
;; (usleep 500)
(emit next 'clicked)
(set! i (1+ i)))
))
(define (start-test treeview model selection popup-menu first next)
(let ((i 0))
(gtk-list-store-clear model)
(test-suite-1 treeview model selection popup-menu)
(while (< i 10)
(test-suite-2 treeview model selection first next)
(set! i (1+ i))
)))
(define (animate)
(let* ((window (make <gtk-window>
:type 'toplevel
:title "Get path at pos test"
))
(vbox (make <gtk-vbox>
:homogeneous #f
:spacing 2))
(hbox (make <gtk-hbox>
:homogeneous #f
:spacing 2))
(scrollw (make <gtk-scrolled-window>
:hscrollbar-policy 'never
:vscrollbar-policy 'automatic))
(treeview (make <gtk-tree-view>))
(firstrow (make <gtk-button>
:label "first row")) ;; (gtk-stock-id 'close)
(nextrow (make <gtk-button>
:label "next row")) ;; (gtk-stock-id 'close)
(test-1 (make <gtk-button>
:label "Test suite"))
(test-2 (make <gtk-button>
:label "Start ..."))
(statusbar (make <gtk-statusbar>))
(popup-menu (make-popup-menu)))
(set-default-size window 400 150)
(receive (model selection)
(setup-treeview treeview)
(populate-model model)
(add window vbox)
(add scrollw treeview)
(pack-start vbox scrollw #t #t 0)
(pack-start vbox hbox #f #f 0)
(pack-start hbox firstrow #f #f 0)
(pack-start hbox nextrow #f #f 0)
(pack-start hbox test-1 #f #f 0)
(pack-start hbox test-2 #t #t 0)
(pack-start vbox statusbar #f #f 0)
(connect window
'delete-event
(lambda (widget event)
(destroy widget)
(gtk-main-quit)
#f))
(connect selection
'changed
(lambda (selection)
(receive (model iter)
(get-selected selection)
(if iter
(let* ((path (get-path model iter))
(row (car path)))
;(gtku/status-pop statusbar "")
;(gtku/status-push statusbar (get-value model iter 0) "")
#t
)))
#f))
(connect treeview
'button-press-event
(lambda (w ev)
(case (gdk-event:type ev)
((button-press)
(let* ((button (gdk-event-button:button ev))
(time (gdk-event-button:time ev))
(x-pos (inexact->exact (gdk-event-button:x ev)))
(y-pos (inexact->exact (gdk-event-button:y ev)))
(path-values ;; (get-path-at-pos w x-pos y-pos)
(values (list 1) #t 10 10)
))
(case button
((3)
(receive (indices bool x y)
path-values
(let* ((row (car indices))
(iter (get-iter model row)))
(gtk-menu-popup popup-menu
#f ;; parent-menu-shell or #f
#f ;; parent-menu-item or #f
#f ;; user supplied func to position the menu or #f
;; #f - no more user supplied data to pass to func
button
time
)))))))
((2button-press)
(simple-format #t "ignoring 2button-press events...~%"))
((3button-press)
(simple-format #t "ignoring 3button-press events...~%"))
)
#f
))
(connect firstrow
'clicked
(lambda (but)
(select-path selection (list 0))
(gtk-tree-view-scroll-to-cell treeview (list 0) #f #t 0.3)))
(connect nextrow
'clicked
(lambda (but)
(receive (model iter)
(get-selected selection)
(if iter
(let* ((path (get-path model iter))
(row (car path))
(new-path (list (1+ row))))
(select-path selection new-path)
(gtk-tree-view-scroll-to-cell treeview new-path #f #t 0.3))))
))
(connect test-1
'clicked
(lambda (but)
(start-test treeview model selection popup-menu firstrow nextrow)))
(connect test-2
'clicked
(lambda (but)
(let ((i 0))
(while (< i 10)
(emit test-1 'clicked)
(set! i (1+ i))
))))
)
(show-all window)
(gtk-main)))
(animate)
next reply other threads:[~2011-07-09 6:51 UTC|newest]
Thread overview: 2+ messages / expand[flat|nested] mbox.gz Atom feed top
2011-07-09 6:51 David Pirotte [this message]
2011-07-14 9:07 ` vm-error: guile-gnome-2 / treeview / 'button-press-event Andy Wingo
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20110709035114.31446e40@rascar \
--to=david@altosw.be \
--cc=bug-guile@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).