* vm-error: guile-gnome-2 / treeview / 'button-press-event
@ 2011-07-09 6:51 David Pirotte
2011-07-14 9:07 ` Andy Wingo
0 siblings, 1 reply; 2+ messages in thread
From: David Pirotte @ 2011-07-09 6:51 UTC (permalink / raw)
To: bug-guile
[-- 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)
^ permalink raw reply [flat|nested] 2+ messages in thread* Re: vm-error: guile-gnome-2 / treeview / 'button-press-event
2011-07-09 6:51 vm-error: guile-gnome-2 / treeview / 'button-press-event David Pirotte
@ 2011-07-14 9:07 ` Andy Wingo
0 siblings, 0 replies; 2+ messages in thread
From: Andy Wingo @ 2011-07-14 9:07 UTC (permalink / raw)
To: David Pirotte; +Cc: bug-guile
Hi David,
On Sat 09 Jul 2011 08:51, David Pirotte <david@altosw.be> writes:
> Too few values returned to continuation
> (let* ([...]
> (path-values ;; (get-path-at-pos w x-pos y-pos)
> (values (list 1) #t 10 10)
> ))
The problem is here. From the NEWS:
** Returning multiple values to compiled code will silently truncate the
values to the expected number
For example, the interpreter would raise an error evaluating the form,
`(+ (values 1 2) (values 3 4))', because it would see the operands as
being two compound "values" objects, to which `+' does not apply.
The compiler, on the other hand, receives multiple values on the stack,
not as a compound object. Given that it must check the number of values
anyway, if too many values are provided for a continuation, it chooses
to truncate those values, effectively evaluating `(+ 1 3)' instead.
The idea is that the semantics that the compiler implements is more
intuitive, and the use of the interpreter will fade out with time.
This behavior is allowed both by the R5RS and the R6RS.
** Multiple values in compiled code are not represented by compound
objects
This change may manifest itself in the following situation:
(let ((val (foo))) (do-something) val)
In the interpreter, if `foo' returns multiple values, multiple values
are produced from the `let' expression. In the compiler, those values
are truncated to the first value, and that first value is returned. In
the compiler, if `foo' returns no values, an error will be raised, while
the interpreter would proceed.
Both of these behaviors are allowed by R5RS and R6RS. The compiler's
behavior is more correct, however. If you wish to preserve a potentially
multiply-valued return, you will need to set up a multiple-value
continuation, using `call-with-values'.
(It is no longer true that the interpreter and the compiler behave
differently; they behave the same.)
Anyway, if you want a compound values object, use "list", then in your
values-producing expression
> (receive (indices bool x y)
> path-values
use (apply values my-list).
Regards,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2011-07-14 9:07 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-07-09 6:51 vm-error: guile-gnome-2 / treeview / 'button-press-event David Pirotte
2011-07-14 9:07 ` Andy Wingo
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).