File: gtk.scm

package info (click to toggle)
guile-gtk-1.2 0.31-3
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 2,544 kB
  • ctags: 2,413
  • sloc: sh: 11,073; ansic: 3,380; lisp: 1,058; makefile: 106
file content (106 lines) | stat: -rw-r--r-- 3,157 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
(define-module (gtk-1.2 gtk)
  :use-module (gtk-1.2 dynlink))

(define-public gtk-major-version 1)
(define-public gtk-minor-version 2)

(merge-compiled-code "sgtk_init_gtk_gtk_glue" "libguilegtk-1.2")

(define-public (gtk-update)
  (cond ((> (gtk-events-pending) 0)
	 (gtk-main-iteration)
	 (gtk-update))))

(define-public (gtk-standalone-main toplevel)
  (cond ((gtk-standalone?)
	 (gtk-signal-connect toplevel "destroy" gtk-exit)
	 (gtk-main))))

;; Some aliases and quickies

(define-public gtk-radio-menu-item-new 
  gtk-radio-menu-item-new-from-widget)
(define-public gtk-radio-menu-item-new-with-label
  gtk-radio-menu-item-new-with-label-from-widget)
(define-public gtk-radio-button-new
  gtk-radio-button-new-from-widget)
(define-public gtk-radio-button-new-with-label
  gtk-radio-button-new-with-label-from-widget)
(define-public (gtk-idle-add proc)
  (gtk-idle-add-full 0 proc))

;; The error reporter

(define-public gtk-show-error
  (let ((window #f)
	(text #f))
    (lambda (msg)
      (cond ((not window)
	     (set! window (gtk-window-new 'toplevel))
	     (set! text (gtk-text-new #f #f))
	     (let* ((vscroll (gtk-vscrollbar-new (gtk-text-vadj text)))
		    (close (gtk-button-new-with-label "Close"))
		    (hbox (gtk-hbox-new #f 1))
		    (vbox (gtk-vbox-new #f 3)))

	       (gtk-container-add window vbox)
	       (gtk-box-pack-start vbox hbox #t #t 0)
	       (gtk-box-pack-start hbox text #t #t 0)
	       (gtk-box-pack-start hbox vscroll #f #t 0)
	       (gtk-box-pack-start vbox close #f #t 0)
	       (gtk-window-set-title window "guile-gtk error messages")
	       (gtk-widget-set-usize window 320 200)
	       (gtk-window-set-policy window #t #t #f)
	       (gtk-signal-connect close "clicked"
				   (lambda () (gtk-widget-destroy window)))
	       (gtk-signal-connect window "destroy"
				   (lambda () 
				     (set! window #f)
				     (set! text #f)))
	       (gtk-widget-show-all window))))
      (gtk-text-insert text #f #f #f msg -1))))

(define (call-with-error-catching thunk)
  (let ((the-last-stack #f)
	(stack-saved? #f))
    
    (define (handle-error key args)
      (let ((text (call-with-output-string
		   (lambda (cep)
		     (if the-last-stack
			 (display-backtrace the-last-stack cep)
			 (display "no backtrace available.\n" cep))
		     (apply display-error the-last-stack cep args)))))
	(gtk-show-error text)
	#f))

    (define (save-stack)
      (cond (stack-saved?)
	    ((not (memq 'debug (debug-options-interface)))
	     (set! the-last-stack #f)
	     (set! stack-saved? #t))
	    (else
	     (set! the-last-stack (make-stack #t lazy-dispatch 4))
	     (set! stack-saved? #t))))

    (define (lazy-dispatch key . args)
      (save-stack)
      (apply throw key args))

    (start-stack #t
		 (catch #t
			(lambda ()
			  (lazy-catch #t
				      thunk
				      lazy-dispatch))
			(lambda (key . args)
			  (if (= (length args) 4)
			      (handle-error key args)
			      (apply throw key args)))))))

(define-macro (with-error-catching . body)
  `(call-with-error-catching (lambda () ,@body)))

(gtk-callback-trampoline (lambda (proc args)
			   (with-error-catching
			    (apply proc args))))