;; Whether a cursor should be blinking.
(in-focus? define standard initial-value #f))
-(define screen-list)
+(define screen-list) ;serialize with glib lock
(define (make-gtk-screen #!optional geometry)
(%trace "; make-gtk-screen "geometry"\n")
- (let* ((toplevel (gtk-window-new 'toplevel))
- (screen (%make-gtk-screen toplevel (current-thread) (make-queue)))
- (geometry* (if (default-object? geometry)
- "80x24"
- (begin
- (guarantee-string geometry 'make-gtk-screen)
- geometry))))
- (gtk-widget-set-opacity toplevel 0.95)
- (init-font-dimensions! screen "Monospace 11")
- (init-size! screen geometry*)
- (let ((thread (create-blinker-thread screen)))
- (%trace "; blinker thread: "thread"\n")
- (set-gtk-screen-blinker! screen thread)
- (detach-thread thread)
- (%trace "; editor thread: "(current-thread)"\n"))
- (set! screen-list (cons screen screen-list))
- (%trace "; screen: "screen"\n")
- screen))
+ (with-glib-lock
+ (lambda ()
+ (let* ((toplevel (gtk-window-new 'toplevel))
+ (screen (%make-gtk-screen toplevel (current-thread) (make-queue)))
+ (geometry* (if (default-object? geometry)
+ "80x24"
+ (begin
+ (guarantee-string geometry 'make-gtk-screen)
+ geometry))))
+ (gtk-widget-set-opacity toplevel 0.95)
+ (init-font-dimensions! screen "Monospace 11")
+ (init-size! screen geometry*)
+ (let ((thread (create-blinker-thread screen)))
+ (%trace "; blinker thread: "thread"\n")
+ (set-gtk-screen-blinker! screen thread)
+ (detach-thread thread)
+ (%trace "; editor thread: "(current-thread)"\n"))
+ (set! screen-list (cons screen screen-list))
+ (%trace "; screen: "screen"\n")
+ screen))))
(define (init-font-dimensions! screen spec)
(%trace "; init-font-dimensions! "screen" "spec"\n")
(define-method set-screen-size! ((screen <gtk-screen>) x-size y-size)
(%trace "; (set-screen-size! <gtk-screen>) "screen" "x-size"x"y-size"\n")
- (without-interrupts
+ (%without-interruption
(lambda ()
(set-screen-x-size! screen x-size)
(set-screen-y-size! screen y-size)
(lambda ()
(%trace2 ";blinking started on "screen"\n")
(let loop ()
- (without-interrupts
+ (%without-interruption
(lambda ()
(let ((cursor (gtk-screen-blinking screen)))
(cond ((not cursor)
(%trace2 ";blinker: awake after invisible "cursor"\n"))
(else
(%trace3 ";blinker: off "cursor"\n")
- (set-fix-ink-widgets! cursor '())
+ (with-glib-lock
+ (lambda () (set-fix-ink-widgets! cursor '())))
(sleep-current-thread 500)
(if (cursor-ink-visible? cursor)
(begin
(%trace3 ";blinker: on "cursor"\n")
- (set-fix-ink-widgets! cursor
- (cursor-ink-widget-list cursor))
+ (with-glib-lock
+ (lambda ()
+ (set-fix-ink-widgets!
+ cursor (cursor-ink-widget-list cursor))))
(sleep-current-thread 500))
(begin
(%trace ";blinker: on: invisible "cursor"\n")
(loop)))))
\f
(define-method screen-beep ((screen <gtk-screen>))
+ (assert-glib-locked '(screen-beep <gtk-screen>))
(gtk-widget-error-bell (gtk-screen-toplevel screen)))
(define-method screen-enter! ((screen <gtk-screen>))
(%trace "; screen-enter! "screen"\n")
+ (assert-glib-locked '(screen-enter! <gtk-screen>))
(update-widgets screen)
(gtk-window-present (gtk-screen-toplevel screen))
(%trace "; screen-enter!: done\n"))
(define-method screen-exit! ((screen <gtk-screen>))
(%trace "; screen-exit! "screen"\n")
+ (assert-glib-locked '(screen-exit! <gtk-screen>))
(set-gtk-screen-in-focus?! screen #f)
(update-blinking screen))
(define-method screen-discard! ((screen <gtk-screen>))
+ (%trace "; screen-discard! "screen"\n")
+ (assert-glib-locked '(screen-discard! <gtk-screen>))
(set! screen-list (delq! screen screen-list))
(gtk-widget-destroy (gtk-screen-toplevel screen))
(pango-font-description-free (gtk-screen-font screen)))
+(define %glib-mutex (access glib-mutex (->environment '(glib))))
(define-method screen-modeline-event! ((screen <gtk-screen>) window type)
- (%trace "; screen-modeline-event! "screen" "window" "type"\n"))
+ (%trace "; screen-modeline-event! "screen" "window" "type"\n")
+ ;;(assert-glib-locked '(screen-modeline-event! <gtk-screen>))
+ (if (not (eq? (current-thread) (thread-mutex-owner %glib-mutex)))
+ (begin
+ (outf-error "Yo!\n")
+ (error "yo:" screen window type)))
+ unspecific)
\f
;;; These scrolling procedures are for editor commands (not
;;; scrollbars). They force a buffer-drawing layout update
(define-method screen/window-scroll-y-absolute! ((screen <gtk-screen>)
frame y-point)
(%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n")
+ (assert-glib-locked '(screen/window-scroll-y-absolute! <gtk-screen>))
(with-updated-window
screen frame 'SCROLL-Y-ABSOLUTE!
(lambda (widget)
(define-method screen/window-scroll-y-relative! ((screen <gtk-screen>)
frame delta)
(%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n")
+ (assert-glib-locked '(screen/window-scroll-y-relative! <gtk-screen>))
(with-updated-window
screen frame 'SCROLL-Y-RELATIVE!
(lambda (widget)
(define-method screen/set-window-start-mark! ((screen <gtk-screen>)
frame mark force?)
(%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n")
+ (assert-glib-locked '(screen/set-window-start-mark! <gtk-screen>))
(with-updated-window
screen frame 'SET-START-MARK!
(lambda (widget)
(define-method screen/window-mark-visible? ((screen <gtk-screen>) frame mark)
(%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n")
+ (assert-glib-locked '(screen/window-mark-visible? <gtk-screen>))
(with-updated-window
screen frame 'MARK-VISIBLE?
(lambda (widget)
(define-method screen/window-mark->x ((screen <gtk-screen>) frame mark)
(%trace "; screen/window-mark->x "screen" "frame" "mark"\n")
+ (assert-glib-locked '(screen/window-mark->x <gtk-screen>))
(with-updated-window
screen frame 'MARK->X
(lambda (widget)
(define-method screen/window-mark->y ((screen <gtk-screen>) frame mark)
(%trace "; screen/window-mark->y "screen" "frame" "mark"\n")
+ (assert-glib-locked '(screen/window-mark->y <gtk-screen>))
(with-updated-window
screen frame 'MARK->Y
(lambda (widget)
(define-method screen/window-mark->coordinates ((screen <gtk-screen>)
frame mark)
(%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n")
+ (assert-glib-locked '(screen/window-mark->coordinates <gtk-screen>))
(with-updated-window
screen frame 'MARK->COORDINATES
(lambda (widget)
(line->row line widget screen)))))))
(define-method screen/window-point-x ((screen <gtk-screen>) frame)
+ (assert-glib-locked '(screen/window-point-x <gtk-screen>))
(screen/window-mark->x screen frame (window-point frame)))
(define-method screen/window-point-y ((screen <gtk-screen>) frame)
+ (assert-glib-locked '(screen/window-point-y <gtk-screen>))
(screen/window-mark->y screen frame (window-point frame)))
(define-method screen/window-point-coordinates ((screen <gtk-screen>) frame)
+ (assert-glib-locked '(screen/window-point-coordinates <gtk-screen>))
(screen/window-mark->coordinates screen frame (window-point frame)))
(define-method screen/window-coordinates->mark ((screen <gtk-screen>)
frame x y)
(%trace "; screen/window-coordinates->mark "screen" "frame" "x" "y"\n")
(%trace-buttons "coordinates->mark "screen" "frame" "x" "y)
+ (assert-glib-locked '(screen/window-coordinates->mark! <gtk-screen>))
(with-updated-window
screen frame 'COORDINATES->MARK
(lambda (widget)
((INPUT-EVENT)
#t)
((PROCESS-STATUS)
- (if (handle-process-status-changes)
- (update-screens! #f))
+ (with-glib-lock
+ (lambda ()
+ (if (handle-process-status-changes)
+ (update-screens! #f))))
(loop))
((PROCESS-OUTPUT)
- (if (accept-process-output)
- (update-screens! #f))
+ (with-glib-lock
+ (lambda ()
+ (if (accept-process-output)
+ (update-screens! #f))))
(loop))
((INFERIOR-THREAD-OUTPUT)
- (if (accept-thread-output)
- (update-screens! #f))
+ (with-glib-lock
+ (lambda ()
+ (if (accept-thread-output)
+ (update-screens! #f))))
(loop))
((TIMEOUT)
#f)
halt?))
(named-lambda (gtk-screen-peek-no-hang msec)
(%trace2 ";peek-no-hang "msec"\n")
- (let ((event (and (block-for-input-event event-queue msec)
- (queue/peek event-queue))))
- (%trace2 ";peek-no-hang "msec" => "event"\n")
- event))
+ (without-glib-lock
+ (lambda ()
+ (let ((event (and (block-for-input-event event-queue msec)
+ (queue/peek event-queue))))
+ (%trace2 ";peek-no-hang "msec" => "event"\n")
+ event))))
(named-lambda (gtk-screen-peek)
(%trace2 ";peek\n")
- (let ((event (and (block-for-input-event event-queue #f)
- (queue/peek event-queue))))
- (%trace2 ";peek => "event"\n")
- event))
+ (without-glib-lock
+ (lambda ()
+ (let ((event (and (block-for-input-event event-queue #f)
+ (queue/peek event-queue))))
+ (%trace2 ";peek => "event"\n")
+ event))))
(named-lambda (gtk-screen-read)
(%trace2 ";read\n")
- (let ((event (and (block-for-input-event event-queue #f)
- (dequeue!/unsafe event-queue))))
- (%trace2 ";read => "event"\n")
- event)))))
+ (without-glib-lock
+ (lambda ()
+ (let ((event (and (block-for-input-event event-queue #f)
+ (dequeue!/unsafe event-queue))))
+ (%trace2 ";read => "event"\n")
+ event)))))))
(set!
os/interprogram-cut
(named-lambda (os/interprogram-cut string point)
(declare (ignore point))
+ (assert-glib-locked 'os/interprogram-cut)
(gtk-window-set-clipboard-text (gtk-screen-toplevel (selected-screen))
string)))
os/interprogram-paste
(named-lambda (os/interprogram-paste point)
(declare (ignore point))
+ (assert-glib-locked 'os/interprogram-paste)
(gtk-window-get-clipboard-text (gtk-screen-toplevel (selected-screen)))))
-(define interrupts?)
+(define (with-gtk-grabbed receiver)
+ (%trace "; with-gtk-grabbed "(current-thread)"\n")
+ (with-glib-lock (lambda () (receiver with-gtk-ungrabbed '()))))
-(define (interrupt!)
- (%trace ";interrupt!...")
- (if interrupts?
- (begin
- (%trace " signaling.\n")
- (editor-beep)
- (temporary-message "Quit")
- (^G-signal))
- (%trace " masked!\n")))
-
-(define (with-editor-interrupts-from-gtk receiver)
- (fluid-let ((interrupts? #t))
- (%trace ";with-editor-interrupts-from-gtk "(current-thread)"\n")
- (receiver (lambda (thunk) (thunk)) '())))
-
-(define (with-gtk-interrupts-enabled thunk)
- (fluid-let ((interrupts? #t))
- (%trace ";with-gtk-interrupts-enabled\n")
- (let ((v (thunk)))
- (%trace ";with-gtk-interrupts-enabled => "v"\n")
- v)))
-
-(define (with-gtk-interrupts-disabled thunk)
- (fluid-let ((interrupts? #f))
- (%trace ";with-gtk-interrupts-disabled\n")
- (let ((v (thunk)))
- (%trace ";with-gtk-interrupts-disabled => "v"\n")
- v)))
+(define (with-gtk-ungrabbed thunk)
+ (%trace "; with-gtk-ungrabbbed "(current-thread)"\n")
+ (without-glib-lock thunk))
(define (focus-change-handler widget in?)
(%trace "; Focus-"(if in? "in" "out")": "widget"\n")
thread
(lambda ()
(%trace ";interrupt! in editor "(current-thread)"\n")
- (interrupt!)))
+ (editor-beep)
+ (temporary-message "Quit")
+ (^G-signal)))
(%trace "; pushed ^G in "(current-thread)".\n")
#t)
(queue! (merge-bucky-bits k char-bits)))
gtk-initialized?
make-gtk-screen
get-gtk-input-operations
- with-editor-interrupts-from-gtk
- with-gtk-interrupts-enabled
- with-gtk-interrupts-disabled))
+ with-gtk-grabbed
+ %with-interruption
+ %without-interruption))
unspecific)
(define (spawn-edit . args)
unspecific)
(define-method fix-widget-realize-callback ((widget <text-widget>))
- (%trace ";(fix-widget-realize-callback <text-widget>) "widget"\n")
+ (%trace "; (fix-widget-realize-callback <text-widget>) "widget"\n")
(let ((geometry (fix-widget-geometry widget)))
(if (or (not (fix-rect-width geometry))
(not (fix-rect-height geometry)))
widget)
(define-method fix-widget-realize-callback ((widget <modeline-widget>))
- (%trace ";(fix-widget-realize-callback <modeline-widget>) "widget"\n")
+ (%trace "; (fix-widget-realize-callback <modeline-widget>) "widget"\n")
(let ((screen (edwin-widget-screen widget))
(geometry (fix-widget-geometry widget)))
(if (or (not (fix-rect-width geometry))
;; remembers the start and end indices of a line in a buffer and the
;; bounding box of the laid-up line/paragraph, and not much else.
;;
-;; The INCREMENTAL version of this process UPDATES an existing column
+;; The incremental version of this process updates an existing column
;; of <line-ink>s after the buffer has changed. It skips
;; unchanged lines at the top, and re-lays out lines in the change
;; region. Depending on the newlines in the region, it may re-use
;; keep a PangoLayout around to service expose events. A drawing of a
;; large buffer, with thousands of lines, if drawn with
;; simple-text-inks, would allocate thousands of PangoLayouts, each
-;; with an image of a line (the images alone consuming more bytes than
-;; in the original buffer content).
+;; with an image of a line. The images alone would occupy more bytes
+;; than the buffer text.
;;
;; To lighten the footprint of a large buffer drawing, line-inks do
;; not hold a PangoLayout, but create one on demand using the buffer
;; allows most expose events to find exposed line-inks ready with a
;; PangoLayout to paint. As lines scroll into view, new PangoLayouts
;; are allocated (or stolen), and the buffer text is re-imaged,
-;; styled, and re-layed-out just as when originally drawn. Sometimes,
-;; however, the original buffer text is NOT available.
-;;
-;; Expose events arrive ASYNCHRONOUSLY, and may find that a line's
-;; text has changed. The line may extend into (or just touch!) a
-;; buffer's change region. The original buffer text is no longer
-;; available, so the original PangoLayout cannot be re-constructed.
-;; The event handler must PUNT, and leave the line blank. (It will
-;; have been cleared to the background color.)
-;;
-;; To ensure that lines can be exposed as soon as they are re-drawn,
-;; each buffer drawing keeps an "update region" that it narrows as it
-;; redraws. The expose handlers refer to THIS change region, when
-;; available (during Redisplay), rather than the buffer's change
-;; region. Narrowing a buffer-drawing's update region BEFORE
-;; redrawing lines ensures that the resulting expose events will not
-;; be punted.
+;; styled, and re-layed-out just as when originally drawn.
;;
-;; Punted exposures should be infrequent, resulting from external
-;; events (e.g. an obscuring window was closed) exposing lines that
-;; have just recently changed in the buffer, during the tiny Eval and
-;; Redisplay parts of Edwin's main loop. These occasional misses
-;; should be hardly noticeable. The blank line should be quickly
-;; redrawn by the end of Redisplay.
+;; Edwin now runs with the glib lock, giving it up only to read input.
+;; Thus the expose event handler should not run until the end of
+;; redisplay when all drawings are up-to-date and there are no buffer
+;; changed regions, allowing an exposed line ink to re-construct its
+;; PangoLayout from unchanged buffer text.
(define-method update-screen! ((screen <gtk-screen>) display-style)
(%trace "; (update-screen! <gtk-screen>) "screen" "display-style"\n")
(declare (integrate-operator with-screen-in-update))
(define (with-screen-in-update screen thunk)
+ (assert-glib-locked 'with-screen-in-update)
(if (screen-in-update? screen)
(error "Recursive update:" screen))
(set-screen-in-update?! screen #t)
(let ((v (thunk)))
(set-screen-in-update?! screen #f)
- ;; It would be better if this happened AFTER buffer change
- ;; regions were cleared. Or use gdk-window-process-updates here?
- (for-each (lambda (buffer.drawing)
- (set-buffer-drawing-update-region! (cdr buffer.drawing) #f))
- (gtk-screen-drawings screen))
v))
(define (update-blinking screen)
(mark-index display-start)))
(change-end-index (if (buffer-drawing-valid? drawing)
(group-end-changes-index group)
- (mark-index display-end)))
- (update-region #f))
+ (mark-index display-end))))
(define-syntax %trace3
(syntax-rules ()
(%trace ";\tno changes\n")
#t)
(else
- (set! update-region (cons change-start-index change-end-index))
- (set-buffer-drawing-update-region! drawing update-region)
(let ((finished?
(redraw-start
redraw-end)))))))))
- (set-buffer-drawing-update-region! drawing finished?)
(if finished?
(begin
(set-size)
(set! drawing-extent (copy-fix-rect extent))
(fix-rect-union! drawing-extent extent)))
- ;; If the update region is narrowed to exclude each line before it
- ;; is re-drawn, then the resulting exposes will not be punted by
- ;; the line-ink expose handler (which is otherwise shuns change
- ;; regions). The expose event could arrive instantly (thread
- ;; timer interrupts permitting), so this must be done before
- ;; (re)drawing the line-ink.
- (define (update-region! start)
- (set-car! update-region (mark-index start)))
-
;; Keeps the next line to redraw on the front, skipping inks like
;; cursors, selection boxes, embedded images/widgets/whatnot.
(define (next-lines inks)
(%trace3 "; add-line "start" "num" "y" "old"\n")
(let ((new (make-line-ink)))
(set-line-ink-start! new (mark-permanent-copy start))
- (update-region! start)
(set-line-ink-end! new (mark-permanent-copy start))
(set-line-ink-number! new num)
(fix-drawing-add-ink! drawing new (and (pair? old) (car old)))
(define (steal-line! line start num y)
(%trace3 "; steal-line! "line" "start" "num" "y"\n")
(move-mark-to! (line-ink-start line) start)
- (update-region! start)
(set-line-ink-number! line num)
(redraw-line! line 0 y (layout))
(union-ink! line))
(let* ((extent (fix-ink-extent line))
(old-num (line-ink-number line))
(old-y (fix-rect-y extent)))
- (update-region! start)
(if (not (fix:= old-y y))
(set-text-ink-position! line 0 y))
(if (not (fix:= old-num num))
(define (remove-line line)
(mark-temporary! (line-ink-start line))
(mark-temporary! (line-ink-end line))
- (without-interrupts
+ (%without-interruption
(lambda ()
(clear-cached-pango-layout line)
(fix-ink-remove! line))))
(%trace3 ";\t redraw-line! "line" from "(line-ink-start line)
" ("x","y") with "pango-layout"\n")
- (without-interrupts
+ (%without-interruption
(lambda ()
(%layout-line! line pango-layout)))
(pango-layout-get-pixel-extents
pango-layout
(lambda (width height)
- (without-interrupts
+ (%without-interruption
(lambda ()
(clear-cached-pango-layout line)
(%trace3 ";\t erasing "(fix-ink-extent line)"\n")
(define image-buffer (string-allocate image-buffer-size))
(define (%layout-line! line pango-layout)
- ;; This must run without-interrupts because it uses image-buffer.
- ;; An async expose event might otherwise fubar it.
(let* ((drawing (fix-ink-drawing line))
(buffer (buffer-drawing-buffer drawing))
(group (buffer-group buffer))
(declare (integrate-operator unchanged?))
(define (unchanged? line)
(let* ((drawing (fix-ink-drawing line))
- (update-region (buffer-drawing-update-region drawing)))
- (cond ((eq? update-region #t) #t)
- ((pair? update-region)
- (or
- (let ((change-start (car update-region))
- (line-end (line-ink-end-index line)))
- (fix:<= line-end change-start))
- (let ((change-end (cdr update-region))
- (line-start (line-ink-start-index line)))
- (fix:< change-end line-start))))
- (else
- (let ((buffer (buffer-drawing-buffer drawing)))
- (and buffer
- (let ((group (buffer-group buffer)))
- (%unchanged? line
- (group-start-changes-index group)
- (group-end-changes-index group)))))))))
+ (buffer (buffer-drawing-buffer drawing)))
+ (and buffer
+ (let ((group (buffer-group buffer)))
+ (%unchanged? line
+ (group-start-changes-index group)
+ (group-end-changes-index group))))))
(declare (integrate-operator %unchanged?))
(define (%unchanged? line change-start change-end)
(display-start define standard initial-value #f)
(display-end define standard initial-value #f)
- ;; During redisplay this is the portion of the buffer's change
- ;; region that has yet to be re-drawn.
- (update-region define standard initial-value #f)
-
;; These are the particulars of the set of PangoLayouts in use.
;; Each element is a "cache" containing: (<line-ink>|#f
;; . <pango-layout>). Thus each layout is either idle, or in use --
(define-method text-ink-pango-layout ((ink <line-ink>))
;; A cached pango layout is presumed to be all laid out. A cache
- ;; miss means a PangoLayout must be re-laid-up from the buffer text,
- ;; if the text has not changed. If the change region intersects,
- ;; punt!
+ ;; miss means a PangoLayout must be re-laid-up from the buffer text.
(define (salvage-pango-layout line)
;; Look for a cached PangoLayout to re-use. Returns abandoned
layout))
;; Do not (call-next-method ink). There is no <text-ink> method.
- (cond ((fix:zero? (fix-rect-height (fix-ink-extent ink)))
- ;; An expose event can arrive between adding a new line to
- ;; the drawing and laying it out (see add-line in
- ;; update-drawing). If the dimensions (any) are zero, punt.
- #f)
- ((unchanged? ink)
- (or (line-ink-cached-pango-layout ink)
- ;; When executed by the expose handler, this already runs
- ;; without-interrupts. However there are other places
- ;; (e.g. redraw-cursor) where this could be called. Ensure
- ;; that the async. expose handlers do not start frobbing the
- ;; pango-layout cache until we are done here.
- (without-interrupts
- (lambda ()
- (let ((layout (or (salvage-pango-layout ink)
- (cache-pango-layout ink))))
- (%layout-line! ink layout)
- layout)))))
- (else
- (outf-error ";text-ink-pango-layout: punted "ink"\n")
- #f)))
+ (or (line-ink-cached-pango-layout ink)
+ (let ((layout (or (salvage-pango-layout ink)
+ (cache-pango-layout ink))))
+ (%layout-line! ink layout)
+ layout)))
(define (clear-cached-pango-layout line)
- ;; This probably aught to be done without-interrupts, since it
- ;; frobs a cache used (filled!) by the async expose handler.
(let ((layout (line-ink-cached-pango-layout line)))
(if layout
(let* ((drawing (fix-ink-drawing line))
(define (visible! cursor visible?)
;; Atomically sets cursor-ink-visible? and fix-ink-widgets.
- (without-interrupts
+ (%without-interruption
(lambda ()
(if visible?
(if (not (cursor-ink-visible? cursor))
(define (blink! screen cursor)
;; Atomically sets CURSOR up to blink. CURSOR may be #f, in which
;; case blinking will pause.
- (without-interrupts
+ (%without-interruption
(lambda ()
(let ((old (gtk-screen-blinking screen)))
(if cursor
(<rectangle-ink>)
(text-ink define standard))
\f
+(define-integrable %without-interruption without-interruption)
+#;(define (%without-interruption thunk)
+ (%trace "; %without-interruption "thunk"\n")
+ (%assert-with-interruption '%without-interruption)
+ (let ((v (without-interruption thunk)))
+ (%trace "; %without-interruption "thunk" => "v"\n")
+ v))
+
+(define (%with-interruption thunk)
+ (%trace "; %with-interruption "thunk"\n")
+ (%assert-without-interruption '%with-interruption)
+ (unblock-thread-events)
+ (let ((v (thunk)))
+ (%trace "; %with-interruption "thunk" => "v"\n")
+ (block-thread-events)
+ v))
+
+#;(begin
+ (define-integrable (%assert-without-interruption operator)
+ (declare (ignore operator))
+ #f)
+ (define-integrable (%assert-with-interruption operator)
+ (declare (ignore operator))
+ #f))
+
+(begin
+ (define %get-thread-event-block
+ (access get-thread-event-block (->environment '(runtime thread))))
+
+ (define-integrable (%assert-without-interruption operator)
+ (if (not (%get-thread-event-block))
+ (outf-error ";not without interruption: "operator"\n")))
+ (define-integrable (%assert-with-interruption operator)
+ (if (%get-thread-event-block)
+ (outf-error ";not with interruption: "operator"\n"))))
+
(define %trace? #f)
(define-syntax %trace
projects / mit-scheme.git / commitdiff