home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / gtk-1.2 / gtk.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  3.1 KB  |  107 lines
  1. (define-module (gtk-1.2 gtk)
  2.   :use-module (gtk-1.2 dynlink))
  3.  
  4. (define-public gtk-major-version 1)
  5. (define-public gtk-minor-version 2)
  6.  
  7. (merge-compiled-code "sgtk_init_gtk_gtk_glue" "libguilegtk-1.2")
  8.  
  9. (define-public (gtk-update)
  10.   (cond ((> (gtk-events-pending) 0)
  11.      (gtk-main-iteration)
  12.      (gtk-update))))
  13.  
  14. (define-public (gtk-standalone-main toplevel)
  15.   (cond ((gtk-standalone?)
  16.      (gtk-signal-connect toplevel "destroy" gtk-exit)
  17.      (gtk-main))))
  18.  
  19. ;; Some aliases and quickies
  20.  
  21. (define-public gtk-radio-menu-item-new 
  22.   gtk-radio-menu-item-new-from-widget)
  23. (define-public gtk-radio-menu-item-new-with-label
  24.   gtk-radio-menu-item-new-with-label-from-widget)
  25. (define-public gtk-radio-button-new
  26.   gtk-radio-button-new-from-widget)
  27. (define-public gtk-radio-button-new-with-label
  28.   gtk-radio-button-new-with-label-from-widget)
  29. (define-public (gtk-idle-add proc)
  30.   (gtk-idle-add-full 0 proc))
  31.  
  32. ;; The error reporter
  33.  
  34. (define-public gtk-show-error
  35.   (let ((window #f)
  36.     (text #f))
  37.     (lambda (msg)
  38.       (cond ((not window)
  39.          (set! window (gtk-window-new 'toplevel))
  40.          (set! text (gtk-text-new #f #f))
  41.          (let* ((vscroll (gtk-vscrollbar-new (gtk-text-vadj text)))
  42.             (close (gtk-button-new-with-label "Close"))
  43.             (hbox (gtk-hbox-new #f 1))
  44.             (vbox (gtk-vbox-new #f 3)))
  45.  
  46.            (gtk-container-add window vbox)
  47.            (gtk-box-pack-start vbox hbox #t #t 0)
  48.            (gtk-box-pack-start hbox text #t #t 0)
  49.            (gtk-box-pack-start hbox vscroll #f #t 0)
  50.            (gtk-box-pack-start vbox close #f #t 0)
  51.            (gtk-window-set-title window "guile-gtk error messages")
  52.            (gtk-widget-set-usize window 320 200)
  53.            (gtk-window-set-policy window #t #t #f)
  54.            (gtk-signal-connect close "clicked"
  55.                    (lambda () (gtk-widget-destroy window)))
  56.            (gtk-signal-connect window "destroy"
  57.                    (lambda () 
  58.                      (set! window #f)
  59.                      (set! text #f)))
  60.            (gtk-widget-show-all window))))
  61.       (gtk-text-insert text #f #f #f msg -1))))
  62.  
  63. (define (call-with-error-catching thunk)
  64.   (let ((the-last-stack #f)
  65.     (stack-saved? #f))
  66.     
  67.     (define (handle-error key args)
  68.       (let ((text (call-with-output-string
  69.            (lambda (cep)
  70.              (if the-last-stack
  71.              (display-backtrace the-last-stack cep)
  72.              (display "no backtrace available.\n" cep))
  73.              (apply display-error the-last-stack cep args)))))
  74.     (gtk-show-error text)
  75.     #f))
  76.  
  77.     (define (save-stack)
  78.       (cond (stack-saved?)
  79.         ((not (memq 'debug (debug-options-interface)))
  80.          (set! the-last-stack #f)
  81.          (set! stack-saved? #t))
  82.         (else
  83.          (set! the-last-stack (make-stack #t lazy-dispatch 4))
  84.          (set! stack-saved? #t))))
  85.  
  86.     (define (lazy-dispatch key . args)
  87.       (save-stack)
  88.       (apply throw key args))
  89.  
  90.     (start-stack #t
  91.          (catch #t
  92.             (lambda ()
  93.               (lazy-catch #t
  94.                       thunk
  95.                       lazy-dispatch))
  96.             (lambda (key . args)
  97.               (if (= (length args) 4)
  98.                   (handle-error key args)
  99.                   (apply throw key args)))))))
  100.  
  101. (define-macro (with-error-catching . body)
  102.   `(call-with-error-catching (lambda () ,@body)))
  103.  
  104. (gtk-callback-trampoline (lambda (proc args)
  105.                (with-error-catching
  106.                 (apply proc args))))
  107.