@copying
This manual documents @acronym{Gtk} @value{VERSION}.
-Copyright @copyright{} 2008, 2009, 2010 Matthew Birkholz
+Copyright @copyright{} 2008, 2009, 2010, 2011 Matthew Birkholz
@quotation
Permission is granted to copy, distribute and/or modify this document
@example
../microcode/scheme --library ../lib
- (load-option 'GTK)
+ (load-option 'Gtk)
(make-gtk-event-viewer-demo)
@end example
@node Debugging Facilities, , Gdk Functions, API Reference
@section Debugging Facilities
-@deffn Procedure kill-gtk-thread
+@deffn Procedure stop-gtk-thread
A convenient procedure to call in an emergency.
@end deffn
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
#f)
(define (start-spinning drawing)
+ (let ((thread (create-spinner drawing)))
+ (detach-thread thread)
+ thread))
+
+(define (create-spinner drawing)
(create-thread
#f
(lambda ()
(loop (modulo (fix:1+ frame) frames)))))))))
(define (start-blinking drawing)
+ (let ((thread (create-blinker drawing)))
+ (detach-thread thread)
+ thread))
+
+(define (create-blinker drawing)
(create-thread
#f
(lambda ()
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(trace ";((initialize-instance <fix-layout>) "widget" "width" "height")...\n")
(call-next-method widget)
(let ((alien (gobject-alien widget)))
- (let ((geometry (fix-layout-geometry widget))
- (w (->requisition-fixnum width))
+ (let ((w (->requisition-fixnum width))
(h (->requisition-fixnum height)))
- (C->= alien "GtkWidget requisition width" w)
- (C->= alien "GtkWidget requisition height" h)
- (set-fix-rect-size! geometry w h))
-
+ (C-call "gtk_widget_set_size_request" alien w h))
(C-call "gtk_widget_set_has_window" alien 1)
(C-call "gtk_widget_set_can_focus" alien 1))
(set-gtk-object-destroy-callback! widget)
(define-generic fix-layout-realize-callback (layout))
(define-method fix-layout-realize-callback ((widget <fix-layout>))
- (trace ";fix-layout-realize-<fix-layout> "widget"\n")
+ (trace ";((fix-layout-realize-callback <fix-layout>) "widget")...\n")
(let ((geometry (fix-layout-geometry widget))
(attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|))
(main-GdkWindow (fix-layout-window widget))
;; For the convenience of SWAT's canvas item group, mostly.
(define-generic fix-ink-move! (ink dx dy))
+
+;; Use this to define your fix-ink-move! method iff your extent is all
+;; that needs to be updated when you move. This is not a default
+;; method, else things might (only) appear to work.
+(define-integrable (generic-fix-ink-move! ink dx dy)
+ (without-interrupts
+ (lambda ()
+ (let ((extent (fix-ink-extent ink)))
+ (drawing-damage ink)
+ (fix-rect-move! extent dx dy)
+ (drawing-damage ink)))))
\f
;; This kind of ink draws (outlines and/or fills) a shape using a
;; gdk_draw_* function with a GdkGC from gtk_gc_get (i.e. using the
(drawing-damage ink)))))))
(define-method fix-ink-move! ((ink <text-ink>) dx dy)
- (without-interrupts
- (lambda ()
- (let ((extent (fix-ink-extent ink)))
- (drawing-damage ink)
- (fix-rect-move! extent dx dy)
- (drawing-damage ink)))))
+ (generic-fix-ink-move! ink dx dy))
(define (recache-text-extent! ink)
(let ((layout (text-ink-pango-layout ink))
(ink-extent (pango-rectangle))
(logical-extent (pango-rectangle)))
- (trace ";recache-text-extent!")
(C-call "pango_layout_get_pixel_extents"
(gobject-alien layout) 0 logical-extent)
(drawing-damage ink)
0 0 ;x_dither, y_dither
))))))))
+(define-method fix-ink-move! ((ink <image-ink>) dx dy)
+ (generic-fix-ink-move! ink dx dy))
+
(define (make-image-ink-from-file filename)
(let ((ink (make-image-ink)))
(load-pixbuf-from-file (image-ink-loader ink) filename)
(fix-rect-width extent)
(fix-rect-height extent)))))
+(define-method fix-ink-move! ((ink <box-ink>) dx dy)
+ (generic-fix-ink-move! ink dx dy))
+
(define (set-box-ink! ink x y width height)
(guarantee-fixnum x 'set-box-ink!)
(guarantee-fixnum y 'set-box-ink!)
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(if (pixbuf-loader-port loader)
(error "Pixbuf loader has already started:" loader))
(set-pixbuf-loader-port! loader input-port)
- (set-pixbuf-loader-thread! loader (create-pixbuf-loader-thread loader)))))
+ (let ((thread (create-pixbuf-loader-thread loader)))
+ (set-pixbuf-loader-thread! loader thread)
+ (detach-thread thread)))))
(define (create-pixbuf-loader-thread loader)
(create-thread
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
set-fix-layout-motion-handler!
set-fix-layout-button-handler!
- <fix-drawing> make-fix-drawing fix-drawing-widgets
+ <fix-drawing> guarantee-fix-drawing
+ make-fix-drawing fix-drawing-widgets
set-fix-drawing-size! fix-drawing-pick-list
fix-drawing-add-ink!
(parent (runtime thread))
(files "thread")
(depends-on "gtk.ext" "pango.ext")
- (export (gtk)
- kill-gtk-thread)
+ (export ()
+ stop-gtk-thread)
(import (gtk gobject)
run-gc-cleanups)
(import (runtime primitive-io)
default/process-command-line)
(import (runtime)
ucode-primitive)
+ (import (runtime subprocess)
+ hook/subprocess-wait nonblocking/subprocess-wait)
(import (gtk thread)
- create-gtk-thread)
- (export (gtk)
+ create-gtk-thread exit-gtk-thread)
+ (export ()
gtk-time-slice-window?
gtk-time-slice-window!
gtk-select-trace?
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
set-fix-layout-motion-handler!
set-fix-layout-button-handler!
- <fix-drawing> make-fix-drawing fix-drawing-widgets
+ <fix-drawing> guarantee-fix-drawing
+ make-fix-drawing fix-drawing-widgets
set-fix-drawing-size! fix-drawing-pick-list
fix-drawing-add-ink!
(define-package (gtk thread)
(parent (runtime thread))
(files "thread")
- (export (gtk)
- kill-gtk-thread)
+ (export ()
+ stop-gtk-thread)
(import (gtk gobject)
run-gc-cleanups)
(import (runtime primitive-io)
default/process-command-line)
(import (runtime)
ucode-primitive)
+ (import (runtime subprocess)
+ hook/subprocess-wait nonblocking/subprocess-wait)
(import (gtk thread)
- create-gtk-thread)
- (export (gtk)
+ create-gtk-thread exit-gtk-thread)
+ (export ()
gtk-time-slice-window?
gtk-time-slice-window!
gtk-select-trace?
#| -*-Scheme-*-
-Copyright (C) 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(c-include "gtk")
+(define (gtk-start)
+ (set! hook/subprocess-wait nonblocking/subprocess-wait)
+ (gtk-init ((ucode-primitive scheme-program-name 0)) *unused-command-line*)
+ (gtk-main+))
+
(define (initialize-package!)
(let ((program-name ((ucode-primitive scheme-program-name 0))))
(let ((processor hook/process-command-line))
(processor
(list->vector
(gtk-init program-name (vector->list line))))
- (gtk-main+))))
- (gtk-init program-name *unused-command-line*))
- (gtk-main+))
+ (gtk-main+))))))
(define (gtk-init name args)
;; Call gtk_init_check. Signals an error if gtk_init_check returns 0.
;; Sortof does the opposite of gtk-main+.
(without-interrupts
(lambda ()
- (kill-gtk-thread)
+ (exit-gtk-thread)
(C-call "gtk_main_plus_quit"))))
(define (gtk-time-slice-window?)
(C-call "gtk_time_slice_window_p"))
(define (gtk-time-slice-window! open?)
- (C-call "gtk_time_slice_window" open?))
+ (C-call "gtk_time_slice_window" (if open? 1 0)))
(define (gtk-select-trace?)
(C-call "gtk_select_trace_p"))
(with-loader-base-uri (system-library-uri "gtk/")
(lambda ()
(load-package-set "gtk")))
-(add-subsystem-identification! "Gtk" '(0 2))
\ No newline at end of file
+(add-subsystem-identification! "Gtk" '(0 2))
+((access gtk-start (->environment '(gtk main))))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2010 Matthew Birkholz
+Copyright (C) 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(define (initialize-package!)
(set! swat-input-queue (make-thread-queue 100))
- (set! swat-thread (make-swat-thread)))
+ (set! swat-thread (create-swat-thread))
+ (detach-thread swat-thread))
-(define (make-swat-thread)
+(define (create-swat-thread)
(create-thread
#f
(lambda ()
(define (after-delay seconds thunk)
(guarantee-index-fixnum seconds 'after-delay)
(guarantee-procedure-of-arity thunk 0 'after-delay)
- (create-thread
- #f
- (lambda ()
- (trace ";after-delay "seconds", sleeping "(current-thread)"\n")
- (sleep-current-thread (* seconds 1000))
- (thunk)
- (stop-current-thread))))
+ (detach-thread
+ (create-thread
+ #f
+ (lambda ()
+ (trace ";after-delay "seconds", sleeping "(current-thread)"\n")
+ (sleep-current-thread (* seconds 1000))
+ (thunk)
+ (stop-current-thread)))))
;;; * widget-mit
;;;
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(trace ";run-gtk done at "(real-time-clock)"\n"))
(maybe-signal-io-thread-events)))
(yield-current-thread)
- (gtk-thread-loop)))))))
+ (gtk-thread-loop))))))
+ (detach-thread gtk-thread))
(define (no-threads-nor-timers)
(error "gtk-thread: no threads, no timers: "next-scheduled-timeout))
-(define (kill-gtk-thread)
+(define (exit-gtk-thread)
(let ((thread gtk-thread))
(set! gtk-thread #f)
(if (not thread) (error "A GTk thread was not running."))
thread (lambda ()
(exit-current-thread #t)))))
+(define (stop-gtk-thread)
+ (signal-thread-event gtk-thread (lambda () (stop-current-thread))))
+
+(define (restart-gtk-thread)
+ (restart-thread gtk-thread #t #f))
+
(define trace? #f)
(define-syntax trace
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
+ Technology
This file is part of MIT/GNU Scheme.
= (poll ((SR_ENTRIES (r)),
(SR_N_FDS (r)),
(blockp ? INFTIM : 0)));
- if (nfds >= 0)
+ if (nfds > 0)
return (nfds);
- if (errno != EINTR)
+ if (nfds < 0 && errno != EINTR)
error_system_call (errno, syscall_select);
if (OS_process_any_status_change ())
return (SELECT_PROCESS_STATUS_CHANGE);
if (pending_interrupts_p ())
return (SELECT_INTERRUPT);
+ /* nfds == 0, AND no status-change nor interrupts pending */
+ return (0);
}
}
int nfds = (poll (pfds, 1, (blockp ? INFTIM : 0)));
if (nfds > 0)
return (ENCODE_MODE ((pfds [0]) . revents));
- if (nfds == 0)
- return (0);
- if (errno != EINTR)
+ if (nfds < 0 && errno != EINTR)
error_system_call (errno, syscall_select);
if (OS_process_any_status_change ())
return (SELECT_PROCESS_STATUS_CHANGE);
if (pending_interrupts_p ())
return (SELECT_INTERRUPT);
+ /* nfds == 0, AND no status-change nor interrupts pending */
+ return (0);
}
}
(SR_RWRITERS (r)),
0,
(blockp ? 0 : (&zero_timeout))))));
- if (nfds >= 0)
+ if (nfds > 0)
return (nfds);
- if (errno != EINTR)
+ if (nfds < 0 && errno != EINTR)
error_system_call (errno, syscall_select);
if (OS_process_any_status_change ())
return (SELECT_PROCESS_STATUS_CHANGE);
if (pending_interrupts_p ())
return (SELECT_INTERRUPT);
+ /* nfds == 0, AND no status-change nor interrupts pending */
+ return (0);
}
#else
error_system_call (ENOSYS, syscall_select);
return
(((FD_ISSET (fd, (&readable))) ? SELECT_MODE_READ : 0)
| ((FD_ISSET (fd, (&writeable))) ? SELECT_MODE_WRITE : 0));
- if (nfds == 0)
- return (0);
- if (errno != EINTR)
+ if (nfds < 0 && errno != EINTR)
error_system_call (errno, syscall_select);
if (OS_process_any_status_change ())
return (SELECT_PROCESS_STATUS_CHANGE);
if (pending_interrupts_p ())
return (SELECT_INTERRUPT);
+ /* nfds == 0, AND no status-change nor interrupts pending */
+ return (0);
}
#else
error_system_call (ENOSYS, syscall_select);
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
+ Technology
This file is part of MIT/GNU Scheme.
(define (subprocess-wait process)
(let loop ()
- ((ucode-primitive process-wait 1) (subprocess-index process))
+ (hook/subprocess-wait process)
(let ((status (%subprocess-status process)))
(if (eqv? status 0)
(loop)
(convert-subprocess-status status)))))
+(define (normal/subprocess-wait process)
+ ((ucode-primitive process-wait 1) (subprocess-index process)))
+
+(define (nonblocking/subprocess-wait process)
+ (without-interrupts
+ (lambda ()
+ (let ((status (%subprocess-status process)))
+ (if (eqv? status 0)
+ (begin
+ (block-on-process-status-change)
+ (subprocess-global-status-tick)
+ (handle-subprocess-status-change)))))))
+
+(define hook/subprocess-wait normal/subprocess-wait)
+
(define (subprocess-continue-foreground process)
(let loop ()
((ucode-primitive process-continue-foreground 1)
(else (error "Illegal process job-control status:" n)))))
\f
(define (handle-subprocess-status-change)
+ (if hook/subprocess-status-change (hook/subprocess-status-change))
(if (eq? 'NT microcode-id/operating-system)
(for-each (lambda (process)
(if (memq (subprocess-status process) '(EXITED SIGNALLED))
(close-subprocess-i/o process)))
(subprocess-list))))
+(define hook/subprocess-status-change #f)
+
(define-integrable subprocess-job-control-available?
(ucode-primitive os-job-control? 0))
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
+ Technology
This file is part of MIT/GNU Scheme.
handle-subprocess-status-change)
(export (runtime socket)
handle-subprocess-status-change)
+ (import (runtime thread)
+ block-on-process-status-change)
(initialization (initialize-package!)))
(define-package (runtime synchronous-subprocess)
#| -*-Scheme-*-
-Copyright (C) 2005, 2009 Matthew Birkholz
+Copyright (C) 2005, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
#f)
(%queue! queue item))))
+(define (thread-queue/dequeue-no-hang queue timeout)
+ (guarantee-thread-queue queue 'thread-queue/dequeue-no-hang)
+ (guarantee-non-negative-fixnum timeout 'thread-queue/dequeue-no-hang)
+ (thread-queue/dequeue-until queue (+ (real-time-clock) timeout)))
+
+(define (thread-queue/dequeue-until queue time)
+ (guarantee-thread-queue queue 'thread-queue/dequeue-until)
+ (guarantee-integer time 'thread-queue/dequeue-until)
+ (when-non-empty-before time queue %dequeue!))
+
+(declare (integrable-operator when-non-empty-before))
+(define (when-non-empty-before time queue operation)
+ (without-interrupts
+ (lambda ()
+ (let loop ()
+ (if (not (%empty? queue))
+ (operation queue)
+ (let ((now (real-time-clock)))
+ (if (<= time now)
+ #f
+ (begin
+ (register-timer-event (- time now) (lambda () unspecific))
+ (suspend-current-thread)
+ (loop)))))))))
+
(define (thread-queue/dequeue! queue)
(without-interrupts
(lambda ()
(list (current-thread))))
(suspend-current-thread)))))
-(define (thread-queue/peek-no-hang queue #!optional timeout)
+(define (thread-queue/peek-no-hang queue timeout)
(guarantee-thread-queue queue 'thread-queue/peek-no-hang)
- (if (not (default-object? timeout))
- (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang))
- (let ((timeout (if (default-object? timeout) 0 timeout))
- (time (real-time-clock)))
- (thread-queue/peek-until queue (+ time timeout))))
+ (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang)
+ (thread-queue/peek-until queue (+ (real-time-clock) timeout)))
(define (thread-queue/peek-until queue time)
(guarantee-thread-queue queue 'thread-queue/peek-until)
(guarantee-integer time 'thread-queue/peek-until)
- (without-interrupts
- (lambda ()
- (let loop ()
- (if (not (%empty? queue))
- (car (%thread-queue/first-pair queue))
- (let ((now (real-time-clock)))
- (if (<= time now)
- #f
- (begin
- (register-timer-event (- time now) (lambda () unspecific))
- (suspend-current-thread)
- (loop)))))))))
+ (when-non-empty-before time queue %peek))
(define (thread-queue/peek queue)
(without-interrupts
(lambda ()
(do ()
((and (not (%empty? queue))
- (car (%thread-queue/first-pair queue))))
+ (%peek queue)))
(set-%thread-queue/waiting-dequeuers!
queue (append! (%thread-queue/waiting-dequeuers queue)
(list (current-thread))))
(suspend-current-thread)))))
\f
+(define-integrable (%peek queue)
+ (car (%thread-queue/first-pair queue)))
(define (%queue! queue item)
(let ((last (%thread-queue/last-pair queue))
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
+ 2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
+ Technology
This file is part of MIT/GNU Scheme.
(define (maybe-signal-io-thread-events)
(if io-registrations
- (signal-select-result (test-select-registry io-registry #f))))
+ (let ((result (test-select-registry io-registry #f)))
+ (trace "maybe-signal-io-thread-events: "result" "io-registry"\n")
+ (signal-select-result result))))
(define (block-on-io-descriptor descriptor mode)
(without-interrupts
(%deregister-io-thread-event registration-2)
(%deregister-io-thread-event registration-1)
(%maybe-toggle-thread-timer)))))))
+
+(define (block-on-process-status-change)
+ (without-interrupts
+ (lambda ()
+ (let ((registration))
+ (dynamic-wind
+ (lambda ()
+ (let ((thread (current-thread)))
+ (set! registration
+ (%register-io-thread-event
+ 'PROCESS-STATUS-CHANGE
+ 'READ
+ thread
+ (lambda (mode)
+ (declare (ignore mode))
+ unspecific)
+ #f #t)))
+ (%maybe-toggle-thread-timer))
+ (lambda ()
+ (%suspend-current-thread))
+ (lambda ()
+ (%deregister-io-thread-event registration)
+ (%maybe-toggle-thread-timer)))))))
\f
(define (permanently-register-io-thread-event descriptor mode thread event)
(register-io-thread-event-1 descriptor mode thread event
projects / mit-scheme.git / commitdiff