From fd9f0d054aadcf8206cfc1dddc08fb062ba20c4c Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 28 May 2014 16:04:27 -0700
Subject: [PATCH] cairo: Add a cairo graphics device type.  And many fixes...

Use the cairo graphics device in the planetarium's mit-snapshot.scm
script to draw the tellurion to a PNG image file without loading Gtk.

Fix the linker commandline(!) and cairo-line-to(!!).  Add cairo-save/
restore around polygon fill options, just because all the rest do.
Punt gtk-graphics/make since a window-less gtk output device is no
longer necessary for planetarium/mit-snapshot.scm.  Clean up some free
variables, other CREF complains, unknown texinfo references, etc.

Rename add-gc-cleanups add-GLIB-cleanups because they are run by the
glib-thread.  Replaced punt-gc-cleanup with execute-glib-cleanup
because you probably should not use the former, rather the latter.
---
 src/cairo/Makefile.in            |   2 +-
 src/cairo/cairo-graphics.scm     | 315 +++++++++++++++++++++++++++++++
 src/cairo/cairo.pkg              |  17 +-
 src/cairo/cairo.scm              |  25 ++-
 src/cairo/compile.scm            |   3 +
 src/gl/check.scm                 |   2 +-
 src/gl/gl-glx.scm                |  62 +-----
 src/gl/gl.pkg                    |  12 +-
 src/glib/gio.scm                 |  36 ++--
 src/glib/glib-thread.scm         |   2 +-
 src/glib/glib.pkg                |   5 +-
 src/glib/glib.scm                |  55 +++++-
 src/glib/glib.texinfo            |   6 +-
 src/glib/glibio.c                |  10 +-
 src/glib/gobject.scm             |  93 ++-------
 src/gtk/check-doc.scm            |   4 +-
 src/gtk/fix-layout.scm           |   4 +-
 src/gtk/gdk.scm                  |  17 +-
 src/gtk/gtk-check.scm            |   2 +-
 src/gtk/gtk-graphics.scm         |   6 -
 src/gtk/gtk-widget.scm           |   2 +-
 src/gtk/gtk.pkg                  |   5 +-
 src/gtk/gtk.texinfo              |  78 +-------
 src/pango/pango.scm              |  64 +++----
 src/planetarium/Makefile         |  39 ++++
 src/planetarium/geometry.scm     |  44 ++++-
 src/planetarium/mit-3d.pkg       |   1 +
 src/planetarium/mit-cairo.scm    |  59 ++++++
 src/planetarium/mit-compile.scm  |   3 +-
 src/planetarium/mit-snapshot.scm |  35 +---
 src/planetarium/mit.pkg          |  17 +-
 src/planetarium/tellurion.scm    |  58 ++----
 32 files changed, 689 insertions(+), 394 deletions(-)
 create mode 100644 src/cairo/cairo-graphics.scm
 create mode 100644 src/planetarium/Makefile
 create mode 100644 src/planetarium/mit-cairo.scm

diff --git a/src/cairo/Makefile.in b/src/cairo/Makefile.in
index b41e36401..c4daa61ac 100644
--- a/src/cairo/Makefile.in
+++ b/src/cairo/Makefile.in
@@ -88,7 +88,7 @@ tags:
 
 cairo-shim.so: cairo-shim.o
 	echo "(link-shim)" | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
-			`pkg-config --libs cairo`
+			`pkg-config --libs pangocairo`
 
 cairo-shim.o: cairo-shim.c
 	echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
