[MIT-Scheme-devel] GTk+ in MIT-Scheme?

[Matt Birkholz]

> From: Matt Birkholz <address@hidden>
> Date: Wed, 23 Mar 2005 16:16:38 +0000
> 
> [...]
> Did my foot get shot?

Yep, this new thread is just part of my on-going soliloquy.

Nope, I am not feeling any pain.

I am feeling pretty good, actually.  I have a simple "Hello, world!"
program (below) running in Edwin's *scheme* REPListener, AND
evaluating sexprs in the terminal (after spawning Edwin via
create-thread), AND clicking on my "Hello, world!"  GtkButton -- all
simultaneous-like.  Clicking on the close (X) button cleans things up
even!  I think I know enough to start auto-generating the glue code,
but where to go with that?

I am not looking for compiled Scheme code to drive forms (labels,
buttons, and all that) really really fast.  I want a fancier kind of
Edwin window.  But the Gnome canvas looks a bit clunky for such a
use.  I would hate to re-write all of the canvas's functionality in
Scheme, or maybe... maybe I would LIKE it...


;;; Havoc Pennington's Hello World example from _GTK+_/_Gnome_
;;; Application_Development_

(define (main)
  (let* ((window (gtk-window-new 'toplevel))
         (button (gtk-button-new))
         (label (gtk-label-new "Hello, world!"))
         (delete-event-cb
          (lambda (window)
            (gtk-widget-destroy window)))
         (button-click-cb
          (lambda (window)
            (let ((text (gtk-label-get-text label)))
              (gtk-label-set-text
               label (list->string (reverse! (string->list text))))))))
    (gtk-container-add button label)
    (gtk-container-add window button)
    (gtk-window-set-title window "Hello")
    (gtk-container-set-border-width button 10)
    (g-object-connect window 'delete_event delete-event-cb)
    (g-object-connect button 'clicked button-click-cb)
    (gtk-widget-show-all window)))


Just to tease y'all, here's how I patched the (runtime thread) package
to make this work.  The ucode-primitive syntax highlights my new
primitives.

;;;-*-Scheme-*-
;;;
;;; Load into the (runtime thread) package.
;;;
;;; This file redefines the procedure that handles the results of the
;;; test-select-registry procedure, which now can return 'CALLBACKS.
;;; Also redefines the thread timer interrupt handler to yield to the
;;; toolkit (via the new return-to-c primitive) in addition to the
;;; other Scheme threads.

(define (thread-timer-interrupt-handler)
  (set-interrupt-enables! interrupt-mask/gc-ok)
  ((ucode-primitive return-to-C 0))                             ;ADDED
  (deliver-timer-events)
  (maybe-signal-io-thread-events)
  (let ((thread first-running-thread))
    (cond ((not thread)
           (%maybe-toggle-thread-timer))
          ((thread/continuation thread)
           (run-thread thread))
          ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
                     (thread/execution-state thread)))
           (yield-thread thread))
          (else
           (%resume-current-thread thread)))))

(define (signal-select-result result)
  (cond ((vector? result)
         (signal-io-thread-events (vector-ref result 0)
                                  (vector-ref result 1)
                                  (vector-ref result 2)))
        ((eq? 'PROCESS-STATUS-CHANGE result)
         (signal-io-thread-events 1
                                  '#(PROCESS-STATUS-CHANGE)
                                  '#(READ)))
        ((eq? 'CALLBACKS result)                                ;ADDED
         (signal-callbacks))))

(define (signal-callbacks)                              ;TOTALLY ADDED
  (let loop ()
    (let ((data ((ucode-primitive dequeue-callback))))
      (debug-display "Callback data: " data)
      (if (not data)
          #f
          (let ((signal-quark (car data))
                (gobject-id (cadr data)))
            (if (= signal-quark destroy-quark)
                ;; The destroy callback is a special case.
                (g-object-destroy gobject-id)
                (let* ((gobject (g-object gobject-id))
                       (thread (g-object-thread gobject)))
                  (if (eq? (thread/execution-state thread) 'DEAD)
                      ;; If the g-object's thread is dead, just forget
                      ;; about it.  Maybe destroy the widget???
                      unspecific
                      (%signal-thread-event thread
                        (lambda ()
                          (dispatch-callback
                           gobject signal-quark (cddr data)))))))
            (loop))))))

(define (dispatch-callback gobject signal-quark arguments)
  (let* ((entry (assv signal-quark (g-object-callbacks gobject)))
         (callback (and entry (cdr entry))))
    (if (not callback)
        (error "No callback for signal" signal-quark gobject)
        (apply callback gobject arguments)))
  unspecific)

(define destroy-quark ((ucode-primitive intern-quark) "destroy"))
(define (g-object-destroy id)
  ;; Zeros the g-object's id and frees it from the all-g-objects
  ;; vector.
  (let ((gobject (vector-ref all-g-objects id)))
    (vector-set! all-g-objects id #f)
    (set-g-object-%id! gobject #f))
  ((ucode-primitive deallocate-g-object-id) id)
  unspecific)