From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Tue, 23 Oct 2012 23:15:55 +0000 (-0700)
Subject: Merge branch 'Gtk' into Gtk-Screen
X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~72
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=21e3846813c207046027a10e5d692af47698e7a1;p=mit-scheme.git

Merge branch 'Gtk' into Gtk-Screen
---

21e3846813c207046027a10e5d692af47698e7a1
diff --cc doc/gtk/gtk.texinfo
index e9c74d052,7dec4120b..304f4a510
--- a/doc/gtk/gtk.texinfo
+++ b/doc/gtk/gtk.texinfo
@@@ -1397,67 -1416,59 +1416,75 @@@ will apply @var{callback} to @var{butto
  @var{button} in @var{callback}'s closure, else it cannot be GCed.
  @end deffn
  
- @node Gtk Box, Gtk Frame, Gtk Check Button, API Reference
- @section Gtk Box
+ @node Gtk Grid, Gtk Frame, Gtk Check Button, API Reference
+ @section Gtk Grid
+ 
+ GtkGrids arrange their children in rows and columns.
  
- Gtk boxes can be vboxes or hboxes arranging their children vertically
- or horizontally, respectively.
+ @deffn Class <gtk-grid>
+ A direct subclass of gtk-container representing a reference to a GtkGrid.
+ @end deffn
  
- @anchor{gtk-box-pack-start}
- @deffn Procedure gtk-box-pack-start box child expand? fill? padding
- Adds @var{child} to @var{box} @emph{after} siblings previously packed
- with this procedure, and @emph{before} siblings previously packed with
- @bref{gtk-box-pack-end}.  @var{Box} can be a gtk-vbox or gtk-hbox.  If
- @var{expand?}, the new child is positioned within a share of any extra
- space.  If @var{fill?} (and @var{expand?}), the child is allocated the
- share of extra space.  @var{Padding} is the space around the child,
- e.g. between it and its neighbors @emph{and} the edge of the box.
+ @deffn Procedure gtk-grid? object
+ Type predicate.
  @end deffn
  
- @anchor{gtk-box-pack-end}
- @deffn Procedure gtk-box-pack-end box child expand? fill? padding
- Just like @bref{gtk-box-pack-start}, except @var{child} is packed
- @emph{before} siblings previously packed with this procedure,
- @emph{after} siblings packed with gtk-box-pack-start.
+ @deffn Procedure guarantee-gtk-grid object operator
+ Type guarantor.
  @end deffn
  
- @deffn Class <gtk-vbox>
- A direct subclass of gtk-container representing a reference to a GtkVBox.
+ @deffn Procedure gtk-grid-new
+ A new gtk-grid.
  @end deffn
  
- @deffn Procedure gtk-vbox? object
- Type predicate.
+ @deffn Procedure gtk-grid-set-row-spacing grid space
+ Set the distance between rows of @var{grid} to @var{space} pixels.
  @end deffn
  
- @deffn Procedure guarantee-gtk-vbox object operator
- Type guarantor.
+ @deffn Procedure gtk-grid-set-column-spacing grid space
+ Set the distance between columns of @var{grid} to @var{space} pixels.
  @end deffn
  
- @deffn Procedure gtk-vbox-new homogeneous? spacing
- A new gtk-vbox.  If @var{homogeneous?} is not #f, all children are
- given equal space allocations.  @var{Spacing} is the distance between
- children.
+ @deffn Procedure gtk-grid-set-row-homogeneous grid homogeneous?
+ Set the homogeneity of row heights.  If @var{homogeneous?} is
+ @code{#f}, rows can have different heights.  Else they are all
+ allocated the same height.
  @end deffn
  
- @deffn Class <gtk-hbox>
- A direct subclass of gtk-container representing a reference to a GtkHBox.
+ @deffn Procedure gtk-grid-set-column-homogeneous grid homogeneous?
+ Set the homogeneity of column widths.  If @var{homogeneous?} is
+ @code{#f}, columns can have different widths.  Else they are all
+ allocated the same width.
  @end deffn
  
- @deffn Procedure gtk-hbox? object
- Type predicate.
+ @anchor{gtk-grid-attach}
+ @deffn Procedure gtk-grid-attach grid widget left top width height
+ Place @var{widget} in @var{grid} at column @var{left} spanning
+ @var{width} columns, and at row @var{top} spanning @var{height} rows.
  @end deffn
  
- @deffn Procedure guarantee-gtk-hbox object operator
- Type guarantor.
++@deffn Procedure gtk-grid-attach-next-to grid widget sibling side width height
++Add @var{widget} to @var{grid} at @var{side} of @var{sibling} spanning
++@var{width} columns and @code{height} rows.  @var{Side} should be one
++of the symbols @code{left}, @code{right}, @code{top} or @code{bottom}.
++@var{Sibling} must be a child widget of @var{grid} or @code{#f}.  When
++@var{sibling} is @code{#f}, @var{widget} is placed on the @var{side} of
++row or column 0.  Thus adding three widgets on the @code{left} (with
++@var{sibling} @code{#f}) causes the third widget to be layed out at
++(-2,0), the first at (0,0).
++@end deffn
++
++@deffn Procedure gtk-orientable-get-orientation orientable
++Returns a GtkOrientable's orientation --- one of the symbols
++@code{horizontal} or @code{vertical}.
 +@end deffn
 +
- @deffn Procedure gtk-hbox-new homogeneous? spacing
- A new gtk-hbox.  If @var{homogeneous?} is not #f, all children are
- given equal space allocations.  @var{Spacing} is the distance between
- children.
+ @deffn Procedure gtk-orientable-set-orientation orientable orientation
+ Set a GtkOrientable to @var{orientation} which should be one of the
+ symbols @code{horizontal} or @code{vertical}.
  @end deffn
  
- @node Gtk Frame, Gtk Scrolled Window, Gtk Box, API Reference
+ @node Gtk Frame, Gtk Scrolled Window, Gtk Grid, API Reference
  @section Gtk Frame
  
  A bin with a decorative frame and optional label.
diff --cc src/gtk-screen/gtk-screen.pkg
index f5f2df5cc,000000000..41118da37
mode 100644,000000..100644
--- a/src/gtk-screen/gtk-screen.pkg
+++ b/src/gtk-screen/gtk-screen.pkg
@@@ -1,192 -1,0 +1,194 @@@
 +#| -*-Scheme-*-
 +
 +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012  Matthew Birkholz
 +
 +This file is part of an extension to MIT/GNU Scheme.
 +
 +MIT/GNU Scheme is free software; you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation; either version 2 of the License, or (at
 +your option) any later version.
 +
 +MIT/GNU Scheme is distributed in the hope that it will be useful, but
 +WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with MIT/GNU Scheme; if not, write to the Free Software
 +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 +USA.
 +
 +|#
 +
 +;;;; Gtk-Screen System Packaging
 +
 +(global-definitions "../runtime/runtime")
 +(global-definitions "../sos/sos")
 +(global-definitions "../gtk/gtk")
 +(global-definitions "../edwin/edwin")
 +
 +(define-package (edwin screen gtk-screen)
 +  (files "gtk-screen")
 +  (parent (edwin screen))
 +  (export ()
 +	  set-gtk-screen-hooks!)
 +  (export (edwin)
 +	  ;; edwin-variable$x-cut-to-clipboard
 +	  ;; edwin-variable$x-paste-from-clipboard
 +	  ;; os/interprogram-cut
 +	  ;; os/interprogram-paste
 +	  ;; x-root-window-size
 +	  ;; x-screen-ignore-focus-button?
 +	  ;; x-selection-timeout
 +	  ;; xterm-screen/flush!
 +	  ;; xterm-screen/grab-focus!
 +	  )
 +  (export (edwin x-commands)
 +	  ;; screen-display
 +	  ;; screen-xterm
 +	  ;; xterm-screen/set-icon-name
 +	  ;; xterm-screen/set-name
 +	  )
 +  (import (runtime thread)
 +	  register-subprocess-status-change-event)
 +  (import (edwin process)
 +	  hook/inferior-process-output)
 +  (import (edwin window)
 +	  editor-frame-root-window
 +	  window-inferiors find-inferior window-next
 +	  combination? combination-vertical? combination-child
 +	  (%window-x-size window-x-size)
 +	  (%window-y-size window-y-size)
 +	  %set-window-x-size!
 +	  %set-window-y-size!
 +	  inferior-window
 +	  inferior-x-start
 +	  inferior-y-start
 +	  %set-inferior-start!
 +	  editor-frame
 +	  buffer-frame?
 +	  frame-modeline-inferior
 +	  frame-text-inferior
 +	  %window-buffer
 +	  %window-char-image-strings
 +	  %window-force-redraw?
 +	  %window-group
 +	  %window-point-index
 +	  %set-window-point-index!
 +	  %window-point-moved?
 +	  %set-window-point-moved?!
 +	  %window-start-mark
 +	  %set-window-start-mark!
 +	  %window-tab-width)
 +  (import (gtk pango)
 +	  pangos->pixels)
 +  (import (gtk gtk-widget)
 +	  gtk-widget-destroy-callback
 +	  gtk-container-reverse-children)
 +  (import (gtk fix-layout)
 +	  fix-widget-geometry
 +
 +	  drawing-damage
 +	  fix-drawing-display-list
 +	  fix-drawing-extent
 +	  fix-ink-extent
 +	  text-ink-pango-layout
 +
 +	  make-fix-rect copy-fix-rect fix-rect-string
 +	  fix-rect-x fix-rect-y fix-rect-width fix-rect-height
 +	  fix-rect-min-x fix-rect-max-x fix-rect-min-y fix-rect-max-y
 +	  set-fix-rect-size! set-fix-rect-position!
 +	  fix-rect-intersect? fix-rect-union!)
 +  (import (gtk)
 +	  gdk-key-state->char-bits gdk-keyval->name
 +	  gobject-alien gobject-unref!
 +	  gdk-window-process-updates
 +
 +	  gtk-widget-destroyed? gtk-widget-destroy
 +
 +	  gtk-widget? gtk-widget-parent
 +	  gtk-widget-grab-focus
 +	  gtk-widget-show gtk-widget-show-all
 +	  gtk-widget-error-bell
 +	  gtk-widget-queue-draw
 +	  gtk-widget-font set-gtk-widget-font!
 +	  gtk-widget-get-pango-context
 +	  gtk-widget-create-pango-layout
++	  gtk-widget-set-hexpand
++	  gtk-widget-set-vexpand
 +	  gtk-widget-set-size-request
 +	  gtk-widget-bg-color set-gtk-widget-bg-color!
 +	  gtk-widget-fg-color set-gtk-widget-fg-color!
 +
 +	  gtk-container?
 +	  gtk-container-children gtk-container-add gtk-container-remove
 +	  gtk-container-set-border-width
 +
 +	  gtk-scrolled-window? gtk-scrolled-window-new
 +	  gtk-scrolled-window-set-policy
 +	  gtk-scrolled-window-set-placement
 +
- 	  <gtk-hbox> gtk-hbox? gtk-hbox-new
- 	  <gtk-vbox> gtk-vbox? gtk-vbox-new
- 	  gtk-box-pack-end
++	  <gtk-grid> gtk-grid? gtk-grid-new
++	  gtk-orientable-get-orientation
++	  gtk-orientable-set-orientation
 +
 +	  gtk-window-new
 +	  gtk-window-present
 +	  gtk-window-set-title
 +	  gtk-window-set-opacity
 +	  gtk-window-set-default-size
 +
 +	  pango-layout-get-pixel-extents
 +	  pango-layout-index-to-pos
 +	  pango-layout-set-text
 +
 +	  pango-context-get-metrics
 +	  pango-context-spacing
 +
 +	  pango-font-description-from-string
 +	  pango-font-description-to-string
 +	  pango-font-description-free
 +	  pango-font-metrics-get-ascent pango-font-metrics-get-descent
 +	  pango-font-metrics-get-approximate-char-width
 +	  pango-font-metrics-unref
 +
 +	  fix-widget?
 +	  fix-widget-new-geometry-callback fix-widget-realize-callback
 +	  set-fix-widget-map-handler!
 +	  set-fix-widget-unmap-handler!
 +	  set-fix-widget-enter-notify-handler!
 +	  set-fix-widget-leave-notify-handler!
 +	  set-fix-widget-focus-change-handler!
 +	  set-fix-widget-visibility-notify-handler!
 +	  set-fix-widget-key-press-handler!
 +	  set-fix-widget-motion-handler!
 +	  set-fix-widget-button-handler!
 +
 +	  <fix-layout> fix-layout?
 +	  fix-layout-view fix-layout-drawing set-fix-layout-drawing!
 +	  fix-layout-scroll-step set-fix-layout-scroll-step!
 +	  fix-layout-scroll-to! fix-layout-scroll-nw!
 +
 +	  fix-resizer?
 +	  make-fix-resizer
 +	  fix-resizer-before set-fix-resizer-before!
 +	  fix-resizer-after set-fix-resizer-after!
 +
 +	  <fix-drawing> guarantee-fix-drawing
 +	  make-fix-drawing fix-drawing-widgets
 +	  set-fix-drawing-size!
 +	  fix-drawing-add-ink!
 +
 +	  <fix-ink> fix-ink?
 +	  fix-ink-drawing
 +	  fix-ink-widgets set-fix-ink-widgets!
 +	  fix-ink-remove!
 +
 +	  <text-ink> text-ink? set-text-ink-position!
 +	  set-text-ink-color!
 +
 +	  <simple-text-ink> simple-text-ink? make-simple-text-ink
 +	  simple-text-ink-text set-simple-text-ink-text!
 +
 +	  <box-ink> set-box-ink! set-box-ink-position!))
diff --cc src/gtk-screen/gtk-screen.scm
index 4488c6081,000000000..b67b4532d
mode 100644,000000..100644
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@@ -1,2502 -1,0 +1,2519 @@@
 +#| -*-Scheme-*-
 +
 +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012  Matthew Birkholz
 +
 +This file is part of an extension to MIT/GNU Scheme.
 +
 +MIT/GNU Scheme is free software; you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation; either version 2 of the License, or (at
 +your option) any later version.
 +
 +MIT/GNU Scheme is distributed in the hope that it will be useful, but
 +WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with MIT/GNU Scheme; if not, write to the Free Software
 +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 +USA.
 +
 +|#
 +
 +;;;; A GTK-based <screen> for Edwin.
 +;;; Package: (edwin screen gtk-screen)
 +
 +(define-class (<gtk-screen>
 +	       (constructor %make-gtk-screen (toplevel editor-thread) no-init))
 +    (<screen>) ;; TODO: could also be a <gtk-window>, replacing toplevel!
 +
 +  ;; The toplevel <gtk-window>.  The top widget.
 +  (toplevel define accessor)
 +
 +  ;; The Edwin thread, used by event handlers (callbacks) running in
 +  ;; the gtk-thread, where editor-thread is unassigned.
 +  (editor-thread define accessor)
 +
 +  ;; An alist of Edwin buffers and their drawings, to be shared among
 +  ;; the text-widgets, and updated during screen update.
 +  (drawings define standard initial-value '())
 +
 +  ;; The window/icon/taskbar name.  #f just means "not set".  Cannot be
 +  ;; set to #f!
 +  (name define standard initial-value #f)
 +
 +  ;; The default font.  Initially a string.  Replaced with a
 +  ;; PangoFontDescription when the toplevel has been realized.
 +  (font define standard)
 +
 +  ;; The default font's character dimensions.
 +  (char-width define standard)
 +  (line-height define standard)
 +  (line-spacing define standard)
 +
 +  ;; The thread that blinks the cursor and the blinking <cursor-ink>.
 +  (blinker define standard)
 +  (blinking define standard initial-value #f)
 +
 +  ;; Whether a cursor should be blinking.
 +  (in-focus? define standard initial-value #f))
 +
 +(define screen-list)
 +
 +(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)))
 +	 (geometry* (if (default-object? geometry)
 +			"80x24"
 +			(begin
 +			  (guarantee-string geometry 'make-gtk-screen)
 +			  geometry))))
 +    (gtk-window-set-opacity toplevel 0.95)
 +    (set-gtk-screen-font! screen "Monospace 11")
 +    (init-font-dimensions! screen)
 +    (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)
 +  (%trace ";   init-font-dimensions! "screen"\n")
 +  ;; Lookup SCREEN's font via the toplevel widget's pango-context,
 +  ;; which appears to be available before toplevel is realized.
 +
 +  (let* ((spec (gtk-screen-font screen))
 +	 (toplevel (gtk-screen-toplevel screen))
 +	 (context (gtk-widget-get-pango-context toplevel))
 +	 (font (pango-font-description-from-string spec))
 +	 (metrics (pango-context-get-metrics context font)))
 +    (pango-font-description-free font)
 +    (let ((ascent (pangos->pixels (pango-font-metrics-get-ascent metrics)))
 +	  (descent (pangos->pixels (pango-font-metrics-get-descent metrics)))
 +	  (width (pangos->pixels
 +		  (pango-font-metrics-get-approximate-char-width metrics)))
 +	  (spacing (pangos->pixels (pango-context-spacing context))))
 +      (if (zero? width)
 +	  (error "could not get metrics for font" spec))
 +      (set-gtk-screen-char-width! screen width)
 +      (set-gtk-screen-line-spacing! screen spacing)
 +      (set-gtk-screen-line-height! screen (fix:+ ascent descent))
 +      (%trace ";     Font: \""spec"\" "width"x"ascent"+"descent" "spacing"\n")
 +      (pango-font-metrics-unref metrics))))
 +
 +(define (realize-font! widget)
 +  (let* ((screen (edwin-widget-screen widget))
 +	 (font (gtk-screen-font screen)))
 +    (if (string? font)
 +	(let ((desc (pango-font-description-from-string font)))
 +	  (%trace ";  realize-font!\n")
 +	  (set-gtk-widget-font! (gtk-screen-toplevel screen) desc)
 +	  (set-gtk-widget-font! widget desc)
 +	  (set-gtk-screen-font! screen desc))
 +	(set-gtk-widget-font! widget font))))
 +
 +(define (init-size! screen geometry)
 +  (%trace ";   init-size! "screen" "geometry"\n")
 +  ;; Sets the logical screen size.  This sets Edwin window and thus
 +  ;; text-widget sizes, which ultimately determine the GtkWindow size
 +  ;; request.  Sets a small (arbitrary) minimum size so that the luser
 +  ;; can resize to a size smaller than the logical size.
 +  (parse-geometry
 +   geometry
 +   (lambda (width height x y)
 +     (declare (ignore x y))
 +     ;; For make-editor-frame:
 +     (set-screen-x-size! screen width)
 +     (set-screen-y-size! screen height)
 +     (let ((toplevel (gtk-screen-toplevel screen)))
 +       (gtk-window-set-default-size toplevel
 +				    (x-size->width screen width)
 +				    (+ (y-size->height screen (- height 2))
 +				       ;; Modeline.
 +				       (y-size->height screen 1)
 +				       ;; Typein.
 +				       (y-size->height screen 1)))))))
 +
 +(define (parse-geometry geometry receiver)
 +  (let* ((num "[0-9]+")
 +	 (size-patt (string "\\("num"\\)x\\("num"\\)"))
 +	 (position-patt (string "\\([-+]"num"\\)\\([-+]"num"\\)"))
 +	 (extract (lambda (regs index)
 +		    (string->number (re-match-extract geometry regs index)))))
 +    (declare (integrate extract))
 +    (cond ((re-string-match (string size-patt position-patt) geometry)
 +	   => (lambda (regs)
 +		(receiver (extract regs 1) (extract regs 2)
 +			  (extract regs 3) (extract regs 4))))
 +	  ((re-string-match position-patt geometry)
 +	   => (lambda (regs)
 +		(receiver #f #f
 +			  (extract regs 1) (extract regs 2))))
 +	  ((re-string-match size-patt geometry)
 +	   => (lambda (regs)
 +		(receiver (extract regs 1) (extract regs 2)
 +			  #f #f)))
 +	  (else
 +	   (error:wrong-type-argument geometry
 +				      "window geometry (e.g. \"80x40-0-0\")"
 +				      'parse-geometry)))))
 +
 +(define (x-size->width screen x-size)
 +  (fix:* x-size (gtk-screen-char-width screen)))
 +
 +(define (y-size->height screen y-size)
 +  (fix:+ (fix:* y-size (gtk-screen-line-height screen))
 +	 (fix:* (fix:1+ y-size) (gtk-screen-line-spacing screen))))
 +
 +(define (width->x-size screen width)
 +  (fix:quotient width (gtk-screen-char-width screen)))
 +
 +(define (height->y-size screen height)
 +  (let ((line-spacing (gtk-screen-line-spacing screen))
 +	(line-height (gtk-screen-line-height screen)))
 +    (fix:quotient (fix:- height line-spacing)
 +		  (fix:+ line-height line-spacing))))
 +
 +(define (column->x screen column)
 +  (fix:* column (gtk-screen-char-width screen)))
 +
 +(define (row->y screen row)
 +  (fix:* row (fix:+ (gtk-screen-line-spacing screen)
 +		    (gtk-screen-line-height screen))))
 +
 +(define (window-text-widget* window)
 +  (any-child (lambda (widget)
 +	       (and (text-widget? widget)
 +		    (eq? window (text-widget-buffer-frame widget))))
 +	     (gtk-screen-toplevel (window-screen window))))
 +
 +(define-integrable (window-modeline* window)
 +  (let ((widget (window-text-widget* window)))
 +    (and widget (text-widget-modeline widget))))
 +
 +(define-integrable (window-cursor-ink* window)
 +  (let ((widget (window-text-widget* window)))
 +    (and widget (text-widget-cursor-ink widget))))
 +
 +(define-integrable (selected-text-widget* screen)
 +  (let ((window (screen-cursor-window screen)))
 +    (and window (window-text-widget* window))))
 +
 +(define-integrable (car* obj) (and (pair? obj) (car obj)))
 +
 +(define-integrable (cdr* obj) (and (pair? obj) (cdr obj)))
 +
 +(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
 +   (lambda ()
 +     (set-screen-x-size! screen x-size)
 +     (set-screen-y-size! screen y-size)
 +     (send (screen-root-window screen) ':set-size! x-size y-size))))
 +
 +(define %trace-blinker? #f)
 +
 +(define (create-blinker-thread screen)
 +
 +  (define-syntax %trace3
 +    (syntax-rules ()
 +      ((_ ARGS ...) (if %trace-blinker? (outf-error ARGS ...)))))
 +
 +  (create-thread
 +   #f
 +   (lambda ()
 +     (%trace2 ";blinking started on "screen"\n")
 +     (let loop ()
 +       (without-interrupts
 +	(lambda ()
 +	  (let ((cursor (gtk-screen-blinking screen)))
 +	    (cond ((not cursor)
 +		   (%trace2 ";blinker: no blinking "screen"\n")
 +		   (suspend-current-thread)
 +		   (%trace2 ";blinker: awake after not blinking "screen"\n"))
 +		  ((not (cursor-ink-visible? cursor))
 +		   (%trace2 ";blinker: invisible "cursor"\n")
 +		   (suspend-current-thread)
 +		   (%trace2 ";blinker: awake after invisible "cursor"\n"))
 +		  (else
 +		   (%trace3 ";blinker: off "cursor"\n")
 +		   (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))
 +			 (sleep-current-thread 500))
 +		       (begin
 +			 (%trace ";blinker: on: invisible "cursor"\n")
 +			 unspecific)))))))
 +       (loop)))))
 +
 +(define-method screen-beep ((screen <gtk-screen>))
 +  (gtk-widget-error-bell (gtk-screen-toplevel screen)))
 +
 +(define-method screen-enter! ((screen <gtk-screen>))
 +  (%trace "; screen-enter! "screen"\n")
 +  (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")
 +  (set-gtk-screen-in-focus?! screen #f)
 +  (update-blinking screen))
 +
 +(define-method screen-discard! ((screen <gtk-screen>))
 +  (set! screen-list (delq! screen screen-list))
 +  (gtk-widget-destroy (gtk-screen-toplevel screen)))
 +
 +(define-method screen-modeline-event! ((screen <gtk-screen>) window type)
 +  (%trace "; screen-modeline-event! "screen" "window" "type"\n"))
 +
 +;;; These scrolling procedures are for editor commands (not
 +;;; scrollbars).  They force a buffer-drawing layout update
 +;;; (effectively, a redisplay) after which they can map window coords
 +;;; to drawing coords to line ink to buffer index.
 +
 +(define-method screen/window-scroll-y-absolute! ((screen <gtk-screen>)
 +						 frame y-point)
 +  (%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n")
 +  (with-updated-window
 +   screen frame 'SCROLL-Y-ABSOLUTE!
 +   (lambda (widget)
 +     (let ((cursor (text-widget-cursor-ink widget))
 +	   (view (fix-layout-view widget)))
 +       (let ((desired-y (fix:+ (fix-rect-y view)
 +			       (row->y screen y-point)))
 +	     (actual-y (fix-rect-y (fix-ink-extent cursor))))
 +	 (%scroll-to screen widget
 +		     (fix-rect-x view)
 +		     (fix:+ (fix:- actual-y desired-y)
 +			    (fix-rect-y view))))))))
 +
 +(define (%scroll-to screen widget x y)
 +  (let* ((max-y (let ((drawing (text-widget-buffer-drawing widget)))
 +		  (if drawing
 +		      (fix:max 0
 +			       (fix:- (fix-rect-max-y
 +				       (fix-drawing-extent drawing))
 +				      (gtk-screen-line-height screen)))
 +		      0)))
 +	 (y* (fix:min max-y (fix:max 0 y))))
 +    (%trace ";   %scroll-to "x" "y*"\n")
 +    (fix-layout-scroll-to! widget x y*)
 +    (update-start-mark widget)))
 +
 +(define (with-updated-window screen frame what operation)
 +  (%trace "; with-updated-window "screen" "frame" "what"\n")
 +
 +  (if (not (screen-in-update? screen))
 +      ;; Don't loop when used during screen update(!).
 +      (begin
 +	(%trace ";   forcing update...\n")
 +	(update-screens! #t)
 +	(%trace ";   ...forced update finished.\n"))
 +      (%trace ";   in update, with widget "(window-text-widget* frame)"\n"))
 +
 +  (let ((widget (window-text-widget* frame)))
 +    (if (not widget) (error "No widget:" frame))
 +    (operation widget)))
 +
 +(define-method screen/window-scroll-y-relative! ((screen <gtk-screen>)
 +						 frame delta)
 +  (%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n")
 +  (with-updated-window
 +   screen frame 'SCROLL-Y-RELATIVE!
 +   (lambda (widget)
 +     (let ((view (fix-layout-view widget))
 +	   (delta* (row->y screen delta)))
 +       (%scroll-to screen widget
 +		   (fix-rect-x view)
 +		   (fix:+ delta* (fix-rect-y view)))
 +       (update-point 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")
 +  (with-updated-window
 +   screen frame 'SET-START-MARK!
 +   (lambda (widget)
 +     (let ((view (fix-layout-view widget))
 +	   (line (find-line-at mark widget)))
 +       (let ((x (fix-rect-x view))
 +	     (y (if line
 +		    (fix:- (fix-rect-y (fix-ink-extent line))
 +			   (gtk-screen-line-spacing screen))
 +		    0)))
 +	 (cond (force?
 +		(fix-layout-scroll-to! widget x y)
 +		(update-start-mark widget)
 +		(update-point widget))
 +	       ((let ((extent (fix-ink-extent (text-widget-cursor-ink widget))))
 +		  (and (fix:<= y
 +			       (fix-rect-min-y extent))
 +		       (fix:< (fix-rect-min-y extent)
 +			      (fix:+ y (fix-rect-height view)))))
 +		(fix-layout-scroll-to! widget x y)
 +		(update-start-mark widget))))))))
 +
 +(define-method screen/window-mark-visible? ((screen <gtk-screen>) frame mark)
 +  (%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n")
 +  (with-updated-window
 +   screen frame 'MARK-VISIBLE?
 +   (lambda (widget)
 +     (let ((view (fix-layout-view widget))
 +	   (line (find-line-at mark widget)))
 +       (let ((min-y (if line
 +			(fix-rect-min-y (fix-ink-extent line))
 +			0)))
 +	 (if (and (fix:<= (fix-rect-min-y view)
 +			  min-y)
 +		  (fix:< min-y
 +			 (fix-rect-max-y view)))
 +	     (begin
 +	       (%trace ";   visible\n")
 +	       #t)
 +	     (begin
 +	       (%trace ";   NOT visible\n")
 +	       #f)))))))
 +
 +(define-method screen/window-mark->x ((screen <gtk-screen>) frame mark)
 +  (%trace "; screen/window-mark->x "screen" "frame" "mark"\n")
 +  0					; Need a real X???
 +  )
 +
 +(define-method screen/window-mark->y ((screen <gtk-screen>) frame mark)
 +  (%trace "; screen/window-mark->y "screen" "frame" "mark"\n")
 +  (with-updated-window
 +   screen frame 'MARK->Y
 +   (lambda (widget)
 +     (line->row screen widget (find-line-at mark widget)))))
 +
 +(define-integrable (line->row screen widget line)
 +  (let* ((view (fix-layout-view widget))
 +	 (spacing (gtk-screen-line-spacing screen))
 +	 (height (gtk-screen-line-height screen))
 +	 (y (if (not line)
 +		0
 +		(fix-rect-y (fix-ink-extent line)))))
 +    (fix:quotient (fix:- y (fix-rect-y view))
 +		  (fix:+ height spacing))))
 +
 +(define-method screen/window-mark->coordinates ((screen <gtk-screen>)
 +						frame mark)
 +  (%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n")
 +  (with-updated-window
 +   screen frame 'MARK->COORDINATES
 +   (lambda (widget)
 +     (let ((line (find-line-at mark widget)))
 +       (cons
 +	0				; Need a real X???
 +	(line->row screen widget line))))))
 +
 +(define-method screen/window-point-x ((screen <gtk-screen>) frame)
 +  (screen/window-mark->x screen frame (window-point frame)))
 +
 +(define-method screen/window-point-y ((screen <gtk-screen>) frame)
 +  (screen/window-mark->y screen frame (window-point frame)))
 +
 +(define-method screen/window-point-coordinates ((screen <gtk-screen>) frame)
 +  (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")
 +  (with-updated-window
 +   screen frame 'COORDINATES->MARK
 +   (lambda (widget)
 +     (let* ((y* (fix:+ (row->y screen y)
 +		       (fix-rect-y (fix-layout-view widget))))
 +	    (line (find-line-after y* widget)))
 +       (%trace ";  line at "y*": "line"\n")
 +       (mark-temporary-copy (line-start line widget))))))
 +
 +(define-integrable (update-start-mark widget)
 +  ;; Set WIDGET's window's start-mark to the start of the first
 +  ;; completely visible line ink.
 +  (let ((line (find-line-after (fix-rect-y (fix-layout-view widget)) widget)))
 +    (move-mark-to! (get-start-mark widget)
 +		   (line-start line widget))))
 +
 +(define-integrable (get-start-mark widget)
 +  (let ((window (frame-text-inferior (text-widget-buffer-frame widget))))
 +    (or (%window-start-mark window)
 +	(let ((new (mark-permanent-copy (no-line-start widget))))
 +	  (%set-window-start-mark! window new)
 +	  new))))
 +
 +(define-integrable (no-line-start widget)
 +  (buffer-drawing-display-start (fix-layout-drawing widget)))
 +
 +(define (update-point widget)
 +  (%trace "; update-point "widget"\n")
 +  ;; Move WIDGET's window's point into view at the beginning of the
 +  ;; nearest (first or last) completely visible line.
 +
 +  (define-integrable (move-point for/back line)
 +    (let ((window (frame-text-inferior (text-widget-buffer-frame widget))))
 +      (%trace ";   "for/back"ward to "line"\n")
 +      (%set-window-point-index! window
 +				(mark-index (line-start line widget)))
 +      (%set-window-point-moved?! window #t)
 +      (update-cursor widget)))
 +
 +  (let ((extent (fix-ink-extent (text-widget-cursor-ink widget)))
 +	(view (fix-layout-view widget)))
 +    (cond ((fix:< (fix-rect-min-y extent)
 +		  (fix-rect-min-y view))
 +	   (move-point 'for (find-line-after (fix-rect-min-y view) widget)))
 +	  ((fix:< (fix-rect-max-y view)
 +		  (fix-rect-max-y extent))
 +	   (move-point 'back (find-line-before (fix-rect-max-y view) widget)))
 +	  (else
 +	   (%trace ";   no need to move\n")))))
 +
 +(define-integrable (line-start line widget)
 +  (if line
 +      (line-ink-start line)
 +      (no-line-start widget)))
 +
 +(define (find-line-at point widget)
 +  ;; Return the line-ink that includes the character at POINT.  If
 +  ;; there is no such line, return #f or the last line found.
 +  (let loop ((inks (fix-drawing-display-list
 +		     (fix-layout-drawing widget)))
 +	     (last #f))
 +    (cond ((null? inks) last)
 +	  ((not (line-ink? (car inks)))
 +	   (loop (cdr inks) last))
 +	  (else
 +	   (let ((line (car inks)))
 +	     (if (mark< point (line-ink-end line))
 +		 line
 +		 (loop (cdr inks) line)))))))
 +
 +(define (find-line-after y widget)
 +  ;; Find the first line-ink that starts at or below Y, or the last
 +  ;; (closest) line.  Returns #f when the buffer is empty.
 +  (let loop ((inks (fix-drawing-display-list (fix-layout-drawing widget)))
 +	     (previous #f))
 +    (if (pair? inks)
 +	(let ((ink (car inks)))
 +	  (if (line-ink? ink)
 +	      (if (fix:<= y (fix-rect-y (fix-ink-extent ink)))
 +		  ink
 +		  (loop (cdr inks) ink))
 +	      (loop (cdr inks) previous)))
 +	previous)))
 +
 +(define (find-line-before y widget)
 +  ;; Find the last line-ink that ends at or above Y.  Returns #f when
 +  ;; the buffer is empty.
 +  (let loop ((inks (fix-drawing-display-list (fix-layout-drawing widget)))
 +	     (previous #f))
 +    (if (pair? inks)
 +	(let ((ink (car inks)))
 +	  (if (line-ink? ink)
 +	      (if (fix:< y (fix-rect-max-y (fix-ink-extent ink)))
 +		  previous
 +		  (loop (cdr inks) ink))
 +	      (loop (cdr inks) previous)))
 +	previous)))
 +
 +;;; Event Handling
 +
 +(define event-queue)
 +(define change-event-registration)
 +
 +(define (get-gtk-input-operations)
 +  (values
 +   (lambda ()				;halt-update?
 +     ;; Large buffers will generate large runs of these traces...
 +     ;;(%trace2 ";halt-update?")
 +     (let ((halt? (not (thread-queue/empty? event-queue))))
 +       ;;(%trace2 " => "halt?"\n")
 +       halt?))
 +   (lambda (msec)			;peek-no-hang
 +     (%trace2 ";peek-no-hang "msec"\n")
 +     (let ((event (thread-queue/peek-no-hang event-queue msec)))
 +       (%trace2 ";peek-no-hang "msec" => "event"\n")
 +       event))
 +   (lambda ()				;peek
 +     (%trace2 ";peek\n")
 +     (let ((event (thread-queue/peek event-queue)))
 +       (%trace2 ";peek => "event"\n")
 +       event))
 +   (lambda ()				;read
 +     (%trace2 ";read\n")
 +     (let ((event (thread-queue/dequeue! event-queue)))
 +       (%trace2 ";read => "event"\n")
 +       event))))
 +
 +(define (gtk-screen-inferior-thread-output)
 +  ;; Invoked via hook/signal-inferior-thread-output!.
 +  (thread-queue/queue-no-hang!
 +   event-queue (make-input-event 'UPDATE gtk-screen-accept-thread-output)))
 +
 +(define (gtk-screen-accept-thread-output)
 +  (if (accept-thread-output)
 +      (update-screens! #f)))
 +
 +(define (gtk-screen-inferior-process-output)
 +  ;; Invoked via hook/inferior-process-output.
 +  (thread-queue/queue-no-hang!
 +   event-queue (make-input-event 'UPDATE gtk-screen-accept-process-output)))
 +
 +(define (gtk-screen-accept-process-output)
 +  (if (accept-process-output)
 +      (update-screens! #f)))
 +
 +(define (gtk-screen-process-status-change)
 +  ;; Invoked by a thread-event (asynchronously) whenever ANY
 +  ;; subprocess status changes.
 +  (thread-queue/queue-no-hang!
 +   event-queue
 +   (make-input-event 'UPDATE gtk-screen-accept-process-status-change)))
 +
 +(define (gtk-screen-accept-process-status-change)
 +  (if (handle-process-status-changes)
 +      (update-screens! #f)))
 +
 +(define interrupts?)
 +
 +(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 (map-handler widget)
 +  (%trace "; Mapped: "widget"\n")
 +  0 ;;Continue.
 +  )
 +
 +(define (unmap-handler widget)
 +  (%trace "; Unmapped: "widget"\n")
 +  0 ;;Continue.
 +  )
 +
 +(define (focus-change-handler widget in?)
 +  (%trace "; Focus-"(if in? "in" "out")": "widget"\n")
 +  (let ((screen (edwin-widget-screen widget)))
 +    (set-gtk-screen-in-focus?! screen in?)
 +    (update-blinking screen))
 +  0 ;;Continue.
 +  )
 +
 +(define (visibility-notify-handler widget state)
 +  (%trace "; Visibility: "state" "widget"\n")
 +  (let ((screen (edwin-widget-screen widget)))
 +    (case state
 +      ((VISIBLE) (set-screen-visibility! screen 'VISIBLE))
 +      ((PARTIALLY-OBSCURED) (set-screen-visibility! screen 'PARTIALLY-OBSCURED))
 +      ((OBSCURED) (set-screen-visibility! screen 'OBSCURED))
 +      (else (warn "unexpected visibility state:" state))))
 +  1 ;;Handled.
 +  )
 +
 +(define (key-press-handler widget key char-bits)
 +  (%trace "; Key-press: "key" "char-bits" "widget"\n")
 +  (let ((queue! (lambda (x)
 +		  (thread-queue/queue-no-hang! event-queue x)
 +		  (%trace ";  queued "x"\n")
 +		  1 ;;Handled.
 +		  ))
 +	(k (case key
 +	     ((#\backspace) #\rubout)
 +	     ((#\rubout) #\c-d)
 +	     ((#\return) #\c-m)
 +	     ((#\linefeed) #\c-j)
 +	     ((#\tab) #\c-i)
 +	     ((Shift-L Shift-R Control-L Control-R Caps-Lock Shift-Lock
 +		       Meta-L Meta-R Alt-L Alt-R
 +		       Super-L Super-R Hyper-L Hyper-R)
 +	      #f)
 +	     (else key))))
 +    (if (char? k)
 +	(if (char=? k #\BEL)
 +	    (let* ((screen (edwin-widget-screen widget))
 +		   (thread (gtk-screen-editor-thread screen)))
 +	      (%trace ";  pushing ^G in "(current-thread)"...\n")
 +	      (thread-queue/push! event-queue #\BEL)
 +	      (%trace ";  signaling "thread"\n")
 +	      (signal-thread-event
 +	       thread
 +	       (lambda ()
 +		 (%trace ";interrupt! in editor "(current-thread)"\n")
 +		 (interrupt!)))
 +	      (%trace ";  pushed ^G in "(current-thread)".\n")
 +	      1 ;;Handled.
 +	      )
 +	    (queue! (merge-bucky-bits k char-bits)))
 +	(if k
 +	    (queue! (make-special-key k char-bits))
 +	    1 ;;Handled.
 +	    ))))
 +
 +;;; Initialization
 +
 +(define gtk-display-type)
 +
 +(define (set-gtk-screen-hooks!)
 +  (set! hook/signal-inferior-thread-output! gtk-screen-inferior-thread-output)
 +  (set! hook/inferior-process-output gtk-screen-inferior-process-output))
 +
 +(define (initialize-package!)
 +  (set! screen-list '())
 +  (set! event-queue (make-thread-queue 128))
 +  (set! change-event-registration	;deregister when???
 +	(register-subprocess-status-change-event
 +	 (lambda (mode)
 +	   (declare (ignore mode))
 +	   (gtk-screen-process-status-change))))
 +  (set! gtk-display-type
 +	(make-display-type 'GTK
 +			   #t
 +			   gtk-thread-running?
 +			   make-gtk-screen
 +			   (lambda (screen)
 +			     screen	;ignore
 +			     (get-gtk-input-operations))
 +			   with-editor-interrupts-from-gtk
 +			   with-gtk-interrupts-enabled
 +			   with-gtk-interrupts-disabled))
 +  unspecific)
 +
 +(define (update-widgets screen)
 +  (%trace ";   update-widgets "screen"\n")
 +
 +  (define-integrable (main)
 +    (let* ((root (screen-root-window screen)) ;editor-frame
 +	   (toplevel (gtk-screen-toplevel screen))
 +	   (top-children (gtk-container-reverse-children toplevel)))
 +      (update-name screen)
 +      (if (null? top-children)
- 	  (let ((top-box (gtk-vbox-new #f 0)))
- 	    (gtk-container-add toplevel top-box)
- 	    (%trace ";     -init "root" in "top-box"\n")
++	  (let ((top-grid (let ((g (gtk-grid-new)))
++			    (gtk-orientable-set-orientation g 'VERTICAL)
++			    ;; homogenous: #f  spacing: 0
++			    g)))
++	    (gtk-container-add toplevel top-grid)
++	    (%trace ";     -init "root" in "top-grid"\n")
 +	    (re-pack-windows! (%reversed-children root)
- 			      '() top-box #f "--")
++			      '() top-grid #f "--")
 +	    (%trace ";     -show-init "toplevel"\n")
 +	    (gtk-widget-grab-focus (typein-widget screen))
 +	    (for-each-text-widget screen update-widget-buffer)
 +	    (gtk-widget-show-all toplevel)
 +	    (%trace ";   update-widgets init done\n"))
- 	  (let ((top-box (car top-children)))
- 	    (%trace ";     -pack "root" into "top-box"\n")
++	  (let ((top-grid (car top-children)))
++	    (%trace ";     -pack "root" into "top-grid"\n")
 +	    (re-pack-windows! (%reversed-children root)
- 			      (gtk-container-children top-box) top-box #f "--")
++			      (gtk-container-children top-grid)
++			      top-grid #f "--")
 +	    (for-each-text-widget screen update-widget-buffer)
 +	    (%trace ";     -show-all "toplevel"\n")
 +	    (gtk-widget-show-all toplevel)
 +	    (%trace ";   update-widgets done\n")))))
 +
-   (define (re-pack-windows! windows widgets box resizer prefix)
++  (define (re-pack-windows! windows widgets grid resizer prefix)
 +    (cond
 +
 +     ((and (not (pair? windows))
 +	   (not (pair? widgets)))
 +      (%trace ";     "prefix"done\n"))
 +
 +     ((not (pair? windows))		;extra children
 +      (for-each (lambda (child)
 +		  (%trace ";     "prefix"destroying extra "child"\n")
 +		  (gtk-widget-destroy child))
 +		widgets)
 +      (%trace ";     "prefix"done, tossed extra children\n"))
 +
 +     ((not (pair? widgets))
 +      ;; and (pair? windows) -- insufficient children
-       (pack-new! windows box resizer prefix))
++      (pack-new! windows grid resizer prefix))
 +
 +     (else ;; (and (pair? widgets) (pair? windows))
 +      (let ((widget (car widgets))
 +	    (window (car windows)))
 +	(cond
 +
 +	 ;; Exact combo. match.
 +	 ((and (combination? window)
 +	       (not (buffer-frame-widget? widget))
 +	       (if (combination-vertical? window)
- 		   (gtk-vbox? widget)
- 		   (gtk-hbox? widget)))
++		   (and (gtk-grid? widget)
++			(eq? 'VERTICAL
++			     (gtk-orientable-get-orientation widget)))
++		   (and (gtk-grid? widget)
++			(eq? 'HORIZONTAL
++			     (gtk-orientable-get-orientation widget)))))
 +	  (%trace ";     "prefix"matched "window" to "widget"\n")
 +	  (re-pack-windows! (%reversed-children window)
 +			    (gtk-container-children widget)
 +			    widget #f (string-append prefix "--"))
- 	  (re-pack-resizer! windows widgets box resizer prefix))
++	  (re-pack-resizer! windows widgets grid resizer prefix))
 +
 +	 ;; Exact leaf match.
 +	 ((and (buffer-frame? window)
 +	       (buffer-frame-widget? widget)
 +	       (let ((text (buffer-frame-widget-text* widget)))
 +		 (and text
 +		      (eq? window (text-widget-buffer-frame text))
 +		      text)))
 +	  => (lambda (text)
 +	       (%trace ";     "prefix"matched "window" to "
 +		       widget" (containing "text")\n")
 +	       (re-size! text window)
- 	       (re-pack-resizer! windows widgets box resizer prefix)))
++	       (re-pack-resizer! windows widgets grid resizer prefix)))
 +
 +	 (else
 +	  ;; Children were added/removed.  Must remove the rest
 +	  ;; before adding any, to get the ordering right.  For
 +	  ;; now, just remove one, in case one child was removed
 +	  ;; and we will match the next...
 +	  (%trace ";     "prefix"destroying "widget
 +		  ", which mismatched "window"\n")
 +	  (gtk-widget-destroy widget)
- 	  (re-pack-windows! windows (cdr widgets) box resizer prefix)))))))
++	  (re-pack-windows! windows (cdr widgets) grid resizer prefix)))))))
 +
-   (define (re-pack-resizer! windows widgets box resizer prefix)
++  (define (re-pack-resizer! windows widgets grid resizer prefix)
 +    ;; (car WINDOWS) matched (car WIDGETS) and was re-packed.  Now
 +    ;; link the latter to the previous RESIZER, find or add the next
 +    ;; resizer (if needed), then tail-call re-pack-windows! on the
 +    ;; rest.
 +    (if (and resizer
 +	     (not (eq? (car widgets) (fix-resizer-before resizer))))
 +	(set-fix-resizer-before! resizer (car widgets)))
 +
-     (if (and (gtk-hbox? box) (pair? (cdr windows)))
++    (if (and (gtk-grid? grid)
++	     (eq? 'HORIZONTAL (gtk-orientable-get-orientation grid))
++	     (pair? (cdr windows)))
 +	;; Need resizer.
 +	(let ((resizer (and (pair? (cdr widgets))
 +			    (fix-resizer? (cadr widgets))
 +			    (cadr widgets))))
 +	  (if resizer
- 	      (re-pack-windows! (cdr windows) (cddr widgets) box resizer prefix)
++	      (re-pack-windows! (cdr windows) (cddr widgets)
++				grid resizer prefix)
 +	      (let ((new (make-fix-resizer (gtk-screen-char-width screen) -1)))
- 		(set-fix-resizer-after! new box)
- 		(gtk-box-pack-end box new #f #f 0)
++		(set-fix-resizer-after! new grid)
++		(gtk-container-add grid new)
 +		(for-each
 +		  (lambda (w)
 +		    (outf-error ";     "prefix"destroying unexpected "w"\n")
 +		    (gtk-widget-destroy w))
 +		  (cdr widgets))
- 		(re-pack-windows! (cdr windows) '() box new prefix))))
++		(re-pack-windows! (cdr windows) '() grid new prefix))))
 +	;; Need NO resizer.
- 	(re-pack-windows! (cdr windows) (cdr widgets) box #f prefix)))
++	(re-pack-windows! (cdr windows) (cdr widgets) grid #f prefix)))
 +
 +    (define (re-size! widget window)
 +      (let ((area (fix-widget-geometry widget))
 +	    (window-x-size (%text-x-size window))
 +	    (window-y-size (%text-y-size window)))
 +	(let ((width (fix-rect-width area))
 +	      (height (fix-rect-height area)))
 +	  (if (or (not width) (not height))
 +	      (%trace ";\t  re-size!: unrealized "widget"\n")
 +	      (let ((widget-x-size (width->x-size screen width))
 +		    (widget-y-size (height->y-size screen height)))
 +		(if (and (fix:= widget-x-size window-x-size)
 +			 (fix:= widget-y-size window-y-size))
 +		    (%trace ";\t  re-size!: no change\n")
 +		    (let ((new-width (x-size->width screen window-x-size))
 +			  (new-height (y-size->height screen window-y-size)))
 +		      (%trace ";\t  new size request! "widget
 +			      " from "widget-x-size"x"widget-y-size" "
 +			      "("width"x"height")"
 +			      " to "window-x-size"x"window-y-size" "
 +			      "("new-width"x"new-height")\n")
 +		      (gtk-widget-set-size-request widget
 +						   new-width new-height))))))))
 +
-     (define (pack-new! windows box resizer prefix)
++    (define (pack-new! windows grid resizer prefix)
 +      (let ((window (car windows)))
- 	(%trace ";     "prefix"pack-new! "window" in "box"\n")
++	(%trace ";     "prefix"pack-new! "window" in "grid"\n")
 +	(cond
 +	 ((combination? window)
- 	  (let ((new (if (combination-vertical? window)
- 			 (gtk-vbox-new #f 0)
- 			 (gtk-hbox-new #f 0)))
++	  (let ((new (gtk-grid-new))
 +		(new-prefix (string-append prefix "--")))
++	    (if (combination-vertical? window)
++		(begin
++		  (gtk-orientable-set-orientation new 'vertical)
++		  (gtk-widget-set-vexpand new #t))
++		(begin
++		  (gtk-orientable-set-orientation new 'horizontal)
++		  (gtk-widget-set-hexpand new #t)))
 +	    (pack-new! (%reversed-children (car windows)) new #f new-prefix)
- 	    (gtk-box-pack-end box new #t #t 0)
- 	    (%trace ";     "prefix"packed "new" in "box"\n")
++	    (gtk-container-add grid new)
++	    (%trace ";     "prefix"packed "new" in "grid"\n")
 +	    (if resizer (set-fix-resizer-before! resizer new))
- 	    (if (and (gtk-hbox? box) (pair? (cdr windows)))
++	    (if (and (eq? 'HORIZONTAL (gtk-orientable-get-orientation grid))
++		     (pair? (cdr windows)))
 +		;; Need resizer.
 +		(let ((new-resizer
 +		       (make-fix-resizer (gtk-screen-char-width screen) -1)))
 +		  (set-fix-resizer-after! new-resizer new)
- 		  (gtk-box-pack-end box new-resizer #f #f 0)
- 		  (pack-new! (cdr windows) box new-resizer prefix))
++		  (gtk-container-add grid new-resizer)
++		  (pack-new! (cdr windows) grid new-resizer prefix))
 +		;; Need NO resizer.
 +		(if (pair? (cdr windows))
- 		    (pack-new! (cdr windows) box #f prefix)))))
++		    (pack-new! (cdr windows) grid #f prefix)))))
 +
 +	 ((buffer-frame? window)
- 	  (let ((vbox (make-buffer-frame-widget))
++	  (let ((vgrid (make-buffer-frame-widget))
 +		(text (make-text-widget screen
 +					(%text-x-size window)
 +					(%text-y-size window)))
 +		(scroller (gtk-scrolled-window-new))
 +		(modeline (if (not (frame-modeline-inferior window))
 +			      #f
 +			      (make-modeline-widget screen)))
 +		(y-step (fix:+ (gtk-screen-line-height screen)
 +			       (gtk-screen-line-spacing screen)))
 +		(x-step (gtk-screen-char-width screen)))
 +	    (set-text-widget-buffer-frame! text window)
 +	    (set-text-widget-modeline! text modeline)
 +	    (set-fix-layout-scroll-step! text x-step y-step)
 +	    (gtk-scrolled-window-set-policy scroller 'auto 'always)
 +	    (gtk-scrolled-window-set-placement scroller 'bottom-left)
- 	    (gtk-container-add scroller text)
 +	    (if (not modeline)
 +		;; No modeline: the window/text-widget should NOT expand.
 +		(begin
- 		  ;; This is also necessary! Why???
- 		  (gtk-widget-set-size-request scroller
- 					       (%widget-x-size window screen)
- 					       (%widget-y-size window screen))
- 		  (gtk-box-pack-end vbox scroller #f #f 0)
- 		  (gtk-box-pack-end box vbox #f #f 0)
- 		  (%trace ";     "prefix"packed "vbox" into "box"\n"))
- 		;; With modeline: vbox and scroller SHOULD expand.
++		  (gtk-container-add scroller text)
++		  (gtk-container-add vgrid scroller)
++		  (gtk-container-add grid vgrid)
++		  (%trace ";     "prefix"packed "vgrid" into "grid"\n"))
++		;; With modeline: vgrid and scroller SHOULD expand.
 +		(begin
- 		  (gtk-box-pack-end vbox modeline #f #f 0)
- 		  (gtk-box-pack-end vbox scroller #t #t 0)
- 		  (gtk-box-pack-end box vbox #t #t 0)
- 		  (%trace ";     "prefix"packed "vbox" into "box"\n")))
- 	    (if resizer (set-fix-resizer-before! resizer vbox))
- 	    (if (and (gtk-hbox? box) (pair? (cdr windows)))
++		  (gtk-widget-set-vexpand text #t)
++		  (gtk-container-add scroller text)
++		  (gtk-container-add vgrid modeline)
++		  (gtk-container-add vgrid scroller)
++		  (gtk-container-add grid vgrid)
++		  (%trace ";     "prefix"packed "vgrid" into "grid"\n")))
++	    (if resizer (set-fix-resizer-before! resizer vgrid))
++	    (if (and (eq? 'HORIZONTAL (gtk-orientable-get-orientation grid))
++		     (pair? (cdr windows)))
 +		;; Need resizer.
 +		(let ((new-resizer
 +		       (make-fix-resizer (gtk-screen-char-width screen) -1)))
- 		  (set-fix-resizer-after! new-resizer vbox)
- 		  (gtk-box-pack-end box new-resizer #f #f 0)
- 		  (pack-new! (cdr windows) box new-resizer prefix))
++		  (set-fix-resizer-after! new-resizer vgrid)
++		  (gtk-container-add grid new-resizer)
++		  (pack-new! (cdr windows) grid new-resizer prefix))
 +		;; Need NO resizer.
 +		(if (pair? (cdr windows))
- 		    (pack-new! (cdr windows) box #f prefix)))))
++		    (pack-new! (cdr windows) grid #f prefix)))))
 +	 (else (error "Unexpected Edwin window:" window)))))
 +
 +    (main))
 +
 +(define-integrable (typein-widget screen)
-   (let* ((top-box (car (gtk-container-reverse-children
- 		       (gtk-screen-toplevel screen))))
++  (let* ((top-grid (car (gtk-container-reverse-children
++			 (gtk-screen-toplevel screen))))
 +	 ;; Typein widget is always added first -- last in the reverse list.
- 	 (typein-frame (last (gtk-container-reverse-children top-box))))
++	 (typein-frame (last (gtk-container-reverse-children top-grid))))
 +    (any-child text-widget? typein-frame)))
 +
 +(define (%reversed-children window)
 +  ;; Produce a list of a combination window's children from right to
 +  ;; left (or bottom to top).
 +  (cond ((editor-frame? window)
 +	 (list (editor-frame-typein-window window)
 +	       (editor-frame-root-window window)))
 +	((combination? window)
 +	 (let loop ((child (combination-child window))
 +		    (so-far '()))
 +	   (if child
 +	       (loop (window-next child)
 +		     (cons child so-far))
 +	       so-far)))
 +	(else (error "Unexpected Edwin window:" window))))
 +
 +(define-integrable (%text-x-size window)
 +  (%window-x-size (frame-text-inferior window)))
 +
 +(define-integrable (%text-y-size window)
 +  (%window-y-size (frame-text-inferior window)))
 +
 +(define-integrable (%widget-x-size window screen)
 +  (x-size->width screen (%text-x-size window)))
 +
 +(define-integrable (%widget-y-size window screen)
 +  (y-size->height screen (%text-y-size window)))
 +
 +(define (for-each-text-widget screen procedure)
 +  (every-child (lambda (widget)
 +		 (and (text-widget? widget)
 +		      (procedure widget))
 +		 #t)
 +	       (gtk-screen-toplevel screen)))
 +
 +(define (every-text-widget screen predicate)
 +  ;; Returns #t iff PREDICATE returns #t for every text widget on the
 +  ;; screen.
 +  (every-child (lambda (widget)
 +		 (or (not (text-widget? widget))
 +		     (predicate widget)))
 +	       (gtk-screen-toplevel screen)))
 +
 +(define (any-text-widget container)
 +  (any-child text-widget? container))
 +
 +(define (any-child predicate container)
 +  (let loop ((children (gtk-container-reverse-children container)))
 +    (cond ((null? children) #f)
 +	  ((predicate (car children)) (car children))
 +	  ((gtk-container? (car children))
 +	   (or (loop (gtk-container-reverse-children (car children)))
 +	       (loop (cdr children))))
 +	  (else
 +	   (loop (cdr children))))))
 +
 +(define (every-child predicate container)
 +  (let loop ((children (gtk-container-reverse-children container)))
 +    (cond ((null? children) #t)
 +	  ((gtk-container? (car children))
 +	   (and (loop (gtk-container-reverse-children (car children)))
 +		(loop (cdr children))))
 +	  ((predicate (car children)) (loop (cdr children)))
 +	  (else #f))))
 +
 +;;; Text and Modeline Widgets
 +
 +(define-class <edwin-widget>
 +    (<fix-layout>)
 +
 +  (screen define standard))
 +
 +(define-class (<text-widget>
 +	       (constructor make-text-widget (screen) (x-size y-size)))
 +    (<edwin-widget>)
 +
 +  (override-drawing define standard)
 +  (buffer-drawing define standard initial-value #f)
 +
 +  ;; Scroll pos for buffer-drawing, saved while override-drawing is up.
 +  (text-pos define standard initializer (lambda () (cons 0 0)))
 +
 +  (buffer-frame define standard)
 +  (modeline define standard initial-value #f)
 +  (cursor-ink define standard initial-value #f)
 +  (start-mark define standard initial-value #f))
 +
 +(define-guarantee text-widget "a <text-widget>")
 +
 +(define-method initialize-instance ((widget <text-widget>) x-size y-size)
 +;;;  (%trace ";(initialize-instance <text-widget>) "widget
 +;;;	  " "x-size" "y-size"\n")
 +  (let ((screen (edwin-widget-screen widget)))
 +    (call-next-method widget
 +		      (x-size->width screen x-size)
 +		      (y-size->height screen y-size)))
 +  (let ((drawing (make-fix-drawing)))
 +;;;    (%trace "; drawing: "drawing"\n")
 +    (let ((ink (make-simple-text-ink)))
 +      (set-simple-text-ink-text! ink widget "Initial override message.")
 +      (set-text-ink-color! ink "black")
 +      (fix-drawing-add-ink! drawing ink)
 +      (let ((extent (fix-ink-extent ink)))
 +	(set-fix-drawing-size! drawing
 +			       (fix-rect-width extent)
 +			       (fix-rect-height extent))))
 +    (set-text-widget-override-drawing! widget drawing)
 +    (set-fix-layout-drawing! widget drawing 0 0))
 +  (set-fix-widget-map-handler! widget map-handler)
 +  (set-fix-widget-unmap-handler! widget unmap-handler)
 +  (set-fix-widget-focus-change-handler! widget focus-change-handler)
 +  (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
 +  (set-fix-widget-key-press-handler! widget key-press-handler)
 +  widget)
 +
 +(define-method gtk-widget-destroy-callback ((widget <text-widget>))
 +  ;; NOTE that this callback can be called before a widget is realized(!).
 +  (call-next-method widget)
 +  (let ((cursor (text-widget-cursor-ink widget)))
 +    (if cursor
 +	(fix-ink-remove! cursor)))
 +  (and-let* ((drawing (text-widget-override-drawing widget))
 +	     (ink (car (fix-drawing-display-list drawing)))
 +	     ((text-ink? ink))
 +	     (layout (text-ink-pango-layout ink)))
 +    (gobject-unref! layout))
 +  unspecific)
 +
 +(define-method fix-widget-realize-callback ((widget <text-widget>))
 +  (%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)))
 +	;; Unfortunately a widget can be realized before it is
 +	;; allocated a size -- when it is added to a realized
 +	;; container.  In this case, initialize WIDGET's size to
 +	;; something reasonable.
 +	(let ((window (text-widget-buffer-frame widget))
 +	      (screen (edwin-widget-screen widget)))
 +	  (%trace "; uninitialized geometry: "geometry"\n")
 +	  (set-fix-rect-size! geometry
 +			      (%widget-x-size window screen)
 +			      (%widget-y-size window screen))
 +	  (%trace "; initialized geometry: "geometry"\n"))))
 +  (call-next-method widget)
 +  (realize-font! widget)
 +  (set-gtk-widget-bg-color! widget "white"))
 +
 +(define-method fix-widget-new-geometry-callback ((widget <text-widget>))
 +  (%trace ";(fix-widget-new-geometry-callback <text-widget>) "widget"\n")
 +  (call-next-method widget)
 +  (thread-queue/queue-no-hang!
 +   event-queue
 +   (make-input-event
 +    'SET-WINDOW-SIZE
 +    (lambda (widget)
 +      (%trace ";  input event: set-window-size "widget"\n")
 +      (let ((geometry (fix-widget-geometry widget))
 +	    (screen (edwin-widget-screen widget))
 +	    (window (text-widget-buffer-frame widget)))
 +	(let ((widget-x-size (width->x-size screen (fix-rect-width geometry)))
 +	      (widget-y-size (height->y-size screen (fix-rect-height geometry)))
 +	      (window-x-size (%text-x-size window))
 +	      (window-y-size (%text-y-size window)))
 +	  (%trace "; "widget": "geometry"\n")
 +	  (%trace "; "window": "window-x-size"x"window-y-size"\n")
 +	  (if (not (and (fix:= widget-x-size window-x-size)
 +			(fix:= widget-y-size window-y-size)))
 +	      (update-sizes screen)))))
 +    widget)))
 +
 +(define (update-sizes screen)
 +  ;; The underhanded way to adjust window sizes.  This procedure does
 +  ;; not use the :set-size! method, which presumably adjusts the
 +  ;; widget sizes.  It does the "opposite".  It leaves the widgets
 +  ;; alone and adjusts Edwin's window and screen sizes (using %
 +  ;; operators).
 +
 +  (define (%set-size! screen window prefix)
 +    (cond
 +     ((buffer-frame? window)
 +      (let ((widget (window-text-widget* window)))
 +	(if widget
 +	    (let* ((view (fix-layout-view widget))
 +		   (width (fix-rect-width view))
 +		   (height (fix-rect-height view))
 +		   (x-size (width->x-size screen width))
 +		   (y-size (height->y-size screen height))
 +		   (x-size* (if (window-has-right-neighbor? window)
 +				(fix:1+ x-size) x-size))
 +		   (y-size* (if (frame-modeline-inferior window)
 +				(fix:1+ y-size) y-size))
 +		   (text (frame-text-inferior window)))
 +
 +	      (%trace ";   "prefix""text": "x-size"x"y-size" "view"\n")
 +	      (%set-window-x-size! text x-size)
 +	      (%set-window-y-size! text y-size)
 +	      (%trace ";   "prefix""window": "x-size*"x"y-size*"\n")
 +	      (%set-window-x-size! window x-size*)
 +	      (%set-window-y-size! window y-size*))
 +	    (%trace ";   "prefix""window": no widget\n"))))
 +
 +     ((or (combination? window)
 +	  (editor-frame? window))
 +      (let ((total-x-size #f)
 +	    (total-y-size #f)
 +	    (vertical? (or (editor-frame? window)
 +			   (combination-vertical? window))))
 +	(for-each
 +	  (lambda (inferior)
 +	    (let ((child (inferior-window inferior)))
 +	      (%set-size! screen child (string-append prefix "--"))
 +	      (if vertical?
 +		  (let ((x-size (%window-x-size child))
 +			(y-size (%window-y-size child)))
 +		    (set! total-x-size
 +			  (if (not total-x-size)
 +			      x-size
 +			      (fix:max x-size total-x-size)))
 +		    (set! total-y-size
 +			  (if (not total-y-size)
 +			      y-size
 +			      (fix:+ total-y-size y-size))))
 +		  (let ((x-size (%window-x-size child))
 +			(y-size (%window-y-size child)))
 +		    (set! total-y-size
 +			  (if (not total-y-size)
 +			      y-size
 +			      (fix:max y-size total-y-size)))
 +		    (set! total-x-size
 +			  (if (not total-x-size)
 +			      x-size
 +			      (fix:+ total-x-size x-size)))))))
 +	  (window-inferiors window))
 +	(%trace ";   "prefix""window": "total-x-size"x"total-y-size"\n")
 +	(%set-window-x-size! window total-x-size)
 +	(%set-window-y-size! window total-y-size)))
 +
 +     (else
 +      (%trace ";   "prefix""window": unexpected type\n"))))
 +
 +  (define (%set-starts! windows parent prefix x y)
 +    (if (pair? windows)
 +	(let* ((window (car windows))
 +	       (inferior (find-inferior (window-inferiors parent) window)))
 +	  (%trace ";   "prefix""window" start: "x"x"y
 +		  " (was "
 +		  (inferior-x-start inferior)"x"(inferior-y-start inferior)
 +		  ")\n")
 +	  (%set-inferior-start! inferior x y)
 +	  (if (or (editor-frame? window)
 +		  (combination? window))
 +	      (%set-starts! (reverse! (%reversed-children window)) window
 +			    (string-append prefix "--")
 +			    x y))
 +	  (if (or (editor-frame? parent)
 +		  (and (combination? parent)
 +		       (combination-vertical? parent)))
 +	      (%set-starts! (cdr windows) parent prefix
 +			    x
 +			    (fix:+ y (%window-y-size window)))
 +	      (%set-starts! (cdr windows) parent prefix
 +			    (fix:+ x (%window-x-size window))
 +			    y)))))
 +
 +  (%trace "; update-sizes "screen"\n")
 +  (let ((root (screen-root-window screen)))
 +    (let ((x-size (%window-x-size root))
 +	  (y-size (%window-y-size root)))
 +      (%trace ";   initial root size: "x-size"x"y-size"\n"))
 +    (%set-size! screen root "--")
 +    (let ((x-size (%window-x-size root))
 +	  (y-size (%window-y-size root)))
 +      (%trace ";   screen: "x-size"x"y-size"\n")
 +      (set-screen-x-size! screen x-size)
 +      (set-screen-y-size! screen y-size))
 +    (%set-starts! (reverse! (%reversed-children root)) root "--" 0 0)))
 +
 +(define-integrable (editor-frame? object)
 +  (object-of-class? editor-frame object))
 +
 +(define-class (<modeline-widget> (constructor make-modeline-widget (screen)))
 +    (<edwin-widget>))
 +
 +(define-method initialize-instance ((widget <modeline-widget>))
 +;;;  (%trace ";(initialize-instance <modeline-widget>) "widget"\n")
 +  (let ((screen (edwin-widget-screen widget)))
 +    (call-next-method widget -1 (y-size->height screen 1)))
 +  (let ((drawing (make-fix-drawing)))
 +;;;    (%trace "; drawing: "drawing"\n")
 +    (let ((ink (make-simple-text-ink)))
 +      (set-simple-text-ink-text!
 +       ink widget "--------Initial mode line.--------------------------------")
 +      (set-text-ink-color! ink "white")
 +      (fix-drawing-add-ink! drawing ink)
 +      (let ((extent (fix-ink-extent ink)))
 +	(set-fix-drawing-size! drawing
 +			       (fix-rect-width extent)
 +			       (fix-rect-height extent))))
 +    (set-fix-layout-drawing! widget drawing 0 0))
 +  (set-fix-widget-map-handler! widget map-handler)
 +  (set-fix-widget-unmap-handler! widget unmap-handler)
 +  (set-fix-widget-focus-change-handler! widget focus-change-handler)
 +  (set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
 +  (set-fix-widget-key-press-handler! widget key-press-handler)
 +  widget)
 +
 +(define-method fix-widget-realize-callback ((widget <modeline-widget>))
 +  (%trace ";(fix-widget-realize-callback <modeline-widget>) "widget"\n")
 +  (let ((geometry (fix-widget-geometry widget)))
 +    (if (or (not (fix-rect-width geometry))
 +	    (not (fix-rect-height geometry)))
 +	;; Unfortunately a widget can be realized before it is
 +	;; allocated a size -- when it is added to a realized
 +	;; container.  In this case, initialize WIDGET's size to
 +	;; something reasonable.
 +	(let ((screen (edwin-widget-screen widget)))
 +	  (%trace "; uninitialized geometry: "geometry"\n")
 +	  (set-fix-rect-size! geometry -1 (y-size->height screen 1))
 +	  (%trace "; initialized geometry: "geometry"\n"))))
 +  (call-next-method widget)
 +  (realize-font! widget)
 +  (set-gtk-widget-bg-color! widget "black"))
 +
 +(define-class (<buffer-frame-widget> (constructor ()))
-     (<gtk-vbox>)
++    (<gtk-grid>)
 +
 +  ;; This one just "marks" a gtk-container as the type that holds a
 +  ;; text-widget and its modeline (and button bars?) together.  If the
 +  ;; frame has no modeline (nor button bars? :-) a lone scroller STILL
 +  ;; gets wrapped.
 +  )
 +
 +(define-method initialize-instance ((widget <buffer-frame-widget>))
 +;;;  (%trace ";(initialize-instance <buffer-frame-widget>) "widget"\n")
-   (call-next-method widget #f 0))
++  (call-next-method widget #f 0)
++  (gtk-orientable-set-orientation widget 'vertical))
 +
 +;; Assume there is one text-widget in a buffer-frame-widget.
 +(define-integrable buffer-frame-widget-text* any-text-widget)
 +
 +;;; Incremental Redisplay
 +
 +;; Drawing a Buffer
 +;;
 +;; At its simplest, drawing a buffer is a process of searching for
 +;; the "lines" between newlines and creating a <line-ink> for
 +;; each.  The <line-ink>s are sized -- layed out in a PangoLayout
 +;; -- and arranged vertically against the left margin.  Each line-ink
 +;; 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
 +;; 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
 +;; lines, create more, or erase some.  Lines below the region are
 +;; textually unchanged, and do not have to be re-layed out by Pango,
 +;; though they may need to be moved to accommodate insertions and
 +;; deletions above them.
 +;; 
 +;; <line-ink>s are text-inks, but not simple-text-inks.  The latter
 +;; 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).
 +;;
 +;; To lighten the footprint of a large buffer drawing, line-inks do
 +;; not hold a PangoLayout, but create one on demand using the buffer
 +;; text.  They cache the created PangoLayout, and steal existing
 +;; PangoLayouts from line-inks that are off-screen.  The caching
 +;; 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.
 +;;
 +;; 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.
 +
 +(define-method update-screen! ((screen <gtk-screen>) display-style)
 +  (%trace "; (update-screen! <gtk-screen>) "screen" "display-style"\n")
 +  (with-screen-in-update
 +   screen
 +   (lambda ()
 +     (cond
 +      ((display-style/no-screen-output? display-style)
 +       (invalidate-all-drawings! screen)
 +       (%trace "; (update-screen! <gtk-screen>) done: no-output\n")
 +       'NO-OUTPUT)
 +      ((not (memq (screen-visibility screen) '(VISIBLE PARTIALLY-OBSCURED)))
 +       (let ((visibility (screen-visibility screen)))
 +	 (if (not (eq? visibility 'DELETED))
 +	     (update-name screen))
 +	 (invalidate-all-drawings! screen)
 +	 (%trace "; (update-screen! <gtk-screen>) done: "visibility"\n")
 +	 visibility))
 +      (else
 +       (update-widgets screen)
 +       (%trace ";   update drawings\n")
 +       (if (every (lambda (entry) (update-drawing screen (cdr entry)))
 +		  (gtk-screen-drawings screen))
 +	   (begin
 +	     (%trace ";   update windows\n")
 +	     (for-each-text-widget screen update-window)
 +	     (if (display-style/discard-screen-contents? display-style)
 +		 (for-each-text-widget screen gtk-widget-queue-draw))
 +	     (update-blinking screen)
 +	     (%trace "; (update-screen! <gtk-screen>) done: finished\n")
 +	     #t)
 +	   (begin
 +	     (%trace "; (update-screen! <gtk-screen>) done: halted\n")
 +	     #f)))))))
 +
 +(define (invalidate-all-drawings! screen)
 +  (%trace ";   invalidated all drawings\n")
 +  (for-each (lambda (entry)
 +	      (set-buffer-drawing-valid?! (cdr entry) #f))
 +	    (gtk-screen-drawings screen)))
 +
 +(define-integrable with-screen-in-update
 +  (named-lambda (with-screen-in-update screen thunk)
 +    (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)
 +  ;; Sometimes called by a callback (i.e. without-interrupts).  Frobs
 +  ;; JUST the canvas (else must queue an editor input event.)
 +  (%trace ";   update blinking "screen"\n")
 +  (if (not (gtk-screen-in-focus? screen))
 +      (begin
 +	(%trace ";     not the focus\n")
 +	(blink! screen #f))
 +      (let ((window (screen-cursor-window screen)))
 +	(if (not window)
 +	    (begin
 +	      (%trace ";     no cursor window\n")
 +	      (blink! screen #f))
 +	    (let ((widget (window-text-widget* window)))
 +	      (%trace ";     cursor window: "window" "widget"\n")
 +	      (guarantee-text-widget widget 'update-blinking)
 +	      (let ((cursor (text-widget-cursor-ink widget)))
 +		(if (not cursor)
 +		    (begin
 +		      (%trace ";     no cursor yet\n")
 +		      (blink! screen #f))
 +		    (begin
 +		      (%trace ";     enabling "cursor"\n")
 +		      (visible! cursor #t)
 +		      (blink! screen cursor)))))))))
 +
 +(define-method update-screen-window!
 +    ((screen <gtk-screen>) window display-style)
 +  (%trace "; (update-screen-window! <gtk-screen>) "screen" "window"\n")
 +  (let ((v (update-screens! display-style)))
 +    (%trace "; (update-screen-window! <gtk-screen>) "screen" "window" => "v"\n")
 +    v))
 +
 +(define (update-widget-buffer widget)
 +  (%trace ";     update-widget-buffer "widget"\n")
 +  (let ((screen (edwin-widget-screen widget))
 +	(window (text-widget-buffer-frame widget)))
 +	    
 +    (define-integrable (main)
 +      (let* ((new-buffer (window-buffer window))
 +	     (old-drawing (text-widget-buffer-drawing widget))
 +	     (old-buffer (and old-drawing
 +			      (buffer-drawing-buffer old-drawing))))
 +	(if (and old-buffer (eq? new-buffer old-buffer)
 +		 old-drawing (drawing-match? old-drawing))
 +	    (%trace ";\tno change\n")
 +	    (let ((new-drawing (find/create-drawing widget)))
 +	      (%trace ";\tnew/old buffer: "new-buffer
 +		      "/"old-buffer" ("old-drawing")\n")
 +	      (set-text-widget-buffer-drawing! widget new-drawing)
 +	      (re-cursor widget new-drawing)
 +	      (if (not (eq? (fix-layout-drawing widget)
 +			    (text-widget-override-drawing widget)))
 +		  (set-fix-layout-drawing! widget new-drawing 0 0))))))
 +
 +    (define (re-cursor widget drawing)
 +      ;; Re-set text-WIDGET-cursor-ink per new buffer in DRAWING.
 +      (%trace ";\tre-cursor "widget" "drawing"\n")
 +      (let ((cursor (text-widget-cursor-ink widget))
 +	    (modeline (text-widget-modeline widget)))
 +	(cond ((not cursor)
 +	       (let ((new (make-cursor-ink))
 +		     (width (fix:quotient (gtk-screen-char-width screen) 2))
 +		     (height (gtk-screen-line-height screen))
 +		     (space (gtk-screen-line-spacing screen))
 +		     (widgets (list widget)))
 +		 (%trace ";\t  new "new" for new "widget"\n")
 +		 (set-box-ink! new 0 space width height)
 +		 (set-cursor-ink-widget-list! new widgets)
 +		 (if (not modeline)
 +		     (begin
 +		       (set-fix-ink-widgets! new '())
 +		       (set-cursor-ink-visible?! new #f))
 +		     (begin
 +		       (set-fix-ink-widgets! new widgets)))
 +		 (set-text-widget-cursor-ink! widget new)
 +		 (fix-drawing-add-ink! drawing new 'bottom)))
 +	      ((not (eq? drawing (fix-ink-drawing cursor)))
 +	       (%trace ";\t  moving "cursor" to new "drawing"\n")
 +	       (fix-ink-remove! cursor)
 +	       (set-box-ink-position! cursor 0 (gtk-screen-line-spacing screen))
 +	       (fix-drawing-add-ink! drawing cursor 'bottom))
 +	      (else
 +	       (%trace ";\t  no change\n")))))
 +
 +    (define (find/create-drawing widget)
 +      (%trace ";\tfind/create-drawing for "widget" ("window")\n")
 +      (let ((buffer (window-buffer window))
 +	    (drawings (gtk-screen-drawings screen)))
 +	(or
 +	 (cdr* (find (lambda (buffer.drawing)
 +		       (and (eq? (car buffer.drawing) buffer)
 +			    (drawing-match? (cdr buffer.drawing))))
 +		     drawings))
 +	 (let* ((bufwin (frame-text-inferior window))
 +		(new (make-buffer-drawing
 +		      buffer
 +		      (%window-tab-width bufwin)
 +		      (%window-char-image-strings bufwin))))
 +	   (%trace ";\t  new buffer drawing: "new" "buffer
 +		   " "window" "widget"\n")
 +	   (set-gtk-screen-drawings! screen (cons (cons buffer new) drawings))
 +	   new))))
 +
 +    (define (drawing-match? drawing)
 +      ;; #t iff nothing has changed, in terms of drawing style
 +      ;; parameters, between WINDOW and DRAWING.
 +      (let ((bufwin (frame-text-inferior window)))
 +	(and (fix:= (%window-tab-width bufwin)
 +		    (buffer-drawing-tab-width drawing))
 +	     (eq? (%window-char-image-strings bufwin)
 +		  (buffer-drawing-char-image-strings drawing)))))
 +
 +    (main)))
 +
 +(define (update-window widget)
 +  (%trace ";     update-window "widget"\n")
 +  (let ((window (text-widget-buffer-frame widget)))
 +    (let ((message (window-override-message window))
 +	  (drawing (fix-layout-drawing widget)) ; current drawing: either...
 +	  (override (text-widget-override-drawing widget)) ; this...
 +	  (text (text-widget-buffer-drawing widget)))	   ; or this.
 +      (guarantee-fix-drawing drawing 'update-window)
 +      (guarantee-fix-drawing override 'update-window)
 +      (guarantee-fix-drawing text 'update-window)
 +      (if message
 +	  (begin
 +	    ;; ReDisplay message in override.
 +	    (let* ((text-ink (car (fix-drawing-display-list override))))
 +	      (set-simple-text-ink-text! text-ink widget message)
 +	      (let ((e (fix-ink-extent text-ink)))
 +		(set-fix-drawing-size! override
 +				       (fix-rect-width e)
 +				       (fix-rect-height e))))
 +	    (if (not (eq? override drawing))
 +		(let ((saved-pos (text-widget-text-pos widget))
 +		      (view (fix-layout-view widget)))
 +		  (set-car! saved-pos (fix-rect-x view))
 +		  (set-cdr! saved-pos (fix-rect-y view))
 +		  (%trace ";\tsaving text position "saved-pos"\n")
 +		  (set-fix-layout-drawing! widget override 0 0))
 +		(%trace ";\toverride still up\n")))
 +	  (begin
 +	    ;; ReDisplay text, and scroll to cursor.
 +	    (if (not (eq? text drawing))
 +		(let ((saved-pos (text-widget-text-pos widget)))
 +		  (%trace ";\trestoring "text" to "saved-pos"\n")
 +		  (set-fix-layout-drawing! widget text
 +					   (car saved-pos) (cdr saved-pos)))
 +		(%trace ";\ttext still up\n"))
 +	    (update-cursor widget)
 +	    (let ((extent (fix-ink-extent (text-widget-cursor-ink widget))))
 +	      (%trace ";\tscrolling to "extent"\n")
 +	      (fix-layout-scroll-nw! widget extent)
 +	      (%trace ";\tview: "(fix-layout-view widget)"\n"))
 +	    (update-modeline widget))))))
 +
 +;; This variable caches a modeline image buffer.  A modeline update
 +;; hacks this buffer, then compares it to the string in the simple-
 +;; text-ink.  This avoids much consing and widget damage.  The Edwin
 +;; thread should be the only thread accessing this resource.
 +(define modeline-image "")
 +
 +(define (update-modeline widget)
 +  ;; Must be last in the update process.  Some of its state depends on
 +  ;; the final scroll position!
 +  (%trace ";     update-modeline "widget"\n")
 +  (let* ((window (text-widget-buffer-frame widget))
 +	 ;; Add a few columns so the text runs past scrollbars and
 +	 ;; whatnot, off the right side of the widget.
 +	 (x-size (+ 5 (%window-x-size window))))
 +    (if widget
 +	(let ((modeline (text-widget-modeline widget)))
 +	  (if modeline
 +	      (begin
 +		(let ((maxlen (string-maximum-length modeline-image)))
 +		  (if (> x-size maxlen)
 +		      (set! modeline-image (string-allocate x-size))
 +		      (set-string-length! modeline-image maxlen)))
 +		(modeline-string! window modeline-image 0 x-size)
 +		(set-string-length! modeline-image x-size)
 +		(let* ((drawing (fix-layout-drawing modeline))
 +		       (inks (fix-drawing-display-list drawing))
 +		       (ink (cond ((null? inks)
 +				   (let ((i (make-simple-text-ink)))
 +				     (fix-drawing-add-ink! drawing i)
 +				     i))
 +				  ((simple-text-ink? (car inks)) (car inks))
 +				  (else (error "bogus modeline drawing"))))
 +		       (old (simple-text-ink-text ink)))
 +		  (if (not (and old (string=? old modeline-image)))
 +		      (let ((copy (string-copy modeline-image)))
 +			(set-simple-text-ink-text! ink widget copy)
 +			;; Ensure that text-ink is wider than widget???
 +			(%trace ";\tupdated "modeline": \""copy"\"\n"))
 +		      (%trace ";\tunchanged "modeline"\n"))))
 +	      (%trace ";\tno modeline\n")))
 +	(%trace ";\tno widget!\n")))
 +  (%trace ";     update-modeline done\n"))
 +
 +(define (update-name screen)
 +  (let ((name (frame-name screen))
 +	(name* (gtk-screen-name screen)))
 +    (if (and name (or (not name*) (not (string=? name name*))))
 +	(begin
 +	  (set-gtk-screen-name! screen name)
 +	  (gtk-window-set-title (gtk-screen-toplevel screen) name)))))
 +
 +(define (frame-name screen)
 +  (let* ((window
 +	  (if (and (eq? screen (selected-screen)) (within-typein-edit?))
 +	      (typein-edit-other-window)
 +	      (screen-selected-window screen)))
 +	 (buffer (window-buffer window))
 +	 (format (ref-variable frame-name-format buffer)))
 +    (and format
 +	 (string-trim-right
 +	  (format-modeline-string
 +	   window format (ref-variable frame-name-length buffer))))))
 +
 +(define (update-drawing screen drawing)
 +  ;; Redraw a buffer-DRAWING.
 +  (%trace ";     update-drawing "screen" "drawing"\n")
 +
 +  ;; This is the traditional Emacs layout, in a fixed-width font, with
 +  ;; 2 and 4 character depictions of many characters (e.g. ^@ and
 +  ;; \200).
 +
 +  ;; Line wrapping is not currently supported.
 +
 +  ;; Consider first a diagram of our buffer:
 +  ;; 
 +  ;;     unchanged prefix
 +  ;;     change-region
 +  ;;     unchanged suffix
 +  ;; 
 +  ;; and the process of redrawing it:
 +  ;; 
 +  ;;     Skip through prefix, to a line needing updating -- a line
 +  ;;     stretching into the change region.  There may be no such line
 +  ;;     if there is no next line, or the next line does not need
 +  ;;     updating -- lies beyond the change region.
 +  ;; 
 +  ;;     Steal this line-needing-updating (if any); lay it out again;
 +  ;;     move/re-size it.  Steal it AND the next... until the last
 +  ;;     stolen line reaches beyond the change region, or there are no
 +  ;;     more lines-needing-updating to steal.  Remove any remaining
 +  ;;     lines-needing-updating.  If the last stolen line did NOT
 +  ;;     reach beyond the change region (nor hit the buffer's end),
 +  ;;     add lines until the last added line does.  The last stolen or
 +  ;;     added line should MEET the next line, a line NOT needing
 +  ;;     updating (if any, else the buffer's end).
 +  ;;
 +  ;;     Move the remaining lines -- those entirely in the suffix (if
 +  ;;     any).  Note that if the first remaining line does not need to
 +  ;;     move, neither do the rest.
 +  ;; 
 +  ;; Now consider display-start/end:
 +  ;; 
 +  ;;     Remove lines starting before display-start.
 +  ;;     Steal/add lines until they match the prefix (or perhaps the
 +  ;;     suffix, OR the display-end).
 +  ;; 
 +  ;;     As before, skip through the prefix, except that these
 +  ;;     "unchanged" lines might have to move.
 +  ;; 
 +  ;;     As before, steal/add changed lines until they reach (and
 +  ;;     meet!) lines in the suffix.
 +  ;; 
 +  ;;     As before, move lines in the suffix as necessary, except do
 +  ;;     not bother with lines reaching beyond display-end.
 +  ;; 
 +  ;;     Remove lines extending beyond display-end.  Add lines until
 +  ;;     they hit display-end.
 +
 +  (let* ((line-height (gtk-screen-line-height screen))
 +	 (line-spacing (gtk-screen-line-spacing screen))
 +	 (drawing-extent #f)	       ;set when an ink extent is known
 +	 (pango-layout #f)	       ;set when a pango-layout is allocated
 +	 (buffer (buffer-drawing-buffer drawing))
 +	 (group (buffer-group buffer))
 +	 (display-start (group-display-start group))
 +	 (display-end (group-display-end group))
 +	 (change-start-index (if (buffer-drawing-valid? drawing)
 +				 (group-start-changes-index group)
 +				 (mark-index display-start)))
 +	 (change-end-index (if (buffer-drawing-valid? drawing)
 +			       (group-end-changes-index group)
 +			       (mark-index display-end)))
 +	 (update-region #f))
 +
 +    (define-syntax %trace3
 +      (syntax-rules ()
 +	((_ ARGS ...) (if %trace-redraw?
 +			  (apply outf-error (%trace-simplify ARGS ...))))))
 +
 +    (define-integrable (main)
 +      (%trace3 ";\tdrawing/buffer ticks:"
 +	       " "(buffer-drawing-modified-tick drawing)
 +	       "/"(group-modified-tick group)"\n"
 +	       ";\tchange/display regions:"
 +	       " "change-start-index"-"change-end-index
 +	       "/"display-start"-"display-end"\n")
 +      (init-start/end)
 +      (cond
 +       ((no-display-changes?)
 +	(%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
 +		(next-lines (fix-drawing-display-list drawing))
 +		display-start 1 line-spacing
 +		(lambda (lines start num y)
 +
 +		  (redraw-prefix
 +		   lines start num y
 +		   (lambda (lines start num y)
 +
 +		     (redraw-changed
 +		      lines start num y
 +		      (lambda (lines start num y)
 +
 +			(redraw-suffix
 +			 lines start num y
 +
 +			 redraw-end)))))))))
 +
 +	  (set-buffer-drawing-update-region! drawing finished?)
 +	  (if finished?
 +	      (begin
 +		(set-size)
 +		(move-mark-to! (buffer-drawing-display-start drawing)
 +			       display-start)
 +		(move-mark-to! (buffer-drawing-display-end drawing)
 +			       display-end)
 +		(set-buffer-drawing-modified-tick!
 +		 drawing (group-modified-tick group))
 +		(set-buffer-drawing-valid?! drawing #t)))
 +
 +	  (if pango-layout (gobject-unref! pango-layout))
 +	  finished?))))
 +
 +    (define-integrable (init-start/end)
 +      (if (not (buffer-drawing-display-start drawing))
 +	  (begin
 +	    (set-buffer-drawing-display-start! drawing
 +					       (mark-permanent-copy
 +						display-start))
 +	    (set-buffer-drawing-display-end! drawing
 +					     (mark-permanent-copy
 +					      display-end)))))
 +    (define-integrable (set-size)
 +      (if drawing-extent
 +	  (let ((width+
 +		 (fix:+ (fix-rect-max-x drawing-extent)
 +			(gtk-screen-char-width screen)))
 +		(height+
 +		 (fix:+ (fix-rect-max-y drawing-extent)
 +			(if (final-newline? group)
 +			    (fix:+ line-spacing
 +				   (fix:+ line-height
 +					  line-spacing))
 +			    line-spacing))))
 +	    (fix-rect-union! drawing-extent (make-fix-rect 0 0 width+ height+))
 +	    (if (not (and (fix:= (fix-rect-min-x drawing-extent) 0)
 +			  (fix:= (fix-rect-min-y drawing-extent) 0)))
 +		(%trace "; Warning: drawing min x,y"
 +		       " = "(fix-rect-min-x drawing-extent)
 +		       ","(fix-rect-min-y drawing-extent)"!\n"))
 +	    (set-fix-drawing-size! drawing
 +				   (fix-rect-max-x drawing-extent)
 +				   (fix-rect-max-y drawing-extent)))
 +	  (set-fix-drawing-size! drawing 0 0))
 +      (%trace ";\tnew drawing extent: "(fix-drawing-extent drawing)"\n"))
 +
 +    (define (redraw-start lines start num y receiver)
 +      (%trace3 ";         redraw-start "lines" "start" "num" "y"\n")
 +      (let ((old-start (and (more-lines? lines)
 +			    (%unchanged? (car lines)
 +					 change-start-index change-end-index)
 +			    (line-ink-start (car lines)))))
 +	(cond ((not old-start)
 +	       (%trace3 ";           hit changed "(and(not(null? lines))(car lines))"\n")
 +	       (receiver lines start num y))
 +	      ((mark= start old-start)
 +	       (%trace3 ";           matched "(car lines)"\n")
 +	       (receiver lines start num y))
 +	      ((mark< start old-start)
 +	       (let ((new (add-line start num y lines)))
 +		 (%trace3 ";           added "new"\n")
 +		 (redraw-start lines (next-start new)
 +			       (next-num num) (next-y new) receiver)))
 +	      ((mark< old-start start)	;uncommon
 +	       (redraw-start (remove-lines-before lines start)
 +			     start num y receiver))
 +	      (else (%trace3 "; Unreachable?!\n")))))
 +
 +    (define (redraw-prefix lines start num y receiver)
 +      (%trace3 ";        redraw-prefix "lines" "start" "num" "y"\n")
 +      (cond (((editor-halt-update? current-editor))
 +	     (%trace3 ";           halt redraw!\n")
 +	     #f)
 +	    ((not (more-lines? lines))
 +	     (%trace3 ";           no more lines\n")
 +	     (receiver lines start num y))
 +	    ((and (%unchanged? (car lines) change-start-index change-end-index)
 +		  (mark<= (line-ink-end (car lines)) display-end))
 +	     (let ((next-y (move-line! (car lines) start num y)))
 +	       (%trace3 ";           prefix "(car lines)"\n")
 +	       (redraw-prefix (next-lines (cdr lines))
 +			      (next-start (car lines))
 +			      (next-num num)
 +			      next-y
 +			      receiver)))
 +	    (else
 +	     (%trace3 ";           not prefix "(car lines)"\n")
 +	     (receiver lines start num y))))
 +
 +    (define (redraw-changed lines start num y receiver)
 +      (%trace3 ";         redraw-changed "lines" "start" "num" "y"\n")
 +      (if (not change-start-index)
 +	  (begin
 +	    (%trace3 ";           no change region\n")
 +	    (receiver lines start num y))
 +	  (steal-changed
 +	   lines start num y
 +	   (lambda (lines start num y)
 +	     (remove-changed
 +	      lines start num y
 +	      (lambda (lines start num y)
 +		(add-changed
 +		 lines start num y
 +		 (lambda (lines start num y)
 +		   (receiver lines start num y)))))))))
 +
 +    (define (steal-changed lines start num y receiver)
 +      (%trace3 ";           steal-changed "lines" "start" "num" "y"\n")
 +      (cond (((editor-halt-update? current-editor))
 +	     (%trace3 ";             halt redraw!\n")
 +	     #f)
 +	    ((not (more-lines? lines))
 +	     (%trace3 ";             no more lines\n")
 +	     (receiver lines start num y))
 +	    ((mark<= display-end start)
 +	     (%trace3 ";             hit end at "start" with "lines"\n")
 +	     (receiver lines start num y))
 +	    ((%unchanged? (car lines) change-start-index change-end-index)
 +	     (%trace3 ";             unchanged "(car lines)"\n")
 +	     (receiver lines start num y))
 +	    ((fix:< change-start-index (mark-index start))
 +	     (%trace3 ";             beyond changes at "start"\n")
 +	     (receiver lines start num y))
 +	    (else
 +	     (steal-line! (car lines) start num y)
 +	     (%trace3 ";             stole line "(car lines)"\n")
 +	     (let* ((line (car lines))
 +		    (next-start (next-start line))
 +		    (next-lines (next-lines (cdr lines))))
 +	       (steal-changed (remove-lines-before next-lines next-start)
 +			      next-start (next-num num) (next-y line)
 +			      receiver)))))
 +
 +    (define (remove-changed lines start num y receiver)
 +      (%trace3 ";           remove-changed "lines" "start" "num" "y"\n")
 +      (cond (((editor-halt-update? current-editor))
 +	     (%trace3 ";             halt redraw!\n")
 +	     #f)
 +	    ((not (more-lines? lines))
 +	     (%trace3 ";             no more lines\n")
 +	     (receiver lines start num y))
 +	    ((%unchanged? (car lines) change-start-index change-end-index)
 +	     (%trace3 ";             unchanged "(car lines)"\n")
 +	     (receiver lines start num y))
 +	    (else
 +	     (remove-line (car lines))
 +	     (remove-changed (next-lines (cdr lines))
 +			     start num y receiver))))
 +
 +    (define (add-changed lines start num y receiver)
 +      (%trace3 ";           add-changed "lines" "start" "num" "y"\n")
 +      (cond (((editor-halt-update? current-editor))
 +	     (%trace3 ";           halt redraw!\n")
 +	     #f)
 +	    ((mark<= display-end start)
 +	     (%trace3 ";           hit end at "start" with "lines"\n")
 +	     (receiver lines start num y))
 +	    ((fix:<= (mark-index start) change-end-index)
 +	     (let* ((new (add-line start num y lines))
 +		    (new-start (next-start new)))
 +	       (%trace3 ";           added "new"\n")
 +	       (add-changed (remove-lines-before lines new-start)
 +			    new-start (next-num num) (next-y new) receiver)))
 +	    (else
 +	     (%trace3 ";           beyond change at "start"\n")
 +	     (receiver lines start num y))))
 +
 +    (define (redraw-suffix lines start num y receiver)
 +      (%trace3 ";         redraw-suffix "lines" "start" "num" "y"\n")
 +      (cond (((editor-halt-update? current-editor))
 +	     (%trace3 ";           halt redraw!\n")
 +	     #f)
 +	    ((not (more-lines? lines))
 +	     (%trace3 ";           no more lines\n")
 +	     (receiver lines start num y))
 +	    ((mark= display-end start)
 +	     (%trace3 ";           at end "(car lines)"\n")
 +	     (receiver lines start num y))
 +	    ((mark< display-end start)
 +	     (%trace3 ";           beyond end "(car lines)"\n")
 +	     (receiver lines start num y))
 +	    (else
 +	     (let ((next-y (move-line! (car lines) start num y)))
 +	       (%trace3 ";           suffix "(car lines)"\n")
 +	       (redraw-suffix (next-lines (cdr lines))
 +			      (next-start (car lines))
 +			      (next-num num)
 +			      next-y
 +			      receiver)))))
 +
 +    (define (redraw-end lines start num y)
 +      (%trace3 ";         redraw-end "lines" "start" "num" "y"\n")
 +      (cond (((editor-halt-update? current-editor))
 +	     (%trace3 ";           halt redraw!\n")
 +	     #f)
 +	    ((mark= start display-end)	;common
 +	     (%trace3 ";           clipping "lines"\n")
 +	     (remove-lines lines)
 +	     #t)
 +	    ((and (mark< start display-end)
 +		  (more-lines? lines))
 +	     (steal-line! (car lines) start num y)
 +	     (%trace3 ";           stole line "(car lines)"\n")
 +	     (redraw-end (next-lines (cdr lines))
 +			 (next-start (car lines))
 +			 (next-num num)
 +			 (next-y (car lines))))
 +	    ((mark< start display-end)	;no more lines to steal
 +	     (let ((new (add-line start num y '())))
 +	       (%trace3 ";           added "new"\n")
 +	       (redraw-end lines
 +			   (next-start new)
 +			   (next-num num)
 +			   (next-y new))))
 +	    (else
 +	     ;; (mark< display-end start)
 +	     (%trace3 "; Warning: last line (before "(car lines)")"
 +		    " ended beyond display-end!\n")
 +	     (remove-lines lines))))
 +
 +    ;; If all inks in the drawing go through next-lines,
 +    ;; move-line!, add-line or steal-line!, then all of their extents
 +    ;; can be unioned to get the extent encompassing them all.
 +    (define (union-ink! ink)
 +      (union-extent! (fix-ink-extent ink)))
 +
 +    (define (union-extent! extent)
 +      (if (not drawing-extent)
 +	  (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)
 +      (cond ((null? inks) '())
 +	    ((line-ink? (car inks)) inks)
 +	    ((cursor-ink? (car inks))
 +	     ;; Punt cursor extents.  They often move around at the last
 +	     ;; moment. :-)
 +	     (next-lines (cdr inks)))
 +	    ((fix-ink? (car inks))
 +	     (union-ink! (car inks))
 +	     (next-lines (cdr inks)))
 +	    (else
 +	     (%trace3 "; Warning: bogus "(car inks)" in "drawing"\n")
 +	     (next-lines (cdr inks)))))
 +
 +    (define-integrable next-start line-ink-end)
 +
 +    (define-integrable next-num fix:1+)
 +
 +    (define (next-y line)
 +      (next-y-extent (fix-ink-extent line)))
 +
 +    (define (next-y-extent extent)
 +      (fix:+ (fix-rect-max-y extent) line-spacing))
 +
 +    (define (more-lines? inks)
 +      (and (not (null? inks))
 +	   (line-ink? (car inks))))
 +
 +    (define (remove-lines-before lines start)
 +      ;; Used to clear off (erase!) lines that have been run over by
 +      ;; newly added (stolen) lines.
 +      (%trace3 ";           remove-lines-before "start" "lines"\n")
 +      (cond ((null? lines) '())
 +	    ((mark< (line-ink-start (car lines)) start)
 +	     (remove-line (car lines))
 +	     (remove-lines-before (next-lines (cdr lines)) start))
 +	    (else lines)))
 +
 +    (define (remove-lines lines)
 +      ;; Used to clear off lines that hang on after the end.
 +      (%trace3 ";           remove-lines "lines"\n")
 +      (cond ((null? lines) '())
 +	    (else
 +	     (remove-line (car lines))
 +	     (remove-lines (next-lines (cdr lines))))))
 +
 +    (define (add-line start num y old)
 +      (%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)))
 +	(redraw-line! new 0 y (layout))	;Needs the ink on its drawing.
 +	(union-ink! new)
 +	new))
 +
 +    (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))
 +
 +    (define (move-line! line start num y)
 +      (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))
 +	    (set-line-ink-number! line num))
 +	(if (not (mark= start (line-ink-start line)))
 +	    (warn "mismatched line-ink start:" start line))
 +	(union-ink! line)
 +	(next-y-extent extent)))
 +
 +    (define (remove-line line)
 +      (mark-temporary! (line-ink-start line))
 +      (mark-temporary! (line-ink-end line))
 +      (without-interrupts
 +       (lambda ()
 +	 (clear-cached-pango-layout line)
 +	 (fix-ink-remove! line))))
 +
 +    (define (no-display-changes?)
 +      ;; If the drawing already agrees with the buffer and its current
 +      ;; clipping, return #t.
 +      (let ((old-tick (buffer-drawing-modified-tick drawing)))
 +	(and (fix:= old-tick (group-modified-tick group)) ;already redrawn
 +	     (let ((old-start (buffer-drawing-display-start drawing))
 +		   (old-end (buffer-drawing-display-end drawing)))
 +	       (and (mark= old-start display-start)
 +		    (mark= old-end display-end))))))
 +
 +    (define (layout)
 +      (if pango-layout pango-layout
 +	  (let ((new (gtk-widget-create-pango-layout
 +		      (gtk-screen-toplevel screen))))
 +	    (%trace3 ";             created "new" to lay up new text\n")
 +	    (set! pango-layout new)
 +	    new)))
 +
 +    (main)))
 +
 +(define %trace-redraw? #f)
 +
 +(define (%trace-simplify . args)
 +  (map (lambda (obj)
 +	 (cond ((mark? obj) (mark-index obj))
 +	       ((and (pair? obj) (line-ink? (car obj)))
 +		(list (car obj) '...))
 +	       (else obj)))
 +       args))
 +
 +(define (redraw-line! line x y pango-layout)
 +  ;; Updates LINE by (re)parsing its buffer.  (Re)Images and
 +  ;; (re)lays-out the line to get its dimensions.  (Re)sizes LINE and
 +  ;; (re)positions it at (X, Y).  A separate PANGO-LAYOUT is (re)used
 +  ;; during this process, and any cached layout is cleared.
 +
 +  (define-syntax %trace3
 +    (syntax-rules ()
 +      ((_ ARGS ...) (if %trace-redraw?
 +			(apply outf-error (%trace-simplify ARGS ...))))))
 +
 +  (%trace3 ";\t      redraw-line! "line" from "(line-ink-start line)
 +	   " ("x","y") with "pango-layout"\n")
 +  (layout-line! line pango-layout)
 +  (pango-layout-get-pixel-extents
 +   pango-layout
 +   (lambda (width height)
 +     (without-interrupts
 +      (lambda ()
 +	(clear-cached-pango-layout line)
 +	(%trace3 ";\t        erasing "(fix-ink-extent line)"\n")
 +	(drawing-damage line)
 +	(let ((extent (fix-ink-extent line)))
 +	  (set-fix-rect-size! extent width height)
 +	  (set-fix-rect-position! extent x y))
 +	(%trace3 ";\t        drawing "(fix-ink-extent line)"\n")
 +	(drawing-damage line))))))
 +
 +(define image-buffer-size (* 50 1024))
 +(define image-buffer (string-allocate image-buffer-size))
 +(define-integrable image-results substring-image-results)
 +
 +(define (layout-line! line pango-layout)
 +  (let* ((drawing (fix-ink-drawing line))
 +	 (buffer (buffer-drawing-buffer drawing))
 +	 (group (buffer-group buffer))
 +	 (max-image-size (fix:-1+ image-buffer-size)))
 +    ;; Image the whole paragraph into a max-sized image-buffer.
 +    (set-string-length! image-buffer image-buffer-size)
 +    (group-line-image!
 +     group (line-ink-start-index line) (group-display-end-index group)
 +     image-buffer 0 max-image-size
 +     (buffer-drawing-tab-width drawing)
 +     0 ;; column-offset
 +     (buffer-drawing-char-image-strings drawing)
 +     (lambda (text-index image-index)
 +       (if (fix:= image-index max-image-size)
 +	   (warn ";layout-line!: long paragraph"))
 +       (set-mark-index! (line-ink-end line) text-index)
 +
 +       ;; Run Pango on buffer.
 +       (set-string-length! image-buffer image-index)
 +       (pango-layout-set-text pango-layout image-buffer)))))
 +
 +(define (final-newline? group)
 +  (let ((index (group-display-end-index group)))
 +    (and (not (group-start-index? group index))
 +	 (char=? #\newline (group-left-char group index)))))
 +
 +(define-integrable unchanged?
 +  (named-lambda (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))))))))))
 +
 +(define-integrable %unchanged?
 +  (named-lambda (%unchanged? line change-start change-end)
 +    (or
 +     ;; Common trivial case: no change = unchanged.
 +     (not change-start)
 +
 +     ;; First case: the change region ends before LINE starts.
 +     ;;
 +     ;; LINE and change region may not touch.  The change region may
 +     ;; have removed the newline before LINE, or inserted new text
 +     ;; after the newline, changing LINE's start.
 +     (let ((line-start (line-ink-start-index line)))
 +       (fix:< change-end line-start))
 +
 +     ;; Second case: the change region starts after LINE ends.
 +     ;;
 +     ;; LINE must end with a newline, else a change region touching
 +     ;; the end is adding to the line.  Rather than test for this,
 +     ;; consider touching lines as NOT unchanged.
 +     (let ((line-end (line-ink-end-index line)))
 +       (fix:< line-end change-start)))))
 +
 +(define (update-cursor widget)
 +  (%trace ";\t  update-cursor "widget"\n")
 +  (let ((window (text-widget-buffer-frame widget))
 +	(cursor (text-widget-cursor-ink widget)))
 +    (%trace ";\t    cursor: "cursor"\n")
 +    (redraw-cursor widget (window-point window))
 +
 +    ;; Get cursor appearance right per current mode.  An active
 +    ;; typein window looks selected, else invisible.  An active buffer
 +    ;; looks selected, else visible.
 +    (let ((selected (screen-cursor-window (window-screen window))))
 +      (cond ((eq? window selected)
 +	     (visible! cursor #t))
 +	    ((and (text-widget? widget)
 +		  (not (text-widget-modeline widget)))
 +	     (visible! cursor #f))
 +	    (else ;; text widget
 +	     (visible! cursor #t))))))
 +
 +(define (redraw-cursor widget point)
 +  (%trace ";\t      redraw-cursor at "point" in "widget"\n")
 +  (let* ((window (text-widget-buffer-frame widget))
 +	 (screen (window-screen window))
 +	 (cursor (text-widget-cursor-ink widget))
 +	 (line (find-line-at point widget))
 +	 (group (mark-group point)))
 +    (%trace ";\t\tfound line: "line"\n")
 +
 +    (define-integrable (main)
 +      (cond
 +       ((not cursor)
 +	(%trace ";\t\tno widget for "window"\n")
 +	#t)
 +
 +       ;; When beyond a final newline, position cursor where next line
 +       ;; would start.
 +       ((and line
 +	     (mark= point (group-display-end group))
 +	     (final-newline? group))
 +	(let* ((extent (fix-ink-extent line))
 +	       (line-spacing (gtk-screen-line-spacing screen))
 +	       (y (fix:+ (fix-rect-max-y extent) line-spacing)))
 +	  (%trace ";\t\tredraw-cursor beyond final newline, at 0,"y"\n")
 +	  (set-half-box! 0 y)))
 +
 +       ;; Else at end (or inside) found line.
 +       (line
 +	(let* ((extent (fix-ink-extent line))
 +	       (layout (text-ink-pango-layout line))
 +	       (column (image-column point line)))
 +	  (pango-layout-index-to-pos
 +	   layout column
 +	   (lambda (xG yG widthG heightG)
 +	     (let ((log-x (fix:+ xG (fix-rect-x extent)))
 +		   (log-y (fix:+ yG (fix-rect-y extent))))
 +	       (%trace ";\t\tredraw-cursor: index-to-pos: "column
 +		       " => "log-x","log-y" "widthG"x"heightG" - "layout"\n")
 +	       (set-box! log-x log-y widthG heightG))))))
 +
 +       ;; Else... a half-char box for the empty buffer.
 +       (else
 +	(%trace ";\t\tno line found: half box at 0,0\n")
 +	(set-half-box! 0 0))))
 +
 +    (define (set-half-box! x y)
 +      (let ((half-width (quotient (gtk-screen-char-width screen) 2))
 +	    (line-height (gtk-screen-line-height screen)))
 +	(set-box-ink! cursor x y half-width line-height))
 +      #t)
 +
 +    (define (set-box! x y width height)
 +      (if (fix:< width 5)
 +	  (set-box-ink! cursor x y 5 height)
 +	  (set-box-ink! cursor x y width height))
 +      #t)
 +
 +    (main)))
 +
 +(define (image-column point line)
 +  ;; Returns the index of the character at POINT within LINE's image.
 +  (let* ((drawing (fix-ink-drawing line))
 +	 (buffer (buffer-drawing-buffer drawing))
 +	 (group (buffer-group buffer)))
 +    (group-columns group
 +		   (mark-index (line-ink-start line))
 +		   (mark-index point)
 +		   0 ;; start column
 +		   (buffer-drawing-tab-width drawing)
 +		   (buffer-drawing-char-image-strings drawing))))
 +
 +;;; Buffer Drawings and Buffer Lines
 +
 +(define-class (<buffer-drawing>
 +	       (constructor make-buffer-drawing
 +			    (buffer tab-width char-image-strings)
 +			    no-init))
 +    (<fix-drawing>)
 +
 +  ;; The buffer being drawn, and the "visual" parameters affecting its
 +  ;; rendition.
 +  (buffer define accessor)
 +  (tab-width define accessor)
 +  (char-image-strings define accessor)
 +
 +  ;; If the drawing has not been kept up-to-date with the buffer, set
 +  ;; this flag to #f.  The next redraw will ignore the buffer's change
 +  ;; region and redraw the entire buffer (and set this back to #t).
 +  (valid? define standard initial-value #f)
 +
 +  ;; The buffer's modified-tick, and copies of the buffer's
 +  ;; display-start/end at the time of the last successful redraw.
 +  (modified-tick define standard initial-value #f)
 +  (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 --
 +  ;; in a line-ink's cached-pango-layout slot.
 +  (pango-layout-caches define standard initial-value '()))
 +
 +;; The pango-layout-cache abstraction:
 +(define-integrable make-cache cons)
 +(define-integrable cache-line car)
 +(define-integrable cache-layout cdr)
 +(define-integrable set-cache-line! set-car!)
 +(define (find-cache line drawing)
 +  (or
 +   (assq line (buffer-drawing-pango-layout-caches drawing))
 +   (error "missing from pango-layout cache" line drawing)))
 +
 +(define-class (<line-ink> (constructor ()))
 +    (<text-ink>)
 +
 +  (start define standard initial-value #f)
 +  (end define standard initial-value #f)
 +  (number define standard initial-value #f)
 +  (cached-pango-layout define standard initial-value #f))
 +
 +(define (line-ink-start-index line)
 +  (let ((mark (line-ink-start line)))
 +    (and mark (mark-index mark))))
 +
 +(define (line-ink-end-index line)
 +  (let ((mark (line-ink-end line)))
 +    (and mark (mark-index mark))))
 +
 +(define-method write-instance ((line <line-ink>) port)
 +  (write-instance-helper
 +   "line-ink" line port
 +   (lambda ()
 +     (write-char #\space port)
 +     (write-char #\# port)
 +     (write (line-ink-number line) port)
 +     (write-char #\space port)
 +     (write (line-ink-start-index line) port)
 +     (write-char #\- port)
 +     (write (line-ink-end-index line) port))))
 +
 +(define-method initialize-instance ((ink <line-ink>))
 +  (call-next-method ink)
 +  (set-text-ink-color! ink "black"))
 +
 +(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!
 +
 +  (define (salvage-pango-layout line)
 +    ;; Look for a cached PangoLayout to re-use.  Returns abandoned
 +    ;; layouts (whose line is #f), and layouts for lines that are
 +    ;; off-screen in all of the drawing's widgets.
 +    (let* ((drawing (fix-ink-drawing line))
 +	   (widgets (fix-drawing-widgets drawing)))
 +      (let loop ((caches (buffer-drawing-pango-layout-caches drawing)))
 +	(if (null? caches)
 +	    #f
 +	    (let* ((cache (car caches))
 +		   (old (cache-line cache)))
 +	      (if (or (eq? old #f)
 +		      (every (let ((old-extent (fix-ink-extent old)))
 +			       (lambda (widget)
 +				 (or (gtk-widget-destroyed? widget)
 +				     (not (fix-rect-intersect?
 +					   old-extent
 +					   (fix-layout-view widget))))))
 +			     widgets))
 +		  (let ((layout (cache-layout cache)))
 +		    (if old (set-line-ink-cached-pango-layout! old #f))
 +		    (set-cache-line! cache line)
 +		    (set-line-ink-cached-pango-layout! line layout)
 +		    layout)
 +		  (loop (cdr caches))))))))
 +
 +  (define (cache-pango-layout line)
 +    (let* ((drawing (fix-ink-drawing line))
 +	   (widget (car (fix-drawing-widgets drawing)))
 +	   (layout (gtk-widget-create-pango-layout widget))
 +	   (new (make-cache line layout)))
 +      (set-buffer-drawing-pango-layout-caches!
 +       drawing (cons new (buffer-drawing-pango-layout-caches drawing)))
 +      (set-line-ink-cached-pango-layout! line layout)
 +      layout))
 +
 +  ;; Do not (call-next-method ink).  There is no <text-ink> method.
 +  (if (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))))
 +      (begin
 +	(outf-error ";text-ink-pango-layout: punted "ink"\n")
 +	#f)))
 +
 +(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))
 +	       (cache (find-cache line drawing)))
 +	  (set-cache-line! cache #f)
 +	  (set-line-ink-cached-pango-layout! line #f)))))
 +
 +(define-class (<cursor-ink> (constructor ()))
 +    (<box-ink>)
 +
 +  ;; #t if the cursor should be drawn.
 +  (visible? define standard initial-value #t)
 +
 +  ;; A list of one <fix-layout>.  Used to blink this ink "on"
 +  ;; (restore its ink-widgets list) withOUT consing.
 +  (widget-list define standard))
 +
 +(define (guarantee-cursor-ink object)
 +  (if (cursor-ink? object) object
 +      (error:wrong-type-argument object "<cursor-ink>" 'guarantee-cursor-ink)))
 +
 +(define (cursor-ink-widget cursor)
 +  (car (cursor-ink-widget-list cursor)))
 +
 +(define (visible! cursor visible?)
 +  ;; Atomically sets cursor-ink-visible? and fix-ink-widgets.
 +  (without-interrupts
 +   (lambda ()
 +     (if visible?
 +	 (if (not (cursor-ink-visible? cursor))
 +	     (begin
 +	       (set-fix-ink-widgets! cursor (cursor-ink-widget-list cursor))
 +	       (set-cursor-ink-visible?! cursor #t)))
 +	 (if (cursor-ink-visible? cursor)
 +	     (begin
 +	       (set-cursor-ink-visible?! cursor #f)
 +	       (set-fix-ink-widgets! cursor '())))))))
 +
 +(define (blink! screen cursor)
 +  ;; Atomically sets CURSOR up to blink.  CURSOR may be #f, in which
 +  ;; case blinking will pause.
 +  (without-interrupts
 +   (lambda ()
 +     (let ((old (gtk-screen-blinking screen)))
 +       (if cursor
 +	   (begin
 +	     (if (not (eq? cursor old))
 +		 (set-gtk-screen-blinking! screen cursor))
 +	     (if (not old)
 +		 (signal-thread-event (gtk-screen-blinker screen)
 +				      (lambda () #f))))
 +	   (if old (set-gtk-screen-blinking! screen #f)))))))
 +
 +;;; Buffer Status
 +;;
 +;; The (re)layout process starts at the top of a changed buffer region
 +;; and works its way to the bottom, scanning for line separators,
 +;; "imaging" the content (e.g. replacing #\null with "^@"), feeding
 +;; the translation (with style info!) to Pango for layup, and stacking
 +;; the laid-up lines.  Reading a large file may produce a change
 +;; region containing hundreds of thousands of lines, taking a
 +;; non-interactive amount of time to layout for display.  In spite of
 +;; this, the user may want to type ahead, e.g. go to the end of the
 +;; buffer and start typing in a new line.
 +;;
 +;; To keep redisplay interactive in such a case, a thread might be
 +;; spawned to do the layout.  The editor thread can then continue with
 +;; event (keypress) processing.  The new thread works on the buffer
 +;; (re)drawing, and shows its progress by animating a progress/status
 +;; indicator in the drawing.  The indicator might report the number of
 +;; bytes remaining to be (re)parsed, with newly re-parsed lines
 +;; appearing above it.  When the point is at buffer indices that are
 +;; not (yet) laid out, the cursor appears after the progress
 +;; indicator.  Any typeahead will be displayed... eventually.
 +
 +(define-class (<buffer-status> (constructor add-buffer-status (drawing) 1))
 +    (<box-ink>)
 +  (text-ink define standard))
 +
 +(define %trace? #f)
 +
 +(define-syntax %trace
 +  (syntax-rules ()
 +    ((_ ARGS ...) (if %trace? (outf-error ARGS ...)))))
 +
 +(define %trace2? #f)
 +
 +(define-syntax %trace2
 +  (syntax-rules ()
 +    ((_ ARGS ...) (if %trace2? (outf-error ARGS ...)))))
 +
 +(initialize-package!)
diff --cc src/gtk/cairo.scm
index 212cfa353,45220b12d..7421880dd
--- a/src/gtk/cairo.scm
+++ b/src/gtk/cairo.scm
@@@ -57,4 -57,15 +57,15 @@@ USA
  	(let ((msg (C-call "cairo_status_to_string"
  			   (make-alien '(* (const char)))
  			   cairo)))
- 	  (error msg cairo)))))
+ 	  (error msg cairo)))))
+ 
+ (define-integrable (cairo-clip-extents cairo receiver)
+   (let ((doubles (malloc (fix:* 4 (C-sizeof "double")) 'double)))
+     (let ((y1 (C-array-loc doubles "double" 1))
+ 	  (x2 (C-array-loc doubles "double" 2))
+ 	  (y2 (C-array-loc doubles "double" 3)))
+       (C-call "cairo_clip_extents" cairo doubles y1 x2 y2)
+       (let ((x1. (C-> doubles "double")) (y1. (C-> y1 "double"))
+ 	    (x2. (C-> x2 "double")) (y2. (C-> y2 "double")))
+ 	(free doubles)
 -	(receiver x1. y1. x2. y2.)))))
++	(receiver x1. y1. x2. y2.)))))
diff --cc src/gtk/gtk-widget.scm
index 8604f62f7,3cf96294c..844e6dc83
--- a/src/gtk/gtk-widget.scm
+++ b/src/gtk/gtk-widget.scm
@@@ -514,57 -540,63 +540,70 @@@ USA
    (named-lambda (gtk-check-button-toggled-callback button)
       (callback button)))
  
- ;;; GtkVBox
+ ;;; GtkGrids
  
- (define-class (<gtk-vbox> (constructor () (homogeneous? spacing)))
+ (define-class (<gtk-grid> (constructor gtk-grid-new ()))
      (<gtk-container>))
  
- (define-guarantee gtk-vbox "a <gtk-vbox>")
+ (define-guarantee gtk-grid "a <gtk-grid>")
  
- (define-method initialize-instance ((vbox <gtk-vbox>) homogeneous? spacing)
-   (call-next-method vbox)
-   (let ((alien (gobject-alien vbox)))
-     (C-call "gtk_vbox_new" alien (if homogeneous? 1 0) spacing)
-     (error-if-null alien "Could not create:" vbox)
+ (define-method initialize-instance ((grid <gtk-grid>))
+   (call-next-method grid)
+   (let ((alien (gobject-alien grid)))
+     (C-call "gtk_grid_new" alien)
+     (error-if-null alien "Could not create:" grid)
      (C-call "g_object_ref_sink" alien alien))
-   (set-gtk-widget-destroy-callback! vbox))
- 
- (define (gtk-vbox-new homogeneous? spacing)
-   (guarantee-boolean homogeneous? 'gtk-vbox-new)
-   (guarantee-non-negative-fixnum spacing 'gtk-vbox-new)
-   (make-gtk-vbox homogeneous? spacing))
- 
- (define-integrable-operator (guarantee-boolean object operator)
-   (if (not (or (eq? object #t) (eq? object #f)))
-       (error:wrong-type-argument object "#t or #f" operator)))
- 
- (define-class (<gtk-hbox> (constructor () (homogeneous? spacing)))
-     (<gtk-container>))
- 
- (define-guarantee gtk-hbox "a <gtk-hbox>")
- 
- (define-method initialize-instance ((hbox <gtk-hbox>) homogeneous? spacing)
-   (call-next-method hbox)
-   (let ((alien (gobject-alien hbox)))
-     (C-call "gtk_hbox_new" alien (if homogeneous? 1 0) spacing)
-     (error-if-null alien "Could not create:" hbox)
-     (C-call "g_object_ref_sink" alien alien))
-   (set-gtk-widget-destroy-callback! hbox))
- 
- (define (gtk-hbox-new homogeneous? spacing)
-   (guarantee-boolean homogeneous? 'gtk-hbox-new)
-   (guarantee-non-negative-fixnum spacing 'gtk-hbox-new)
-   (make-gtk-hbox homogeneous? spacing))
- 
- (define (gtk-box-pack-start box child expand? fill? padding)
-   (container-add! box child)
-   (C-call "gtk_box_pack_start" (gobject-alien box) (gobject-alien child)
- 	  (if expand? 1 0) (if fill? 1 0) padding))
- 
- (define (gtk-box-pack-end box child expand? fill? padding)
-   (container-add! box child)
-   (C-call "gtk_box_pack_end" (gobject-alien box) (gobject-alien child)
- 	  (if expand? 1 0) (if fill? 1 0) padding))
+   (set-gtk-widget-destroy-callback! grid))
+ 
+ (define (gtk-grid-set-row-homogeneous grid homogeneous?)
+   (guarantee-gtk-grid grid 'gtk-grid-set-row-homogeneous)
+   (C-call "gtk_grid_set_row_homogeneous" (gobject-alien grid)
+ 	  (if homogeneous? 1 0)))
+ 
+ (define (gtk-grid-set-column-homogeneous grid homogeneous?)
+   (guarantee-gtk-grid grid 'gtk-grid-set-column-homogeneous)
+   (C-call "gtk_grid_set_column_homogeneous" (gobject-alien grid)
+ 	  (if homogeneous? 1 0)))
+ 
+ (define (gtk-grid-set-row-spacing grid spacing)
+   (guarantee-gtk-grid grid 'gtk-grid-set-row-spacing)
+   (guarantee-non-negative-fixnum spacing 'gtk-grid-set-row-spacing)
+   (C-call "gtk_grid_set_row_spacing" (gobject-alien grid) spacing))
+ 
+ (define (gtk-grid-set-column-spacing grid spacing)
+   (guarantee-gtk-grid grid 'gtk-grid-set-column-spacing)
+   (guarantee-non-negative-fixnum spacing 'gtk-grid-set-column-spacing)
+   (C-call "gtk_grid_set_column_spacing" (gobject-alien grid) spacing))
+ 
+ (define (gtk-grid-attach grid widget left top width height)
+   (guarantee-gtk-grid grid 'gtk-grid-attach)
+   (guarantee-gtk-widget widget 'gtk-grid-attach)
+   (guarantee-fixnum left 'gtk-grid-attach)
+   (guarantee-fixnum top 'gtk-grid-attach)
+   (guarantee-fixnum width 'gtk-grid-attach)
+   (guarantee-fixnum height 'gtk-grid-attach)
+   (container-add! grid widget)
+   (C-call "gtk_grid_attach" (gobject-alien grid) (gobject-alien widget)
+ 	  left top width height))
+ 
++(define (gtk-orientable-get-orientation orientable)
++  (let ((o (C-call "gtk_orientable_get_orientation"
++		   (gobject-alien orientable))))
++    (cond ((= o (C-enum "GTK_ORIENTATION_VERTICAL")) 'VERTICAL)
++	  ((= o (C-enum "GTK_ORIENTATION_HORIZONTAL")) 'HORIZONTAL)
++	  (else (error "Invalid orientation:" o)))))
++
+ (define (gtk-orientable-set-orientation orientable orientation)
+   (C-call "gtk_orientable_set_orientation" (gobject-alien orientable)
+ 	  (case orientation
+ 	    ((VERTICAL) (C-enum "GTK_ORIENTATION_VERTICAL"))
+ 	    ((HORIZONTAL) (C-enum "GTK_ORIENTATION_HORIZONTAL"))
+ 	    (else (error:wrong-type-argument
+ 		   orientation
+ 		   "an orientation (vertical or horizontal)"
+ 		   'gtk-orientable-set-orientation)))))
+ 
+ ;;; GtkFrames
  
  (define-class (<gtk-frame> (constructor () (label))) (<gtk-container>))
  
diff --cc src/gtk/gtk.pkg
index 13ccbcd43,3a3dc5bc6..85d9278cf
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@@ -194,9 -195,13 +195,14 @@@ USA
  	  gtk-check-button-new
  	  gtk-check-button-get-active gtk-check-button-set-active
  	  set-gtk-check-button-toggled-callback!
- 	  <gtk-vbox> gtk-vbox? guarantee-gtk-vbox gtk-vbox-new
- 	  <gtk-hbox> gtk-hbox? guarantee-gtk-hbox gtk-hbox-new
- 	  gtk-box-pack-start gtk-box-pack-end
+ 	  <gtk-grid> gtk-grid? guarantee-gtk-grid gtk-grid-new
+ 	  gtk-grid-set-row-spacing
+ 	  gtk-grid-set-column-spacing
+ 	  gtk-grid-set-row-homogeneous
+ 	  gtk-grid-set-column-homogeneous
+ 	  gtk-grid-attach
++	  gtk-orientable-get-orientation
+ 	  gtk-orientable-set-orientation
  	  <gtk-frame> gtk-frame? guarantee-gtk-frame gtk-frame-new
  	  gtk-frame-set-shadow-type
  	  <gtk-scrolled-window> gtk-scrolled-window?
diff --cc src/gtk/scm-widget.scm
index 683961d0f,981e21048..21c684315
--- a/src/gtk/scm-widget.scm
+++ b/src/gtk/scm-widget.scm
@@@ -40,4 -40,20 +40,20 @@@ USA
  (define (set-scm-widget-set-scroll-adjustments-callback! widget callback)
    (guarantee-scm-widget widget 'set-scm-widget-set-scroll-adjustments-callback!)
    (guarantee-procedure-of-arity callback 3 'set-scm-widget-set-scroll-adjustments-callback!)
-   (g-signal-connect widget (C-callback "set_scroll_adjustments") callback))
+   (g-signal-connect widget (C-callback "set_scroll_adjustments") callback))
+ 
+ (define (set-scm-widget-minimum-size! widget width height)
+   (guarantee-scm-widget widget 'set-scm-widget-minimum-size!)
+   (guarantee-non-negative-fixnum width 'set-scm-widget-minimum-size!)
+   (guarantee-non-negative-fixnum height 'set-scm-widget-minimum-size!)
+   (let ((a (gobject-alien widget)))
+     (C->= a "ScmWidget minimum_width" width)
+     (C->= a "ScmWidget minimum_height" height)))
+ 
+ (define (set-scm-widget-natural-size! widget width height)
+   (guarantee-scm-widget widget 'set-scm-widget-natural-size!)
+   (guarantee-non-negative-fixnum width 'set-scm-widget-natural-size!)
+   (guarantee-non-negative-fixnum height 'set-scm-widget-natural-size!)
+   (let ((a (gobject-alien widget)))
+     (C->= a "ScmWidget natural_width" width)
 -    (C->= a "ScmWidget natural_height" height)))
++    (C->= a "ScmWidget natural_height" height)))