diff --git a/src/cairo/cairo-graphics.scm b/src/cairo/cairo-graphics.scm
new file mode 100644
index 000000000..f812adcd1
--- /dev/null
+++ b/src/cairo/cairo-graphics.scm
@@ -0,0 +1,315 @@
+#| -*-Scheme-*-
+
+Copyright (C) 2014  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.
+
+|#
+
+;;;; Scheme Graphics Operations to a Cairo Image Surface.
+;;; package: (cairo graphics)
+
+(define-structure (cairo-graphics
+		   (constructor %make-cairo-graphics
+				(width height surface context)))
+
+  ;; Cairo Surface -- |cairo_surface_t| alien.
+  surface width height
+
+  ;; Cairo Context -- |cairo_t| alien.
+  context
+
+  ;; Bounds to which context is clipped, scaled, translated...
+  (limits '(-1. -1. 1. 1.))
+  (scale 1.)
+
+  (fgcolor #f)
+  (fgcolor-name #f)
+  (bgcolor #f)
+  (bgcolor-name #f))
+
+(define (make-cairo-graphics width height)
+  (let ((factor (->flonum (/ (min (-1+ width) (-1+ height)) 2))))
+    (if (not (flo:positive? factor))
+	(error "Invalid width x height:" width height))
+    (let* ((surface (cairo-image-surface-create width height))
+	   (cr (cairo-create surface))
+	   (graphics (%make-cairo-graphics width height surface cr)))
+      (cairo-save cr)
+      (cairo-scale cr factor (flo:negate factor))
+      (set-cairo-graphics-scale! graphics factor)
+      (cairo-set-line-width cr (flo:/ 1.0 factor))
+      (cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
+				  (cairo-matrix k 0. 0.
+						0. (flo:negate k) 0.)))
+      (cairo-translate cr 1.0 -1.0)
+      (let ((black (->color "black" 'make-cairo-graphics))
+	    (white (->color "white" 'make-cairo-graphics)))
+	(cairo-set-source-color cr white)
+	(cairo-paint cr)
+	(cairo-set-source-color cr black)
+	(set-cairo-graphics-bgcolor-name! graphics "white")
+	(set-cairo-graphics-bgcolor! graphics white)
+	(set-cairo-graphics-fgcolor-name! graphics "black")
+	(set-cairo-graphics-fgcolor! graphics black))
+      graphics)))
+
+(define (cairo-graphics/available?) #t)
+
+(define (cairo-graphics/open make-device #!optional width height)
+  (let ((width (if (default-object? width) 512 width))
+	(height (if (default-object? height) 384 height)))
+    (guarantee-positive-fixnum width 'cairo-graphics/open)
+    (guarantee-positive-fixnum height 'cairo-graphics/open)
+    (make-device (make-cairo-graphics width height))))
+
+(define (cairo-graphics/close device)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((surface (cairo-graphics-surface graphics)))
+      (if surface
+	  (let ((cr (cairo-graphics-context graphics)))
+	    (cairo-destroy cr)
+	    (set-cairo-graphics-context! graphics #f)
+	    (cairo-surface-destroy surface)
+	    (set-cairo-graphics-surface! graphics #f))))))
+
+(define (cairo-graphics/device-coordinate-limits device)
+  (let ((graphics (graphics-device/descriptor device)))
+    (values 0 (cairo-graphics-height graphics)
+	    (cairo-graphics-width graphics) 0)))
+
+(define (cairo-graphics/coordinate-limits device)
+  (apply values (cairo-graphics-limits (graphics-device/descriptor device))))
+
+(define (cairo-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics)))
+      (if (zero? (- x-right x-left)) (error "Zero width coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
+      (if (zero? (- y-bottom y-top)) (error "Zero height coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
+      (cairo-restore cr)	;back to device coords.
+      (cairo-save cr)
+      (let ((x-factor (->flonum (/ (-1+ (cairo-graphics-width graphics))
+				   (- x-right x-left))))
+	    (y-factor (->flonum (/ (-1+ (cairo-graphics-height graphics))
+				   (- y-bottom y-top)))))
+	(cairo-scale cr x-factor y-factor)
+	(let ((factor (flo:min (flo:abs x-factor) (flo:abs y-factor))))
+	  (set-cairo-graphics-scale! graphics factor)
+	  (cairo-set-line-width cr (flo:/ 1.0 factor))
+	  (cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
+				      (cairo-matrix k 0. 0.
+						    0. (flo:negate k) 0.)))))
+      (cairo-translate cr (- x-left) (- y-top))
+      (let ((fgcolor (cairo-graphics-fgcolor graphics)))
+	(cairo-set-source-color cr fgcolor)))
+    (set-cairo-graphics-limits! graphics (list x-left y-bottom x-right y-top))))
+
+(define (cairo-graphics/clear device)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (bgcolor (cairo-graphics-bgcolor graphics))
+	  (bgcolor-name (cairo-graphics-bgcolor-name graphics)))
+      (set-cairo-graphics-fgcolor! graphics bgcolor)
+      (set-cairo-graphics-fgcolor-name! graphics bgcolor-name)
+      (cairo-set-source-color cr bgcolor)
+      (cairo-reset-clip cr)
+      (cairo-paint cr))))
+
+(define (cairo-graphics/draw-point device x y)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (x (->flonum x))
+	  (y (->flonum y))
+	  (radius (/ 3.0 (cairo-graphics-scale device))))
+      (cairo-arc cr x y radius 0. 2pi)
+      (cairo-stroke cr))))
+
+(define (cairo-graphics/draw-line device x-start y-start x-end y-end)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (x (->flonum x-start))
+	  (y (->flonum y-start)))
+      (let ((dx (flo:- (->flonum x-end) x))
+	    (dy (flo:- (->flonum y-end) y)))
+	(cairo-move-to cr x y)
+	(cairo-rel-line-to cr dx dy)
+	(cairo-stroke cr)))))
+
+(define (cairo-graphics/draw-text device x y string)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (x (->flonum x))
+	  (y (->flonum y)))
+      (cairo-move-to cr x y)
+      (cairo-show-text cr string))))
+
+(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
+
+(define (cairo-graphics/draw-circle device x y radius)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (x (->flonum x))
+	  (y (->flonum y))
+	  (radius (->flonum radius)))
+      (cairo-arc cr x y radius 0. 2pi)
+      (cairo-stroke cr))))
+
+(define (cairo-graphics/move-cursor device x y)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (x (->flonum x))
+	  (y (->flonum y)))
+      (cairo-move-to cr x y))))
+
+(define (cairo-graphics/drag-cursor device x y)
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (x (->flonum x))
+	  (y (->flonum y)))
+      (cairo-line-to cr x y)
+      (cairo-stroke cr))))
+
+(define (cairo-graphics/set-drawing-mode device mode)
+  (let ((operator
+	 (case mode
+	   ((0) 'CLEAR)			;GXclear         0
+	   ((1) 'IN)			;GXand           src AND dst
+	   ((2) 'OUT)			;GXandReverse    src AND NOT dst
+	   ((3) 'SOURCE)		;GXcopy          src
+	   ((4) 'DEST-OUT)		;GXandInverted   NOT src AND dst
+	   ((5) 'DEST)			;GXnoop          dst
+	   ((6) 'XOR)			;GXxor           src XOR dst
+	   ((7) 'OVER)			;GXor            src OR dst
+	   ((8) (warn "unimplemented:" '|GXnor|) #f)           ;GXnor           NOT src AND NOT dst
+	   ((9) (warn "unimplemented:" '|GXequiv|) #f)         ;GXequiv         NOT src XOR dst
+	   ((10) (warn "unimplemented:" '|GXinvert|) #f)       ;GXinvert        NOT dst
+	   ((11) (warn "unimplemented:" '|GXorReverse|) #f)    ;GXorReverse     src OR NOT dst
+	   ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted  NOT src
+	   ((13) (warn "unimplemented:" '|GXorInverted|) #f)   ;GXorInverted    NOT src OR dst
+	   ((14) (warn "unimplemented:" '|GXnand|) #f)         ;GXnand          NOT src OR NOT dst
+	   ((15) 'SOURCE)		;GXset           1
+	   (else (error:wrong-type-argument mode "a drawing mode"
+					    'cairo-graphics/set-drawing-mode)))))
+    (if operator
+	(cairo-set-operator
+	 (cairo-graphics-context (graphics-device/descriptor device))
+	 operator))))
+
+(define (cairo-graphics/set-line-style device style)
+  (let ((graphics (graphics-device/descriptor device))
+	(dashes
+	 (case style
+	   ((0) '())
+	   ((1) '(8.))
+	   ((2) '(1.))
+	   ((3) '(13. 1. 1. 1.))
+	   ((4) '(11. 1. 1. 1. 1. 1.))
+	   ((5) '(11. 5.))
+	   ((6) '(12. 1. 2. 1))
+	   ((7) '( 9. 1. 2. 1. 2. 1.))
+	   (else (error:wrong-type-argument style "a line style"
+					    'cairo-graphics/set-line-style)))))
+    (let ((cr (cairo-graphics-context graphics))
+	  (factor (flo:/ 16. (cairo-graphics-scale graphics))))
+      (cairo-set-dash cr (map (lambda (len) (flo:* len factor)) dashes)))))
+
+(define (cairo-graphics/fill-polygon-list device points)
+  ;; POINTS should be a list of flo:vectors each with a length greater than 1.
+  (let ((graphics (graphics-device/descriptor device)))
+    (let ((cr (cairo-graphics-context graphics))
+	  (p (car points)))
+      (define-integrable (x p) (flo:vector-ref p 0))
+      (define-integrable (y p) (flo:vector-ref p 1))
+      (cairo-move-to cr (x p) (y p))
+      (for-each (lambda (p)
+		  (cairo-line-to cr (x p) (y p)))
+		(cdr points))
+      (cairo-close-path cr)
+      (cairo-fill cr))))
+
+(define (cairo-graphics/flush device)
+  (cairo-surface-flush
+   (or (cairo-graphics-surface
+	(graphics-device/descriptor device))
+       (error "Cairo graphics device closed:" device))))
+
+(define (cairo-graphics/write-to-png device filename)
+  (cairo-surface-write-to-png
+   (or (cairo-graphics-surface
+	(graphics-device/descriptor device))
+       (error "Cairo graphics device closed:" device))
+   (->namestring filename)))
+
+(define (cairo-graphics/destroy device)
+  (cairo-surface-destroy (cairo-graphics-surface
+			  (graphics-device/descriptor device))))
+
+(define (cairo-graphics/set-background-color device name)
+  (let ((graphics (graphics-device/descriptor device)))
+    (if (not (string=? name (cairo-graphics-bgcolor-name graphics)))
+	(let ((new (->color name 'cairo-graphics/set-background-color)))
+	  (set-cairo-graphics-bgcolor! graphics new)
+	  (set-cairo-graphics-bgcolor-name! graphics name)))))
+
+(define (cairo-graphics/set-foreground-color device name)
+  (let ((graphics (graphics-device/descriptor device)))
+    (if (not (string=? name (cairo-graphics-fgcolor-name graphics)))
+	(let ((new (->color name 'cairo-graphics/set-foreground-color)))
+	  (set-cairo-graphics-fgcolor! graphics new)
+	  (set-cairo-graphics-fgcolor-name! graphics name)
+	  (cairo-set-source-color (cairo-graphics-context graphics) new)))))
+
+(define (cairo-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
+  (let ((cr (cairo-graphics-context (graphics-device/descriptor device)))
+	(x (->flonum x-left))
+	(y (->flonum y-top)))
+    (let ((width (flo:- (->flonum x-right) x))
+	  (height (flo:- (->flonum y-bottom) y)))
+      (cairo-rectangle cr x y width height)
+      (cairo-clip cr))))
+
+(define (cairo-graphics/reset-clip-rectangle device)
+  (cairo-reset-clip (cairo-graphics-context
+		     (graphics-device/descriptor device))))
+
+(define cairo-graphics-device-type)
+
+(define (initialize-package!)
+  (set! cairo-graphics-device-type
+	(make-graphics-device-type
+	 'CAIRO
+	 `((available? ,cairo-graphics/available?)
+	   (open ,cairo-graphics/open)
+	   (clear ,cairo-graphics/clear)
+	   (close ,cairo-graphics/close)
+	   (coordinate-limits ,cairo-graphics/coordinate-limits)
+	   (device-coordinate-limits ,cairo-graphics/device-coordinate-limits)
+	   (move-cursor ,cairo-graphics/move-cursor)
+	   (drag-cursor ,cairo-graphics/drag-cursor)
+	   (draw-line ,cairo-graphics/draw-line)
+	   (draw-point ,cairo-graphics/draw-point)
+	   (draw-text ,cairo-graphics/draw-text)
+	   (draw-circle ,cairo-graphics/draw-circle)
+	   (flush ,cairo-graphics/flush)
+	   (reset-clip-rectangle ,cairo-graphics/reset-clip-rectangle)
+	   (set-clip-rectangle ,cairo-graphics/set-clip-rectangle)
+	   (set-coordinate-limits ,cairo-graphics/set-coordinate-limits)
+	   (set-drawing-mode ,cairo-graphics/set-drawing-mode)
+	   (set-line-style ,cairo-graphics/set-line-style)))))
+
+(initialize-package!)
\ No newline at end of file
diff --git a/src/cairo/cairo.pkg b/src/cairo/cairo.pkg
index 794ed1e81..6ecd686f3 100644
--- a/src/cairo/cairo.pkg
+++ b/src/cairo/cairo.pkg
@@ -70,4 +70,19 @@ USA.
 	  cairo-fill cairo-fill-preserve
 	  cairo-stroke cairo-stroke-preserve
 	  cairo-set-font-matrix
-	  cairo-matrix))
\ No newline at end of file
+	  cairo-matrix))
+
+(define-package (cairo graphics)
+  (parent (cairo))
+  (files "cairo-graphics")
+  (export ()
+	  cairo-graphics/set-background-color
+	  cairo-graphics/set-foreground-color
+	  cairo-graphics/draw-line
+	  cairo-graphics/draw-text
+	  cairo-graphics/draw-circle
+	  cairo-graphics/fill-polygon-list
+	  cairo-graphics/clear
+	  cairo-graphics/flush
+	  cairo-graphics/write-to-png
+	  cairo-graphics/destroy))
\ No newline at end of file
diff --git a/src/cairo/cairo.scm b/src/cairo/cairo.scm
index b1909ffd6..3a9e9d1bd 100644
--- a/src/cairo/cairo.scm
+++ b/src/cairo/cairo.scm
@@ -29,7 +29,7 @@ USA.
 (define (cairo-image-surface-create width height)
   (let ((surface (make-alien '|cairo_surface_t|))
 	(copy (make-alien '|cairo_surface_t|)))
-    (add-gc-cleanup surface (make-cairo-surface-cleanup copy))
+    (add-glib-cleanup surface (make-cairo-surface-cleanup copy))
     (C-call "cairo_image_surface_create" copy
 	    (C-enum "CAIRO_FORMAT_RGB24") width height)
     (copy-alien-address! surface copy)
@@ -50,9 +50,8 @@ USA.
    (lambda ()
      (if (not (alien-null? surface))
 	 (begin
-	   (C-call "cairo_surface_destroy" surface)
-	   (alien-null! surface)))))
-  (punt-gc-cleanup surface))
+	   (execute-glib-cleanup surface)
+	   (alien-null! surface))))))
 
 (define (check-cairo-surface-status surface)
   (let ((status (C-call "cairo_surface_status" surface)))
@@ -79,7 +78,7 @@ USA.
 (define (cairo-pattern-create-linear x1 y1 x2 y2)
   (let ((pattern (make-alien '|cairo_pattern_t|))
 	(copy (make-alien '|cairo_pattern_t|)))
-    (add-gc-cleanup pattern (make-cairo-pattern-cleanup copy))
+    (add-glib-cleanup pattern (make-cairo-pattern-cleanup copy))
     (C-call "cairo_pattern_create_linear" copy
 	    (->flonum x1) (->flonum y1) (->flonum x2) (->flonum y2))
     (copy-alien-address! pattern copy)
@@ -89,7 +88,7 @@ USA.
 (define (cairo-pattern-create-radial cx0 cy0 radius0 cx1 cy1 radius1)
   (let ((pattern (make-alien '|cairo_pattern_t|))
 	(copy (make-alien '|cairo_pattern_t|)))
-    (add-gc-cleanup pattern (make-cairo-pattern-cleanup copy))
+    (add-glib-cleanup pattern (make-cairo-pattern-cleanup copy))
     (C-call "cairo_pattern_create_radial" copy
 	    (->flonum cx0) (->flonum cy0) (->flonum radius0)
 	    (->flonum cx1) (->flonum cy1) (->flonum radius1))
@@ -111,9 +110,8 @@ USA.
    (lambda ()
      (if (not (alien-null? pattern))
 	 (begin
-	   (C-call "cairo_pattern_destroy" pattern)
-	   (alien-null! pattern)))))
-  (punt-gc-cleanup pattern))
+	   (execute-glib-cleanup pattern)
+	   (alien-null! pattern))))))
 
 (define (check-cairo-pattern-status pattern)
   (let ((status (C-call "cairo_pattern_status" pattern)))
@@ -145,7 +143,7 @@ USA.
   (guarantee-cairo-surface surface 'cairo-create)
   (let ((cairo (make-alien '|cairo_t|))
 	(copy (make-alien '|cairo_t|)))
-    (add-gc-cleanup cairo (make-cairo-cleanup copy))
+    (add-glib-cleanup cairo (make-cairo-cleanup copy))
     (C-call "cairo_create" copy surface)
     (copy-alien-address! cairo copy)
     (check-cairo-status cairo)
@@ -165,9 +163,8 @@ USA.
    (lambda ()
      (if (not (alien-null? cairo))
 	 (begin
-	   (C-call "cairo_destroy" cairo)
-	   (alien-null! cairo)))))
-  (punt-gc-cleanup cairo))
+	   (execute-glib-cleanup cairo)
+	   (alien-null! cairo))))))
 
 (define (check-cairo-status cairo)
   (let ((status (C-call "cairo_status" cairo)))
@@ -305,7 +302,7 @@ USA.
   (guarantee-cairo cairo 'cairo-line-to)
   (let ((x (->flonum x))
 	(y (->flonum y)))
-    (C-call "cairo_rel_line_to" cairo x y)))
+    (C-call "cairo_line_to" cairo x y)))
 
 (define (cairo-rel-line-to cairo dx dy)
   (guarantee-cairo cairo 'cairo-rel-line-to)
diff --git a/src/cairo/compile.scm b/src/cairo/compile.scm
index ff9347231..44c9008dc 100644
--- a/src/cairo/compile.scm
+++ b/src/cairo/compile.scm
@@ -41,4 +41,7 @@ USA.
 	(compile-file "cairo" '("cairo-const.bin")
 		      (->environment '(cairo)))
 
+	(compile-file "cairo-graphics" '("cairo-const.bin")
+		      (->environment '(cairo graphics)))
+
 	(cref/generate-constructors "cairo" 'ALL)))))
\ No newline at end of file
diff --git a/src/gl/check.scm b/src/gl/check.scm
index 7379e6a86..fc1001576 100644
--- a/src/gl/check.scm
+++ b/src/gl/check.scm
@@ -7,7 +7,7 @@
 (load-option 'FFI)
 (load-option 'GTK)
 
-(if (gtk-thread-running?)
+(if (gtk-initialized?)
     (begin
       (let ((env (->environment '(runtime pathname))))
 	(set! (access library-directory-path env)
diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index 60f08daa8..53f9461e9 100644
--- a/src/gl/gl-glx.scm
+++ b/src/gl/gl-glx.scm
@@ -55,9 +55,9 @@ USA.
 
 (define-method initialize-instance ((widget <glx-widget>) width height)
   (call-next-method widget width height)
-  (add-gc-cleanup widget (make-glx-widget-cleanup
-			  (glx-widget-xdisplay widget)
-			  (glx-widget-glxcontext widget)))
+  (add-glib-cleanup widget (make-glx-widget-cleanup
+			    (glx-widget-xdisplay widget)
+			    (glx-widget-glxcontext widget)))
   (C-call "gtk_widget_set_double_buffered" (gobject-alien widget) 0))
 
 (define (make-glx-widget-cleanup xdisplay glxcontext)
@@ -74,9 +74,7 @@ USA.
 (define-method gtk-widget-destroy-callback ((widget <glx-widget>))
   (without-interrupts
    (lambda ()
-     (punt-gc-cleanup widget)
-     (cleanup-glx-widget (glx-widget-xdisplay widget)
-			 (glx-widget-glxcontext widget))))
+     (execute-glib-cleanup widget)))
   (call-next-method widget))
 
 (define-method fix-widget-realize-callback ((widget <glx-widget>))
@@ -146,18 +144,14 @@ USA.
 	(copy (make-alien '|GLXFBConfig|))
 	(attribs (make-attribs attrib-list))
 	(num-configs (malloc (C-sizeof "int") 'int)))
-    (add-gc-cleanup configs (make-fb-configs-cleanup copy))
+    (add-glib-cleanup configs (make-fb-configs-cleanup copy))
     (C-call "glXChooseFBConfig" copy
 	    display screen-num attribs num-configs)
     (free attribs)
     (free num-configs)
-    (if (alien-null? copy)
-	(begin
-	  (punt-gc-cleanup configs)
-	  #f)
-	(begin
-	  (copy-alien-address! configs copy)
-	  configs))))
+    (copy-alien-address! configs copy)
+    (error-if-null configs "Could not find:" configs)
+    configs))
 
 #;(define (make-fb-configs-cleanup alien)
   (named-lambda (fb-configs-cleanup)
@@ -170,14 +164,6 @@ USA.
 	(C-call "XFree" alien)
 	(alien-null! alien))))
 
-#;(define (xfree alien)
-  (without-interrupts
-   (lambda ()
-     (if (not (alien-null? alien))
-	 (let ((cleanup (punt-gc-cleanup alien)))
-	   (if cleanup (cleanup))
-	   (alien-null! alien))))))
-
 (define (make-attribs attribs)
   (let* ((len (length attribs))
 	 (alien (malloc (* len (C-sizeof "int")) '|int|)))
@@ -212,38 +198,6 @@ USA.
 		      "GError pointer not set.")))
 	    (gerror-pointer-free gerror*)
 	    (error message))))))
-
-#;(define (make-gerror-pointer)
-  (let ((alien (make-alien '(* |GError|)))
-	(copy (make-alien '(* |GError|))))
-    (add-gc-cleanup alien (make-gerror-pointer-cleanup copy))
-    (C-call "g_try_malloc0" copy (C-sizeof "* GError"))
-    (if (alien-null? copy)
-	(begin
-	  (punt-gc-cleanup alien)
-	  (error "Could not create:" alien))
-	(begin
-	  (copy-alien-address! alien copy)
-	  alien))))
-
-#;(define (make-gerror-pointer-cleanup gerror*)
-  (named-lambda (gerror-pointer-cleanup)
-    ;;without-interrupts
-    (if (not (alien-null? gerror*))
-	(let ((gerror (make-alien '|GError|)))
-	  (C-> gerror* "* GError" gerror)
-	  (if (not (alien-null? gerror))
-	      (C-call "g_error_free" gerror))
-	  (C-call "g_free" gerror*)
-	  (alien-null! gerror*)))))
-
-#;(define (gerror-pointer-free gerror*)
-  (without-interrupts
-   (lambda ()
-     (if (not (alien-null? gerror*))
-	 (let ((cleanup (punt-gc-cleanup gerror*)))
-	   (if cleanup (cleanup))
-	   (alien-null! gerror*))))))
 
 (define-class (<glx-viewport> (constructor () (width height)))
     ;; A <glx-widget> with camera parameters, and a default key-press
diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg
index 790d7ed5f..2715bc72d 100644
--- a/src/gl/gl.pkg
+++ b/src/gl/gl.pkg
@@ -26,6 +26,7 @@ USA.
 (global-definitions runtime/)
 (global-definitions ffi/)
 (global-definitions sos/)
+(global-definitions glib/)
 (global-definitions gtk/)
 
 (define-package (gl)
@@ -80,7 +81,11 @@ USA.
 	  ucode-primitive)
   (import (runtime ffi)
 	  %set-alien/address!)
-  (import (gtk gobject)
+  (import (glib)
+	  add-glib-cleanup execute-glib-cleanup)
+  (import (gobject)
+	  gobject-alien)
+  (import (gtk gdk)
 	  make-pixbuf)
   (import (gtk gtk-widget)
 	  gtk-widget-destroy-callback)
@@ -89,9 +94,8 @@ USA.
 	  fix-widget-geometry fix-widget-window
 	  set-fix-widget-map-handler! set-fix-widget-unmap-handler!)
   (import (gtk)
-	  cairo-clip-extents
-	  add-gc-cleanup punt-gc-cleanup error-if-null
-	  gobject-alien gtk-window-new
+	  error-if-null
+	  gtk-window-new
 	  gtk-widget-destroy gtk-widget-parent
 	  gtk-widget-show-all
 	  gtk-widget-queue-draw
diff --git a/src/glib/gio.scm b/src/glib/gio.scm
index 82dbae12e..0dc93162a 100644
--- a/src/glib/gio.scm
+++ b/src/glib/gio.scm
@@ -240,16 +240,16 @@ USA.
 
 (define-method initialize-instance ((object <g-input-stream>))
   (call-next-method object)
-  (add-gc-cleanup object (make-g-input-stream-cleanup
-			  (gio-cleanup-info object)
-			  (g-input-stream-cleanup-info object))))
+  (add-glib-cleanup object (make-g-input-stream-cleanup
+			    (gio-cleanup-info object)
+			    (g-input-stream-cleanup-info object))))
 
 (define (make-g-input-stream-cleanup gio-info info)
   (named-lambda (g-input-stream-cleanup)
     (cleanup-g-input-stream gio-info info)))
 
 (define (cleanup-g-input-stream gio-info info)
-  ;; For gc-cleanup.  Run without-interrupts.
+  ;; For glib-cleanups.  Run without-interrupts.
   (cleanup-gio gio-info)
   (cleanup-callback-id info g-input-stream read-id)
   (cleanup-callback-id info g-input-stream skip-id))
@@ -428,16 +428,16 @@ USA.
 
 (define-method initialize-instance ((object <g-output-stream>))
   (call-next-method object)
-  (add-gc-cleanup object (make-g-output-stream-cleanup
-			  (gio-cleanup-info object)
-			  (g-output-stream-cleanup-info object))))
+  (add-glib-cleanup object (make-g-output-stream-cleanup
+			    (gio-cleanup-info object)
+			    (g-output-stream-cleanup-info object))))
 
 (define (make-g-output-stream-cleanup gio-info info)
   (named-lambda (g-output-stream-cleanup)
     (cleanup-g-output-stream gio-info info)))
 
 (define (cleanup-g-output-stream gio-info info)
-  ;; For gc-cleanup.  Run without-interrupts.
+  ;; For glib-cleanups.  Run without-interrupts.
   (cleanup-gio gio-info)
   (cleanup-callback-id info g-output-stream write-id)
   (cleanup-callback-id info g-output-stream flush-id))
@@ -713,7 +713,7 @@ USA.
 
 (define-method initialize-instance ((object <gfile-info>))
   (call-next-method object)
-  (add-gc-cleanup object (make-ginfo-cleanup (gio-cleanup-info object))))
+  (add-glib-cleanup object (make-ginfo-cleanup (gio-cleanup-info object))))
 
 (define (make-ginfo-cleanup gio-info)
   (named-lambda (ginfo-cleanup)
@@ -813,16 +813,16 @@ USA.
 
 (define-method initialize-instance ((object <gfile-enumerator>))
   (call-next-method object)
-  (add-gc-cleanup object (make-gfile-enumerator-cleanup
-			  (gio-cleanup-info object)
-			  (gfile-enumerator-ginfos object))))
+  (add-glib-cleanup object (make-gfile-enumerator-cleanup
+			    (gio-cleanup-info object)
+			    (gfile-enumerator-ginfos object))))
 
 (define (make-gfile-enumerator-cleanup gio-info ginfos)
   (named-lambda (gfile-enumerator-cleanup)
     (cleanup-gfile-enumerator gio-info ginfos)))
 
 (define (cleanup-gfile-enumerator gio-info ginfos)
-  ;; For gc-cleanup.  Run without-interrupts.
+  ;; For glib-cleanups.  Run without-interrupts.
   (cleanup-gio gio-info)
   (cleanup-ginfos ginfos))
 
@@ -974,7 +974,8 @@ USA.
 
 (define-method initialize-instance ((gmountop <g-mount-operation>))
   (call-next-method gmountop)
-  (add-gc-cleanup gmountop (make-gmountop-cleanup (gio-cleanup-info gmountop)))
+  (add-glib-cleanup gmountop
+		    (make-gmountop-cleanup (gio-cleanup-info gmountop)))
   (let ((alien (gobject-alien gmountop)))
     (set-alien/ctype! alien '|GMountOperation|)
     (C-call "g_mount_operation_new" alien)
@@ -1192,7 +1193,7 @@ USA.
   ;; SETTER is applied to an alien that must not escape.
   (let ((alien (make-alien '(* uchar)))
 	(copy (make-alien '(* uchar))))
-    (add-gc-cleanup alien (make-cstringv-cleanup copy))
+    (add-glib-cleanup alien (make-cstringv-cleanup copy))
     (setter copy)
     (copy-alien-address! alien copy)
     alien))
@@ -1226,9 +1227,8 @@ USA.
 (define (free-cstringv alien)
   (without-interrupts
    (lambda ()
-     (let ((cleanup (punt-gc-cleanup alien)))
-       (if cleanup (cleanup))
-       (alien-null! alien)))))
+     (execute-glib-cleanup alien)
+     (alien-null! alien))))
 
 (define %trace? #f)
 
diff --git a/src/glib/glib-thread.scm b/src/glib/glib-thread.scm
index cc7c14b3d..55bd2b30d 100644
--- a/src/glib/glib-thread.scm
+++ b/src/glib/glib-thread.scm
@@ -57,7 +57,7 @@ USA.
 		     (let ((gc-tick (car (gc-timestamp))))
 		       (if (fix:< done-tick gc-tick)
 			   (begin
-			     (run-gc-cleanups)
+			     (run-glib-cleanups)
 			     (set! done-tick gc-tick)))
 		       (if (fix:< next-secondary-tick gc-tick)
 			   (begin
diff --git a/src/glib/glib.pkg b/src/glib/glib.pkg
index 19d154cf9..d2b873981 100644
--- a/src/glib/glib.pkg
+++ b/src/glib/glib.pkg
@@ -42,7 +42,6 @@ USA.
 	  <gobject> gobject-alien
 	  gobject-live? gobject-unref!
 	  g-signal-connect g-signal-disconnect
-	  add-gc-cleanup punt-gc-cleanup
 	  gobject-get-property gobject-set-properties
 	  gquark-from-string gquark-to-string))
 
@@ -115,8 +114,8 @@ USA.
   ;;(depends-on "main")
   (export ()
 	  stop-glib-thread)
-  (import (gobject)
-	  run-gc-cleanups)
+  (import (glib)
+	  run-glib-cleanups)
   (import (glib main)
 	  run-glib)
   (import (runtime primitive-io)
diff --git a/src/glib/glib.scm b/src/glib/glib.scm
index f9a13c48e..23a5838f9 100644
--- a/src/glib/glib.scm
+++ b/src/glib/glib.scm
@@ -105,4 +105,57 @@ USA.
   (if (color? o) (flo:vector-set! o 2 b)(error:wrong-type-argument o"a color")))
 
 (define-integrable-operator (set-color-alpha! o a)
-  (if (color? o) (flo:vector-set! o 3 a)(error:wrong-type-argument o"a color")))
\ No newline at end of file
+  (if (color? o) (flo:vector-set! o 3 a)(error:wrong-type-argument o"a color")))
+
+;;; GLib Cleanups
+
+(define glib-cleanups)
+
+(define (initialize-glib-cleanups!)
+  (set! glib-cleanups '()))
+
+(define (run-glib-cleanups)
+  (let loop ((alist glib-cleanups)
+	     (prev #f))
+    (if (pair? alist)
+	(if (weak-pair/car? (car alist))
+	    (loop (cdr alist) alist)
+	    (let ((thunk (weak-cdr (car alist)))
+		  (next (cdr alist)))
+	      (thunk)
+	      (if prev
+		  (set-cdr! prev next)
+		  (set! glib-cleanups next))
+	      (loop next prev))))))
+
+(define (reset-glib-cleanups!)
+  (set! glib-cleanups '()))
+
+(define (add-glib-cleanup object cleanup-thunk)
+  (let ((weak-pair (weak-cons object cleanup-thunk)))
+    (without-interrupts
+     (lambda ()
+       (set! glib-cleanups (cons weak-pair glib-cleanups))))
+    weak-pair))
+
+(define (execute-glib-cleanup object)
+  (let ((entry (weak-assq object glib-cleanups)))
+    (if entry
+	(begin
+	  ((weak-cdr entry))
+	  (set! glib-cleanups (delq! entry glib-cleanups)))))
+  unspecific)
+
+(define (weak-assq obj alist)
+  (let loop ((alist alist))
+    (if (null? alist) #f
+	(let* ((entry (car alist))
+	       (key (weak-car entry)))
+	  (if (eq? obj key) entry
+	      (loop (cdr alist)))))))
+
+(define (initialize-package!)
+  (initialize-glib-cleanups!)
+  (add-event-receiver! event:after-restore reset-glib-cleanups!))
+
+(initialize-package!)
\ No newline at end of file
diff --git a/src/glib/glib.texinfo b/src/glib/glib.texinfo
index 1b51c88c1..a3732d661 100644
--- a/src/glib/glib.texinfo
+++ b/src/glib/glib.texinfo
@@ -604,12 +604,12 @@ signal handlers to them.
 
 @unnumberedsec Toolkit Resource Usage
 
-Each gobject instance is tracked by the weak alist @code{gc-cleanups},
+Each gobject instance is tracked by the weak alist @code{glib-cleanups},
 so that the toolkit object can be @code{g_object_unref}'ed when the
 instance is GCed.
 
 The initialize-instance method for subclasses of gobject should chain
-up early, adding the instance's alien to gc-cleanups @emph{before}
+up early, adding the instance's alien to glib-cleanups @emph{before}
 calling out to the toolkit.  This ensures that an allocated toolkit
 object will not be dropped; its alien address is on the list of GC
 cleanups before it is even allocated.  @emph{After} the callout, the
@@ -644,7 +644,7 @@ will not be invoked after an instance is GCed, else an error should be
 signaled.
 
 TODO: A world save hook might warn of gobject instances still on the
-gc-cleanups list.  A world restore hook could kill them.
+glib-cleanups list.  A world restore hook could kill them.
 
 @node GNU Free Documentation License, , Implementation Notes, Top
 @appendix GNU Free Documentation License
diff --git a/src/glib/glibio.c b/src/glib/glibio.c
index 9d3d29c91..a4b7a7e09 100644
--- a/src/glib/glibio.c
+++ b/src/glib/glibio.c
@@ -522,27 +522,31 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr)
     {
       struct handler_record * scan;
 
+      trace (";signal %d: in scheme_thread\n", signo);
       scan = old_handlers;
       while (scan != NULL)
 	{
 	  if (scan->signo == signo)
 	    {
+	      trace (";signal %d: invoking original handler\n", signo);
 	      (scan->handler)(signo, siginfo, ptr);
+	      trace (";signal %d: original handler returned\n", signo);
 	      return;
 	    }
 	  scan = scan->next;
 	}
-      complain (";signal_forwarder: no handler for signo %d\n", signo);
+      complain (";signal %d: no handler\n", signo);
     }
   else
     {
       int err;
 
+      trace (";signal %d: outside scheme_thread\n", signo);
       err = pthread_kill (scheme_thread, signo);
       if (err != 0)
 	{
-	  complain (";signal_forwarder: pthread_kill failed: %s\n",
-		    errno_name (err));
+	  complain (";signal %d: pthread_kill failed: %s\n",
+		    signo, errno_name (err));
 	  sleep (1);
 	}
     }
diff --git a/src/glib/gobject.scm b/src/glib/gobject.scm
index 85dde6699..30bc55e07 100644
--- a/src/glib/gobject.scm
+++ b/src/glib/gobject.scm
@@ -40,7 +40,7 @@ USA.
   (signals define standard
 	   initializer (lambda () (list 'GOBJECT-SIGNALS)))
 
-  ;; This instance's weak-pair on the gc-cleanups list.  This is
+  ;; This instance's weak-pair on the glib-cleanups list.  This is
   ;; cached here mainly for g-signal-connect, which must create
   ;; callbacks that only weakly reference this instance.
   (weak-self define standard))
@@ -53,36 +53,28 @@ USA.
 (define-method initialize-instance ((object <gobject>))
   (call-next-method object)
   (set-gobject-weak-self!
-   object (add-gc-cleanup object (make-gobject-cleanup-thunk
-				  (gobject-alien object)
-				  (gobject-signals object)))))
+   object (add-glib-cleanup object (make-gobject-cleanup
+				    (gobject-alien object)
+				    (gobject-signals object)))))
 
-(define (make-gobject-cleanup-thunk alien signals)
+(define (make-gobject-cleanup alien signals)
   ;; This separate procedure ensures that the gobject is not caught in
   ;; the closure.
-  (named-lambda (gobject-cleanup-thunk)
-    (gobject-cleanup alien signals)))
+  (named-lambda (gobject-cleanup)
+    (%trace ";gobject-cleanup "alien"\n")
+    (if (not (alien-null? alien))
+	(begin
+	  (for-each
+	    (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle)))
+	    (cdr signals))
+	  (C-call "g_object_unref" alien)
+	  (alien-null! alien)))
+    (%trace ";gobject-cleanup done with "alien"\n")))
 
 (define (gobject-unref! object)
   (without-interrupts
    (lambda ()
-     (gobject-cleanup (gobject-alien object) (gobject-signals object))
-     (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups))
-     unspecific)))
-
-(define (gobject-cleanup alien signals)
-  ;; Run as a gc-daemon, or with exclusive write access to ALIEN and
-  ;; SIGNALS (or without-interrupts).
-
-  (%trace ";gobject-cleanup "alien"\n")
-  (if (not (alien-null? alien))
-      (begin
-	(for-each
-	  (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle)))
-	  (cdr signals))
-	(C-call "g_object_unref" alien)
-	(alien-null! alien)))
-  (%trace ";gobject-cleanup done with "alien"\n"))
+     (execute-glib-cleanup object))))
 
 (define (g-signal-connect gobject alien-function callback
 			  #!optional signal-name)
@@ -152,57 +144,6 @@ USA.
 	(set-car! id.handle #f)
 	#t)))
 
-;;; GC Cleanups
-
-(define gc-cleanups)
-
-(define (initialize-gc-cleanups!)
-  (set! gc-cleanups '()))
-
-(define (run-gc-cleanups)
-  (%trace ";run-gc-cleanups\n")
-  (let loop ((alist gc-cleanups)
-	     (prev #f))
-    (if (pair? alist)
-	(if (weak-pair/car? (car alist))
-	    (loop (cdr alist) alist)
-	    (let ((thunk (weak-cdr (car alist)))
-		  (next (cdr alist)))
-	      (thunk)
-	      (if prev
-		  (set-cdr! prev next)
-		  (set! gc-cleanups next))
-	      (loop next prev)))))
-  (%trace ";run-gc-cleanups done\n"))
-
-(define (reset-gc-cleanups!)
-  (set! gc-cleanups '()))
-
-(define-integrable (add-gc-cleanup object cleanup-thunk)
-  (let ((weak-pair (weak-cons object cleanup-thunk)))
-    (without-interrupts
-     (lambda ()
-       (set! gc-cleanups (cons weak-pair gc-cleanups))))
-    weak-pair))
-
-(define-integrable (punt-gc-cleanup object)
-  (without-interrupts
-   (lambda ()
-     (let ((entry (weak-assq object gc-cleanups)))
-       (if entry
-	   (begin
-	     (set! gc-cleanups (delq! entry gc-cleanups))
-	     (weak-cdr entry))
-	   #f)))))
-
-(define (weak-assq obj alist)
-  (let loop ((alist alist))
-    (if (null? alist) #f
-	(let* ((entry (car alist))
-	       (key (weak-car entry)))
-	  (if (eq? obj key) entry
-	      (loop (cdr alist)))))))
-
 
 ;;; Properties
 
@@ -474,9 +415,7 @@ USA.
   unspecific)
 
 (define (initialize-package!)
-  (initialize-gc-cleanups!)
   (add-event-receiver! event:after-restore reset-quark-cache!)
-  (add-event-receiver! event:after-restore reset-gc-cleanups!)
   unspecific)
 
 (define %trace? #f)
diff --git a/src/gtk/check-doc.scm b/src/gtk/check-doc.scm
index 6e6f3d459..1f2786fc8 100644
--- a/src/gtk/check-doc.scm
+++ b/src/gtk/check-doc.scm
@@ -102,9 +102,7 @@
 	 (bindings (append (pmodel/global-exports pmodel)
 			   (pmodel/package-bindings pmodel '(gtk))))
 	 (missing (minus (minus bindings deffns)
-			 '(add-gc-cleanup
-			   punt-gc-cleanup
-			   make-pole-zero
+			 '(make-pole-zero
 			   make-fix-layout-demo
 			   make-gtk-event-viewer-demo)))
 	 (extras (minus deffns bindings)))
diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 65fac2cc4..5071c6c4a 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -1242,8 +1242,10 @@ USA.
 	  (let ((fill (get-option ink 'FILL '())))
 	    (if (not (null? fill))
 		(begin
+		  (cairo-save cr)
 		  (set-fill-options! cr ink)
-		  (cairo-fill-preserve cr))))
+		  (cairo-fill-preserve cr)
+		  (cairo-restore cr))))
 	  (let ((outline (get-option ink 'OUTLINE '())))
 	    (if (not (null? outline))
 		(begin
diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm
index 102628752..be96a3aba 100644
--- a/src/gtk/gdk.scm
+++ b/src/gtk/gdk.scm
@@ -25,12 +25,13 @@ USA.
 ;;; package: (gdk)
 
 (define (gdk-cairo-create gdkwindow)
-  (guarantee-gdk-window gdkwindow 'gdk-window-process-updates)
+  (guarantee-gdk-window gdkwindow 'gdk-cairo-create)
   (let ((cairo (make-alien '|cairo_t|))
 	(copy (make-alien '|cairo_t|)))
-    (add-gc-cleanup cairo (make-cairo-cleanup copy))
+    (add-glib-cleanup cairo (make-cairo-cleanup copy))
     (C-call "gdk_cairo_create" copy gdkwindow)
     (copy-alien-address! cairo copy)
+    (error-if-null cairo "Could not create:" cairo gdkwindow)
     (check-cairo-status cairo)
     cairo))
 
@@ -162,11 +163,10 @@ USA.
 (define (make-gerror-pointer)
   (let ((alien (make-alien '(* |GError|)))
 	(copy  (make-alien '(* |GError|))))
-    (add-gc-cleanup alien (make-gerror-pointer-cleanup copy))
+    (add-glib-cleanup alien (make-gerror-pointer-cleanup copy))
     (C-call "g_try_malloc0" copy (C-sizeof "* GError"))
-    (if (alien-null? copy)
-	(error "Could not create a GError pointer."))
     (copy-alien-address! alien copy)
+    (error-if-null alien "Could not create:" alien)
     alien))
 
 (define (make-gerror-pointer-cleanup copy)
@@ -183,11 +183,8 @@ USA.
   (without-interrupts
    (lambda ()
      (if (not (alien-null? gerror*))
-	 (let ((gerror (make-alien '|GError|)))
-	   (C-> gerror* "* GError" gerror)
-	   (if (not (alien-null? gerror))
-	       (C-call "g_error_free" gerror))
-	   (C-call "g_free" gerror*)
+	 (begin
+	   (execute-glib-cleanup gerror*)
 	   (alien-null! gerror*))))))
 
 (define (load-pixbuf-from-file loader filename)
diff --git a/src/gtk/gtk-check.scm b/src/gtk/gtk-check.scm
index 6048872c1..c64e07c08 100644
--- a/src/gtk/gtk-check.scm
+++ b/src/gtk/gtk-check.scm
@@ -61,7 +61,7 @@ USA.
      'gtk-demos.callbacks
      (named-lambda (gtk-demos.callbacks-test)
        (assert = 0 (car (registered-callback-count))
-	       '(REGISTERED-CALLBACK-COUNT))))
+	       '(CAR (REGISTERED-CALLBACK-COUNT)))))
 
     (run-test
      'gtk-demos.mallocs
diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm
index c73735009..8ee68607f 100644
--- a/src/gtk/gtk-graphics.scm
+++ b/src/gtk/gtk-graphics.scm
@@ -90,12 +90,6 @@ USA.
 	  (gtk-widget-show-all window)
 	  (make-device graphics)))))
 
-(define (gtk-graphics/make width height)
-  (guarantee-positive-fixnum width 'gtk-graphics/open)
-  (guarantee-positive-fixnum height 'gtk-graphics/open)
-  (%make-graphics-device gtk-graphics-device-type
-			 (make-gtk-graphics width height)))
-
 (define (toplevel graphics)
   (let ((widgets (fix-drawing-widgets (fix-ink-drawing graphics))))
     (if (null? (cdr widgets))
diff --git a/src/gtk/gtk-widget.scm b/src/gtk/gtk-widget.scm
index e4ce63ed4..18cfd573b 100644
--- a/src/gtk/gtk-widget.scm
+++ b/src/gtk/gtk-widget.scm
@@ -103,7 +103,7 @@ USA.
 
 ;;; This is unfortunate.  We rely on the most specialized method to
 ;;; call out, creating a specific type of GtkWidget.  We want the
-;;; <gobject> method to go first, as usual, to add a gc-cleanup, but
+;;; <gobject> method to go first, as usual, to add a glib-cleanup, but
 ;;; this method to go last, AFTER the most specific (most unusual!)
 ;;; else it cannot connect its destroy-callback.  To do both would
 ;;; take... a computed effective method procedure?  For now, rely on
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index ce3a358c4..d8b666a0a 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -288,8 +288,6 @@ USA.
   (import (gtk fix-layout)
 	  fix-ink-extent fix-rect-height fix-rect-width
 	  ->color set-surface-ink-surface! drawing-damage)
-  (import (runtime graphics)
-	  %make-graphics-device)
   (export ()
 	  gtk-graphics/set-background-color
 	  gtk-graphics/set-foreground-color
@@ -298,8 +296,7 @@ USA.
 	  gtk-graphics/draw-circle
 	  gtk-graphics/fill-polygon-list
 	  gtk-graphics/clear
-	  gtk-graphics/flush
-	  gtk-graphics/make))
+	  gtk-graphics/flush))
 
 (define-package (gtk fix-layout demo)
   (parent (gtk fix-layout))
diff --git a/src/gtk/gtk.texinfo b/src/gtk/gtk.texinfo
index 1446dd9c0..081f73272 100644
--- a/src/gtk/gtk.texinfo
+++ b/src/gtk/gtk.texinfo
@@ -233,7 +233,7 @@ pixels in size.  If @var{no-window?} is specified (not @code{#f}) the
 device will write to the surface, but not put the surface in a window.
 Instead the device's descriptor, a @bref{<surface-ink>}, can be added
 to any fix-drawing, or its Cairo surface can be passed to e.g.
-@bref{cairo-surface-write-to-png}.
+@code{cairo-surface-write-to-png}.
 
 By default (or when @var{no-window?} is @code{#f}) the device's output
 appears in a scrollable window.
@@ -241,13 +241,6 @@ appears in a scrollable window.
 You can draw on the surface with the simple graphics interface and/or
 the following procedures.
 
-@deffn Procedure gtk-graphics/make width height
-Creates a Gtk graphics device even if the output device is not
-available.  The output still goes to a new Cairo image surface with
-@var{width}x@var{height} pixels.  It just can't be displayed (only
-written to a file).
-@end deffn
-
 @deffn Procedure gtk-graphics/fill-polygon-list device points
 Draws a filled polygon.  @var{Points} is a list of flo:vectors each
 containing at least two flonums, the x and y coordinates of a point.
@@ -282,9 +275,9 @@ after resetting its clip region.
 @end deffn
 
 @deffn Procedure gtk-graphics/flush device
-Applies @bref{cairo-surface-flush} to @var{device}'s Cairo surface,
+Applies @code{cairo-surface-flush} to @var{device}'s Cairo surface,
 and updates any drawings containing @var{device}'s descriptor, a
-@bref{<surface-ink>}.  @xref{cairo-surface-flush}.  This is the method
+@bref{<surface-ink>}.  This is the method
 used by @code{graphics-flush}.
 @end deffn
 
@@ -450,11 +443,11 @@ is currently visible.
 
 A gtk-widget is a gobject that can be "destroyed".  Each instance is
 connected to the "destroy" signal of its GtkWidget.  The callback
-applies @bref{gobject-unref!} to the instance,
+applies @code{gobject-unref!} to the instance,
 allowing the toolkit to finalize and dispose of the widget.
 
 If a Gtk Widget is "dropped", never destroyed, eventually GCed, the
-usual gobject cleanup will effect a @bref{gobject-unref!} and
+usual gobject cleanup will effect a @code{gobject-unref!} and
 (potentially) release the toolkit resources.
 
 A Gtk Widget also has a ``parent'' slot --- a @bref{gtk-container} or
@@ -593,7 +586,7 @@ toplevel changes.  It will be updated to match changes to
 @var{widget}'s attributes.  @var{Widget}'s @code{style-set} and
 @code{direction-changed} signals indicate when the context has
 changed.  If you keep a PangoLayout using this default context, the
-signal callbacks should apply @bref{pango-layout-context-changed}.
+signal callbacks should apply @code{pango-layout-context-changed}.
 @end deffn
 
 @deffn Procedure gtk-widget-create-pango-layout widget #!optional text
@@ -601,7 +594,7 @@ Creates a new pango-layout with the appropriate font map, font
 description, and base direction for drawing text for @var{widget}.
 The layout will be empty unless @var{text}, a string, is provided.  If
 @var{widget}'s base direction or font changes, apply
-@bref{pango-layout-context-changed} to re-lay-out the text.
+@code{pango-layout-context-changed} to re-lay-out the text.
 @end deffn
 
 @deffn Procedure gtk-widget-get-size widget
@@ -1944,7 +1937,7 @@ displaying @var{ink}.
 @deffn Procedure set-simple-text-ink-font! text font
 Sets @var{text}'s pango layout's font to @var{font}.  @var{Font}
 should be a PangoFontDescription, or a string acceptable to
-@bref{pango-font-description-from-string} (e.g. @code{courier 12}).
+@code{pango-font-description-from-string} (e.g. @code{courier 12}).
 @end deffn
 
 @subsection Image Ink
@@ -2114,61 +2107,6 @@ In the example call to @code{gtk-label-get-text} above, a Scheme
 object represents the GtkLabel.  It is a gtk-label instance, whose
 class is a specialization of the abstract gtk-object class.
 
-@unnumberedsec Gtk Thread
-
-When the Gtk system loads, it starts a toolkit main loop with Scheme
-attached as an custom idle task.  The main loop then re-starts Scheme,
-which creates a thread to ``run'' the toolkit (actually, return to
-it).  Thus Scheme threads multitask with the toolkit.  Scheme runs as
-an idle task in the toolkit, and the toolkit runs in a Scheme thread.
-A program using the Gtk system does not call @code{gtk_init} nor
-@code{gtk_main}.  It need only create toolkit objects and attach
-signal handlers to them.
-
-@unnumberedsec Toolkit Resource Usage
-
-Each gobject instance is tracked by the weak alist @code{gc-cleanups},
-so that the toolkit object can be @code{g_object_unref}'ed when the
-instance is GCed.
-
-The initialize-instance method for subclasses of gobject should chain
-up early, adding the instance's alien to gc-cleanups @emph{before}
-calling out to the toolkit.  This ensures that an allocated toolkit
-object will not be dropped; its alien address is on the list of GC
-cleanups before it is even allocated.  @emph{After} the callout, the
-initialize method should also @code{g_object_ref_sink} any floating
-refs it receives.
-
-The following scenarios are typical of Gtk resource management.
-
-Temporary alien: The (alien) address of a PangoFontDescription
-is read from a PangoLayout member.  The layout ``owns'' the
-font description.  Scheme does not.  The address should only be used
-while without-toolkit (or without-interrupts), else the
-toolkit may "dispose" of it while Scheme is using it.
-
-Schemely: A toolkit object is created and reflected in Scheme by a
-gobject instance.  Scheme owns the toolkit object, holds a reference,
-and should eventually @code{g_object_unref} it.  The instance may be
-shared among any number of Scheme widgets or other data structures
-(e.g a file->pixbuf cache) and @emph{never} explicitly ``killed''.
-When there are no more Scheme objects sharing the instance, it
-will be GCed and its GC cleanup procedure will ``kill''
-(@code{g_object_unref}) the toolkit object.  This may release toolkit
-resources or not depending on references elsewhere in the toolkit
-data structures.  In any case the instance was GCed --- the object
-cannot be erroneously used by Scheme in the future.
-
-Signals: The @bref{g-signal-connect} procedure takes pains not to hold
-a strong reference to a gobject instance.  These instances can be GCed
-even while signal handlers are connected.  The registered callbacks
-hold only a weak reference to the instance.  It is assumed a callback
-will not be invoked after an instance is GCed, else an error should be
-signaled.
-
-TODO: A world save hook might warn of gobject instances still on the
-gc-cleanups list.  A world restore hook could kill them.
-
 @node GNU Free Documentation License, , Implementation Notes, Top
 @appendix GNU Free Documentation License
 
diff --git a/src/pango/pango.scm b/src/pango/pango.scm
index 4f2ab5b68..41824bc04 100644
--- a/src/pango/pango.scm
+++ b/src/pango/pango.scm
@@ -133,19 +133,15 @@ USA.
   (guarantee-pango-layout layout 'pango-layout-get-baseline)
   (let ((iter (make-alien '|PangoLayoutIter|))
 	(copy (make-alien '|PangoLayoutIter|)))
-    (add-gc-cleanup iter (make-pango-layout-iter-cleanup copy))
+    (add-glib-cleanup iter (make-pango-layout-iter-cleanup copy))
     (C-call "pango_layout_get_iter" copy (gobject-alien layout))
-    (if (alien-null? copy)
-	(begin
-	  (punt-gc-cleanup iter)
-	  #f)
-	(begin
-	  (copy-alien-address! iter copy)
-	  (let ((baseline
-		 (pangos->pixels
-		  (C-call "pango_layout_iter_get_baseline" iter))))
-	    (pango-layout-iter-free iter)
-	    baseline)))))
+    (copy-alien-address! iter copy)
+    (error-if-null iter "Could not create:" iter layout)
+    (let ((baseline
+	   (pangos->pixels
+	    (C-call "pango_layout_iter_get_baseline" iter))))
+      (pango-layout-iter-free iter)
+      baseline)))
 
 (define (make-pango-layout-iter-cleanup alien)
   (named-lambda (pango-layout-iter-cleanup)
@@ -160,9 +156,8 @@ USA.
    (lambda ()
      (if (not (alien-null? iter))
 	 (begin
-	   (C-call "pango_layout_iter_free" iter)
-	   (alien-null! iter)
-	   (punt-gc-cleanup iter))))))
+	   (execute-glib-cleanup iter)
+	   (alien-null! iter))))))
 
 ;;; PangoFontDescription
 
@@ -171,15 +166,11 @@ USA.
   (guarantee-string string 'pango-font-description-from-string)
   (let ((font (make-alien '|PangoFontDescription|))
 	(copy (make-alien '|PangoFontDescription|)))
-    (add-gc-cleanup font (make-pango-font-description-cleanup copy))
+    (add-glib-cleanup font (make-pango-font-description-cleanup copy))
     (C-call "pango_font_description_from_string" copy string)
-    (if (alien-null? copy)
-	(begin
-	  (punt-gc-cleanup font)
-	  #f)
-	(begin
-	  (copy-alien-address! font copy)
-	  font))))
+    (copy-alien-address! font copy)
+    (error-if-null font "Could not create:" font)
+    font))
 
 (define (make-pango-font-description-cleanup alien)
   (named-lambda (pango-font-description-cleanup)
@@ -195,9 +186,8 @@ USA.
    (lambda ()
      (if (not (alien-null? font))
 	 (begin
-	   (C-call "pango_font_description_free" font)
-	   (alien-null! font)
-	   (punt-gc-cleanup font))))))
+	   (execute-glib-cleanup font)
+	   (alien-null! font))))))
 
 (define (pango-font-description-to-string font)
   (guarantee-pango-font-description font 'pango-font-description-to-string)
@@ -214,15 +204,11 @@ USA.
 (define (pango-font-description-copy font)
   (let ((new (make-alien '|PangoFontDescription|))
 	(copy (make-alien '|PangoFontDescription|)))
-    (add-gc-cleanup new (make-pango-font-description-cleanup copy))
+    (add-glib-cleanup new (make-pango-font-description-cleanup copy))
     (C-call "pango_font_description_copy" copy font)
-    (if (alien-null? copy)
-	(begin
-	  (punt-gc-cleanup font)
-	  #f)
-	(begin
-	  (copy-alien-address! new copy)
-	  new))))
+    (copy-alien-address! new copy)
+    (error-if-null new "Could not create:" new font)
+    new))
 
 (define-integrable (guarantee-pango-font-description object operator)
   (if (not (and (alien? object)
@@ -251,9 +237,10 @@ USA.
   (guarantee-pango-font-description font 'pango-context-get-metrics)
   (let ((alien (make-alien '|PangoFontMetrics|))
 	(copy (make-alien '|PangoFontMetrics|)))
-    (add-gc-cleanup alien (make-pango-font-metrics-cleanup copy))
+    (add-glib-cleanup alien (make-pango-font-metrics-cleanup copy))
     (C-call "pango_context_get_metrics" copy context font 0)
     (copy-alien-address! alien copy)
+    (error-if-null alien "Could not get:" alien)
     alien))
 
 (define (pango-context-spacing context)
@@ -285,9 +272,8 @@ USA.
    (lambda ()
      (if (not (alien-null? metrics))
 	 (begin
-	   (C-call "pango_font_metrics_unref" metrics)
-	   (alien-null! metrics)
-	   (punt-gc-cleanup metrics))))))
+	   (execute-glib-cleanup metrics)
+	   (alien-null! metrics))))))
 
 (define (pango-font-metrics-get-ascent metrics)
   (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-ascent)
@@ -328,7 +314,7 @@ USA.
 (define-integrable (pixels->pangos pixel-units)
   (* pixel-units 1024))
 
-;;; Debugging hacks.  No gc-cleanups!
+;;; Debugging hacks.  No cleanups!
 
 (define (pango-context-list-families PangoContext)
   (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFamily|))))
diff --git a/src/planetarium/Makefile b/src/planetarium/Makefile
new file mode 100644
index 000000000..e98198f84
--- /dev/null
+++ b/src/planetarium/Makefile
@@ -0,0 +1,39 @@
+# Copyright (C) 2014 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.
+
+MIT_SCHEME_EXE = mit-scheme
+exe = '$(MIT_SCHEME_EXE)' --batch-mode
+
+all:
+	echo '(load "mit-compile")' | $(exe)
+	@if [ -s mit-3d-unx.crf ]; then \
+	    echo "mit-3d-unx.crf:0: error: non-empty"; exit 1; fi
+
+check:
+	echo '(load "mit-check")' | $(exe)
+
+.PHONY: all check
+
+maintainer-clean distclean clean:
+	rm -f *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd
+
+tags:
+	etags *.scm
+
+.PHONY: clean distclean maintainer-clean tags
diff --git a/src/planetarium/geometry.scm b/src/planetarium/geometry.scm
index 9a99f86fb..6dd46faf1 100644
--- a/src/planetarium/geometry.scm
+++ b/src/planetarium/geometry.scm
@@ -121,7 +121,7 @@ USA.
 (define (latitude-longitude->string lat/lng)
   ;; Format a latitude/longitude in the standard form, e.g.
   ;;
-  ;;     30°26.40′N 122°44.40′W
+  ;;     30°26.400′N 122°44.400′W
 
   (let ((lat (latitude lat/lng))
 	(lng (longitude lat/lng)))
@@ -136,15 +136,43 @@ USA.
 	  (string-append
 	   (number->string (inexact->exact lat-deg) '(int))
 	   "°"
-	   (number->string lat-min '(fix 2))
+	   (number->string lat-min '(fix 3))
 	   "′"
 	   (if neg-lat? "S " "N ")
 	   (number->string (inexact->exact lng-deg) '(int))
 	   "°"
-	   (number->string lng-min '(fix 2))
+	   (number->string lng-min '(fix 3))
 	   "′"
 	   (if neg-lng? "W" "E")))))))
 
+(define (string->latitude-longitude string)
+  (let* ((digits "\\([0-9]+\\)")
+	 (regs (re-string-match
+		(string-append "^"digits"°"digits"."digits"′\\([SN]\\)"
+			       " "digits"°"digits"."digits"′\\([EW]\\)$")
+		string)))
+
+    (define-integrable (->flo n)
+      (->flonum (string->number (re-match-extract string regs n))))
+
+    (define-integrable (->neg? num)
+      (let ((string (re-match-extract string regs num)))
+	(or (string=? "W" string)
+	    (string=? "S" string))))
+
+    (define-integrable (dms.->d neg? degrees minutes millimin)
+      (let ((absolute (flo:+ degrees
+			     (flo:* 60.0 (flo:+ minutes
+						(flo:/ millimin 1000.))))))
+	(if neg?
+	    (flo:negate absolute)
+	    absolute)))
+
+    (and regs
+	 (make-latitude/longitude
+	  (dms.->d (->neg? 4) (->flo 1) (->flo 2) (->flo 3))
+	  (dms.->d (->neg? 8) (->flo 5) (->flo 6) (->flo 7))))))
+
 (define (geodesic-distance p1 p2)
   ;; "[Given] the geographic coordinates of two points on the surface
   ;; of the Earth [...] the shortest distance S between these points,
@@ -185,6 +213,16 @@ USA.
 	     (flo:+ pi d)
 	     d))))))
 
+#;(define (package-tests)
+  (run-test test-lat/lng-un/parse)
+  (run-test test-angular-separation))
+
+(define (test-lat/lng-un/parse)
+  (let ((samp "30°26.432′N 122°44.456′W"))
+    (if (not (string=? samp (latitude-longitude->string
+			     (string->latitude-longitude samp))))
+	(warn "Latitude/longitude un/parsing failed."))))
+
 (define (test-angular-separation)
 
   (define (test lat1 lng1 lat2 lng2 degrees tolerance)
diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg
index ab0d04f80..23cc94674 100644
--- a/src/planetarium/mit-3d.pkg
+++ b/src/planetarium/mit-3d.pkg
@@ -26,6 +26,7 @@ USA.
 (global-definitions runtime/)
 (global-definitions sos/)
 (global-definitions xml/)
+(global-definitions glib/)
 (global-definitions gtk/)
 (global-definitions gl/)
 (global-definitions "./mit")
diff --git a/src/planetarium/mit-cairo.scm b/src/planetarium/mit-cairo.scm
new file mode 100644
index 000000000..d83920ed4
--- /dev/null
+++ b/src/planetarium/mit-cairo.scm
@@ -0,0 +1,59 @@
+#| -*-Scheme-*-
+
+Copyright (C) 2014  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.
+
+|#
+
+;;;; System specific code for MIT Scheme using a cairo-graphics device.
+
+(define (make-suitable-graphics-device)
+  (let ((device (make-graphics-device 'cairo 512 512)))
+    (graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
+    device))
+
+(define-integrable (x p) (flo:vector-ref p 0))
+(define-integrable (y p) (flo:vector-ref p 1))
+
+(define (draw-segment device start end color)
+  (cairo-graphics/set-foreground-color device color)
+  #;(cairo-graphics/draw-line-points device start end)
+  (cairo-graphics/draw-line device
+			    (x start) (y start)
+			    (x end) (y end)))
+
+(define (draw-circle device center radius color)
+  (cairo-graphics/set-foreground-color device color)
+  (cairo-graphics/draw-circle device (x center) (y center) radius))
+
+(define (draw-text device coords string color)
+  (cairo-graphics/set-foreground-color device color)
+  (cairo-graphics/draw-text device (x coords) (y coords) string))
+
+(define (fill-polygon-available?) #t)
+
+(define (fill-polygon device points color)
+  (cairo-graphics/set-foreground-color device color)
+  (cairo-graphics/fill-polygon-list device points))
+
+(define (clear-graphics device)
+  (cairo-graphics/clear device))
+
+(define (flush-graphics device)
+  (cairo-graphics/flush device))
\ No newline at end of file
diff --git a/src/planetarium/mit-compile.scm b/src/planetarium/mit-compile.scm
index b4566ebc4..0a1e5ba64 100644
--- a/src/planetarium/mit-compile.scm
+++ b/src/planetarium/mit-compile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-Copyright (C) 2013  Matthew Birkholz
+Copyright (C) 2013, 2014  Matthew Birkholz
 
 This file is part of an extension to MIT/GNU Scheme.
 
@@ -51,6 +51,7 @@ USA.
     (cf '("earth" "tellurion")
 		       '("geometry" "matrices") '(planetarium))
     (cf "mit-gtk"      '() '(planetarium gtk-graphics))
+    (cf "mit-cairo"    '() '(planetarium cairo-graphics))
     (cf "mit-x"        '() '(planetarium x-graphics))
     (cf "mit-graphics" '() '(planetarium simple-graphics))
     (cf "mit-cil"      `("mit-syntax" ,@(directory-read "cil-*.txt"))
diff --git a/src/planetarium/mit-snapshot.scm b/src/planetarium/mit-snapshot.scm
index a2709f806..ca391e1f4 100644
--- a/src/planetarium/mit-snapshot.scm
+++ b/src/planetarium/mit-snapshot.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-Copyright (C) 2013  Matthew Birkholz
+Copyright (C) 2013, 2014  Matthew Birkholz
 
 This file is part of an extension to MIT/GNU Scheme.
 
@@ -24,43 +24,29 @@ USA.
 ;;;; Generate snapshots (PNG files).
 
 ;; Expect warning about DISPLAY not set.
-(load-option 'GTK)
+(load-option 'CAIRO)
 
 (with-working-directory-pathname
     (directory-pathname (current-load-pathname))
   (lambda ()
-    (load "mit-compile")
-    (let* ((package-set (package-set-pathname "mit"))
-	   (file (fasload package-set)))
-      (if (not ((access package-file? (->environment '(package))) file))
-	  (error "Malformed package-description file:" pkg))
-      (load-packages-from-file file '()
-			       (lambda (pathname environment)
-				 (load pathname environment 'DEFAULT #t)))
-      ((access initialize-packages-from-file (->environment '(package))) file)
-      (flush-purification-queue!))))
+    (load-package-set "mit")))
 
 (let ((planet (->environment '(planetarium)))
-      (graphics (->environment '(planetarium gtk-graphics))))
+      (graphics (->environment '(planetarium cairo-graphics))))
   (for-each (lambda (name) (environment-link-name planet graphics name))
-	    '(make-suitable-graphics-device
-	      draw-segment draw-circle draw-text
+	    '(draw-segment draw-circle draw-text
 	      fill-polygon-available? fill-polygon
 	      clear-graphics flush-graphics)))
 
 (let ((here (the-environment))
-      (planet (->environment '(planetarium)))
-      (gtk (->environment '(gtk))))
+      (planet (->environment '(planetarium))))
   (for-each (lambda (name) (environment-link-name here planet name))
-	    '(make-latitude/longitude draw-tellurion))
-  (for-each (lambda (name) (environment-link-name here gtk name))
-	    '(surface-ink-surface
-	      cairo-surface-write-to-png cairo-surface-destroy)))
+	    '(make-latitude/longitude draw-tellurion)))
 
 (let ((time (get-universal-time))
       (latitude 33.3)
       (longitude -111.9)
-      (device (gtk-graphics/make 400 400)))
+      (device (make-graphics-device 'cairo 400 400)))
   (graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
 
   (call-with-append-file "tellurion.log"
@@ -77,6 +63,5 @@ USA.
 	  (write-string (universal-time->local-time-string time) out)
 	  (newline out)))))
 
-  (let ((surface (surface-ink-surface (graphics-device/descriptor device))))
-    (cairo-surface-write-to-png surface "tellurion.png")
-    (cairo-surface-destroy surface)))
\ No newline at end of file
+  (cairo-graphics/write-to-png device "tellurion.png")
+  (cairo-graphics/destroy device))
\ No newline at end of file
diff --git a/src/planetarium/mit.pkg b/src/planetarium/mit.pkg
index ad91156b5..caef3d10e 100644
--- a/src/planetarium/mit.pkg
+++ b/src/planetarium/mit.pkg
@@ -24,6 +24,7 @@ USA.
 ;;;; Planetarium Packaging
 
 (global-definitions runtime/)
+(global-definitions cairo/)
 (global-definitions gtk/)
 
 (define-package (r3rs essential)
@@ -113,6 +114,8 @@ USA.
 	  decoded-time/year decoded-time/month decoded-time/day 
 	  universal-time->string
 
+	  re-string-match re-match-extract
+
 	  error warn)
   (import (planetarium syntax)
 	  define-integrable-operator)
@@ -126,25 +129,33 @@ USA.
   (export ()
 	  make-tellurion))
 
+(define-package (planetarium cairo-graphics)
+  (parent ())
+  (files "mit-cairo")
+  (export (planetarium)
+	  ;; Exports must be set up manually, as in mit-link.scm, if
+	  ;; this is the desired type of output device.
+	  ))
+
 (define-package (planetarium gtk-graphics)
   (parent ())
   (files "mit-gtk")
   (export (planetarium)
-	  ;; Exports are actually set up by make.scm per the available graphics.
+	  ;; Exports are set up by mit-link.scm per the available graphics.
 	  ))
 
 (define-package (planetarium x-graphics)
   (parent ())
   (files "mit-x")
   (export (planetarium)
-	  ;; Exports are actually set up by make.scm per the available graphics.
+	  ;; Exports are set up by mit-link.scm per the available graphics.
 	  ))
 
 (define-package (planetarium simple-graphics)
   (parent ())
   (files "mit-graphics")
   (export (planetarium)
-	  ;; Exports are actually set up by make.scm per the available graphics.
+	  ;; Exports are set up by mit-link.scm per the available graphics.
 	  ))
 
 (define-package (planetarium earth-cil)
diff --git a/src/planetarium/tellurion.scm b/src/planetarium/tellurion.scm
index 3ec6233d3..450aa4b78 100644
--- a/src/planetarium/tellurion.scm
+++ b/src/planetarium/tellurion.scm
@@ -56,11 +56,11 @@ USA.
 (define (run-tellurion queue)
   (let ((device (make-suitable-graphics-device))
 	;; Latitude and longitude per GPS -- positive degrees long. to the east.
-	(lat/long (make-latitude/longitude 23.271 0.))
+	(lat/lng (make-latitude/longitude 23.271 0.))
 	(time (get-universal-time))
 	(stopped? #f))
     (define-integrable (draw)
-      (draw-tellurion device time lat/long))
+      (draw-tellurion device time lat/lng))
     (draw)
     (let loop ()
       (let ((command (if stopped?
@@ -76,8 +76,8 @@ USA.
 	       (set! time (get-universal-time))
 	       (draw))
 	      ((eq? (car command) 'TURN-TO)
-	       (set-latitude! lat/long (cadr command))
-	       (set-longitude! lat/long (caddr command))
+	       (set-latitude! lat/lng (cadr command))
+	       (set-longitude! lat/lng (caddr command))
 	       (draw))
 	      ((eq? (car command) 'TIME-TO)
 	       (if (eq? (cadr command) 'current)
@@ -105,62 +105,28 @@ USA.
       (loop))))
 
 (define draw-tellurion
-  (let ((lat/long-pos (make-2d-point -1. -1.02))
+  (let ((lat/lng-pos (make-2d-point -1. -1.02))
 	(time-pos (make-2d-point -1. 1.))
 	(cross-hair-left (make-2d-point -.02 0.))
 	(cross-hair-right (make-2d-point .02 0.))
 	(cross-hair-top (make-2d-point 0. .02))
 	(cross-hair-bottom (make-2d-point 0. -.02)))
-    (named-lambda (draw-tellurion device time lat/long)
+    (named-lambda (draw-tellurion device time lat/lng)
       (clear-graphics device)
       (draw-text device time-pos (universal-time->string time) "black")
-      (draw-text device lat/long-pos (latitude/longitude-string lat/long) "black")
+      (draw-text device lat/lng-pos (latitude-longitude->string lat/lng) "black")
       (draw-earth device
-		  (orientation-matrix lat/long)
+		  (orientation-matrix lat/lng)
 		  (solar-latitude/longitude
 		   (universal-time->julian-day time)))
       (draw-segment device cross-hair-left cross-hair-right "black")
       (draw-segment device cross-hair-top cross-hair-bottom "black")
       (flush-graphics device))))
 
-(define (orientation-matrix lat/long)
+(define (orientation-matrix lat/lng)
   (let ((Mx (make-x-rotation-matrix (degrees->radians
-				     (latitude lat/long))))
+				     (latitude lat/lng))))
 	(My (make-y-rotation-matrix (degrees->radians
-				     (flo:negate (longitude lat/long))))))
+				     (flo:negate (longitude lat/lng))))))
     (3d-multiply! Mx My Mx)
-    Mx))
-
-(define (latitude/longitude-string lat/long)
-  (let ((lat (latitude lat/long))
-	(long (longitude lat/long)))
-    (let ((lat-deg (truncate->exact (abs lat)))
-	  (long-deg (truncate->exact (abs long))))
-      (let ((lat-minutes (* 60 (- (abs lat) lat-deg)))
-	    (long-minutes (* 60 (- (abs long) long-deg))))
-	(let ((lat-min (truncate->exact lat-minutes))
-	      (long-min (truncate->exact long-minutes)))
-	  (let ((lat-frac (round->exact (* 1000 (- lat-minutes lat-min))))
-		(long-frac (round->exact (* 1000 (- long-minutes long-min)))))
-	    (string-append (cond ((flo:negative? lat) "S")
-				 ((flo:positive? lat) "N")
-				 (else ""))
-			   (number->string lat-deg '(int))
-			   "°"
-			   (string-pad-left (number->string lat-min '(int))
-					    2 #\0)
-			   "."
-			   (string-pad-left (number->string lat-frac '(int))
-					    3 #\0)
-			   "' "
-			   (cond ((flo:negative? long) "W")
-				 ((flo:positive? long) "E")
-				 (else ""))
-			   (number->string long-deg '(int))
-			   "°"
-			   (string-pad-left (number->string long-min '(int))
-					    2 #\0)
-			   "."
-			   (string-pad-left (number->string long-frac '(int))
-					    3 #\0)
-			   "'")))))))
\ No newline at end of file
+    Mx))
\ No newline at end of file
-- 
2.25.1