From dea4d05507e59ab779ed4bb209e05971d87e260c Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Fri, 2 Jul 2010 10:11:35 +0100
Subject: [PATCH] Massive reorganization in progress.

The code is a complete disaster area right now.
---
 .skelrc                                            |   2 +-
 NOTES                                              |  38 -
 builtin.lisp                                       | 350 --------
 class-builder.lisp                                 | 505 ------------
 class-finalize.lisp                                | 291 -------
 class-layout.lisp                                  | 657 ---------------
 combination.lisp                                   | 129 ---
 cutting-room-floor.lisp                            | 195 -----
 sod-backg.tex => doc/sod-backg.tex                 |   0
 doc/sod-protocol.tex                               | 695 ++++++++++++++++
 sod-tut.tex => doc/sod-tut.tex                     |   0
 sod.tex => doc/sod.tex                             |  99 ++-
 .../standard-method-combination.svg                |   0
 emacs-hacks.el                                     |  14 +
 layout.org                                         | 141 ----
 sod.c => lib/sod.c                                 |   6 +-
 sod.h => lib/sod.h                                 |  16 +-
 output.lisp                                        | 259 ------
 pre-reorg/builtin.lisp                             |  42 +
 pre-reorg/c-types.lisp                             |  79 ++
 pre-reorg/class-builder.lisp                       | 129 +++
 class-defs.lisp => pre-reorg/class-defs.lisp       |   0
 pre-reorg/class-finalize.lisp                      |  31 +
 pre-reorg/class-layout.lisp                        |  80 ++
 class-output.lisp => pre-reorg/class-output.lisp   | 201 +++--
 pre-reorg/codegen.lisp                             |  89 +++
 pre-reorg/combination.lisp                         |  34 +
 pre-reorg/cpl.lisp                                 | 133 +++
 pre-reorg/cutting-room-floor.lisp                  | 491 ++++++++++++
 errors.lisp => pre-reorg/errors.lisp               |   7 +-
 examples.lisp => pre-reorg/examples.lisp           |   0
 pre-reorg/foo.lisp                                 |   2 +
 lex.lisp => pre-reorg/lex.lisp                     |  70 +-
 pre-reorg/methods.lisp                             |  43 +
 module-output.lisp => pre-reorg/module-output.lisp |   0
 module.lisp => pre-reorg/module.lisp               | 276 -------
 pre-reorg/output.lisp                              |  63 ++
 parse-c-types.lisp => pre-reorg/parse-c-types.lisp |   0
 posn-stream.lisp => pre-reorg/posn-stream.lisp     |   0
 pset.lisp => pre-reorg/pset.lisp                   | 248 ------
 pre-reorg/sift.lisp                                | 333 ++++++++
 sod.asd => pre-reorg/sod.asd                       |   9 +-
 tables.lisp => pre-reorg/tables.lisp               |   0
 src/builtin.lisp                                   | 306 +++++++
 src/class-utilities.lisp                           | 199 +++++
 src/classes.lisp                                   | 445 +++++++++++
 src/foo.lisp                                       |   7 +
 src/impl-c-types-class.lisp                        | 145 ++++
 c-types.lisp => src/impl-c-types.lisp              | 545 ++++++-------
 cpl.lisp => src/impl-class-finalize.lisp           | 331 +++++---
 src/impl-class-layout.lisp                         | 395 +++++++++
 src/impl-class-make.lisp                           | 240 ++++++
 src/impl-codegen.lisp                              | 199 +++++
 src/impl-lexer.lisp                                | 297 +++++++
 methods.lisp => src/impl-method.lisp               | 537 ++++---------
 src/impl-module.lisp                               | 189 +++++
 src/impl-output.lisp                               |  58 ++
 src/impl-pset.lisp                                 |  83 ++
 src/lexer-bits.lisp                                |  98 +++
 src/output-class.lisp                              | 576 +++++++++++++
 src/package.lisp                                   |  31 +
 src/parse-c-types.lisp                             | 314 ++++++++
 src/parse-lexical.lisp                             | 198 +++++
 src/parser/impl-floc.lisp                          |  47 ++
 src/parser/impl-parser-expr.lisp                   | 219 +++++
 src/parser/impl-parser-plug.lisp                   |  31 +
 src/parser/impl-parser.lisp                        | 166 ++++
 src/parser/impl-scanner-charbuf.lisp               | 433 ++++++++++
 src/parser/impl-scanner-context.lisp               |  88 ++
 src/parser/impl-scanner-token.lisp                 |  78 ++
 src/parser/impl-scanner.lisp                       | 120 +++
 src/parser/impl-streams.lisp                       | 382 +++++++++
 src/parser/opprec.lisp                             |   6 +
 package.lisp => src/parser/package.lisp            |  14 +-
 src/parser/proto-floc.lisp                         | 299 +++++++
 src/parser/proto-parser-expr.lisp                  | 253 ++++++
 src/parser/proto-parser.lisp                       | 890 +++++++++++++++++++++
 src/parser/proto-scanner.lisp                      | 258 ++++++
 src/parser/proto-streams.lisp                      |  46 ++
 src/parser/test-parser.lisp                        | 444 ++++++++++
 src/parser/test-scanner-charbuf.lisp               | 353 ++++++++
 src/proto-c-types.lisp                             | 259 ++++++
 src/proto-class-finalize.lisp                      |  96 +++
 src/proto-class-layout.lisp                        | 320 ++++++++
 src/proto-class-make.lisp                          | 293 +++++++
 codegen.lisp => src/proto-codegen.lisp             | 311 +++----
 src/proto-lexer.lisp                               | 216 +++++
 src/proto-method.lisp                              | 399 +++++++++
 src/proto-module.lisp                              | 202 +++++
 src/proto-output.lisp                              | 171 ++++
 src/proto-pset.lisp                                | 320 ++++++++
 src/scratch.lisp                                   |  16 +
 src/sod-test.asd                                   |  76 ++
 src/sod.asd                                        | 162 ++++
 src/test-base.lisp                                 |  58 ++
 src/test-c-types.lisp                              | 235 ++++++
 src/test-codegen.lisp                              | 121 +++
 src/utilities.lisp                                 | 690 ++++++++++++++++
 chimaera.sod => test/chimaera.sod                  |  10 +-
 utilities.lisp                                     | 411 ----------
 100 files changed, 14713 insertions(+), 4730 deletions(-)
 delete mode 100644 NOTES
 delete mode 100644 builtin.lisp
 delete mode 100644 class-builder.lisp
 delete mode 100644 class-finalize.lisp
 delete mode 100644 class-layout.lisp
 delete mode 100644 combination.lisp
 delete mode 100644 cutting-room-floor.lisp
 rename sod-backg.tex => doc/sod-backg.tex (100%)
 create mode 100644 doc/sod-protocol.tex
 rename sod-tut.tex => doc/sod-tut.tex (100%)
 rename sod.tex => doc/sod.tex (91%)
 rename standard-method-combination.svg => doc/standard-method-combination.svg (100%)
 create mode 100644 emacs-hacks.el
 delete mode 100644 layout.org
 rename sod.c => lib/sod.c (95%)
 rename sod.h => lib/sod.h (91%)
 delete mode 100644 output.lisp
 create mode 100644 pre-reorg/builtin.lisp
 create mode 100644 pre-reorg/c-types.lisp
 create mode 100644 pre-reorg/class-builder.lisp
 rename class-defs.lisp => pre-reorg/class-defs.lisp (100%)
 create mode 100644 pre-reorg/class-finalize.lisp
 create mode 100644 pre-reorg/class-layout.lisp
 rename class-output.lisp => pre-reorg/class-output.lisp (78%)
 create mode 100644 pre-reorg/codegen.lisp
 create mode 100644 pre-reorg/combination.lisp
 create mode 100644 pre-reorg/cpl.lisp
 create mode 100644 pre-reorg/cutting-room-floor.lisp
 rename errors.lisp => pre-reorg/errors.lisp (98%)
 rename examples.lisp => pre-reorg/examples.lisp (100%)
 create mode 100644 pre-reorg/foo.lisp
 rename lex.lisp => pre-reorg/lex.lisp (88%)
 create mode 100644 pre-reorg/methods.lisp
 rename module-output.lisp => pre-reorg/module-output.lisp (100%)
 rename module.lisp => pre-reorg/module.lisp (60%)
 create mode 100644 pre-reorg/output.lisp
 rename parse-c-types.lisp => pre-reorg/parse-c-types.lisp (100%)
 rename posn-stream.lisp => pre-reorg/posn-stream.lisp (100%)
 rename pset.lisp => pre-reorg/pset.lisp (52%)
 create mode 100644 pre-reorg/sift.lisp
 rename sod.asd => pre-reorg/sod.asd (89%)
 rename tables.lisp => pre-reorg/tables.lisp (100%)
 create mode 100644 src/builtin.lisp
 create mode 100644 src/class-utilities.lisp
 create mode 100644 src/classes.lisp
 create mode 100644 src/foo.lisp
 create mode 100644 src/impl-c-types-class.lisp
 rename c-types.lisp => src/impl-c-types.lisp (54%)
 rename cpl.lisp => src/impl-class-finalize.lisp (59%)
 create mode 100644 src/impl-class-layout.lisp
 create mode 100644 src/impl-class-make.lisp
 create mode 100644 src/impl-codegen.lisp
 create mode 100644 src/impl-lexer.lisp
 rename methods.lisp => src/impl-method.lisp (53%)
 create mode 100644 src/impl-module.lisp
 create mode 100644 src/impl-output.lisp
 create mode 100644 src/impl-pset.lisp
 create mode 100644 src/lexer-bits.lisp
 create mode 100644 src/output-class.lisp
 create mode 100644 src/package.lisp
 create mode 100644 src/parse-c-types.lisp
 create mode 100644 src/parse-lexical.lisp
 create mode 100644 src/parser/impl-floc.lisp
 create mode 100644 src/parser/impl-parser-expr.lisp
 create mode 100644 src/parser/impl-parser-plug.lisp
 create mode 100644 src/parser/impl-parser.lisp
 create mode 100644 src/parser/impl-scanner-charbuf.lisp
 create mode 100644 src/parser/impl-scanner-context.lisp
 create mode 100644 src/parser/impl-scanner-token.lisp
 create mode 100644 src/parser/impl-scanner.lisp
 create mode 100644 src/parser/impl-streams.lisp
 create mode 100644 src/parser/opprec.lisp
 rename package.lisp => src/parser/package.lisp (82%)
 create mode 100644 src/parser/proto-floc.lisp
 create mode 100644 src/parser/proto-parser-expr.lisp
 create mode 100644 src/parser/proto-parser.lisp
 create mode 100644 src/parser/proto-scanner.lisp
 create mode 100644 src/parser/proto-streams.lisp
 create mode 100644 src/parser/test-parser.lisp
 create mode 100644 src/parser/test-scanner-charbuf.lisp
 create mode 100644 src/proto-c-types.lisp
 create mode 100644 src/proto-class-finalize.lisp
 create mode 100644 src/proto-class-layout.lisp
 create mode 100644 src/proto-class-make.lisp
 rename codegen.lisp => src/proto-codegen.lisp (66%)
 create mode 100644 src/proto-lexer.lisp
 create mode 100644 src/proto-method.lisp
 create mode 100644 src/proto-module.lisp
 create mode 100644 src/proto-output.lisp
 create mode 100644 src/proto-pset.lisp
 create mode 100644 src/scratch.lisp
 create mode 100644 src/sod-test.asd
 create mode 100644 src/sod.asd
 create mode 100644 src/test-base.lisp
 create mode 100644 src/test-c-types.lisp
 create mode 100644 src/test-codegen.lisp
 create mode 100644 src/utilities.lisp
 rename chimaera.sod => test/chimaera.sod (80%)
 delete mode 100644 utilities.lisp

diff --git a/.skelrc b/.skelrc
index d27ff69..c1d8aa7 100644
--- a/.skelrc
+++ b/.skelrc
@@ -3,7 +3,7 @@
 (setq skel-alist
       (append
        '((author . "Straylight/Edgeware")
-	 (full-title . "the Simple Object Definition system")
+	 (full-title . "the Sensble Object Design, an object system for C")
 	 (program . "SOD")
 	 (licence-text . skelrc-gpl))
        skel-alist))
diff --git a/NOTES b/NOTES
deleted file mode 100644
index c22622c..0000000
--- a/NOTES
+++ /dev/null
@@ -1,38 +0,0 @@
-* Stuff from the ABI spec
-
-** Notation
-
-     * sizeof(O) :: size of an object O
-     * align(O) :: alignment of the object O
-     * offset(C) :: offset of the component C within O
-     * dsize(O) :: data size of the object O (without tail padding)
-     * nvsize(O) :: the /non-virtual/ size of the object O (i.e.,
-       without virtual bases)
-     * nvalign(O) :: the non-virtual alignment of the object O
-
-** Other concepts
-
-     * POD for the purpose of layout :: 
-
-
-* Order of stuff in output files
-
-** Header
-
-  * Multiple inclusion and C++ guards
-  * Forward declarations of structs and typedef names.
-  * User code
-  * Structure definitions
-  * Macros
-  * Function declarations for methods
-
-** Implementation
-
-  * User code
-  * Method and table definitions
-
-* COMMENT
-
-# Local variables:
-# mode: org
-# End:
diff --git a/builtin.lisp b/builtin.lisp
deleted file mode 100644
index 9309581..0000000
--- a/builtin.lisp
+++ /dev/null
@@ -1,350 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Builtin module provides basic definitions
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Output of class instances.
-
-(defun output-imprint-function (class stream)
-  (let ((ilayout (sod-class-ilayout class)))
-    (format stream "~&~:
-/* Imprint raw memory with instance structure. */
-static void *~A__imprint(void *p)
-{
-  struct ~A *sod__obj = p;
-
-  ~:{sod__obj.~A.~A._vt = &~A;~:^~%  ~}
-  return (p);
-}~2%"
-	    class
-	    (ilayout-struct-tag class)
-	    (mapcar (lambda (ichain)
-		      (let* ((head (ichain-head ichain))
-			     (tail (ichain-tail ichain)))
-			(list (sod-class-nickname head)
-			      (sod-class-nickname tail)
-			      (vtable-name class head))))
-		    (ilayout-ichains ilayout)))))
-
-(defun output-init-function (class stream)
-  ;; FIXME this needs a metaobject protocol
-  (let ((ilayout (sod-class-ilayout class)))
-    (format stream "~&~:
-static void *~A__init(void *p)
-{
-  struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
-	    class
-	    (ilayout-struct-tag class))
-    (dolist (ichain (ilayout-ichains ilayout))
-      (let ((ich (format nil "sod__obj.~A.~A"
-			 (sod-class-nickname (ichain-head ichain))
-			 (sod-class-nickname (ichain-tail ichain)))))
-	(dolist (item (ichain-body ichain))
-	  (etypecase item
-	    (vtable-pointer
-	     nil)
-	    (islots
-	     (let ((isl (format nil "~A.~A"
-				ich
-				(sod-class-nickname (islots-class item)))))
-	       (dolist (slot (islots-slots item))
-		 (let ((dslot (effective-slot-direct-slot slot))
-		       (init (effective-slot-initializer slot)))
-		   (when init
-		     (format stream "  ~A =" isl)
-		     (ecase (sod-initializer-value-kind init)
-		       (:simple (write (sod-initializer-value-form init)
-				       :stream stream
-				       :pretty nil :escape nil)
-				(format stream ";~%"))
-		       (:compound (format stream " (~A) {"
-					  (sod-slot-type dslot))
-				  (write (sod-initializer-value-form init)
-					 :stream stream
-					 :pretty nil :escape nil)
-				  (format stream "};~%"))))))))))))
-    (format stream "~&~:
-  return (p);
-}~2%")))
-
-(defun output-supers-vector (class stream)
-  (let ((supers (sod-class-direct-superclasses class)))
-    (when supers
-      (format stream "~&~:
-/* Direct superclasses. */
-static const SodClass *const ~A__supers[] = {
-  ~{~A__class~^,~%  ~}
-};~2%"
-	      class supers))))
-
-(defun output-cpl-vector (class stream)
-  (format stream "~&~:
-/* Class precedence list. */
-static const SodClass *const ~A__cpl[] = {
-  ~{~A__class~^,~%  ~}
-};~2%"
-	  class (sod-class-precedence-list class)))
-
-(defun output-chains-vector (class stream)
-  (let ((chains (sod-class-chains class)))
-    (format stream "~&~:
-/* Chain structure. */
-~1@*~:{static const SodClass *const ~A__chain_~A[] = {
-  ~{~A__class~^,~%  ~}
-};~:^~2%~}
-
-~0@*static const struct sod_chain ~A__chains[] = {
-~:{  { ~3@*~A,
-    ~0@*&~A__chain_~A,
-    ~4@*offsetof(struct ~A, ~A),
-    (const struct sod_vtable *)&~A,
-    sizeof(struct ~A) }~:^,~%~}
-};~2%"
-	    class			;0
-	    (mapcar (lambda (chain)	;1
-		      (let* ((head (sod-class-chain-head (car chain)))
-			     (chain-nick (sod-class-nickname head)))
-			(list class chain-nick			    ;0 1
-			      (reverse chain)			    ;2
-			      (length chain)			    ;3
-			      (ilayout-struct-tag class) chain-nick ;4 5
-			      (vtable-name class head)		    ;6
-			      (ichain-struct-tag class head))))	    ;7
-		    chains))))
-
-(defclass sod-class-slot (sod-slot)
-  ((initializer-function :initarg :initializer-function
-			 :type (or symbol function)
-			 :reader sod-slot-initializer-function)
-   (prepare-function :initarg :prepare-function :type (or symbol function)
-		     :reader sod-slot-prepare-function))
-  (:documentation
-   "Special class for slots defined on SodClass.
-
-   These slots need class-specific initialization.  It's easier to keep all
-   of the information (name, type, and how to initialize them) about these
-   slots in one place, so that's what we do here."))
-
-(defclass sod-magic-class-initializer (sod-class-initializer)
-  ((initializer-function :initarg :initializer-function
-			 :type (or symbol function)
-			 :reader sod-initializer-function)
-   (prepare-function  :initarg :prepare-function
-		      :type (or symbol function)
-		      :reader sod-initializer-prepare-function)))
-
-(defmethod shared-initialize :after
-    ((slot sod-class-slot) slot-names &key pset)
-  (declare (ignore slot-names))
-  (default-slot (slot 'initializer-function)
-    (get-property pset :initializer-function t nil))
-  (default-slot (slot 'prepare-function)
-    (get-property pset :prepare-function t nil)))
-
-(defclass sod-class-effective-slot (effective-slot)
-  ((initializer-function :initarg :initializer-function
-			 :type (or symbol function)
-			 :reader effective-slot-initializer-function)
-   (prepare-function :initarg :prepare-function :type (or symbol function)
-		     :reader effective-slot-prepare-function))
-  (:documentation
-   "Special class for slots defined on SodClass.
-
-   This class ignores any explicit initializers and computes initializer
-   values using the slot's INIT-FUNC slot and a magical protocol during
-   metaclass instance construction."))
-
-(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
-  (make-instance 'sod-class-effective-slot
-		 :class class :slot slot
-		 :initializer-function (sod-slot-initializer-function slot)
-		 :prepare-function (sod-slot-prepare-function slot)
-		 :initializer (find-slot-initializer class slot)))
-
-;;;--------------------------------------------------------------------------
-;;; Class slots table.
-
-(defparameter *sod-class-slots*
-  `(
-
-    ;; Basic informtion.
-    ("name" ,(c-type const-string)
-	    :initializer-function
-	    ,(lambda (class)
-	       (prin1-to-string (sod-class-name class))))
-    ("nick" ,(c-type const-string)
-	    :initializer-function
-	    ,(lambda (class)
-	       (prin1-to-string (sod-class-nickname class))))
-
-    ;; Instance allocation and initialization.
-    ("instsz" ,(c-type size-t)
-	      :initializer-function
-	      ,(lambda (class)
-		 (format nil "sizeof(struct ~A)"
-			 (ilayout-struct-tag class))))
-    ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
-	       :prepare-function output-imprint-function
-	       :initializer-function
-	       ,(lambda (class)
-		  (format nil "~A__imprint" class)))
-    ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
-	    :prepare-function output-init-function
-	    :initializer-function
-	    ,(lambda (class)
-	       (format nil "~A__init" class)))
-
-    ;; Superclass structure.
-    ("n_supers" ,(c-type size-t)
-		:initializer-function
-		,(lambda (class)
-		   (length (sod-class-direct-superclasses class))))
-    ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
-	      :prepare-function output-supers-vector
-	      :initializer-function
-	      ,(lambda (class)
-		 (if (sod-class-direct-superclasses class)
-		     (format nil "~A__supers" class)
-		     0)))
-    ("n_cpl" ,(c-type size-t)
-	     :initializer-function
-		,(lambda (class)
-		   (length (sod-class-precedence-list class))))
-    ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
-	   :prepare-function output-cpl-vector
-	   :initializer-function
-	   ,(lambda (class)
-	      (format nil "~A__cpl" class)))
-
-    ;; Chain structure.
-    ("link" ,(c-type (* (class "SodClass" :const)))
-	    :initializer-function
-	    ,(lambda (class)
-	       (let ((link (sod-class-chain-link class)))
-		 (if link
-		     (format nil "~A__class" link)
-		     0))))
-    ("head" ,(c-type (* (class "SodClass" :const)))
-	    :initializer-function
-	    ,(lambda (class)
-	       (format nil "~A__class" (sod-class-chain-head class))))
-    ("level" ,(c-type size-t)
-	     :initializer-function
-	     ,(lambda (class)
-		(position class (reverse (sod-class-chain class)))))
-    ("n_chains" ,(c-type size-t)
-		:initializer-function
-		,(lambda (class)
-		   (length (sod-class-chains class))))
-    ("chains" ,(c-type (* (struct "sod_chain" :const)))
-	      :prepare-function output-chains-vector
-	      :initializer-function
-	      ,(lambda (class)
-		 (format nil "~A__chains" class)))
-
-    ;; Class-specific layout.
-    ("off_islots" ,(c-type size-t)
-		  :initializer-function
-		  ,(lambda (class)
-		     (format nil "offsetof(struct ~A, ~A)"
-			     (ichain-struct-tag class
-						(sod-class-chain-head class))
-			     (sod-class-nickname class))))
-    ("islotsz" ,(c-type size-t)
-	       :initializer-function
-	       ,(lambda (class)
-		  (format nil "sizeof(struct ~A)"
-			  (islots-struct-tag class))))))
-
-;;;--------------------------------------------------------------------------
-;;; Bootstrapping the class graph.
-
-(defun bootstrap-classes (module)
-  (let* ((sod-object (make-sod-class "SodObject" nil
-				     (make-property-set :nick 'obj)))
-	 (sod-class (make-sod-class "SodClass" (list sod-object)
-				    (make-property-set :nick 'cls)))
-	 (classes (list sod-object sod-class)))
-
-    ;; Sort out the recursion.
-    (setf (slot-value sod-class 'chain-link) sod-object)
-    (dolist (class classes)
-      (setf (slot-value class 'metaclass) sod-class))
-
-    ;; Predeclare the class types.
-    (dolist (class classes)
-      (make-class-type (sod-class-name class)))
-
-    ;; Attach the class slots.
-    (loop for (name type . plist) in *sod-class-slots*
-	  do (make-sod-slot sod-class name type
-			    (apply #'make-property-set
-				   :lisp-class 'sod-class-slot
-				   plist)))
-
-    ;; These classes are too closely intertwined.  We must partially finalize
-    ;; them together by hand.  This is cloned from FINALIZE-SOD-CLASS.
-    (dolist (class classes)
-      (with-slots (class-precedence-list chain-head chain chains) class
-	(setf class-precedence-list (compute-cpl class))
-	(setf (values chain-head chain chains) (compute-chains class))))
-
-    ;; Done.
-    (dolist (class classes)
-      (finalize-sod-class class)
-      (add-to-module module class))))
-
-(defun make-builtin-module ()
-  (let ((module (make-instance 'module
-			       :name (make-pathname :name "SOD-BASE"
-						    :type "SOD"
-						    :case :common)
-			       :state nil))
-	(*type-map* (make-hash-table :test #'equal)))
-    (dolist (name '("va_list" "size_t" "ptrdiff_t"))
-      (add-to-module module (make-instance 'type-item :name name)))
-    (bootstrap-classes module)
-    module))
-
-(defun reset-builtin-module ()
-  (setf *builtin-module* (make-builtin-module))
-  (module-import *builtin-module*))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(define-sod-class "AbstractStack" ("SodObject")
-  :nick 'abstk
-  (message "emptyp" (fun int))
-  (message "push" (fun void ("item" (* void))))
-  (message "pop" (fun (* void)))
-  (method "abstk" "pop" (fun void) #{
-     assert(!me->_vt.emptyp());
-   }
-   :role :before))
-
-;;;----- That's all, folks --------------------------------------------------
diff --git a/class-builder.lisp b/class-builder.lisp
deleted file mode 100644
index 59dd4ee..0000000
--- a/class-builder.lisp
+++ /dev/null
@@ -1,505 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Equipment for building classes and friends
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Finding things by name
-
-(defun find-superclass-by-nick (class nick)
-  "Returns the superclass of CLASS with nickname NICK, or signals an error."
-
-  ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
-  ;; trundle through its superclasses and hope for the best.
-  (if (string= nick (sod-class-nickname class))
-      class
-      (or (some (lambda (super)
-		  (find nick (sod-class-precedence-list super)
-			:key #'sod-class-nickname
-			:test #'string=))
-		(sod-class-direct-superclasses class))
-	  (error "No superclass of `~A' with nickname `~A'" class nick))))
-
-(flet ((find-item-by-name (what class list name key)
-	 (or (find name list :key key :test #'string=)
-	     (error "No ~A in class `~A' with name `~A'" what class name))))
-
-  (defun find-instance-slot-by-name (class super-nick slot-name)
-    (let ((super (find-superclass-by-nick class super-nick)))
-      (find-item-by-name "slot" super (sod-class-slots super)
-			 slot-name #'sod-slot-name)))
-
-  (defun find-class-slot-by-name (class super-nick slot-name)
-    (let* ((meta (sod-class-metaclass class))
-	   (super (find-superclass-by-nick meta super-nick)))
-      (find-item-by-name "slot" super (sod-class-slots super)
-			 slot-name #'sod-slot-name)))
-
-  (defun find-message-by-name (class super-nick message-name)
-    (let ((super (find-superclass-by-nick class super-nick)))
-      (find-item-by-name "message" super (sod-class-messages super)
-			 message-name #'sod-message-name))))
-
-;;;--------------------------------------------------------------------------
-;;; Class construction.
-
-(defun make-sod-class (name superclasses pset &optional location)
-  "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
-
-   This is the main constructor function for classes.  The protocol works as
-   follows.  The :LISP-CLASS property in PSET is checked: if it exists, it
-   must be a symbol naming a (CLOS) class, which is used in place of
-   SOD-CLASS.  All of the arguments are then passed to MAKE-INSTANCE; further
-   behaviour is left to the standard CLOS instance construction protocol; for
-   example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
-
-   Minimal sanity checking is done during class construction; most of it is
-   left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
-
-   Unused properties in PSET are diagnosed as errors."
-
-  (with-default-error-location (location)
-    (let ((class (make-instance (get-property pset :lisp-class :symbol
-					      'sod-class)
-				:name name
-				:superclasses superclasses
-				:location (file-location location)
-				:pset pset)))
-      (check-unused-properties pset)
-      class)))
-
-(defgeneric guess-metaclass (class)
-  (:documentation
-   "Determine a suitable metaclass for the CLASS.
-
-   The default behaviour is to choose the most specific metaclass of any of
-   the direct superclasses of CLASS, or to signal an error if that failed."))
-
-(defmethod guess-metaclass ((class sod-class))
-  "Default metaclass-guessing function for classes.
-
-   Return the most specific metaclass of any of the CLASS's direct
-   superclasses."
-  (do ((supers (sod-class-direct-superclasses class) (cdr supers))
-       (meta nil (let ((candidate (sod-class-metaclass (car supers))))
-		   (cond ((null meta) candidate)
-			 ((sod-subclass-p meta candidate) meta)
-			 ((sod-subclass-p candidate meta) candidate)
-			 (t (error "Unable to choose metaclass for `~A'"
-				   class))))))
-      ((endp supers) meta)))
-
-(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
-  "Specific behaviour for SOD class initialization.
-
-   Properties inspected are as follows:
-
-     * :METACLASS names the metaclass to use.  If unspecified, NIL is stored,
-       and (unless you intervene later) GUESS-METACLASS will be called by
-       FINALIZE-SOD-CLASS to find a suitable default.
-
-     * :NICK provides a nickname for the class.  If unspecified, a default
-       (the class's name, forced to lowercase) will be chosen in
-       FINALIZE-SOD-CLASS.
-
-     * :LINK names the chained superclass.  If unspecified, this class will
-       be left at the head of its chain."
-
-  ;; If no nickname, copy the class name.  It won't be pretty, though.
-  (default-slot (class 'nickname)
-    (get-property pset :nick :id (string-downcase (slot-value class 'name))))
-
-  ;; If no metaclass, guess one in a (Lisp) class-specific way.
-  (default-slot (class 'metaclass)
-    (multiple-value-bind (name floc) (get-property pset :metaclass :id)
-      (if floc
-	  (find-sod-class name floc)
-	  (guess-metaclass class))))
-
-  ;; If no chain-link, then start a new chain here.
-  (default-slot (class 'chain-link)
-    (multiple-value-bind (name floc) (get-property pset :link :id)
-      (if floc
-	  (find-sod-class name floc)
-	  nil))))
-
-;;;--------------------------------------------------------------------------
-;;; Slot construction.
-
-(defgeneric make-sod-slot (class name type pset &optional location)
-  (:documentation
-   "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
-
-   This is the main constructor function for slots.  This is a generic
-   function primarily so that the CLASS can intervene in the construction
-   process.  The default method uses the :LISP-CLASS property (defaulting to
-   SOD-SLOT) to choose a (CLOS) class to instantiate.  The slot is then
-   constructed by MAKE-INSTANCE passing the arguments as initargs; further
-   behaviour is left to the standard CLOS instance construction protocol; for
-   example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
-
-   Unused properties on PSET are diagnosed as errors."))
-
-(defmethod make-sod-slot
-    ((class sod-class) name type pset &optional location)
-  (with-default-error-location (location)
-    (let ((slot (make-instance (get-property pset :lisp-class :symbol
-					     'sod-slot)
-			       :class class
-			       :name name
-			       :type type
-			       :location (file-location location)
-			       :pset pset)))
-      (with-slots (slots) class
-	(setf slots (append slots (list slot))))
-      (check-unused-properties pset))))
-
-(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
-  "This method exists so that it isn't an error to provide a :PSET initarg
-   to (make-instance 'sod-slot ...).  It does nothing."
-  (declare (ignore slot-names pset))
-  nil)
-
-;;;--------------------------------------------------------------------------
-;;; Slot initializer construction.
-
-(defgeneric make-sod-instance-initializer
-    (class nick name value-kind value-form pset &optional location)
-  (:documentation
-   "Construct and attach an instance slot initializer, to CLASS.
-
-   This is the main constructor function for instance initializers.  This is
-   a generic function primarily so that the CLASS can intervene in the
-   construction process.  The default method looks up the slot using
-   FIND-INSTANCE-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to
-   actually make the initializer object, and adds it to the appropriate list
-   in CLASS.
-
-   Unused properties on PSET are diagnosed as errors."))
-
-(defgeneric make-sod-class-initializer
-    (class nick name value-kind value-form pset &optional location)
-  (:documentation
-   "Construct and attach a class slot initializer, to CLASS.
-
-   This is the main constructor function for class initializers.  This is a
-   generic function primarily so that the CLASS can intervene in the
-   construction process.  The default method looks up the slot using
-   FIND-CLASS-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to actually
-   make the initializer object, and adds it to the appropriate list in CLASS.
-
-   Unused properties on PSET are diagnosed as errors."))
-
-(defgeneric make-sod-initializer-using-slot
-    (class slot init-class value-kind value-form pset location)
-  (:documentation
-   "Common construction protocol for slot initializers.
-
-   This generic function does the common work for constructing instance and
-   class initializers.  It can usefully be specialized according to both the
-   class and slot types.  The default method uses the :LISP-CLASS property
-   (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate.  The
-   slot is then constructed by MAKE-INSTANCE passing the arguments as
-   initargs; further behaviour is left to the standard CLOS instance
-   construction protocol; for example, SOD-INITIALIZER defines
-   an :AFTER-method on SHARED-INITIALIZE.
-
-   Diagnosing unused properties is left for the caller (usually
-   MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do.  The
-   caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if
-   appropriate.
-
-   You are not expected to call this generic function directly; it's more
-   useful as a place to hang methods for custom initializer classes."))
-
-(defmethod make-sod-instance-initializer
-    ((class sod-class) nick name value-kind value-form pset
-     &optional location)
-  (with-default-error-location (location)
-    (let* ((slot (find-instance-slot-by-name class nick name))
-	   (initializer (make-sod-initializer-using-slot
-			 class slot 'sod-instance-initializer
-			 value-kind value-form pset
-			 (file-location location))))
-      (with-slots (instance-initializers) class
-	(setf instance-initializers (append instance-initializers
-					    (list initializer))))
-      (check-unused-properties pset))))
-
-(defmethod make-sod-class-initializer
-    ((class sod-class) nick name value-kind value-form pset
-     &optional location)
-  (with-default-error-location (location)
-    (let* ((slot (find-class-slot-by-name class nick name))
-	   (initializer (make-sod-initializer-using-slot
-			class slot 'sod-class-initializer
-			value-kind value-form pset
-			(file-location location))))
-      (with-slots (class-initializers) class
-	(setf class-initializers (append class-initializers
-					 (list initializer))))
-      (check-unused-properties pset))))
-
-(defmethod make-sod-initializer-using-slot
-    ((class sod-class) (slot sod-slot)
-     init-class value-kind value-form pset location)
-  (make-instance (get-property pset :lisp-class :symbol init-class)
-		 :class class
-		 :slot slot
-		 :value-kind value-kind
-		 :value-form value-form
-		 :location location
-		 :pset pset))
-
-(defmethod shared-initialize :after
-    ((init sod-initializer) slot-names &key pset)
-  "This method exists so that it isn't an error to provide a :PSET initarg
-   to (make-instance 'sod-initializer ...).  It does nothing."
-  (declare (ignore slot-names pset))
-  nil)
-
-;;;--------------------------------------------------------------------------
-;;; Message construction.
-
-(defgeneric make-sod-message (class name type pset &optional location)
-  (:documentation
-   "Construct and attach a new message with given NAME and TYPE, to CLASS.
-
-   This is the main constructor function for messages.  This is a generic
-   function primarily so that the CLASS can intervene in the construction
-   process.  The default method uses the :LISP-CLASS property (defaulting to
-   SOD-MESSAGE) to choose a (CLOS) class to instantiate.  The message is then
-   constructed by MAKE-INSTANCE passing the arguments as initargs; further
-   behaviour is left to the standard CLOS instance construction protocol; for
-   example, SOD-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE.
-
-   Unused properties on PSET are diagnosed as errors."))
-
-(defgeneric check-message-type (message type)
-  (:documentation
-   "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.
-
-   This is separated out of SHARED-INITIALIZE, where it's called, so that it
-   can be overridden conveniently by subclasses."))
-
-(defmethod make-sod-message
-    ((class sod-class) name type pset &optional location)
-  (with-default-error-location (location)
-    (let ((message (make-instance (get-property pset :lisp-class :symbol
-						'standard-message)
-			       :class class
-			       :name name
-			       :type type
-			       :location (file-location location)
-			       :pset pset)))
-      (with-slots (messages) class
-	(setf messages (append messages (list message))))
-      (check-unused-properties pset))))
-
-(defmethod check-message-type ((message sod-message) (type c-function-type))
-  nil)
-(defmethod check-message-type ((message sod-message) (type c-type))
-  (error "Messages must have function type, not ~A" type))
-
-(defmethod shared-initialize :after
-    ((message sod-message) slot-names &key pset)
-  (declare (ignore slot-names pset))
-  (with-slots (type) message
-    (check-message-type message type)))
-
-;;;--------------------------------------------------------------------------
-;;; Method construction.
-
-(defgeneric make-sod-method
-    (class nick name type body pset &optional location)
-  (:documentation
-   "Construct and attach a new method to CLASS.
-
-   This is the main constructor function for methods.  This is a generic
-   function primarily so that the CLASS can intervene in the message lookup
-   process, though this is actually a fairly unlikely occurrence.
-
-   The default method looks up the message using FIND-MESSAGE-BY-NAME,
-   invokes MAKE-SOD-METHOD-USING-MESSAGE to make the method object, and then
-   adds the method to the class's list of methods.  This split allows the
-   message class to intervene in the class selection process, for example.
-
-   Unused properties on PSET are diagnosed as errors."))
-
-(defgeneric make-sod-method-using-message
-    (message class type body pset location)
-  (:documentation
-   "Main construction subroutine for method construction.
-
-   This is a generic function so that it can be specialized according to both
-   a class and -- more particularly -- a message.  The default method uses
-   the :LISP-CLASS property (defaulting to calling SOD-MESSAGE-METHOD-CLASS)
-   to choose a (CLOS) class to instantiate.  The method is then constructed
-   by MAKE-INSTANCE passing the arguments as initargs; further behaviour is
-   left to the standard CLOS instance construction protocol; for example,
-   SOD-METHOD defines an :AFTER-method on SHARED-INITIALIZE.
-
-   Diagnosing unused properties is left for the caller (usually
-   MAKE-SOD-METHOD) to do.  The caller is also expected to have set
-   WITH-DEFAULT-ERROR-LOCATION if appropriate.
-
-   You are not expected to call this generic function directly; it's more
-   useful as a place to hang methods for custom initializer classes."))
-
-(defgeneric sod-message-method-class (message class pset)
-  (:documentation
-   "Return the preferred class for methods on MESSAGE.
-
-   The message can inspect the PSET to decide on a particular message.  A
-   :LISP-CLASS property will usually override this decision: it's then the
-   programmer's responsibility to ensure that the selected method class is
-   appropriate."))
-
-(defgeneric check-method-type (method message type)
-  (:documentation
-   "Check that TYPE is a suitable type for METHOD.  Signal errors if not.
-
-   This is separated out of SHARED-INITIALIZE, where it's called, so that it
-   can be overridden conveniently by subclasses."))
-
-(defmethod make-sod-method
-    ((class sod-class) nick name type body pset &optional location)
-  (with-default-error-location (location)
-    (let* ((message (find-message-by-name class nick name))
-	   (method (make-sod-method-using-message message class
-						  type body pset
-						  (file-location location))))
-      (with-slots (methods) class
-	(setf methods (append methods (list method)))))
-    (check-unused-properties pset)))
-
-(defmethod make-sod-method-using-message
-    ((message sod-message) (class sod-class) type body pset location)
-  (make-instance (or (get-property pset :lisp-class :symbol)
-		     (sod-message-method-class message class pset))
-		 :message message
-		 :class class
-		 :type type
-		 :body body
-		 :location location
-		 :pset pset))
-
-(defmethod sod-message-method-class
-    ((message sod-message) (class sod-class) pset)
-  (declare (ignore pset))
-  'sod-method)
-
-(defmethod check-method-type
-    ((method sod-method) (message sod-message) (type c-type))
-  (error "Methods must have function type, not ~A" type))
-
-(defun argument-lists-compatible-p (message-args method-args)
-  "Compare argument lists for compatibility.
-
-   Return true if METHOD-ARGS is a suitable method argument list
-   corresponding to the message argument list MESSAGE-ARGS.  This is the case
-   if the lists are the same length, each message argument has a
-   corresponding method argument with the same type, and if the message
-   arguments end in an ellpisis, the method arguments must end with a
-   `va_list' argument.  (We can't pass actual variable argument lists around,
-   except as `va_list' objects, which are devilish inconvenient things and
-   require much hacking.  See the method combination machinery for details.)"
-
-  (and (= (length message-args) (length method-args))
-       (every (lambda (message-arg method-arg)
-		(if (eq message-arg :ellipsis)
-		    (eq method-arg (c-type va-list))
-		    (c-type-equal-p (argument-type message-arg)
-				    (argument-type method-arg))))
-	      message-args method-args)))
-
-(defmethod check-method-type
-    ((method sod-method) (message sod-message) (type c-function-type))
-  (with-slots ((msgtype type)) message
-    (unless (c-type-equal-p (c-type-subtype msgtype)
-			    (c-type-subtype type))
-      (error "Method return type ~A doesn't match message ~A"
-	      (c-type-subtype msgtype) (c-type-subtype type)))
-    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
-					 (c-function-arguments type))
-      (error "Method arguments ~A don't match message ~A" type msgtype))))
-
-(defmethod shared-initialize :after
-    ((method sod-method) slot-names &key pset)
-  (declare (ignore slot-names pset))
-
-  ;; Check that the arguments are named if we have a method body.
-  (with-slots (body type) method
-    (unless (or (not body)
-		(every #'argument-name (c-function-arguments type)))
-      (error "Abstract declarators not permitted in method definitions")))
-
-  ;; Check the method type.
-  (with-slots (message type) method
-    (check-method-type method message type)))
-
-;;;--------------------------------------------------------------------------
-;;; Builder macros.
-
-(defmacro define-sod-class (name (&rest superclasses) &body body)
-  (let ((plist nil)
-	(classvar (gensym "CLASS")))
-    (loop
-      (when (or (null body)
-		(not (keywordp (car body))))
-	(return))
-      (push (pop body) plist)
-      (push (pop body) plist))
-    `(let ((,classvar (make-sod-class ,name
-				      (mapcar #'find-sod-class
-					      (list ,@superclasses))
-				      (make-property-set
-				       ,@(nreverse plist)))))
-       (macrolet ((message (name type &rest plist)
-		    `(make-sod-message ,',classvar ,name (c-type ,type)
-				       (make-property-set ,@plist)))
-		  (method (nick name type body &rest plist)
-		    `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
-				      ,body (make-property-set ,@plist)))
-		  (slot (name type &rest plist)
-		    `(make-sod-slot ,',classvar ,name (c-type ,type)
-				    (make-property-set ,@plist)))
-		  (instance-initializer
-		      (nick name value-kind value-form &rest plist)
-		    `(make-sod-instance-initializer ,',classvar ,nick ,name
-						    ,value-kind ,value-form
-						    (make-property-set
-						     ,@plist)))
-		  (class-initializer
-		      (nick name value-kind value-form &rest plist)
-		    `(make-sod-class-initializer ,',classvar ,nick ,name
-						 ,value-kind ,value-form
-						 (make-property-set
-						  ,@plist))))
-	 ,@body
-	 (finalize-sod-class ,classvar)
-	 (add-to-module *module* ,classvar)))))
-
-;;;----- That's all, folks --------------------------------------------------
diff --git a/class-finalize.lisp b/class-finalize.lisp
deleted file mode 100644
index fa8cc7d..0000000
--- a/class-finalize.lisp
+++ /dev/null
@@ -1,291 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Class finalization
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Class finalization.
-
-;; Protocol.
-
-(defgeneric compute-chains (class)
-  (:documentation
-   "Compute the layout chains for CLASS.
-
-   Returns the following three values.
-
-     * the head of the class's primary chain;
-
-     * the class's primary chain as a list, most- to least-specific; and
-
-     * the complete collection of chains, as a list of lists, each most- to
-       least-specific, with the primary chain first.
-
-   These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots.
-
-   If the chains are ill-formed (i.e., not distinct) then an error is
-   signalled."))
-
-(defgeneric check-sod-class (class)
-  (:documentation
-   "Check the CLASS for validity.
-
-   This is done as part of class finalization.  The checks performed are as
-   follows.
-
-     * The class name and nickname, and the names of messages, obey the
-       rules (see VALID-NAME-P).
-
-     * The messages and slots have distinct names.
-
-     * The classes in the class-precedence-list have distinct nicknames.
-
-     * The chain-link is actually a proper (though not necessarily direct)
-       superclass.
-
-     * The chosen metaclass is actually a subclass of all of the
-       superclasses' metaclasses.
-
-   Returns true if all is well; false (and signals errors) if anything was
-   wrong."))
-
-(defgeneric finalize-sod-class (class)
-  (:documentation
-   "Computes all of the gory details about a class.
-
-   Once one has stopped inserting methods and slots and so on into a class,
-   one needs to finalize it to determine the layout structure and the class
-   precedence list and so on.  More precisely that gets done is this:
-
-     * Related classes (i.e., direct superclasses and the metaclass) are
-       finalized if they haven't been already.
-
-     * If you've been naughty and failed to store a list of slots or
-       whatever, then an empty list is inserted.
-
-     * The class precedence list is computed and stored.
-
-     * The class is checked for compiance with the well-formedness rules.
-
-     * The layout chains are computed.
-
-   Other stuff will need to happen later, but it's not been done yet.  In
-   particular:
-
-     * Actually computing the layout of the instance and the virtual tables.
-
-     * Combining the applicable methods into effective methods.
-
-   FIXME this needs doing."))
-
-;; Implementation.
-
-(defun sod-subclass-p (class-a class-b)
-  "Return whether CLASS-A is a descendent of CLASS-B."
-  (member class-b (sod-class-precedence-list class-a)))
-
-(defun valid-name-p (name)
-  "Checks whether NAME is a valid name.
-
-   The rules are:
-
-     * the name must be a string
-     * which is nonempty
-     * whose first character is alphabetic
-     * all of whose characters are alphanumeric or underscores
-     * and which doesn't contain two consecutive underscores."
-
-  (and (stringp name)
-       (plusp (length name))
-       (alpha-char-p (char name 0))
-       (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
-       (not (search "__" name))))
-
-(defmethod compute-chains ((class sod-class))
-  (with-default-error-location (class)
-    (with-slots (chain-link class-precedence-list) class
-      (let* ((head (if chain-link
-		       (sod-class-chain-head chain-link)
-		       class))
-	     (chain (cons class (and chain-link
-				     (sod-class-chain chain-link))))
-	     (table (make-hash-table)))
-
-	;; Check the chains.  We work through each superclass, maintaining a
-	;; hash table keyed by class.  If we encounter a class C which links
-	;; to L, then we store C as L's value; if L already has a value then
-	;; we've found an error.  By the end of all of this, the classes
-	;; which don't have an entry are the chain tails.
-	(dolist (super class-precedence-list)
-	  (let ((link (sod-class-chain-link super)))
-	    (when link
-	      (when (gethash link table)
-		(error "Conflicting chains in class ~A: ~
-			(~A and ~A both link to ~A)"
-		       class super (gethash link table) link))
-	      (setf (gethash link table) super))))
-
-	;; Done.
-	(values head chain
-		(cons chain
-		      (mapcar #'sod-class-chain
-			      (remove-if (lambda (super)
-					   (gethash super table))
-					 (cdr class-precedence-list)))))))))
-
-(defmethod check-sod-class ((class sod-class))
-  (with-default-error-location (class)
-
-    ;; Check the names of things are valid.
-    (with-slots (name nickname messages) class
-      (unless (valid-name-p name)
-	(error "Invalid class name `~A'" class))
-      (unless (valid-name-p nickname)
-	(error "Invalid class nickname `~A' on class `~A'" nickname class))
-      (dolist (message messages)
-	(unless (valid-name-p (sod-message-name message))
-	  (error "Invalid message name `~A' on class `~A'"
-		 (sod-message-name message) class))))
-
-    ;; Check that the slots and messages have distinct names.
-    (with-slots (slots messages class-precedence-list) class
-      (flet ((check-list (list what namefunc)
-	       (let ((table (make-hash-table :test #'equal)))
-		 (dolist (item list)
-		   (let ((name (funcall namefunc item)))
-		     (if (gethash name table)
-			 (error "Duplicate ~A name `~A' on class `~A'"
-				what name class)
-			 (setf (gethash name table) item)))))))
-	(check-list slots "slot" #'sod-slot-name)
-	(check-list messages "message" #'sod-message-name)
-	(check-list class-precedence-list "nickname" #'sod-class-name)))
-
-    ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
-    ;; eliminates hairy things like a class being its own link.)
-    (with-slots (class-precedence-list chain-link) class
-      (unless (or (not chain-link)
-		  (member chain-link (cdr class-precedence-list)))
-	(error "In `~A~, chain-to class `~A' is not a proper superclass"
-	       class chain-link)))
-
-    ;; Check for circularity in the superclass graph.  Since the superclasses
-    ;; should already be acyclic, it suffices to check that our class is not
-    ;; a superclass of any of its own direct superclasses.
-    (let ((circle (find-if (lambda (super)
-			     (sod-subclass-p super class))
-			   (sod-class-direct-superclasses class))))
-      (when circle
-	(error "Circularity: ~A is already a superclass of ~A"
-	       class circle)))
-
-    ;; Check that the class has a unique root superclass.
-    (find-root-superclass class)
-
-    ;; Check that the metaclass is a subclass of each direct superclass's
-    ;; metaclass.
-    (with-slots (metaclass direct-superclasses) class
-      (dolist (super direct-superclasses)
-	(unless (sod-subclass-p metaclass (sod-class-metaclass super))
-	  (error "Incompatible metaclass for `~A': ~
-		  `~A' isn't a subclass of `~A' (of `~A')"
-		 class metaclass (sod-class-metaclass super) super))))))
-
-(defmethod finalize-sod-class ((class sod-class))
-
-  ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
-  ;; clone of the CPL and chain establishment code.  If the interface changes
-  ;; then BOOTSTRAP-CLASSES will need to be changed too.
-
-  (with-default-error-location (class)
-    (ecase (sod-class-state class)
-      ((nil)
-
-       ;; If this fails, mark the class as a loss.
-       (setf (sod-class-state class) :broken)
-
-       ;; Finalize all of the superclasses.  There's some special pleading
-       ;; here to make bootstrapping work: we don't try to finalize the
-       ;; metaclass if we're a root class (no direct superclasses -- because
-       ;; in that case the metaclass will have to be a subclass of us!), or
-       ;; if it's equal to us.  This is enough to tie the knot at the top of
-       ;; the class graph.
-       (with-slots (name direct-superclasses metaclass) class
-	 (dolist (super direct-superclasses)
-	   (finalize-sod-class super))
-	 (unless (or (null direct-superclasses)
-		     (eq class metaclass))
-	   (finalize-sod-class metaclass)))
-
-       ;; Stash the class's type.
-       (setf (sod-class-type class)
-	     (make-class-type (sod-class-name class)))
-
-       ;; Clobber the lists of items if they've not been set.
-       (dolist (slot '(slots instance-initializers class-initializers
-		       messages methods))
-	 (unless (slot-boundp class slot)
-	   (setf (slot-value class slot) nil)))
-
-       ;; If the CPL hasn't been done yet, compute it.
-       (with-slots (class-precedence-list) class
-	 (unless (slot-boundp class 'class-precedence-list)
-	   (setf class-precedence-list (compute-cpl class))))
-
-       ;; If no metaclass has been established, then choose one.
-       (with-slots (metaclass) class
-	 (unless (and (slot-boundp class 'metaclass) metaclass)
-	   (setf metaclass (guess-metaclass class))))
-
-       ;; If no nickname has been set, choose a default.  This might cause
-       ;; conflicts, but, well, the user should have chosen an explicit
-       ;; nickname.
-       (with-slots (name nickname) class
-	 (unless (and (slot-boundp class 'nickname) nickname)
-	   (setf nickname (string-downcase name))))
-
-       ;; Check that the class is fairly sane.
-       (check-sod-class class)
-
-       ;; Determine the class's layout.
-       (with-slots (chain-head chain chains) class
-	 (setf (values chain-head chain chains) (compute-chains class)))
-
-       (with-slots (ilayout effective-methods vtables) class
-	 (setf ilayout (compute-ilayout class))
-	 (setf effective-methods (compute-effective-methods class))
-	 (setf vtables (compute-vtables class)))
-
-       ;; Done.
-       (setf (sod-class-state class) :finalized)
-       t)
-
-      (:broken
-       nil)
-
-      (:finalized
-       t))))
-
-;;;----- That's all, folks --------------------------------------------------
diff --git a/class-layout.lisp b/class-layout.lisp
deleted file mode 100644
index 8770739..0000000
--- a/class-layout.lisp
+++ /dev/null
@@ -1,657 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Layout for instances and vtables
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Effective slot objects.
-
-(defclass effective-slot ()
-  ((class :initarg :class :type sod-slot :reader effective-slot-class)
-   (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
-   (initializer :initarg :initializer :type (or sod-initializer null)
-		:reader effective-slot-initializer))
-  (:documentation
-   "Describes a slot and how it's meant to be initialized.
-
-   Effective slot objects are usually attached to layouts."))
-
-(defgeneric find-slot-initializer (class slot)
-  (:documentation
-   "Return the most specific initializer for SLOT, starting from CLASS."))
-
-(defgeneric compute-effective-slot (class slot)
-  (:documentation
-   "Construct an effective slot from the supplied direct slot.
-
-   SLOT is a direct slot defined on CLASS or one of its superclasses.
-   (Metaclass initializers are handled using a different mechanism.)"))
-
-(defmethod print-object ((slot effective-slot) stream)
-  (maybe-print-unreadable-object (slot stream :type t)
-    (format stream "~A~@[ = ~@_~A~]"
-	    (effective-slot-direct-slot slot)
-	    (effective-slot-initializer slot))))
-
-(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
-  (some (lambda (super)
-	  (find slot
-		(sod-class-instance-initializers super)
-		:key #'sod-initializer-slot))
-	(sod-class-precedence-list class)))
-
-(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
-  (make-instance 'effective-slot
-		 :slot slot
-		 :class class
-		 :initializer (find-slot-initializer class slot)))
-
-;;;--------------------------------------------------------------------------
-;;; Instance layout objects.
-
-;;; islots
-
-(defclass islots ()
-  ((class :initarg :class :type sod-class :reader islots-class)
-   (subclass :initarg :subclass :type sod-class :reader islots-subclass)
-   (slots :initarg :slots :type list :reader islots-slots))
-  (:documentation
-   "The collection of effective SLOTS defined by an instance of CLASS."))
-
-(defmethod print-object ((islots islots) stream)
-  (print-unreadable-object (islots stream :type t)
-    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (islots-subclass islots)
-	    (islots-class islots)
-	    (islots-slots islots))))
-
-(defgeneric compute-islots (class subclass)
-  (:documentation
-   "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS.
-
-   Initializers for the slots should be taken from the most specific
-   superclass of SUBCLASS."))
-
-;;; vtable-pointer
-
-(defclass vtable-pointer ()
-  ((class :initarg :class :type sod-class :reader vtable-pointer-class)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader vtable-pointer-chain-head)
-   (chain-tail :initarg :chain-tail :type sod-class
-	       :reader vtable-pointer-chain-tail))
-  (:documentation
-   "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
-
-(defmethod print-object ((vtp vtable-pointer) stream)
-  (print-unreadable-object (vtp stream :type t)
-    (format stream "~A:~A"
-	    (vtable-pointer-class vtp)
-	    (sod-class-nickname (vtable-pointer-chain-head vtp)))))
-
-;;; ichain
-
-(defclass ichain ()
-  ((class :initarg :class :type sod-class :reader ichain-class)
-   (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
-   (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
-   (body :initarg :body :type list :reader ichain-body))
-  (:documentation
-   "All of the instance layout for CLASS corresponding to a particular CHAIN.
-
-   The BODY is a list of things to include in the finished structure.  By
-   default, it contains a VTABLE-POINTER and ISLOTS for each class in the
-   chain."))
-
-(defmethod print-object ((ichain ichain) stream)
-  (print-unreadable-object (ichain stream :type t)
-    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (ichain-class ichain)
-	    (sod-class-nickname (ichain-head ichain))
-	    (ichain-body ichain))))
-
-(defgeneric compute-ichain (class chain)
-  (:documentation
-   "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.
-
-   The CHAIN is a list of classes, with the least specific first -- so the
-   chain head is the first element."))
-
-;;; ilayout
-
-(defclass ilayout ()
-  ((class :initarg :class :type sod-class :reader ilayout-class)
-   (ichains :initarg :ichains :type list :reader ilayout-ichains))
-  (:documentation
-   "All of the instance layout for a CLASS.
-
-   Consists of an ICHAIN for each distinct chain."))
-
-(defmethod print-object ((ilayout ilayout) stream)
-  (print-unreadable-object (ilayout stream :type t)
-    (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (ilayout-class ilayout)
-	    (ilayout-ichains ilayout))))
-
-(defgeneric compute-ilayout (class)
-  (:documentation
-   "Compute and return an instance layout for CLASS."))
-
-;;; Standard implementation.
-
-(defmethod compute-islots ((class sod-class) (subclass sod-class))
-  (make-instance 'islots
-		 :class class
-		 :subclass subclass
-		 :slots (mapcar (lambda (slot)
-				  (compute-effective-slot subclass slot))
-				(sod-class-slots class))))
-
-(defmethod compute-ichain ((class sod-class) chain)
-  (let* ((chain-head (car chain))
-	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
-			   :key #'sod-class-chain-head))
-	 (vtable-pointer (make-instance 'vtable-pointer
-					:class class
-					:chain-head chain-head
-					:chain-tail chain-tail))
-	 (islots (remove-if-not #'islots-slots
-				(mapcar (lambda (super)
-					  (compute-islots super class))
-					chain))))
-    (make-instance 'ichain
-		   :class class
-		   :chain-head chain-head
-		   :chain-tail chain-tail
-		   :body (cons vtable-pointer islots))))
-
-(defmethod compute-ilayout ((class sod-class))
-  (make-instance 'ilayout
-		 :class class
-		 :ichains (mapcar (lambda (chain)
-				    (compute-ichain class
-						    (reverse chain)))
-				  (sod-class-chains class))))
-
-;;;--------------------------------------------------------------------------
-;;; Effective methods.
-
-(defclass effective-method ()
-  ((message :initarg :message :type sod-message
-	    :reader effective-method-message)
-   (class :initarg :class :type sod-class :reader effective-method-class))
-  (:documentation
-   "The effective method invoked by sending MESSAGE to an instance of CLASS.
-
-   This is not a useful class by itself.  Message classes are expected to
-   define their own effective-method classes.
-
-   An effective method class must accept a :DIRECT-METHODS initarg, which
-   will be a list of applicable methods sorted in most-to-least specific
-   order."))
-
-(defmethod print-object ((method effective-method) stream)
-  (maybe-print-unreadable-object (method stream :type t)
-    (format stream "~A ~A"
-	    (effective-method-message method)
-	    (effective-method-class method))))
-
-(defgeneric message-effective-method-class (message)
-  (:documentation
-   "Return the effective method class for the given MESSAGE."))
-
-(defgeneric compute-sod-effective-method (message class)
-  (:documentation
-   "Return the effective method when a CLASS instance receives MESSAGE.
-
-   The default method constructs an instance of the message's chosen
-   MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the
-   list of applicable methods as initargs to MAKE-INSTANCE."))
-
-(defmethod compute-sod-effective-method
-    ((message sod-message) (class sod-class))
-  (let ((direct-methods (mappend (lambda (super)
-				   (remove message
-					   (sod-class-methods super)
-					   :key #'sod-method-message
-					   :test-not #'eql))
-				(sod-class-precedence-list class))))
-    (make-instance (message-effective-method-class message)
-		   :message message
-		   :class class
-		   :direct-methods direct-methods)))
-
-;;;--------------------------------------------------------------------------
-;;; Vtable layout.
-
-;;; method-entry
-
-(defclass method-entry ()
-  ((method :initarg :method :type effective-method
-	   :reader method-entry-effective-method)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader method-entry-chain-head)
-   (chain-tail :initarg :chain-tail :type sod-class
-	       :reader method-entry-chain-tail))
-  (:documentation
-   "An entry point into an effective method.
-
-   Calls to an effective method via different vtable chains will have their
-   `me' pointers pointing to different ichains within the instance layout.
-   Rather than (necessarily) duplicating the entire effective method for each
-   chain, we insert an entry veneer (the method entry) to fix up the pointer.
-   Exactly how it does this is up to the effective method -- and duplication
-   under some circumstances is probably a reasonable approach -- e.g., if the
-   effective method is just going to call a direct method immediately."))
-
-(defmethod print-object ((entry method-entry) stream)
-  (maybe-print-unreadable-object (entry stream :type t)
-    (format stream "~A:~A"
-	    (method-entry-effective-method entry)
-	    (sod-class-nickname (method-entry-chain-head entry)))))
-
-(defgeneric make-method-entry (effective-method chain-head chain-tail)
-  (:documentation
-   "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
-
-   There is no default method for this function.  (Maybe when the
-   effective-method/method-entry output protocol has settled down I'll know
-   what a sensible default action would be.)"))
-
-;;; vtmsgs
-
-(defclass vtmsgs ()
-  ((class :initarg :class :type sod-class :reader vtmsgs-class)
-   (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader vtmsgs-chain-head)
-   (chain-tail :initarg :chain-tail :type sod-class
-	       :reader vtmsgs-chain-tail)
-   (entries :initarg :entries :type list :reader vtmsgs-entries))
-  (:documentation
-   "The message dispatch table for a particular CLASS.
-
-   The BODY contains a list of effective method entry objects for the
-   messages defined on CLASS, customized for calling from the chain headed by
-   CHAIN-HEAD."))
-
-(defmethod print-object ((vtmsgs vtmsgs) stream)
-  (print-unreadable-object (vtmsgs stream :type t)
-    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (vtmsgs-subclass vtmsgs)
-	    (vtmsgs-class vtmsgs)
-	    (vtmsgs-entries vtmsgs))))
-
-(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
-  (:documentation
-   "Return a VTMSGS object containing method entries for CLASS.
-
-   The CHAIN-HEAD describes which chain the method entries should be
-   constructed for.
-
-   The default method simply calls MAKE-METHOD-ENTRY for each of the methods
-   and wraps a VTMSGS object around them.  This ought to be enough for almost
-   all purposes."))
-
-;;; class-pointer
-
-(defclass class-pointer ()
-  ((class :initarg :class :type sod-class :reader class-pointer-class)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader class-pointer-chain-head)
-   (metaclass :initarg :metaclass :type sod-class
-	      :reader class-pointer-metaclass)
-   (meta-chain-head :initarg :meta-chain-head :type sod-class
-		    :reader class-pointer-meta-chain-head))
-  (:documentation
-   "Represents a pointer to a class object for the instance's class.
-
-   A class instance can have multiple chains.  It may be useful to find any
-   of those chains from an instance of the class.  Therefore the vtable
-   stores a pointer to each separate chain of the class instance."))
-
-(defmethod print-object ((cptr class-pointer) stream)
-  (print-unreadable-object (cptr stream :type t)
-    (format stream "~A:~A"
-	    (class-pointer-metaclass cptr)
-	    (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
-
-(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
-  (:documentation
-   "Return a class pointer to a metaclass chain."))
-
-;;; base-offset
-
-(defclass base-offset ()
-  ((class :initarg :class :type sod-class :reader base-offset-class)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader base-offset-chain-head))
-  (:documentation
-   "The offset of this chain to the ilayout base.
-
-   There's only one of these per vtable."))
-
-(defmethod print-object ((boff base-offset) stream)
-  (print-unreadable-object (boff stream :type t)
-    (format stream "~A:~A"
-	    (base-offset-class boff)
-	    (sod-class-nickname (base-offset-chain-head boff)))))
-
-(defgeneric make-base-offset (class chain-head)
-  (:documentation
-   "Return the base offset object for CHAIN-HEAD ichain."))
-
-;;; chain-offset
-
-(defclass chain-offset ()
-  ((class :initarg :class :type sod-class :reader chain-offset-class)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader chain-offset-chain-head)
-   (target-head :initarg :target-head :type sod-class
-		:reader chain-offset-target-head))
-  (:documentation
-   "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain."))
-
-(defmethod print-object ((choff chain-offset) stream)
-  (print-unreadable-object (choff stream :type t)
-    (format stream "~A:~A->~A"
-	    (chain-offset-class choff)
-	    (sod-class-nickname (chain-offset-chain-head choff))
-	    (sod-class-nickname (chain-offset-target-head choff)))))
-
-(defgeneric make-chain-offset (class chain-head target-head)
-  (:documentation
-   "Return the offset from CHAIN-HEAD to TARGET-HEAD."))
-
-;;; vtable
-
-(defclass vtable ()
-  ((class :initarg :class :type sod-class :reader vtable-class)
-   (chain-head :initarg :chain-head :type sod-class
-	       :reader vtable-chain-head)
-   (chain-tail :initarg :chain-tail :type sod-class
-	       :reader vtable-chain-tail)
-   (body :initarg :body :type list :reader vtable-body))
-  (:documentation
-   "VTABLEs hold all of the per-chain static information for a class.
-
-   There is one vtable for each chain of each class.  The vtables for a class
-   are prefixes of the corresponding chains of its subclasses.
-
-   Vtables contain method entry pointers, pointers to class objects, and
-   the offset information used for cross-chain slot access."))
-
-(defmethod print-object ((vtable vtable) stream)
-  (print-unreadable-object (vtable stream :type t)
-    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (vtable-class vtable)
-	    (sod-class-nickname (vtable-chain-head vtable))
-	    (vtable-body vtable))))
-
-(defgeneric compute-vtable (class chain)
-  (:documentation
-   "Compute the vtable layout for a chain of CLASS.
-
-   The CHAIN is a list of classes, with the least specific first."))
-
-(defgeneric compute-vtables (class)
-  (:documentation
-   "Compute the vtable layouts for CLASS.
-
-   Returns a list of VTABLE objects in the order of CLASS's chains."))
-
-;;; Implementation.
-
-(defmethod compute-vtmsgs
-    ((class sod-class)
-     (subclass sod-class)
-     (chain-head sod-class)
-     (chain-tail sod-class))
-  (flet ((make-entry (message)
-	   (let ((method (find message
-			       (sod-class-effective-methods subclass)
-			       :key #'effective-method-message)))
-	     (make-method-entry method chain-head chain-tail))))
-    (make-instance 'vtmsgs
-		   :class class
-		   :subclass subclass
-		   :chain-head chain-head
-		   :chain-tail chain-tail
-		   :entries (mapcar #'make-entry
-				    (sod-class-messages class)))))
-
-(defmethod make-class-pointer
-    ((class sod-class) (chain-head sod-class)
-     (metaclass sod-class) (meta-chain-head sod-class))
-
-  ;; Slightly tricky.  We don't necessarily want a pointer to the metaclass,
-  ;; but to its most specific subclass on the given chain.  Fortunately, CL
-  ;; is good at this game.
-  (let* ((meta-chains (sod-class-chains metaclass))
-	 (meta-chain-tails (mapcar #'car meta-chains))
-	 (meta-chain-tail (find meta-chain-head meta-chain-tails
-				:key #'sod-class-chain-head)))
-    (make-instance 'class-pointer
-		   :class class
-		   :chain-head chain-head
-		   :metaclass meta-chain-tail
-		   :meta-chain-head meta-chain-head)))
-
-(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
-  (make-instance 'base-offset
-		 :class class
-		 :chain-head chain-head))
-
-(defmethod make-chain-offset
-    ((class sod-class) (chain-head sod-class) (target-head sod-class))
-  (make-instance 'chain-offset
-		 :class class
-		 :chain-head chain-head
-		 :target-head target-head))
-
-;; Special variables used by COMPUTE-VTABLE.
-(defvar *done-metaclass-chains*)
-(defvar *done-instance-chains*)
-
-(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
-  (:documentation
-   "Emit vtable items for a superclass of CLASS.
-
-   This function is called for each superclass SUPER of CLASS reached on the
-   chain headed by CHAIN-HEAD.  The function should call EMIT for each
-   vtable item it wants to write.
-
-   The right way to check to see whether items have already been emitted
-   (e.g., has an offset to some other chain been emitted?) is as follows:
-
-     * In a method on COMPUTE-VTABLE, bind a special variable to an empty
-       list or hash table.
-
-     * In a method on this function, check the variable or hash table.
-
-   This function is the real business end of COMPUTE-VTABLE."))
-
-(defmethod compute-vtable-items
-    ((class sod-class) (super sod-class) (chain-head sod-class)
-     (chain-tail sod-class) (emit function))
-
-  ;; If this class introduces new metaclass chains, then emit pointers to
-  ;; them.
-  (let* ((metasuper (sod-class-metaclass super))
-	 (metasuper-chains (sod-class-chains metasuper))
-	 (metasuper-chain-heads (mapcar (lambda (chain)
-					  (sod-class-chain-head (car chain)))
-					metasuper-chains)))
-    (dolist (metasuper-chain-head metasuper-chain-heads)
-      (unless (member metasuper-chain-head *done-metaclass-chains*)
-	(funcall emit (make-class-pointer class
-					  chain-head
-					  metasuper
-					  metasuper-chain-head))
-	(push metasuper-chain-head *done-metaclass-chains*))))
-
-  ;; If there are new instance chains, then emit offsets to them.
-  (let* ((chains (sod-class-chains super))
-	 (chain-heads (mapcar (lambda (chain)
-				(sod-class-chain-head (car chain)))
-			      chains)))
-    (dolist (head chain-heads)
-      (unless (member head *done-instance-chains*)
-	(funcall emit (make-chain-offset class chain-head head))
-	(push head *done-instance-chains*))))
-
-  ;; Finally, if there are interesting methods, emit those too.
-  (when (sod-class-messages super)
-    (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
-
-(defun find-root-superclass (class)
-  "Returns the `root' superclass of CLASS.
-
-   The root superclass is the superclass which itself has no direct
-   superclasses.  In universes not based on the provided builtin module, the
-   root class may not be our beloved SodObject; however, there must be one
-   (otherwise the class graph is cyclic, which should be forbidden), and we
-   instist that it be unique."
-
-  ;; The root superclass must be a chain head since the chains partition the
-  ;; superclasses; the root has no superclasses so it can't have a link and
-  ;; must therefore be a head.  This narrows the field down quite a lot.
-  ;;
-  ;; Note!  This function gets called from CHECK-SOD-CLASS before the class's
-  ;; chains have been computed.  Therefore we iterate over the direct
-  ;; superclass's chains rather than the class's own.  This misses a chain
-  ;; only in the case where the class is its own chain head.  There are two
-  ;; subcases: if there are no direct superclasses at all, then the class is
-  ;; its own root; otherwise, it clearly can't be the root and the omission
-  ;; is harmless.
-  (let* ((supers (sod-class-direct-superclasses class))
-	 (roots (if supers
-		    (remove-duplicates
-		     (remove-if #'sod-class-direct-superclasses
-				(mappend (lambda (super)
-					   (mapcar (lambda (chain)
-						     (sod-class-chain-head
-						      (car chain)))
-						   (sod-class-chains super)))
-					 supers)))
-		    (list class))))
-    (cond ((null roots) (error "Class ~A has no root class!" class))
-	  ((cdr roots) (error "Class ~A has multiple root classes ~
-			       ~{~A~#[~; and ~;, ~]~}"
-			      class roots))
-	  (t (car roots)))))
-
-(defun find-root-metaclass (class)
-  "Returns the `root' metaclass of CLASS.
-
-   The root metaclass is the metaclass of the root superclass -- see
-   FIND-ROOT-SUPERCLASS."
-  (sod-class-metaclass (find-root-superclass class)))
-
-(defmethod compute-vtable ((class sod-class) (chain list))
-  (let* ((chain-head (car chain))
-	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
-			   :key #'sod-class-chain-head))
-	 (*done-metaclass-chains* nil)
-	 (*done-instance-chains* (list chain-head))
-	 (done-superclasses nil)
-	 (items nil))
-    (flet ((emit (item)
-	     (push item items)))
-
-      ;; Find the root chain in the metaclass and write a pointer.
-      (let* ((metaclass (sod-class-metaclass class))
-	     (metaclass-root (find-root-metaclass class))
-	     (metaclass-root-head (sod-class-chain-head metaclass-root)))
-	(emit (make-class-pointer class chain-head metaclass
-				  metaclass-root-head))
-	(push metaclass-root-head *done-metaclass-chains*))
-
-      ;; Write an offset to the instance base.
-      (emit (make-base-offset class chain-head))
-
-      ;; Now walk the chain.  As we ascend the chain, scan the class
-      ;; precedence list of each class in reverse to ensure that we have
-      ;; everything interesting.
-      (dolist (super chain)
-	(dolist (sub (reverse (sod-class-precedence-list super)))
-	  (unless (member sub done-superclasses)
-	    (compute-vtable-items class
-				  sub
-				  chain-head
-				  chain-tail
-				  #'emit)
-	    (push sub done-superclasses))))
-
-      ;; We're through.
-      (make-instance 'vtable
-		     :class class
-		     :chain-head chain-head
-		     :chain-tail chain-tail
-		     :body (nreverse items)))))
-
-(defgeneric compute-effective-methods (class)
-  (:documentation
-   "Return a list of all of the effective methods needed for CLASS.
-
-   The list needn't be in any particular order."))
-
-(defmethod compute-effective-methods ((class sod-class))
-  (mapcan (lambda (super)
-	    (mapcar (lambda (message)
-		      (compute-sod-effective-method message class))
-		    (sod-class-messages super)))
-	  (sod-class-precedence-list class)))
-
-(defmethod compute-vtables ((class sod-class))
-  (mapcar (lambda (chain)
-	    (compute-vtable class (reverse chain)))
-	  (sod-class-chains class)))
-
-;;;--------------------------------------------------------------------------
-;;; Names of things.
-
-(defun islots-struct-tag (class)
-  (format nil "~A__islots" class))
-
-(defun ichain-struct-tag (class chain-head)
-  (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
-
-(defun ichain-union-tag (class chain-head)
-  (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
-
-(defun ilayout-struct-tag (class)
-  (format nil "~A__ilayout" class))
-
-(defun vtmsgs-struct-tag (class super)
-  (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
-
-(defun vtable-struct-tag (class chain-head)
-  (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
-
-(defun vtable-name (class chain-head)
-  (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
-
-;;;----- That's all, folks --------------------------------------------------
diff --git a/combination.lisp b/combination.lisp
deleted file mode 100644
index b700993..0000000
--- a/combination.lisp
+++ /dev/null
@@ -1,129 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Method combinations
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Common behaviour.
-
-(defclass simple-message (basic-message)
-  ()
-  (:documentation
-   "Base class for messages with `simple' method combinations.
-
-   A simple method combination is one which has only one method role other
-   than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
-   We call these `primary' methods, and the programmer designates them by not
-   specifying an explicit role.
-
-   If the programmer doesn't define any primary methods then the effective
-   method is null -- i.e., the method entry pointer shows up as a null
-   pointer."))
-
-(defclass simple-effective-method (basic-effective-method)
-  ((primary-methods :initarg :primary-methods :initform nil
-		    :type list :reader effective-method-primary-methods))
-  (:documentation
-   "Effective method counterpart to SIMPLE-MESSAGE."))
-
-(defgeneric primary-method-class (message)
-  (:documentation
-   "Return the name of the primary direct method class for MESSAGE."))
-
-(defgeneric simple-method-body (method codegen target)
-  (:documentation
-   "Generate the body of a simple effective method.
-
-   The function is invoked on an effective METHOD, with a CODEGEN to which it
-   should emit code delivering the method's value to TARGET."))
-
-(defmethod sod-message-method-class
-    ((message standard-message) (class sod-class) pset)
-  (if (get-property pset :role :keyword nil)
-      (call-next-method)
-      (primary-method-class message)))
-
-(defmethod shared-initialize :after
-    ((method simple-effective-method) slot-names &key direct-methods)
-  (declare (ignore slot-names))
-  (categorize (method direct-methods :bind ((role (sod-method-role method))))
-      ((primary (null role))
-       (before (eq role :before))
-       (after (eq role :after))
-       (around (eq role :around)))
-    (with-slots (primary-methods before-methods after-methods around-methods)
-	method
-      (setf primary-methods primary
-	    before-methods before
-	    after-methods (reverse after)
-	    around-methods around))))
-
-(defmethod compute-effective-method-entry-functions
-    ((method standard-effective-method))
-  (if (effective-method-primary-methods method)
-      (call-next-method)
-      nil))
-
-(defmethod compute-effective-method-body
-    ((method simple-effective-method) codegen target)
-  (with-slots (message basic-argument-names primary-methods) method
-    (basic-effective-method-body codegen target method
-				 (lambda (target)
-				   (simple-method-body method
-						       codegen
-						       target)))))
-
-;;;--------------------------------------------------------------------------
-;;; Standard method combination.
-
-(defclass standard-message (simple-message)
-  ()
-  (:documentation
-   "Message class for standard method combination.
-
-   Standard method combination is a simple method combination where the
-   primary methods are invoked as a delegation chain, from most- to
-   least-specific."))
-
-(defclass standard-effective-method (simple-effective-method)
-  ()
-  (:documentation
-   "Effective method counterpart to STANDARD-MESSAGE."))
-
-(defmethod primary-method-class ((message standard-message))
-  'delegating-direct-method)
-
-(defmethod message-effective-method-class ((message standard-message))
-  'standard-effective-method)
-
-(defmethod simple-method-body
-    ((method standard-effective-method) codegen target)
-  (invoke-delegation-chain codegen
-			   target
-			   (effective-method-basic-argument-names method)
-			   (effective-method-primary-methods method)
-			   nil))
-
-;;;----- That's all, folks --------------------------------------------------
diff --git a/cutting-room-floor.lisp b/cutting-room-floor.lisp
deleted file mode 100644
index 2f82c65..0000000
--- a/cutting-room-floor.lisp
+++ /dev/null
@@ -1,195 +0,0 @@
-;;;--------------------------------------------------------------------------
-;;; C types stuff.
-
-(cl:defpackage #:c-types
-  (:use #:common-lisp
-	#+sbcl #:sb-mop
-	#+(or cmu clisp) #:mop
-	#+ecl #:clos)
-  (:export #:c-type
-	   #:c-declarator-priority #:maybe-parenthesize
-	   #:pprint-c-type
-	   #:c-type-subtype #:compount-type-declaration
-	   #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
-	   #:simple-c-type #:c-type-name
-	   #:c-pointer-type
-	   #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
-	   #:tagged-c-type-kind
-	   #:c-array-type #:c-array-dimensions
-	   #:make-argument #:argument-name #:argument-type
-	   #:c-function-type #:c-function-arguments
-
-	   #:define-c-type-syntax #:c-type-alias #:defctype
-	   #:print-c-type
-	   #:qualifier #:declare-qualifier
-	   #:define-simple-c-type
-
-	   #:const #:volatile #:static #:restrict
-	   #:char #:unsigned-char #:uchar #:signed-char #:schar
-	   #:int #:signed #:signed-int #:sint
-	   #:unsigned #:unsigned-int #:uint
-	   #:short #:signed-short #:short-int #:signed-short-int #:sshort
-	   #:unsigned-short #:unsigned-short-int #:ushort
-	   #:long #:signed-long #:long-int #:signed-long-int #:slong
-	   #:unsigned-long #:unsigned-long-int #:ulong
-	   #:float #:double #:long-double
-	   #:pointer #:ptr
-	   #:[] #:vec
-	   #:fun #:func #:fn))
-
-
-;;;--------------------------------------------------------------------------
-;;; Convenient syntax for C types.
-
-;; Basic machinery.
-
-;; Qualifiers.  They have hairy syntax and need to be implemented by hand.
-
-;; Simple types.
-
-;; Pointers.
-
-;; Tagged types.
-
-;; Arrays.
-
-;; Functions.
-
-
-(progn
-  (defconstant q-byte (byte 3 0))
-  (defconstant q-const 1)
-  (defconstant q-volatile 2)
-  (defconstant q-restrict 4)
-
-  (defconstant z-byte (byte 3 3))
-  (defconstant z-unspec 0)
-  (defconstant z-short 1)
-  (defconstant z-long 2)
-  (defconstant z-long-long 3)
-  (defconstant z-double 4)
-  (defconstant z-long-double 5)
-
-  (defconstant s-byte (byte 2 6))
-  (defconstant s-unspec 0)
-  (defconstant s-signed 1)
-  (defconstant s-unsigned 2)
-
-  (defconstant t-byte (byte 3 8))
-  (defconstant t-unspec 0)
-  (defconstant t-int 1)
-  (defconstant t-char 2)
-  (defconstant t-float 3)
-  (defconstant t-user 4))
-
-(defun make-type-flags (size sign type &rest quals)
-  (let ((flags 0))
-    (dolist (qual quals)
-      (setf flags (logior flags qual)))
-    (setf (ldb z-byte flags) size
-	  (ldb s-byte flags) sign
-	  (ldb t-byte flags) type)
-    flags))
-
-
-(defun expand-c-type (spec)
-  "Parse SPEC as a C type and return the result.
-
-   The SPEC can be one of the following.
-
-     * A C-TYPE object, which is returned immediately.
-
-     * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
-       function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
-       or some other means is invoked on the ARGUMENTS, and the result is
-       returned.
-
-     * A symbol, which is treated the same way as a singleton list would be."
-
-  (flet ((interp (sym)
-	   (or (get sym 'c-type)
-	       (error "Unknown C type operator ~S." sym))))
-    (etypecase spec
-      (c-type spec)
-      (symbol (funcall (interp spec)))
-      (list (apply (interp (car spec)) (cdr spec))))))
-
-(defmacro c-type (spec)
-  "Evaluates to the type that EXPAND-C-TYPE would return.
-
-   Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
-   later it will do something more clever."
-  `(expand-c-type ',spec))
-
-;; S-expression machinery.  Qualifiers have hairy syntax and need to be
-;; implemented by hand.
-
-(defun qualifier (qual &rest args)
-  "Parse a qualified C type.
-
-   The ARGS consist of a number of qualifiers and exactly one C-type
-   S-expression.  The result is a qualified version of this type, with the
-   given qualifiers attached."
-  (if (null args)
-      qual
-      (let* ((things (mapcar #'expand-c-type args))
-	     (quals (delete-duplicates
-		     (sort (cons qual (remove-if-not #'keywordp things))
-			   #'string<)))
-	     (types (remove-if-not (lambda (thing) (typep thing 'c-type))
-				   things)))
-	(when (or (null types)
-		  (not (null (cdr types))))
-	  (error "Only one proper type expected in ~S." args))
-	(qualify-type (car types) quals))))
-(setf (get 'qualifier 'c-type) #'qualifier)
-
-(defun declare-qualifier (qual)
-  "Defines QUAL as being a type qualifier.
-
-   When used as a C-type operator, it applies that qualifier to the type that
-   is its argument."
-  (let ((kw (intern (string qual) :keyword)))
-    (setf (get qual 'c-type)
-	  (lambda (&rest args)
-	    (apply #'qualifier kw args)))))
-
-;; Define some initial qualifiers.
-(dolist (qual '(const volatile restrict))
-  (declare-qualifier qual))
-
-
-(define-c-type-syntax simple-c-type (name)
-  "Constructs a simple C type called NAME (a string or symbol)."
-  (make-simple-type (c-name-case name)))
-
-(defmethod print-c-type :around
-    (stream (type qualifiable-c-type) &optional colon atsign)
-  (if (c-type-qualifiers type)
-      (pprint-logical-block (stream nil :prefix "(" :suffix ")")
-	(format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
-		(c-type-qualifiers type))
-	(call-next-method stream type colon atsign))
-      (call-next-method)))
-;; S-expression syntax.
-
-
-(define-c-type-syntax enum (tag)
-  "Construct an enumeration type named TAG."
-  (make-instance 'c-enum-type :tag (c-name-case tag)))
-(define-c-type-syntax struct (tag)
-  "Construct a structure type named TAG."
-  (make-instance 'c-struct-type :tag (c-name-case tag)))
-(define-c-type-syntax union (tag)
-  "Construct a union type named TAG."
-  (make-instance 'c-union-type :tag (c-name-case tag)))
-
-(defgeneric make-me-argument (message class)
-  (:documentation
-   "Return an ARGUMENT object for the `me' argument to MESSAGE, as
-   specialized to CLASS."))
-
-(defmethod make-me-argument
-    ((message basic-message) (class sod-class))
-  (make-argument "me" (make-instance 'c-pointer-type
-				     :subtype (sod-class-type class))))
diff --git a/sod-backg.tex b/doc/sod-backg.tex
similarity index 100%
rename from sod-backg.tex
rename to doc/sod-backg.tex
diff --git a/doc/sod-protocol.tex b/doc/sod-protocol.tex
new file mode 100644
index 0000000..f0bd115
--- /dev/null
+++ b/doc/sod-protocol.tex
@@ -0,0 +1,695 @@
+%%% -*-latex-*-
+%%%
+%%% Description of the internal class structure and protocol
+%%%
+%%% (c) 2009 Straylight/Edgeware
+%%%
+
+%%%----- Licensing notice ---------------------------------------------------
+%%%
+%%% This file is part of the Simple Object Definition system.
+%%%
+%%% SOD 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.
+%%%
+%%% SOD 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 SOD; if not, write to the Free Software Foundation,
+%%% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+\chapter{Protocol overview} \label{ch:proto}
+
+This chapter provides an overview of the Sod translator's internal object
+model.  It describes most of the important classes and generic functions, how
+they are used to build a model of a Sod module and produce output code, and
+how an extension might modify the translator's behaviour.
+
+I assume familiarity with the Common Lisp Object System (CLOS).  Familiarity
+with the CLOS Metaobject Protocol isn't necessary but may be instructive.
+
+%%%--------------------------------------------------------------------------
+\section{A tour through the translator}
+
+At the very highest level, the Sod translator works in two phases: it
+\emph{parses} source files into an internal representation, and then it
+\emph{generates} output files from the internal representation.
+
+The function @|read-module| is given a pathname for a file: it opens the
+file, parses the program text, and returns a @|module| instance describing
+the classes and other items found.
+
+At the other end, the main output function is @|output-module|, which is
+given a module, an output stream and a 
+
+
+%%%--------------------------------------------------------------------------
+\section{Specification conventions} \label{sec:proto.conventions}
+
+Throughout this specification, the phrase `it is an error' indicates that a
+particular circumstance is erroneous and results in unspecified and possibly
+incorrect behaviour.  In particular, the situation need not be immediately
+diagnosed, and the consequences may be far-reaching.
+
+The following conventions apply throughout this specification.
+
+\begin{itemize}
+
+\item If a specification describes an argument as having a particular type or
+  syntax, then it is an error to provide an argument not having that
+  particular type or syntax.
+
+\item If a specification describes a function then that function might be
+  implemented as a generic function; it is an error to attempt to (re)define
+  it as a generic function, or to attempt to add methods to it.  A function
+  specified as being a generic function will certainly be so; if user methods
+  are permitted on the generic function then this will be specified.
+
+\item Where a class precedence list is specified, either explicitly or
+  implicitly by a class hierarchy, the implementation may include additional
+  superclasses not specified here.  Such additional superclasses will not
+  affect the order of specified classes in the class precedence lists either
+  of specified classes themselves or of user-defined subclasses of specified
+  classes.
+
+\item Unless otherwise specified, generic functions use the standard method
+  combination.
+
+\item The specifications for methods are frequently brief; they should be
+  read in conjunction with and in the context of the specification for the
+  generic function and specializing classes, if any.
+
+\item An object $o$ is a \emph{direct instance} of a class $c$ if @|(eq
+  (class-of $o$) $c$)|; $o$ is an \emph{instance} of $c$ if it is a direct
+  instance of any subclass of $c$.
+
+\item If a class is specified as being \emph{abstract} then it is an error to
+  construct direct instances of it, e.g., using @|make-instance|.
+
+\item If an object is specified as being \emph{immutable} then it is an error
+  to mutate it, e.g., using @|(setf (slot-value \ldots) \ldots)|.  Programs
+  may rely on immutable objects retaining their state.
+
+\item A value is \emph{fresh} if it is guaranteed to be not @|eql| to any
+  previously existing value.
+
+\item Unless otherwise specified, it is an error to change the class of an
+  instance of any class described here; and it is an error to change the
+  class of an object to a class described here.
+
+\end{itemize}
+
+\subsection{Format of the entries} \label{sec:proto.conventions.format}
+
+Most symbols defined by the protocol have their own entries.  An entry begins
+with a header line, showing a synopsis of the symbol on the left, and the
+category (function, class, macro, etc.) on the right.
+
+\begin{describe}{fun}{example-function @<required>
+    \&optional @<optional>
+    \&rest @<rest>
+    \&key :keyword}
+  The synopsis for a function, generic function or method describes the
+  function's lambda-list using the usual syntax.  Note that keyword arguments
+  are shown by naming their keywords; in the description, the value passed
+  for the keyword argument @|keyword| is shown as @<keyword>.
+
+  For a method, specializers are shown using the usual @|defmethod| syntax,
+  e.g.,
+  \begin{quote}
+    some-generic-function ((@<specialized> list) @<unspecialized>)
+  \end{quote}
+\end{describe}
+
+\begin{describe}{mac}{example-macro
+  ( @{ @<symbol> @! (@<symbol> @<form>) @}^* ) \\ \push
+    @[[ @<declaration>^* @! @<documentation-string> @]] \\
+    @<body-form>^*}
+  The synopsis for a macro describes the acceptable syntax using the
+  following notation.
+  \begin{itemize}
+  \item Literal symbols, e.g., keywords and parenthesis, are shown in
+    @|monospace|.
+  \item Metasyntactic variables are shown in @<italics>.
+  \item Items are grouped together by braces `@{ $\dots$ @}'.  The notation
+    `@{ $\dots$ @}^*' indicates that the enclosed items may be repeated zero
+    or more times; `@{ $\dots$ @}^+' indicates that the enclosed items may be
+    repeated one or more times.  This notation may be applied to a single
+    item without the braces.
+  \item Optional items are shown enclosed in brackets `@[ $\dots$ @]'.
+  \item Alternatives are separated by vertical bars `@!'; the vertical bar
+    has low precedence, so alternatives extend as far as possible between
+    bars and up to the enclosing brackets if any.
+  \item A sequence of alternatives enclosed in double-brackets `@[[ $\ldots$
+    @]]' indicates that the alternatives may occur in any order, but each may
+    appear at most once unless marked by a star.
+  \end{itemize}
+  For example, the notation at the head of this example describes syntax
+  for @|let|.
+\end{describe}
+
+
+\begin{describe}{cls}{example-class (direct-super other-direct-super) \&key
+    :initarg}
+  The synopsis for a class lists the class's direct superclasses, and the
+  acceptable initargs in the form of a lambda-list.  The initargs may be
+  passed to @|make-instance| when constructing an instance of the class or a
+  subclass of it.  If instances of the class may be reinitialized, or if
+  objects can be changed to be instances of the class, then these initargs
+  may also be passed to @|reinitialize-instance| and/or @|change-class| as
+  applicable; the class description will state explicitly when these
+  operations are allowed.
+\end{describe}
+
+%%%--------------------------------------------------------------------------
+\section{C type representation} \label{sec:proto.c-types}
+
+\subsection{Overview} \label{sec:proto.c-types.over}
+
+The Sod translator represents C types in a fairly simple and direct way.
+However, because it spends a fair amount of its time dealing with C types, it
+provides a number of useful operations and macros.
+
+The class hierarchy is shown in~\xref{fig:proto.c-types}.
+
+\begin{figure} \centering
+  \parbox{10pt}{\begin{tabbing}
+    @|c-type| \\ \push
+      @|qualifiable-c-type| \\ \push
+        @|simple-c-type| \\ \push
+          @|c-class-type| \- \\
+        @|tagged-c-type| \\ \push
+          @|c-struct-type| \\
+          @|c-union-type| \\
+          @|c-enum-type| \- \\
+        @|c-pointer-type| \- \\
+      @|c-array-type| \\
+      @|c-function-type|
+  \end{tabbing}}
+  \caption{Classes representing C types}
+\label{fig:proto.c-types}
+\end{figure}
+
+C type objects are immutable unless otherwise specified.
+
+\subsubsection{Constructing C type objects}
+There is a constructor function for each non-abstract class of C type object.
+Note, however, that constructor functions need not generate a fresh type
+object if a previously existing type object is suitable.  In this case, we
+say that the objects are \emph{interned}.  Some constructor functions are
+specified to return interned objects: programs may rely on receiving the same
+(@|eq|) type object for similar (possibly merely @|equal|) arguments.  Where
+not specified, clients may still not rely on receiving fresh objects.
+
+A convenient S-expression notation is provided by the @|c-type| macro.  Use
+of this macro is merely an abbreviation for corresponding use of the various
+constructor functions, and therefore interns type objects in the same manner.
+The syntax accepted by the macro can be extended in order to support new
+classes: see @|defctype|, @|c-type-alias| and @|define-c-type-syntax|.
+
+The descriptions of each of the various classes include descriptions of the
+initargs which may be passed to @|make-instance| when constructing a new
+instance of the class.  However, the constructor functions and S-expression
+syntax are strongly recommended over direct use of @|make-instance|.
+
+\subsubsection{Printing}
+There are two protocols for printing C types.  Unfortunately they have
+similar names.
+\begin{itemize}
+\item The @|print-c-type| function prints a C type value using the
+  S-expression notation.  It is mainly useful for diagnostic purposes.
+\item The @|pprint-c-type| function prints a C type as a C-syntax
+  declaration.
+\end{itemize}
+Neither generic function defines a default primary method; subclasses of
+@|c-type| must define their own methods in order to print correctly.
+
+\subsection{The C type root class} \label{sec:proto.c-types.root}
+
+\begin{describe}{cls}{c-type ()}
+  The class @|c-type| marks the root of the built-in C type hierarchy.
+
+  Users may define subclasses of @|c-type|.  All non-abstract subclasses must
+  have a primary method defined on @|pprint-c-type|; unless instances of the
+  subclass are interned, a method on @|c-type-equal-p| is also required.
+
+  The class @|c-type| is abstract.
+\end{describe}
+
+\subsection{C type S-expression notation} \label{sec:proto.c-types.sexp}
+
+The S-expression representation of a type is described syntactically as a
+type specifier.  Type specifiers fit into two syntactic categories.
+\begin{itemize}
+\item A \emph{symbolic type specifier} consists of a symbol.  It has a
+  single, fixed meaning: if @<name> is a symbolic type specifier, then each
+  use of @<name> in a type specifier evaluates to the same (@|eq|) type
+  object, until the @<name> is redefined.
+\item A \emph{type operator} is a symbol; the corresponding specifier is a
+  list whose @|car| is the operator.  The remaining items in the list are
+  arguments to the type operator.
+\end{itemize}
+
+\begin{describe}{mac}{c-type @<type-spec> @to @<type>}
+  Evaluates to a C type object, as described by the type specifier
+  @<type-spec>.
+\end{describe}
+
+\begin{describe}{mac}{
+    defctype @{ @<name> @! (@<name>^*) @} @<type-spec> @to @<names>}
+  Defines a new symbolic type specifier @<name>; if a list of @<name>s is
+  given, then all are defined in the same way.  The type constructed by using
+  any of the @<name>s is as described by the type specifier @<type-spec>.
+
+  The resulting type object is constructed once, at the time that the macro
+  expansion is evaluated; the same (@|eq|) value is used each time any
+  @<name> is used in a type specifier.
+\end{describe}
+
+\begin{describe}{mac}{c-type-alias @<original> @<alias>^* @to @<aliases>}
+  Defines each @<alias> as being a type operator identical in behaviour to
+  @<original>.  If @<original> is later redefined then the behaviour of the
+  @<alias>es changes too.
+\end{describe}
+
+\begin{describe}{mac}{%
+  define-c-type-syntax @<name> @<lambda-list> \\ \push
+    @<form>^* \-\\
+  @to @<name>}
+  Defines the symbol @<name> as a new type operator.  When a list of the form
+  @|(@<name> @<argument>^*)| is used as a type specifier, the @<argument>s
+  are bound to fresh variables according to @<lambda-list> (a destructuring
+  lambda-list) and the @<form>s evaluated in order in the resulting lexical
+  environment as an implicit @|progn|.  The value should be a Lisp form which
+  will evaluate to the type specified by the arguments.
+
+  The @<form>s may call @|expand-c-type-spec| in order to recursively expand
+  type specifiers among its arguments.
+\end{describe}
+
+\begin{describe}{fun}{expand-c-type-spec @<type-spec> @to @<form>}
+  Returns the Lisp form that @|(c-type @<type-spec>)| would expand into.
+\end{describe}
+
+\begin{describe}{gf}{%
+    print-c-type @<stream> @<type> \&optional @<colon> @<atsign>}
+  Print the C type object @<type> to @<stream> in S-expression form.  The
+  @<colon> and @<atsign> arguments may be interpreted in any way which seems
+  appropriate: they are provided so that @|print-c-type| may be called via
+  @|format|'s @|\char`\~/\dots/| command; they are not set when
+  @|print-c-type| is called by Sod functions.
+
+  There should be a method defined for every C type class; there is no
+  default method.
+\end{describe}
+
+\subsection{Comparing C types} \label{sec:proto.c-types.cmp}
+
+It is necessary to compare C types for equality, for example when checking
+argument lists for methods.  This is done by @|c-type-equal-p|.
+
+\begin{describe}{gf}{c-type-equal-p @<type>_1 @<type>_2 @to @<boolean>}
+  The generic function @|c-type-equal-p| compares two C types @<type>_1 and
+  @<type>_2 for equality; it returns true if the two types are equal and
+  false if they are not.
+
+  Two types are equal if they are structurally similar, where this property
+  is defined by methods for each individual class; see the descriptions of
+  the classes for the details.
+
+  The generic function @|c-type-equal-p| uses the @|and| method combination.
+
+  \begin{describe}{meth}{c-type-equal-p @<type>_1 @<type>_2}
+    A default primary method for @|c-type-equal-p| is defined.  It simply
+    returns @|nil|.  This way, methods can specialize on both arguments
+    without fear that a call will fail because no methods are applicable.
+  \end{describe}
+  \begin{describe}{ar-meth}{c-type-equal-p @<type>_1 @<type>_2}
+    A default around-method for @|c-type-equal-p| is defined.  It returns
+    true if @<type>_1 and @<type>_2 are @|eql|; otherwise it delegates to the
+    primary methods.  Since several common kinds of C types are interned,
+    this is a common case worth optimizing.
+  \end{describe}
+\end{describe}
+
+\subsection{Outputting C types} \label{sec:proto.c-types.output}
+
+\begin{describe}{gf}{pprint-c-type @<type> @<stream> @<kernel>}
+  The generic function @|pprint-c-type| pretty-prints to @<stream> a C-syntax
+  declaration of an object or function of type @<type>.  The result is
+  written to @<stream>.
+
+  A C declaration has two parts: a sequence of \emph{declaration specifiers}
+  and a \emph{declarator}.  The declarator syntax involves parentheses and
+  operators, in order to reflect the operators applicable to the declared
+  variable.  For example, the name of a pointer variable is preceded by @`*';
+  the name of an array is followed by dimensions enclosed in @`['\dots @`]'.
+
+  The @<kernel> argument must be a function designator (though see the
+  standard around-method); it is invoked as
+  \begin{quote} \codeface
+    (funcall @<kernel> @<stream> @<priority> @<spacep>)
+  \end{quote}
+  It should write to @<stream> -- which may not be the same stream originally
+  passed into the generic function -- the `kernel' of the declarator, i.e.,
+  the part to which prefix and/or postfix operators are attached to form the
+  full declarator.
+
+  The methods on @|pprint-c-type| specialized for compound types work by
+  recursively calling @|pprint-c-type| on the subtype, passing down a closure
+  which prints the necessary additional declarator operators before calling
+  the original @<kernel> function.  The additional arguments @<priority> and
+  @<spacep> support this implementation technique.
+
+  The @<priority> argument describes the surrounding operator context.  It is
+  zero if no type operators are directly attached to the kernel (i.e., there
+  are no operators at all, or the kernel is enclosed in parentheses), one if
+  a prefix operator is directly attached, or two if a postfix operator is
+  directly attached.  If the @<kernel> function intends to provide its own
+  additional declarator operators, it should check the @<priority> in order
+  to determine whether parentheses are necessary.  See also the
+  @|maybe-in-parens| macro (page~\pageref{mac:maybe-in-parens}).
+
+  The @<spacep> argument indicates whether a space needs to be printed in
+  order to separate the declarator from the declaration specifiers.  A kernel
+  which contains an identifier should insert a space before the identifier
+  when @<spacep> is non-nil.  An `empty' kernel, as found in an abstract
+  declarator (one that specifies no name), looks more pleasing without a
+  trailing space.  See also the @|c-type-space| function
+  (page~\pageref{fun:c-type-space}).
+
+  Every concrete subclass of @|c-type| is expected to provide a primary
+  method on this function.  There is no default primary method.
+
+  \begin{describe}{ar-meth}{pprint-c-type @<type> @<stream> @<kernel>}
+    A default around method is defined on @|pprint-c-type| which `canonifies'
+    non-function @<kernel> arguments.  In particular:
+    \begin{itemize}
+    \item if @<kernel> is nil, then @|pprint-c-type| is called recursively
+      with a @<kernel> function that does nothing; and
+    \item if @<kernel> is any other kind of object, then @|pprint-c-type| is
+      called recursively with a @<kernel> function that prints the object as
+      if by @|princ|, preceded if necessary by space using @|c-type-space|.
+    \end{itemize}
+  \end{describe}
+\end{describe}
+
+\begin{describe}{fun}{c-type-space @<stream>}
+  Writes a space and other pretty-printing instructions to @<stream> in order
+  visually to separate a declarator from the preceding declaration
+  specifiers.  The precise details are subject to change.
+\end{describe}
+
+\begin{describe}{mac}{%
+  maybe-in-parens (@<stream-var> @<guard-form>) \\ \push
+    @<form>^*}
+  The @<guard-form> is evaluated, and then the @<form>s are evaluated in
+  sequence within a pretty-printer logical block writing to the stream named
+  by the symbol @<stream-var>.  If the @<guard-form> evaluates to nil, then
+  the logical block has empty prefix and suffix strings; if it evaluates to a
+  non-nil value, then the logical block has prefix and suffix @`(' and @`)'
+  respectively.
+
+  Note that this may cause @<stream> to be bound to a different stream object
+  within the @<form>s.
+\end{describe}
+
+\subsection{Type qualifiers and qualifiable types}
+\label{sec:proto.ctypes.qual}
+
+\begin{describe}{cls}{qualifiable-c-type (c-type) \&key :qualifiers}
+  The class @|qualifiable-c-type| describes C types which can bear
+  `qualifiers' (\Cplusplus\ calls them `cv-qualifiers'): @|const|,
+  @|restrict| and @|volatile|.
+
+  The @<qualifiers> are a list of keyword symbols @|:const|, @|:restrict| and
+  @|:volatile|.  There is no built-in limitation to these particular
+  qualifiers; others keywords may be used, though this isn't recommended.
+
+  Two qualifiable types are equal only if they have \emph{matching
+    qualifiers}: i.e., every qualifier attached to one is also attached to
+  the other: order is not significant, and neither is multiplicity.
+
+  The class @|qualifiable-c-type| is abstract.
+\end{describe}
+
+\begin{describe}{gf}{c-type-qualifiers @<type> @to @<list>}
+  Returns the qualifiers of the @|qualifiable-c-type| instance @<type> as an
+  immutable list.
+\end{describe}
+
+\begin{describe}{fun}{qualify-type @<type> @<qualifiers>}
+  The argument @<type> must be an instance of @|qualifiable-c-type|,
+  currently bearing no qualifiers, and @<qualifiers> a list of qualifier
+  keywords.  The result is a C type object like @<c-type> except that it
+  bears the given @<qualifiers>.
+
+  The @<type> is not modified.  If @<type> is interned, then the returned
+  type will be interned.
+\end{describe}
+
+\begin{describe}{fun}{format-qualifiers @<qualifiers>}
+  Returns a string containing the qualifiers listed in @<qualifiers> in C
+  syntax, with a space after each.  In particular, if @<qualifiers> is
+  non-null then the final character of the returned string will be a space.
+\end{describe}
+
+\subsection{Leaf types} \label{sec:proto.c-types.leaf}
+
+A \emph{leaf type} is a type which is not defined in terms of another type.
+In Sod, the leaf types are
+\begin{itemize}
+\item \emph{simple types}, including builtin types like @|int| and @|char|,
+  as well as type names introduced by @|typename|, because Sod isn't
+  interested in what the type name means, merely that it names a type; and
+\item \emph{tagged types}, i.e., enum, struct and union types which are named
+  by a keyword identifying the kind of type, and a \emph{tag}.
+\end{itemize}
+
+\begin{describe}{cls}{simple-c-type (qualifiable-c-type)
+    \&key :qualifiers :name}
+  The class of `simple types'; an instance denotes the type @<qualifiers>
+  @<name>.
+
+  A simple type object maintains a \emph{name}, which is a string whose
+  contents are the C name for the type.  The initarg @|:name| may be used to
+  provide this name when calling @|make-instance|.
+
+  Two simple type objects are equal if and only if they have @|string=| names
+  and matching qualifiers.
+
+  A number of symbolic type specifiers for builtin types are predefined as
+  shown in \xref{tab:proto.c-types.simple}.  These are all defined as if by
+  @|define-simple-c-type|, so can be used to construct qualified types.
+\end{describe}
+
+\begin{table}
+  \begin{tabular}[C]{|l|l|}                                        \hlx{hv}
+    \textbf{C type}     & \textbf{Specifiers}                   \\ \hlx{vhv}
+    @|void|             & @|void|                               \\ \hlx{vhv}
+    @|char|             & @|char|                               \\ \hlx{v}
+    @|unsigned char|    & @|unsigned-char|, @|uchar|            \\ \hlx{v}
+    @|signed char|      & @|signed-char|, @|schar|              \\ \hlx{vhv}
+    @|short|            & @|short|, @|signed-short|, @|short-int|,
+                          @|signed-short-int| @|sshort|         \\ \hlx{v}
+    @|unsigned short|   & @|unsigned-short|, @|unsigned-short-int|,
+                          @|ushort|                             \\ \hlx{vhv}
+    @|int|              & @|int|, @|signed|, @|signed-int|,
+                          @|sint|                               \\ \hlx{v}
+    @|unsigned int|     & @|unsigned|, @|unsigned-int|, @|uint| \\ \hlx{vhv}
+    @|long|             & @|long|, @|signed-long|, @|long-int|,
+                          @|signed-long-int|, @|slong|          \\ \hlx{v}
+    @|unsigned long|    & @|unsigned-long|, @|unsigned-long-int|,
+                          @|ulong|                              \\ \hlx{vhv}
+    @|long long|        & @|long-long|, @|signed-long-long|,
+                          @|long-long-int|,                     \\
+                        & \qquad @|signed-long-long-int|,
+                          @|llong|, @|sllong|                   \\ \hlx{v}
+    @|unsigned long long|
+                        & @|unsigned-long-long|, @|unsigned-long-long-int|,
+                          @|ullong|                             \\ \hlx{vhv}
+    @|float|            & @|float|                              \\ \hlx{v}
+    @|double|           & @|double|                             \\ \hlx{vhv}
+    @|va_list|          & @|va-list|                            \\ \hlx{v}
+    @|size_t|           & @|size-t|                             \\ \hlx{v}
+    @|ptrdiff_t|        & @|ptrdiff-t|                          \\ \hlx{vh}
+  \end{tabular}
+  \caption{Builtin symbolic type specifiers for simple C types}
+  \label{tab:proto.c-types.simple}
+\end{table}
+
+\begin{describe}{fun}{make-simple-type @<name> \&optional @<qualifiers>}
+  Return the (unique interned) simple C type object for the C type whose name
+  is @<name> (a string) and which has the given @<qualifiers> (a list of
+  keywords).
+\end{describe}
+
+\begin{describe}{gf}{c-type-name @<type>}
+  Returns the name of a @|simple-c-type| instance @<type> as an immutable
+  string.
+\end{describe}
+
+\begin{describe}{mac}{%
+    define-simple-c-type @{ @<name> @! (@<name>^*) @} @<string>}
+  Define type specifiers for a new simple C type.  Each symbol @<name> is
+  defined as a symbolic type specifier for the (unique interned) simple C
+  type whose name is the value of @<string>.  Further, each @<name> is
+  defined to be a type operator: the type specifier @|(@<name>
+  @<qualifier>^*)| evaluates to the (unique interned) simple C type whose
+  name is @<string> and which has the @<qualifiers> (which are evaluated).
+\end{describe}
+
+\begin{describe}{cls}{tagged-c-type (qualifiable-c-type)
+    \&key :qualifiers :tag}
+  Provides common behaviour for C tagged types.  A @<tag> is a string
+  containing a C identifier.
+
+  Two tagged types are equal if and only if they have the same class, their
+  @<tag>s are @|string=|, and they have matching qualifiers.  (User-defined
+  subclasses may have additional methods on @|c-type-equal-p| which impose
+  further restrictions.)
+\end{describe}
+\begin{boxy}[Bug]
+  Sod maintains distinct namespaces for the three kinds of tagged types.  In
+  C, there is only one namespace for tags which is shared between enums,
+  structs and unions.
+\end{boxy}
+
+\begin{describe}{gf}{c-tagged-type-kind @<type>}
+  Returns a symbol classifying the tagged @<type>: one of @|enum|, @|struct|
+  or @|union|.  User-defined subclasses of @|tagged-c-type| should return
+  their own classification symbols.  It is intended that @|(string-downcase
+  (c-tagged-type-kind @<type>))| be valid C syntax.\footnote{%
+    Alas, C doesn't provide a syntactic category for these keywords;
+    \Cplusplus\ calls them a @<class-key>.} %
+\end{describe}
+
+\begin{describe}{cls}{c-enum-type (tagged-c-type) \&key :qualifiers :tag}
+  Represents a C enumerated type.  An instance denotes the C type @|enum|
+  @<tag>.  See the direct superclass @|tagged-c-type| for details.
+
+  The type specifier @|(enum @<tag> @<qualifier>^*)| returns the (unique
+  interned) enumerated type with the given @<tag> and @<qualifier>s (all
+  evaluated).
+\end{describe}
+\begin{describe}{fun}{make-enum-type @<tag> \&optional @<qualifiers>}
+  Return the (unique interned) C type object for the enumerated C type whose
+  tag is @<tag> (a string) and which has the given @<qualifiers> (a list of
+  keywords).
+\end{describe}
+
+\begin{describe}{cls}{c-struct-type (tagged-c-type) \&key :qualifiers :tag}
+  Represents a C structured type.  An instance denotes the C type @|struct|
+  @<tag>.  See the direct superclass @|tagged-c-type| for details.
+
+  The type specifier @|(struct @<tag> @<qualifier>^*)| returns the (unique
+  interned) structured type with the given @<tag> and @<qualifier>s (all
+  evaluated).
+\end{describe}
+\begin{describe}{fun}{make-struct-type @<tag> \&optional @<qualifiers>}
+  Return the (unique interned) C type object for the structured C type whose
+  tag is @<tag> (a string) and which has the given @<qualifiers> (a list of
+  keywords).
+\end{describe}
+
+\begin{describe}{cls}{c-union-type (tagged-c-type) \&key :qualifiers :tag}
+  Represents a C union type.  An instance denotes the C type @|union|
+  @<tag>.  See the direct superclass @|tagged-c-type|
+  for details.
+
+  The type specifier @|(union @<tag> @<qualifier>^*)| returns the (unique
+  interned) union type with the given @<tag> and @<qualifier>s (all
+  evaluated).
+\end{describe}
+\begin{describe}{fun}{make-union-type @<tag> \&optional @<qualifiers>}
+  Return the (unique interned) C type object for the union C type whose tag
+  is @<tag> (a string) and which has the given @<qualifiers> (a list of
+  keywords).
+\end{describe}
+
+\subsection{Pointers and arrays} \label{sec:proto.c-types.ptr-array}
+
+Pointers and arrays are \emph{compound types}: they're defined in terms of
+existing types.  A pointer describes the type of objects it points to; an
+array describes the type of array element.
+\begin{describe}{gf}{c-type-subtype @<type>}
+  Returns the underlying type of a compound type @<type>.  Precisely what
+  this means depends on the class of @<type>.
+\end{describe}
+
+\begin{describe}{cls}{c-pointer-type (qualifiable-c-type)
+    \&key :qualifiers :subtype}
+  Represents a C pointer type.  An instance denotes the C type @<subtype>
+  @|*|@<qualifiers>.
+
+  The @<subtype> may be any C type.  Two pointer types are equal if and only
+  if their subtypes are equal and they have matching qualifiers.
+
+  The type specifier @|(* @<type-spec> @<qualifier>^*)| returns a type
+  qualified pointer-to-@<subtype>, where @<subtype> is the type specified by
+  @<type-spec> and the @<qualifier>s are qualifier keywords (which are
+  evaluated).  The synonyms @|ptr| and @|pointer| may be used in place of the
+  star @`*'.
+
+  The symbol @|string| is a type specifier for the type of pointer to
+  characters; the symbol @|const-string| is a type specifier for the type
+  pointer to constant characters.
+\end{describe}
+\begin{describe}{fun}{make-pointer-type @<subtype> \&optional @<qualifiers>}
+  Return an object describing the type of qualified pointers to @<subtype>.
+  If @<subtype> is interned, then the returned pointer type object is
+  interned also.
+\end{describe}
+
+\begin{describe}{cls}{c-array-type (c-type) \&key :subtype :dimensions}
+  Represents a multidimensional C array type.  The @<dimensions> are a list
+  of dimension specifiers $d_0$, $d_1$, \ldots, $d_{n-1}$; an instance then
+  denotes the C type @<subtype> @|[$d_0$][$d_1$]$\ldots$[$d_{n-1}$]|.  An
+  individual dimension specifier is either a string containing a C integral
+  constant expression, or nil which is equivalent to an empty string.  Only
+  the first (outermost) dimension $d_0$ should be empty.
+
+  C doesn't actually have multidimensional arrays as a primitive notion;
+  rather, it permits an array (with known extent) to be the element type of
+  an array, which achieves an equivalent effect.  C arrays are stored in
+  row-major order: i.e., if we write down the indices of the elements of an
+  array in order of ascending address, the rightmost index varies fastest;
+  hence, the type constructed is more accurately an array of $d_0$ arrays of
+  $d_1$ of \ldots\ arrays of $d_{n-1}$ elements of type @<subtype>.  We shall
+  continue to abuse terminology and refer to multidimensional arrays.
+
+  The type specifier @|([] @<type-spec> @<dimension>^*)| constructs a
+  multidimensional array with the given @<dimension>s whose elements have the
+  type specified by @<type-spec>.  If no dimensions are given then a
+  single-dimensional array with unspecified extent.  The synonyms @|array|
+  and @|vector| may be used in place of the brackets @`[]'.
+\end{describe}
+\begin{describe}{fun}{make-array-type @<subtype> @<dimensions>}
+  Return an object describing the type of arrays with given @<dimensions> and
+  with element type @<subtype> (an instance of @|c-type|).  The @<dimensions>
+  argument is a list whose elements are strings or nil; see the description
+  of the class @|c-array-type| above for details.
+\end{describe}
+\begin{describe}{gf}{c-array-dimensions @<type>}
+  Returns the dimensions of @<type>, an array type, as an immutable list.
+\end{describe}
+
+\subsection{Function types} \label{sec:proto.c-types.fun}
+
+\begin{describe}{cls}{c-function-type (c-type) \&key :subtype :arguments}
+  Represents C function types.  An instance denotes the C type of a C
+  function which 
+\end{describe}
+
+%%%----- That's all, folks --------------------------------------------------
+
+%%% Local variables:
+%%% mode: LaTeX
+%%% TeX-master: "sod.tex"
+%%% TeX-PDF-mode: t
+%%% End:
diff --git a/sod-tut.tex b/doc/sod-tut.tex
similarity index 100%
rename from sod-tut.tex
rename to doc/sod-tut.tex
diff --git a/sod.tex b/doc/sod.tex
similarity index 91%
rename from sod.tex
rename to doc/sod.tex
index dfc4a10..50f6121 100644
--- a/sod.tex
+++ b/doc/sod.tex
@@ -5,28 +5,58 @@
 \usepackage[palatino, helvetica, courier, maths=cmr]{mdwfonts}
 \usepackage{syntax}
 \usepackage{sverb}
+\usepackage{mdwtab}
+\usepackage{footnote}
 \usepackage{at}
 \usepackage{mdwref}
 
 \title{A Sensible Object Design for C}
 \author{Mark Wooding}
 
+\makeatletter
+
+\errorcontextlines999
+
 \def\syntleft{\normalfont\itshape}
 \let\syntright\empty
 
-\def\ulitleft{\normalfont\sffamily}
+\let\codeface\sffamily
+
+\def\ulitleft{\normalfont\codeface}
 \let\ulitright\empty
 
 \let\listingsize\relax
 
 \let\epsilon\varepsilon
 
-\atdef <#1>{\synt{#1}}
-\atdef "#1"{\lit*{#1}}
-\atdef `#1'{\lit{#1}}
-\atdef |#1|{\textsf{#1}}
-
-\def\Cplusplus{C\kern-1pt++}
+\atdef <#1>{\synt{#1}\@scripts}
+\atdef "#1"{\lit*{#1}\@scripts}
+\atdef `#1'{\lit{#1}\@scripts}
+\atdef |#1|{\textsf{#1}\@scripts}
+\def\dbl@maybe#1{\let\@tempa#1\futurelet\@ch\dbl@maybe@i}
+\def\dbl@maybe@i{\m@maybe\ifx\@ch\@tempa\@tempa\!\@tempa%
+  \expandafter\@firstoftwo\expandafter\@scripts%
+  \else\@tempa\expandafter\@scripts\fi}
+\atdef [{\dbl@maybe[}
+\atdef ]{\dbl@maybe]}
+\atdef {{\m@maybe\{\@scripts}
+\atdef }{\m@maybe\}\@scripts}
+\atdef ({\m@maybe(\@scripts}
+\atdef ){\m@maybe)\@scripts}
+\atdef !{\m@maybe|\@scripts}
+\atdef to{\leavevmode\unskip\quad\m@maybe\longrightarrow\m@maybe@end\quad}
+\let\m@maybe@end\relax
+\def\m@maybe{\ifmmode\else$\let\m@maybe@end$\fi}
+\def\@scripts{\futurelet\@ch\@scripts@i}
+
+\atdef ;#1\\{\normalfont\itshape;#1\\}
+
+\begingroup\lccode`\~=`\_\lowercase{\endgroup
+\def\@scripts@i{\if1\ifx\@ch~1\else\ifx\@ch^1\else0\fi\fi%
+  \expandafter\@scripts@ii\else\expandafter\m@maybe@end\fi}}
+\def\@scripts@ii#1#2{\m@maybe#1{#2}\@scripts}
+
+\def\Cplusplus{C\kern-\p@++}
 \def\Csharp{C\#}
 \def\man#1#2{\textbf{#1}(#2)}
 
@@ -34,9 +64,9 @@
 \lowercase{
 \endgroup
 \def\prog{%
-  \sffamily%
+  \codeface%
   \quote%
-  \let\oldnl\\%
+  \let\old@nl\\%
   \obeylines%
   \tabbing%
   \global\let~\\%
@@ -44,10 +74,59 @@
 }
 \def\endprog{%
   \endtabbing%
-  \global\let\\\oldnl%
+  \global\let\\\old@nl%
   \endquote%
 }}
 
+\newenvironment{boxy}[1][\q@]{%
+  \dimen@\linewidth\advance\dimen@-1.2pt\advance\dimen@-2ex%
+  \medskip%
+  \vbox\bgroup\hrule\hbox\bgroup\vrule%
+  \vbox\bgroup\vskip1ex\hbox\bgroup\hskip1ex\minipage\dimen@%
+  \def\@temp{#1}\ifx\@temp\q@\else\leavevmode{\headfam\bfseries#1\quad}\fi%
+}{%
+  \endminipage\hskip1ex\egroup\vskip1ex\egroup%
+  \vrule\egroup\hrule\egroup%
+  \medskip%
+}
+
+\def\definedescribecategory#1#2{\@namedef{cat!#1}{#2}}
+\def\describecategoryname#1{%
+  \expandafter\let\expandafter\@tempa\csname cat!#1\endcsname%
+  \ifx\@tempa\relax#1\else\@tempa\fi}
+\definedescribecategory{fun}{function}
+\definedescribecategory{gf}{generic function}
+\definedescribecategory{var}{variable}
+\definedescribecategory{const}{constant}
+\definedescribecategory{meth}{primary method}
+\definedescribecategory{ar-meth}{around-method}
+\definedescribecategory{be-meth}{before-method}
+\definedescribecategory{af-meth}{after-method}
+\definedescribecategory{cls}{class}
+\definedescribecategory{ty}{type}
+\definedescribecategory{mac}{macro}
+
+\def\q@{\q@}
+\newenvironment{describe}[3][\q@]{%
+  \normalfont%
+  \par\goodbreak%
+  \vspace{\bigskipamount}%
+  \setbox\z@\hbox{\bfseries[\describecategoryname{#2}]}%
+  \dimen@\linewidth\advance\dimen@-\wd\z@%
+  \def\@temp##1 ##2\q@{\message{#2:##1}\label{#2:##1}}%
+  \def\@tempa{#1}\ifx\@tempa\q@\@temp#3 \q@\else\@temp{#1} \\\fi%
+  \edef\@temp{{\the\linewidth}{@{}p{\the\dimen@}%
+      @{\extracolsep{\fill}}l@{\extracolsep{0pt}}}}%
+  \noindent\csname tabular*\expandafter\endcsname\@temp%
+  \tabbing\codeface#3\endtabbing&\unhbox\z@\\\endtabular%
+%  \@afterheading%
+  \list{}{\rightmargin\z@}\item%
+}{%
+  \endlist%
+}
+
+\def\push{\quad\=\+\kill}
+
 \begin{document}
 
 \maketitle
diff --git a/standard-method-combination.svg b/doc/standard-method-combination.svg
similarity index 100%
rename from standard-method-combination.svg
rename to doc/standard-method-combination.svg
diff --git a/emacs-hacks.el b/emacs-hacks.el
new file mode 100644
index 0000000..c807c28
--- /dev/null
+++ b/emacs-hacks.el
@@ -0,0 +1,14 @@
+(dolist (entry '((parse 0)
+		 (many 1)
+		 (skip-many 1)
+		 (seq 1)
+		 (lisp 0)
+		 (if-parse 2)
+		 (if-char 2)
+		 (expr 1)
+		 (acond . cond)
+		 (define-class-slot 3)))
+  (put (car entry) 'common-lisp-indent-function
+       (if (symbolp (cdr entry))
+	   (get (cdr entry) 'common-lisp-indent-function)
+	 (cadr entry))))
\ No newline at end of file
diff --git a/layout.org b/layout.org
deleted file mode 100644
index 2bc237a..0000000
--- a/layout.org
+++ /dev/null
@@ -1,141 +0,0 @@
-* Instance layout
-
-This is fairly easy.  The superclasses are partitioned into chains.
-Each chain is named after its head class (i.e., the class with no
-successor).
-
-** Things in instance layouts
-
-An instance layout contains a chunk for each component chain.
-
-	struct CLASS__ilayout {
-	  struct CLASS__ichain_CHAINn NICKn;
-	  /* ... */
-	};
-
-An ilayout is a C structure consisting of an ichain for each of the
-class's chains, with the primary chain first.  The others are in
-direct-superclass order.
-
-** Instance slots
-
-An islots structure is a C structure consisting of a class's instance
-slots, in order.
-
-	struct CLASS__islots {
-	  TYPEn SLOTn;
-	  /* ... */
-	};
-
-If a class defines no slots then it has no islots structure.
-
-** Instance chains
-
-	struct CLASS__ichain_CHAIN {
-	  const struct CLASS__vt_CHAIN *_vt;
-	  struct SUPERn__islots NICKn;
-	  /* ... */
-	};
-
-A ichain is a C structure consisting of:
-
-  * A pointer `_vt' to the chain's vtable structure.
-
-  * An islots substructure, named after the class's nick for each class
-    on the chain, least-specific first.
-
-Because of the chain invariant, all of a class's ichains are prefixes of
-the corresponding ichains of any of its subclasses.
-
-The type CLASS is an alias for the class's primary ichain
-CLASS__ichain_CHAIN.  One needs to do a cross-chain upcast to find slots
-in non-primary chains.
-
-* Vtable layout
-
-This is more complicated.  The vtable for a chain doesn't just contain
-things directly relevant to the classes on the chain: because a vtable
-is (assumed) immutable, we can have copies of values from other chains
-where this is convenient.
-
-Note that effective methods are customized for particular classes: they
-can assume that their argument points to a specific ichain of a an
-instance of a specific class.  This makes conversions in effective
-methods very cheap.  By including apparently effective-method pointers
-for messages defined in other chains, we can speed up dispatch.
-
-** Things in a vtable chain
-
-There are three kinds of items to store in a vtable chain.
-
-  * Class pointers
-  * The base offset
-  * Chain offsets
-  * Effective method pointers
-
-	struct CLASS__vt_CHAIN {
-	  struct METACLASS__ichain_sod_object *_class;
-	  size_t _base;
-	  struct METACLASS__ichain_METACHAINn *_cls_NICKn;
-	  ptrdiff_t _off_CHAINn;
-	  struct SUPERn__vtmsgs NICKn;
-	};
-
-A class has a separate vtable chain for each of its chains.
-
-** The base offset
-
-There is a single member _base which is the offset of the chain's ichain
-in the overall ilayout structure.  This lets you find the bottom of the
-ilayout given a pointer to any ichain as
-
-	(CLASS__ilayout *)((char *)p - p->_vt._base)
-
-** Class pointers
-
-The class's metaclass may have multiple chains.  For each chain of the
-metaclass, there is a separate pointer to that metaclass's ichain, named
-_cls_NICKn after the metaclass's chain head.  Exception: _cls_cls is
-called _class instead.
-
-** Chain offsets
-
-For each other chain, there is a member _off_NICKn named after the
-chain's head giving the offset of that ichain from the current chain's
-ichain.  (There's a long way around, exploring the class's layout
-information, but this provides a much easier way of doing cross-chain
-upcasts.)
-
-** Effective method pointers
-
-For each class, there may be a structure
-
-	struct CLASS__vtmsgs {
-	  TYPEn (*MSGn)(ARGnn *, ...);
-	  /* ... */
-	};
-
-of pointers to effective methods for the messages defined by the class.
-If a class defines no messages then it won't have a vtmsgs structure.
-
-** Layout order
-
-The first two items are always _class and _base.  After that:
-
-  * for each class in the chain, from least to most specific,
-
-  * for each of that class's superclasses, in reverse class-precedence-
-    list order, which has not yet been processed:
-
-  * if the class is in a chain which hasn't been seen before (it must be
-    the chain head!), emit a chain offset for it;
-
-  * if the class has a metaclass chain which hasn't been seen before,
-    emit a class pointer for it;
-
-  * if the class has a vtmsgs structure, emit it.
-
-* Questions
-
-Are class-slot initializers inherited?  No.  We have instance
-initializers on metaclasses for that.
diff --git a/sod.c b/lib/sod.c
similarity index 95%
rename from sod.c
rename to lib/sod.c
index 24a6429..bd600f9 100644
--- a/sod.c
+++ b/lib/sod.c
@@ -7,7 +7,7 @@
 
 /*----- Licensing notice --------------------------------------------------*
  *
- * This file is part of the Simple Object Definition system.
+ * This file is part of the Sensble Object Design, an object system for C.
  *
  * SOD is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -79,8 +79,8 @@ static const struct sod_chain *find_chain(const SodClass *sub,
  * Returns:	Nonzero if @sub@ is a subclass of @super@.
  */
 
-int sod_subclassp(const SodClass *c, const SodClass *d)
-  { return (!!find_chain(c, d)); }
+int sod_subclassp(const SodClass *sub, const SodClass *super)
+  { return (!!find_chain(sub, super)); }
 
 /* --- @sod_convert@ --- *
  *
diff --git a/sod.h b/lib/sod.h
similarity index 91%
rename from sod.h
rename to lib/sod.h
index 999c30e..12c7817 100644
--- a/sod.h
+++ b/lib/sod.h
@@ -7,7 +7,7 @@
 
 /*----- Licensing notice --------------------------------------------------*
  *
- * This file is part of the Simple Object Definition system.
+ * This file is part of the Sensble Object Design, an object system for C.
  *
  * SOD is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -44,7 +44,7 @@
  * pointer to one of these.
  */
 struct sod_vtable {
-  SodClass *_class;			/* Pointer to class object */
+  const SodClass *_class;		/* Pointer to class object */
   size_t _base;				/* Offset to instance base */
 };
 
@@ -141,12 +141,12 @@ struct sod_chain {
 
 /* --- @sod_subclassp@ --- *
  *
- * Arguments:	@const SodClass *c, *d@ = pointers to two classes
+ * Arguments:	@const SodClass *sub, *super@ = pointers to two classes
  *
  * Returns:	Nonzero if @c@ is a subclass of @d@.
  */
 
-extern int sod_subclassp(const SodClass */*c*/, const SodClass */*d*/);
+extern int sod_subclassp(const SodClass */*sub*/, const SodClass */*super*/);
 
 /* --- @sod_convert@ --- *
  *
@@ -159,19 +159,19 @@ extern int sod_subclassp(const SodClass */*c*/, const SodClass */*d*/);
  * Use:		General down/cross-casting function.
  *
  *		Upcasts can be performed efficiently using the automatically
- *		generated macros.  In particular, upcasts with a chain are
+ *		generated macros.  In particular, upcasts within a chain are
  *		trivial; cross-chain upcasts require information from vtables
  *		but are fairly fast.  This function is rather slower, but is
  *		much more general.
  *
  *		Suppose we have an instance of a class C, referred to by a
- *		pointer to an instance of one of C's superclasses S.  If S'
+ *		pointer to an instance of one of C's superclasses S.  If T
  *		is some other superclass of C then this function will return
- *		a pointer to C suitable for use as an instance of S'.  If S'
+ *		a pointer to C suitable for use as an instance of T.  If T
  *		is not a superclass of C, then the function returns null.
  *		(If the pointer doesn't point to an instance of some class
  *		then the behaviour is undefined.)  Note that you don't need
- *		to know what C or S actually are.
+ *		to know what either C or S actually are.
  */
 
 extern void *sod_convert(const SodClass */*cls*/, void */*p*/);
diff --git a/output.lisp b/output.lisp
deleted file mode 100644
index b0df32b..0000000
--- a/output.lisp
+++ /dev/null
@@ -1,259 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Output driver for SOD translator
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Sequencing machinery.
-
-(defclass sequencer-item ()
-  ((name :initarg :name :reader sequencer-item-name)
-   (functions :initarg :functions :initform nil
-	      :type list :accessor sequencer-item-functions))
-  (:documentation
-   "Represents a distinct item to be sequenced by a SEQUENCER.
-
-   A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
-   sequencer is invoked.  This class is not intended to be subclassed."))
-
-(defmethod print-object ((item sequencer-item) stream)
-  (print-unreadable-object (item stream :type t)
-    (prin1 (sequencer-item-name item) stream)))
-
-(defclass sequencer ()
-  ((constraints :initarg :constraints :initform nil
-		:type list :accessor sequencer-constraints)
-   (table :initform (make-hash-table :test #'equal)
-	  :reader sequencer-table))
-  (:documentation
-   "A sequencer tracks items and invokes them in the proper order.
-
-   The job of a SEQUENCER object is threefold.  Firstly, it collects
-   sequencer items and stores them in its table indexed by name.  Secondly,
-   it gathers CONSTRAINTS, which impose an ordering on the items.  Thirdly,
-   it can be instructed to invoke the items in an order compatible with the
-   established constraints.
-
-   Sequencer item names may may any kind of object which can be compared with
-   EQUAL.  In particular, symbols, integers and strings are reasonable
-   choices for atomic names, and lists work well for compound names -- so
-   it's possible to construct a hierarchy."))
-
-(defgeneric ensure-sequencer-item (sequencer name)
-  (:documentation
-   "Arrange that SEQUENCER has a sequencer-item called NAME.
-
-   Returns the corresponding SEQUENCER-ITEM object."))
-
-(defgeneric add-sequencer-constraint (sequencer constraint)
-  (:documentation
-   "Attach the given CONSTRAINT to an SEQUENCER.
-
-   The CONSTRAINT should be a list of sequencer-item names; see
-   ENSURE-SEQUENCER-ITEM for what they look like.  Note that the names
-   needn't have been declared in advance; indeed, they needn't be mentioned
-   anywhere else at all."))
-
-(defgeneric add-sequencer-item-function (sequencer name function)
-  (:documentation
-   "Arranges to call FUNCTION when the item called NAME is traversed.
-
-   More than one function can be associated with a given sequencer item.
-   They are called in the same order in which they were added.
-
-   Note that an item must be mentioned in at least one constraint in order to
-   be traversed by INVOKE-SEQUENCER-ITEMS.  If there are no special ordering
-   requirments for a particular item, then the trivial constraint (NAME) will
-   suffice."))
-
-(defgeneric invoke-sequencer-items (sequencer &rest arguments)
-  (:documentation
-   "Invoke functions attached to the SEQUENCER's items in the right order.
-
-   Each function is invoked in turn with the list of ARGUMENTS.  The return
-   values of the functions are discarded."))
-
-(defmethod ensure-sequencer-item ((sequencer sequencer) name)
-  (with-slots (table) sequencer
-    (or (gethash name table)
-	(setf (gethash name table)
-	      (make-instance 'sequencer-item :name name)))))
-
-(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
-  (let ((converted-constraint (mapcar (lambda (name)
-					(ensure-sequencer-item sequencer
-							       name))
-				      constraint)))
-    (with-slots (constraints) sequencer
-      (pushnew converted-constraint constraints :test #'equal))))
-
-(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
-  (let ((item (ensure-sequencer-item sequencer name)))
-    (pushnew function (sequencer-item-functions item))))
-
-(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
-  (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
-    (dolist (function (reverse (sequencer-item-functions item)))
-      (apply function arguments))))
-
-;;;--------------------------------------------------------------------------
-;;; Output preparation.
-
-(defgeneric add-output-hooks (object reason sequencer)
-  (:documentation
-   "Announces the intention to write SEQUENCER, with a particular REASON.
-
-   The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
-   can be matched using an EQL-specializer.  In response, OBJECT should add
-   any constrains and item functions that it wishes, and pass the
-   announcement to its sub-objects.")
-  (:method-combination progn)
-  (:method progn (object reason sequencer)
-    nil))
-
-(defvar *seen-announcement*)		;Keep me unbound!
-#+hmm
-(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
-  "Arrange not to invoke any object more than once during a particular
-   announcement."
-  (declare (ignore stuff))
-  (cond ((not (boundp '*seen-announcement*))
-	 (let ((*seen-announcement* (make-hash-table)))
-	   (setf (gethash object *seen-announcement*) t)
-	   (call-next-method)))
-	((gethash object *seen-announcement*)
-	 nil)
-	(t
-	 (setf (gethash object *seen-announcement*) t)
-	 (call-next-method))))
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-;;;--------------------------------------------------------------------------
-;;; Header output.
-
-(defun write-module-header (module)
-  (let* ((file (merge-pathnames (make-pathname :type "H" :case :common)
-				(module-name module)))
-	 (fakename (make-pathname :name (pathname-name file)
-				  :type (pathname-type file))))
-    (with-open-file (uoutput file
-			     :direction :output
-			     :if-exists :supersede
-			     :if-does-not-exist :create)
-      (let ((output (make-instance 'position-aware-output-stream
-				   :stream uoutput
-				   :file fakename)))
-
-	;; Format the header and guards.
-	(format output "~
-/* -*-c-*-
- *
- * Header file generated by SOD for ~A
- */
-
-#ifndef ~A
-#define ~:*~A
-
-#ifdef __cplusplus
-  extern \"C\" {
-#endif~%"
-		(namestring (module-name module))
-		(or (getf (module-plist module) 'include-guard)
-		    ))
-
-	  ;; Forward declarations of all the structures and types.  Nothing
-	  ;; interesting gets said here; this is just so that the user code
-	  ;; can talk meainingfully about the things we're meant to be
-	  ;; defining here.
-	  ;;
-	  ;; FIXME
-
-	  ;; The user fragments.
-	  (when (module-header-fragments module)
-	    (banner "User code" output)
-	    (dolist (frag (module-header-fragments module))
-	      (princ frag output)))
-
-	  ;; The definitions of the necessary structures.
-	  ;;
-	  ;; FIXME
-
-	  ;; The definitions of the necessary direct-methods.
-	  ;;
-	  ;; FIXME
-
-	  ;; The trailer section.
-	  (banner "That's all, folks" output)
-	  (format output "~
-#ifdef __cplusplus
-  }
-#endif
-
-#endif~%")))))
-
-;;;--------------------------------------------------------------------------
-;;; Source output.
-
-(defun write-module-source (module)
-  (let* ((file (merge-pathnames (make-pathname :type "C" :case :common)
-				(module-name module)))
-	 (fakename (make-pathname :name (pathname-name file)
-				  :type (pathname-type file))))
-    (with-open-file (uoutput file
-			     :direction :output
-			     :if-exists :supersede
-			     :if-does-not-exist :create)
-      (let ((output (make-instance 'position-aware-output-stream
-				   :stream uoutput
-				   :file fakename)))
-
-	;; Format the header.
-	(format output "~
-/* -*-c-*-
- *
- * Source file generated by SOD for ~A
- */~%"
-		(namestring (module-name module)))
-
-	  ;; The user fragments.
-	  (when (module-source-fragments module)
-	    (banner "User code" output)
-	    (dolist (frag (module-source-fragments module))
-	      (princ frag output)))
-
-	  ;; The definitions of the necessary tables.
-	  ;;
-	  ;; FIXME
-
-	  ;; The definitions of the necessary effective-methods.
-	  ;;
-	  ;; FIXME
-
-	  ;; The trailer section.
-	  (banner "That's all, folks" output :blank-line-p nil)))))
-
-;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/builtin.lisp b/pre-reorg/builtin.lisp
new file mode 100644
index 0000000..ef99571
--- /dev/null
+++ b/pre-reorg/builtin.lisp
@@ -0,0 +1,42 @@
+;;; -*-lisp-*-
+;;;
+;;; Builtin module provides basic definitions
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(define-sod-class "AbstractStack" ("SodObject")
+  :nick 'abstk
+  (message "emptyp" (fun int))
+  (message "push" (fun void ("item" (* void))))
+  (message "pop" (fun (* void)))
+  (method "abstk" "pop" (fun void) #{
+     assert(!me->_vt.emptyp());
+   }
+   :role :before))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/c-types.lisp b/pre-reorg/c-types.lisp
new file mode 100644
index 0000000..4a443cd
--- /dev/null
+++ b/pre-reorg/c-types.lisp
@@ -0,0 +1,79 @@
+;;; -*-lisp-*-
+;;;
+;;; Dealing with C types
+;;;
+;;; (c) 2008 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Plain old C types.
+
+;; Class definition.
+
+;; Important protocol.
+
+;; Utility functions and macros.
+
+;; S-expression syntax machinery.
+
+;; Basic definitions.
+
+;; A handy utility.
+
+;;;--------------------------------------------------------------------------
+;;; Simple C types (e.g., built-in arithmetic types).
+
+;; Basic definitions.
+
+(let ((cache (make-hash-table :test #'equal)))
+
+;;;--------------------------------------------------------------------------
+;;; Tag types (structs, unions and enums).
+
+;; Definitions.
+
+;;;--------------------------------------------------------------------------
+;;; Pointer types.
+
+;; Definitions.
+
+(let ((cache (make-hash-table :test #'eql)))
+
+;; S-expression syntax.
+
+;;;--------------------------------------------------------------------------
+;;; Array types.
+
+;; Definitions.
+
+
+;;;--------------------------------------------------------------------------
+;;; Function types.
+
+;; Arguments.
+
+;; Definitions.
+
+;; S-expression syntax.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/class-builder.lisp b/pre-reorg/class-builder.lisp
new file mode 100644
index 0000000..5107ffb
--- /dev/null
+++ b/pre-reorg/class-builder.lisp
@@ -0,0 +1,129 @@
+;;; -*-lisp-*-
+;;;
+;;; Equipment for building classes and friends
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Finding things by name
+
+(defun find-superclass-by-nick (class nick)
+  "Returns the superclass of CLASS with nickname NICK, or signals an error."
+
+  ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
+  ;; trundle through its superclasses and hope for the best.
+  (if (string= nick (sod-class-nickname class))
+      class
+      (or (some (lambda (super)
+		  (find nick (sod-class-precedence-list super)
+			:key #'sod-class-nickname
+			:test #'string=))
+		(sod-class-direct-superclasses class))
+	  (error "No superclass of `~A' with nickname `~A'" class nick))))
+
+(flet ((find-item-by-name (what class list name key)
+	 (or (find name list :key key :test #'string=)
+	     (error "No ~A in class `~A' with name `~A'" what class name))))
+
+  (defun find-instance-slot-by-name (class super-nick slot-name)
+    (let ((super (find-superclass-by-nick class super-nick)))
+      (find-item-by-name "slot" super (sod-class-slots super)
+			 slot-name #'sod-slot-name)))
+
+  (defun find-class-slot-by-name (class super-nick slot-name)
+    (let* ((meta (sod-class-metaclass class))
+	   (super (find-superclass-by-nick meta super-nick)))
+      (find-item-by-name "slot" super (sod-class-slots super)
+			 slot-name #'sod-slot-name)))
+
+  (defun find-message-by-name (class super-nick message-name)
+    (let ((super (find-superclass-by-nick class super-nick)))
+      (find-item-by-name "message" super (sod-class-messages super)
+			 message-name #'sod-message-name))))
+
+;;;--------------------------------------------------------------------------
+;;; Class construction.
+
+(defun make-sod-class (name superclasses pset &optional location)
+  "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
+
+   This is the main constructor function for classes.  The protocol works as
+   follows.  The :LISP-CLASS property in PSET is checked: if it exists, it
+   must be a symbol naming a (CLOS) class, which is used in place of
+   SOD-CLASS.  All of the arguments are then passed to MAKE-INSTANCE; further
+   behaviour is left to the standard CLOS instance construction protocol; for
+   example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
+
+   Minimal sanity checking is done during class construction; most of it is
+   left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
+
+   Unused properties in PSET are diagnosed as errors."
+
+  (with-default-error-location (location)
+    (let ((class (make-instance (get-property pset :lisp-class :symbol
+					      'sod-class)
+				:name name
+				:superclasses superclasses
+				:location (file-location location)
+				:pset pset)))
+      (check-unused-properties pset)
+      class)))
+
+(defgeneric guess-metaclass (class)
+  (:documentation
+   "Determine a suitable metaclass for the CLASS.
+
+   The default behaviour is to choose the most specific metaclass of any of
+   the direct superclasses of CLASS, or to signal an error if that failed."))
+
+;;;--------------------------------------------------------------------------
+;;; Slot construction.
+
+(defgeneric make-sod-slot (class name type pset &optional location)
+  (:documentation
+   "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
+
+   This is the main constructor function for slots.  This is a generic
+   function primarily so that the CLASS can intervene in the construction
+   process.  The default method uses the :LISP-CLASS property (defaulting to
+   SOD-SLOT) to choose a (CLOS) class to instantiate.  The slot is then
+   constructed by MAKE-INSTANCE passing the arguments as initargs; further
+   behaviour is left to the standard CLOS instance construction protocol; for
+   example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
+
+   Unused properties on PSET are diagnosed as errors."))
+
+;;;--------------------------------------------------------------------------
+;;; Slot initializer construction.
+
+;;;--------------------------------------------------------------------------
+;;; Message construction.
+
+;;;--------------------------------------------------------------------------
+;;; Method construction.
+
+;;;--------------------------------------------------------------------------
+;;; Builder macros.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/class-defs.lisp b/pre-reorg/class-defs.lisp
similarity index 100%
rename from class-defs.lisp
rename to pre-reorg/class-defs.lisp
diff --git a/pre-reorg/class-finalize.lisp b/pre-reorg/class-finalize.lisp
new file mode 100644
index 0000000..fc2d967
--- /dev/null
+++ b/pre-reorg/class-finalize.lisp
@@ -0,0 +1,31 @@
+;;; -*-lisp-*-
+;;;
+;;; Class finalization
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Class finalization.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/class-layout.lisp b/pre-reorg/class-layout.lisp
new file mode 100644
index 0000000..8b6b1eb
--- /dev/null
+++ b/pre-reorg/class-layout.lisp
@@ -0,0 +1,80 @@
+;;; -*-lisp-*-
+;;;
+;;; Layout for instances and vtables
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slot objects.
+
+(defclass effective-slot ()
+  ((class :initarg :class :type sod-slot :reader effective-slot-class)
+   (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
+   (initializer :initarg :initializer :type (or sod-initializer null)
+		:reader effective-slot-initializer))
+  (:documentation
+   "Describes a slot and how it's meant to be initialized.
+
+   Effective slot objects are usually attached to layouts."))
+
+(defgeneric find-slot-initializer (class slot)
+  (:documentation
+   "Return the most specific initializer for SLOT, starting from CLASS."))
+
+(defgeneric compute-effective-slot (class slot)
+  (:documentation
+   "Construct an effective slot from the supplied direct slot.
+
+   SLOT is a direct slot defined on CLASS or one of its superclasses.
+   (Metaclass initializers are handled using a different mechanism.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout objects.
+
+(defclass islots ()
+  ((class :initarg :class :type sod-class :reader islots-class)
+   (subclass :initarg :subclass :type sod-class :reader islots-subclass)
+   (slots :initarg :slots :type list :reader islots-slots))
+  (:documentation
+   "The collection of effective SLOTS defined by an instance of CLASS."))
+
+;;; Standard implementation.
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods.
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+;;; base-offset
+
+;;; chain-offset
+
+;;; vtable
+
+;;; Implementation.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/class-output.lisp b/pre-reorg/class-output.lisp
similarity index 78%
rename from class-output.lisp
rename to pre-reorg/class-output.lisp
index da6531b..b93a0a0 100644
--- a/class-output.lisp
+++ b/pre-reorg/class-output.lisp
@@ -26,40 +26,10 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
-;;; Utility macro.
-
-(defmacro sequence-output
-    ((streamvar sequencer) &body clauses)
-  (let ((seqvar (gensym "SEQ")))
-    (labels ((convert-item-name (name)
-	       (if (listp name)
-		   (cons 'list name)
-		   name))
-	     (convert-constraint (constraint)
-	       (cons 'list (mapcar #'convert-item-name constraint)))
-	     (process-body (clauses)
-	       (if (eq (car clauses) :constraint)
-		   (cons `(add-sequencer-constraint
-			   ,seqvar
-			   ,(convert-constraint (cadr clauses)))
-			 (process-body (cddr clauses)))
-		   (mapcar (lambda (clause)
-			     (let ((name (car clause))
-				   (body (cdr clause)))
-			       `(add-sequencer-item-function
-				 ,seqvar
-				 ,(convert-item-name name)
-				 (lambda (,streamvar)
-				   ,@body))))
-			   clauses))))
-      `(let ((,seqvar ,sequencer))
-	 ,@(process-body clauses)))))
-
-;;;--------------------------------------------------------------------------
 ;;; Classes.
 
-(defmethod add-output-hooks progn
-    ((class sod-class) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((class sod-class) (reason (eql :h))
+				   sequencer)
 
   ;; Main output sequencing.
   (sequence-output (stream sequencer)
@@ -103,7 +73,7 @@
   ;; Maybe generate an islots structure.
   (when (sod-class-slots class)
     (dolist (slot (sod-class-slots class))
-      (add-output-hooks slot 'populate-islots sequencer))
+      (hook-output slot 'islots sequencer))
     (sequence-output (stream sequencer)
       ((class :islots :start)
        (format stream "/* Instance slots. */~@
@@ -136,35 +106,39 @@
 	 (terpri stream)))))
 
   ;; Generate vtmsgs structure for all superclasses.
-  (add-output-hooks (car (sod-class-vtables class))
-		    'populate-vtmsgs
+  (hook-output (car (sod-class-vtables class))
+		    'vtmsgs
 		    sequencer))
 
-(defmethod add-output-hooks progn ((class sod-class) reason sequencer)
+(defmethod hook-output progn ((class sod-class) reason sequencer)
   (with-slots (ilayout vtables methods effective-methods) class
-    (add-output-hooks ilayout reason sequencer)
-    (dolist (method methods) (add-output-hooks method reason sequencer))
+    (hook-output ilayout reason sequencer)
+    (dolist (method methods) (hook-output method reason sequencer))
     (dolist (method effective-methods)
-      (add-output-hooks method reason sequencer))
-    (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
+      (hook-output method reason sequencer))
+    (dolist (vtable vtables) (hook-output vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Instance structure.
 
-(defmethod add-output-hooks progn
-    ((slot sod-slot) (reason (eql 'populate-islots)) sequencer)
+(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
+				   sequencer)
   (sequence-output (stream sequencer)
     (((sod-slot-class slot) :islots :slots)
      (pprint-logical-block (stream nil :prefix "  " :suffix ";")
        (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
      (terpri stream))))
 
-(defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer)
+(defmethod hook-output progn ((ilayout ilayout) reason sequencer)
   (with-slots (ichains) ilayout
-    (dolist (ichain ichains) (add-output-hooks ichain reason sequencer))))
+    (dolist (ichain ichains) (hook-output ichain reason sequencer))))
 
-(defmethod add-output-hooks progn
-    ((ilayout ilayout) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((ichain ichain) reason sequencer)
+  (dolist (item (ichain-body ichain))
+    (hook-output item reason sequencer)))
+
+(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
+				   sequencer)
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)
@@ -174,10 +148,10 @@
       ((class :ilayout :end)
        (format stream "};~2%")))
     (dolist (ichain ichains)
-      (add-output-hooks ichain 'populate-ilayout sequencer))))
+      (hook-output ichain 'ilayout sequencer))))
 
-(defmethod add-output-hooks progn
-    ((ichain ichain) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
+				   sequencer)
   (with-slots (class chain-head chain-tail) ichain
     (when (eq class chain-tail)
       (sequence-output (stream sequencer)
@@ -197,13 +171,17 @@
 			 ~:{  struct ~A ~A;~%~}~
 			 };~2%"
 		 (ichain-union-tag chain-tail chain-head)
+
+		 ;; Make sure the most specific class is first: only the
+		 ;; first element of a union can be statically initialized in
+		 ;; C90.
 		 (mapcar (lambda (super)
 			   (list (ichain-struct-tag super chain-head)
 				 (sod-class-nickname super)))
 			 (sod-class-chain chain-tail))))))))
 
-(defmethod add-output-hooks progn
-    ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
+				   sequencer)
   (with-slots (class chain-head chain-tail) ichain
     (sequence-output (stream sequencer)
       ((class :ilayout :slots)
@@ -211,20 +189,20 @@
 	       (ichain-union-tag chain-tail chain-head)
 	       (sod-class-nickname chain-head))))))
 
-(defmethod add-output-hooks progn
-    ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
+				   sequencer)
   (with-slots (class chain-head chain-tail) vtptr
     (sequence-output (stream sequencer)
       ((class :ichain chain-head :slots)
        (format stream "  const struct ~A *_vt;~%"
 	       (vtable-struct-tag chain-tail chain-head))))))
 
-(defmethod add-output-hooks progn ((islots islots) reason sequencer)
+(defmethod hook-output progn ((islots islots) reason sequencer)
   (dolist (slot (islots-slots islots))
-    (add-output-hooks slot reason sequencer)))
+    (hook-output slot reason sequencer)))
 
-(defmethod add-output-hooks progn
-    ((islots islots) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((islots islots) (reason (eql :h))
+				   sequencer)
   (with-slots (class subclass slots) islots
     (sequence-output (stream sequencer)
       ((subclass :ichain (sod-class-chain-head class) :slots)
@@ -235,12 +213,12 @@
 ;;;--------------------------------------------------------------------------
 ;;; Vtable structure.
 
-(defmethod add-output-hooks progn ((vtable vtable) reason sequencer)
+(defmethod hook-output progn ((vtable vtable) reason sequencer)
   (with-slots (body) vtable
-    (dolist (item body) (add-output-hooks item reason sequencer))))
+    (dolist (item body) (hook-output item reason sequencer))))
 
-(defmethod add-output-hooks progn
-    ((method sod-method) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((method sod-method) (reason (eql :h))
+				   sequencer)
   (with-slots (class) method
     (sequence-output (stream sequencer)
       ((class :methods)
@@ -250,8 +228,8 @@
 			(sod-method-function-name method))
 	 (format stream ";~%"))))))
 
-(defmethod add-output-hooks progn
-    ((vtable vtable) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((vtable vtable) (reason (eql :h))
+				   sequencer)
   (with-slots (class chain-head chain-tail) vtable
     (when (eq class chain-tail)
       (sequence-output (stream sequencer)
@@ -272,8 +250,8 @@
 	       (vtable-struct-tag chain-tail chain-head)
 	       class (sod-class-nickname chain-head))))))
 
-(defmethod add-output-hooks progn
-    ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
+				   sequencer)
   (with-slots (class subclass chain-head chain-tail) vtmsgs
     (sequence-output (stream sequencer)
       ((subclass :vtable chain-head :slots)
@@ -281,8 +259,8 @@
 	       (vtmsgs-struct-tag subclass class)
 	       (sod-class-nickname class))))))
 
-(defmethod add-output-hooks progn
-    ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
+				   sequencer)
   (when (vtmsgs-entries vtmsgs)
     (with-slots (class subclass) vtmsgs
       (sequence-output (stream sequencer)
@@ -299,16 +277,16 @@
 	((subclass :vtmsgs class :end)
 	 (format stream "};~2%"))))))
 
-(defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
   (with-slots (entries) vtmsgs
-    (dolist (entry entries) (add-output-hooks entry reason sequencer))))
+    (dolist (entry entries) (hook-output entry reason sequencer))))
 
-(defmethod add-output-hooks progn ((entry method-entry) reason sequencer)
+(defmethod hook-output progn ((entry method-entry) reason sequencer)
   (with-slots (method) entry
-    (add-output-hooks method reason sequencer)))
+    (hook-output method reason sequencer)))
 
-(defmethod add-output-hooks progn
-    ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
+(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
+				   sequencer)
   (let* ((method (method-entry-effective-method entry))
 	 (message (effective-method-message method))
 	 (class (effective-method-class method))
@@ -320,8 +298,8 @@
 	 (pprint-c-type commented-type stream (sod-message-name message)))
        (terpri stream)))))
 
-(defmethod add-output-hooks progn
-    ((cptr class-pointer) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
+				   sequencer)
   (with-slots (class chain-head metaclass meta-chain-head) cptr
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
@@ -331,15 +309,15 @@
 		   (sod-class-nickname meta-chain-head)
 		   nil))))))
 
-(defmethod add-output-hooks progn
-    ((boff base-offset) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((boff base-offset) (reason (eql :h))
+				   sequencer)
   (with-slots (class chain-head) boff
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
        (write-line "  size_t _base;" stream)))))
 
-(defmethod add-output-hooks progn
-    ((choff chain-offset) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
+				   sequencer)
   (with-slots (class chain-head target-head) choff
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
@@ -351,8 +329,8 @@
 
 (defvar *instance-class*)
 
-(defmethod add-output-hooks progn
-    ((class sod-class) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((class sod-class) (reason (eql :c))
+				   sequencer)
   (sequence-output (stream sequencer)
 
     :constraint
@@ -377,18 +355,18 @@ const struct ~A ~A__classobj = {~%"
      (format stream "};~2%")))
 
   (let ((*instance-class* class))
-    (add-output-hooks (sod-class-ilayout (sod-class-metaclass class))
-		      'populate-class
+    (hook-output (sod-class-ilayout (sod-class-metaclass class))
+		      'class
 		      sequencer)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Direct methods.
 
-(defmethod add-output-hooks progn
-    ((method delegating-direct-method) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
+				   sequencer)
   (with-slots (class body) method
     (unless body
-      (return-from add-output-hooks))
+      (return-from hook-output))
     (sequence-output (stream sequencer)
       ((class :direct-method method :start)
        (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
@@ -398,11 +376,11 @@ const struct ~A ~A__classobj = {~%"
       ((class :direct-method method :end)
        (format stream "#undef CALL_NEXT_METHOD~%")))))
 
-(defmethod add-output-hooks progn
-    ((method sod-method) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((method sod-method) (reason (eql :c))
+				   sequencer)
   (with-slots (class body) method
     (unless body
-      (return-from add-output-hooks))
+      (return-from hook-output))
     (sequence-output (stream sequencer)
       :constraint ((class :direct-methods :start)
 		   (class :direct-method method :start)
@@ -422,8 +400,8 @@ const struct ~A ~A__classobj = {~%"
 ;;;--------------------------------------------------------------------------
 ;;; Vtables.
 
-(defmethod add-output-hooks progn
-    ((vtable vtable) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
+				   sequencer)
   (with-slots (class chain-head chain-tail) vtable
     (sequence-output (stream sequencer)
       :constraint ((class :vtables :start)
@@ -439,8 +417,8 @@ const struct ~A ~A__classobj = {~%"
       ((class :vtable chain-head :end)
        (format stream "};~2%")))))
 
-(defmethod add-output-hooks progn
-    ((cptr class-pointer) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
+				   sequencer)
   (with-slots (class chain-head metaclass meta-chain-head) cptr
     (sequence-output (stream sequencer)
       :constraint ((class :vtable chain-head :start)
@@ -452,8 +430,8 @@ const struct ~A ~A__classobj = {~%"
 	       (sod-class-nickname meta-chain-head)
 	       (sod-class-nickname metaclass))))))
 
-(defmethod add-output-hooks progn
-    ((boff base-offset) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((boff base-offset) (reason (eql :c))
+				   sequencer)
   (with-slots (class chain-head) boff
     (sequence-output (stream sequencer)
       :constraint ((class :vtable chain-head :start)
@@ -464,8 +442,8 @@ const struct ~A ~A__classobj = {~%"
 	       (ilayout-struct-tag class)
 	       (sod-class-nickname chain-head))))))
 
-(defmethod add-output-hooks progn
-    ((choff chain-offset) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
+				   sequencer)
   (with-slots (class chain-head target-head) choff
     (sequence-output (stream sequencer)
       :constraint ((class :vtable chain-head :start)
@@ -477,8 +455,8 @@ const struct ~A ~A__classobj = {~%"
 	       (sod-class-nickname chain-head)
 	       (sod-class-nickname target-head))))))
 
-(defmethod add-output-hooks progn
-    ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
+				   sequencer)
   (with-slots (class subclass chain-head) vtmsgs
     (sequence-output (stream sequencer)
       :constraint ((subclass :vtable chain-head :start)
@@ -492,8 +470,8 @@ const struct ~A ~A__classobj = {~%"
       ((subclass :vtable chain-head :vtmsgs class :end)
        (format stream "  },~%")))))
 
-(defmethod add-output-hooks progn
-    ((entry method-entry) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((entry method-entry) (reason (eql :c))
+				   sequencer)
   (with-slots (method chain-head chain-tail) entry
     (let* ((message (effective-method-message method))
 	   (class (effective-method-class method))
@@ -506,8 +484,8 @@ const struct ~A ~A__classobj = {~%"
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.
 
-(defmethod add-output-hooks progn
-    ((ichain ichain) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
+				   sequencer)
   (with-slots (class chain-head) ichain
     (sequence-output (stream sequencer)
       :constraint ((*instance-class* :object :start)
@@ -520,8 +498,8 @@ const struct ~A ~A__classobj = {~%"
       ((*instance-class* :object chain-head :ichain :end)
        (format stream "  } },~%")))))
 
-(defmethod add-output-hooks progn
-    ((islots islots) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((islots islots) (reason (eql 'class))
+				   sequencer)
   (with-slots (class) islots
     (let ((chain-head (sod-class-chain-head class)))
       (sequence-output (stream sequencer)
@@ -535,8 +513,8 @@ const struct ~A ~A__classobj = {~%"
 	((*instance-class* :object class :slots :end)
 	 (format stream "      },~%"))))))
 
-(defmethod add-output-hooks progn
-    ((vtptr vtable-pointer) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
+				   sequencer)
   (with-slots (class chain-head chain-tail) vtptr
     (sequence-output (stream sequencer)
       :constraint ((*instance-class* :object chain-head :ichain :start)
@@ -569,8 +547,7 @@ const struct ~A ~A__classobj = {~%"
 	(:compound (format stream "        ~@<{ ~;~A~; },~:>~%"
 			 (sod-initializer-value-form init)))))))
 
-(defmethod add-output-hooks progn ((slot sod-class-effective-slot)
-				   (reason (eql 'populate-class))
+(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
 				   sequencer)
   (let ((instance *instance-class*)
 	(func (effective-slot-prepare-function slot)))
@@ -579,8 +556,8 @@ const struct ~A ~A__classobj = {~%"
 	((instance :object :prepare)
 	 (funcall func instance stream))))))
 
-(defmethod add-output-hooks progn
-    ((slot effective-slot) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
+				   sequencer)
   (with-slots (class (dslot slot)) slot
     (let ((instance *instance-class*)
 	  (super (sod-slot-class dslot)))
@@ -595,7 +572,7 @@ const struct ~A ~A__classobj = {~%"
 (defun test (name)
   (let ((sequencer (make-instance 'sequencer))
 	(class (find-sod-class name)))
-    (add-output-hooks class :h sequencer)
+    (hook-output class :h sequencer)
     (invoke-sequencer-items sequencer *standard-output*)
     sequencer))
 
diff --git a/pre-reorg/codegen.lisp b/pre-reorg/codegen.lisp
new file mode 100644
index 0000000..c177a6a
--- /dev/null
+++ b/pre-reorg/codegen.lisp
@@ -0,0 +1,89 @@
+;;; -*-lisp-*-
+;;;
+;;; Code generator for effective methods
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Temporary names.
+
+;;;--------------------------------------------------------------------------
+;;; Instructions.
+
+;;;--------------------------------------------------------------------------
+;;; Instruction types.
+;; Top level things.
+
+;;;--------------------------------------------------------------------------
+;;; Code generator objects.
+
+(defgeneric emit-inst (codegen inst)
+  (:documentation
+   "Add INST to the end of CODEGEN's list of instructions.")
+  (:method ))
+
+(defgeneric emit-insts (codegen insts)
+  (:documentation
+   "Add a list of INSTS to the end of CODEGEN's list of instructions.")
+  (:method))
+
+(defgeneric ensure-var (codegen name type &optional init)
+  (:documentation
+   "Add a variable to CODEGEN's list.
+
+   The variable is called NAME (which should be comparable using EQUAL and
+   print to an identifier) and has the given TYPE.  If INIT is present and
+   non-nil it is an expression INST used to provide the variable with an
+   initial value.")
+  (:method))
+
+(defgeneric codegen-push (codegen)
+  (:documentation
+   "Pushes the current code generation state onto a stack.
+
+   The state consists of the accumulated variables and instructions, i.e.,
+   what is representable by a BASIC-CODEGEN.")
+  (:method))
+
+(defgeneric codegen-pop (codegen)
+  (:documentation
+   "Pops a saved state off of the CODEGEN's stack.
+
+   Returns the newly accumulated variables and instructions as lists, as
+   separate values.")
+  (:method))
+
+(defgeneric codegen-add-function (codegen function)
+  (:documentation
+   "Adds a function to CODEGEN's list.
+
+   Actually, we're not picky: FUNCTION can be any kind of object that you're
+   willing to find in the list returned by CODEGEN-FUNCTIONS.")
+  (:method ))
+
+
+;;;--------------------------------------------------------------------------
+;;; Code generation idioms.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/combination.lisp b/pre-reorg/combination.lisp
new file mode 100644
index 0000000..2287fab
--- /dev/null
+++ b/pre-reorg/combination.lisp
@@ -0,0 +1,34 @@
+;;; -*-lisp-*-
+;;;
+;;; Method combinations
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Common behaviour.
+
+;;;--------------------------------------------------------------------------
+;;; Standard method combination.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/cpl.lisp b/pre-reorg/cpl.lisp
new file mode 100644
index 0000000..eb7a3fa
--- /dev/null
+++ b/pre-reorg/cpl.lisp
@@ -0,0 +1,133 @@
+;;; -*-lisp-*-
+;;;
+;;; Computing class precedence lists
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Linearizations.
+
+;;;--------------------------------------------------------------------------
+;;; Class protocol.
+
+(defgeneric compute-cpl (class)
+  (:documentation
+   "Returns the class precedence list for CLASS."))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(progn
+  (defclass test-class ()
+    ((name :initarg :name :accessor sod-class-name)
+     (direct-superclasses :initarg :superclasses
+			  :accessor sod-class-direct-superclasses)
+     (class-precedence-list)))
+
+  (defmethod print-object ((class test-class) stream)
+    (if *print-escape*
+	(print-unreadable-object (class stream :type t :identity nil)
+	  (princ (sod-class-name class) stream))
+	(princ (sod-class-name class) stream)))
+
+  (defvar *test-linearization*)
+
+  (defmethod sod-class-precedence-list ((class test-class))
+    (if (slot-boundp class 'class-precedence-list)
+	(slot-value class 'class-precedence-list)
+	(setf (slot-value class 'class-precedence-list)
+	      (funcall *test-linearization* class)))))
+
+#+test
+(defun test-cpl (linearization heterarchy)
+  (let* ((*test-linearization* linearization)
+	 (classes (make-hash-table :test #'equal)))
+    (dolist (class heterarchy)
+      (let ((name (car class)))
+	(setf (gethash (car class) classes)
+	      (make-instance 'test-class :name name))))
+    (dolist (class heterarchy)
+      (setf (sod-class-direct-superclasses (gethash (car class) classes))
+	    (mapcar (lambda (super) (gethash super classes)) (cdr class))))
+    (mapcar (lambda (class)
+	      (handler-case
+		  (mapcar #'sod-class-name
+			  (sod-class-precedence-list (gethash (car class)
+							      classes)))
+		(inconsistent-merge-error ()
+		  (list (car class) :error))))
+	    heterarchy)))
+
+#+test
+(progn
+  (defparameter *confused-heterarchy*
+    '((object) (grid-layout object)
+      (horizontal-grid grid-layout) (vertical-grid grid-layout)
+      (hv-grid horizontal-grid vertical-grid)
+      (vh-grid vertical-grid horizontal-grid)
+      (confused-grid hv-grid vh-grid)))
+  (defparameter *boat-heterarchy*
+    '((object)
+      (boat object)
+      (day-boat boat)
+      (wheel-boat boat)
+      (engine-less day-boat)
+      (small-multihull day-boat)
+      (pedal-wheel-boat engine-less wheel-boat)
+      (small-catamaran small-multihull)
+      (pedalo pedal-wheel-boat small-catamaran)))
+  (defparameter *menu-heterarchy*
+    '((object)
+      (choice-widget object)
+      (menu choice-widget)
+      (popup-mixin object)
+      (popup-menu menu popup-mixin)
+      (new-popup-menu menu popup-mixin choice-widget)))
+  (defparameter *pane-heterarchy*
+    '((pane) (scrolling-mixin) (editing-mixin)
+      (scrollable-pane pane scrolling-mixin)
+      (editable-pane pane editing-mixin)
+      (editable-scrollable-pane scrollable-pane editable-pane)))
+  (defparameter *baker-nonmonotonic-heterarchy*
+    '((z) (x z) (y) (b y) (a b x) (c a b x y)))
+  (defparameter *baker-nonassociative-heterarchy*
+    '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
+  (defparameter *distinguishing-heterarchy*
+    '((object)
+      (a object) (b object) (c object)
+      (p a b) (q a c)
+      (u p) (v q)
+      (x u v)
+      (y x b c)
+      (z x c b)))
+  (defparameter *python-heterarchy*
+    '((object)
+      (a object) (b object) (c object) (d object) (e object)
+      (k1 a b c)
+      (k2 d b e)
+      (k3 d a)
+      (z k1 k2 k3))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/cutting-room-floor.lisp b/pre-reorg/cutting-room-floor.lisp
new file mode 100644
index 0000000..294e5b6
--- /dev/null
+++ b/pre-reorg/cutting-room-floor.lisp
@@ -0,0 +1,491 @@
+;;;--------------------------------------------------------------------------
+;;; C types stuff.
+
+(cl:defpackage #:c-types
+  (:use #:common-lisp
+	#+sbcl #:sb-mop
+	#+(or cmu clisp) #:mop
+	#+ecl #:clos)
+  (:export #:c-type
+	   #:c-declarator-priority #:maybe-parenthesize
+	   #:pprint-c-type
+	   #:c-type-subtype #:compount-type-declaration
+	   #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
+	   #:simple-c-type #:c-type-name
+	   #:c-pointer-type
+	   #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
+	   #:tagged-c-type-kind
+	   #:c-array-type #:c-array-dimensions
+	   #:make-argument #:argument-name #:argument-type
+	   #:c-function-type #:c-function-arguments
+
+	   #:define-c-type-syntax #:c-type-alias #:defctype
+	   #:print-c-type
+	   #:qualifier #:declare-qualifier
+	   #:define-simple-c-type
+
+	   #:const #:volatile #:static #:restrict
+	   #:char #:unsigned-char #:uchar #:signed-char #:schar
+	   #:int #:signed #:signed-int #:sint
+	   #:unsigned #:unsigned-int #:uint
+	   #:short #:signed-short #:short-int #:signed-short-int #:sshort
+	   #:unsigned-short #:unsigned-short-int #:ushort
+	   #:long #:signed-long #:long-int #:signed-long-int #:slong
+	   #:unsigned-long #:unsigned-long-int #:ulong
+	   #:float #:double #:long-double
+	   #:pointer #:ptr
+	   #:[] #:vec
+	   #:fun #:func #:fn))
+
+
+;;;--------------------------------------------------------------------------
+;;; Convenient syntax for C types.
+
+;; Basic machinery.
+
+;; Qualifiers.  They have hairy syntax and need to be implemented by hand.
+
+;; Simple types.
+
+;; Pointers.
+
+;; Tagged types.
+
+;; Arrays.
+
+;; Functions.
+
+
+(progn
+  (defconstant q-byte (byte 3 0))
+  (defconstant q-const 1)
+  (defconstant q-volatile 2)
+  (defconstant q-restrict 4)
+
+  (defconstant z-byte (byte 3 3))
+  (defconstant z-unspec 0)
+  (defconstant z-short 1)
+  (defconstant z-long 2)
+  (defconstant z-long-long 3)
+  (defconstant z-double 4)
+  (defconstant z-long-double 5)
+
+  (defconstant s-byte (byte 2 6))
+  (defconstant s-unspec 0)
+  (defconstant s-signed 1)
+  (defconstant s-unsigned 2)
+
+  (defconstant t-byte (byte 3 8))
+  (defconstant t-unspec 0)
+  (defconstant t-int 1)
+  (defconstant t-char 2)
+  (defconstant t-float 3)
+  (defconstant t-user 4))
+
+(defun make-type-flags (size sign type &rest quals)
+  (let ((flags 0))
+    (dolist (qual quals)
+      (setf flags (logior flags qual)))
+    (setf (ldb z-byte flags) size
+	  (ldb s-byte flags) sign
+	  (ldb t-byte flags) type)
+    flags))
+
+
+(defun expand-c-type (spec)
+  "Parse SPEC as a C type and return the result.
+
+   The SPEC can be one of the following.
+
+     * A C-TYPE object, which is returned immediately.
+
+     * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
+       function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
+       or some other means is invoked on the ARGUMENTS, and the result is
+       returned.
+
+     * A symbol, which is treated the same way as a singleton list would be."
+
+  (flet ((interp (sym)
+	   (or (get sym 'c-type)
+	       (error "Unknown C type operator ~S." sym))))
+    (etypecase spec
+      (c-type spec)
+      (symbol (funcall (interp spec)))
+      (list (apply (interp (car spec)) (cdr spec))))))
+
+(defmacro c-type (spec)
+  "Evaluates to the type that EXPAND-C-TYPE would return.
+
+   Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
+   later it will do something more clever."
+  `(expand-c-type ',spec))
+
+;; S-expression machinery.  Qualifiers have hairy syntax and need to be
+;; implemented by hand.
+
+(defun qualifier (qual &rest args)
+  "Parse a qualified C type.
+
+   The ARGS consist of a number of qualifiers and exactly one C-type
+   S-expression.  The result is a qualified version of this type, with the
+   given qualifiers attached."
+  (if (null args)
+      qual
+      (let* ((things (mapcar #'expand-c-type args))
+	     (quals (delete-duplicates
+		     (sort (cons qual (remove-if-not #'keywordp things))
+			   #'string<)))
+	     (types (remove-if-not (lambda (thing) (typep thing 'c-type))
+				   things)))
+	(when (or (null types)
+		  (not (null (cdr types))))
+	  (error "Only one proper type expected in ~S." args))
+	(qualify-type (car types) quals))))
+(setf (get 'qualifier 'c-type) #'qualifier)
+
+(defun declare-qualifier (qual)
+  "Defines QUAL as being a type qualifier.
+
+   When used as a C-type operator, it applies that qualifier to the type that
+   is its argument."
+  (let ((kw (intern (string qual) :keyword)))
+    (setf (get qual 'c-type)
+	  (lambda (&rest args)
+	    (apply #'qualifier kw args)))))
+
+;; Define some initial qualifiers.
+(dolist (qual '(const volatile restrict))
+  (declare-qualifier qual))
+
+
+(define-c-type-syntax simple-c-type (name)
+  "Constructs a simple C type called NAME (a string or symbol)."
+  (make-simple-type (c-name-case name)))
+
+(defmethod print-c-type :around
+    (stream (type qualifiable-c-type) &optional colon atsign)
+  (if (c-type-qualifiers type)
+      (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+	(format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
+		(c-type-qualifiers type))
+	(call-next-method stream type colon atsign))
+      (call-next-method)))
+;; S-expression syntax.
+
+
+(define-c-type-syntax enum (tag)
+  "Construct an enumeration type named TAG."
+  (make-instance 'c-enum-type :tag (c-name-case tag)))
+(define-c-type-syntax struct (tag)
+  "Construct a structure type named TAG."
+  (make-instance 'c-struct-type :tag (c-name-case tag)))
+(define-c-type-syntax union (tag)
+  "Construct a union type named TAG."
+  (make-instance 'c-union-type :tag (c-name-case tag)))
+
+(defgeneric make-me-argument (message class)
+  (:documentation
+   "Return an ARGUMENT object for the `me' argument to MESSAGE, as
+   specialized to CLASS."))
+
+(defmethod make-me-argument
+    ((message basic-message) (class sod-class))
+  (make-argument "me" (make-instance 'c-pointer-type
+				     :subtype (sod-class-type class))))
+
+;;;--------------------------------------------------------------------------
+;;; Keyword arguments and lambda lists.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun transform-otherkeys-lambda-list (bvl)
+    "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
+
+   &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
+   (which must also be present); &ALLOW-OTHER-KEYS must not be present.
+
+   The behaviour is that
+
+     * the presence of non-listed keyword arguments is permitted, as if
+       &ALLOW-OTHER-KEYS had been provided, and
+
+     * a list of the keyword arguments other than the ones explicitly listed
+       is stored in the VAR.
+
+   The return value is a replacement BVL which binds the &OTHER-KEYS variable
+   as an &AUX parameter if necessary.
+
+   At least for now, fancy things like destructuring lambda-lists aren't
+   supported.  I suspect you'll get away with a specializing lambda-list."
+
+    (prog ((new-bvl nil)
+	   (rest-var nil)
+	   (keywords nil)
+	   (other-keys-var nil)
+	   (tail bvl))
+
+     find-rest
+       ;; Scan forwards until we find &REST or &KEY.  If we find the former,
+       ;; then remember the variable name.  If we find the latter first then
+       ;; there can't be a &REST argument, so we should invent one.  If we
+       ;; find neither then there's nothing to do.
+       (when (endp tail)
+	 (go ignore))
+       (let ((item (pop tail)))
+	 (push item new-bvl)
+	 (case item
+	   (&rest (when (endp tail)
+		    (error "Missing &REST argument name"))
+		  (setf rest-var (pop tail))
+		  (push rest-var new-bvl))
+	   (&aux (go ignore))
+	   (&key (unless rest-var
+		   (setf rest-var (gensym "REST"))
+		   (setf new-bvl (nconc (list '&key rest-var '&rest)
+					(cdr new-bvl))))
+		 (go scan-keywords)))
+	 (go find-rest))
+
+     scan-keywords
+       ;; Read keyword argument specs one-by-one.  For each one, stash it on
+       ;; the NEW-BVL list, and also parse it to extract the keyword, which
+       ;; we stash in KEYWORDS.  If we don't find &OTHER-KEYS then there's
+       ;; nothing for us to do.
+       (when (endp tail)
+	 (go ignore))
+       (let ((item (pop tail)))
+	 (push item new-bvl)
+	 (case item
+	   ((&aux &allow-other-keys) (go ignore))
+	   (&other-keys (go fix-tail)))
+	 (let ((keyword (if (symbolp item)
+			    (intern (symbol-name item) :keyword)
+			    (let ((var (car item)))
+			      (if (symbolp var)
+				  (intern (symbol-name var) :keyword)
+				  (car var))))))
+	   (push keyword keywords))
+	 (go scan-keywords))
+
+     fix-tail
+       ;; We found &OTHER-KEYS.  Pick out the &OTHER-KEYS var.
+       (pop new-bvl)
+       (when (endp tail)
+	 (error "Missing &OTHER-KEYS argument name"))
+       (setf other-keys-var (pop tail))
+       (push '&allow-other-keys new-bvl)
+
+       ;; There should be an &AUX next.  If there isn't, assume there isn't
+       ;; one and provide our own.  (This is safe as long as nobody else is
+       ;; expecting to plumb in lambda keywords too.)
+       (when (and (not (endp tail)) (eq (car tail) '&aux))
+	 (pop tail))
+       (push '&aux new-bvl)
+
+       ;; Add our shiny new &AUX argument.
+       (let ((keys-var (gensym "KEYS"))
+	     (list-var (gensym "LIST")))
+	 (push `(,other-keys-var (do ((,list-var nil)
+				      (,keys-var ,rest-var (cddr ,keys-var)))
+				     ((endp ,keys-var) (nreverse ,list-var))
+				   (unless (member (car ,keys-var)
+						   ',keywords)
+				     (setf ,list-var
+					   (cons (cadr ,keys-var)
+						 (cons (car ,keys-var)
+						       ,list-var))))))
+	       new-bvl))
+
+       ;; Done.
+       (return (nreconc new-bvl tail))
+
+     ignore
+       ;; Nothing to do.  Return the unmolested lambda-list.
+       (return bvl))))
+
+(defmacro lambda-otherkeys (bvl &body body)
+  "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
+  `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
+
+(defmacro defun-otherkeys (name bvl &body body)
+  "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
+  `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
+
+(defmacro defmethod-otherkeys (name &rest stuff)
+  "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
+  (do ((quals nil)
+       (stuff stuff (cdr stuff)))
+      ((listp (car stuff))
+       `(defmethod ,name ,@(nreverse quals)
+	    ,(transform-otherkeys-lambda-list (car stuff))
+	  ,@(cdr stuff)))
+    (push (car stuff) quals)))
+
+
+(defparse many ((acc init update
+		 &key (new 'it) (final acc) (min nil minp) max (commitp t))
+		parser &optional (sep nil sepp))
+  "Parse a sequence of homogeneous items.
+
+   The behaviour is similar to `do'.  Initially an accumulator ACC is
+   established, and bound to the value of INIT.  The PARSER is then evaluated
+   repeatedly.  Each time it succeeds, UPDATE is evaluated with NEW (defaults
+   to `it') bound to the result of the parse, and the value returned by
+   UPDATE is stored back into ACC.  If the PARSER fails, then the parse ends.
+
+   If a SEP parser is provided, then the behaviour changes as follows.
+   Before each attempt to parse a new item using PARSER, the parser SEP is
+   invoked.  If SEP fails then the parse ends; if SEP succeeds, then the
+   PARSER must also succeed or the overall parse will fail.
+
+   If MAX (which will be evaluated) is not nil, then it must be a number: the
+   parse ends automatically after PARSER has succeeded MAX times.  When the
+   parse has ended, if the PARSER succeeded fewer than MIN (which will be
+   evaluated) times then the parse fails.  Otherwise, the FINAL form (which
+   defaults to simply returning ACC) is evaluated and its value becomes the
+   result of the parse.  MAX defaults to nil -- i.e., no maximum; MIN
+   defaults to 1 if a SEP parser is given, or 0 if not.
+
+   Note that `many' cannot fail if MIN is zero."
+
+  (unless minp (setf min (if sepp 1 0)))
+  (with-gensyms (block value win consumedp cp i up done)
+    (once-only (init min max commitp)
+      (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0)))))
+	`(block ,block
+
+	   ;; Keep track of variables.  We only need an accumulator if it's
+	   ;; not nil, and we don't need a counter if (a) there's no maximum,
+	   ;; and either (b) the minimum is zero, or (c) the minimum is one
+	   ;; and there's a separator.  In case (c), we can keep track of how
+	   ;; much has been seen using control flow.
+	   (let ((,consumedp nil)
+		 ,@(and acc `((,acc ,init)))
+		 ,@(and counterp `((,i 0))))
+
+	     ;; Some handy functions.  `up' will update the accumulator.
+	     ;; `done' will return the necessary final value.
+	     (flet (,@(and acc `((,up (,new)
+				   (declare (ignorable ,new))
+				   (setf ,acc ,update))))
+		    (,done () (return-from ,block
+				(values ,final t ,consumedp))))
+
+	       ;; If there's a separator, prime the pump by parsing a first
+	       ;; item.  This makes the loop easy: it just parses a separator
+	       ;; and an item each time.  And it means we don't need a
+	       ;; counter in the case of a minimum of 1.
+	       ,@(and sepp
+		      `((multiple-value-bind (,value ,win ,cp)
+			    (parse ,parser)
+			  (when ,cp (setf ,consumedp t))
+			  (unless ,win
+			    ,(cond ((eql min 0)
+				    `(,done))
+				   ((and (numberp min) (plusp min))
+				    `(return-from ,block
+				       (values ,value nil ,consumedp)))
+				   (t
+				    `(if (< 0 ,min)
+					 (return-from ,block
+					   (values ,value nil, consumedp))
+					 (,done)))))
+			  ,@(and acc `((,up ,value))))
+			,@(and counterp `((incf ,i)))))
+
+	       ;; The main loop...
+	       (loop
+
+		 ;; If we've hit the maximum then stop.  But, attention, if
+		 ;; we have a separator and we're not committing to parsing
+		 ;; items, then check after scanning the separator, not
+		 ;; before.
+		 ,@(and max commitp
+			`((when (and ,@(and (not (constantp max))
+					    `(,max))
+				     ,@(and (not (constantp commitp))
+					    `(,commitp))
+				     (>= ,i ,max))
+			    (,done))))
+
+		 ,@(if sepp
+		       ;; We're expecting a separator.  If this fails and
+		       ;; we're below minimum then we've failed altogether.
+		       ;; If it succeeds then we should go on to parse an
+		       ;; item.
+		       `((multiple-value-bind (,value ,win ,cp) (parse ,sep)
+			   ,@(and (numberp min) (<= min 1)
+				  `((declare (ignore ,value))))
+			   (when ,cp (setf ,consumedp t))
+			   (unless ,win
+			     ,(if (and (numberp min) (<= min 1))
+				  `(,done)
+				  `(if (>= ,i ,min)
+				       (return ,final)
+				       (return-from ,block
+					 (values ,value nil ,consumedp))))))
+
+			 ;; If we're not committing then now is the time to
+			 ;; check for hitting the maximum number of
+			 ;; repetitions.
+			 ,@(and max (or (not commitp)
+					(not (constantp commitp)))
+				`((when (and ,@(and (not (constantp max))
+						    `(,max))
+					     ,@(and commitp
+						    `((not ,commitp)))
+					     (>= ,i ,max))
+				    (,done))))
+
+			 ;; Now parse an item.  If this fails and we're
+			 ;; committed then we've blown the whole parse.  If
+			 ;; it fails and we've not committed then we need to
+			 ;; check the minimum.  It's getting very tempting to
+			 ;; write a compiler for optimizing these
+			 ;; conditionals.  (If we don't do this, we get
+			 ;; annoying warnings.)
+			 (multiple-value-bind (,value ,win ,cp)
+			     (parse ,parser)
+			   (when ,cp (setf ,consumedp t))
+			   (unless ,win
+			     ,(cond ((and (constantp commitp) commitp)
+				     `(return-from ,block
+					(values ,value nil ,consumedp)))
+				    ((not commitp)
+				     (if (and (numberp min) (<= min 1))
+					 `(,done)
+					 `(if (>= ,i ,min)
+					      (,done)
+					      (return-from ,block
+						(values ,value nil
+							,consumedp)))))
+				    ((and (numberp min) (<= min 1))
+				     `(if ,commitp
+					  (return-from ,block
+					    (values ,value nil ,consumedp))
+					  (,done)))
+				    (t
+				     `(if (or ,commitp (< ,i ,min))
+					  (return-from ,block
+					    (values ,value nil ,consumedp))
+					  (,done)))))
+			   ,@(and acc `((,up ,value)))))
+
+		       ;; No separator.  Just parse the value.  If it fails,
+		       ;; check that we've met the minimum.
+		       `((multiple-value-bind (,value ,win ,cp)
+			     (parse ,parser)
+			   ,@(and (eql min 0) (null acc)
+				  `((declare (ignore ,value))))
+			   (when ,cp (setf ,consumedp t))
+			   (unless ,win
+			     ,(if (eql min 0)
+				  `(,done)
+				  `(if (>= ,i ,min)
+				       (,done)
+				       (return-from ,block
+					 (values ,value nil ,consumedp)))))
+			  ,@(and acc `((,up ,value))))))
+
+		 ;; Done.  Update the counter and go round again.
+		 ,@(and counterp `((incf ,i)))))))))))
\ No newline at end of file
diff --git a/errors.lisp b/pre-reorg/errors.lisp
similarity index 98%
rename from errors.lisp
rename to pre-reorg/errors.lisp
index 4b92fee..6ff6747 100644
--- a/errors.lisp
+++ b/pre-reorg/errors.lisp
@@ -29,8 +29,7 @@
 ;;; Enclosing conditions.
 
 (define-condition enclosing-condition (condition)
-  ((enclosed-condition :initarg :condition
-		       :type condition
+  ((enclosed-condition :initarg :condition :type condition
 		       :reader enclosed-condition))
   (:documentation
    "A condition which encloses another condition
@@ -45,9 +44,7 @@
 ;;; Conditions with location information.
 
 (define-condition condition-with-location (condition)
-  ((location :initarg :location
-	     :reader file-location
-	     :type file-location))
+  ((location :initarg :location :reader file-location :type file-location))
   (:documentation
    "A condition which has some location information attached."))
 
diff --git a/examples.lisp b/pre-reorg/examples.lisp
similarity index 100%
rename from examples.lisp
rename to pre-reorg/examples.lisp
diff --git a/pre-reorg/foo.lisp b/pre-reorg/foo.lisp
new file mode 100644
index 0000000..b5b8509
--- /dev/null
+++ b/pre-reorg/foo.lisp
@@ -0,0 +1,2 @@
+;;;
+(write-line "stuff's a-goin' on")
diff --git a/lex.lisp b/pre-reorg/lex.lisp
similarity index 88%
rename from lex.lisp
rename to pre-reorg/lex.lisp
index 0c0fa65..d7fd2c0 100644
--- a/lex.lisp
+++ b/pre-reorg/lex.lisp
@@ -179,28 +179,11 @@
 
 (defgeneric skip-spaces (lexer)
   (:documentation
-   "Skip over whitespace characters in the LEXER.")
-  (:method ((lexer lexer))
-    (do ((ch (lexer-char lexer) (next-char lexer)))
-	((not (whitespace-char-p ch))))))
+   "Skip over whitespace characters in the LEXER."))
 
 ;;;--------------------------------------------------------------------------
 ;;; Lexer utilities.
 
-(defun require-token
-    (lexer wanted-token-type &key (errorp t) (consumep t) default)
-  (with-slots (token-type token-value) lexer
-    (cond ((eql token-type wanted-token-type)
-	   (prog1 token-value
-	     (when consumep (next-token lexer))))
-	  (errorp
-	   (cerror* "Expected ~A but found ~A"
-		    (format-token wanted-token-type)
-		    (format-token token-type token-value))
-	   default)
-	  (t
-	   default))))
-
 ;;;--------------------------------------------------------------------------
 ;;; Our main lexer.
 
@@ -414,57 +397,6 @@
 ;;;--------------------------------------------------------------------------
 ;;; C fragments.
 
-(defclass c-fragment ()
-  ((location :initarg :location :type file-location
-	     :accessor c-fragment-location)
-   (text :initarg :text :type string :accessor c-fragment-text))
-  (:documentation
-   "Represents a fragment of C code to be written to an output file.
-
-   A C fragment is aware of its original location, and will bear proper #line
-   markers when written out."))
-
-(defun output-c-excursion (stream location thunk)
-  "Invoke THUNK surrounding it by writing #line markers to STREAM.
-
-   The first marker describes LOCATION; the second refers to the actual
-   output position in STREAM.  If LOCATION doesn't provide a line number then
-   no markers are output after all.  If the output stream isn't
-   position-aware then no final marker is output."
-
-  (let* ((location (file-location location))
-	 (line (file-location-line location))
-	 (pathname (file-location-pathname location))
-	 (namestring (and pathname (namestring pathname))))
-    (cond (line
-	   (format stream "~&#line ~D~@[ ~S~]~%" line namestring)
-	   (funcall thunk)
-	   (when (typep stream 'position-aware-stream)
-	     (fresh-line stream)
-	     (format stream "~&#line ~D ~S~%"
-		     (1+ (position-aware-stream-line stream))
-		     (namestring (stream-pathname stream)))))
-	  (t
-	   (funcall thunk)))))
-
-(defmethod print-object ((fragment c-fragment) stream)
-  (let ((text (c-fragment-text fragment))
-	(location (c-fragment-location fragment)))
-    (if *print-escape*
-	(print-unreadable-object (fragment stream :type t)
-	  (when location
-	    (format stream "~A " location))
-	  (cond ((< (length text) 40)
-		 (prin1 text stream) stream)
-		(t
-		 (prin1 (subseq text 0 40) stream)
-		 (write-string "..." stream))))
-	(output-c-excursion stream location
-			    (lambda () (write-string text stream))))))
-
-(defmethod make-load-form ((fragment c-fragment) &optional environment)
-  (make-load-form-saving-slots fragment :environment environment))
-
 (defun scan-c-fragment (lexer end-chars)
   "Snarfs a sequence of C tokens with balanced brackets.
 
diff --git a/pre-reorg/methods.lisp b/pre-reorg/methods.lisp
new file mode 100644
index 0000000..93782be
--- /dev/null
+++ b/pre-reorg/methods.lisp
@@ -0,0 +1,43 @@
+;;; -*-lisp-*-
+;;;
+;;; Infrastructure for effective method generation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Direct method classes.
+
+;;;--------------------------------------------------------------------------
+;;; Effective method classes.
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
+
+;;;--------------------------------------------------------------------------
+;;; Effective method entry points.
+
+;;;--------------------------------------------------------------------------
+;;; Output.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/module-output.lisp b/pre-reorg/module-output.lisp
similarity index 100%
rename from module-output.lisp
rename to pre-reorg/module-output.lisp
diff --git a/module.lisp b/pre-reorg/module.lisp
similarity index 60%
rename from module.lisp
rename to pre-reorg/module.lisp
index 6f8aeec..604703f 100644
--- a/module.lisp
+++ b/pre-reorg/module.lisp
@@ -26,135 +26,8 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
-;;; Module basics.
-
-(defclass module ()
-  ((name :initarg :name :type pathname :reader module-name)
-   (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
-   (items :initarg :items :initform nil :type list :accessor module-items)
-   (dependencies :initarg :dependencies :initform nil
-		 :type list :accessor module-dependencies)
-   (state :initarg :state :initform nil :accessor module-state))
-  (:documentation
-   "A module is a container for the definitions made in a source file.
-
-   Modules are the fundamental units of translation.  The main job of a
-   module is to remember which definitions it contains, so that they can be
-   translated and written to output files.  The module contains the following
-   handy bits of information:
-
-     * A (path) name, which is the filename we used to find it.  The default
-       output filenames are derived from this.  (We use the file's truename
-       as the hash key to prevent multiple inclusion, and that's a different
-       thing.)
-
-     * A property list containing other useful things.
-
-     * A list of the classes defined in the source file.
-
-     * Lists of C fragments to be included in the output header and C source
-       files.
-
-     * A list of other modules that this one depends on.
-
-   Modules are usually constructed by the PARSE-MODULE function, which is in
-   turn usually invoked by IMPORT-MODULE, though there's nothing to stop
-   fancy extensions building modules programmatically."))
-
-(defparameter *module* nil
-  "The current module under construction.
-
-   This is always an instance of MODULE.  Once we've finished constructing
-   it, we'll call CHANGE-CLASS to turn it into an instance of whatever type
-   is requested in the module's :LISP-CLASS property.")
-
-(defgeneric module-import (object)
-  (:documentation
-   "Import definitions into the current environment.
-
-   Instructs the OBJECT to import its definitions into the current
-   environment.  Modules pass the request on to their constituents.  There's
-   a default method which does nothing at all.
-
-   It's not usual to modify the current module.  Inserting things into the
-   *TYPE-MAP* is a good plan.")
-  (:method (object) nil))
-
-(defgeneric add-to-module (module item)
-  (:documentation
-   "Add ITEM to the MODULE's list of accumulated items.
-
-   The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS
-   protocols."))
-
-(defgeneric finalize-module (module)
-  (:documentation
-   "Finalizes a module, setting everything which needs setting.
-
-   This isn't necessary if you made the module by hand.  If you've
-   constructed it incrementally, then it might be a good plan.  In
-   particular, it will change the class (using CHANGE-CLASS) of the module
-   according to the class choice set in the module's :LISP-CLASS property.
-   This has the side effects of calling SHARED-INITIALIZE, setting the
-   module's state to T, and checking for unrecognized properties.  (Therefore
-   subclasses should add a method to SHARED-INITIALIZE should take care of
-   looking at interesting properties, just to make sure they're ticked
-   off.)"))
-
-(defmethod module-import ((module module))
-  (dolist (item (module-items module))
-    (module-import item)))
-
-(defmethod add-to-module ((module module) item)
-  (setf (module-items module)
-	(nconc (module-items module) (list item)))
-  (module-import item))
-
-(defmethod shared-initialize :after ((module module) slot-names &key pset)
-  "Tick off known properties on the property set."
-  (declare (ignore slot-names))
-  (when pset
-    (dolist (prop '(:guard))
-      (get-property pset prop nil))))
-
-(defmethod finalize-module ((module module))
-  (let* ((pset (module-pset module))
-	 (class (get-property pset :lisp-class :symbol 'module)))
-
-    ;; Always call CHANGE-CLASS, even if it's the same one; this will
-    ;; exercise the property-set fiddling in SHARED-INITIALIZE and we can
-    ;; catch unknown-property errors.
-    (change-class module class :state t :pset pset)
-    (check-unused-properties pset)
-    module))
-
-;;;--------------------------------------------------------------------------
 ;;; Module importing.
 
-(defun build-module
-    (name body-func &key (truename (probe-file name)) location)
-  (let ((*module* (make-instance 'module
-				 :name (pathname name)
-				 :state (file-location location)))
-	(*type-map* (make-hash-table :test #'equal)))
-    (module-import *builtin-module*)
-    (when truename
-      (setf (gethash truename *module-map*) *module*))
-    (unwind-protect
-	 (progn
-	   (funcall body-func)
-	   (finalize-module *module*))
-      (when (and truename (not (eq (module-state *module*) t)))
-	(remhash truename *module-map*)))))
-
-(defmacro define-module
-    ((name &key (truename nil truenamep) (location nil locationp))
-     &body body)
-  `(build-module ,name
-		 (lambda () ,@body)
-		 ,@(and truenamep `(:truename ,truename))
-		 ,@(and locationp `(:location ,location))))
-
 (defun read-module (pathname &key (truename (truename pathname)) location)
   "Reads a module.
 
@@ -220,30 +93,6 @@
 	:report "Ignore the error and continue parsing."
 	nil))))
 
-;;;--------------------------------------------------------------------------
-;;; Type definitions.
-
-(defclass type-item ()
-  ((name :initarg :name :type string :reader type-name))
-  (:documentation
-   "A note that a module exports a type.
-
-   We can only export simple types, so we only need to remember the name.
-   The magic simple-type cache will ensure that we get the same type object
-   when we do the import."))
-
-(defmethod module-import ((item type-item))
-  (let* ((name (type-name item))
-	 (def (gethash name *type-map*))
-	 (type (make-simple-type name)))
-    (cond ((not def)
-	   (setf (gethash name *type-map*) type))
-	  ((not (eq def type))
-	   (error "Conflicting types `~A'" name)))))
-
-(defmethod module-import ((class sod-class))
-  (record-sod-class class))
-
 (defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
   "module-decl ::= `typename' id-list `;'"
   (loop (let ((name (require-token lexer :id)))
@@ -257,33 +106,6 @@
 ;;;--------------------------------------------------------------------------
 ;;; Fragments.
 
-(defclass code-fragment-item ()
-  ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
-   (reason :initarg :reason :type keyword :reader code-fragment-reason)
-   (name :initarg :name :type t :reader code-fragment-name)
-   (constraints :initarg :constraints :type list
-		:reader code-fragment-constraints))
-  (:documentation
-   "A plain fragment of C to be dropped in at top-level."))
-
-(defmacro define-fragment ((reason name) &body things)
-  (categorize (thing things)
-      ((constraints (listp thing))
-       (frags (typep thing '(or string c-fragment))))
-    (when (null frags)
-      (error "Missing code fragment"))
-    (when (cdr frags)
-      (error "Multiple code fragments"))
-    `(add-to-module
-      *module*
-      (make-instance 'code-fragment-item
-		     :fragment ',(car frags)
-		     :name ,name
-		     :reason ,reason
-		     :constraints (list ,@(mapcar (lambda (constraint)
-						    (cons 'list constraint))
-						  constraints))))))
-
 (defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
   "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
    constraint ::= id*"
@@ -557,102 +379,4 @@
     (finalize-sod-class class)
     (add-to-module *module* class)))
 
-;;;--------------------------------------------------------------------------
-;;; Modules.
-
-#+(or)
-(defun parse-module (lexer)
-  "Parse a module from the given LEXER.
-
-   The newly constructed module is returned.  This is the top-level parsing
-   function."
-
-  (let ((hfrags nil)
-	(cfrags nil)
-	(classes nil)
-	(plist nil)
-	(deps nil))
-
-    (labels ((fragment (func)
-	       (next-token lexer)
-	       (when (require-token lexer #\{ :consumep nil)
-		 (let ((frag (scan-c-fragment lexer '(#\}))))
-		   (next-token lexer)
-		   (require-token lexer #\})
-		   (funcall func frag)))))
-
-      (tagbody
-
-       top
-	 ;; module : empty | module-def module
-	 ;;
-	 ;; Just read module-defs until we reach the end of the file.
-	 (case (token-type lexer)
-
-	   (:eof
-	    (go done))
-	   (#\;
-	    (next-token lexer)
-	    (go top))
-
-	   ;; module-def : `lisp' sexp
-	   ;;
-	   ;; Process an in-line Lisp form immediately.
-	   (:lisp
-	    
-	    (next-token lexer)
-	    (go top))
-
-	   ;; module-def : `typename' ids `;'
-	   ;; ids : id | ids `,' id
-	   ;;
-	   ;; Add ids as registered type names.  We don't need to know what
-	   ;; they mean at this level.
-	   (:typename
-	    (next-token lexer)
-	    (loop
-	      (let ((id (require-token lexer :id)))
-		(cond ((null id)
-		       (return))
-		      ((gethash id *type-map*)
-		       (cerror* "Type ~A is already defined" id))
-		      (t
-		       (setf (gethash id *type-map*)
-			     (make-instance 'simple-c-type :name id))))
-		(unless (eql (token-type lexer) #\,)
-		  (return))
-		(next-token lexer)))
-	    (go semicolon))
-
-	   ;; module-def : `source' `{' c-stuff `}'
-	   ;; module-def : `header' `{' c-stuff `}'
-	   (:source
-	    (fragment (lambda (frag) (push frag cfrags)))
-	    (go top))
-	   (:header
-	    (fragment (lambda (frag) (push frag hfrags)))
-	    (go top))
-
-	   ;; Anything else is an error.
-	   (t
-	    (cerror* "Unexpected token ~A ignored" (format-token lexer))
-	    (next-token lexer)
-	    (go top)))
-
-       semicolon
-	 ;; Scan a terminating semicolon.
-	 (require-token lexer #\;)
-	 (go top)
-
-       done)
-
-      ;; Assemble the module and we're done.
-      (make-instance 'module
-		     :name (stream-pathname (lexer-stream lexer))
-		     :plist plist
-		     :classes classes
-		     :header-fragments hfrags
-		     :source-fragments cfrags
-		     :dependencies deps))))
-
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/pre-reorg/output.lisp b/pre-reorg/output.lisp
new file mode 100644
index 0000000..dd8bc04
--- /dev/null
+++ b/pre-reorg/output.lisp
@@ -0,0 +1,63 @@
+;;; -*-lisp-*-
+;;;
+;;; Output driver for SOD translator
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(defclass sequencer-item ()
+  ((name :initarg :name :reader sequencer-item-name)
+   (functions :initarg :functions :initform nil
+	      :type list :accessor sequencer-item-functions))
+  (:documentation
+   "Represents a distinct item to be sequenced by a SEQUENCER.
+
+   A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
+   sequencer is invoked.  This class is not intended to be subclassed."))
+
+;;;--------------------------------------------------------------------------
+;;; Output preparation.
+
+(defvar *seen-announcement*)		;Keep me unbound!
+#+hmm
+(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
+  "Arrange not to invoke any object more than once during a particular
+   announcement."
+  (declare (ignore stuff))
+  (cond ((not (boundp '*seen-announcement*))
+	 (let ((*seen-announcement* (make-hash-table)))
+	   (setf (gethash object *seen-announcement*) t)
+	   (call-next-method)))
+	((gethash object *seen-announcement*)
+	 nil)
+	(t
+	 (setf (gethash object *seen-announcement*) t)
+	 (call-next-method))))
+
+;;;--------------------------------------------------------------------------
+;;; Utility macro.
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/parse-c-types.lisp b/pre-reorg/parse-c-types.lisp
similarity index 100%
rename from parse-c-types.lisp
rename to pre-reorg/parse-c-types.lisp
diff --git a/posn-stream.lisp b/pre-reorg/posn-stream.lisp
similarity index 100%
rename from posn-stream.lisp
rename to pre-reorg/posn-stream.lisp
diff --git a/pset.lisp b/pre-reorg/pset.lisp
similarity index 52%
rename from pset.lisp
rename to pre-reorg/pset.lisp
index a9bbde9..20f0ff9 100644
--- a/pset.lisp
+++ b/pre-reorg/pset.lisp
@@ -26,254 +26,6 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
-;;; Property representation.
-
-(defun property-key (name)
-  "Convert NAME into a keyword.
-
-   If NAME isn't a symbol already, then flip its case (using FROB-CASE),
-   replace underscores by hyphens, and intern into the KEYWORD package."
-  (etypecase name
-    (symbol name)
-    (string (intern (substitute #\- #\_ (frob-case name)) :keyword))))
-
-(defun property-type (value)
-  "Guess a sensible property type to use for VALUE."
-  (typecase value
-    (symbol :symbol)
-    (integer :integer)
-    (string :string)
-    (character :char)
-    (c-fragment :frag)
-    (t :other)))
-
-(defstruct (property
-	     (:conc-name p-)
-	     (:constructor make-property
-	       (name value
-		&key (type (property-type value))
-		     ((:location %loc))
-		     seenp
-		&aux (key (property-key name))
-		     (location (file-location %loc)))))
-  "A simple structure for holding a property in a property set.
-
-   The main useful feature is the ability to tick off properties which have
-   been used, so that we can complain about unrecognized properties.
-
-   An explicit type tag is necessary because we need to be able to talk
-   distinctly about identifiers, strings and symbols, and we've only got two
-   obvious Lisp types to play with.  Sad, but true."
-
-  (name nil :type (or string symbol))
-  (value nil :type t)
-  (type nil :type symbol)
-  (location (file-location nil) :type file-location)
-  (key nil :type symbol)
-  (seenp nil :type boolean))
-
-(defun string-to-symbol (string &optional (package *package*))
-  "Convert STRING to a symbol in PACKAGE.
-
-   If PACKAGE is nil, then parse off a `PACKAGE:' prefix from STRING to
-   identify the package.  A doubled colon allows access to internal symbols,
-   and will intern if necessary.  Note that escape characters are /not/
-   processed; don't put colons in package names if you want to use them from
-   SOD property sets."
-
-  (let* ((length (length string))
-	 (colon (position #\: string)))
-    (multiple-value-bind (start internalp)
-	(cond ((not colon) (values 0 t))
-	      ((and (< (1+ colon) length)
-		    (char= (char string (1+ colon)) #\:))
-	       (values (+ colon 2) t))
-	      (t
-	       (values (1+ colon) nil)))
-      (when colon
-	(let* ((package-name (subseq string 0 colon))
-	       (found (find-package package-name)))
-	  (unless found
-	    (error "Unknown package `~A'" package-name))
-	  (setf package found)))
-      (let ((name (subseq string start)))
-	(multiple-value-bind (symbol status)
-	    (funcall (if internalp #'intern #'find-symbol) name package)
-	  (cond ((or internalp (eq status :external))
-		 symbol)
-		((not status)
-		 (error "Symbol `~A' not found in package `~A'"
-			name (package-name package)))
-		(t
-		 (error "Symbol `~A' not external in package `~A'"
-			name (package-name package)))))))))
-
-(defgeneric coerce-property-value (value type wanted)
-  (:documentation
-   "Convert VALUE, a property of type TYPE, to be of type WANTED.
-
-   It's sensible to add additional methods to this function, but there are
-   all the ones we need.")
-
-  ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
-  ;; form.  Otherwise, if nothing else matched, then I guess we'll have to
-  ;; say it didn't work.
-  (:method (value type wanted)
-    (if (eql type wanted)
-	value
-	(error "Incorrect type: expected ~A but found ~A" wanted type)))
-
-  ;; If the caller asks for type T then give him the raw thing.
-  (:method (value type (wanted (eql t)))
-    value)
-
-  ;; Keywords.
-  (:method ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
-    value)
-  (:method ((value string) (type (eql :id)) (wanted (eql :keyword)))
-    (string-to-symbol (substitute #\- #\_ (frob-case value)) :keyword))
-  (:method ((value string) (type (eql :string)) (wanted (eql :keyword)))
-    (string-to-symbol (frob-case value) :keyword))
-
-  ;; Symbols.
-  (:method ((value string) (type (eql :id)) (wanted (eql :symbol)))
-    (string-to-symbol (substitute #\- #\_ (frob-case value))))
-  (:method ((value string) (type (eql :string)) (wanted (eql :symbol)))
-    (string-to-symbol (frob-case value)))
-
-  ;; Identifiers.
-  (:method ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
-    (substitute #\_ #\- (frob-case (symbol-name value)))))
-
-;;;--------------------------------------------------------------------------
-;;; Property set representation.
-;;;
-;;; There shouldn't be any code elsewhere which depends on the
-;;; representation.  It's changed before; it may change again.
-
-(defstruct (pset (:constructor %make-pset)
-		 (:conc-name %pset-))
-  "A property set.
-
-   Wrapped up in a structure so that we can define a print function."
-  (hash (make-hash-table) :type hash-table))
-
-(declaim (inline make-pset pset-get pset-store pset-map))
-
-(defun make-pset ()
-  "Constructor for property sets."
-  (%make-pset))
-
-(defun pset-get (pset key)
-  "Look KEY up in PSET and return what we find.
-
-   If there's no property by that name, return NIL."
-  (values (gethash key (%pset-hash pset))))
-
-(defun pset-store (pset prop)
-  "Store property PROP in PSET.
-
-   Overwrite or replace any previous property with the same name.  Mutates
-   the property set."
-  (setf (gethash (p-key prop) (%pset-hash pset)) prop))
-
-(defun pset-map (func pset)
-  "Call FUNC for each property in PSET."
-  (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
-	   (%pset-hash pset)))
-
-;;;--------------------------------------------------------------------------
-;;; `Cooked' property set operations.
-
-(defun store-property
-    (pset name value &key (type (property-type value)) location)
-  "Store a property in PSET."
-  (pset-store pset
-	      (make-property name value :type type :location location)))
-
-(defun get-property (pset name type &optional default)
-  "Fetch a property from a property set.
-
-   If a property NAME is not found in PSET, or if a property is found, but
-   its type doesn't match TYPE, then return DEFAULT and NIL; otherwise return
-   the value and its file location.  In the latter case, mark the property as
-   having been used.
-
-   The value returned depends on the TYPE argument provided.  If you pass NIL
-   then you get back the entire PROPERTY object.  If you pass T, then you get
-   whatever was left in the property set, uninterpreted.  Otherwise the value
-   is coerced to the right kind of thing (where possible) and returned.
-
-   If PSET is nil, then return DEFAULT."
-
-  (let ((prop (and pset (pset-get pset (property-key name)))))
-    (with-default-error-location ((and prop (p-location prop)))
-      (cond ((not prop)
-	     (values default nil))
-	    ((not type)
-	     (setf (p-seenp prop) t)
-	     (values prop (p-location prop)))
-	    (t
-	     (setf (p-seenp prop) t)
-	     (values (coerce-property-value (p-value prop)
-					    (p-type prop)
-					    type)
-		     (p-location prop)))))))
-
-(defun add-property
-    (pset name value &key (type (property-type value)) location)
-  "Add a property to PSET.
-
-   If a property with the same NAME already exists, report an error."
-
-  (with-default-error-location (location)
-    (let ((existing (get-property pset name nil)))
-      (when existing
-	(error "Property ~S already defined~@[ at ~A~]"
-	       name (p-location existing)))
-      (store-property pset name value :type type :location location))))
-
-(defun make-property-set (&rest plist)
-  "Make a new property set, with given properties.
-
-   This isn't the way to make properties when parsing, but it works well for
-   programmatic generation.  The arguments should form a property list
-   (alternating keywords and values is good).
-
-   An attempt is made to guess property types from the Lisp types of the
-   values.  This isn't always successful but it's not too bad.  The
-   alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing
-   into the set."
-
-  (do ((pset (make-pset))
-       (plist plist (cddr plist)))
-      ((endp plist) pset)
-    (add-property pset (car plist) (cadr plist))))
-
-(defmethod print-object ((pset pset) stream)
-  (print-unreadable-object (pset stream :type t)
-    (pprint-logical-block (stream nil)
-      (let ((firstp t))
-	(pset-map (lambda (prop)
-		    (cond (firstp (setf firstp nil))
-			  (t (write-char #\space stream)
-			     (pprint-newline :linear stream)))
-		    (format stream "~:@<~S ~@_~S ~@_~S~:>"
-			    (p-name prop) (p-type prop) (p-value prop)))
-		  pset)))))
-
-(defun check-unused-properties (pset)
-  "Issue errors about unused properties in PSET."
-  (when pset
-    (pset-map (lambda (prop)
-		(unless (p-seenp prop)
-		  (cerror*-with-location (p-location prop)
-					 "Unknown property `~A'"
-					 (p-name prop))
-		  (setf (p-seenp prop) t)))
-	      pset)))
-
-;;;--------------------------------------------------------------------------
 ;;; Expression parser.
 
 (defun parse-expression (lexer)
diff --git a/pre-reorg/sift.lisp b/pre-reorg/sift.lisp
new file mode 100644
index 0000000..7d78774
--- /dev/null
+++ b/pre-reorg/sift.lisp
@@ -0,0 +1,333 @@
+;;; sift through lists of classes and so on.
+
+(in-package #:cl-user)
+
+(defstruct (cset (:conc-name s-))
+  members supers subs gfs)
+
+(defstruct (class-node (:conc-name c-))
+  name class own-p supers subs visited-p sets)
+
+(defmacro pushnew-end (object place &rest keys &environment env)
+  (multiple-value-bind (temps inits newtemps setform getform)
+      (get-setf-expansion place env)
+    (let ((objvar (gensym "OBJECT"))
+	  (listvar (gensym "LIST")))
+      `(let* ((,objvar ,object)
+	      ,@(mapcar #'list temps inits)
+	      (,listvar ,getform))
+	 (cond ((member ,objvar ,listvar ,@keys)
+		,listvar)
+	       (t
+		(multiple-value-bind ,newtemps
+		    (append ,listvar (list ,objvar))
+		  ,setform
+		  (values ,@newtemps))))))))
+
+(defun show-classes (classes)
+  (let ((map (make-hash-table)))
+
+    (labels ((getnode (class &optional own-p)
+	       (let ((found (gethash class map)))
+		 (if found
+		     (values found t)
+		     (values (setf (gethash class map)
+				   (make-class-node :name (class-name class)
+						    :class class
+						    :own-p own-p))
+			     nil))))
+
+	     (gather (class)
+	       (let ((node (getnode class)))
+		 (dolist (super (class-direct-superclasses class))
+		   (unless (member super (append (mapcar #'find-class
+							 '(t standard-object
+							   structure-object))
+						 (class-direct-superclasses
+						  (find-class 'condition))))
+		     (multiple-value-bind (supernode foundp)
+			 (getnode super)
+		       (pushnew-end supernode (c-supers node))
+		       (pushnew node (c-subs supernode))
+		       (unless foundp (gather super)))))))
+
+	     (walk (node &optional (level 0) super)
+	       (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)"
+		       (* 2 level)
+		       (c-own-p node)
+		       (c-name node))
+	       (cond ((null (cdr (c-supers node))))
+		     ((eq (car (c-supers node)) super)
+		      (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>"
+			      (mapcar #'c-name (c-supers node))))
+		     (t
+		      (format *standard-output* "*~%")
+		      (return-from walk)))
+	       (terpri *standard-output*)
+	       (dolist (sub (c-subs node))
+		 (walk sub (1+ level) node))))
+
+      ;; make nodes for all of the official classes.
+      (dolist (class classes)
+	(getnode class t))
+
+      ;; build the hierarchy, up and down.  this may drag in classes from
+      ;; other packages.
+      (dolist (class classes)
+	(gather class))
+
+      ;; write the table.
+      (dolist (node (sort (loop for node being the hash-values of map
+				unless (c-supers node)
+				collect node)
+			  #'string< :key #'c-name))
+	(walk node)))))
+
+(defun check-sets (members)
+  (let ((done (make-hash-table)))
+    (labels ((check (s)
+	       (when (gethash s done)
+		 (return-from check))
+	       (setf (gethash s done) t)
+
+	       ;; subsets must be proper subsets
+	       (dolist (u (s-supers s))
+		 (assert (subsetp (s-members s) (s-members u)))
+		 (assert (not (subsetp (s-members u) (s-members s))))
+		 (assert (member s (s-subs u))))
+
+	       ;; supersets must be proper supersets
+	       (dolist (u (s-subs s))
+		 (assert (subsetp (s-members u) (s-members s)))
+		 (assert (not (subsetp (s-members s) (s-members u))))
+		 (assert (member s (s-supers u))))
+
+	       ;; supersets must be minimal
+	       (dolist (u (s-supers s))
+		 (dolist (v (s-supers s))
+		   (assert (or (eq u v)
+			       (not (subsetp (s-members u)
+					     (s-members v)))))))
+
+	       ;; subsets must be maximal
+	       (dolist (u (s-subs s))
+		 (dolist (v (s-subs s))
+		   (assert (or (eq u v)
+			       (not (subsetp (s-members u)
+					     (s-members v)))))))
+
+	       ;; members must link to us, directly or indirectly.
+	       (dolist (m (s-members s))
+		 (labels ((look (u)
+			    (or (eq u s) (some #'look (s-supers u)))))
+		   (assert (some #'look (c-sets m)))))
+
+	       ;; check supersets and subsets
+	       (dolist (u (s-supers s)) (check u))
+	       (dolist (u (s-subs s)) (check u))))
+
+      (dolist (m members)
+	(dolist (s (c-sets m))
+
+	  ;; sets must contain us
+	  (assert (member m (s-members s)))
+
+	  ;; sets must be minimal
+	  (dolist (u (c-sets m))
+	    (assert (or (eq u s)
+			(not (subsetp (s-members u)
+				      (s-members s))))))
+
+	  ;; check set
+	  (check s))))))
+
+(defmethod print-object ((c class-node) stream)
+  (format stream "#[~(~A~)]" (c-name c)))
+
+(defmethod print-object ((s cset) stream)
+  (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s)))
+
+(defun ensure-set (members)
+
+  (setf members (remove-duplicates members))
+  (check-sets members)
+
+  (let ((subs nil) (supers nil))
+
+    ;; find the maximal subsets and minimal supersets.  if s is not a subset
+    ;; then answer nil; otherwise answer t, and recursively process all the
+    ;; supersets of s; if none of them answer t then is maximal, so add it to
+    ;; the list.
+    (labels ((up (s)
+	       (cond ((subsetp (s-members s) members)
+		      (unless (some #'up (s-supers s)) (pushnew s subs))
+		      t)
+		     ((subsetp members (s-members s))
+		      (pushnew s supers)
+		      nil)
+		     (t nil))))
+      (dolist (m members)
+	(mapc #'up (c-sets m))))
+    (when (and subs (subsetp members (s-members (car subs))))
+      (return-from ensure-set (car subs)))
+    (let* ((new (make-cset :members members :supers supers :subs subs)))
+
+      ;; now we have to interpolate ourselves properly.  this is the tricky
+      ;; part.
+      (dolist (s supers)
+	(setf (s-subs s)
+	      (cons new (set-difference (s-subs s) subs))))
+      (dolist (s subs)
+	(setf (s-supers s)
+	      (cons new (set-difference (s-supers s) supers))))
+      (dolist (m members)
+	(unless (some (lambda (s) (subsetp (s-members s) members))
+		      (c-sets m))
+	  (setf (c-sets m) (cons new
+				 (remove-if (lambda (s)
+					      (subsetp members
+						       (s-members s)))
+					    (c-sets m))))))
+
+      ;; done
+      (check-sets members)
+      new)))
+
+(defun categorize-protocols (generics classes)
+  (let ((cmap (make-hash-table)))
+
+    (labels ((getnode (class &optional own-p)
+	       (let ((found (gethash class cmap)))
+		 (if found
+		     (values found t)
+		     (values (setf (gethash class cmap)
+				   (make-class-node :name (class-name class)
+						    :class class
+						    :own-p own-p))
+			     nil))))
+
+	     (gather (class)
+	       (let ((node (getnode class)))
+		 (dolist (super (class-direct-superclasses class))
+		   (unless (member super (append (mapcar #'find-class
+							 '(t standard-object
+							   structure-object))
+						 (class-direct-superclasses
+						  (find-class 'condition))))
+		     (multiple-value-bind (supernode foundp)
+			 (getnode super)
+		       (pushnew-end supernode (c-supers node))
+		       (pushnew node (c-subs supernode))
+		       (unless foundp (gather super))))))))
+
+      ;; make nodes for all of the official classes.
+      (dolist (class classes)
+	(getnode class t))
+
+      ;; build the hierarchy, up and down.  this may drag in classes from
+      ;; other packages.
+      (dolist (class classes)
+	(gather class))
+
+      ;; go through the generic functions collecting sets of implementing
+      ;; classes.
+      (dolist (gf generics)
+	(let* ((specs (reduce #'append
+			      (mapcar #'method-specializers
+				      (generic-function-methods gf))
+			      :from-end t))
+	       (members (labels ((down (c)
+				   (delete-duplicates
+				    (cons c (mapcan #'down (c-subs c)))))
+				 (gather (spec)
+				   (let ((c (gethash spec cmap)))
+				     (and c (down c)))))
+			  (delete-duplicates (mapcan #'gather specs))))
+	       (s (and members (ensure-set members))))
+	  (when s
+	    (push gf (s-gfs s)))))
+
+      ;; finally dump the list of participating classes.
+      (let ((tops nil))
+
+	;; find the top-level sets
+	(let ((m (make-hash-table)))
+	  (labels ((ascend (s)
+		     (unless (gethash s m)
+		       (setf (gethash s m) t)
+		       (if (s-supers s)
+			   (mapc #'ascend (s-supers s))
+			   (push s tops)))))
+	    (dolist (c classes)
+	      (mapc #'ascend (c-sets (gethash c cmap))))))
+
+	(let ((done (make-hash-table)))
+	  (labels ((walk (s &optional (level 0))
+		     (let ((seen (gethash s done)))
+		       (unless seen
+			 (setf (gethash s done) t)
+			 (dolist (gf (s-gfs s))
+			   (format *standard-output* "~v,0T~(~A~)~%"
+				   (* 2 level)
+				   (generic-function-name gf))))
+		       (dolist (c (set-difference
+				   (s-members s)
+				   (reduce #'union (mapcar #'s-members
+							   (s-subs s))
+					   :initial-value nil)))
+			 (format *standard-output* "~40T~(~A~)~:[~;*~]~%"
+				 (c-name c) seen))
+		       (dolist (u (s-subs s))
+			 (walk u (1+ level))))))
+	    (mapc #'walk tops)
+	    nil))))))
+
+(defun gather-stuff (package)
+  (let ((classes nil)
+	(functions nil)
+	(generics nil)
+	(structs nil)
+	(macros nil)
+	(methods nil)
+	(package (find-package package)))
+
+    ;; find all of the interesting things in the package.
+    (do-symbols (sym package)
+      (when (eq (symbol-package sym) package)
+	(let ((class (find-class sym nil)))
+	  (typecase class
+	    ((or standard-class sb-pcl::condition-class)
+	     (push class classes))
+	    (structure-class (push class structs))))
+	(when (fboundp sym)
+	  (let ((func (symbol-function sym)))
+	    (if (typep func 'generic-function)
+		(push func generics)
+		(push sym functions))))
+	(let ((macro (macro-function sym)))
+	  (when macro (push sym macros)))))
+
+    ;; sort the lists -- makes things look prettier.
+    (macrolet ((frob (list key)
+		 `(setf ,list (sort ,list #'string< :key #',key))))
+      (frob classes class-name)
+      (frob functions identity)
+      (frob structs class-name)
+      (frob generics generic-function-name)
+      (frob macros identity)
+      (frob methods (lambda (m)
+		      (generic-function-name (method-generic-function m)))))
+
+    ;; present the classes in a vaguely useful way
+    (flet ((sep ()
+	     (format t "~%-------------------------~2%")))
+      (show-classes classes)
+      (sep)
+      (show-classes structs)
+      (sep)
+      (categorize-protocols generics classes)
+      (loop for title in '("Macros" "Functions")
+	    for list in (list macros functions) do
+	    (sep)
+	    (format t "~{~(~A~)~%~}" list)))))
+
diff --git a/sod.asd b/pre-reorg/sod.asd
similarity index 89%
rename from sod.asd
rename to pre-reorg/sod.asd
index 54214fc..48dbcaa 100644
--- a/sod.asd
+++ b/pre-reorg/sod.asd
@@ -82,8 +82,13 @@
    (:file "class-finalize" :depends-on ("class-defs" "cpl"))
    (:file "class-builder" :depends-on ("class-finalize" "pset"))
    (:file "class-layout" :depends-on ("class-defs"))
-   (:file "module" :depends-on ("parse-c-types" "tables"))
+   (:file "module" :depends-on ("parse-c-types" "class-defs" "tables"))
+   (:file "builtin" :depends-on ("module" "class-layout"))
    (:file "output" :depends-on ("module"))
-   (:file "class-output" :depends-on ("class-layout" "output"))))
+   (:file "methods" :depends-on ("class-layout" "codegen" "output"))
+   (:file "class-output" :depends-on ("builtin" "class-builder"
+				      "methods" "output"))
+   (:file "combination" :depends-on ("methods"))
+   (:file "module-output" :depends-on ("combination" "class-output"))))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/tables.lisp b/pre-reorg/tables.lisp
similarity index 100%
rename from tables.lisp
rename to pre-reorg/tables.lisp
diff --git a/src/builtin.lisp b/src/builtin.lisp
new file mode 100644
index 0000000..7ea022e
--- /dev/null
+++ b/src/builtin.lisp
@@ -0,0 +1,306 @@
+;;; -*-lisp-*-
+;;;
+;;; Builtin module provides the root of the class graph
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Infrastructure.
+
+(defvar *class-slot-alist* nil)
+
+(defun add-class-slot-function (name function)
+  "Attach a slot function to the *class-slot-alist*.
+
+   The FUNCTION is invoked with one argument, which is a `sod-class' object
+   to which it should add a slot.  If a function with the same NAME is
+   already defined then that function is replaced; otherwise a new name/
+   function pair is defined.
+
+   Functions are are invoked in the order in which their names were first
+   added."
+
+  (aif (assoc name *class-slot-alist* :test #'string=)
+       (setf (cdr it) function)
+       (asetf *class-slot-alist* (append it (list (cons name function))))))
+
+(defmacro define-class-slot
+    (name (class &optional stream) type init &body prepare)
+  "Define a new class slot.
+
+   The slot will be caled NAME, and will be of TYPE (which should be a type
+   S-expression).  The slot's (static) initializer will be constructed by
+   printing the value of INIT, which is evaluated with CLASS bound to the
+   class object being constructed.  If any PREPARE forms are provided, then
+   they are evaluated as a progn; they are evaluated with CLASS bound to the
+   class object, and STREAM bound to the output stream it should write on."
+
+  (with-gensyms (classvar)
+    `(add-class-slot-function
+      ',name
+      (lambda (,classvar)
+	(make-sod-slot ,classvar ,name (c-type ,type)
+		       (make-property-set :lisp-class 'sod-class-slot
+					  :initializer-function
+					  (lambda (,class)
+					    ,init)
+					  ,@(and prepare
+						 `(:prepare-function
+						   (lambda (,class ,stream)
+						     ,@prepare)))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Basic information.
+
+(define-class-slot "name" (class) const-string
+  (prin1-to-string (sod-class-name class)))
+
+(define-class-slot "nick" (class) const-string
+  (prin1-to-string (sod-class-nickname class)))
+
+;;;--------------------------------------------------------------------------
+;;; Instance allocation and initialization.
+
+(define-class-slot "initsz" (class) size-t
+  (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
+
+(define-class-slot "imprint" (class stream)
+    (* (fun (* void) ("/*p*/" (* void))))
+  (format nil "~A__imprint" class)
+  (let ((ilayout (sod-class-ilayout class)))
+    (format stream "~&~:
+/* Imprint raw memory with instance structure. */
+static void *~A__imprint(void *p)
+{
+  struct ~A *sod__obj = p;
+
+  ~:{sod__obj.~A.~A._vt = &~A;~:^~%  ~}
+  return (p);
+}~2%"
+	    class
+	    (ilayout-struct-tag class)
+	    (mapcar (lambda (ichain)
+		      (let* ((head (ichain-head ichain))
+			     (tail (ichain-tail ichain)))
+			(list (sod-class-nickname head)
+			      (sod-class-nickname tail)
+			      (vtable-name class head))))
+		    (ilayout-ichains ilayout)))))
+
+(define-class-slot "init" (class stream)
+    (* (fun (* void) ("/*p*/" (* void))))
+  (format nil "~A__init" class)
+
+  ;; FIXME this needs a metaobject protocol
+  (let ((ilayout (sod-class-ilayout class)))
+    (format stream "~&~:
+static void *~A__init(void *p)
+{
+  struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
+	    class
+	    (ilayout-struct-tag class))
+    (dolist (ichain (ilayout-ichains ilayout))
+      (let ((ich (format nil "sod__obj.~A.~A"
+			 (sod-class-nickname (ichain-head ichain))
+			 (sod-class-nickname (ichain-tail ichain)))))
+	(dolist (item (ichain-body ichain))
+	  (etypecase item
+	    (vtable-pointer
+	     nil)
+	    (islots
+	     (let ((isl (format nil "~A.~A"
+				ich
+				(sod-class-nickname (islots-class item)))))
+	       (dolist (slot (islots-slots item))
+		 (let ((dslot (effective-slot-direct-slot slot))
+		       (init (effective-slot-initializer slot)))
+		   (when init
+		     (format stream "  ~A.~A =" isl
+			     (sod-slot-name dslot))
+		     (ecase (sod-initializer-value-kind init)
+		       (:simple (write (sod-initializer-value-form init)
+				       :stream stream
+				       :pretty nil :escape nil)
+				(format stream ";~%"))
+		       (:compound (format stream " (~A) {"
+					  (sod-slot-type dslot))
+				  (write (sod-initializer-value-form init)
+					 :stream stream
+					 :pretty nil :escape nil)
+				  (format stream "};~%"))))))))))))
+    (format stream "~&~:
+  return (p);
+}~2%")))
+
+;;;--------------------------------------------------------------------------
+;;; Superclass structure.
+
+(define-class-slot "n_supers" (class) size-t
+  (length (sod-class-direct-superclasses class)))
+
+(define-class-slot "supers" (class stream)
+    (* (* (class "SodClass" :const) :const))
+  (if (null (sod-class-direct-superclasses class)) 0
+      (format nil "~A__supers" class))
+  (let ((supers (sod-class-direct-superclasses class)))
+    (when supers
+      (format stream "~&~:
+/* Direct superclasses. */
+static const SodClass *const ~A__supers[] = {
+  ~{~A__class~^,~%  ~}
+};~2%"
+	      class supers))))
+
+(define-class-slot "n_cpl" (class) size-t
+  (length (sod-class-precedence-list class)))
+
+(define-class-slot "cpl" (class stream)
+    (* (* (class "SodClass" :const) :const))
+  (format nil "~A__cpl" class)
+  (format stream "~&~:
+/* Class precedence list. */
+static const SodClass *const ~A__cpl[] = {
+  ~{~A__class~^,~%  ~}
+};~2%"
+	  class (sod-class-precedence-list class)))
+
+;;;--------------------------------------------------------------------------
+;;; Chain structure.
+
+(define-class-slot "link" (class) (* (class "SodClass" :const))
+  (aif (sod-class-chain-link class)
+       (format nil "~A__class" it)
+       0))
+
+(define-class-slot "head" (class) (* (class "SodClass" :const))
+  (format nil "~A__class" (sod-class-chain-head class)))
+
+(define-class-slot "level" (class) size-t
+  (position class (reverse (sod-class-chain class))))
+
+(define-class-slot "n_chains" (class) size-t
+  (length (sod-class-chains class)))
+
+(define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
+  (format nil "~A__chains" class)
+  (let ((chains (sod-class-chains class)))
+    (format stream "~&~:
+/* Chain structure. */
+~1@*~:{static const SodClass *const ~A__chain_~A[] = {
+  ~{~A__class~^,~%  ~}
+};~:^~2%~}
+
+~0@*static const struct sod_chain ~A__chains[] = {
+~:{  { ~3@*~A,
+    ~0@*&~A__chain_~A,
+    ~4@*offsetof(struct ~A, ~A),
+    (const struct sod_vtable *)&~A,
+    sizeof(struct ~A) }~:^,~%~}
+};~2%"
+	    class			;0
+	    (mapcar (lambda (chain)	;1
+		      (let* ((head (sod-class-chain-head (car chain)))
+			     (chain-nick (sod-class-nickname head)))
+			(list class chain-nick			    ;0 1
+			      (reverse chain)			    ;2
+			      (length chain)			    ;3
+			      (ilayout-struct-tag class) chain-nick ;4 5
+			      (vtable-name class head)		    ;6
+			      (ichain-struct-tag class head))))	    ;7
+		    chains))))
+
+;;;--------------------------------------------------------------------------
+;;; Class-specific layout.
+
+(define-class-slot "off_islots" (class) size-t
+  (format nil "offsetof(struct ~A, ~A)"
+	  (ichain-struct-tag class (sod-class-chain-head class))
+	  (sod-class-nickname class)))
+
+(define-class-slot "islotsz" (class) size-t
+  (format nil "sizeof(struct ~A)"
+	  (islots-struct-tag class)))
+
+;;;--------------------------------------------------------------------------
+;;; Bootstrapping the class graph.
+
+(defun bootstrap-classes (module)
+  (let* ((sod-object (make-sod-class "SodObject" nil
+				     (make-property-set :nick 'obj)))
+	 (sod-class (make-sod-class "SodClass" (list sod-object)
+				    (make-property-set :nick 'cls)))
+	 (classes (list sod-object sod-class)))
+
+    ;; Sort out the recursion.
+    (setf (slot-value sod-class 'chain-link) sod-object)
+    (dolist (class classes)
+      (setf (slot-value class 'metaclass) sod-class))
+
+    ;; Predeclare the class types.
+    (dolist (class classes)
+      (make-class-type (sod-class-name class)))
+
+    ;; Attach the class slots.
+    (dolist (slot *class-slot-alist*)
+      (funcall (cdr slot) sod-class))
+
+    ;; These classes are too closely intertwined.  We must partially finalize
+    ;; them together by hand.  This is cloned from `finalize-sod-class'.
+    (dolist (class classes)
+      (with-slots (class-precedence-list chain-head chain chains) class
+	(setf class-precedence-list (compute-cpl class))
+	(setf (values chain-head chain chains) (compute-chains class))))
+
+    ;; Done.
+    (dolist (class classes)
+      (finalize-sod-class class)
+      (add-to-module module class))))
+
+(defun make-builtin-module ()
+  (let ((module (make-instance 'module
+			       :name (make-pathname :name "SOD-BASE"
+						    :type "SOD"
+						    :case :common)
+			       :state nil))
+	(include (format nil "#include \"~A\"~%"
+			 (make-pathname :name "SOD" :type "H"
+					:case :common))))
+    (call-with-module-environment
+     (lambda ()
+       (dolist (name '("va_list" "size_t" "ptrdiff_t"))
+	 (add-to-module module (make-instance 'type-item :name name)))
+       (add-to-module module (make-instance 'code-fragment-item
+					    :reason :c
+					    :constraints nil
+					    :name :includes
+					    :fragment include))
+       (bootstrap-classes module)))
+    module))
+
+(defvar *builtin-module* nil)
+
+(define-clear-the-decks reset-builtin-module
+  (setf *builtin-module* (make-builtin-module)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp
new file mode 100644
index 0000000..bf02aa6
--- /dev/null
+++ b/src/class-utilities.lisp
@@ -0,0 +1,199 @@
+;;; -*-lisp-*-
+;;;
+;;; A collection of utility functions for SOD classes
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Finding things by name
+
+(export 'find-superclass-by-nick)
+(defun find-superclass-by-nick (class nick)
+  "Returns the superclass of CLASS with nickname NICK, or signals an error."
+
+  ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
+  ;; trundle through its superclasses and hope for the best.
+  (if (string= nick (sod-class-nickname class))
+      class
+      (or (some (lambda (super)
+		  (find nick (sod-class-precedence-list super)
+			:key #'sod-class-nickname
+			:test #'string=))
+		(sod-class-direct-superclasses class))
+	  (error "No superclass of `~A' with nickname `~A'" class nick))))
+
+(export '(find-instance-slot-by-name find-class-slot-by-name
+	  find-message-by-name))
+(flet ((find-thing-by-name (what class list name key)
+	 (or (find name list :key key :test #'string=)
+	     (error "No ~A in class `~A' with name `~A'" what class name))))
+
+  (defun find-instance-slot-by-name (class super-nick slot-name)
+    (let ((super (find-superclass-by-nick class super-nick)))
+      (find-thing-by-name "slot" super (sod-class-slots super)
+			  slot-name #'sod-slot-name)))
+
+  (defun find-class-slot-by-name (class super-nick slot-name)
+    (let* ((meta (sod-class-metaclass class))
+	   (super (find-superclass-by-nick meta super-nick)))
+      (find-thing-by-name "slot" super (sod-class-slots super)
+			  slot-name #'sod-slot-name)))
+
+  (defun find-message-by-name (class super-nick message-name)
+    (let ((super (find-superclass-by-nick class super-nick)))
+      (find-thing-by-name "message" super (sod-class-messages super)
+			  message-name #'sod-message-name))))
+
+;;;--------------------------------------------------------------------------
+;;; Miscellaneous useful functions.
+
+(export 'sod-subclass-p)
+(defun sod-subclass-p (class-a class-b)
+  "Return whether CLASS-A is a descendent of CLASS-B.
+
+   Careful!  Assumes that the class precedence list of CLASS-A has been
+   computed!"
+  (member class-b (sod-class-precedence-list class-a)))
+
+(export 'valid-name-p)
+(defun valid-name-p (name)
+  "Checks whether NAME is a valid name.
+
+   The rules are:
+
+     * the name must be a string
+     * which is nonempty
+     * whose first character is alphabetic
+     * all of whose characters are alphanumeric or underscores
+     * and which doesn't contain two consecutive underscores."
+
+  (and (stringp name)
+       (plusp (length name))
+       (alpha-char-p (char name 0))
+       (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
+       (not (search "__" name))))
+
+(export 'find-root-superclass)
+(defun find-root-superclass (class)
+  "Returns the `root' superclass of CLASS.
+
+   The root superclass is the superclass which itself has no direct
+   superclasses.  In universes not based on the provided builtin module, the
+   root class may not be our beloved SodObject; however, there must be one
+   (otherwise the class graph is cyclic, which should be forbidden), and we
+   insist that it be unique."
+
+  ;; The root superclass must be a chain head since the chains partition the
+  ;; superclasses; the root has no superclasses so it can't have a link and
+  ;; must therefore be a head.  This narrows the field down quite a lot.
+  ;;
+  ;; Note!  This function gets called from `check-sod-class' before the
+  ;; class's chains have been computed.  Therefore we iterate over the direct
+  ;; superclass's chains rather than the class's own.  This misses a chain
+  ;; only in the case where the class is its own chain head.  There are two
+  ;; subcases: if there are no direct superclasses at all, then the class is
+  ;; its own root; otherwise, it clearly can't be the root and the omission
+  ;; is harmless.
+
+  (let* ((supers (sod-class-direct-superclasses class))
+	 (roots (if supers
+		    (remove-duplicates
+		     (remove-if #'sod-class-direct-superclasses
+				(mappend (lambda (super)
+					   (mapcar (lambda (chain)
+						     (sod-class-chain-head
+						      (car chain)))
+						   (sod-class-chains super)))
+					 supers)))
+		    (list class))))
+    (cond ((null roots) (error "Class ~A has no root class!" class))
+	  ((cdr roots) (error "Class ~A has multiple root classes ~
+			       ~{~A~#[~; and ~;, ~]~}"
+			      class roots))
+	  (t (car roots)))))
+
+(export 'find-root-metaclass)
+(defun find-root-metaclass (class)
+  "Returns the `root' metaclass of CLASS.
+
+   The root metaclass is the metaclass of the root superclass -- see
+   `find-root-superclass'."
+  (sod-class-metaclass (find-root-superclass class)))
+
+;;;--------------------------------------------------------------------------
+;;; Type hacking.
+
+(export 'argument-lists-compatible-p)
+(defun argument-lists-compatible-p (message-args method-args)
+  "Compare argument lists for compatibility.
+
+   Return true if METHOD-ARGS is a suitable method argument list
+   corresponding to the message argument list MESSAGE-ARGS.  This is the case
+   if the lists are the same length, each message argument has a
+   corresponding method argument with the same type, and if the message
+   arguments end in an ellpisis, the method arguments must end with a
+   `va_list' argument.  (We can't pass actual variable argument lists around,
+   except as `va_list' objects, which are devilish inconvenient things and
+   require much hacking.  See the method combination machinery for details.)"
+
+  (and (= (length message-args) (length method-args))
+       (every (lambda (message-arg method-arg)
+		(if (eq message-arg :ellipsis)
+		    (eq method-arg (c-type va-list))
+		    (c-type-equal-p (argument-type message-arg)
+				    (argument-type method-arg))))
+	      message-args method-args)))
+
+;;;--------------------------------------------------------------------------
+;;; Names of things.
+
+(export 'islots-struct-tag)
+(defun islots-struct-tag (class)
+  (format nil "~A__islots" class))
+
+(export 'ichain-struct-tag)
+(defun ichain-struct-tag (class chain-head)
+  (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
+
+(export 'ichain-union-tag)
+(defun ichain-union-tag (class chain-head)
+  (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
+
+(export 'ilayout-struct-tag)
+(defun ilayout-struct-tag (class)
+  (format nil "~A__ilayout" class))
+
+(export 'vtmsgs-struct-tag)
+(defun vtmsgs-struct-tag (class super)
+  (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
+
+(export 'vtable-struct-tag)
+(defun vtable-struct-tag (class chain-head)
+  (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
+
+(export 'vtable-name)
+(defun vtable-name (class chain-head)
+  (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/classes.lisp b/src/classes.lisp
new file mode 100644
index 0000000..3d01f57
--- /dev/null
+++ b/src/classes.lisp
@@ -0,0 +1,445 @@
+;;; -*-lisp-*-
+;;;
+;;; Class definitions for main classes
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(export '(sod-class sod-class-name sod-class-nickname
+	  sod-class-type sod-class-metaclass
+	  sod-class-direct-superclasses sod-class-precedence-list
+	  sod-class-chain-link sod-class-chain-head
+	  sod-class-chain sod-class-chains
+	  sod-class-slots
+	  sod-class-instance-initializers sod-class-class-initializers
+	  sod-class-messages sod-class-methods
+	  sod-class-state
+	  sod-class-ilayout sod-class-vtables))
+(defclass sod-class ()
+  ((name :initarg :name :type string :reader sod-class-name)
+   (location :initarg :location :initform (file-location nil)
+	     :type file-location :reader file-location)
+   (nickname :initarg :nick :type string :reader sod-class-nickname)
+   (direct-superclasses :initarg :superclasses :type list
+			:reader sod-class-direct-superclasses)
+   (chain-link :initarg :link :type (or sod-class null)
+	       :reader sod-class-chain-link)
+   (metaclass :initarg :metaclass :type sod-class
+	      :reader sod-class-metaclass)
+   (slots :initarg :slots :initform nil
+	  :type list :accessor sod-class-slots)
+   (instance-initializers :initarg :instance-initializers :initform nil
+			  :type list
+			  :accessor sod-class-instance-initializers)
+   (class-initializers :initarg :class-initializers :initform nil
+		       :type list :accessor sod-class-class-initializers)
+   (messages :initarg :messages :initform nil
+	     :type list :accessor sod-class-messages)
+   (methods :initarg :methods :initform nil
+	    :type list :accessor sod-class-methods)
+
+   (class-precedence-list :type list :accessor sod-class-precedence-list)
+
+   (type :type c-class-type :accessor sod-class-type)
+
+   (chain-head :type sod-class :accessor sod-class-chain-head)
+   (chain :type list :accessor sod-class-chain)
+   (chains :type list :accessor sod-class-chains)
+
+   (ilayout :type ilayout :accessor sod-class-ilayout)
+   (effective-methods :type list :accessor sod-class-effective-methods)
+   (vtables :type list :accessor sod-class-vtables)
+
+   (state :initform nil :type (member nil :finalized broken)
+	  :accessor sod-class-state))
+  (:documentation
+   "Classes describe the layout and behaviour of objects.
+
+   The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAIN-LINK and
+   METACLASS slots are intended to be initialized when the class object is
+   constructed:
+
+     * The NAME is the identifier associated with the class in the user's
+       source file.  It is used verbatim in the generated C code as a type
+       name, and must be distinct from other file-scope names in any source
+       file which includes the class definition.  Furthermore, other names
+       are derived from the class name (most notably the class object
+       NAME__class), which have external linkage and must therefore be
+       distinct from all other identifiers in the program.  It is forbidden
+       for a class NAME to begin with an underscore or to contain two
+       consecutive underscores.
+
+     * The LOCATION identifies where in the source the class was defined.  It
+       gets used in error messages.
+
+     * The NICKNAME is a shorter identifier used to name the class in some
+       circumstances.  The uniqueness requirements on NICKNAME are less
+       strict, which allows them to be shorter: no class may have two classes
+       with the same nickname on its class precedence list.  Nicknames are
+       used (user-visibly) to distinguish slots and messages defined by
+       different classes, and (invisibly) in the derived names of direct
+       methods.  It is forbidden for a nickname to begin with an underscore,
+       or to contain two consecutive underscores.
+
+     * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses,
+       in the order that they were declared in the source.  The class
+       precedence list is computed from the DIRECT-SUPERCLASSES lists of all
+       of the superclasses involved.
+
+     * The CHAIN-LINK is either NIL or one of the DIRECT-SUPERCLASSES.  Class
+       chains are a means for recovering most of the benefits of simple
+       hierarchy lost by the introduction of multiple inheritance.  A class's
+       superclasses (including itself) are partitioned into chains,
+       consisting of a class, its CHAIN-LINK superclass, that class's
+       CHAIN-LINK, and so on.  It is an error if two direct subclasses of any
+       class appear in the same chain (a global property which requires
+       global knowledge of an entire program's class hierarchy in order to
+       determine sensibly).  Slots of superclasses in the same chain can be
+       accessed efficiently; there is an indirection needed to access slots
+       of superclasses in other chains.  Furthermore, an indirection is
+       required to perform a cross-chain conversion (i.e., converting a
+       pointer to an instance of some class into a pointer to an instance of
+       one of its superclasses in a different chain), an operation which
+       occurs implicitly in effective methods in order to call direct methods
+       defined on cross-chain superclasses.
+
+     * The METACLASS is the class of the class object.  Classes are objects
+       in their own right, and therefore must be instances of some class;
+       this class is the metaclass.  Metaclasses can define additional slots
+       and methods to be provided by their instances; a class definition can
+       provide (C constant expression) initial values for the metaclass
+       instance.
+
+   The next few slots can't usually be set at object-construction time, since
+   the objects need to contain references to the class object itself.
+
+     * The SLOTS are a list of the slots defined by the class (instances of
+       `sod-slot').  (The class will also define all of the slots defined by
+       its superclasses.)
+
+     * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of
+       initializers for slots (see `sod-initializer' and subclasses),
+       providing initial values for instances of the class, and for the
+       class's class object itself, respectively.
+
+     * The MESSAGES are a list of the messages recognized by the class
+       (instances of `sod-message' and subclasses).  (Note that the message
+       need not have any methods defined on it.  The class will also
+       recognize all of the messages defined by its superclasses.)
+
+     * The METHODS are a list of (direct) methods defined on the class
+       (instances of `sod-method' and subclasses).  Each method provides
+       behaviour to be invoked by a particular message recognized by the
+       class.
+
+   Other slots are computed from these in order to describe the class's
+   layout and effective methods; this is done by `finalize-sod-class'.
+
+     * The CLASS-PRECEDENCE-LIST is a list of superclasses in a linear order.
+       It is computed by `compute-class-precedence-list', whose default
+       implementation ensures that the order of superclasses is such that (a)
+       subclasses appear before their superclasses; (b) the direct
+       superclasses of a given class appear in the order in which they were
+       declared by the programmer; and (c) classes always appear in the same
+       relative order in all class precedence lists in the same superclass
+       graph.
+
+     * The CHAIN-HEAD is the least-specific class in the class's chain.  If
+       there is no link class then the CHAIN-HEAD is the class itself.  This
+       slot, like the next two, is computed by the generic function
+       `compute-chains'.
+
+     * The CHAIN is the list of classes on the complete primary chain,
+       starting from this class and ending with the CHAIN-HEAD.
+
+     * The CHAINS are the complete collection of chains (most-to-least
+       specific) for the class and all of its superclasses.
+
+   Finally, slots concerning the instance and vtable layout of the class are
+   computed on demand via methods on `slot-unbound'.
+
+     * The ILAYOUT describes the layout for an instance of the class.  It's
+       quite complicated; see the documentation of the ILAYOUT class for
+       detais.
+
+     * The EFFECTIVE-METHODS are a list of effective methods, specialized for
+       the class.
+
+     * The VTABLES are a list of descriptions of vtables for the class.  The
+       individual elements are VTABLE objects, which are even more
+       complicated than ILAYOUT structures.  See the class documentation for
+       details."))
+
+(defmethod print-object ((class sod-class) stream)
+  (maybe-print-unreadable-object (class stream :type t)
+    (princ (sod-class-name class) stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Slots and initializers.
+
+(export '(sod-slot sod-slot-name sod-slot-class sod-slot-type))
+(defclass sod-slot ()
+  ((name :initarg :name :type string :reader sod-slot-name)
+   (location :initarg :location :initform (file-location nil)
+	     :type file-location :reader file-location)
+   (class :initarg :class :type sod-class :reader sod-slot-class)
+   (type :initarg :type :type c-type :reader sod-slot-type))
+  (:documentation
+   "Slots are units of information storage in instances.
+
+   Each class defines a number of slots, which function similarly to (data)
+   members in structures.  An instance contains all of the slots defined in
+   its class and all of its superclasses.
+
+   A slot carries the following information.
+
+     * A NAME, which distinguishes it from other slots defined by the same
+       class.  Unlike most (all?) other object systems, slots defined in
+       different classes are in distinct namespaces.  There are no special
+       restrictions on slot names.
+
+     * A LOCATION, which states where in the user's source the slot was
+       defined.  This gets used in error messages.
+
+     * A CLASS, which states which class defined the slot.  The slot is
+       available in instances of this class and all of its descendents.
+
+     * A TYPE, which is the C type of the slot.  This must be an object type
+       (certainly not a function type, and it must be a complete type by the
+       time that the user header code has been scanned)."))
+
+(defmethod print-object ((slot sod-slot) stream)
+  (maybe-print-unreadable-object (slot stream :type t)
+    (pprint-c-type (sod-slot-type slot) stream
+		   (format nil "~A.~A"
+			   (sod-class-nickname (sod-slot-class slot))
+			   (sod-slot-name slot)))))
+
+(export '(sod-initializer sod-initializer-slot sod-initializer-class
+	  sod-initializer-value-kind sod-initializer-value-form))
+(defclass sod-initializer ()
+  ((slot :initarg :slot :type sod-slot :reader sod-initializer-slot)
+   (location :initarg :location :initform (file-location nil)
+	     :type file-location :reader file-location)
+   (class :initarg :class :type sod-class :reader sod-initializer-class)
+   (value-kind :initarg :value-kind :type keyword
+	       :reader sod-initializer-value-kind)
+   (value-form :initarg :value-form :type c-fragment
+	       :reader sod-initializer-value-form))
+  (:documentation
+   "Provides an initial value for a slot.
+
+   The slots of an initializer are as follows.
+
+     * The SLOT specifies which slot this initializer is meant to initialize.
+
+     * The LOCATION states the position in the user's source file where the
+       initializer was found.  This gets used in error messages.  (Depending
+       on the source layout style, this might differ from the location in the
+       VALUE-FORM C fragment.)
+
+     * The CLASS states which class defined this initializer.  For instance
+       slot initializers (`sod-instance-initializer'), this will be the same
+       as the SLOT's class, or be one of its descendants.  For class slot
+       initializers (`sod-class-initializer'), this will be an instance of
+       the SLOT's class, or an instance of one of its descendants.
+
+     * The VALUE-KIND states what manner of initializer we have.  It can be
+       either `:single', indicating a standalone expression, or `:compound',
+       indicating a compound initializer which must be surrounded by braces
+       on output.
+
+     * The VALUE-FORM gives the text of the initializer, as a C fragment.
+
+   Typically you'll see instances of subclasses of this class in the wild
+   rather than instances of this class directly.  See `sod-class-initializer'
+   and `sod-instance-initializer'."))
+
+(defmethod print-object ((initializer sod-initializer) stream)
+  (if *print-escape*
+      (print-unreadable-object (initializer stream :type t)
+	(format stream "~A = ~A"
+		(sod-initializer-slot initializer)
+		initializer))
+      (format stream "~:[{~A}~;~A~]"
+	      (eq (sod-initializer-value-kind initializer) :single)
+	      (sod-initializer-value-form initializer))))
+
+(export 'sod-class-initializer)
+(defclass sod-class-initializer (sod-initializer)
+  ()
+  (:documentation
+   "Provides an initial value for a class slot.
+
+   A class slot initializer provides an initial value for a slot in the class
+   object (i.e., one of the slots defined by the class's metaclass).  Its
+   VALUE-FORM must have the syntax of an initializer, and its consituent
+   expressions must be constant expressions.
+
+   See `sod-initializer' for more details."))
+
+(export 'sod-instance-initializer)
+(defclass sod-instance-initializer (sod-initializer)
+  ()
+  (:documentation
+   "Provides an initial value for a slot in all instances.
+
+   An instance slot initializer provides an initial value for a slot in
+   instances of the class.  Its VALUE-FORM must have the syntax of an
+   initializer.  Furthermore, if the slot has aggregate type, then you'd
+   better be sure that your compiler supports compound literals (6.5.2.5)
+   because that's what the initializer gets turned into.
+
+   See `sod-initializer' for more details."))
+
+;;;--------------------------------------------------------------------------
+;;; Messages and methods.
+
+(export '(sod-message sod-message-name sod-message-class sod-message-type))
+(defclass sod-message ()
+  ((name :initarg :name :type string :reader sod-message-name)
+   (location :initarg :location :initform (file-location nil)
+	     :type file-location :reader file-location)
+   (class :initarg :class :type sod-class :reader sod-message-class)
+   (type :initarg :type :type c-function-type :reader sod-message-type))
+  (:documentation
+   "Messages the means for stimulating an object to behave.
+
+   SOD is a single-dispatch object system, like Smalltalk, C++, Python and so
+   on, but unlike CLOS and Dylan.  Behaviour is invoked by `sending messages'
+   to objects.  A message carries a name (distinguishing it from other
+   messages recognized by the same class), and a number of arguments; the
+   object may return a value in response.  Sending a message therefore looks
+   very much like calling a function; indeed, each message bears the static
+   TYPE signature of a function.
+
+   An object reacts to being sent a message by executing an `effective
+   method', constructed from the direct methods defined on the recpient's
+   (run-time, not necessarily statically-declared) class and its superclasses
+   according to the message's `method combination'.
+
+   Much interesting work is done by subclasses of `sod-message', which (for
+   example) specify method combinations.
+
+   The slots are as follows.
+
+     * The NAME distinguishes the message from others defined by the same
+       class.  Unlike most (all?) other object systems, messages defined in
+       different classes are in distinct namespaces.  It is forbidden for a
+       message name to begin with an underscore, or to contain two
+       consecutive underscores.  (Final underscores are fine.)
+
+     * The LOCATION states where in the user's source the slot was defined.
+       It gets used in error messages.
+
+     * The CLASS states which class defined the message.
+
+     * The TYPE is a function type describing the message's arguments and
+       return type.
+
+   Subclasses can (and probably will) define additional slots."))
+
+(defmethod print-object ((message sod-message) stream)
+  (maybe-print-unreadable-object (message stream :type t)
+    (pprint-c-type (sod-message-type message) stream
+		   (format nil "~A.~A"
+			   (sod-class-nickname (sod-message-class message))
+			   (sod-message-name message)))))
+
+(export '(sod-method sod-method-message sod-method-class sod-method-type
+	  sod-method-body))
+(defclass sod-method ()
+  ((message :initarg :message :type sod-message :reader sod-method-message)
+   (location :initarg :location :initform (file-location nil)
+	     :type file-location :reader file-location)
+   (class :initarg :class :type sod-class :reader sod-method-class)
+   (type :initarg :type :type c-function-type :reader sod-method-type)
+   (body :initarg :body :type (or c-fragment null) :reader sod-method-body))
+  (:documentation
+   "(Direct) methods are units of behaviour.
+
+   Methods are the unit of behaviour in SOD.  Classes define direct methods
+   for particular messages.
+
+   When a message is received by an instance, all of the methods defined for
+   that message on that instance's (run-time, not static) class and its
+   superclasses are `applicable'.  The applicable methods are gathered
+   together and invoked in some way; the details of this are left to the
+   `method combination', determined by the subclass of `sod-message'.
+
+   The slots are as follows.
+
+     * The MESSAGE describes which meessage invokes the method's behaviour.
+       The method is combined with other methods on the same message
+       according to the message's method combination, to form an `effective
+       method'.
+
+     * The LOCATION states where, in the user's source, the method was
+       defined.  This gets used in error messages.  (Depending on the user's
+       coding style, this location might be subtly different from the BODY's
+       location.)
+
+     * The CLASS specifies which class defined the method.  This will be
+       either the class of the message, or one of its descendents.
+
+     * The TYPE gives the type of the method, including its arguments.  This
+       will, in general, differ from the type of the message for several
+       reasons.
+
+	 -- Firstly, the method type must include names for all of the
+            method's parameters.  The message definition can omit the
+            parameter names (in the same way as a function declaration can).
+            Formally, the message definition can contain abstract
+            declarators, whereas method definitions must not.
+
+	 -- Method combinations may require different parameter or return
+            types.  For example, `before' and `after' methods don't
+            contribute to the message's return value, so they must be defined
+            as returning `void'.
+
+	 -- Method combinations may permit methods whose parameter and/or
+            return types don't exactly match the corresponding types of the
+            message.  For example, one might have methods with covariant
+            return types and contravariant parameter types.  (This sounds
+            nice, but it doesn't actually seem like such a clever idea when
+            you consider that the co-/contravariance must hold among all the
+            applicable methods ordered according to the class precedence
+            list.  As a result, a user might have to work hard to build
+            subclasses whose CPLs match the restrictions implied by the
+            method types.)
+
+   Method objects are fairly passive in the SOD translator.  However,
+   subclasses of `sod-message' may (and probably will) construct instances of
+   subclasses of `sod-method' in order to carry the additional metadata they
+   need to keep track of."))
+
+(defmethod print-object ((method sod-method) stream)
+  (maybe-print-unreadable-object (method stream :type t)
+    (format stream "~A ~@_~A"
+	    (sod-method-message method)
+	    (sod-method-class method))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/foo.lisp b/src/foo.lisp
new file mode 100644
index 0000000..4063c03
--- /dev/null
+++ b/src/foo.lisp
@@ -0,0 +1,7 @@
+(cl:in-package #:sod)
+
+(defun list-tokens (scanner)
+  (let ((toke (make-instance 'sod-token-scanner :char-scanner scanner)))
+    (loop collect (list (token-type toke) (token-value toke))
+	  until (scanner-at-eof-p toke)
+	  do (scanner-step toke))))
diff --git a/src/impl-c-types-class.lisp b/src/impl-c-types-class.lisp
new file mode 100644
index 0000000..f61d84f
--- /dev/null
+++ b/src/impl-c-types-class.lisp
@@ -0,0 +1,145 @@
+;;; -*-lisp-*-
+;;;
+;;; Integrating classes into the C type system
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Class definition.
+
+(export '(c-class-type c-type-class))
+(defclass c-class-type (simple-c-type)
+  ((class :initarg :class :initform nil
+	  :type (or null sod-class) :accessor c-type-class)
+   (tag :initarg :tag))
+  (:documentation
+   "A SOD class, as a C type.
+
+   One usually handles classes as pointers, but the type refers to the actual
+   instance structure itself.  Or, in fact, just the primary chain of the
+   instance (i.e., the one containing the class's own direct slots) -- which
+   is why dealing with the instance structure directly doesn't make much
+   sense.
+
+   The CLASS slot will be NIL if the class isn't defined yet, i.e., this
+   entry was constructed by a forward reference operation.
+
+   The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print
+   the type even when it's a forward reference."))
+
+;; Constructor function and interning.
+
+(define-module-var *module-type-map* (make-hash-table :test #'equal)
+  "Table mapping identifiers to C type objects.
+
+   Each module has its own map.")
+
+(export 'find-class-type)
+(defun find-class-type (name)
+  "Look up NAME and return the corresponding C-CLASS-TYPE.
+
+     * If the type was found, and was a class, returns TYPE.
+
+     * If no type was found at all, returns NIL.
+
+     * If a type was found, but it wasn't a class, signals an error."
+
+  (atypecase (gethash name *module-type-map*)
+    (null nil)
+    (c-class-type it)
+    (t (error "Type `~A' (~A) is not a class" name it))))
+
+(export 'make-class-type)
+(defun make-class-type (name &optional qualifiers)
+  "Make a distinguished object for the class type called NAME."
+
+  ;; We're in an awkward situation.  We want to enter it into the
+  ;; `*c-type-intern-map*' so that it will handle the qualifiers list for
+  ;; us.  But that map isn't scoped to particular modules, so we maintain our
+  ;; own `*module-type-map*'.  But now we need to keep them in sync.
+  ;;
+  ;; The solution is to make the `*module-type-map*' be the master.  Each
+  ;; class-type object has a tag -- a gensym, so that `equal' will think
+  ;; they're different, and we use the tag as part of the input to
+  ;; `intern-c-type'.
+  ;;
+  ;; So the first thing to do is to find the tag for the basic type, without
+  ;; any qualifiers.
+  (multiple-value-bind (type tag)
+      (aif (find-class-type name)
+	   (values it (slot-value it 'tag))
+	   (let* ((tag (gensym "TAG-"))
+		  (type (intern-c-type 'c-class-type :name name :tag tag)))
+	     (values type tag)))
+
+    ;; If no qualifiers are wanted then we've already found or created the
+    ;; wanted type.  Otherwise we'll intern another type with the right
+    ;; qualifiers.
+    (if (null qualifiers)
+	type
+	(intern-c-type 'c-class-type
+		       :name name :tag tag
+		       :qualifiers (canonify-qualifiers qualifiers)))))
+
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and
+    ((type-a c-class-type) (type-b c-class-type))
+  (eql (c-type-class type-a) (c-type-class type-b)))
+
+;; S-expression notation protocol.
+
+(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
+  (declare (ignore colon atsign))
+  (format stream "~:@<CLASS ~:@_~:I~S~{ ~_~S~}~:>"
+	  (c-type-name type)
+	  (c-type-qualifiers type)))
+
+(export 'class)
+(define-c-type-syntax class (name &rest quals)
+  "Returns a type object for the named class."
+  `(make-class-type ,name (list ,@quals)))
+
+;;;--------------------------------------------------------------------------
+;;; Additional functions for lookup.
+
+(export 'find-sod-class)
+(defun find-sod-class (name)
+  "Return the SOD-CLASS object with the given NAME."
+  (aif (find-class-type name)
+       (or (c-type-class it) (error "Class `~A' is incomplete" name))
+       (error "Type `~A' not known" name)))
+
+(export 'record-sod-class)
+(defun record-sod-class (class)
+  "Record CLASS as being a class definition."
+  (with-default-error-location (class)
+    (let* ((name (sod-class-name class))
+	   (type (make-class-type name)))
+      (if (c-type-class type)
+	  (cerror* "Class `~A' already defined at ~A"
+		   name (file-location (c-type-class type)))
+	  (setf (c-type-class type) class)))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/c-types.lisp b/src/impl-c-types.lisp
similarity index 54%
rename from c-types.lisp
rename to src/impl-c-types.lisp
index ed7f922..7892565 100644
--- a/c-types.lisp
+++ b/src/impl-c-types.lisp
@@ -1,13 +1,13 @@
 ;;; -*-lisp-*-
 ;;;
-;;; Dealing with C types
+;;; C type representation implementation
 ;;;
-;;; (c) 2008 Straylight/Edgeware
+;;; (c) 2009 Straylight/Edgeware
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Simple Object Definition system.
+;;; This file is part of the Sensble Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -26,223 +26,73 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
-;;; Plain old C types.
-
-;; Class definition.
-
-(defclass c-type ()
-  ()
-  (:documentation
-   "Base class for C type objects."))
-
-;; Important protocol.
-
-(defgeneric c-type-subtype (type)
-  (:documentation
-   "For compound types, return the base type."))
-
-(defgeneric c-type-equal-p (type-a type-b)
-  (:method-combination and)
-  (:documentation
-   "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.")
-  (:method and (type-a type-b)
-    (eql (class-of type-a) (class-of type-b))))
-
-(defgeneric pprint-c-type (type stream kernel)
-  (:documentation
-   "Pretty-printer for C types.
-
-   Print TYPE to STREAM.  In the middle of the declarator, call the function
-   KERNEL with one argument: whether it needs a leading space.")
-  (:method :around (type stream kernel)
-    (typecase kernel
-      (function (call-next-method))
-      (null (pprint-c-type type stream
-			   (lambda (stream prio spacep)
-			     (declare (ignore stream prio spacep))
-			     nil)))
-      (t (pprint-c-type type stream
-			(lambda (stream prio spacep)
-			  (declare (ignore prio))
-			  (when spacep
-			    (c-type-space stream))
-			  (princ kernel stream)))))))
-
-(defgeneric print-c-type (stream type &optional colon atsign)
-  (:documentation
-   "Print an abbreviated syntax for TYPE to the STREAM."))
-
-(defmethod print-object ((object c-type) stream)
-  (if *print-escape*
-      (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
-      (pprint-c-type object stream nil)))
-
-;; Utility functions and macros.
-
-(defun c-type-space (stream)
-  "Print a space and a miser-mode newline to STREAM.
-
-   This is the right function to call in a PPRINT-C-TYPE kernel function when
-   the SPACEP argument is true."
-  (pprint-indent :block 2 stream)
-  (write-char #\space stream)
-  (pprint-newline :miser stream))
-
-(defun maybe-in-parens* (stream condition thunk)
-  "Helper function for the MAYBE-IN-PARENS macro."
-  (pprint-logical-block
-      (stream nil
-	      :prefix (if condition "(" "")
-	      :suffix (if condition ")" ""))
-    (funcall thunk stream)))
-
-(defmacro maybe-in-parens ((stream condition) &body body)
-  "Evaluate BODY; if CONDITION, write parens to STREAM around it.
-
-   This macro is useful for implementing the PPRINT-C-TYPE method on compound
-   types.  The BODY is evaluated in the context of a logical block printing
-   to STREAM.  If CONDITION is non-nil, then the block will have open/close
-   parens as its prefix and suffix; otherwise they will be empty.
-
-   The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
-  `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
-
-;; S-expression syntax machinery.
-
-(defun c-name-case (name)
-  "Convert NAME to suitable case.
-
-   Strings are returned as-is; symbols are squashed to lower-case and hyphens
-   are replaced by underscores."
-  (typecase name
-    (symbol (with-output-to-string (out)
-	      (loop for ch across (symbol-name name)
-		    do (cond ((alpha-char-p ch)
-			      (write-char (char-downcase ch) out))
-			     ((or (digit-char-p ch)
-				  (char= ch #\_))
-			      (write-char ch out))
-			     ((char= ch #\-)
-			      (write-char #\_ out))
-			     (t
-			      (error "Bad character in C name ~S." name))))))
-    (t name)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defgeneric expand-c-type-spec (spec)
-    (:documentation
-     "Expand SPEC into Lisp code to construct a C type.")
-    (:method ((spec list))
-      (expand-c-type-form (car spec) (cdr spec))))
-  (defgeneric expand-c-type-form (head tail)
-    (:documentation
-     "Expand a C type list beginning with HEAD.")
-    (:method ((name (eql 'lisp)) tail)
-      `(progn ,@tail))))
-
-(defmacro c-type (spec)
-  "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
-  (expand-c-type-spec spec))
-
-(defmacro define-c-type-syntax (name bvl &rest body)
-  "Define a C-type syntax function.
-
-   A function defined by BODY and with lambda-list BVL is associated with the
-   NAME.  When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
-   function with the argument list STUFF."
-  (let ((headvar (gensym "HEAD"))
-	(tailvar (gensym "TAIL")))
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar)
-	 (destructuring-bind ,bvl ,tailvar
-	   ,@body)))))
-
-(defmacro c-type-alias (original &rest aliases)
-  "Make ALIASES behave the same way as the ORIGINAL type."
-  (let ((headvar (gensym "HEAD"))
-	(tailvar (gensym "TAIL")))
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       ,@(mapcar (lambda (alias)
-		   `(defmethod expand-c-type-form
-			((,headvar (eql ',alias)) ,tailvar)
-		      (expand-c-type-form ',original ,tailvar)))
-		 aliases))))
-
-(defmacro defctype (names value)
-  "Define NAMES all to describe the C-type VALUE.
-
-   NAMES can be a symbol (treated as a singleton list), or a list of symbols.
-   The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE.  It will
-   be expanded once at run-time."
-  (let* ((names (if (listp names) names (list names)))
-	 (namevar (gensym "NAME"))
-	 (typevar (symbolicate 'c-type- (car names))))
-    `(progn
-       (defparameter ,typevar ,(expand-c-type-spec value))
-       (eval-when (:compile-toplevel :load-toplevel :execute)
-	 ,@(mapcar (lambda (name)
-		     `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
-			',typevar))
-		   names)))))
+;;; Interning types.
+
+(defparameter *c-type-intern-map* (make-hash-table :test #'equal)
+  "Hash table mapping lists describing types to their distinguished
+   representations.")
+
+(defun intern-c-type (class &rest initargs)
+  "If the CLASS and INITARGS have already been interned, then return the
+   existing object; otherwise make a new one."
+  (let ((list (cons class initargs)))
+    (or (gethash list *c-type-intern-map*)
+	(let ((new (apply #'make-instance class initargs)))
+	  (setf (gethash new *c-type-intern-map*) t
+		(gethash list *c-type-intern-map*) new)))))
+
+#+test
+(defun check-type-intern-map ()
+  "Sanity check for the type-intern map."
+  (let ((map (make-hash-table)))
+
+    ;; Pass 1: check that interned types are consistent with their keys.
+    ;; Remember interned types.
+    (maphash (lambda (k v)
+	       (when (listp k)
+		 (let ((ty (apply #'make-instance k)))
+		   (assert (c-type-equal-p ty v)))
+		 (setf (gethash v map) t)))
+	     *c-type-intern-map*)
+
+    ;; Pass 2: check that the interned type indicators are correct.
+    (maphash (lambda (k v)
+	       (declare (ignore v))
+	       (assert (gethash k *c-type-intern-map*)))
+	     map)
+    (maphash (lambda (k v)
+	       (declare (ignore v))
+	       (when (typep k 'c-type)
+		 (assert (gethash k map))))
+	     *c-type-intern-map*)))
 
 ;;;--------------------------------------------------------------------------
-;;; Types which can accept qualifiers.
+;;; Simple C types.
 
-;; Basic definitions.
+;; Class definition.
 
-(defclass qualifiable-c-type (c-type)
-  ((qualifiers :initarg :qualifiers :initform nil
-	       :type list :accessor c-type-qualifiers))
+(export '(simple-c-type c-type-name))
+(defclass simple-c-type (qualifiable-c-type)
+  ((name :initarg :name :type string :reader c-type-name))
   (:documentation
-   "Base class for C types which can be qualified."))
-
-(defun format-qualifiers (quals)
-  "Return a string listing QUALS, with a space after each."
-  (format nil "~{~(~A~) ~}" quals))
-
-(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
-			       (type-b qualifiable-c-type))
-  (flet ((fix (type)
-	   (sort (copy-list (c-type-qualifiers type)) #'string<)))
-    (equal (fix type-a) (fix type-b))))
-
-;; A handy utility.
-
-(let ((cache (make-hash-table :test #'equal)))
-  (defun qualify-type (c-type qualifiers)
-    "Returns a qualified version of C-TYPE.
-
-   Maintains a cache of qualified types so that we don't have to run out of
-   memory.  This can also speed up type comparisons."
-    (if (null qualifiers)
-	c-type
-	(let ((key (cons c-type qualifiers)))
-	  (unless (typep c-type 'qualifiable-c-type)
-	    (error "~A isn't qualifiable." (class-name (class-of c-type))))
-	  (or (gethash key cache)
-	      (setf (gethash key cache)
-		    (copy-instance c-type :qualifiers qualifiers)))))))
+   "C types with simple forms."))
 
-;;;--------------------------------------------------------------------------
-;;; Simple C types (e.g., built-in arithmetic types).
+;; Constructor function and interning.
 
-(defvar *simple-type-map* (make-hash-table :test #'equal)
-  "A hash table mapping type strings to Lisp symbols naming them.")
+(export 'make-simple-type)
+(defun make-simple-type (name &optional qualifiers)
+  "Make a distinguished object for the simple type called NAME."
+  (intern-c-type 'simple-c-type
+		 :name name
+		 :qualifiers (canonify-qualifiers qualifiers)))
 
-;; Basic definitions.
+;; Comparison protocol.
 
-(defclass simple-c-type (qualifiable-c-type)
-  ((name :initarg :name :type string :reader c-type-name))
-  (:documentation
-   "C types with simple forms."))
+(defmethod c-type-equal-p and
+    ((type-a simple-c-type) (type-b simple-c-type))
+  (string= (c-type-name type-a) (c-type-name type-b)))
 
-(let ((cache (make-hash-table :test #'equal)))
-  (defun make-simple-type (name &optional qualifiers)
-    "Make a distinguished object for the simple type called NAME."
-    (qualify-type (or (gethash name cache)
-		      (setf (gethash name cache)
-			    (make-instance 'simple-c-type :name name)))
-		  qualifiers)))
+;; C syntax output protocol.
 
 (defmethod pprint-c-type ((type simple-c-type) stream kernel)
   (pprint-logical-block (stream nil)
@@ -251,9 +101,10 @@
 	    (c-type-name type))
     (funcall kernel stream 0 t)))
 
-(defmethod c-type-equal-p and ((type-a simple-c-type)
-			       (type-b simple-c-type))
-  (string= (c-type-name type-a) (c-type-name type-b)))
+;; S-expression notation protocol.
+
+(defparameter *simple-type-map* (make-hash-table)
+  "Hash table mapping strings of C syntax to symbolic names.")
 
 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
   (declare (ignore colon atsign))
@@ -262,14 +113,13 @@
     (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
 	    (c-type-qualifiers type) (or symbol name))))
 
-;; S-expression syntax.
-
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmethod expand-c-type-spec ((spec string))
     `(make-simple-type ,spec))
   (defmethod expand-c-type-form ((head string) tail)
-    `(make-simple-type ,head ,@tail)))
+    `(make-simple-type ,head (list ,@tail))))
 
+(export 'define-simple-c-type)
 (defmacro define-simple-c-type (names type)
   "Define each of NAMES to be a simple type called TYPE."
   (let ((names (if (listp names) names (list names))))
@@ -279,6 +129,18 @@
        (define-c-type-syntax ,(car names) (&rest quals)
 	 `(make-simple-type ,',type (list ,@quals))))))
 
+;; Built-in C types.
+
+(export '(void float double long-double va-list size-t ptrdiff-t
+	  char unsigned-char uchar signed-char schar
+	  int signed signed-int sint unsigned unsigned-int uint
+	  short signed-short short-int signed-short-int sshort
+	  unsigned-short unsigned-short-int ushort
+	  long signed-long long-int signed-long-int slong
+	  unsigned-long unsigned-long-int ulong
+	  long-long signed-long-long long-long-int signed-long-long-int
+	  unsigned-long-long unsigned-long-long-int llong sllong ullong))
+
 (define-simple-c-type void "void")
 
 (define-simple-c-type char "char")
@@ -313,34 +175,51 @@
 (define-simple-c-type ptrdiff-t "ptrdiff_t")
 
 ;;;--------------------------------------------------------------------------
-;;; Tag types (structs, unions and enums).
+;;; Tagged types (enums, structs and unions).
 
-;; Definitions.
+;; Class definition.
 
+(export '(tagged-c-type c-type-tag))
 (defclass tagged-c-type (qualifiable-c-type)
   ((tag :initarg :tag :type string :reader c-type-tag))
   (:documentation
    "C types with tags."))
 
+;; Subclass definitions.
+
+(export 'c-tagged-type-kind)
 (defgeneric c-tagged-type-kind (type)
   (:documentation
    "Return the kind of tagged type that TYPE is, as a keyword."))
 
+(export 'kind-c-tagged-type)
+(defgeneric kind-c-tagged-type (kind)
+  (:documentation
+   "Given a keyword KIND, return the appropriate class name."))
+
+(export 'make-c-tagged-type)
+(defun make-c-tagged-type (kind tag &optional qualifiers)
+  "Return a tagged type with the given KIND (keyword) and TAG (string)."
+  (intern-c-type (kind-c-tagged-type kind)
+		 :tag tag
+		 :qualifiers (canonify-qualifiers qualifiers)))
+
 (macrolet ((define-tagged-type (kind what)
-	     (let ((type (symbolicate 'c- kind '-type))
-		   (constructor (symbolicate 'make- kind '-type)))
+	     (let* ((type (symbolicate 'c- kind '-type))
+		    (keyword (intern (symbol-name kind) :keyword))
+		    (constructor (symbolicate 'make- kind '-type)))
 	       `(progn
+		  (export '(,type ,constructor))
 		  (defclass ,type (tagged-c-type) ()
 		    (:documentation ,(format nil "C ~a types." what)))
 		  (defmethod c-tagged-type-kind ((type ,type))
-		    ',kind)
-		  (let ((cache (make-hash-table :test #'equal)))
-		    (defun ,constructor (tag &optional qualifiers)
-		      (qualify-type (or (gethash tag cache)
-					(setf (gethash tag cache)
-					      (make-instance ',type
-							     :tag tag)))
-				    qualifiers)))
+		    ',keyword)
+		  (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
+		    ',type)
+		  (defun ,constructor (tag &optional qualifiers)
+		    (intern-c-type ',type :tag tag
+				   :qualifiers (canonify-qualifiers
+						qualifiers)))
 		  (define-c-type-syntax ,kind (tag &rest quals)
 		    ,(format nil "Construct ~A type named TAG" what)
 		    `(,',constructor ,tag (list ,@quals)))))))
@@ -348,6 +227,13 @@
   (define-tagged-type struct "structure")
   (define-tagged-type union "union"))
 
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
+  (string= (c-type-tag type-a) (c-type-tag type-b)))
+
+;; C syntax output protocol.
+
 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
   (pprint-logical-block (stream nil)
     (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
@@ -356,9 +242,7 @@
 	    (c-type-tag type))
     (funcall kernel stream 0 t)))
 
-(defmethod c-type-equal-p and ((type-a tagged-c-type)
-			       (type-b tagged-c-type))
-  (string= (c-type-tag type-a) (c-type-tag type-b)))
+;; S-expression notation protocol.
 
 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
   (declare (ignore colon atsign))
@@ -370,19 +254,32 @@
 ;;;--------------------------------------------------------------------------
 ;;; Pointer types.
 
-;; Definitions.
+;; Class definition.
 
+(export 'c-pointer-type)
 (defclass c-pointer-type (qualifiable-c-type)
   ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
-  (:documentation
-   "C pointer types."))
+  (:documentation "C pointer types."))
 
-(let ((cache (make-hash-table :test #'eql)))
-  (defun make-pointer-type (subtype &optional qualifiers)
-    "Return a (maybe distinguished) pointer type."
-    (qualify-type (or (gethash subtype cache)
-		      (make-instance 'c-pointer-type :subtype subtype))
-		  qualifiers)))
+;; Constructor function.
+
+(export 'make-pointer-type)
+(defun make-pointer-type (subtype &optional qualifiers)
+  "Return a (maybe distinguished) pointer type."
+  (let ((canonical (canonify-qualifiers qualifiers)))
+    (funcall (if (gethash subtype *c-type-intern-map*)
+		 #'intern-c-type #'make-instance)
+	     'c-pointer-type
+	     :subtype subtype
+	     :qualifiers canonical)))
+
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a c-pointer-type)
+			       (type-b c-pointer-type))
+  (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
+
+;; C syntax output protocol.
 
 (defmethod pprint-c-type ((type c-pointer-type) stream kernel)
   (pprint-c-type (c-type-subtype type) stream
@@ -393,43 +290,76 @@
 			     (c-type-qualifiers type))
 		     (funcall kernel stream 1 (c-type-qualifiers type))))))
 
-(defmethod c-type-equal-p and ((type-a c-pointer-type)
-			       (type-b c-pointer-type))
-  (c-type-equal-p (c-type-subtype type-a)
-		  (c-type-subtype type-b)))
+;; S-expression notation protocol.
 
 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
   (declare (ignore colon atsign))
-  (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>"
+  (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
 	  (c-type-subtype type)
 	  (c-type-qualifiers type)))
 
-;; S-expression syntax.
-
+(export '(* pointer ptr))
 (define-c-type-syntax * (sub &rest quals)
   "Return the type of pointer-to-SUB."
   `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
 (c-type-alias * pointer ptr)
 
+;; Built-in C types.
+
+(export '(string const-string))
 (defctype string (* char))
 (defctype const-string (* (char :const)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Array types.
 
-;; Definitions.
+;; Class definition.
 
+(export '(c-array-type c-array-dimensions))
 (defclass c-array-type (c-type)
   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
    (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
   (:documentation
    "C array types."))
 
+;; Constructor function.
+
+(export 'make-array-type)
 (defun make-array-type (subtype dimensions)
   "Return a new array of SUBTYPE with given DIMENSIONS."
   (make-instance 'c-array-type :subtype subtype
 		 :dimensions (or dimensions '(nil))))
 
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))
+
+  ;; Messy.  C doesn't have multidimensional arrays, but we fake them for
+  ;; convenience's sake.  But it means that we have to arrange for
+  ;; multidimensional arrays to equal vectors of vectors -- and in general
+  ;; for multidimensional arrays of multidimensional arrays to match each
+  ;; other properly, even when their dimensions don't align precisely.
+  (labels ((check (sub-a dim-a sub-b dim-b)
+	     (cond ((endp dim-a)
+		    (cond ((endp dim-b)
+			   (c-type-equal-p sub-a sub-b))
+			  ((typep sub-a 'c-array-type)
+			   (check (c-type-subtype sub-a)
+				  (c-array-dimensions sub-a)
+				  sub-b dim-b))
+			  (t
+			   nil)))
+		   ((endp dim-b)
+		    (check sub-b dim-b sub-a dim-a))
+		   ((equal (car dim-a) (car dim-b))
+		    (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
+		   (t
+		    nil))))
+    (check (c-type-subtype type-a) (c-array-dimensions type-a)
+	   (c-type-subtype type-b) (c-array-dimensions type-b))))
+
+;; C syntax output protocol.
+
 (defmethod pprint-c-type ((type c-array-type) stream kernel)
   (pprint-c-type (c-type-subtype type) stream
 		 (lambda (stream prio spacep)
@@ -438,21 +368,15 @@
 		     (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
 			     (c-array-dimensions type))))))
 
-(defmethod c-type-equal-p and ((type-a c-array-type)
-			       (type-b c-array-type))
-  (and (c-type-equal-p (c-type-subtype type-a)
-		       (c-type-subtype type-b))
-       (equal (c-array-dimensions type-a)
-	      (c-array-dimensions type-b))))
+;; S-expression notation protocol.
 
 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
   (declare (ignore colon atsign))
-  (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>"
+  (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
 	  (c-type-subtype type)
 	  (c-array-dimensions type)))
 
-;; S-expression syntax.
-
+(export '([] array vec))
 (define-c-type-syntax [] (sub &rest dims)
   "Return the type of arrays of SUB with the dimensions DIMS.
 
@@ -464,12 +388,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Function types.
 
-;; Arguments.
-
-(defstruct (argument (:constructor make-argument (name type)) (:type list))
-  "Simple list structure representing a function argument."
-  name
-  type)
+;; Function arguments.
 
 (defun arguments-lists-equal-p (list-a list-b)
   "Return whether LIST-A and LIST-B match.
@@ -484,37 +403,9 @@
 				    (argument-type arg-b))))
 	      list-a list-b)))
 
-(defgeneric commentify-argument-name (name)
-  (:documentation
-   "Produce a `commentified' version of the argument.
-
-   The default behaviour is that temporary argument names are simply omitted
-   (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
-   printable representation of the argument.")
-  (:method ((name null)) nil)
-  (:method ((name t)) (format nil "/*~A*/" name)))
-
-(defun commentify-argument-names (arguments)
-  "Return an argument list with the arguments commentified.
-
-   That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
-  (mapcar (lambda (arg)
-	    (if (eq arg :ellipsis)
-		arg
-		(make-argument (commentify-argument-name (argument-name arg))
-			       (argument-type arg))))
-	  arguments))
-
-(defun commentify-function-type (type)
-  "Return a type like TYPE, but with arguments commentified.
-
-   This doesn't recurse into the return type or argument types."
-  (make-function-type (c-type-subtype type)
-		      (commentify-argument-names
-		       (c-function-arguments type))))
-
-;; Definitions.
+;; Class definition.
 
+(export '(c-function-type c-function-arguments))
 (defclass c-function-type (c-type)
   ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
    (arguments :initarg :arguments :type list :reader c-function-arguments))
@@ -522,28 +413,22 @@
    "C function types.  The subtype is the return type, as implied by the C
     syntax for function declarations."))
 
+;; Constructor function.
+
+(export 'make-function-type)
 (defun make-function-type (subtype arguments)
   "Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
   (make-instance 'c-function-type :subtype subtype :arguments arguments))
 
-(defmethod c-type-equal-p and ((type-a c-function-type)
-			       (type-b c-function-type))
-  (and (c-type-equal-p (c-type-subtype type-a)
-		       (c-type-subtype type-b))
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and
+    ((type-a c-function-type) (type-b c-function-type))
+  (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
        (arguments-lists-equal-p (c-function-arguments type-a)
 				(c-function-arguments type-b))))
 
-(defmethod print-c-type
-    (stream (type c-function-type) &optional colon atsign)
-  (declare (ignore colon atsign))
-  (format stream
-	  #.(concatenate 'string
-			 "~:@<"
-			 "FUN ~@_~:I~/sod::print-c-type/"
-			 "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}"
-			 "~:>")
-	  (c-type-subtype type)
-	  (c-function-arguments type)))
+;; C syntax output protocol.
 
 (defmethod pprint-c-type ((type c-function-type) stream kernel)
   (pprint-c-type (c-type-subtype type) stream
@@ -552,7 +437,6 @@
 		     (when spacep (c-type-space stream))
 		     (funcall kernel stream 2 nil)
 		     (pprint-indent :block 4 stream)
-		     ;;(pprint-newline :miser stream)
 		     (pprint-logical-block
 			 (stream nil :prefix "(" :suffix ")")
 		       (let ((firstp t))
@@ -566,8 +450,23 @@
 					      stream
 					      (argument-name arg))))))))))
 
-;; S-expression syntax.
+;; S-expression notation protocol.
+
+(defmethod print-c-type
+    (stream (type c-function-type) &optional colon atsign)
+  (declare (ignore colon atsign))
+  (format stream "~:@<~
+		  FUN ~@_~:I~/sod:print-c-type/~
+		  ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~
+		  ~:>"
+	  (c-type-subtype type)
+	  (mapcar (lambda (arg)
+		    (if (eq arg :ellipsis)
+			arg
+			(list (argument-name arg) (argument-type arg))))
+		  (c-function-arguments type))))
 
+(export '(fun function func fn))
 (define-c-type-syntax fun (ret &rest args)
   "Return the type of functions which returns RET and has arguments ARGS.
 
@@ -597,8 +496,34 @@
 			    ((or (atom args) (atom (car args)))
 			     (cond ((and (null args) (null list)) `nil)
 				   ((null args) `(list ,@(nreverse list)))
+				   ((and (consp args)
+					 (eq (car args) :ellipsis))
+				    `(list ,@(nreverse list) :ellipsis))
 				   ((null list) `,args)
 				   (t `(list* ,@(nreverse list) ,args)))))))
 (c-type-alias fun function () func fn)
 
+;; Additional utilities for dealing with functions.
+
+(export 'commentify-argument-names)
+(defun commentify-argument-names (arguments)
+  "Return an argument list with the arguments commentified.
+
+   That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
+  (mapcar (lambda (arg)
+	    (if (eq arg :ellipsis)
+		arg
+		(make-argument (commentify-argument-name (argument-name arg))
+			       (argument-type arg))))
+	  arguments))
+
+(export 'commentify-function-type)
+(defun commentify-function-type (type)
+  "Return a type like TYPE, but with arguments commentified.
+
+   This doesn't recurse into the return type or argument types."
+  (make-function-type (c-type-subtype type)
+		      (commentify-argument-names
+		       (c-function-arguments type))))
+
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/cpl.lisp b/src/impl-class-finalize.lisp
similarity index 59%
rename from cpl.lisp
rename to src/impl-class-finalize.lisp
index 041e8e7..6193836 100644
--- a/cpl.lisp
+++ b/src/impl-class-finalize.lisp
@@ -1,13 +1,13 @@
 ;;; -*-lisp-*-
 ;;;
-;;; Computing class precedence lists
+;;; Class finalization implementation
 ;;;
 ;;; (c) 2009 Straylight/Edgeware
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Simple Object Definition system.
+;;; This file is part of the Sensble Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -26,10 +26,10 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
-;;; Linearizations.
+;;; Class precedence lists.
 
-;; Just for fun, we implement a wide selection.  C3 seems to be clearly the
-;; best, with fewer sharp edges for the unwary.
+;; Just for fun, we implement a wide selection of precedence list algorithms.
+;; C3 seems to be clearly the best, with fewer sharp edges for the unwary.
 ;;
 ;; The extended precedence graph (EPG) is constructed by adding edges to the
 ;; superclass graph.  If A and B are classes, then write A < B if A is a
@@ -48,6 +48,8 @@
 ;; Superclass Linearization for Dylan' for more detail.
 ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
 
+;;; Tiebreaker functions.
+
 (defun clos-tiebreaker (candidates so-far)
   "The CLOS linearization tiebreaker function.
 
@@ -68,6 +70,36 @@
       (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
     winner))
 
+(defun c3-tiebreaker (candidates cpls)
+  "The C3 linearization tiebreaker function.
+
+   Intended for use with MERGE-LISTS.  Returns the member of CANDIDATES which
+   appears in the earliest element of CPLS, which should be the list of the
+   class precedence lists of the direct superclasses of the class in
+   question, in the order specified in the class declaration.
+
+   The only class in the class precedence list which does not appear in one
+   of these lists is the new class itself, which must precede all of the
+   others.
+
+   This must disambiguate, since if two classes are in the same class
+   precedence list, then one must appear in it before the other, which
+   provides an ordering between them.  (In this situation we return the one
+   that matches earliest anyway, which would still give the right answer.)
+
+   Note that this will merge the CPLs of superclasses /as they are/, not
+   necessarily as C3 would have computed them.  This ensures monotonicity
+   assuming that the superclass CPLs are already monotonic.  If they aren't,
+   you're going to lose anyway."
+
+  (dolist (cpl cpls)
+    (dolist (candidate candidates)
+      (when (member candidate cpl)
+	(return-from c3-tiebreaker candidate))))
+  (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
+
+;;; Linearization functions.
+
 (defun clos-cpl (class)
   "Compute the class precedence list of CLASS using CLOS linearization rules.
 
@@ -113,34 +145,6 @@
 		       (mapcar #'sod-class-precedence-list direct-supers))
 		 :pick #'clos-tiebreaker)))
 
-(defun c3-tiebreaker (candidates cpls)
-  "The C3 linearization tiebreaker function.
-
-   Intended for use with MERGE-LISTS.  Returns the member of CANDIDATES which
-   appears in the earliest element of CPLS, which should be the list of the
-   class precedence lists of the direct superclasses of the class in
-   question, in the order specified in the class declaration.
-
-   The only class in the class precedence list which does not appear in one
-   of these lists is the new class itself, which must precede all of the
-   others.
-
-   This must disambiguate, since if two classes are in the same class
-   precedence list, then one must appear in it before the other, which
-   provides an ordering between them.  (In this situation we return the one
-   that matches earliest anyway, which would still give the right answer.)
-
-   Note that this will merge the CPLs of superclasses /as they are/, not
-   necessarily as C3 would have computed them.  This ensures monotonicity
-   assuming that the superclass CPLs are already monotonic.  If they aren't,
-   you're going to lose anyway."
-
-  (dolist (cpl cpls)
-    (dolist (candidate candidates)
-      (when (member candidate cpl)
-	(return-from c3-tiebreaker candidate))))
-  (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
-
 (defun c3-cpl (class)
   "Compute the class precedence list of CLASS using C3 linearization rules.
 
@@ -222,12 +226,7 @@
 				       (when (member class candidates)
 					 (return class))))))))
 
-;;;--------------------------------------------------------------------------
-;;; Class protocol.
-
-(defgeneric compute-cpl (class)
-  (:documentation
-   "Returns the class precedence list for CLASS."))
+;;; Default function.
 
 (defmethod compute-cpl ((class sod-class))
   (handler-case (c3-cpl class)
@@ -236,98 +235,166 @@
 	     (sod-class-name class)))))
 
 ;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(progn
-  (defclass test-class ()
-    ((name :initarg :name :accessor sod-class-name)
-     (direct-superclasses :initarg :superclasses
-			  :accessor sod-class-direct-superclasses)
-     (class-precedence-list)))
-
-  (defmethod print-object ((class test-class) stream)
-    (if *print-escape*
-	(print-unreadable-object (class stream :type t :identity nil)
-	  (princ (sod-class-name class) stream))
-	(princ (sod-class-name class) stream)))
-
-  (defvar *test-linearization*)
-
-  (defmethod sod-class-precedence-list ((class test-class))
-    (if (slot-boundp class 'class-precedence-list)
-	(slot-value class 'class-precedence-list)
-	(setf (slot-value class 'class-precedence-list)
-	      (funcall *test-linearization* class)))))
-
-#+test
-(defun test-cpl (linearization heterarchy)
-  (let* ((*test-linearization* linearization)
-	 (classes (make-hash-table :test #'equal)))
-    (dolist (class heterarchy)
-      (let ((name (car class)))
-	(setf (gethash (car class) classes)
-	      (make-instance 'test-class :name name))))
-    (dolist (class heterarchy)
-      (setf (sod-class-direct-superclasses (gethash (car class) classes))
-	    (mapcar (lambda (super) (gethash super classes)) (cdr class))))
-    (mapcar (lambda (class)
-	      (handler-case
-		  (mapcar #'sod-class-name
-			  (sod-class-precedence-list (gethash (car class)
-							      classes)))
-		(inconsistent-merge-error ()
-		  (list (car class) :error))))
-	    heterarchy)))
-
-#+test
-(progn
-  (defparameter *confused-heterarchy*
-    '((object) (grid-layout object)
-      (horizontal-grid grid-layout) (vertical-grid grid-layout)
-      (hv-grid horizontal-grid vertical-grid)
-      (vh-grid vertical-grid horizontal-grid)
-      (confused-grid hv-grid vh-grid)))
-  (defparameter *boat-heterarchy*
-    '((object)
-      (boat object)
-      (day-boat boat)
-      (wheel-boat boat)
-      (engine-less day-boat)
-      (small-multihull day-boat)
-      (pedal-wheel-boat engine-less wheel-boat)
-      (small-catamaran small-multihull)
-      (pedalo pedal-wheel-boat small-catamaran)))
-  (defparameter *menu-heterarchy*
-    '((object)
-      (choice-widget object)
-      (menu choice-widget)
-      (popup-mixin object)
-      (popup-menu menu popup-mixin)
-      (new-popup-menu menu popup-mixin choice-widget)))
-  (defparameter *pane-heterarchy*
-    '((pane) (scrolling-mixin) (editing-mixin)
-      (scrollable-pane pane scrolling-mixin)
-      (editable-pane pane editing-mixin)
-      (editable-scrollable-pane scrollable-pane editable-pane)))
-  (defparameter *baker-nonmonotonic-heterarchy*
-    '((z) (x z) (y) (b y) (a b x) (c a b x y)))
-  (defparameter *baker-nonassociative-heterarchy*
-    '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
-  (defparameter *distinguishing-heterarchy*
-    '((object)
-      (a object) (b object) (c object)
-      (p a b) (q a c)
-      (u p) (v q)
-      (x u v)
-      (y x b c)
-      (z x c b)))
-  (defparameter *python-heterarchy*
-    '((object)
-      (a object) (b object) (c object) (d object) (e object)
-      (k1 a b c)
-      (k2 d b e)
-      (k3 d a)
-      (z k1 k2 k3))))
+;;; Chains.
+
+(defmethod compute-chains ((class sod-class))
+  (with-default-error-location (class)
+    (with-slots (chain-link class-precedence-list) class
+      (let* ((head (if chain-link
+		       (sod-class-chain-head chain-link)
+		       class))
+	     (chain (cons class (and chain-link
+				     (sod-class-chain chain-link))))
+	     (table (make-hash-table)))
+
+	;; Check the chains.  We work through each superclass, maintaining a
+	;; hash table keyed by class.  If we encounter a class C which links
+	;; to L, then we store C as L's value; if L already has a value then
+	;; we've found an error.  By the end of all of this, the classes
+	;; which don't have an entry are the chain tails.
+	(dolist (super class-precedence-list)
+	  (let ((link (sod-class-chain-link super)))
+	    (when link
+	      (when (gethash link table)
+		(error "Conflicting chains in class ~A: ~
+			(~A and ~A both link to ~A)"
+		       class super (gethash link table) link))
+	      (setf (gethash link table) super))))
+
+	;; Done.
+	(values head chain
+		(cons chain
+		      (mapcar #'sod-class-chain
+			      (remove-if (lambda (super)
+					   (gethash super table))
+					 (cdr class-precedence-list)))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Sanity checking.
+
+(defmethod check-sod-class ((class sod-class))
+  (with-default-error-location (class)
+
+    ;; Check the names of things are valid.
+    (with-slots (name nickname messages) class
+      (unless (valid-name-p name)
+	(error "Invalid class name `~A'" class))
+      (unless (valid-name-p nickname)
+	(error "Invalid class nickname `~A' on class `~A'" nickname class))
+      (dolist (message messages)
+	(unless (valid-name-p (sod-message-name message))
+	  (error "Invalid message name `~A' on class `~A'"
+		 (sod-message-name message) class))))
+
+    ;; Check that the slots and messages have distinct names.
+    (with-slots (slots messages class-precedence-list) class
+      (flet ((check-list (list what namefunc)
+	       (let ((table (make-hash-table :test #'equal)))
+		 (dolist (item list)
+		   (let ((name (funcall namefunc item)))
+		     (if (gethash name table)
+			 (error "Duplicate ~A name `~A' on class `~A'"
+				what name class)
+			 (setf (gethash name table) item)))))))
+	(check-list slots "slot" #'sod-slot-name)
+	(check-list messages "message" #'sod-message-name)
+	(check-list class-precedence-list "nickname" #'sod-class-name)))
+
+    ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
+    ;; eliminates hairy things like a class being its own link.)
+    (with-slots (class-precedence-list chain-link) class
+      (unless (or (not chain-link)
+		  (member chain-link (cdr class-precedence-list)))
+	(error "In `~A~, chain-to class `~A' is not a proper superclass"
+	       class chain-link)))
+
+    ;; Check for circularity in the superclass graph.  Since the superclasses
+    ;; should already be acyclic, it suffices to check that our class is not
+    ;; a superclass of any of its own direct superclasses.
+    (let ((circle (find-if (lambda (super)
+			     (sod-subclass-p super class))
+			   (sod-class-direct-superclasses class))))
+      (when circle
+	(error "Circularity: ~A is already a superclass of ~A"
+	       class circle)))
+
+    ;; Check that the class has a unique root superclass.
+    (find-root-superclass class)
+
+    ;; Check that the metaclass is a subclass of each direct superclass's
+    ;; metaclass.
+    (with-slots (metaclass direct-superclasses) class
+      (dolist (super direct-superclasses)
+	(unless (sod-subclass-p metaclass (sod-class-metaclass super))
+	  (error "Incompatible metaclass for `~A': ~
+		  `~A' isn't a subclass of `~A' (of `~A')"
+		 class metaclass (sod-class-metaclass super) super))))))
+
+;;;--------------------------------------------------------------------------
+;;; Finalization.
+
+(defmethod finalize-sod-class ((class sod-class))
+
+  ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
+  ;; clone of the CPL and chain establishment code.  If the interface changes
+  ;; then BOOTSTRAP-CLASSES will need to be changed too.
+
+  (with-default-error-location (class)
+    (ecase (sod-class-state class)
+      ((nil)
+
+       ;; If this fails, mark the class as a loss.
+       (setf (sod-class-state class) :broken)
+
+       ;; Finalize all of the superclasses.  There's some special pleading
+       ;; here to make bootstrapping work: we don't try to finalize the
+       ;; metaclass if we're a root class (no direct superclasses -- because
+       ;; in that case the metaclass will have to be a subclass of us!), or
+       ;; if it's equal to us.  This is enough to tie the knot at the top of
+       ;; the class graph.
+       (with-slots (name direct-superclasses metaclass) class
+	 (dolist (super direct-superclasses)
+	   (finalize-sod-class super))
+	 (unless (or (null direct-superclasses)
+		     (eq class metaclass))
+	   (finalize-sod-class metaclass)))
+
+       ;; Stash the class's type.
+       (setf (sod-class-type class)
+	     (make-class-type (sod-class-name class)))
+
+       ;; Clobber the lists of items if they've not been set.
+       (dolist (slot '(slots instance-initializers class-initializers
+		       messages methods))
+	 (unless (slot-boundp class slot)
+	   (setf (slot-value class slot) nil)))
+
+       ;; If the CPL hasn't been done yet, compute it.
+       (with-slots (class-precedence-list) class
+	 (unless (slot-boundp class 'class-precedence-list)
+	   (setf class-precedence-list (compute-cpl class))))
+
+       ;; Check that the class is fairly sane.
+       (check-sod-class class)
+
+       ;; Determine the class's layout.
+       (with-slots (chain-head chain chains) class
+	 (setf (values chain-head chain chains) (compute-chains class)))
+
+       ;; FIXME: make these slots autovivifying.
+       (with-slots (ilayout effective-methods vtables) class
+	 (setf ilayout (compute-ilayout class))
+	 (setf effective-methods (compute-effective-methods class))
+	 (setf vtables (compute-vtables class)))
+
+       ;; Done.
+       (setf (sod-class-state class) :finalized)
+       t)
+
+      (:broken
+       nil)
+
+      (:finalized
+       t))))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-class-layout.lisp b/src/impl-class-layout.lisp
new file mode 100644
index 0000000..4bff54d
--- /dev/null
+++ b/src/impl-class-layout.lisp
@@ -0,0 +1,395 @@
+;;; -*-lisp-*-
+;;;
+;;; Class layout protocol implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slots.
+
+(defmethod print-object ((slot effective-slot) stream)
+  (maybe-print-unreadable-object (slot stream :type t)
+    (format stream "~A~@[ = ~@_~A~]"
+	    (effective-slot-direct-slot slot)
+	    (effective-slot-initializer slot))))
+
+(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
+  (some (lambda (super)
+	  (find slot
+		(sod-class-instance-initializers super)
+		:key #'sod-initializer-slot))
+	(sod-class-precedence-list class)))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
+  (make-instance 'effective-slot
+		 :slot slot
+		 :class class
+		 :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Special-purpose slot objects.
+
+(export 'sod-class-slot)
+(defclass sod-class-slot (sod-slot)
+  ((initializer-function :initarg :initializer-function
+			 :type (or symbol function)
+			 :reader sod-slot-initializer-function)
+   (prepare-function :initarg :prepare-function :type (or symbol function)
+		     :reader sod-slot-prepare-function))
+  (:documentation
+   "Special class for slots defined on SodClass.
+
+   These slots need class-specific initialization.  It's easier to keep all
+   of the information (name, type, and how to initialize them) about these
+   slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+    ((slot sod-class-slot) slot-names &key pset)
+  (declare (ignore slot-names))
+  (default-slot (slot 'initializer-function)
+    (get-property pset :initializer-function t nil))
+  (default-slot (slot 'prepare-function)
+    (get-property pset :prepare-function t nil)))
+
+(export 'sod-class-effective-slot)
+(defclass sod-class-effective-slot (effective-slot)
+  ((initializer-function :initarg :initializer-function
+			 :type (or symbol function)
+			 :reader effective-slot-initializer-function)
+   (prepare-function :initarg :prepare-function :type (or symbol function)
+		     :reader effective-slot-prepare-function))
+  (:documentation
+   "Special class for slots defined on SodClass.
+
+   This class ignores any explicit initializers and computes initializer
+   values using the slot's INIT-FUNC slot and a magical protocol during
+   metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+  (make-instance 'sod-class-effective-slot
+		 :class class :slot slot
+		 :initializer-function (sod-slot-initializer-function slot)
+		 :prepare-function (sod-slot-prepare-function slot)
+		 :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods.
+
+(defmethod print-object ((method effective-method) stream)
+  (maybe-print-unreadable-object (method stream :type t)
+    (format stream "~A ~A"
+	    (effective-method-message method)
+	    (effective-method-class method))))
+
+(defmethod print-object ((entry method-entry) stream)
+  (maybe-print-unreadable-object (entry stream :type t)
+    (format stream "~A:~A"
+	    (method-entry-effective-method entry)
+	    (sod-class-nickname (method-entry-chain-head entry)))))
+
+(defmethod compute-sod-effective-method
+    ((message sod-message) (class sod-class))
+  (let ((direct-methods (mappend (lambda (super)
+				   (remove message
+					   (sod-class-methods super)
+					   :key #'sod-method-message
+					   :test-not #'eql))
+				(sod-class-precedence-list class))))
+    (make-instance (message-effective-method-class message)
+		   :message message
+		   :class class
+		   :direct-methods direct-methods)))
+
+(defmethod compute-effective-methods ((class sod-class))
+  (mapcan (lambda (super)
+	    (mapcar (lambda (message)
+		      (compute-sod-effective-method message class))
+		    (sod-class-messages super)))
+	  (sod-class-precedence-list class)))
+
+(defmethod slot-unbound
+    (clos-class (class sod-class) (slot-name (eql 'effective-methods)))
+  (setf (slot-value class 'effective-methods)
+	(compute-effective-methods class)))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout.
+
+;;; islots
+
+(defmethod print-object ((islots islots) stream)
+  (print-unreadable-object (islots stream :type t)
+    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+	    (islots-subclass islots)
+	    (islots-class islots)
+	    (islots-slots islots))))
+
+(defmethod compute-islots ((class sod-class) (subclass sod-class))
+  (make-instance 'islots
+		 :class class
+		 :subclass subclass
+		 :slots (mapcar (lambda (slot)
+				  (compute-effective-slot subclass slot))
+				(sod-class-slots class))))
+
+;;; vtable-pointer
+;;; Do we need a construction protocol here?
+
+(defmethod print-object ((vtp vtable-pointer) stream)
+  (print-unreadable-object (vtp stream :type t)
+    (format stream "~A:~A"
+	    (vtable-pointer-class vtp)
+	    (sod-class-nickname (vtable-pointer-chain-head vtp)))))
+
+;;; ichain
+
+(defmethod print-object ((ichain ichain) stream)
+  (print-unreadable-object (ichain stream :type t)
+    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+	    (ichain-class ichain)
+	    (sod-class-nickname (ichain-head ichain))
+	    (ichain-body ichain))))
+
+(defmethod compute-ichain ((class sod-class) chain)
+  (let* ((chain-head (car chain))
+	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+			   :key #'sod-class-chain-head))
+	 (vtable-pointer (make-instance 'vtable-pointer
+					:class class
+					:chain-head chain-head
+					:chain-tail chain-tail))
+	 (islots (remove-if-not #'islots-slots
+				(mapcar (lambda (super)
+					  (compute-islots super class))
+					chain))))
+    (make-instance 'ichain
+		   :class class
+		   :chain-head chain-head
+		   :chain-tail chain-tail
+		   :body (cons vtable-pointer islots))))
+
+;;; ilayout
+
+(defmethod print-object ((ilayout ilayout) stream)
+  (print-unreadable-object (ilayout stream :type t)
+    (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
+	    (ilayout-class ilayout)
+	    (ilayout-ichains ilayout))))
+
+(defmethod compute-ilayout ((class sod-class))
+  (make-instance 'ilayout
+		 :class class
+		 :ichains (mapcar (lambda (chain)
+				    (compute-ichain class
+						    (reverse chain)))
+				  (sod-class-chains class))))
+
+(defmethod slot-unbound
+    (clos-class (class sod-class) (slot-name (eql 'ilayout)))
+  (setf (slot-value class 'ilayout)
+	(compute-ilayout class)))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+(defmethod print-object ((vtmsgs vtmsgs) stream)
+  (print-unreadable-object (vtmsgs stream :type t)
+    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+	    (vtmsgs-subclass vtmsgs)
+	    (vtmsgs-class vtmsgs)
+	    (vtmsgs-entries vtmsgs))))
+
+(defmethod compute-vtmsgs
+    ((class sod-class)
+     (subclass sod-class)
+     (chain-head sod-class)
+     (chain-tail sod-class))
+  (flet ((make-entry (message)
+	   (let ((method (find message
+			       (sod-class-effective-methods subclass)
+			       :key #'effective-method-message)))
+	     (make-method-entry method chain-head chain-tail))))
+    (make-instance 'vtmsgs
+		   :class class
+		   :subclass subclass
+		   :chain-head chain-head
+		   :chain-tail chain-tail
+		   :entries (mapcar #'make-entry
+				    (sod-class-messages class)))))
+
+;;; class-pointer
+
+(defmethod print-object ((cptr class-pointer) stream)
+  (print-unreadable-object (cptr stream :type t)
+    (format stream "~A:~A"
+	    (class-pointer-metaclass cptr)
+	    (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
+
+(defmethod make-class-pointer
+    ((class sod-class) (chain-head sod-class)
+     (metaclass sod-class) (meta-chain-head sod-class))
+
+  ;; Slightly tricky.  We don't necessarily want a pointer to the metaclass,
+  ;; but to its most specific subclass on the given chain.  Fortunately, CL
+  ;; is good at this game.
+  (let* ((meta-chains (sod-class-chains metaclass))
+	 (meta-chain-tails (mapcar #'car meta-chains))
+	 (meta-chain-tail (find meta-chain-head meta-chain-tails
+				:key #'sod-class-chain-head)))
+    (make-instance 'class-pointer
+		   :class class
+		   :chain-head chain-head
+		   :metaclass meta-chain-tail
+		   :meta-chain-head meta-chain-head)))
+
+;;; base-offset
+
+(defmethod print-object ((boff base-offset) stream)
+  (print-unreadable-object (boff stream :type t)
+    (format stream "~A:~A"
+	    (base-offset-class boff)
+	    (sod-class-nickname (base-offset-chain-head boff)))))
+
+(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
+  (make-instance 'base-offset
+		 :class class
+		 :chain-head chain-head))
+
+;;; chain-offset
+
+(defmethod print-object ((choff chain-offset) stream)
+  (print-unreadable-object (choff stream :type t)
+    (format stream "~A:~A->~A"
+	    (chain-offset-class choff)
+	    (sod-class-nickname (chain-offset-chain-head choff))
+	    (sod-class-nickname (chain-offset-target-head choff)))))
+
+(defmethod make-chain-offset
+    ((class sod-class) (chain-head sod-class) (target-head sod-class))
+  (make-instance 'chain-offset
+		 :class class
+		 :chain-head chain-head
+		 :target-head target-head))
+
+;;; vtable
+
+(defmethod print-object ((vtable vtable) stream)
+  (print-unreadable-object (vtable stream :type t)
+    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+	    (vtable-class vtable)
+	    (sod-class-nickname (vtable-chain-head vtable))
+	    (vtable-body vtable))))
+
+;; Special variables used by `compute-vtable'.
+(defvar *done-metaclass-chains*)
+(defvar *done-instance-chains*)
+
+(defmethod compute-vtable-items
+    ((class sod-class) (super sod-class) (chain-head sod-class)
+     (chain-tail sod-class) (emit function))
+
+  ;; If this class introduces new metaclass chains, then emit pointers to
+  ;; them.
+  (let* ((metasuper (sod-class-metaclass super))
+	 (metasuper-chains (sod-class-chains metasuper))
+	 (metasuper-chain-heads (mapcar (lambda (chain)
+					  (sod-class-chain-head (car chain)))
+					metasuper-chains)))
+    (dolist (metasuper-chain-head metasuper-chain-heads)
+      (unless (member metasuper-chain-head *done-metaclass-chains*)
+	(funcall emit (make-class-pointer class
+					  chain-head
+					  metasuper
+					  metasuper-chain-head))
+	(push metasuper-chain-head *done-metaclass-chains*))))
+
+  ;; If there are new instance chains, then emit offsets to them.
+  (let* ((chains (sod-class-chains super))
+	 (chain-heads (mapcar (lambda (chain)
+				(sod-class-chain-head (car chain)))
+			      chains)))
+    (dolist (head chain-heads)
+      (unless (member head *done-instance-chains*)
+	(funcall emit (make-chain-offset class chain-head head))
+	(push head *done-instance-chains*))))
+
+  ;; Finally, if there are interesting methods, emit those too.
+  (when (sod-class-messages super)
+    (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
+
+(defmethod compute-vtable ((class sod-class) (chain list))
+  (let* ((chain-head (car chain))
+	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+			   :key #'sod-class-chain-head))
+	 (*done-metaclass-chains* nil)
+	 (*done-instance-chains* (list chain-head))
+	 (done-superclasses nil)
+	 (items nil))
+    (flet ((emit (item)
+	     (push item items)))
+
+      ;; Find the root chain in the metaclass and write a pointer.
+      (let* ((metaclass (sod-class-metaclass class))
+	     (metaclass-root (find-root-metaclass class))
+	     (metaclass-root-head (sod-class-chain-head metaclass-root)))
+	(emit (make-class-pointer class chain-head metaclass
+				  metaclass-root-head))
+	(push metaclass-root-head *done-metaclass-chains*))
+
+      ;; Write an offset to the instance base.
+      (emit (make-base-offset class chain-head))
+
+      ;; Now walk the chain.  As we ascend the chain, scan the class
+      ;; precedence list of each class in reverse to ensure that we have
+      ;; everything interesting.
+      (dolist (super chain)
+	(dolist (sub (reverse (sod-class-precedence-list super)))
+	  (unless (member sub done-superclasses)
+	    (compute-vtable-items class
+				  sub
+				  chain-head
+				  chain-tail
+				  #'emit)
+	    (push sub done-superclasses))))
+
+      ;; We're through.
+      (make-instance 'vtable
+		     :class class
+		     :chain-head chain-head
+		     :chain-tail chain-tail
+		     :body (nreverse items)))))
+
+(defmethod compute-vtables ((class sod-class))
+  (mapcar (lambda (chain)
+	    (compute-vtable class (reverse chain)))
+	  (sod-class-chains class)))
+
+(defmethod slot-unbound
+    (clos-class (class sod-class) (slot-name (eql 'vtables)))
+  (setf (slot-value class 'vtables)
+	(compute-vtables class)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-class-make.lisp b/src/impl-class-make.lisp
new file mode 100644
index 0000000..4470416
--- /dev/null
+++ b/src/impl-class-make.lisp
@@ -0,0 +1,240 @@
+;;; -*-lisp-*-
+;;;
+;;; Class construction protocol implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(defmethod guess-metaclass ((class sod-class))
+  "Default metaclass-guessing function for classes.
+
+   Return the most specific metaclass of any of the CLASS's direct
+   superclasses."
+  (do ((supers (sod-class-direct-superclasses class) (cdr supers))
+       (meta nil (let ((candidate (sod-class-metaclass (car supers))))
+		   (cond ((null meta) candidate)
+			 ((sod-subclass-p meta candidate) meta)
+			 ((sod-subclass-p candidate meta) candidate)
+			 (t (error "Unable to choose metaclass for `~A'"
+				   class))))))
+      ((endp supers) meta)))
+
+(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
+  "Specific behaviour for SOD class initialization.
+
+   Properties inspected are as follows:
+
+     * `:metaclass' names the metaclass to use.  If unspecified, nil is
+       stored, and (unless you intervene later) `guess-metaclass' will be
+       called by `finalize-sod-class' to find a suitable default.
+
+     * `:nick' provides a nickname for the class.  If unspecified, a default
+       (the class's name, forced to lowercase) will be chosen in
+       `finalize-sod-class'.
+
+     * `:link' names the chained superclass.  If unspecified, this class will
+       be left at the head of its chain."
+
+  ;; If no nickname, copy the class name.  It won't be pretty, though.
+  (default-slot-from-property (class 'nickname slot-names)
+      (pset :nick :id)
+    (string-downcase (slot-value class 'name)))
+
+  ;; If no metaclass, guess one in a (Lisp) class-specific way.
+  (default-slot-from-property (class 'metaclass slot-names)
+      (pset :metaclass :id meta (find-sod-class meta))
+    (guess-metaclass class))
+
+  ;; If no chain-link, then start a new chain here.
+  (default-slot-from-property (class 'chain-link slot-names)
+      (pset :link :id link (find-sod-class link))
+    nil))
+
+;;;--------------------------------------------------------------------------
+;;; Slots.
+
+(defmethod make-sod-slot
+    ((class sod-class) name type pset &optional location)
+  (with-default-error-location (location)
+    (let ((slot (make-instance (get-property pset :lisp-class :symbol
+					     'sod-slot)
+			       :class class
+			       :name name
+			       :type type
+			       :location (file-location location)
+			       :pset pset)))
+      (with-slots (slots) class
+	(setf slots (append slots (list slot))))
+      (check-unused-properties pset))))
+
+(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
+  "This method does nothing.
+
+   It only exists so that it isn't an error to provide a `:pset' initarg
+   to (make-instance 'sod-slot ...)."
+
+  (declare (ignore slot-names pset)))
+
+;;;--------------------------------------------------------------------------
+;;; Slot initializers.
+
+(defmethod make-sod-instance-initializer
+    ((class sod-class) nick name value-kind value-form pset
+     &optional location)
+  (with-default-error-location (location)
+    (let* ((slot (find-instance-slot-by-name class nick name))
+	   (initializer (make-sod-initializer-using-slot
+			 class slot 'sod-instance-initializer
+			 value-kind value-form pset
+			 (file-location location))))
+      (with-slots (instance-initializers) class
+	(setf instance-initializers
+	      (append instance-initializers (list initializer))))
+      (check-unused-properties pset))))
+
+(defmethod make-sod-class-initializer
+    ((class sod-class) nick name value-kind value-form pset
+     &optional location)
+  (with-default-error-location (location)
+    (let* ((slot (find-class-slot-by-name class nick name))
+	   (initializer (make-sod-initializer-using-slot
+			 class slot 'sod-class-initializer
+			 value-kind value-form pset
+			 (file-location location))))
+      (with-slots (class-initializers) class
+	(setf class-initializers
+	      (append class-initializers (list initializer))))
+      (check-unused-properties pset))))
+
+(defmethod make-sod-initializer-using-slot
+    ((class sod-class) (slot sod-slot)
+     init-class value-kind value-form pset location)
+  (make-instance (get-property pset :lisp-class :symbol init-class)
+		 :class class
+		 :slot slot
+		 :value-kind value-kind
+		 :value-form value-form
+		 :location location
+		 :pset pset))
+
+(defmethod shared-initialize :after
+    ((init sod-initializer) slot-names &key pset)
+  "This method does nothing.
+
+   It only exists so that it isn't an error to provide a `:pset' initarg
+   to (make-instance 'sod-initializer ...)."
+  (declare (ignore slot-names pset))
+  nil)
+
+;;;--------------------------------------------------------------------------
+;;; Messages.
+
+(defmethod make-sod-message
+    ((class sod-class) name type pset &optional location)
+  (with-default-error-location (location)
+    (let ((message (make-instance (get-property pset :lisp-class :symbol
+						'standard-message)
+				  :class class
+				  :name name
+				  :type type
+				  :location (file-location location)
+				  :pset pset)))
+      (with-slots (messages) class
+	(setf messages (append messages (list message))))
+      (check-unused-properties pset))))
+
+(defmethod shared-initialize :after
+    ((message sod-message) slot-names &key pset)
+  (declare (ignore slot-names pset))
+  (with-slots (type) message
+    (check-message-type message type)))
+
+(defmethod check-message-type ((message sod-message) (type c-function-type))
+  nil)
+
+(defmethod check-message-type ((message sod-message) (type c-type))
+  (error "Messages must have function type, not ~A" type))
+
+;;;--------------------------------------------------------------------------
+;;; Methods.
+
+(defmethod make-sod-method
+    ((class sod-class) nick name type body pset &optional location)
+  (with-default-error-location (location)
+    (let* ((message (find-message-by-name class nick name))
+	   (method (make-sod-method-using-message message class
+						  type body pset
+						  (file-location location))))
+      (with-slots (methods) class
+	(setf methods (append methods (list method)))))
+    (check-unused-properties pset)))
+
+(defmethod make-sod-method-using-message
+    ((message sod-message) (class sod-class) type body pset location)
+  (make-instance (or (get-property pset :lisp-class :symbol)
+		     (sod-message-method-class message class pset))
+		 :message message
+		 :class class
+		 :type type
+		 :body body
+		 :location location
+		 :pset pset))
+
+(defmethod sod-message-method-class
+    ((message sod-message) (class sod-class) pset)
+  (declare (ignore pset))
+  'sod-method)
+
+(defmethod shared-initialize :after
+    ((method sod-method) slot-names &key pset)
+  (declare (ignore slot-names pset))
+
+  ;; Check that the arguments are named if we have a method body.
+  (with-slots (body type) method
+    (unless (or (not body)
+		(every #'argument-name (c-function-arguments type)))
+      (error "Abstract declarators not permitted in method definitions")))
+
+  ;; Check the method type.
+  (with-slots (message type) method
+    (check-method-type method message type)))
+
+(defmethod check-method-type
+    ((method sod-method) (message sod-message) (type c-type))
+  (error "Methods must have function type, not ~A" type))
+
+(defmethod check-method-type
+    ((method sod-method) (message sod-message) (type c-function-type))
+  (with-slots ((msgtype type)) message
+    (unless (c-type-equal-p (c-type-subtype msgtype)
+			    (c-type-subtype type))
+      (error "Method return type ~A doesn't match message ~A"
+	      (c-type-subtype msgtype) (c-type-subtype type)))
+    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
+					 (c-function-arguments type))
+      (error "Method arguments ~A don't match message ~A" type msgtype))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-codegen.lisp b/src/impl-codegen.lisp
new file mode 100644
index 0000000..25413f8
--- /dev/null
+++ b/src/impl-codegen.lisp
@@ -0,0 +1,199 @@
+;;; -*-lisp-*-
+;;;
+;;; Code generation protocol implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Temporary names.
+
+(export '(temporary-argument temporary-function))
+(defclass temporary-argument (temporary-name) ())
+(defclass temporary-function (temporary-name) ())
+
+(export 'temporary-variable)
+(defclass temporary-variable (temporary-name)
+  ((in-use-p :initarg :in-use-p :initform nil
+	     :type boolean :accessor var-in-use-p)))
+
+(defmethod commentify-argument-name ((name temporary-name))
+  nil)
+
+(export 'temporary-function)
+(defun temporary-function ()
+  "Return a temporary function name."
+  (make-instance 'temporary-function
+		 :tag (prog1 *temporary-index* (incf *temporary-index*))))
+
+(defmethod format-temporary-name ((var temporary-name) stream)
+  (format stream "~A" (temp-tag var)))
+(defmethod format-temporary-name ((var temporary-argument) stream)
+  (format stream "sod__a~A" (temp-tag var)))
+(defmethod format-temporary-name ((var temporary-variable) stream)
+  (format stream "sod__v~A" (temp-tag var)))
+(defmethod format-temporary-name ((var temporary-function) stream)
+  (format stream "sod__f~A" (temp-tag var)))
+
+(defmethod print-object ((var temporary-name) stream)
+  (if *print-escape*
+      (print-unreadable-object (var stream :type t)
+	(prin1 (temp-tag var) stream))
+      (format-temporary-name var stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Instruction types.
+
+;; Compound statements.
+
+(export '(if-inst make-if-inst
+	  while-inst make-while-inst
+	  do-inst make-do-inst
+	  inst-condition inst-consequent inst-alternative inst-body))
+
+(definst if (stream) (condition consequent alternative)
+  (format-compound-statement (stream consequent alternative)
+    (format stream "if (~A)" condition))
+  (when alternative
+    (format-compound-statement (stream alternative)
+      (write-string "else" stream))))
+
+(definst while (stream) (condition body)
+  (format-compound-statement (stream body)
+    (format stream "while (~A)" condition)))
+
+(definst do-while (stream) (body condition)
+  (format-compound-statement (stream body :space)
+    (write-string "do" stream))
+  (format stream "while (~A);" condition))
+
+;; Special varargs hacks.
+
+(export '(va-start-inst make-va-start-inst
+	  va-copy-inst make-va-copy-inst
+	  va-end-inst make-va-end-inst
+	  inst-ap inst-arg inst-to inst-from))
+
+(definst va-start (stream) (ap arg)
+  (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
+
+(definst va-copy (stream) (to from)
+  (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
+
+(definst va-end (stream) (ap)
+  (format stream "va_end(~A);" ap))
+
+;; Expressions.
+
+(export '(call-inst make-call-inst inst-func inst-args))
+
+(definst call (stream) (func args)
+  (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
+
+;;;--------------------------------------------------------------------------
+;;; Code generator objects.
+
+(defclass basic-codegen ()
+  ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
+   (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
+   (temp-index :initarg :temp-index :initform 0
+	       :type fixnum :accessor codegen-temp-index))
+  (:documentation
+   "Base class for code generator state.
+
+   This contains the bare essentials for supporting the EMIT-INST and
+   ENSURE-VAR protocols; see the documentation for those generic functions
+   for more details.
+
+   This class isn't abstract.  A full CODEGEN object uses instances of this
+   to keep track of pending functions which haven't been completed yet.
+
+   Just in case that wasn't clear enough: this is nothing to do with the
+   BASIC language."))
+
+(defmethod emit-inst ((codegen basic-codegen) inst)
+  (push inst (codegen-insts codegen)))
+
+(defmethod emit-insts ((codegen basic-codegen) insts)
+  (asetf (codegen-insts codegen) (revappend insts it)))
+
+(defmethod ensure-var ((codegen basic-codegen) name type &optional init)
+  (let* ((vars (codegen-vars codegen))
+	 (var (find name vars :key #'inst-name :test #'equal)))
+    (cond ((not var)
+	   (setf (codegen-vars codegen)
+		 (cons (make-var-inst name type init) vars)))
+	  ((not (c-type-equal-p type (inst-type var)))
+	   (error "(Internal) Redefining type for variable ~A." name)))
+    name))
+
+(export 'codegen)
+(defclass codegen (basic-codegen)
+  ((functions :initform nil :type list :accessor codegen-functions)
+   (stack :initform nil :type list :accessor codegen-stack))
+  (:documentation
+   "A full-fat code generator which can generate and track functions.
+
+   This is the real deal.  Subclasses may which to attach additional state
+   for convenience's sake, but this class is self-contained.  It supports the
+   CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
+
+(defmethod codegen-push ((codegen codegen))
+  (with-slots (vars insts temp-index stack) codegen
+    (push (make-instance 'basic-codegen
+			 :vars vars
+			 :insts insts
+			 :temp-index temp-index)
+	  stack)
+    (setf vars nil insts nil temp-index 0)))
+
+(defmethod codegen-pop ((codegen codegen))
+  (with-slots (vars insts temp-index stack) codegen
+    (multiple-value-prog1
+	(values (nreverse vars) (nreverse insts))
+      (let ((sub (pop stack)))
+	(setf vars (codegen-vars sub)
+	      insts (codegen-insts sub)
+	      temp-index (codegen-temp-index sub))))))
+
+(defmethod codegen-add-function ((codegen codegen) function)
+  (with-slots (functions) codegen
+    (setf functions (nconc functions (list function)))))
+
+(defmethod temporary-var ((codegen basic-codegen) type)
+  (with-slots (vars temp-index) codegen
+    (or (some (lambda (var)
+		(let ((name (inst-name var)))
+		  (if (and (not (var-in-use-p name))
+			   (c-type-equal-p type (inst-type var)))
+		      name
+		      nil)))
+	      vars)
+	(let* ((name (make-instance 'temporary-variable
+				    :in-use-p t
+				    :tag (prog1 temp-index
+					   (incf temp-index)))))
+	  (push (make-var-inst name type nil) vars)
+	  name))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-lexer.lisp b/src/impl-lexer.lisp
new file mode 100644
index 0000000..9f9d31e
--- /dev/null
+++ b/src/impl-lexer.lisp
@@ -0,0 +1,297 @@
+;;; -*-lisp-*-
+;;;
+;;; Implementation of lexical analysis protocol.
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Basic lexical analyser.
+
+(defstruct (pushed-token
+	     (:constructor make-pushed-token (type value location)))
+  "A token that has been pushed back into a lexer for later processing."
+  type value location)
+
+;;; Class definition.
+
+(export 'basic-lexer)
+(defclass basic-lexer ()
+  ((stream :initarg :stream :type stream :reader lexer-stream)
+   (char :initform nil :type (or character null) :reader lexer-char)
+   (pushback-chars :initform nil :type list)
+   (token-type :initform nil :accessor token-type)
+   (token-value :initform nil :accessor token-value)
+   (location :initform nil :reader file-location)
+   (pushback-tokens :initform nil :type list))
+  (:documentation
+   "Base class for lexical analysers.
+
+   The lexer reads characters from STREAM, which, for best results, wants to
+   be a POSITION-AWARE-INPUT-STREAM.
+
+   The lexer provides one-character lookahead by default: the current
+   lookahead character is available to subclasses in the slot CHAR.  Before
+   beginning lexical analysis, the lookahead character needs to be
+   established with NEXT-CHAR.  If one-character lookahead is insufficient,
+   the analyser can push back an arbitrary number of characters using
+   PUSHBACK-CHAR.
+
+   The NEXT-TOKEN function scans and returns the next token from the STREAM,
+   and makes it available as TOKEN-TYPE and TOKEN-VALUE, providing one-token
+   lookahead.  A parser using the lexical analyser can push back tokens using
+   PUSHBACK-TOKENS.
+
+   For convenience, the lexer implements a FILE-LOCATION method (delegated to
+   the underlying stream)."))
+
+;;; Reading and pushing back characters.
+
+(defmethod next-char ((lexer basic-lexer))
+  (with-slots (stream char pushback-chars) lexer
+    (setf char (if pushback-chars
+		   (pop pushback-chars)
+		   (read-char stream nil)))))
+
+(defmethod pushback-char ((lexer basic-lexer) new-char)
+  (with-slots (char pushback-chars) lexer
+    (push char pushback-chars)
+    (setf char new-char)))
+
+(defmethod fixup-stream* ((lexer basic-lexer) thunk)
+  (with-slots (stream char pushback-chars) lexer
+    (when pushback-chars
+      (error "Lexer has pushed-back characters."))
+    (when (slot-boundp lexer 'char)
+      (unread-char char stream))
+    (unwind-protect
+	 (funcall thunk stream)
+      (setf char (read-char stream nil)))))
+
+;;; Reading and pushing back tokens.
+
+(defmethod next-token :around ((lexer basic-lexer))
+  (unless (slot-boundp lexer 'char)
+    (next-char lexer)))
+
+(defmethod next-token ((lexer basic-lexer))
+  (with-slots (pushback-tokens token-type token-value location) lexer
+    (setf (values token-type token-value)
+	  (if pushback-tokens
+	      (let ((pushback (pop pushback-tokens)))
+		(setf location (pushed-token-location pushback))
+		(values (pushed-token-type pushback)
+			(pushed-token-value pushback)))
+	      (scan-token lexer)))))
+
+(defmethod scan-token :around ((lexer basic-lexer))
+  (with-default-error-location (lexer)
+    (call-next-method)))
+
+(defmethod pushback-token ((lexer basic-lexer) new-token-type
+			   &optional new-token-value new-location)
+  (with-slots (pushback-tokens token-type token-value location) lexer
+    (push (make-pushed-token token-type token-value location)
+	  pushback-tokens)
+    (when new-location (setf location new-location))
+    (setf token-type new-token-type
+	  token-value new-token-value)))
+
+;;; Utilities.
+
+(defmethod skip-spaces ((lexer basic-lexer))
+  (do ((ch (lexer-char lexer) (next-char lexer)))
+      ((not (whitespace-char-p ch)) ch)))
+
+;;;--------------------------------------------------------------------------
+;;; Our main lexer.
+
+(export 'sod-lexer)
+(defclass sod-lexer (basic-lexer)
+  ()
+  (:documentation
+   "Lexical analyser for the SOD lanuage.
+
+   See the LEXER class for the gory details about the lexer protocol."))
+
+(defmethod scan-token ((lexer sod-lexer))
+  (with-slots (stream char keywords location) lexer
+    (prog (ch)
+
+     consider
+
+       ;; Stash the position of this token so that we can report it later.
+       (setf ch (skip-spaces lexer)
+	     location (file-location stream))
+
+       ;; Now work out what it is that we're dealing with.
+       (cond
+
+	 ;; End-of-file brings its own peculiar joy.
+	 ((null ch) (return (values :eof t)))
+
+	 ;; Strings.
+	 ((or (char= ch #\") (char= ch #\'))
+	  (let* ((quote ch)
+		 (string
+		  (with-output-to-string (out)
+		    (loop
+		      (flet ((getch ()
+			       (setf ch (next-char lexer))
+			       (when (null ch)
+				 (cerror* "Unexpected end of file in ~
+					   ~:[string~;character~] constant"
+					  (char= quote #\'))
+				 (return))))
+			(getch)
+			(cond ((char= ch quote) (return))
+			      ((char= ch #\\) (getch)))
+			(write-char ch out))))))
+	    (setf ch (next-char lexer))
+	    (ecase quote
+	      (#\" (return (values :string string)))
+	      (#\' (case (length string)
+		     (0 (cerror* "Empty character constant")
+			(return (values :char #\?)))
+		     (1 (return (values :char (char string 0))))
+		     (t (cerror* "Multiple characters in character constant")
+			(return (values :char (char string 0)))))))))
+
+	 ;; Pick out identifiers and keywords.
+	 ((or (alpha-char-p ch) (char= ch #\_))
+
+	  ;; Scan a sequence of alphanumerics and underscores.  We could
+	  ;; allow more interesting identifiers, but it would damage our C
+	  ;; lexical compatibility.
+	  (let ((id (with-output-to-string (out)
+		      (loop
+			(write-char ch out)
+			(setf ch (next-char lexer))
+			(when (or (null ch)
+				  (not (or (alphanumericp ch)
+					   (char= ch #\_))))
+			  (return))))))
+
+	    ;; Done.
+	    (return (values :id id))))
+
+	 ;; Pick out numbers.  Currently only integers, but we support
+	 ;; multiple bases.
+	 ((digit-char-p ch)
+
+	  ;; Sort out the prefix.  If we're looking at `0b', `0o' or `0x'
+	  ;; (maybe uppercase) then we've got a funny radix to deal with.
+	  ;; Otherwise, a leading zero signifies octal (daft, I know), else
+	  ;; we're left with decimal.
+	  (multiple-value-bind (radix skip-char)
+	      (if (char/= ch #\0)
+		  (values 10 nil)
+		  (case (and (setf ch (next-char lexer))
+			     (char-downcase ch))
+		    (#\b (values 2 t))
+		    (#\o (values 8 t))
+		    (#\x (values 16 t))
+		    (t (values 8 nil))))
+
+	    ;; If we last munched an interesting letter, we need to skip over
+	    ;; it.  That's what the SKIP-CHAR flag is for.
+	    ;;
+	    ;; Danger, Will Robinson!  If we're just about to eat a radix
+	    ;; letter, then the next thing must be a digit.  For example,
+	    ;; `0xfatenning' parses as a hex number followed by an identifier
+	    ;; `0xfa ttening', but `0xturning' is an octal number followed by
+	    ;; an identifier `0 xturning'.
+	    (when skip-char
+	      (let ((peek (next-char lexer)))
+		(unless (digit-char-p peek radix)
+		  (pushback-char lexer ch)
+		  (return-from scan-token (values :integer 0)))
+		(setf ch peek)))
+
+	    ;; Scan an integer.  While there are digits, feed them into the
+	    ;; accumulator.
+	    (do ((accum 0 (+ (* accum radix) digit))
+		 (digit (and ch (digit-char-p ch radix))
+			(and ch (digit-char-p ch radix))))
+		((null digit) (return-from scan-token
+				(values :integer accum)))
+	      (setf ch (next-char lexer)))))
+
+	 ;; A slash might be the start of a comment.
+	 ((char= ch #\/)
+	  (setf ch (next-char lexer))
+	  (case ch
+
+	    ;; Comment up to the end of the line.
+	    (#\/
+	     (loop
+	       (setf ch (next-char lexer))
+	       (when (or (null ch) (char= ch #\newline))
+		 (go scan))))
+
+	    ;; Comment up to the next `*/'.
+	    (#\*
+	     (tagbody
+	      top
+		(case (setf ch (next-char lexer))
+		  (#\* (go star))
+		  ((nil) (go done))
+		  (t (go top)))
+	      star
+		(case (setf ch (next-char lexer))
+		  (#\* (go star))
+		  (#\/ (setf ch (next-char lexer))
+		       (go done))
+		  ((nil) (go done))
+		  (t (go top)))
+	      done)
+	     (go consider))
+
+	    ;; False alarm.  (The next character is already set up.)
+	    (t
+	     (return (values #\/ t)))))
+
+	 ;; A dot: might be `...'.  Tread carefully!  We need more lookahead
+	 ;; than is good for us.
+	 ((char= ch #\.)
+	  (setf ch (next-char lexer))
+	  (cond ((eql ch #\.)
+		 (setf ch (next-char lexer))
+		 (cond ((eql ch #\.) (return (values :ellipsis nil)))
+		       (t (pushback-char lexer #\.)
+			  (return (values #\. t)))))
+		(t
+		 (return (values #\. t)))))
+
+	 ;; Anything else is a lone delimiter.
+	 (t
+	  (return (multiple-value-prog1
+		      (values ch t)
+		    (next-char lexer)))))
+
+     scan
+       ;; Scan a new character and try again.
+       (setf ch (next-char lexer))
+       (go consider))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/methods.lisp b/src/impl-method.lisp
similarity index 53%
rename from methods.lisp
rename to src/impl-method.lisp
index b54887a..a1e2a65 100644
--- a/methods.lisp
+++ b/src/impl-method.lisp
@@ -1,13 +1,13 @@
 ;;; -*-lisp-*-
 ;;;
-;;; Infrastructure for effective method generation
+;;; Method combination implementation
 ;;;
 ;;; (c) 2009 Straylight/Edgeware
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Simple Object Definition system.
+;;; This file is part of the Sensble Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -26,55 +26,9 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
-;;; Function type protocol.
-
-(defgeneric sod-message-argument-tail (message)
-  (:documentation
-   "Return the argument tail for the message, with invented argument names.
-
-   No `me' argument is prepended; any :ELLIPSIS is left as it is."))
-
-(defgeneric sod-message-no-varargs-tail (message)
-  (:documentation
-   "Return the argument tail for the message with :ELLIPSIS substituted.
-
-   As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
-   However, an :ELLIPSIS is replaced by an argument of type `va_list', named
-   `sod__ap'."))
-
-(defgeneric sod-method-function-type (method)
-  (:documentation
-   "Return the C function type for the direct method.
-
-   This is called during initialization of a direct method object, and the
-   result is cached.
-
-   A default method is provided (by BASIC-DIRECT-METHOD) which simply
-   prepends an appropriate `me' argument to the user-provided argument list.
-   Fancy method classes may need to override this behaviour."))
-
-(defgeneric sod-method-next-method-type (method)
-  (:documentation
-   "Return the C function type for the next-method trampoline.
-
-   This is called during initialization of a direct method object, and the
-   result is cached.  It should return a function type, not a pointer type.
-
-   A default method is provided (by DELEGATING-DIRECT-METHOD) which should do
-   the right job.  Very fancy subclasses might need to do something
-   different."))
-
-(defgeneric sod-method-function-name (method)
-  (:documentation
-   "Return the C function name for the direct method."))
-
-(defgeneric method-entry-function-type (entry)
-  (:documentation
-   "Return the C function type for a method entry."))
-
-;;;--------------------------------------------------------------------------
 ;;; Message classes.
 
+(export 'basic-message)
 (defclass basic-message (sod-message)
   ((argument-tail :type list :reader sod-message-argument-tail)
    (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
@@ -85,34 +39,32 @@
    This is a separate class so that `special effect' messages can avoid
    inheriting its default behaviour.
 
-   The function type protocol is implemented on BASIC-MESSAGE using slot
+   The function type protocol is implemented on `basic-message' using slot
    reader methods.  The actual values are computed on demand in methods
-   defined on SLOT-UNBOUND."))
-
-;;; Function type protocol.
+   defined on `slot-unbound'."))
 
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'argument-tail)))
   (let ((seq 0))
-    (mapcar (lambda (arg)
-	      (if (or (eq arg :ellipsis) (argument-name arg))
-		  arg
-		  (make-argument (make-instance 'temporary-argument
-						:tag (prog1 seq (incf seq)))
-				 (argument-type arg))))
-	    (c-function-arguments (sod-message-type message)))))
+    (setf (slot-value message 'argument-tail)
+	  (mapcar (lambda (arg)
+		    (if (or (eq arg :ellipsis) (argument-name arg)) arg
+			(make-argument (make-instance 'temporary-argument
+						      :tag (prog1 seq
+							     (incf seq)))
+				       (argument-type arg))))
+		  (c-function-arguments (sod-message-type message))))))
 
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'no-varargs-tail)))
-  (mapcar (lambda (arg)
-	    (if (eq arg :ellipsis)
-		(make-argument *sod-ap* (c-type va-list))
-		arg))
-	  (sod-message-argument-tail message)))
-
-;;; Method class selection.
+  (setf (slot-value message 'no-varargs-tail)
+	(mapcar (lambda (arg)
+		  (if (eq arg :ellipsis)
+		      (make-argument *sod-ap* (c-type va-list))
+		      arg))
+		(sod-message-argument-tail message))))
 
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
@@ -123,18 +75,31 @@
       ((nil) (error "How odd: a primary method slipped through the net"))
       (t (error "Unknown method role ~A" role)))))
 
-;;; Utility functions.
+(export 'simple-message)
+(defclass simple-message (basic-message)
+  ()
+  (:documentation
+   "Base class for messages with `simple' method combinations.
 
-(defun varargs-message-p (message)
-  "Answer whether the MESSAGE accepts a variable-length argument list.
+   A simple method combination is one which has only one method role other
+   than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
+   We call these `primary' methods, and the programmer designates them by not
+   specifying an explicit role.
 
-   We need to jump through some extra hoops in order to cope with varargs
-   messages, so this is useful to know."
-  (member :ellipsis (sod-message-argument-tail message)))
+   If the programmer doesn't define any primary methods then the effective
+   method is null -- i.e., the method entry pointer shows up as a null
+   pointer."))
+
+(defmethod sod-message-method-class
+    ((message simple-message) (class sod-class) pset)
+  (if (get-property pset :role :keyword nil)
+      (call-next-method)
+      (primary-method-class message)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 
+(export 'basic-direct-method)
 (defclass basic-direct-method (sod-method)
   ((role :initarg :role :type symbol :reader sod-method-role)
    (function-type :type c-function-type :reader sod-method-function-type))
@@ -146,12 +111,12 @@
    inheriting its default behaviour and slots.
 
    A basic method can be assigned a `role', which may be set either as an
-   initarg or using the :ROLE property.  Roles are used for method
+   initarg or using the `:role' property.  Roles are used for method
    categorization.
 
-   The function type protocol is implemented on BASIC-DIRECT-METHOD using
+   The function type protocol is implemented on `basic-direct-method' using
    slot reader methods.  The actual values are computed on demand in methods
-   defined on SLOT-UNBOUND."))
+   defined on `slot-unbound'."))
 
 (defmethod shared-initialize :after
     ((method basic-direct-method) slot-names &key pset)
@@ -172,6 +137,7 @@
 	    (sod-class-nickname (sod-message-class message))
 	    (sod-message-name message))))
 
+(export 'daemon-direct-method)
 (defclass daemon-direct-method (basic-direct-method)
   ()
   (:documentation
@@ -184,10 +150,9 @@
    In C terms, a daemon method must return `void', and is not passed a
    `next_method' pointer."))
 
-(defmethod check-method-type
-    ((method daemon-direct-method)
-     (message sod-message)
-     (type c-function-type))
+(defmethod check-method-type ((method daemon-direct-method)
+			      (message sod-message)
+			      (type c-function-type))
   (with-slots ((msgtype type)) message
     (unless (c-type-equal-p (c-type-subtype type) (c-type void))
       (error "Method return type ~A must be `void'" (c-type-subtype type)))
@@ -195,6 +160,7 @@
 					 (c-function-arguments type))
       (error "Method arguments ~A don't match message ~A" type msgtype))))
 
+(export 'delegating-direct-method)
 (defclass delegating-direct-method (basic-direct-method)
   ((next-method-type :type c-function-type
 		     :reader sod-method-next-method-type))
@@ -246,16 +212,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
-(defgeneric effective-method-basic-argument-names (method)
-  (:documentation
-   "Return a list of argument names to be passed to direct methods.
-
-   The argument names are constructed from the message's arguments returned
-   by SOD-MESSAGE-NO-VARARGS-TAIL.  The basic arguments are the ones
-   immediately derived from the programmer's explicitly stated arguments; the
-   `me' argument is not included, and neither are more exotic arguments added
-   as part of the method delegation protocol."))
-
+(export 'basic-effective-method)
 (defclass basic-effective-method (effective-method)
   ((around-methods :initarg :around-methods :initform nil
 		   :type list :reader effective-method-around-methods)
@@ -273,9 +230,9 @@
    `around' methods and provides behaviour for invoking these methods
    correctly.
 
-   The argument names protocol is implemented on BASIC-EFFECTIVE-METHOD using
-   a slot reader method.  The actual values are computed on demand in methods
-   defined on SLOT-UNBOUND."))
+   The argument names protocol is implemented on `basic-effective-method'
+   using a slot reader method.  The actual values are computed on demand in
+   methods defined on `slot-unbound'."))
 
 (defmethod slot-unbound (class
 			 (method basic-effective-method)
@@ -286,67 +243,44 @@
 		 (mapcar #'argument-name
 			 (sod-message-no-varargs-tail message))))))
 
-;;;--------------------------------------------------------------------------
-;;; Method categorization.
-
-(defmacro categorize ((itemvar items &key bind) categories &body body)
-  "Categorize ITEMS into lists and invoke BODY.
-
-   The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
-   will contain the current item.  The BIND argument is a list of LET*-like
-   clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
-   PREDICATE).
-
-   The behaviour of the macro is as follows.  ITEMVAR is assigned (not
-   bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
-   CATEGORIES list are evaluated in turn, in an environment containing
-   ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
-   At this point, the item is assigned to the category named by the
-   corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
-   error is signalled; a PREDICATE consisting only of T will (of course)
-   match anything; it is detected specially so as to avoid compiler warnings.
-
-   Once all of the ITEMS have been categorized in this fashion, the BODY is
-   evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
-   variable named after that symbol will be bound in the BODY's environment
-   to a list of the items in that category, in the same order in which they
-   were found in the list ITEMS.  The final values of the macro are the final
-   values of the BODY."
-
-  (let* ((cat-names (mapcar #'car categories))
-	 (cat-match-forms (mapcar #'cadr categories))
-	 (cat-vars (mapcar (lambda (name) (gensym (symbol-name name)))
-			   cat-names))
-	 (items-var (gensym "ITEMS")))
-    `(let ((,items-var ,items)
-	   ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
-       (dolist (,itemvar ,items-var)
-	 (let* ,bind
-	   (cond ,@(mapcar (lambda (cat-match-form cat-var)
-			     `(,cat-match-form
-			       (push ,itemvar ,cat-var)))
-			   cat-match-forms cat-vars)
-		 ,@(and (not (member t cat-match-forms))
-			`((t (error "Failed to categorize ~A" ,itemvar)))))))
-       (let ,(mapcar (lambda (name var)
-		       `(,name (nreverse ,var)))
-		     cat-names cat-vars)
-	 ,@body))))
+(defmethod effective-method-function-name ((method effective-method))
+  (let* ((class (effective-method-class method))
+	 (message (effective-method-message method))
+	 (message-class (sod-message-class message)))
+    (format nil "~A__emethod_~A__~A"
+	    class
+	    (sod-class-nickname message-class)
+	    (sod-message-name message))))
 
-;;;--------------------------------------------------------------------------
-;;; Code generation.
+(defmethod slot-unbound
+    (class (method basic-effective-method) (slot-name (eql 'functions)))
+  (setf (slot-value method 'functions)
+	(compute-method-entry-functions method)))
 
-(defclass method-codegen (codegen)
-  ((message :initarg :message :type sod-message :reader codegen-message)
-   (class :initarg :class :type sod-class :reader codegen-class)
-   (method :initarg :method :type effective-method :reader codegen-method)
-   (target :initarg :target :reader codegen-target))
+(export 'simple-effective-method)
+(defclass simple-effective-method (basic-effective-method)
+  ((primary-methods :initarg :primary-methods :initform nil
+		    :type list :reader effective-method-primary-methods))
   (:documentation
-   "Augments CODEGEN with additional state regarding an effective method.
+   "Effective method counterpart to `simple-message'."))
 
-   We store the effective method, and also its target class and owning
-   message, so that these values are readily available to the code-generating
-   functions."))
+(defmethod shared-initialize :after
+    ((method simple-effective-method) slot-names &key direct-methods)
+  (declare (ignore slot-names))
+  (categorize (method direct-methods :bind ((role (sod-method-role method))))
+      ((primary (null role))
+       (before (eq role :before))
+       (after (eq role :after))
+       (around (eq role :around)))
+    (with-slots (primary-methods before-methods after-methods around-methods)
+	method
+      (setf primary-methods primary
+	    before-methods before
+	    after-methods (reverse after)
+	    around-methods around))))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
 
 (defmethod shared-initialize :after
     ((codegen method-codegen) slot-names &key)
@@ -356,141 +290,10 @@
 	      :void
 	      :return))))
 
-(defgeneric compute-effective-method-body (method codegen target)
-  (:documentation
-   "Generates the body of an effective method.
-
-   Writes the function body to the code generator.  It can (obviously)
-   generate auxiliary functions if it needs to.
-
-   The arguments are as specified by the SOD-MESSAGE-NO-VARARGS-TAIL, with an
-   additional argument `sod__obj' of type pointer-to-ilayout.  The code
-   should deliver the result (if any) to the TARGET."))
-
-(defun invoke-method (codegen target arguments-tail direct-method)
-  "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
-
-   The code is generated in the context of CODEGEN, which can be any instance
-   of the CODEGEN class -- it needn't be an instance of METHOD-CODEGEN.  The
-   DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of argument
-   expressions), preceded by a `me' argument of type pointer-to-CLASS where
-   CLASS is the class on which the method was defined.
-
-   If the message accepts a variable-length argument list then a copy of the
-   prevailing master argument pointer is provided in place of the :ELLIPSIS."
-
-  (let* ((message (sod-method-message direct-method))
-	 (class (sod-method-class direct-method))
-	 (function (sod-method-function-name direct-method))
-	 (arguments (cons (format nil "&sod__obj.~A.~A"
-				  (sod-class-nickname
-				   (sod-class-chain-head class))
-				  (sod-class-nickname class))
-			  arguments-tail)))
-    (if (varargs-message-p message)
-	(convert-stmts codegen target
-		       (c-type-subtype (sod-method-type direct-method))
-		       (lambda (var)
-			 (ensure-var codegen *sod-ap* (c-type va-list))
-			 (emit-inst codegen
-				    (make-va-copy-inst *sod-ap*
-						       *sod-master-ap*))
-			 (deliver-expr codegen var
-				       (make-call-inst function arguments))
-			 (emit-inst codegen
-				    (make-va-end-inst *sod-ap*))))
-	(deliver-expr codegen target (make-call-inst function arguments)))))
-
-(definst convert-to-ilayout (stream) (class chain-head expr)
-  (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
-	  class (sod-class-nickname chain-head) expr))
-
-(defun ensure-ilayout-var (codegen super)
-  "Define a variable `sod__obj' pointing to the class's ilayout structure.
-
-   CODEGEN is a METHOD-CODEGEN.  The class in question is CODEGEN's class,
-   i.e., the target class for the effective method.  SUPER is one of the
-   class's superclasses; it is assumed that `me' is a pointer to a SUPER
-   (i.e., to SUPER's ichain within the ilayout)."
-
-  (let* ((class (codegen-class codegen))
-	 (super-head (sod-class-chain-head super)))
-    (ensure-var codegen "sod__obj"
-		(c-type (* (struct (ilayout-struct-tag class))))
-		(make-convert-to-ilayout-inst class super-head "me"))))
-
-(defun make-trampoline (codegen super body)
-  "Construct a trampoline function and return its name.
-
-   CODEGEN is a METHOD-CODEGEN.  SUPER is a superclass of the CODEGEN class.
-   We construct a new trampoline function (with an unimaginative name)
-   suitable for being passed to a direct method defined on SUPER as its
-   `next_method'.  In particular, it will have a `me' argument whose type is
-   pointer-to-SUPER.
-
-   The code of the function is generated by BODY, which will be invoked with
-   a single argument which is the TARGET to which it should deliver its
-   result.
-
-   The return value is the name of the generated function."
-
-  (let* ((message (codegen-message codegen))
-	 (message-type (sod-message-type message))
-	 (return-type (c-type-subtype message-type))
-	 (arguments (mapcar (lambda (arg)
-			      (if (eq (argument-name arg) *sod-ap*)
-				  (make-argument *sod-master-ap*
-						 (c-type va-list))
-				  arg))
-			    (sod-message-no-varargs-tail message))))
-    (codegen-push codegen)
-    (ensure-ilayout-var codegen super)
-    (funcall body (codegen-target codegen))
-    (codegen-pop-function codegen (temporary-function)
-			  (c-type (fun (lisp return-type)
-				       ("me" (* (class super)))
-				       . arguments)))))
-
-(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
-  "Invoke a chain of delegating methods.
-
-   CODEGEN is a METHOD-CODEGEN.  BASIC-TAIL is a list of argument expressions
-   to provide to the methods.  The result of the delegation chain will be
-   delivered to TARGET.
-
-   The CHAIN is a list of DELEGATING-DIRECT-METHOD objects.  The behaviour is
-   as follows.  The first method in the chain is invoked with the necessary
-   arguments (see below) including a `next_method' pointer.  If KERNEL is nil
-   and there are no more methods in the chain then the `next_method' pointer
-   will be null; otherwise it will point to a `trampoline' function, whose
-   behaviour is to call the remaining methods on the chain as a delegation
-   chain.  The method may choose to call this function with its arguments.
-   It will finally return a value, which will be delivered to the TARGET.
-
-   If the chain is empty, then the code generated by KERNEL (given a TARGET
-   argument) will be invoked.  It is an error if both CHAIN and KERNEL are
-   nil."
-
-  (let* ((message (codegen-message codegen))
-	 (argument-tail (if (varargs-message-p message)
-			    (cons *sod-master-ap* basic-tail)
-			    basic-tail)))
-    (labels ((next-trampoline (method chain)
-	       (if (or kernel chain)
-		   (make-trampoline codegen (sod-method-class method)
-				    (lambda (target)
-				      (invoke chain target)))
-		   0))
-	     (invoke (chain target)
-	       (if (null chain)
-		   (funcall kernel target)
-		   (let* ((trampoline (next-trampoline (car chain)
-						       (cdr chain))))
-		     (invoke-method codegen target
-				    (cons trampoline argument-tail)
-				    (car chain))))))
-      (invoke chain target))))
+;;;--------------------------------------------------------------------------
+;;; Invoking direct methods.
 
+(export 'basic-effective-method-body)
 (defun basic-effective-method-body (codegen target method body)
   "Build the common method-invocation structure.
 
@@ -524,15 +327,7 @@
 				 around-methods #'method-kernel)))))
 
 ;;;--------------------------------------------------------------------------
-;;; Effective method entry points.
-
-(defgeneric compute-method-entry-functions (method)
-  (:documentation
-   "Construct method entry functions.
-
-   Builds the effective method function (if there is one) and the necessary
-   method entries.  Returns a list of functions (i.e., FUNCTION-INST objects)
-   which need to be defined in the generated source code."))
+;;; Method entry points.
 
 (defparameter *method-entry-inline-threshold* 200
   "Threshold below which effective method bodies are inlined into entries.
@@ -543,37 +338,34 @@
    fold the method body into the entry functions; otherwise we split the
    effective method out into its own function.")
 
-(defgeneric effective-method-function-name (method)
-  (:documentation
-   "Returns the function name of an effective method."))
-
-(defgeneric method-entry-function-name (method chain-head)
-  (:documentation
-   "Returns the function name of a method entry.
-
-   The method entry is given as an effective method/chain-head pair, rather
-   than as a method entry object because we want the function name before
-   we've made the entry object."))
-
-(defmethod effective-method-function-name ((method effective-method))
-  (let* ((class (effective-method-class method))
-	 (message (effective-method-message method))
-	 (message-class (sod-message-class message)))
-    (format nil "~A__emethod_~A__~A"
-	    class
-	    (sod-class-nickname message-class)
-	    (sod-message-name message))))
-
 (defmethod method-entry-function-name
     ((method effective-method) (chain-head sod-class))
   (let* ((class (effective-method-class method))
 	 (message (effective-method-message method))
 	 (message-class (sod-message-class message)))
-    (format nil "~A__mentry_~A__~A__chain_~A"
-	    class
-	    (sod-class-nickname message-class)
-	    (sod-message-name message)
-	    (sod-class-nickname chain-head))))
+    (if (or (not (slot-boundp method 'functions))
+	    (slot-value method 'functions))
+	(format nil "~A__mentry_~A__~A__chain_~A"
+		class
+		(sod-class-nickname message-class)
+		(sod-message-name message)
+		(sod-class-nickname chain-head))
+	0)))
+
+(defmethod method-entry-function-type ((entry method-entry))
+  (let* ((method (method-entry-effective-method entry))
+	 (message (effective-method-message method))
+	 (type (sod-message-type message)))
+    (c-type (fun (lisp (c-type-subtype type))
+		 ("me" (* (class (method-entry-chain-tail entry))))
+		 . (sod-message-argument-tail message)))))
+
+(defmethod make-method-entry ((method basic-effective-method)
+			      (chain-head sod-class) (chain-tail sod-class))
+  (make-instance 'method-entry
+		 :method method
+		 :chain-head chain-head
+		 :chain-tail chain-tail))
 
 (defmethod compute-method-entry-functions ((method basic-effective-method))
 
@@ -638,25 +430,25 @@
 		     (return prev))))
 	 (entry-target (codegen-target codegen)))
 
-    (labels ((setup-entry (tail)
-	       (let ((head (sod-class-chain-head tail)))
-		 (codegen-push codegen)
-		 (ensure-var codegen "sod__obj" ilayout-type
-			     (make-convert-to-ilayout-inst class
-							   head "me"))))
-	     (varargs-prologue ()
-	       (ensure-var codegen *sod-master-ap* (c-type va-list))
-	       (emit-inst codegen
-			  (make-va-start-inst *sod-master-ap* parm-n)))
-	     (varargs-epilogue ()
-	       (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
-	     (finish-entry (tail)
-	       (let* ((head (sod-class-chain-head tail))
-		      (name (method-entry-function-name method head))
-		      (type (c-type (fun (lisp return-type)
-					 ("me" (* (class tail)))
-					 . entry-args))))
-		 (codegen-pop-function codegen name type))))
+    (flet ((setup-entry (tail)
+	     (let ((head (sod-class-chain-head tail)))
+	       (codegen-push codegen)
+	       (ensure-var codegen "sod__obj" ilayout-type
+			   (make-convert-to-ilayout-inst class
+							 head "me"))))
+	   (varargs-prologue ()
+	     (ensure-var codegen *sod-master-ap* (c-type va-list))
+	     (emit-inst codegen
+			(make-va-start-inst *sod-master-ap* parm-n)))
+	   (varargs-epilogue ()
+	     (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
+	   (finish-entry (tail)
+	     (let* ((head (sod-class-chain-head tail))
+		    (name (method-entry-function-name method head))
+		    (type (c-type (fun (lisp return-type)
+				       ("me" (* (class tail)))
+				       . entry-args))))
+	       (codegen-pop-function codegen name type))))
 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)
@@ -705,35 +497,50 @@
 
       (codegen-functions codegen))))
 
-(defmethod slot-unbound
-    (class (method basic-effective-method) (slot-name (eql 'functions)))
-  (setf (slot-value method 'functions)
-	(compute-method-entry-functions method)))
+(defmethod compute-method-entry-functions
+    ((method simple-effective-method))
+  (if (effective-method-primary-methods method)
+      (call-next-method)
+      nil))
+
+(defmethod compute-effective-method-body
+    ((method simple-effective-method) codegen target)
+  (with-slots (message basic-argument-names primary-methods) method
+    (basic-effective-method-body codegen target method
+				 (lambda (target)
+				   (simple-method-body method
+						       codegen
+						       target)))))
 
-(defmethod method-entry-function-type ((entry method-entry))
-  (let* ((method (method-entry-effective-method entry))
-	 (message (effective-method-message method))
-	 (type (sod-message-type message)))
-    (c-type (fun (lisp (c-type-subtype type))
-		 ("me" (* (class (method-entry-chain-tail entry))))
-		 . (sod-message-argument-tail message)))))
+;;;--------------------------------------------------------------------------
+;;; Standard method combination.
 
-(defmethod make-method-entry ((method basic-effective-method)
-			      (chain-head sod-class) (chain-tail sod-class))
-  (make-instance 'method-entry
-		 :method method
-		 :chain-head chain-head
-		 :chain-tail chain-tail))
+(export 'standard-message)
+(defclass standard-message (simple-message)
+  ()
+  (:documentation
+   "Message class for standard method combination.
 
-;;;--------------------------------------------------------------------------
-;;; Output.
-
-(defmethod add-output-hooks progn
-    ((method basic-effective-method) (reason (eql :c)) sequencer)
-  (with-slots (class functions) method
-    (sequence-output (stream sequencer)
-      ((class :effective-methods)
-       (dolist (func functions)
-	 (write func :stream stream :escape nil :circle nil))))))
+   Standard method combination is a simple method combination where the
+   primary methods are invoked as a delegation chain, from most- to
+   least-specific."))
+
+(export 'standard-effective-method)
+(defclass standard-effective-method (simple-effective-method) ()
+  (:documentation "Effective method counterpart to `standard-message'."))
+
+(defmethod primary-method-class ((message standard-message))
+  'delegating-direct-method)
+
+(defmethod message-effective-method-class ((message standard-message))
+  'standard-effective-method)
+
+(defmethod simple-method-body
+    ((method standard-effective-method) codegen target)
+  (invoke-delegation-chain codegen
+			   target
+			   (effective-method-basic-argument-names method)
+			   (effective-method-primary-methods method)
+			   nil))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-module.lisp b/src/impl-module.lisp
new file mode 100644
index 0000000..8349b85
--- /dev/null
+++ b/src/impl-module.lisp
@@ -0,0 +1,189 @@
+;;; -*-lisp-*-
+;;;
+;;; Module protocol implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Module basics.
+
+(defmethod module-import ((module module))
+  (dolist (item (module-items module))
+    (module-import item)))
+
+(defmethod add-to-module ((module module) item)
+  (setf (module-items module)
+	(nconc (module-items module) (list item)))
+  (module-import item))
+
+(defmethod shared-initialize :after ((module module) slot-names &key pset)
+  "Tick off known properties on the property set."
+  (declare (ignore slot-names))
+  (dolist (prop '(:guard))
+    (get-property pset prop nil)))
+
+(defmethod finalize-module ((module module))
+  (let* ((pset (module-pset module))
+	 (class (get-property pset :lisp-class :symbol 'module)))
+
+    ;; Always call `change-class', even if it's the same one; this will
+    ;; exercise the property-set fiddling in `shared-initialize' and we can
+    ;; catch unknown-property errors.
+    (change-class module class :state t :pset pset)
+    (check-unused-properties pset)
+    module))
+
+;;;--------------------------------------------------------------------------
+;;; Module objects.
+
+(defparameter *module-map* (make-hash-table :test #'equal)
+  "Hash table mapping true names to module objects.")
+
+(defun build-module
+    (name thunk &key (truename (probe-file name)) location)
+  "Construct a new module.
+
+   This is the functionality underlying `define-module'."
+
+  (let ((*module* (make-instance 'module
+				 :name (pathname name)
+				 :state (file-location location))))
+    (when truename
+      (setf (gethash truename *module-map*) *module*))
+    (unwind-protect
+	 (call-with-module-environment (lambda ()
+					 (module-import *builtin-module*)
+					 (funcall thunk)
+					 (finalize-module *module*)))
+      (when (and truename (not (eq (module-state *module*) t)))
+	(remhash truename *module-map*)))))
+
+;;;--------------------------------------------------------------------------
+;;; Type definitions.
+
+(export 'type-item)
+(defclass type-item ()
+  ((name :initarg :name :type string :reader type-name))
+  (:documentation
+   "A note that a module exports a type.
+
+   We can only export simple types, so we only need to remember the name.
+   The magic simple-type cache will ensure that we get the same type object
+   when we do the import."))
+
+(defmethod module-import ((item type-item))
+  (let* ((name (type-name item))
+	 (def (gethash name *module-type-map*))
+	 (type (make-simple-type name)))
+    (cond ((not def)
+	   (setf (gethash name *module-type-map*) type))
+	  ((not (eq def type))
+	   (error "Conflicting types `~A'" name)))))
+
+(defmethod module-import ((class sod-class))
+  (record-sod-class class))
+
+;;;--------------------------------------------------------------------------
+;;; Code fragments.
+
+(export 'c-fragment)
+(defclass c-fragment ()
+  ((location :initarg :location :type file-location
+	     :accessor c-fragment-location)
+   (text :initarg :text :type string :accessor c-fragment-text))
+  (:documentation
+   "Represents a fragment of C code to be written to an output file.
+
+   A C fragment is aware of its original location, and will bear proper #line
+   markers when written out."))
+
+(defun output-c-excursion (stream location thunk)
+  "Invoke THUNK surrounding it by writing #line markers to STREAM.
+
+   The first marker describes LOCATION; the second refers to the actual
+   output position in STREAM.  If LOCATION doesn't provide a line number then
+   no markers are output after all.  If the output stream isn't
+   position-aware then no final marker is output."
+
+  (let* ((location (file-location location))
+	 (line (file-location-line location))
+	 (filename (file-location-filename location)))
+    (cond (line
+	   (format stream "~&#line ~D~@[ ~S~]~%" line filename)
+	   (funcall thunk)
+	   (when (typep stream 'position-aware-stream)
+	     (fresh-line stream)
+	     (format stream "~&#line ~D ~S~%"
+		     (1+ (position-aware-stream-line stream))
+		     (namestring (stream-pathname stream)))))
+	  (t
+	   (funcall thunk)))))
+
+(defmethod print-object ((fragment c-fragment) stream)
+  (let ((text (c-fragment-text fragment))
+	(location (c-fragment-location fragment)))
+    (if *print-escape*
+	(print-unreadable-object (fragment stream :type t)
+	  (when location
+	    (format stream "~A " location))
+	  (cond ((< (length text) 40)
+		 (prin1 text stream) stream)
+		(t
+		 (prin1 (subseq text 0 37) stream)
+		 (write-string "..." stream))))
+	(output-c-excursion stream location
+			    (lambda () (write-string text stream))))))
+
+(defmethod make-load-form ((fragment c-fragment) &optional environment)
+  (make-load-form-saving-slots fragment :environment environment))
+
+(export 'code-fragment-item)
+(defclass code-fragment-item ()
+  ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
+   (reason :initarg :reason :type keyword :reader code-fragment-reason)
+   (name :initarg :name :type t :reader code-fragment-name)
+   (constraints :initarg :constraints :type list
+		:reader code-fragment-constraints))
+  (:documentation
+   "A plain fragment of C to be dropped in at top-level."))
+
+(defmacro define-fragment ((reason name) &body things)
+  (categorize (thing things)
+      ((constraints (listp thing))
+       (frags (typep thing '(or string c-fragment))))
+    (when (null frags)
+      (error "Missing code fragment"))
+    (when (cdr frags)
+      (error "Multiple code fragments"))
+    `(add-to-module
+      *module*
+      (make-instance 'code-fragment-item
+		     :fragment ',(car frags)
+		     :name ,name
+		     :reason ,reason
+		     :constraints (list ,@(mapcar (lambda (constraint)
+						    (cons 'list constraint))
+						  constraints))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-output.lisp b/src/impl-output.lisp
new file mode 100644
index 0000000..30d0c80
--- /dev/null
+++ b/src/impl-output.lisp
@@ -0,0 +1,58 @@
+;;; -*-lisp-*-
+;;;
+;;; Output scheduling protocol implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(defmethod print-object ((item sequencer-item) stream)
+  (print-unreadable-object (item stream :type t)
+    (prin1 (sequencer-item-name item) stream)))
+
+(defmethod ensure-sequencer-item ((sequencer sequencer) name)
+  (with-slots (table) sequencer
+    (or (gethash name table)
+	(setf (gethash name table)
+	      (make-instance 'sequencer-item :name name)))))
+
+(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
+  (let ((converted-constraint
+	 (mapcar (lambda (name)
+		   (ensure-sequencer-item sequencer name))
+		 constraint)))
+    (with-slots (constraints) sequencer
+      (pushnew converted-constraint constraints :test #'equal))))
+
+(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
+  (let ((item (ensure-sequencer-item sequencer name)))
+    (pushnew function (sequencer-item-functions item))))
+
+(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
+  (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
+    (dolist (function (reverse (sequencer-item-functions item)))
+      (apply function arguments))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/impl-pset.lisp b/src/impl-pset.lisp
new file mode 100644
index 0000000..e498deb
--- /dev/null
+++ b/src/impl-pset.lisp
@@ -0,0 +1,83 @@
+;;; -*-lisp-*-
+;;;
+;;; Implementation for property sets
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Property representation.
+
+(defmethod file-location ((prop property))
+  (file-location (p-location prop)))
+
+;;; Keywords.
+
+(defmethod coerce-property-value
+    ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
+  value)
+
+(defmethod coerce-property-value
+    ((value string) (type (eql :id)) (wanted (eql :keyword)))
+  (string-to-symbol value :package :keyword))
+
+(defmethod coerce-property-value
+    ((value string) (type (eql :string)) (wanted (eql :keyword)))
+  (string-to-symbol value :package :keyword :swap-hyphen nil))
+
+;;; Symbols.
+
+(defmethod coerce-property-value
+    ((value string) (type (eql :id)) (wanted (eql :symbol)))
+  (string-to-symbol value))
+
+(defmethod coerce-property-value
+    ((value string) (type (eql :string)) (wanted (eql :symbol)))
+  (string-to-symbol value :swap-hyphen nil))
+
+;;; Identifiers.
+
+(defmethod coerce-property-value
+    ((value string) (type (eql :string)) (wanted (eql :id)))
+  value)
+
+(defmethod coerce-property-value
+    ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
+  (frob-identifier (symbol-name value)))
+
+;;;--------------------------------------------------------------------------
+;;; Property sets.
+
+(defmethod print-object ((pset pset) stream)
+  (print-unreadable-object (pset stream :type t)
+    (pprint-logical-block (stream nil)
+      (let ((firstp t))
+	(pset-map (lambda (prop)
+		    (cond (firstp (setf firstp nil))
+			  (t (write-char #\space stream)
+			     (pprint-newline :linear stream)))
+		    (format stream "~:@<~S ~@_~S ~@_~S~:>"
+			    (p-name prop) (p-type prop) (p-value prop)))
+		  pset)))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/lexer-bits.lisp b/src/lexer-bits.lisp
new file mode 100644
index 0000000..daa533c
--- /dev/null
+++ b/src/lexer-bits.lisp
@@ -0,0 +1,98 @@
+(cl:in-package #:sod)
+
+(defun play-fetch-token (string)
+  (with-parser-context (string-parser :string string)
+    (labels ((digit (radix)
+	       (parse (filter (lambda (ch)
+				(digit-char-p ch radix)))))
+	     (number (radix &optional (initial 0))
+	       (parse (many (a initial (+ (* radix a) it))
+			(digit radix))))
+	     (numeric (radix sigil)
+	       (parse (seq ((first (peek (seq ((nil (funcall sigil))
+					       (d (digit radix)))
+					   d)))
+			    (result (number radix first)))
+			result))))
+ (multiple-value-call #'values
+    (loop
+       (parse :whitespace)
+
+       (cond-parse ()
+
+	 ;; Give up at end-of-file.
+	 (:eof
+	  (return (values :eof nil)))
+
+	 ;; Pick out comments.
+	 ((peek (and #\/ #\*))
+	  (parse (skip-many ()		; this may fail at eof; don't worry
+	           (and (skip-many () (not #\*))
+			(skip-many (:min 1) #\*))
+		   (not #\/)))
+	  (if-parse :eof ()
+	    (cerror* "Unterminated comment")
+	    (parse :any)))
+	 ((and (peek (seq (#\/ #\/)))
+	       (skip-many () (not #\newline))
+	       (or :eof #\newline)))
+
+	 ;; Quoted strings and characters.
+	 ((or #\' #\")
+	  (let ((quote it)
+		(out (make-string-output-stream)))
+	    (parse (skip-many ()
+		     (or (seq ((ch (satisfies (lambda (ch)
+						(and (char/= ch #\\)
+						     (char/= ch quote))))))
+			   (write-char ch out))
+			 (seq (#\\ (ch :any))
+			   (write-char ch out)))))
+	    (if-parse :eof ()
+	      (cerror* "Unterminated ~:[string~;character~] constant"
+		       (char= quote #\'))
+	      (parse :any))
+	    (let ((string (get-output-stream-string out)))
+	      (ecase quote
+		(#\" (return (values :string string)))
+		(#\' (case (length string)
+		       (0 (cerror* "Empty character constant")
+			  (return (values :char #\?)))
+		       (1 (return (values :char (char string 0))))
+		       (t (cerror* "Multiple characters in ~
+				    character constant")
+			  (return (values :char (char string 0))))))))))
+
+	 ;; Identifiers.
+	 ((seq ((first (satisfies (lambda (ch)
+				    (or (char= ch #\_)
+					(alpha-char-p ch)))))
+		(ident (many (out (let ((s (make-string-output-stream)))
+				    (write-char first s)
+				    s)
+				  (progn (write-char it out) out)
+			      :final (get-output-stream-string out))
+			 (satisfies (lambda (ch)
+				      (or (char= ch #\_)
+					  (alphanumericp ch)))))))
+	    (return (values :id ident))))
+
+	 ;; Numbers -- uses the machinery in the labels above.
+	 ((or (seq (#\0
+		    (i (or (numeric 8 (parser () (or #\o #\O)))
+			   (numeric 16 (parser () (or #\x #\X)))
+			   (number 8))))
+		i)
+	      (seq ((first (digit 10))
+		    (rest (number 10 first)))
+		rest))
+	  (return (values :integer it)))
+
+	 ;; Special separator tokens.
+	 ("..."
+	  (return (values :ellipsis :ellipsis)))
+
+	 ;; Anything else is a standalone delimiter character.
+	 (:any
+	  (return (values it it)))))
+    (parse (list () :any))))))
diff --git a/src/output-class.lisp b/src/output-class.lisp
new file mode 100644
index 0000000..58d4830
--- /dev/null
+++ b/src/output-class.lisp
@@ -0,0 +1,576 @@
+;;; -*-lisp-*-
+;;;
+;;; Output for classes
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(defmethod hook-output progn ((class sod-class) (reason (eql :h))
+				   sequencer)
+
+  ;; Main output sequencing.
+  (sequence-output (stream sequencer)
+
+    :constraint
+    ((:classes :start)
+     (class :banner)
+     (class :islots :start) (class :islots :slots) (class :islots :end)
+     (class :vtmsgs :start) (class :vtmsgs :end)
+     (class :vtables :start) (class :vtables :end)
+     (class :vtable-externs) (class :vtable-externs-after)
+     (class :methods :start) (class :methods) (class :methods :end)
+     (class :ichains :start) (class :ichains :end)
+     (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
+     (class :conversions)
+     (class :object)
+     (:classes :end))
+
+    (:typedefs
+     (format stream "typedef struct ~A ~A;~%"
+	     (ichain-struct-tag class (sod-class-chain-head class)) class))
+
+    ((class :banner)
+     (banner (format nil "Class ~A" class) stream))
+    ((class :vtable-externs-after)
+     (terpri stream))
+
+    ((class :vtable-externs)
+     (format stream "/* Vtable structures. */~%"))
+
+    ((class :object)
+     (let ((metaclass (sod-class-metaclass class))
+	   (metaroot (find-root-metaclass class)))
+       (format stream "/* The class object. */~@
+		       extern const struct ~A ~A__classobj;~@
+		       #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
+	       (ilayout-struct-tag metaclass) class
+	       (sod-class-nickname (sod-class-chain-head metaroot))
+	       (sod-class-nickname metaroot)))))
+
+  ;; Maybe generate an islots structure.
+  (when (sod-class-slots class)
+    (dolist (slot (sod-class-slots class))
+      (hook-output slot 'islots sequencer))
+    (sequence-output (stream sequencer)
+      ((class :islots :start)
+       (format stream "/* Instance slots. */~@
+		       struct ~A {~%"
+	       (islots-struct-tag class)))
+      ((class :islots :end)
+       (format stream "};~2%"))))
+
+  ;; Declare the direct methods.
+  (when (sod-class-methods class)
+    (sequence-output (stream sequencer)
+      ((class :methods :start)
+       (format stream "/* Direct methods. */~%"))
+      ((class :methods :end)
+       (terpri stream))))
+
+  ;; Provide upcast macros which do the right thing.
+  (when (sod-class-direct-superclasses class)
+    (sequence-output (stream sequencer)
+      ((class :conversions)
+       (let ((chain-head (sod-class-chain-head class)))
+	 (format stream "/* Conversion macros. */~%")
+	 (dolist (super (cdr (sod-class-precedence-list class)))
+	   (let ((super-head (sod-class-chain-head super)))
+	     (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
+				     ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
+		     class (sod-class-nickname super) super
+		     (eq chain-head super-head)
+		     (sod-class-nickname super-head))))
+	 (terpri stream)))))
+
+  ;; Generate vtmsgs structure for all superclasses.
+  (hook-output (car (sod-class-vtables class))
+		    'vtmsgs
+		    sequencer))
+
+(defmethod hook-output progn ((class sod-class) reason sequencer)
+  (with-slots (ilayout vtables methods effective-methods) class
+    (hook-output ilayout reason sequencer)
+    (dolist (method methods) (hook-output method reason sequencer))
+    (dolist (method effective-methods)
+      (hook-output method reason sequencer))
+    (dolist (vtable vtables) (hook-output vtable reason sequencer))))
+
+;;;--------------------------------------------------------------------------
+;;; Instance structure.
+
+(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
+				   sequencer)
+  (sequence-output (stream sequencer)
+    (((sod-slot-class slot) :islots :slots)
+     (pprint-logical-block (stream nil :prefix "  " :suffix ";")
+       (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
+     (terpri stream))))
+
+(defmethod hook-output progn ((ilayout ilayout) reason sequencer)
+  (with-slots (ichains) ilayout
+    (dolist (ichain ichains) (hook-output ichain reason sequencer))))
+
+(defmethod hook-output progn ((ichain ichain) reason sequencer)
+  (dolist (item (ichain-body ichain))
+    (hook-output item reason sequencer)))
+
+(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
+				   sequencer)
+  (with-slots (class ichains) ilayout
+    (sequence-output (stream sequencer)
+      ((class :ilayout :start)
+       (format stream "/* Instance layout. */~@
+		       struct ~A {~%"
+	       (ilayout-struct-tag class)))
+      ((class :ilayout :end)
+       (format stream "};~2%")))
+    (dolist (ichain ichains)
+      (hook-output ichain 'ilayout sequencer))))
+
+(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
+				   sequencer)
+  (with-slots (class chain-head chain-tail) ichain
+    (when (eq class chain-tail)
+      (sequence-output (stream sequencer)
+	:constraint ((class :ichains :start)
+		     (class :ichain chain-head :start)
+		     (class :ichain chain-head :slots)
+		     (class :ichain chain-head :end)
+		     (class :ichains :end))
+	((class :ichain chain-head :start)
+	 (format stream "/* Instance chain structure. */~@
+			 struct ~A {~%"
+		 (ichain-struct-tag chain-tail chain-head)))
+	((class :ichain chain-head :end)
+	 (format stream "};~2%")
+	 (format stream "/* Union of equivalent superclass chains. */~@
+			 union ~A {~@
+			 ~:{  struct ~A ~A;~%~}~
+			 };~2%"
+		 (ichain-union-tag chain-tail chain-head)
+
+		 ;; Make sure the most specific class is first: only the
+		 ;; first element of a union can be statically initialized in
+		 ;; C90.
+		 (mapcar (lambda (super)
+			   (list (ichain-struct-tag super chain-head)
+				 (sod-class-nickname super)))
+			 (sod-class-chain chain-tail))))))))
+
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
+				   sequencer)
+  (with-slots (class chain-head chain-tail) ichain
+    (sequence-output (stream sequencer)
+      ((class :ilayout :slots)
+       (format stream "  union ~A ~A;~%"
+	       (ichain-union-tag chain-tail chain-head)
+	       (sod-class-nickname chain-head))))))
+
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
+				   sequencer)
+  (with-slots (class chain-head chain-tail) vtptr
+    (sequence-output (stream sequencer)
+      ((class :ichain chain-head :slots)
+       (format stream "  const struct ~A *_vt;~%"
+	       (vtable-struct-tag chain-tail chain-head))))))
+
+(defmethod hook-output progn ((islots islots) reason sequencer)
+  (dolist (slot (islots-slots islots))
+    (hook-output slot reason sequencer)))
+
+(defmethod hook-output progn ((islots islots) (reason (eql :h))
+				   sequencer)
+  (with-slots (class subclass slots) islots
+    (sequence-output (stream sequencer)
+      ((subclass :ichain (sod-class-chain-head class) :slots)
+       (format stream "  struct ~A ~A;~%"
+	       (islots-struct-tag class)
+	       (sod-class-nickname class))))))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable structure.
+
+(defmethod hook-output progn ((vtable vtable) reason sequencer)
+  (with-slots (body) vtable
+    (dolist (item body) (hook-output item reason sequencer))))
+
+(defmethod hook-output progn ((method sod-method) (reason (eql :h))
+				   sequencer)
+  (with-slots (class) method
+    (sequence-output (stream sequencer)
+      ((class :methods)
+       (let ((type (sod-method-function-type method)))
+	 (princ "extern " stream)
+	 (pprint-c-type (commentify-function-type type) stream
+			(sod-method-function-name method))
+	 (format stream ";~%"))))))
+
+(defmethod hook-output progn ((vtable vtable) (reason (eql :h))
+				   sequencer)
+  (with-slots (class chain-head chain-tail) vtable
+    (when (eq class chain-tail)
+      (sequence-output (stream sequencer)
+	:constraint ((class :vtables :start)
+		     (class :vtable chain-head :start)
+		     (class :vtable chain-head :slots)
+		     (class :vtable chain-head :end)
+		     (class :vtables :end))
+	((class :vtable chain-head :start)
+	 (format stream "/* Vtable structure. */~@
+			 struct ~A {~%"
+		 (vtable-struct-tag chain-tail chain-head)))
+	((class :vtable chain-head :end)
+	 (format stream "};~2%"))))
+    (sequence-output (stream sequencer)
+      ((class :vtable-externs)
+       (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
+	       (vtable-struct-tag chain-tail chain-head)
+	       class (sod-class-nickname chain-head))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
+				   sequencer)
+  (with-slots (class subclass chain-head chain-tail) vtmsgs
+    (sequence-output (stream sequencer)
+      ((subclass :vtable chain-head :slots)
+       (format stream "  struct ~A ~A;~%"
+	       (vtmsgs-struct-tag subclass class)
+	       (sod-class-nickname class))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
+				   sequencer)
+  (when (vtmsgs-entries vtmsgs)
+    (with-slots (class subclass) vtmsgs
+      (sequence-output (stream sequencer)
+	:constraint ((subclass :vtmsgs :start)
+		     (subclass :vtmsgs class :start)
+		     (subclass :vtmsgs class :slots)
+		     (subclass :vtmsgs class :end)
+		     (subclass :vtmsgs :end))
+	((subclass :vtmsgs class :start)
+	 (format stream "/* Messages protocol from class ~A */~@
+			 struct ~A {~%"
+		 class
+		 (vtmsgs-struct-tag subclass class)))
+	((subclass :vtmsgs class :end)
+	 (format stream "};~2%"))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
+  (with-slots (entries) vtmsgs
+    (dolist (entry entries) (hook-output entry reason sequencer))))
+
+(defmethod hook-output progn ((entry method-entry) reason sequencer)
+  (with-slots (method) entry
+    (hook-output method reason sequencer)))
+
+(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
+				   sequencer)
+  (let* ((method (method-entry-effective-method entry))
+	 (message (effective-method-message method))
+	 (class (effective-method-class method))
+	 (type (method-entry-function-type entry))
+	 (commented-type (commentify-function-type type)))
+    (sequence-output (stream sequencer)
+      ((class :vtmsgs (sod-message-class message) :slots)
+       (pprint-logical-block (stream nil :prefix "  " :suffix ";")
+	 (pprint-c-type commented-type stream (sod-message-name message)))
+       (terpri stream)))))
+
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
+				   sequencer)
+  (with-slots (class chain-head metaclass meta-chain-head) cptr
+    (sequence-output (stream sequencer)
+      ((class :vtable chain-head :slots)
+       (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
+	       metaclass
+	       (if (sod-class-direct-superclasses meta-chain-head)
+		   (sod-class-nickname meta-chain-head)
+		   nil))))))
+
+(defmethod hook-output progn ((boff base-offset) (reason (eql :h))
+				   sequencer)
+  (with-slots (class chain-head) boff
+    (sequence-output (stream sequencer)
+      ((class :vtable chain-head :slots)
+       (write-line "  size_t _base;" stream)))))
+
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
+				   sequencer)
+  (with-slots (class chain-head target-head) choff
+    (sequence-output (stream sequencer)
+      ((class :vtable chain-head :slots)
+       (format stream "  ptrdiff_t _off_~A;~%"
+	       (sod-class-nickname target-head))))))
+
+;;;--------------------------------------------------------------------------
+;;; Implementation output.
+
+(defvar *instance-class*)
+
+(defmethod hook-output progn ((class sod-class) (reason (eql :c))
+				   sequencer)
+  (sequence-output (stream sequencer)
+
+    :constraint
+    ((:classes :start)
+     (class :banner)
+     (class :direct-methods :start) (class :direct-methods :end)
+     (class :effective-methods)
+     (class :vtables :start) (class :vtables :end)
+     (class :object :prepare) (class :object :start) (class :object :end)
+     (:classes :end))
+
+    ((class :banner)
+     (banner (format nil "Class ~A" class) stream))
+
+    ((class :object :start)
+     (format stream "~
+/* The class object. */
+const struct ~A ~A__classobj = {~%"
+	     (ilayout-struct-tag (sod-class-metaclass class))
+	     class))
+    ((class :object :end)
+     (format stream "};~2%")))
+
+  (let ((*instance-class* class))
+    (hook-output (sod-class-ilayout (sod-class-metaclass class))
+		      'class
+		      sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Direct methods.
+
+(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
+				   sequencer)
+  (with-slots (class body) method
+    (unless body
+      (return-from hook-output))
+    (sequence-output (stream sequencer)
+      ((class :direct-method method :start)
+       (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
+	       (mapcar #'argument-name
+		       (c-function-arguments (sod-method-next-method-type
+					      method)))))
+      ((class :direct-method method :end)
+       (format stream "#undef CALL_NEXT_METHOD~%")))))
+
+(defmethod hook-output progn ((method sod-method) (reason (eql :c))
+				   sequencer)
+  (with-slots (class body) method
+    (unless body
+      (return-from hook-output))
+    (sequence-output (stream sequencer)
+      :constraint ((class :direct-methods :start)
+		   (class :direct-method method :start)
+		   (class :direct-method method :body)
+		   (class :direct-method method :end)
+		   (class :direct-methods :end))
+      ((class :direct-method method :body)
+       (pprint-c-type (sod-method-function-type method)
+		      stream
+		      (sod-method-function-name method))
+       (format stream "~&{~%")
+       (write body :stream stream :pretty nil :escape nil)
+       (format stream "~&}~%"))
+      ((class :direct-method method :end)
+       (terpri stream)))))
+
+(defmethod hook-output progn ((method basic-effective-method) (reason (eql :c))
+			      sequencer)
+  (with-slots (class functions) method
+    (sequence-output (stream sequencer)
+      ((class :effective-methods)
+       (dolist (func functions)
+	 (write func :stream stream :escape nil :circle nil))))))
+
+;;;--------------------------------------------------------------------------
+;;; Vtables.
+
+(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
+				   sequencer)
+  (with-slots (class chain-head chain-tail) vtable
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtables :start)
+		   (class :vtable chain-head :start)
+		   (class :vtable chain-head :end)
+		   (class :vtables :end))
+      ((class :vtable chain-head :start)
+       (format stream "/* Vtable for ~A chain. */~@
+		       static const struct ~A ~A = {~%"
+	       chain-head
+	       (vtable-struct-tag chain-tail chain-head)
+	       (vtable-name chain-tail chain-head)))
+      ((class :vtable chain-head :end)
+       (format stream "};~2%")))))
+
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
+				   sequencer)
+  (with-slots (class chain-head metaclass meta-chain-head) cptr
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtable chain-head :start)
+		   (class :vtable chain-head :class-pointer metaclass)
+		   (class :vtable chain-head :end))
+      ((class :vtable chain-head :class-pointer metaclass)
+       (format stream "  &~A__classobj.~A.~A,~%"
+	       (sod-class-metaclass class)
+	       (sod-class-nickname meta-chain-head)
+	       (sod-class-nickname metaclass))))))
+
+(defmethod hook-output progn ((boff base-offset) (reason (eql :c))
+				   sequencer)
+  (with-slots (class chain-head) boff
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtable chain-head :start)
+		   (class :vtable chain-head :base-offset)
+		   (class :vtable chain-head :end))
+      ((class :vtable chain-head :base-offset)
+       (format stream "  offsetof(struct ~A, ~A),~%"
+	       (ilayout-struct-tag class)
+	       (sod-class-nickname chain-head))))))
+
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
+				   sequencer)
+  (with-slots (class chain-head target-head) choff
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtable chain-head :start)
+		   (class :vtable chain-head :chain-offset target-head)
+		   (class :vtable chain-head :end))
+      ((class :vtable chain-head :chain-offset target-head)
+       (format stream "  SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+	       (ilayout-struct-tag class)
+	       (sod-class-nickname chain-head)
+	       (sod-class-nickname target-head))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
+				   sequencer)
+  (with-slots (class subclass chain-head) vtmsgs
+    (sequence-output (stream sequencer)
+      :constraint ((subclass :vtable chain-head :start)
+		   (subclass :vtable chain-head :vtmsgs class :start)
+		   (subclass :vtable chain-head :vtmsgs class :slots)
+		   (subclass :vtable chain-head :vtmsgs class :end)
+		   (subclass :vtable chain-head :end))
+      ((subclass :vtable chain-head :vtmsgs class :start)
+       (format stream "  { /* Method entries for ~A messages. */~%"
+	       class))
+      ((subclass :vtable chain-head :vtmsgs class :end)
+       (format stream "  },~%")))))
+
+(defmethod hook-output progn ((entry method-entry) (reason (eql :c))
+				   sequencer)
+  (with-slots (method chain-head chain-tail) entry
+    (let* ((message (effective-method-message method))
+	   (class (effective-method-class method))
+	   (super (sod-message-class message)))
+      (sequence-output (stream sequencer)
+	((class :vtable chain-head :vtmsgs super :slots)
+	 (format stream "    ~A,~%"
+		 (method-entry-function-name method chain-head)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Filling in the class object.
+
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
+				   sequencer)
+  (with-slots (class chain-head) ichain
+    (sequence-output (stream sequencer)
+      :constraint ((*instance-class* :object :start)
+		   (*instance-class* :object chain-head :ichain :start)
+		   (*instance-class* :object chain-head :ichain :end)
+		   (*instance-class* :object :end))
+      ((*instance-class* :object chain-head :ichain :start)
+       (format stream "  { { /* ~A ichain */~%"
+	       (sod-class-nickname chain-head)))
+      ((*instance-class* :object chain-head :ichain :end)
+       (format stream "  } },~%")))))
+
+(defmethod hook-output progn ((islots islots) (reason (eql 'class))
+				   sequencer)
+  (with-slots (class) islots
+    (let ((chain-head (sod-class-chain-head class)))
+      (sequence-output (stream sequencer)
+	:constraint ((*instance-class* :object chain-head :ichain :start)
+		     (*instance-class* :object class :slots :start)
+		     (*instance-class* :object class :slots)
+		     (*instance-class* :object class :slots :end)
+		     (*instance-class* :object chain-head :ichain :end))
+	((*instance-class* :object class :slots :start)
+	 (format stream "      { /* Class ~A */~%" class))
+	((*instance-class* :object class :slots :end)
+	 (format stream "      },~%"))))))
+
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
+				   sequencer)
+  (with-slots (class chain-head chain-tail) vtptr
+    (sequence-output (stream sequencer)
+      :constraint ((*instance-class* :object chain-head :ichain :start)
+		   (*instance-class* :object chain-head :vtable)
+		   (*instance-class* :object chain-head :ichain :end))
+      ((*instance-class* :object chain-head :vtable)
+       (format stream "      &~A__vtable_~A,~%"
+	       class (sod-class-nickname chain-head))))))
+
+(defgeneric find-class-initializer (slot class)
+  (:method ((slot effective-slot) (class sod-class))
+    (let ((dslot (effective-slot-direct-slot slot)))
+      (or (some (lambda (super)
+		  (find dslot (sod-class-class-initializers super)
+			:test #'sod-initializer-slot))
+		(sod-class-precedence-list class))
+	  (effective-slot-initializer slot)))))
+
+(defgeneric output-class-initializer (slot instance stream)
+  (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
+    (let ((func (effective-slot-initializer-function slot)))
+      (if func
+	  (format stream "        ~A,~%" (funcall func instance))
+	  (call-next-method))))
+  (:method ((slot effective-slot) (instance sod-class) stream)
+    (let ((init (find-class-initializer slot instance)))
+      (ecase (sod-initializer-value-kind init)
+	(:simple (format stream "        ~A,~%"
+			 (sod-initializer-value-form init)))
+	(:compound (format stream "        ~@<{ ~;~A~; },~:>~%"
+			 (sod-initializer-value-form init)))))))
+
+(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
+				   sequencer)
+  (let ((instance *instance-class*)
+	(func (effective-slot-prepare-function slot)))
+    (when func
+      (sequence-output (stream sequencer)
+	((instance :object :prepare)
+	 (funcall func instance stream))))))
+
+(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
+				   sequencer)
+  (with-slots (class (dslot slot)) slot
+    (let ((instance *instance-class*)
+	  (super (sod-slot-class dslot)))
+      (sequence-output (stream sequencer)
+	((instance :object super :slots)
+	 (output-class-initializer slot instance stream))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..60da8ea
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,31 @@
+;;; -*-lisp-*-
+;;;
+;;; Package definition for SOD utility
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:sod
+  (:use #:common-lisp
+	#:sod-utilities
+	#:sod-parser))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parse-c-types.lisp b/src/parse-c-types.lisp
new file mode 100644
index 0000000..15de8b0
--- /dev/null
+++ b/src/parse-c-types.lisp
@@ -0,0 +1,314 @@
+;;; -*-lisp-*-
+;;;
+;;; Parser for C types
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Declaration specifiers.
+
+(defclass declspec ()
+  ((label :type keyword :initarg :label :reader ds-label)
+   (name :type string :initarg :name :reader ds-name)
+   (kind :type (member type sign size qualifier tagged)
+	 :initarg :kind :reader ds-kind)))
+
+(defmethod shared-initialize :after ((ds declspec) slot-names &key)
+  (default-slot (ds 'name slot-names)
+    (string-downcase (ds-label ds))))
+
+(defclass declspecs ()
+  ((type :initform nil :initarg :type :reader ds-type)
+   (sign :initform nil :initarg :sign :reader ds-sign)
+   (size :initform nil :initarg :size :reader ds-size)
+   (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers)))
+
+(defparameter *declspec-map*
+  (let ((map (make-hash-table :test #'equal)))
+    (dolist (item '((type :void :char :int :float :double)
+		    (size :short :long (:long-long "long long"))
+		    (sign :signed :unsigned)
+		    (qualifier :const :restrict :volatile)
+		    (tagged :enum :struct :union)))
+      (let ((kind (car item)))
+	(dolist (spec (cdr item))
+	  (multiple-value-bind (label name)
+	      (if (consp spec)
+		  (values (car spec) (cadr spec))
+		  (values spec (string-downcase spec)))
+	    (let ((ds (make-instance 'declspec
+				     :label label :name name :kind kind)))
+	      (setf (gethash name map) ds
+		    (gethash label map) ds))))))
+    map))
+
+(defmethod ds-label ((ty c-type)) :c-type)
+(defmethod ds-name ((ty c-type)) (princ-to-string ty))
+(defmethod ds-kind ((ty c-type)) 'type)
+
+(defparameter *good-declspecs*
+  '(((:int) (:signed :unsigned) (:short :long :long-long))
+    ((:char) (:signed :unsigned) ())
+    ((:double) () (:long))
+    (t () ()))
+  "List of good collections of declaration specifiers.
+
+   Each item is a list of the form (TYPES SIGNS SIZES).  Each of TYPES, SIGNS
+   and SIZES is either a list of acceptable specifiers of the appropriate
+   kind, or T, which matches any specifier.")
+
+(defun scan-declspec (scanner)
+  "Scan a DECLSPEC from SCANNER.
+
+   Value on success is either a DECLSPEC object or a C-TYPE object."
+
+  ;; Turns out to be easier to do this by hand.
+  (let ((ds (and (eq (token-type scanner) :id)
+		 (let ((kw (token-value scanner)))
+		   (or (gethash kw *declspec-map*)
+		       (gethash kw *module-type-map*))))))
+    (cond ((not ds)
+	   (values (list :declspec) nil nil))
+	  ((eq (ds-kind ds) :tagged)
+	   (scanner-step scanner)
+	   (if (eq (token-type scanner) :id)
+	       (let ((ty (make-c-tagged-type (ds-label ds)
+					     (token-value scanner))))
+		 (scanner-step scanner)
+		 (values ty t t))
+	       (values :tag nil t)))
+	  (t
+	   (scanner-step scanner)
+	   (values ds t t)))))
+
+(defun good-declspecs-p (specs)
+  "Are SPECS a good collection of declaration specifiers?"
+  (let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs))))
+    (some (lambda (it)
+	    (every (lambda (spec pat)
+		     (or (eq pat t) (null spec)
+			 (member (ds-label spec) pat)))
+		   speclist it))
+	  *good-declspecs*)))
+
+(defun combine-declspec (specs ds)
+  "Combine the declspec DS with the existing SPECS.
+
+   Returns new DECLSPECS if they're OK, or `nil' if not.  The old SPECS are
+   not modified."
+  (let* ((kind (ds-kind ds))
+	 (old (slot-value specs kind)))
+    (multiple-value-bind (ok new)
+	(case kind
+	  (qualifier (values t (adjoin ds old)))
+	  (size (cond ((not old) (values t ds))
+		      ((and (eq (ds-label old) :long) (eq ds old))
+		       (values t (gethash :long-long *declspec-map*)))
+		      (t (values nil nil))))
+	  (t (values (not old) ds)))
+      (if ok
+	  (let ((copy (copy-instance specs)))
+	    (setf (slot-value copy kind) new)
+	    (and (good-declspecs-p copy) copy))
+	  nil))))
+
+(defun scan-and-merge-declspec (scanner specs)
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (if-parse (:consumedp consumedp) (scan-declspec scanner)
+      (aif (combine-declspec specs it)
+	   (values it t consumedp)
+	   (values (list :declspec) nil consumedp)))))
+
+(defun declspecs-type (specs)
+  (let ((type (ds-type specs))
+	(size (ds-size specs))
+	(sign (ds-sign specs)))
+    (cond ((or type size sign)
+	   (when (and (eq (ds-label sign) :signed)
+		      (eq (ds-label type) :int))
+	     (setf sign nil))
+	   (cond ((and (or (null type) (eq (ds-label type) :int))
+		       (or size sign))
+		  (setf type nil))
+		 ((null type)
+		  (setf type (gethash :int *declspec-map*))))
+	   (make-simple-type (format nil "~{~@[~A~^ ~]~}"
+				     (mapcar #'ds-label
+					     (remove nil
+						     (list sign size type))))
+			     (mapcar #'ds-label (ds-qualifiers specs))))
+	  (t
+	   nil))))
+
+(defun parse-c-type (scanner)
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (if-parse (:result specs :consumedp cp)
+	      (many (specs (make-instance 'declspecs) it :min 1)
+		(scan-and-merge-declspec scanner specs))
+	      (let ((type (declspecs-type specs)))
+		(if type (values type t cp)
+		    (values (list :declspec) nil cp))))))
+
+
+
+
+
+
+
+
+
+
+
+  ;; This is rather complicated, but extracting all the guts into a structure
+  ;; and passing it around makes matters worse rather than better.
+  ;;
+  ;; We categorize declaration specifiers into four kinds.
+  ;;
+  ;;   * `Type specifiers' describe the actual type, whether that's integer,
+  ;;	 character, floating point, or some tagged or user-named type.
+  ;;
+  ;;   * `Size specifiers' distinguish different sizes of the same basic
+  ;;	 type.  This is how we tell the difference between `int' and `long'.
+  ;;
+  ;;   * `Sign specifiers' distinguish different signednesses.  This is how
+  ;;	 we tell the difference between `int' and `unsigned'.
+  ;;
+  ;;   * `Qualifiers' are our old friends `const', `restrict' and `volatile'.
+  ;;
+  ;; These groupings are for our benefit here, in determining whether a
+  ;; particular declaration specifier is valid in the current context.  We
+  ;; don't accept `function specifiers' (of which the only current example is
+  ;; `inline') since it's meaningless to us.
+  ;;
+  ;; Our basic strategy is to parse declaration specifiers while they're
+  ;; valid, and keep track of what we've read.  When we've reached the end,
+  ;; we'll convert what we've got into a `canonical form', and then convert
+  ;; that into a C type object of the appropriate kind.
+
+  (let ((specs (make-instance 'declspecs)))
+    
+
+  (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
+    (labels ((goodp (ty sg sz)
+	       "Are (TY SG SZ) a good set of declaration specifiers?"
+	       (some (lambda (it)
+		       (every (lambda (spec pat)
+				(or (eq pat t) (eq spec nil)
+				    (member spec pat)))
+			      decls it))
+		     *good-declspecs*))
+
+	     (scan-declspec ()
+	       "Scan a declaration specifier."
+	       (flet ((win (value &optional (consumedp t))
+			(when consumedp (scanner-step scanner))
+			(return-from scan-declspec
+			  (values value t consumedp)))
+		      (lose (wanted &optional (consumedp nil))
+			(values wanted nil consumedp)))
+		 (unless (eq (token-type scanner) :id) (lose :declspec))
+		 (let* ((id (token-value scanner))
+			(ds (or (gethash id *declspec-map*)
+				(gethash id *module-type-map*))))
+		   (unless ds (lose :declspec))
+		   (let ((label (ds-label ds)))
+		     (ecase (ds-kind ds)
+		       (:qualifier
+			(push (ds-label ds) quals)
+			(win ds))
+		       (:size
+			(cond ((and (not size) (goodp type label sign))
+			       (setf size label)
+			       (win ds))
+			      (t
+			       (lose :declspec))))
+		       (:sign
+			(cond ((and (not sign) (goodp type size label))
+			       (setf sign label)
+			       (win ds))
+			      (t
+			       (lose :declspec))))
+		       (:type
+			(when (and (eq type :long) (eq label :long))
+			  (setf label :long-long))
+			(cond ((and (or (not type) (eq type :long))
+				    (goodp label size sign))
+			       (setf type label)
+			       (win ds))
+			      (t
+			       (lose :declspec))))
+		       (:tagged
+			(unless (and (not type) (goodp label size sign))
+			  (lose :declspec))
+			(scanner-step scan)
+			(unless (eq (token-type scanner) :id)
+			  (lose :tagged t))
+			(setf type
+			      (make-c-tagged-type label
+						  (token-value scanner)))
+			(win type))))))))
+
+      (with-parser-context (token-scanner-context :scanner scanner)
+	(many (nil nil nil :min 1)
+	  (scan-declspec))
+
+
+
+
+  (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
+    (labels ((check (ty sz sg)
+	       (case ty
+		 ((nil :int) t)
+		 (:char (null sz))
+		 (:double (and (null sg) (or (null sz) (eq sz :long))))
+		 (t (and (null sg) (null sz)))))
+	     (set-type (ty)
+	       (when ))
+	     (set-size (sz)
+	       (when (and (eq sz :long) (eq size :long))
+		 (setf sz :long-long))
+	       (when (and (or (null size) (eq sz :long-long))
+			  (check type sz sign))
+		 (setf size sz)))
+	     (set-sign (sg)
+	       (when (and (null sign) (check type size sg))
+		 (setf sign sg)))
+	     (parse-declspec ()
+	       (multiple-value-bind (kind value)
+		   (categorize-declspec scanner)
+		 (if (ecase kind
+		       (:qualifier (push value quals))
+		       (:type (and (null type) (check value size sign)
+				   (setf type value)))
+		       (:size (let ((sz (if (and (eq size :long)
+						 (eq value :long))
+					    :long-long value)))
+				(and (or (null size) (eq sz :long-long))
+				     (check type value sign)
+				     (setf size value))))
+		       (:sign (and (null sign) (check type size value)
+				   (setf sign value)))
+		       
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parse-lexical.lisp b/src/parse-lexical.lisp
new file mode 100644
index 0000000..9fe6bb8
--- /dev/null
+++ b/src/parse-lexical.lisp
@@ -0,0 +1,198 @@
+;;; -*-lisp-*-
+;;;
+;;; Lexical analysis for input parser
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Class definition.
+
+(export 'sod-token-scanner)
+(defclass sod-token-scanner (token-scanner)
+  ((char-scanner :initarg :char-scanner :reader token-scanner-char-scanner))
+  (:documentation
+   "A token scanner for SOD input files.
+
+   Not a lot here, apart from a character scanner to read from and the
+   standard token scanner infrastructure."))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun show-char (stream char &optional colonp atsignp)
+  "Format CHAR to STREAM in a readable way.
+
+   Usable in `format''s ~/.../ command."
+  (declare (ignore colonp atsignp))
+  (cond ((null char) (write-string "<eof>" stream))
+	((and (graphic-char-p char) (char/= char #\space))
+	 (format stream "`~C'" char))
+	(t (format stream "<~(~:C~)>" char))))
+
+(defun scan-comment (scanner)
+  "Scan a comment (either `/* ... */' or `// ...') from SCANNER.
+
+   The result isn't interesting."
+  (with-parser-context (character-scanner-context :scanner scanner)
+    (parse (or (and "/*"
+		    (and (skip-many ()
+			   (and (skip-many () (not #\*))
+				(label "*/" (skip-many (:min 1) #\*)))
+			   (not #\/))
+			 #\/))
+	       (and "//"
+		    (skip-many () (not #\newline))
+		    (? #\newline))))))
+
+;;;--------------------------------------------------------------------------
+;;; Error reporting.
+
+(export 'syntax-error)
+(defun syntax-error (scanner expected &key (continuep t))
+  "Signal a (maybe) continuable syntax error."
+  (labels ((show-token (type value)
+	     (if (characterp type)
+		 (format nil "~/sod::show-char/" type)
+		 (case type
+		   (:id (format nil "<identifier~@[ `~A'~]>" value))
+		   (:string "<string-literal>")
+		   (:char "<character-literal>")
+		   (:eof "<end-of-file>")
+		   (:ellipsis "`...'")
+		   (t (format nil "<? ~S~@[ ~S~]>" type value)))))
+	   (show-expected (thing)
+	     (cond ((atom thing) (show-token thing nil))
+		   ((eq (car thing) :id)
+		    (format nil "`~A'" (cadr thing)))
+		   (t (format nil "<? ~S>" thing)))))
+    (funcall (if continuep #'cerror* #'error)
+	     "Syntax error: ~
+	      expected ~{#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
+	      but found ~A"
+	     (mapcar #'show-expected expected)
+	     (show-token (token-type scanner) (token-value scanner)))))
+
+;;;--------------------------------------------------------------------------
+;;; Token scanner protocol implementation.
+
+(defmethod scanner-token ((scanner sod-token-scanner))
+  (with-slots (char-scanner line column) scanner
+    (with-parser-context (character-scanner-context :scanner char-scanner)
+
+      (flet ((scan-digits (&key (radix 10) (min 1) (init 0))
+	       ;; Scan an return a sequence of digits.
+	       (parse (many (acc init (+ (* acc radix) it) :min min)
+			(label (list :digit radix)
+			       (filter (lambda (ch)
+					 (digit-char-p ch radix)))))))
+
+	     (lexer-error (expected consumedp)
+	       ;; Report a lexical error.
+	       (cerror* "Lexical error: ~
+			 expected ~{~#[<bug>~;~A~;~A or ~A~;:~A, ~]~} ~
+			 but found ~/sod::show-char/~
+			 ~@[ at ~A~]"
+			(mapcar (lambda (exp)
+				  (typecase exp
+				    (character
+				     (format nil "~/sod::show-char/" exp))
+				    (string (format nil "`~A'" exp))
+				    ((cons (eql :digit) *)
+				     (format nil "<radix-~A digit>"
+					     (cadr exp)))
+				    ((eql :eof) "<end-of-file>")
+				    ((eql :any) "<character>")
+				    (t (format nil "<? ~S>" exp))))
+				expected)
+			(and (not (scanner-at-eof-p char-scanner))
+			     (scanner-current-char char-scanner))
+			(and consumedp (file-location char-scanner)))))
+
+	;; Skip initial junk, and remember the place.
+	(loop
+	  (setf (scanner-line scanner) (scanner-line char-scanner)
+		(scanner-column scanner) (scanner-column char-scanner))
+	  (cond-parse (:consumedp cp :expected exp)
+	    ((satisfies whitespace-char-p) (parse :whitespace))
+	    ((scan-comment char-scanner))
+	    (t (if cp (lexer-error exp cp) (return)))))
+
+	;; Now parse something.
+	(cond-parse (:consumedp cp :expected exp)
+
+	  ;; Alphanumerics mean we read an identifier.
+	  ((or #\_ (satisfies alpha-char-p))
+	   (values :id (with-output-to-string (out)
+			 (write-char it out)
+			 (parse (many (nil nil (write-char it out))
+				  (or #\_ (satisfies alphanumericp)))))))
+
+	  ;; Quotes introduce a literal.
+	  ((seq ((quote (or #\" #\'))
+		 (contents (many (out (make-string-output-stream)
+				      (progn (write-char it out) out)
+				      :final (get-output-stream-string out))
+			     (or (and #\\ :any) (not quote))))
+		 (nil (char quote)))
+	     (ecase quote
+	       (#\" contents)
+	       (#\' (case (length contents)
+		      (1 (char contents 0))
+		      (0 (cerror* "Empty character literal") #\?)
+		      (t (cerror* "Too many characters in literal")
+			 (char contents 0))))))
+	   (values (etypecase it
+		     (character :char)
+		     (string :string))
+		   it))
+
+	  ;; Zero introduces a chosen-radix integer.
+	  ((and #\0
+		(or (and (or #\b #\B) (scan-digits :radix 2))
+		    (and (or #\o #\O) (scan-digits :radix 8))
+		    (and (or #\x #\X) (scan-digits :radix 16))
+		    (scan-digits :radix 8 :min 0)))
+	   (values :int it))
+
+	  ;; Any other digit forces radix-10.
+	  ((seq ((d (filter digit-char-p))
+		 (i (scan-digits :radix 10 :min 0 :init d)))
+	     i)
+	   (values :int it))
+
+	  ;; Some special punctuation sequences are single tokens.
+	  ("..." (values :ellipsis nil))
+
+	  ;; Any other character is punctuation.
+	  (:any (values it nil))
+
+	  ;; End of file means precisely that.
+	  (:eof (values :eof nil))
+
+	  ;; Report errors and try again.  Because we must have consumed some
+	  ;; input in order to get here (we've matched both :any and :eof) we
+	  ;; must make progress on every call.
+	  (t (assert cp) (lexer-error exp cp) (scanner-token scanner)))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-floc.lisp b/src/parser/impl-floc.lisp
new file mode 100644
index 0000000..3fb6a5e
--- /dev/null
+++ b/src/parser/impl-floc.lisp
@@ -0,0 +1,47 @@
+;;; -*-lisp-*-
+;;;
+;;; Implementation of file-location protocol
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; File location objects.
+
+(let ((null-file-location (make-file-location nil nil nil)))
+  (defmethod file-location ((thing t)) null-file-location))
+
+(defmethod file-location ((stream stream))
+  (make-file-location (stream-pathname stream) nil nil))
+
+(defmethod print-object ((object file-location) stream)
+  (maybe-print-unreadable-object (object stream :type t)
+    (format stream "~:[<unknown>~;~:*~A~]~@[:~D~]~@[:~D~]"
+	    (file-location-filename object)
+	    (file-location-line object)
+	    (file-location-column object))))
+
+(defmethod make-load-form ((object file-location) &optional environment)
+  (make-load-form-saving-slots object :environment environment))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-parser-expr.lisp b/src/parser/impl-parser-expr.lisp
new file mode 100644
index 0000000..b5c1b57
--- /dev/null
+++ b/src/parser/impl-parser-expr.lisp
@@ -0,0 +1,219 @@
+;;; -*-lisp-*-
+;;;
+;;; Parsers for expressions with binary operators
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol implementation.
+
+(defclass expression-parse-state ()
+  ((opstack :initform nil :type list)
+   (valstack :initform nil :type list)
+   (nesting :initform 0 :type fixnum))
+  (:documentation
+   "State for the expression parser.  Largely passive."))
+
+(defmethod push-value (value (state expression-parse-state))
+  (with-slots (valstack) state
+    (push value valstack)))
+
+(defmethod push-operator (operator (state expression-parse-state))
+  (with-slots (opstack) state
+    (loop
+      (when (null opstack) (return))
+      (let ((head (car opstack)))
+	(ecase (operator-push-action head operator)
+	  (:push (return))
+	  (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~
+			    operators aren't associative"
+			   head operator))
+	  (:apply (apply-operator head state)
+		  (setf opstack (cdr opstack))))))
+    (push operator opstack)))
+
+(defgeneric apply-pending-operators (state)
+  (:documentation
+   "Apply all of the pending operators to their arguments.
+
+   The return value is the final result of the parse.  By the time all of the
+   operators have been applied, of course, there ought to be exactly one
+   operand remaining.")
+  (:method ((state expression-parse-state))
+    (with-slots (opstack valstack) state
+      (dolist (operator opstack)
+	(apply-operator operator state))
+      (assert (and (consp valstack) (null (cdr valstack))))
+      (pop valstack))))
+
+;;;--------------------------------------------------------------------------
+;;; Basic operator implementation.
+
+(defmethod operator-push-action (left right)
+  (let ((lprec (operator-right-precedence left))
+	(rprec (operator-left-precedence right)))
+    (cond ((< lprec rprec) :push)
+	  ((> lprec rprec) :apply)
+	  (t (let ((lassoc (operator-associativity left))
+		   (rassoc (operator-associativity right)))
+	       (cond ((not (eq lassoc rassoc))
+		      (cerror* "Parse error: ... ~A ... ~A ...: ~
+				inconsistent associativity: ~
+				~(~A~) versus ~(~A~))"
+			       left right
+			       (or lassoc "none") (or rassoc "none"))
+		      :apply)
+		     ((not lassoc)
+		      (cerror* "Parse error: ... ~A ... ~A ...: ~
+				operators are not associative"
+			       left right)
+		      :apply)
+		     ((eq lassoc :left) :apply)
+		     ((eq lassoc :right) :push)
+		     (t (error "Invalid associativity ~S ~
+				for operators ~A and ~A"
+			       lassoc left right))))))))
+
+(defmethod print-object ((operator simple-operator) stream)
+  (maybe-print-unreadable-object (operator stream :type t)
+    (princ (operator-name operator) stream)))
+
+(defmethod shared-initialize :after
+    ((operator simple-binary-operator) slot-names &key)
+  (when (slot-boundp operator 'lprec)
+    (default-slot (operator 'rprec slot-names)
+      (slot-value operator 'lprec))))
+
+(defmethod shared-initialize :after
+    ((operator simple-binary-operator) slot-names &key)
+  (when (slot-boundp operator 'lprec)
+    (default-slot (operator 'rprec slot-names)
+      (slot-value operator 'lprec))))
+
+(defmethod push-operator
+    ((operator prefix-operator) (state expression-parse-state))
+
+  ;; It's not safe to apply stacked operators here.  Already-stacked prefix
+  ;; operators won't have their operands yet, so we'll end up in an
+  ;; inconsistent state.
+  (with-slots (opstack) state
+    (push operator opstack)))
+
+(defmethod apply-operator
+    ((operator simple-unary-operator) (state expression-parse-state))
+  (with-slots (function) operator
+    (with-slots (valstack) state
+      (assert (not (null valstack)))
+      (push (funcall function (pop valstack)) valstack))))
+
+(defmethod apply-operator
+    ((operator simple-binary-operator) (state expression-parse-state))
+  (with-slots (function) operator
+    (with-slots (valstack) state
+      (assert (not (or (null valstack)
+		       (null (cdr valstack)))))
+      (let ((second (pop valstack))
+	    (first (pop valstack)))
+	(push (funcall function first second) valstack)))))
+
+;;;--------------------------------------------------------------------------
+;;; Parenthesis protocol implementation.
+
+(defmethod push-operator :after
+    ((paren open-parenthesis) (state expression-parse-state))
+  (with-slots (nesting) state
+    (incf nesting)))
+
+(defmethod push-operator
+    ((paren close-parenthesis) (state expression-parse-state))
+  (with-slots (opstack nesting) state
+    (with-slots (tag) paren
+      (flet ((fail ()
+	       (cerror* "Parse error: spurious `~A'" tag)
+	       (return-from push-operator)))
+	(loop
+	  (when (null opstack) (fail))
+	  (let ((head (car opstack)))
+	    (cond ((not (typep head 'open-parenthesis))
+		   (apply-operator head state))
+		  ((not (eq (slot-value head 'tag) tag))
+		   (fail))
+		  (t
+		   (return)))
+	    (setf opstack (cdr opstack))))
+	(setf opstack (cdr opstack))
+	(decf nesting)))))
+
+(defmethod apply-operator
+    ((paren open-parenthesis) (state expression-parse-state))
+  (with-slots (tag) paren
+    (cerror* "Parse error: missing `~A'" tag)))
+
+(defmethod operator-push-action (left (right open-parenthesis))
+  :push)
+
+(defmethod operator-push-action ((left open-parenthesis) right)
+  :push)
+
+;;;--------------------------------------------------------------------------
+;;; Main expression parser implementation.
+
+(defun parse-expression (p-operand p-binop p-preop p-postop)
+  (let ((state (make-instance 'expression-parse-state))
+	(consumed-any-p nil))
+
+    (labels ((fail (expected)
+	       (return-from parse-expression
+		 (values expected nil consumed-any-p)))
+
+	     (parse (parser)
+	       (unless parser
+		 (return-from parse (values nil nil)))
+	       (multiple-value-bind (value winp consumedp)
+		   (funcall parser (plusp (slot-value state 'nesting)))
+		 (when consumedp (setf consumed-any-p t))
+		 (unless (or winp (not consumedp)) (fail value))
+		 (values value winp)))
+
+	     (get-operand ()
+	       (loop (multiple-value-bind (value winp) (parse p-preop)
+		       (unless winp (return))
+		       (push-operator value state)))
+	       (multiple-value-bind (value winp) (parse p-operand)
+		 (unless winp (fail value))
+		 (push-value value state))
+	       (loop (multiple-value-bind (value winp) (parse p-postop)
+		       (unless winp (return))
+		       (push-operator value state)))))
+
+      (get-operand)
+      (loop
+	(multiple-value-bind (value winp) (parse p-binop)
+	  (unless winp (return))
+	  (push-operator value state))
+	(get-operand))
+
+      (values (apply-pending-operators state) t consumed-any-p))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-parser-plug.lisp b/src/parser/impl-parser-plug.lisp
new file mode 100644
index 0000000..9af84f6
--- /dev/null
+++ b/src/parser/impl-parser-plug.lisp
@@ -0,0 +1,31 @@
+;;; -*-lisp-*-
+;;;
+;;; Pluggable extensable parser
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;;
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-parser.lisp b/src/parser/impl-parser.lisp
new file mode 100644
index 0000000..0a7d667
--- /dev/null
+++ b/src/parser/impl-parser.lisp
@@ -0,0 +1,166 @@
+;;; -*-lisp-*-
+;;;
+;;; Parser protocol implementation.
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Hairy functions used by parser syntax expanders.
+
+(declaim (inline %many))
+(defun %many (update final parser &key (min 0) max)
+  "Helper function for the `many' parser syntax.
+
+   This deals with simple repetition, without separators.  See the parser
+   syntax documentation for details."
+
+  (let ((consumed-any-p nil))
+    (do ((i 0 (1+ i)))
+	((and max (>= i max)))
+      (multiple-value-bind (value winp consumep) (funcall parser)
+	(when consumep (setf consumed-any-p t))
+	(cond (winp (funcall update value))
+	      ((or consumep (< i min))
+	       (return-from %many (values value nil consumed-any-p)))
+	      (t (return)))))
+    (values (funcall final) t consumed-any-p)))
+
+(defun %many-sep (update final parser sep &key (min 1) max (commitp t))
+  "Helper function for the `many' parser syntax.
+
+   This deals with the hairy separator and commit stuff.  See the parser
+   syntax documentation for details."
+
+  (let ((consumed-any-p nil)
+	(i 0))
+    (block nil
+      (flet ((sep ()
+	       (multiple-value-bind (value winp consumep) (funcall sep)
+		 (when consumep (setf consumed-any-p t))
+		 (unless winp
+		   (if (and (>= i min) (not consumep)) (return)
+		       (return-from %many-sep
+			 (values value nil consumed-any-p))))))
+
+	     (main (mustp)
+	       (multiple-value-bind (value winp consumep) (funcall parser)
+		 (when consumep (setf consumed-any-p t))
+		 (cond (winp (funcall update value))
+		       ((or mustp consumep (< i min))
+			(return-from %many-sep
+			  (values value nil consumed-any-p)))
+		       (t (return))))
+	       (incf i)))
+
+	(when (eql max 0) (return))
+
+	(main nil)
+
+	(if commitp
+	    (loop (when (and max (>= i max)) (return)) (sep) (main t))
+	    (loop (sep) (when (and max (>= i max)) (return)) (main nil)))))
+
+    (values (funcall final) t consumed-any-p)))
+
+;;;--------------------------------------------------------------------------
+;;; Token parser implementation.
+
+(defmethod parser-at-eof-p ((context token-parser-context))
+  `(eq ,(parser-token-type context) :eof))
+
+;;;--------------------------------------------------------------------------
+;;; Simple list-based parser; useful for testing.
+
+(export 'list-parser)
+(defclass list-parser ()
+  ((var :initarg :var :type symbol :reader parser-var)))
+
+(defmethod parser-at-eof-p ((context list-parser))
+  `(not ,(parser-var context)))
+
+(defmethod parser-capture-place ((context list-parser))
+  `,(parser-var context))
+
+(defmethod parser-restore-place ((context list-parser) place)
+  `(setf ,(parser-var context) ,place))
+
+(defmethod expand-parser-spec ((context list-parser) parser)
+  (if (atom parser)
+      (expand-parser-form context 'quote (list parser))
+      (call-next-method)))
+
+(defparse quote (:context (context list-parser) object)
+  `(if (and ,(parser-var context)
+	    (eql (car ,(parser-var context)) ',object))
+       (progn (pop ,(parser-var context)) (values ',object t t))
+       (values (list ',object) nil nil)))
+
+(defparse type (:context (context list-parser) type)
+  `(if (and ,(parser-var context)
+	    (typep (car ,(parser-var context)) ',type))
+       (values (pop ,(parser-var context)) t t)
+       (values (list ',type) nil nil)))
+
+(defmethod parser-places-must-be-released-p ((context list-parser)) nil)
+
+;;;--------------------------------------------------------------------------
+;;; Simple string-based parser; useful for testing.
+
+(export 'string-parser)
+(defclass string-parser (character-parser-context)
+  ((string :initarg :string :reader parser-string)
+   (index :initarg :index :initform 0 :reader parser-index)
+   (length :initform (gensym "LEN-") :reader parser-length)))
+
+(defmethod wrap-parser ((context string-parser) form)
+  (with-slots (string index length) context
+    `(let* (,@(unless (symbolp string)
+		(let ((s string))
+		  (setf string (gensym "STRING-"))
+		  `((,string ,s))))
+	    ,@(unless (symbolp index)
+		(let ((i index))
+		  (setf index (gensym "INDEX-"))
+		  `((,index ,i))))
+	      (,length (length ,string)))
+       ,form)))
+
+(defmethod parser-at-eof-p ((context string-parser))
+  `(>= ,(parser-index context) ,(parser-length context)))
+
+(defmethod parser-current-char ((context string-parser))
+  `(char ,(parser-string context) ,(parser-index context)))
+
+(defmethod parser-step ((context string-parser))
+  `(incf ,(parser-index context)))
+
+(defmethod parser-capture-place ((context string-parser))
+  `,(parser-index context))
+
+(defmethod parser-restore-place ((context string-parser) place)
+  `(setf ,(parser-index context) ,place))
+
+(defmethod parser-places-must-be-released-p ((context string-parser)) nil)
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-scanner-charbuf.lisp b/src/parser/impl-scanner-charbuf.lisp
new file mode 100644
index 0000000..aaa1b5a
--- /dev/null
+++ b/src/parser/impl-scanner-charbuf.lisp
@@ -0,0 +1,433 @@
+;;; -*-lisp-*-
+;;;
+;;; Efficient buffering character scanner
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Infrastructure types.
+
+(defconstant charbuf-size 4096
+  "Number of characters in a character buffer.")
+
+(deftype charbuf ()
+  "Type of character buffers."
+  `(simple-string ,charbuf-size))
+
+(deftype charbuf-index ()
+  "Type of indices into character buffers."
+  `(integer 0 ,charbuf-size))
+
+(declaim (inline make-charbuf))
+(defun make-charbuf ()
+  "Return a fresh uninitialized character buffer."
+  (make-array charbuf-size :element-type 'character))
+
+(defstruct charbuf-chain-link
+  "A link in the charbuf scanner's buffer chain.
+
+   Usually the scanner doesn't bother maintaining a buffer chain; but if
+   we've rewound to a captured place then we need to be able to retrace our
+   steps on to later buffers.
+
+   It turns out to be easier to have an explicit link to the next structure
+   in the chain than to maintain a spine of cons cells, so we do that; the
+   only other things we need are the buffer itself and its length, which
+   might be shorter than `charbuf-size', e.g., if we hit end-of-file."
+  (next nil :type (or charbuf-chain-link null))
+  (buf nil :type (or charbuf (member nil :eof)) :read-only t)
+  (size 0 :type charbuf-index :read-only t))
+
+(export 'charbuf-scanner-place-p)
+(defstruct charbuf-scanner-place
+  "A captured place we can return to later.
+
+   We remember the buffer-chain link, so that we can retrace our steps up to
+   the present.  We also need the index at which we continue reading
+   characters; and the line and column numbers to resume from."
+  (link nil :type charbuf-chain-link :read-only t)
+  (index 0 :type charbuf-index :read-only t)
+  (line 0 :type fixnum :read-only t)
+  (column 0 :type fixnum :read-only t))
+
+;;;--------------------------------------------------------------------------
+;;; Main class.
+
+(export 'charbuf-scanner)
+(defclass charbuf-scanner (character-scanner)
+  ((stream :initarg :stream :type stream)
+   (buf :initform nil :type (or charbuf (member nil :eof)))
+   (size :initform 0 :type (integer 0 #.charbuf-size))
+   (index :initform 0 :type (integer 0 #.charbuf-size))
+   (captures :initform 0 :type (and fixnum unsigned-byte))
+   (tail :initform nil :type (or charbuf-chain-link null))
+   (unread :initform nil :type (or charbuf-chain-link nil))
+   (filename :initarg :filename :type (or string null)
+	     :reader scanner-filename)
+   (line :initarg line :initform 1 :type fixnum :reader scanner-line)
+   (column :initarg :column :initform 0 :type fixnum :reader scanner-column))
+  (:documentation
+   "An efficient rewindable scanner for character streams.
+
+   The scanner should be used via the parser protocol.  The following notes
+   describe the class's slots and the invariants maintained by the class.
+
+   The scanner reads characters from STREAM.  It reads in chunks,
+   `charbuf-size' characters at a time, into freshly allocated arrays.  At
+   the beginning of time, BUF is nil; and SIZE is 0, indicating that a new
+   buffer needs to be read in; this anomalous situation is remedied during
+   instance initialization.  At all times thereafter:
+
+     * If SIZE > 0 then BUF is a `charbuf' containing characters.
+
+     * (<= 0 INDEX SIZE charbuf-size).
+
+   When the current buffer is finished with, another one is fetched.  If
+   we've rewound the scanner to a captured place, then there'll be a chain of
+   buffers starting at TAIL (which corresponds to the current buffer); and we
+   should use its NEXT buffer when we've finished this one.
+
+   If there is no next buffer then we should acquire a new one and fill it
+   from the input stream.  If there is an outstanding captured place then we
+   must also create a buffer chain entry for this new buffer and link it onto
+   the chain.  If there aren't outstanding captures then we don't need to
+   bother with any of that -- earlier places certainly can't be captured and
+   a capture of the current position can allocate its own buffer chain
+   entry.
+
+   Which leaves us with the need to determine whether there are outstanding
+   captures.  We simply maintain a counter, and rely on the client releasing
+   captured places properly when he's finished.  In practice, this is usually
+   done using the `peek' parser macro so there isn't a problem."))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defgeneric charbuf-scanner-fetch (scanner)
+  (:documentation
+   "Refill the scanner buffer.
+
+   This is an internal method, which is really only a method so that the
+   compiler will optimize slot references.
+
+   Replace the current buffer with the next one, either from the buffer chain
+   (if we're currently rewound) or with a new buffer from the stream."))
+
+(defmethod charbuf-scanner-fetch ((scanner charbuf-scanner))
+  (with-slots (stream buf size index tail captures) scanner
+    (loop
+      (acond
+
+	;; If we've hit the end of the line, stop.
+	((eq buf :eof)
+	 (return nil))
+
+	;; If there's another buffer, we should check it out.
+	((and tail (charbuf-chain-link-next tail))
+	 (setf tail it
+	       buf (charbuf-chain-link-buf it)
+	       size (charbuf-chain-link-size it)
+	       index 0))
+
+	;; No joy: try reading more stuff from the input stream.
+	(t
+	 (let* ((new (make-charbuf))
+		(n (read-sequence new stream :start 0 :end charbuf-size)))
+
+	   ;; If there's nothing coming in then store a magical marker.
+	   (when (zerop n) (setf new :eof))
+
+	   ;; If there's someone watching, link a new entry onto the chain.
+	   ;; There must, under these circumstances, be a `tail'.
+	   (if (plusp captures)
+	       (let ((next (make-charbuf-chain-link :buf new :size n)))
+		 (setf (charbuf-chain-link-next tail) next
+		       tail next))
+	       (setf tail nil))
+
+	   ;; Store the new state.
+	   (setf buf new
+		 size n
+		 index 0))))
+
+      ;; If there's stuff in the current buffer, we're done.
+      (when (< index size)
+	(return t)))))
+
+(export 'charbuf-scanner-map)
+(defgeneric charbuf-scanner-map (scanner func &optional fail)
+  (:documentation
+   "Read characters from the SCANNER's raw buffers.
+
+   This is intended to be an efficient and versatile interface for reading
+   characters from a scanner in bulk.  The FUNC is invoked repeatedly with
+   three arguments: a simple string BUF and two nonnegative fixnums START and
+   END, indicating that the subsequence of BUF between START (inclusive) and
+   END (exclusive) should be processed.  The FUNC returns two values: a
+   generalized boolean DONEP and a nonnegative fixnum USED.  If DONEP is
+   false then USED is ignored: the function has consumed the entire buffer
+   and wishes to read more.  If DONEP is true then the condition (<= START
+   USED END) must hold; the FUNC has consumed the buffer as far as USED
+   (exclusive) and has completed successfully; the values DONEP and `t' are
+   returned as the result of CHARBUF-SCANNER-MAP.
+
+   If end-of-file is encountered before FUNC completes successfully then FAIL
+   is called with no arguments, and CHARBUF-SCANNER-MAP returns whatever
+   FAIL returns.
+
+   Observe that, if FAIL returns a second value of nil, then
+   `charbuf-scanner-map' is usable as a parser expression."))
+
+(defmethod charbuf-scanner-map
+    ((scanner charbuf-scanner) func &optional fail)
+  (with-slots (buf index size) scanner
+    (flet ((offer (buf start end)
+
+	     ;; Pass the buffer to the function, and see what it thought.
+	     (multiple-value-bind (donep used) (funcall func buf start end)
+
+	       ;; Update the position as far as the function read.
+	       (with-slots (line column) scanner
+		 (let ((l line) (c column) (limit (if donep used end)))
+		   (do ((i start (1+ i)))
+		       ((>= i limit))
+		     (setf (values l c)
+			   (update-position (char buf i) l c)))
+		   (setf line l column c)))
+
+	       ;; If the function is finished then update our state and
+	       ;; return.
+	       (when donep
+		 (setf index used)
+		 (when (>= index size)
+		   (charbuf-scanner-fetch scanner))
+		 (return-from charbuf-scanner-map (values donep t))))))
+
+      ;; If there's anything in the current buffer, offer it to the function.
+      (when (< index size)
+	(offer buf index size))
+
+      ;; Repeatedly fetch new buffers and offer them to the function.
+      ;; Because the buffers are fresh, we know that we must process them
+      ;; from the beginning.  Note that `offer' will exit if FUNC has
+      ;; finished, so we don't need to worry about that.
+      (loop
+	(unless (charbuf-scanner-fetch scanner)
+	  (return (if fail (funcall fail) (values nil nil))))
+	(offer buf 0 size)))))
+
+;;;--------------------------------------------------------------------------
+;;; Initialization.
+
+(defmethod shared-initialize :after
+    ((scanner charbuf-scanner) slot-names &key)
+
+  ;; Grab the filename from the underlying stream if we don't have a better
+  ;; guess.
+  (default-slot (scanner 'filename slot-names)
+    (with-slots (stream) scanner
+      (aif (stream-pathname stream) (namestring it) nil)))
+
+  ;; Get ready with the first character.
+  (charbuf-scanner-fetch scanner))
+
+;;;--------------------------------------------------------------------------
+;;; Scanner protocol implementation.
+
+(defmethod scanner-at-eof-p ((scanner charbuf-scanner))
+  (with-slots (buf) scanner
+    (eq buf :eof)))
+
+(defmethod scanner-current-char ((scanner charbuf-scanner))
+  (with-slots (buf index) scanner
+    (schar buf index)))
+
+(defmethod scanner-step ((scanner charbuf-scanner))
+  (with-slots (buf size index line column) scanner
+
+    ;; If there's a current character then update the position from it.  When
+    ;; is there a current character?  When the index is valid.
+    (when (< index size)
+      (setf (values line column)
+	    (update-position (schar buf index) line column)))
+
+    ;; Now move the position on.  If there's still a character left then we
+    ;; win; otherwise fetch another buffer.
+    (or (< (incf index) size)
+	(charbuf-scanner-fetch scanner))))
+
+(defmethod scanner-unread ((scanner charbuf-scanner) char)
+  (with-slots (buf index size unread tail line column) scanner
+    (cond
+
+      ;; First, let's rewind the buffer index.  This isn't going to work if
+      ;; the index is already zero.  (Note that this implies that INDEX is
+      ;; zero in the remaining cases.)
+      ((plusp index)
+       (decf index))
+
+      ;; Plan B.  Maybe we've been here before, in which case we'll have left
+      ;; the appropriate state kicking about already.  Note that, according
+      ;; to the `unread' rules, the character must be the same as last time,
+      ;; so we can just reuse the whole thing unchanged.  Also, note that
+      ;; the NEXT field in UNREAD is not nil due to the way that we construct
+      ;; the link below.
+      ((and unread (eql (charbuf-chain-link-next unread) tail))
+       (setf tail unread  size 1
+	     buf (charbuf-chain-link-buf unread)))
+
+      ;; Nope, we've not been here, at least not recently.  We'll concoct a
+      ;; new buffer and put the necessary stuff in it.  Store it away for
+      ;; later so that repeated read/unread oscillations at this position
+      ;; don't end up consing enormous arrays too much.
+      (t
+       (let* ((next (or tail (make-charbuf-chain-link :buf buf :size size)))
+	      (fake (make-charbuf))
+	      (this (make-charbuf-chain-link :buf fake :size 1 :next next)))
+	 (setf (schar fake 0) char  buf fake  size 1
+	       tail this  unread this))))
+
+    ;; That's that sorted; now we have to fiddle the position.
+    (setf (values line column) (backtrack-position char line column))))
+
+(defmethod scanner-capture-place ((scanner charbuf-scanner))
+  (with-slots (buf size index captures tail line column) scanner
+    (incf captures)
+    (unless tail
+      (setf tail (make-charbuf-chain-link :buf buf :size size)))
+    (make-charbuf-scanner-place :link tail :index index
+				:line line :column column)))
+
+(defmethod scanner-restore-place ((scanner charbuf-scanner) place)
+  (with-slots (buf size index tail line column) scanner
+    (let ((link (charbuf-scanner-place-link place)))
+      (setf buf (charbuf-chain-link-buf link)
+	    size (charbuf-chain-link-size link)
+	    index (charbuf-scanner-place-index place)
+	    line (charbuf-scanner-place-line place)
+	    column (charbuf-scanner-place-column place)
+	    tail link))))
+
+(defmethod scanner-release-place ((scanner charbuf-scanner) place)
+  (with-slots (captures) scanner
+    (decf captures)))
+
+(defstruct (charbuf-slice
+	     (:constructor make-charbuf-slice
+			   (buf &optional (start 0) %end
+			    &aux (end (or %end (length buf))))))
+  (buf nil :type (or charbuf (eql :eof)) :read-only t)
+  (start 0 :type (and fixnum unsigned-byte) :read-only t)
+  (end 0 :type (and fixnum unsigned-byte) :read-only t))
+
+(declaim (inline charbuf-slice-length))
+(defun charbuf-slice-length (slice)
+  (- (charbuf-slice-end slice) (charbuf-slice-start slice)))
+
+(defun concatenate-charbuf-slices (slices)
+  (let* ((len (reduce #'+ slices
+		      :key #'charbuf-slice-length
+		      :initial-value 0))
+	 (string (make-array len :element-type 'character))
+	 (i 0))
+    (dolist (slice slices)
+      (let ((buf (charbuf-slice-buf slice))
+	    (end (charbuf-slice-end slice)))
+	(do ((j (charbuf-slice-start slice) (1+ j)))
+	    ((>= j end))
+	  (setf (schar string i) (schar buf j))
+	  (incf i))))
+    string))
+
+(defmethod scanner-interval
+    ((scanner charbuf-scanner) place-a &optional place-b)
+  (let* ((slices nil)
+	 (place-b (or place-b
+		      (with-slots (index tail) scanner
+			(make-charbuf-scanner-place :link tail
+						    :index index))))
+	 (last-link (charbuf-scanner-place-link place-b)))
+    (flet ((bad ()
+	     (error "Incorrect places ~S and ~S to SCANNER-INTERVAL."
+		    place-a place-b)))
+      (do ((link (charbuf-scanner-place-link place-a)
+		 (charbuf-chain-link-next link))
+	   (start (charbuf-scanner-place-index place-a) 0))
+	  ((eq link last-link)
+	   (let ((end (charbuf-scanner-place-index place-b)))
+	     (when (< end start)
+	       (bad))
+	     (push (make-charbuf-slice (charbuf-chain-link-buf link)
+				       start end)
+	       slices)
+	     (concatenate-charbuf-slices (nreverse slices))))
+	(when (null link) (bad))
+	(push (make-charbuf-slice (charbuf-chain-link-buf link)
+				  start
+				  (charbuf-chain-link-size link))
+	      slices)))))
+
+;;;--------------------------------------------------------------------------
+;;; Specialized streams.
+
+(export 'charbuf-scanner-stream)
+(defclass charbuf-scanner-stream (character-scanner-stream)
+  ((scanner :initarg :scanner :type charbuf-scanner)))
+
+(defmethod stream-read-sequence
+    ((stream charbuf-scanner-stream) (seq string) &optional (start 0) end)
+  (with-slots (scanner) stream
+    (unless end (setf end (length seq)))
+    (let ((i start) (n (- end start)))
+      (labels ((copy (i buf start end)
+		 (do ((j i (1+ j))
+		      (k start (1+ k)))
+		     ((>= k end))
+		   (setf (char seq j) (schar buf k))))
+	       (snarf (buf start end)
+		 (let ((m (- end start)))
+		   (cond ((< m n)
+			  (copy i buf start end) (decf n m) (incf i m)
+			  (values nil 0))
+			 (t
+			  (copy i buf start (+ start n)) (incf i n)
+			  (values t n))))))
+	(charbuf-scanner-map scanner #'snarf)
+	i))))
+
+(defmethod stream-read-line ((stream charbuf-scanner-stream))
+  (with-slots (scanner) stream
+    (let ((slices nil))
+      (flet ((snarf (buf start end)
+	       (let ((pos (position #\newline buf :start start :end end)))
+		 (push (make-charbuf-slice buf start (or pos end)) slices)
+		 (if pos
+		     (values (concatenate-charbuf-slices (nreverse slices))
+			     (1+ pos))
+		     (values nil 0))))
+	     (fail ()
+	       (values (concatenate-charbuf-slices (nreverse slices)) t)))
+	(charbuf-scanner-map scanner #'snarf #'fail)))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-scanner-context.lisp b/src/parser/impl-scanner-context.lisp
new file mode 100644
index 0000000..cbedd31
--- /dev/null
+++ b/src/parser/impl-scanner-context.lisp
@@ -0,0 +1,88 @@
+;;; -*-lisp-*-
+;;;
+;;; Parser contexts for scanners
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic scanner behaviour.
+
+;; Basic scanners.
+
+(defmethod parser-step ((context scanner-context))
+  `(scanner-step ,(parser-scanner context)))
+
+(defmethod parser-at-eof-p ((context scanner-context))
+  `(scanner-at-eof-p ,(parser-scanner context)))
+
+(defmethod parser-capture-place ((context scanner-context))
+  `(scanner-capture-place ,(parser-scanner context)))
+
+(defmethod parser-restore-place ((context scanner-context) place)
+  `(scanner-restore-place ,(parser-scanner context) ,place))
+
+(defmethod parser-release-place ((context scanner-context) place)
+  `(scanner-release-place ,(parser-scanner context) ,place))
+
+;; Character scanners.
+
+(defmethod parser-current-char ((context character-scanner-context))
+  `(scanner-current-char ,(parser-scanner context)))
+
+;; Token scanners.
+
+(defmethod parser-token-type ((context token-scanner-context))
+  `(token-type ,(parser-scanner context)))
+
+(defmethod parser-token-value ((context token-scanner-context))
+  `(token-value ,(parser-scanner context)))
+
+;;;--------------------------------------------------------------------------
+;;; Contexts for specific scanner classes.
+
+;; String scanner.
+
+(defclass string-scanner-context (character-scanner-context)
+  ()
+  (:documentation
+   "Specialized parser context for scanning strings.
+
+   Most notably, string positions don't need to be released, which means that
+   the expanded code doesn't need to do install `unwind-protect' handlers."))
+
+(defmethod parser-places-must-be-released-p
+    ((context string-scanner-context))
+  nil)
+
+;; List scanner.
+
+(defclass list-scanner-context (token-scanner-context)
+  ()
+  (:documentation
+   "Specialized scanner contexts for the list scanner."))
+
+(defmethod parser-places-must-be-released-p ((context list-scanner-context))
+  nil)
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-scanner-token.lisp b/src/parser/impl-scanner-token.lisp
new file mode 100644
index 0000000..e058b27
--- /dev/null
+++ b/src/parser/impl-scanner-token.lisp
@@ -0,0 +1,78 @@
+;;; -*-lisp-*-
+;;;
+;;; Tokenizing scanner
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Token scanner implementation.
+
+(defmethod shared-initialize :after
+    ((scanner token-scanner) slot-names &key)
+  (declare (ignore slot-names))
+  (scanner-step scanner))
+
+(defmethod scanner-at-eof-p ((scanner token-scanner))
+  (with-slots (type) scanner
+    (eq type :eof)))
+
+(defmethod scanner-step ((scanner token-scanner))
+  (with-slots (type value tail captures line column) scanner
+    (cond (tail
+	   (let ((next (token-scanner-place-next tail)))
+	     (setf type (token-scanner-place-type next)
+		   value (token-scanner-place-value next)
+		   line (token-scanner-place-line next)
+		   column (token-scanner-place-column next)
+		   tail next)))
+	  (t
+	   (multiple-value-bind (ty val) (scanner-token scanner)
+	     (setf type ty
+		   value val)
+	     (when (plusp captures)
+	       (let ((next (make-token-scanner-place
+			    :type ty :value val :line line :column column)))
+		 (setf (token-scanner-place-next tail) next
+		       tail next))))))))
+
+(defmethod scanner-capture-place ((scanner token-scanner))
+  (with-slots (type value captures tail line column) scanner
+    (incf captures)
+    (or tail
+	(setf tail (make-token-scanner-place
+		    :type type :value value :line line :column column)))))
+
+(defmethod scanner-restore-place ((scanner token-scanner) place)
+  (with-slots (type value tail line column) scanner
+    (setf type (token-scanner-place-type place)
+	  value (token-scanner-place-value place)
+	  line (token-scanner-place-line place)
+	  column (token-scanner-place-column place)
+	  tail place)))
+
+(defmethod scanner-release-place ((scanner token-scanner) place)
+  (with-slots (captures) scanner
+    (decf captures)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-scanner.lisp b/src/parser/impl-scanner.lisp
new file mode 100644
index 0000000..aa8a98a
--- /dev/null
+++ b/src/parser/impl-scanner.lisp
@@ -0,0 +1,120 @@
+;;; -*-lisp-*-
+;;;
+;;; Basic scanner interface
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Common scanner implementation..
+
+(defmethod file-location ((scanner character-scanner))
+  (scanner-file-location scanner))
+
+;;;--------------------------------------------------------------------------
+;;; Streams on character scanners.
+
+(defmethod stream-read-char ((stream character-scanner-stream))
+  (with-slots (scanner) stream
+    (if (scanner-at-eof-p scanner)
+	:eof
+	(prog1 (scanner-current-char scanner)
+	  (scanner-step scanner)))))
+
+(defmethod stream-unread-char ((stream character-scanner-stream) char)
+  (with-slots (scanner) stream
+    (scanner-unread scanner char)))
+
+(defmethod stream-peek-char ((stream character-scanner-stream))
+  (with-slots (scanner) stream
+    (scanner-current-char scanner)))
+
+;;;--------------------------------------------------------------------------
+;;; String scanner.
+
+;; This is much more convenient for testing lexers than the full character
+;; buffer scanner.
+
+(export '(string-scanner make-string-scanner string-scanner-p))
+(defstruct (string-scanner
+	     (:constructor make-string-scanner
+		 (string &key (start 0) end
+		  &aux (index start)
+		       (limit (or end (length string))))))
+  "Scanner structure for a simple string scanner."
+  (string "" :type string :read-only t)
+  (index 0 :type (and fixnum unsigned-byte))
+  (limit nil :type (and fixnum unsigned-byte) :read-only t))
+
+(defmethod scanner-at-eof-p ((scanner string-scanner))
+  (>= (string-scanner-index scanner) (string-scanner-limit scanner)))
+
+(defmethod scanner-current-char ((scanner string-scanner))
+  (char (string-scanner-string scanner) (string-scanner-index scanner)))
+
+(defmethod scanner-step ((scanner string-scanner))
+  (incf (string-scanner-index scanner)))
+
+(defmethod scanner-capture-place ((scanner string-scanner))
+  (string-scanner-index scanner))
+
+(defmethod scanner-restore-place ((scanner string-scanner) place)
+  (setf (string-scanner-index scanner) place))
+
+(defmethod scanner-interval
+    ((scanner string-scanner) place-a &optional place-b)
+  (with-slots (string index) scanner
+    (subseq string place-a (or place-b index))))
+
+;;;--------------------------------------------------------------------------
+;;; List scanner.
+
+(export 'list-scanner)
+(defstruct (list-scanner
+	     (:constructor make-list-scanner (list)))
+  "Simple token scanner for lists.
+
+   The list elements are the token semantic values; the token types are the
+   names of the elements' classes.  This is just about adequate for testing
+   purposes, but is far from ideal for real use."
+  (list nil :type list))
+
+(defmethod scanner-step ((scanner list-scanner))
+  (pop (list-scanner-list scanner)))
+
+(defmethod scanner-at-eof-p ((scanner list-scanner))
+  (null (list-scanner-list scanner)))
+
+(defmethod token-type ((scanner list-scanner))
+  (class-name (class-of (car (list-scanner-list scanner)))))
+
+(defmethod token-value ((scanner list-scanner))
+  (car (list-scanner-list scanner)))
+
+(defmethod scanner-capture-place ((scanner list-scanner))
+  (list-scanner-list scanner))
+
+(defmethod scanner-restore-place ((scanner list-scanner) place)
+  (setf (list-scanner-list scanner) place))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/impl-streams.lisp b/src/parser/impl-streams.lisp
new file mode 100644
index 0000000..6094b56
--- /dev/null
+++ b/src/parser/impl-streams.lisp
@@ -0,0 +1,382 @@
+;;; -*-lisp-*-
+;;;
+;;; Additional streams.
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Compatibility hacking.
+
+;; ECL is different and strange.  In early versions (0.9j and thereabouts)
+;; the Gray streams functions are in the SI package; CLOSE and STREAM-
+;; ELEMENT-TYPE are not generic, and call the generic functions SI:STREAM-
+;; CLOSE and SI:STREAM-ELT-TYPE if they find that they can't handle their
+;; argument.  The STREAM-CLOSE generic function doesn't have a method for the
+;; built-in streams.  In later versions (9.6.1 and thereabouts) the Gray
+;; streams functions are in the GRAY package; CLOSE and STREAM-ELEMENT-TYPE
+;; are still not generic, but now they call correspondingly-named generic
+;; functions in GRAY, and the generic versions do cover the built-in streams.
+;;
+;; The right thing to, then, seems to be as follows.
+;;
+;;   * ECL is the weird system, so we'll hack it to be less weird.  Hacking
+;;     non-weird platforms seems wrong-headed.
+;;
+;;   * Since SI:STREAM-CLOSE is missing a method which works on standard
+;;     streams, we should add one if we're running that version of ECL.
+;;
+;;   * Then we can shadow CLOSE and drop SI:STREAM-CLOSE or GRAY:CLOSE over
+;;     the top.  In the latter case, we can just do a SHADOWING-IMPORT; in
+;;     the latter, we'll need to mess with FDEFINITION.
+;;
+;;   * We'll do something similar for STREAM-ELEMENT-TYPE.
+;;
+;; Note that the following are all separate top-level forms so that later
+;; ones will be read with different symbols than earlier ones.  This also
+;; means that we can use the *FEATURES* mechanism and avoid lots of the
+;; tedious messing about with FIND-SYMBOL.
+
+#+ecl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (if (find-package '#:gray)
+    (push :sod-ecl-broken-gray-streams *features*)))
+
+#+(and ecl (not sod-ecl-broken-gray-streams))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadowing-import '(gray:close gray:stream-element-type)))
+
+#+(and ecl sod-ecl-broken-gray-streams)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadow '(close stream-element-type)))
+#+(and ecl sod-ecl-broken-gray-streams)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf (fdefinition 'close) #'si:stream-close
+	(fdefinition 'stream-element-type #'si:stream-elt-type)))
+
+;;;--------------------------------------------------------------------------
+;;; Proxy streams.
+
+;; Base classes for proxy streams.
+
+(defclass proxy-stream (fundamental-stream)
+  ((ustream :initarg :stream :type stream
+	    :reader position-aware-stream-underlying-stream))
+  (:documentation
+   "Base class for proxy streams.
+
+   A proxy stream is one that works by passing most of its work to an
+   underlying stream.  We provide some basic functionality for the later
+   classes."))
+
+(defmethod close ((stream proxy-stream) &key abort)
+  (with-slots (ustream) stream
+    (close ustream :abort abort)))
+
+(defmethod stream-element-type ((stream proxy-stream))
+  (with-slots (ustream) stream
+    (stream-element-type ustream)))
+
+(defmethod stream-file-position
+    ((stream proxy-stream) &optional (position nil posp))
+  (with-slots (ustream) stream
+    (if posp
+	(file-position ustream position)
+	(file-position ustream))))
+
+(defmethod stream-pathname ((stream proxy-stream))
+  (with-slots (ustream) stream
+    (stream-pathname ustream)))
+
+;; Base class for input streams.
+
+(defclass proxy-input-stream (proxy-stream fundamental-input-stream)
+  ()
+  (:documentation
+   "Base class for proxy input streams."))
+
+(defmethod stream-clear-input ((stream proxy-input-stream))
+  (with-slots (ustream) stream
+    (clear-input ustream)))
+
+(defmethod stream-read-sequence
+    ((stream proxy-input-stream) seq &optional (start 0) end)
+  (with-slots (ustream) stream
+    (read-sequence seq ustream :start start :end end)))
+
+;; Base class for output streams.
+
+(defclass proxy-output-stream (proxy-stream fundamental-output-stream)
+  ()
+  (:documentation
+   "Base class for proxy output streams."))
+
+(defmethod stream-clear-output ((stream proxy-output-stream))
+  (with-slots (ustream) stream
+    (clear-output ustream)))
+
+(defmethod stream-finish-output ((stream proxy-output-stream))
+  (with-slots (ustream) stream
+    (finish-output ustream)))
+
+(defmethod stream-force-output ((stream proxy-output-stream))
+  (with-slots (ustream) stream
+    (force-output ustream)))
+
+(defmethod stream-write-sequence
+    ((stream proxy-output-stream) seq &optional (start 0) end)
+  (with-slots (ustream) stream
+    (write-sequence seq ustream :start start :end end)))
+
+;; Character input streams.
+
+(defclass proxy-character-input-stream
+    (proxy-input-stream fundamental-character-input-stream)
+  ()
+  (:documentation
+   "A character-input-stream which is a proxy for an existing stream.
+
+   This doesn't actually change the behaviour of the underlying stream very
+   much, but it's a useful base to work on when writing more interesting
+   classes."))
+
+(defmethod stream-read-char ((stream proxy-character-input-stream))
+  (with-slots (ustream) stream
+    (read-char ustream nil :eof nil)))
+
+(defmethod stream-read-line ((stream proxy-character-input-stream))
+  (with-slots (ustream) stream
+    (read-line ustream nil "" nil)))
+
+(defmethod stream-unread-char ((stream proxy-character-input-stream) char)
+  (with-slots (ustream) stream
+    (unread-char char ustream)))
+
+;; Character output streams.
+
+(defclass proxy-character-output-stream
+    (proxy-stream fundamental-character-output-stream)
+  ()
+  (:documentation
+   "A character-output-stream which is a proxy for an existing stream.
+
+   This doesn't actually change the behaviour of the underlying stream very
+   much, but it's a useful base to work on when writing more interesting
+   classes."))
+
+(defmethod stream-line-column ((stream proxy-character-output-stream))
+  nil)
+
+(defmethod stream-line-length ((stream proxy-character-output-stream))
+  nil)
+
+(defmethod stream-terpri ((stream proxy-character-output-stream))
+  (with-slots (ustream) stream
+    (terpri ustream)))
+
+(defmethod stream-write-char ((stream proxy-character-output-stream) char)
+  (with-slots (ustream) stream
+    (write-char char ustream)))
+
+(defmethod stream-write-string
+    ((stream proxy-character-output-stream) string &optional (start 0) end)
+  (with-slots (ustream) stream
+    (write-string string ustream :start start :end end)))
+
+;;;--------------------------------------------------------------------------
+;;; The position-aware stream.
+
+;; Base class.
+
+(export '(position-aware-stream
+	  position-aware-stream-line position-aware-stream-column))
+(defclass position-aware-stream (proxy-stream)
+  ((file :initarg :file :initform nil
+	 :type pathname :accessor position-aware-stream-file)
+   (line :initarg :line :initform 1
+	 :type fixnum :accessor position-aware-stream-line)
+   (column :initarg :column :initform 0
+	   :type fixnum :accessor position-aware-stream-column))
+  (:documentation
+   "Character stream which keeps track of the line and column position.
+
+   A position-aware-stream wraps an existing character stream and tracks the
+   line and column position of the current stream position.  A newline
+   character increases the line number by one and resets the column number to
+   zero; most characters advance the column number by one, but tab advances
+   to the next multiple of eight.  (This is consistent with Emacs, at least.)
+   The position can be read using STREAM-LINE-AND-COLUMN.
+
+   This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
+   POSITION-AWARE-OUTPUT-STREAM."))
+
+(defgeneric stream-line-and-column (stream)
+  (:documentation
+   "Returns the current stream position of STREAM as line/column numbers.
+
+   Returns two values: the line and column numbers of STREAM's input
+   position.")
+  (:method ((stream stream))
+    (values nil nil))
+  (:method ((stream position-aware-stream))
+    (with-slots (line column) stream
+      (values line column))))
+
+(defmethod stream-pathname ((stream position-aware-stream))
+  "Return the pathname corresponding to a POSITION-AWARE-STREAM.
+
+   A POSITION-AWARE-STREAM can be given an explicit pathname, which is
+   returned in preference to the pathname of the underlying stream.  This is
+   useful in two circumstances.  Firstly, the pathname associated with a file
+   stream will have been subjected to TRUENAME, and may be less pleasant to
+   present back to a user.  Secondly, a name can be attached to a stream
+   which doesn't actually have a file backing it."
+
+  (with-slots (file) stream
+    (or file (call-next-method))))
+
+(defmethod file-location ((stream position-aware-stream))
+  (multiple-value-bind (line column) (stream-line-and-column stream)
+    (make-file-location (stream-pathname stream) line column)))
+
+;; Utilities.
+
+(defmacro with-position ((stream) &body body)
+  "Convenience macro for tracking the read position.
+
+   Within the BODY, the macro (update CHAR) is defined to update the STREAM's
+   position according to the character CHAR.
+
+   The position is actually cached in local variables, but will be written
+   back to the stream even in the case of non-local control transfer from the
+   BODY.  What won't work well is dynamically nesting WITH-POSITION forms."
+
+  (with-gensyms (line column char)
+    (once-only (stream)
+      `(let* ((,line (position-aware-stream-line ,stream))
+	      (,column (position-aware-stream-column ,stream)))
+	 (macrolet ((update (,char)
+		      ;; This gets a little hairy.  Hold tight.
+		      `(multiple-value-setq (,',line ,',column)
+			 (update-position ,,char ,',line ,',column))))
+	   (unwind-protect
+		(progn ,@body)
+	     (setf (position-aware-stream-line ,stream) ,line
+		   (position-aware-stream-column ,stream) ,column)))))))
+
+;; Input stream.
+
+(export 'position-aware-input-stream)
+(defclass position-aware-input-stream
+    (position-aware-stream proxy-character-input-stream)
+  ()
+  (:documentation
+   "A character input stream which tracks the input position.
+
+   This is particularly useful for parsers and suchlike, which want to
+   produce accurate error-location information."))
+
+(defmethod stream-unread-char ((stream position-aware-input-stream) char)
+
+  ;; I could have written this as a :before or :after method, but I think
+  ;; this is the right answer.  All of the other methods have to be primary
+  ;; (or around) methods, so at least it's consistent.
+  (with-slots (line column) stream
+    (setf (values line column) (backtrack-position char line column)))
+  (call-next-method))
+
+(defmethod stream-read-sequence
+    ((stream position-aware-input-stream) seq &optional (start 0) end)
+  (declare (ignore end))
+  (let ((pos (call-next-method)))
+    (with-position (stream)
+      (dosequence (ch seq :start start :end pos)
+	(update ch)))
+    pos))
+
+(defmethod stream-read-char ((stream position-aware-input-stream))
+  (let ((char (call-next-method)))
+    (with-position (stream)
+      (update char))
+    char))
+
+(defmethod stream-read-line ((stream position-aware-input-stream))
+  (multiple-value-bind (line eofp) (call-next-method)
+    (if eofp
+	(with-position (stream)
+	  (dotimes (i (length line))
+	    (update (char line i))))
+	(with-slots (line column) stream
+	  (incf line)
+	  (setf column 0)))
+    (values line eofp)))
+
+;; Output stream.
+
+(export 'position-aware-output-stream)
+(defclass position-aware-output-stream
+    (position-aware-stream proxy-character-output-stream)
+  ()
+  (:documentation
+   "A character output stream which tracks the output position.
+
+   This is particularly useful when generating C code: the position can be
+   used to generate `#line' directives referring to the generated code after
+   insertion of some user code."))
+
+(defmethod stream-write-sequence
+    ((stream position-aware-output-stream) seq &optional (start 0) end)
+  (with-position (stream)
+    (dosequence (ch seq :start start :end end)
+      (update ch))
+    (call-next-method)))
+
+(defmethod stream-line-column ((stream position-aware-output-stream))
+  (with-slots (column) stream
+    column))
+
+(defmethod stream-start-line-p ((stream position-aware-output-stream))
+  (with-slots (column) stream
+    (zerop column)))
+
+(defmethod stream-terpri ((stream position-aware-output-stream))
+  (with-slots (line column) stream
+    (incf line)
+    (setf column 0))
+  (call-next-method))
+
+(defmethod stream-write-char ((stream position-aware-output-stream) char)
+  (with-position (stream)
+    (update char))
+  (call-next-method))
+
+(defmethod stream-write-string
+    ((stream position-aware-output-stream) string &optional (start 0) end)
+  (with-position (stream)
+    (do ((i start (1+ i))
+	 (end (or end (length string))))
+	((>= i end))
+      (update (char string i))))
+  (call-next-method))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/opprec.lisp b/src/parser/opprec.lisp
new file mode 100644
index 0000000..2f1f728
--- /dev/null
+++ b/src/parser/opprec.lisp
@@ -0,0 +1,6 @@
+;;; operator precedence parser hacking
+
+(in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
diff --git a/package.lisp b/src/parser/package.lisp
similarity index 82%
rename from package.lisp
rename to src/parser/package.lisp
index 92e6a0c..6439f62 100644
--- a/package.lisp
+++ b/src/parser/package.lisp
@@ -1,13 +1,13 @@
 ;;; -*-lisp-*-
 ;;;
-;;; Package definition for SOD utility
+;;; Package definition for the Sod parser infrastructure
 ;;;
 ;;; (c) 2009 Straylight/Edgeware
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Simple Object Definition system.
+;;; This file is part of the Sensble Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -23,14 +23,9 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
-(cl:defpackage #:sod
+(cl:defpackage #:sod-parser
   (:use #:common-lisp
-
-	;; Find the meta-object protocol.  Our demands are not particularly
-	;; heavy.
-	#+sbcl #:sb-mop
-	#+(or cmu clisp) #:mop
-	#+ecl #:mop
+	#:sod-utilities
 
 	;; Try to find Gray streams support from somewhere.  ECL tucks them
 	;; somewhere unhelpful.
@@ -40,5 +35,4 @@
 	#+clisp #:gray
 	#-(or sbcl cmu ecl clisp) ...))
 
-
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/proto-floc.lisp b/src/parser/proto-floc.lisp
new file mode 100644
index 0000000..9e246ab
--- /dev/null
+++ b/src/parser/proto-floc.lisp
@@ -0,0 +1,299 @@
+;;; -*-lisp-*-
+;;;
+;;; Protocol for file locations
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; File location objects.
+
+(export '(file-location make-file-location file-location-p
+	  file-location-filename file-location-line file-location-column))
+(defstruct (file-location
+	     (:constructor make-file-location
+			   (%filename line column
+			    &aux (filename
+				  (etypecase %filename
+				    ((or string null) %filename)
+				    (pathname (namestring %filename)))))))
+  "A simple structure containing file location information.
+
+   Construct using MAKE-FILE-LOCATION; the main useful function is
+   ERROR-FILE-LOCATION."
+  (filename nil :type (or string null) :read-only t)
+  (line nil :type (or fixnum null) :read-only t)
+  (column nil :type (or fixnum null) :read-only t))
+
+(defgeneric file-location (thing)
+  (:documentation
+   "Convert THING into a FILE-LOCATION, if possible.
+
+   A THING which can be converted into a FILE-LOCATION is termed a
+   `file-location designator'.")
+  (:method ((thing file-location)) thing))
+
+;;;--------------------------------------------------------------------------
+;;; Enclosing conditions.
+
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+  ((enclosed-condition :initarg :condition :type condition
+		       :reader enclosed-condition))
+  (:documentation
+   "A condition which encloses another condition
+
+   This is useful if one wants to attach additional information to an
+   existing condition.  The enclosed condition can be obtained using the
+   ENCLOSED-CONDITION function.")
+  (:report (lambda (condition stream)
+	     (princ (enclosed-condition condition) stream))))
+
+;;;--------------------------------------------------------------------------
+;;; Conditions with location information.
+
+(export 'condition-with-location)
+(define-condition condition-with-location (condition)
+  ((location :initarg :location :reader file-location :type file-location))
+  (:documentation
+   "A condition which has some location information attached."))
+
+(export 'enclosing-condition-with-location)
+(define-condition enclosing-condition-with-location
+    (condition-with-location enclosing-condition)
+  ())
+
+(export 'error-with-location)
+(define-condition error-with-location (condition-with-location error)
+  ())
+
+(export 'warning-with-location)
+(define-condition warning-with-location (condition-with-location warning)
+  ())
+
+(export 'enclosing-error-with-location)
+(define-condition enclosing-error-with-location
+    (enclosing-condition-with-location error)
+  ())
+
+(export 'enclosing-warning-with-location)
+(define-condition enclosing-warning-with-location
+    (enclosing-condition-with-location warning)
+  ())
+
+(export 'simple-condition-with-location)
+(define-condition simple-condition-with-location
+    (condition-with-location simple-condition)
+  ())
+
+(export 'simple-error-with-location)
+(define-condition simple-error-with-location
+    (error-with-location simple-error)
+  ())
+
+(export 'simple-warning-with-location)
+(define-condition simple-warning-with-location
+    (warning-with-location simple-warning)
+  ())
+
+;;;--------------------------------------------------------------------------
+;;; Reporting errors.
+
+(export 'make-condition-with-location)
+(defun make-condition-with-location (default-type floc datum &rest arguments)
+  "Construct a CONDITION-WITH-LOCATION given a condition designator.
+
+   The returned condition will always be a CONDITION-WITH-LOCATION.  The
+   process consists of two stages.  In the first stage, a condition is
+   constructed from the condition designator DATUM and ARGUMENTS with default
+   type DEFAULT-TYPE (a symbol).  The precise behaviour depends on DATUM:
+
+     * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
+       empty list.
+
+     * If DATUM is a symbol, then it must name a condition type.  An instance
+       of this class is constructed using ARGUMENTS as initargs, i.e., as
+       if (apply #'make-condition ARGUMENTS); if the type is a subtype of
+       CONDITION-WITH-LOCATION then FLOC is attached as the location.
+
+     * If DATUM is a format control (i.e., a string or function), then the
+       condition is constructed as if, instead, DEFAULT-TYPE had been
+       supplied as DATUM, and the list (:format-control DATUM
+       :format-arguments ARGUMENTS) supplied as ARGUMENTS.
+
+   In the second stage, the condition constructed by the first stage is
+   converted into a CONDITION-WITH-LOCATION.  If the condition already has
+   type CONDITION-WITH-LOCATION then it is returned as is.  Otherwise it is
+   wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
+   if the condition was a subtype of ERROR or WARNING then the resulting
+   condition will also be subtype of ERROR or WARNING as appropriate."
+
+  (labels ((wrap (condition)
+	     (make-condition
+	      (etypecase condition
+		(error 'enclosing-error-with-location)
+		(warning 'enclosing-warning-with-location)
+		(condition 'enclosing-condition-with-location))
+	      :condition condition
+	      :location (file-location floc)))
+	   (make (type &rest initargs)
+	     (if (subtypep type 'condition-with-location)
+		 (apply #'make-condition type
+			:location (file-location floc)
+			initargs)
+		 (wrap (apply #'make-condition type initargs)))))
+    (etypecase datum
+      (condition-with-location datum)
+      (condition (wrap datum))
+      (symbol (apply #'make arguments))
+      ((or string function) (make default-type
+				  :format-control datum
+				  :format-arguments arguments)))))
+
+(export 'error-with-location)
+(defun error-with-location (floc datum &rest arguments)
+  "Report an error with attached location information."
+  (error (apply #'make-condition-with-location
+		'simple-error-with-location
+		floc datum arguments)))
+
+(export 'warn-with-location)
+(defun warn-with-location (floc datum &rest arguments)
+  "Report a warning with attached location information."
+  (warn (apply #'make-condition-with-location
+	       'simple-warning-with-location
+	       floc datum arguments)))
+
+(export 'cerror-with-location)
+(defun cerror-with-location (floc continue-string datum &rest arguments)
+  "Report a continuable error with attached location information."
+  (cerror continue-string
+	  (apply #'make-condition-with-location
+		 'simple-error-with-location
+		 floc datum arguments)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+  (apply #'cerror "Continue" datum arguments))
+
+(export 'cerror*-with-location)
+(defun cerror*-with-location (floc datum &rest arguments)
+  (apply #'cerror-with-location floc "Continue" datum arguments))
+
+;;;--------------------------------------------------------------------------
+;;; Stamping errors with location information.
+
+(defun with-default-error-location* (floc thunk)
+  "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
+   other conditions) which do not have file location information attached to
+   them already.
+
+   See the WITH-DEFAULT-ERROR-LOCATION macro for more details."
+
+  (if floc
+      (handler-bind
+	  ((condition-with-location
+	    (lambda (condition)
+	      (declare (ignore condition))
+	      :decline))
+	   (condition
+	    (lambda (condition)
+	      (signal (make-condition-with-location nil floc condition)))))
+	(funcall thunk))
+      (funcall thunk)))
+
+(export 'with-default-error-location)
+(defmacro with-default-error-location ((floc) &body body)
+  "Evaluate BODY, as an implicit progn, in a dynamic environment which
+   attaches FLOC to errors (and other conditions) which do not have file
+   location information attached to them already.
+
+   If a condition other than a CONDITION-WITH-LOCATION is signalled during
+   the evaluation of the BODY, then an instance of an appropriate subcalass
+   of ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the
+   original condition, and signalled.  In particular, if the original
+   condition was a subtype of ERROR or WARNING, then the new condition will
+   also be a subtype of ERROR or WARNING as appropriate.
+
+   The FLOC argument is coerced to a FILE-LOCATION object each time a
+   condition is signalled.  For example, if FLOC is a lexical analyser object
+   which reports its current position in response to FILE-LOCATION, then each
+   condition will be reported as arising at the lexer's current position at
+   that time, rather than all being reported at the same position.
+
+   If the new enclosing condition is not handled, the handler established by
+   this macro will decline to handle the original condition.  Typically,
+   however, the new condition will be handled by COUNT-AND-REPORT-ERRORS.
+
+   As a special case, if FLOC is nil, then no special action is taken, and
+   BODY is simply evaluated, as an implicit progn."
+
+  `(with-default-error-location* ,floc (lambda () ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Front-end error reporting.
+
+(defun count-and-report-errors* (thunk)
+  "Invoke THUNK in a dynamic environment which traps and reports errors.
+
+   See the COUNT-AND-REPORT-ERRORS macro for more detais."
+
+  (let ((errors 0)
+	(warnings 0))
+    (handler-bind
+	((error (lambda (error)
+		  (let ((fatal (not (find-restart 'continue error))))
+		    (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
+			    (file-location error)
+			    fatal
+			    error)
+		    (incf errors)
+		    (if fatal
+			(return-from count-and-report-errors*
+			  (values nil errors warnings))
+			(invoke-restart 'continue)))))
+	 (warning (lambda (warning)
+		    (format *error-output* "~&~A: Warning: ~A~%"
+			  (file-location warning)
+			  warning)
+		    (incf warnings)
+		    (invoke-restart 'muffle-warning))))
+      (values (funcall thunk)
+	      errors
+	      warnings))))
+
+(export 'count-and-report-errors)
+(defmacro count-and-report-errors (() &body body)
+  "Evaluate BODY in a dynamic environment which traps and reports errors.
+
+   The BODY is evaluated.  If an error or warning is signalled, it is
+   reported (using its report function), and counted.  Warnings are otherwise
+   muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
+   continued; non-continuable errors cause an immediate exit from the BODY.
+
+   The final value consists of three values: the primary value of the BODY
+   (or NIL if a non-continuable error occurred), the number of errors
+   reported, and the number of warnings reported."
+  `(count-and-report-errors* (lambda () ,@body)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/proto-parser-expr.lisp b/src/parser/proto-parser-expr.lisp
new file mode 100644
index 0000000..b2919d6
--- /dev/null
+++ b/src/parser/proto-parser-expr.lisp
@@ -0,0 +1,253 @@
+;;; -*-lisp-*-
+;;;
+;;; Parsers for expressions with binary operators
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol.
+
+(export 'push-operator)
+(defgeneric push-operator (operator state)
+  (:documentation
+   "Push an OPERATOR onto the STATE's operator stack.
+
+   This should apply existing stacked operators as necessary to obey the
+   language's precedence rules."))
+
+(export 'push-vlaue)
+(defgeneric push-value (value state)
+  (:documentation
+   "Push VALUE onto the STATE's value stack.
+
+   The default message just does that without any fuss.  It's unlikely that
+   this will need changing unless you invent some really weird values."))
+
+(export 'apply-operator)
+(defgeneric apply-operator (operator state)
+  (:documentation
+   "Apply the OPERATOR to argument on the STATE's value stack.
+
+   This should pop any necessary arguments, and push the result."))
+
+(export 'operator-push-action)
+(defgeneric operator-push-action (left right)
+  (:documentation
+   "Determine relative precedence between LEFT and RIGHT operators.
+
+   Returns one of three possible values:
+
+     * `:push' means to push the RIGHT operator onto the stack, above the
+       LEFT operator -- i.e., RIGHT has higher precedence than LEFT.
+
+     * `:apply' means to apply the LEFT operator to arguments immediately
+       and try again, comparing RIGHT to the new topmost operator -- i.e.,
+       LEFT has higher precedence than RIGHT.
+
+     * `:error' means that the situation is erroneous: a continuable error is
+       signalled and the situation resolved by applying the LEFT operator and
+       then pushing the RIGHT one -- i.e., treating them as having similar
+       precedence and left associativity).
+
+   There is a default method which decides between `:push' and `:apply' by
+   comparing numerical precedence values."))
+
+(export 'expr)
+(defparse expr ((&key (nestedp (gensym "NESTEDP-")))
+		operand binop preop postop)
+  "Parse an expression involving unary and binary operators."
+  (flet ((wrap (parser)
+	   `(parser (,nestedp)
+	      (declare (ignorable ,nestedp))
+	      ,parser)))
+    `(parse-expression ,(wrap operand)
+		       ,(wrap binop)
+		       ,(wrap preop)
+		       ,(wrap postop))))
+
+;;;--------------------------------------------------------------------------
+;;; Numerical precedence.
+
+(export '(operator-left-precedence operator-right-precedence))
+(defgeneric operator-left-precedence (operator)
+  (:documentation
+   "Return the OPERATOR's left-precedence.
+
+   Higher precedence numbers indicate tighter leftward binding.  Under the
+   default method for `operator-push-action', the OPERATOR's left precedence
+   is compared to the existing operators' right precedences to determine the
+   parser's behaviour: if it is higher, then the OPERATOR is pushed;
+   otherwise the existing operator is applied.  Thus, equal precedences cause
+   left-associative parsing."))
+(defgeneric operator-right-precedence (operator)
+  (:documentation
+   "Return the OPERATOR's right-precedence.
+
+   Higher precedence numbers indicate tighter rightward binding.  Under the
+   default method for `operator-push-action', a new operator's left
+   precedence may be compared to the existing OPERATOR'S right precedences to
+   determine the parser's behaviour: if it is higher, then the new operator
+   is pushed; otherwise the existing OPERATOR is applied.  Thus, equal
+   precedences cause left-associative parsing."))
+
+(defgeneric operator-associativity (operator)
+  (:documentation
+   "Returns an OPERATOR's associativity, as a symbol.
+
+   The return value is one of `:left', `:right' or `nil'.  If two adjacent
+   operators have the same precedence, their associativities are compared.
+   If both associativities are `:left' then the left-hand operator is
+   considered to have higher precedence; if both are `:right' then the
+   right-hand operator is considered to have higher precedence.  If they're
+   inconsistent or `nil', then an error is reported and the behaviour is as
+   if both were `:left'.")
+  (:method (operator) :left))
+
+;;;--------------------------------------------------------------------------
+;;; Basic operator protocol.
+
+(export 'prefix-operator)
+(defclass prefix-operator ()
+  ()
+  (:documentation
+   "Prefix operator base class.
+
+   Prefix operators are special because they are pushed at a time when the
+   existing topmost operator on the stack may not have its operand
+   available.  It is therefore incorrect to attempt to apply any existing
+   operators without careful checking.  This class provides a method on
+   `push-operator' which immediately pushes the new operator without
+   inspecting the existing stack."))
+
+(export 'simple-operator)
+(defclass simple-operator ()
+  ((function :initarg :function :reader operator-function)
+   (name :initarg :name :initform "<unnamed operator>"
+	 :reader operator-name))
+  (:documentation
+   "A simple operator applies a FUNCTION to arguments when it is applied.
+
+   The precise details of the function are left to subclasses to sort out."))
+
+(export 'simple-unary-operator)
+(defclass simple-unary-operator (simple-operator)
+  ()
+  (:documentation
+   "A unary operator works on the topmost value on the value stack.
+
+   The topmost item is popped, the FUNCTION is applied to it, and the result
+   is pushed back on."))
+
+(export 'simple-binary-operator)
+(defclass simple-binary-operator (simple-operator)
+  ((lprec :initarg :left-precedence :initarg :precedence
+	  :reader operator-left-precedence)
+   (rprec :initarg :right-precedence :reader operator-right-precedence)
+   (associativity :initarg :associative :initform :left
+		  :reader operator-associativity))
+  (:documentation
+   "A binary operator works on the two topmost values on the value stack.
+
+   The function's arguments are the two topmost items in /reverse/ order --
+   so the topmost item is second.  This is usually what you want.
+
+   The left and right precedences are settable independently.  Usually (and
+   this is the default) you will set them equal, and use the `:associativity'
+   initarg to determine associativity; however, right-associativity can also
+   be obtained by setting the right-precedence lower than the left.  Special
+   effects can be obtained by setting them in other ways.  Use your
+   imagination."))
+
+(export 'simple-postfix-operator)
+(defclass simple-postfix-operator (simple-unary-operator)
+  ((lprec :initarg :left-precedence :initarg :precedence
+	  :reader operator-left-precedence)
+   (rprec :initarg :right-precedence :reader operator-right-precedence))
+  (:documentation
+   "A postfix operator is applied to a single operand.
+
+   The left and right precedences are settable independently.  Usually you
+   will want to set them equal (this is the default) and quite high.  Special
+   effects can be obtained by doing other things instead; but note that you
+   will get an incorrect parse if the right precedence is lower than the left
+   precedence of a binary operator because the postfix operator will be
+   applied to the result of the binary operator."))
+
+(export 'simple-prefix-operator)
+(defclass simple-prefix-operator (prefix-operator simple-unary-operator)
+  ((rprec :initarg :precedence :reader operator-right-precedence))
+  (:documentation
+   "A prefix operator is applied to a single operand.
+
+   There is only one precedence value for a prefix operator: the
+   `prefix-operator' superclass arranges that the left precedence is
+   effectively minus infinity."))
+
+(export 'preop)
+(defmacro preop (name (x prec) &body body)
+  `(make-instance 'simple-prefix-operator
+		  :name ,name
+		  :precedence ,prec
+		  :function (lambda (,x) ,@body)))
+
+(export 'postop)
+(defmacro postop (name (x prec &key rprec) &body body)
+  (once-only (name prec rprec)
+    `(make-instance 'simple-postfix-operator
+		    :name ,name
+		    :left-precedence ,prec
+		    :right-precedence ,(or rprec prec)
+		    :function (lambda (,x) ,@body))))
+
+(export 'binop)
+(defmacro binop (name (x y prec &key rprec (assoc :left)) &body body)
+  (once-only (name prec rprec assoc)
+    `(make-instance 'simple-binary-operator
+		    :name ,name
+		    :left-precedence ,prec
+		    :right-precedence ,(or rprec prec)
+		    :associative ,assoc
+		    :function (lambda (,x ,y) ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Parentheses.
+
+(defclass parenthesis ()
+  ((tag :initarg :tag :initform nil))
+  (:documentation
+   "Base class for parenthesis operators."))
+
+(export 'open-parenthesis)
+(defclass open-parenthesis (parenthesis prefix-operator) ())
+
+(export 'close-parenthesis)
+(defclass close-parenthesis (parenthesis) ())
+
+(export '(lparen rparen))
+(defun lparen (tag)
+  (make-instance 'open-parenthesis :tag tag))
+(defun rparen (tag)
+  (make-instance 'close-parenthesis :tag tag))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/proto-parser.lisp b/src/parser/proto-parser.lisp
new file mode 100644
index 0000000..f32a304
--- /dev/null
+++ b/src/parser/proto-parser.lisp
@@ -0,0 +1,890 @@
+;;; -*-lisp-*-
+;;;
+;;; Protocol for parsing.
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;;--------------------------------------------------------------------------
+;;; Parser protocol discussion.
+;;;
+;;; Other languages, notably Haskell and ML, have `parser combinator
+;;; libraries', which allow one to construct recursive descent parsers using
+;;; approximately pleasant syntax.  While attempts have been made to
+;;; introduce the benefits of these libraries to Lisp, they've not been
+;;; altogether successful; this seems due to Lisp's lack of features such as
+;;; pattern matching, currying and lazy evaluation.  Rather than fight with
+;;; Lisp's weaknesses, this library plays to its strength, making heavy use
+;;; of macros.  Effectively, the `combinators' we build here are /compile-
+;;; time/ combinators, not run-time ones.
+;;;
+;;; A `parser' is simply an expression which returns three values.
+;;;
+;;;   * If the second value is nil, then the parser is said to have /failed/,
+;;;	and the first value is a list describing the things that the parser
+;;;	expected to find but didn't.  (The precise details of the list items
+;;;	are important to error-reporting functions, but not to the low-level
+;;;	machinery, and are left up to higher-level protocols to nail down
+;;;	harder.)
+;;;
+;;;   * If the second value is not nil, then the parser is said to have
+;;;	/succeeded/, and the first value is its /result/.
+;;;
+;;;   * The third value indicates whether the parser consumed any of its
+;;;	input.  Parsers don't backtrack implicitly (to avoid space leaks and
+;;;	bad performance), so the `consumedp' return value is used to decide
+;;;	whether the parser has `committed' to a particular branch.  If the
+;;;	parser context supports place-capture (many do) then `peek' can be
+;;;	used to suppress consumption of input in the case of parser failure.
+;;;
+;;; The functions and macros here are simply ways of gluing together
+;;; expressions which obey this protocol.
+;;;
+;;; The main contribution of this file is a macro WITH-PARSER-CONTEXT which
+;;; embeds a parsing-specific S-expressions language entered using the new
+;;; macro PARSE.  The behaviour of this macro is controlled by a pair of
+;;; compile-time generic functions EXPAND-PARSER-SPEC and EXPAND-PARSER-FORM.
+;;; As well as the parser expression they're meant to process, these
+;;; functions dispatch on a `context' argument, which is intended to help
+;;; `leaf' parsers find the terminal symbols which they're meant to process.
+;;;
+;;; Note that the context is a compile-time object, constructed by the PARSE
+;;; macro expansion function, though the idea is that it will contain the
+;;; name or names of variables holding the run-time parser state (which will
+;;; typically be a lexical analyser or an input stream or suchlike).
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun combine-parser-failures (failures)
+  "Combine the failure indicators listed in FAILURES.
+
+   (Note that this means that FAILURES is a list of lists.)"
+
+  (reduce (lambda (f ff) (union f ff :test #'equal))
+	  failures
+	  :initial-value nil))
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+  (export 'expand-parser-spec)
+  (defgeneric expand-parser-spec (context spec)
+    (:documentation
+     "Expand a parser specifier SPEC in a particular parser CONTEXT.")
+    (:method (context (spec list))
+      (expand-parser-form context (car spec) (cdr spec))))
+
+  (export 'expand-parser-form)
+  (defgeneric expand-parser-form (context head tail)
+    (:documentation
+     "Expand a parser list-form given by HEAD and TAIL, in CONTEXT.")
+    (:method (context head tail)
+      (cons head tail)))
+
+  (export 'wrap-parser)
+  (defgeneric wrap-parser (context form)
+    (:documentation
+     "Enclose FORM in whatever is necessary to make the parser work.")
+    (:method (context form) form)))
+
+(export 'defparse)
+(defmacro defparse (name bvl &body body)
+  "Define a new parser form.
+
+   The full syntax is hairier than it looks:
+
+	defparse NAME ( [[ :context (CTX SPEC) ]] . BVL )
+	  { FORM }*
+
+   The macro defines a new parser form (NAME ...) which is expanded by the
+   body FORMs. The BVL is a destructuring lambda-list to be applied to the
+   tail of the form.  The body forms are enclosed in a block called NAME.
+
+   Within the FORMs, a function `expand' is available: it takes a parser
+   specifier as its argument and returns its expansion in the parser's
+   context.
+
+   If the :context key is provided, then the parser form is specialized on a
+   particular class of parser contexts SPEC; specialized expanders take
+   priority over less specialized or unspecialized expanders -- so you can
+   use this to override the built-in forms safely if they don't seem to be
+   doing the right thing for you.  Also, the context -- which is probably
+   interesting to you if you've bothered to specialize -- is bound to the
+   variable CTX."
+
+  ;; BUG! misplaces declarations: if you declare the CONTEXT argument
+  ;; `special' it won't be bound properly.  I'm really not at all sure I know
+  ;; how to fix this.
+
+  (with-gensyms (head tail context)
+    (let ((ctxclass t))
+      (loop
+	(unless (and bvl (keywordp (car bvl))) (return))
+	(ecase (pop bvl)
+	  (:context (destructuring-bind (name spec) (pop bvl)
+		      (setf ctxclass spec context name)))))
+      (multiple-value-bind (doc decls body) (parse-body body)
+	`(defmethod expand-parser-form
+	     ((,context ,ctxclass) (,head (eql ',name)) ,tail)
+	   ,@doc
+	   (block ,name
+	     (destructuring-bind ,bvl ,tail
+	       ,@decls
+	       ,@body)))))))
+
+(export '(with-parser-context parse))
+(defmacro with-parser-context ((class &rest initargs) &body body)
+  "Evaluate BODY with a macro `parse' which expands parser forms.
+
+   Evaluate BODY as an implicit progn.  At compile time, a parser context is
+   constructed by (apply #'make-instance CLASS INITARGS).  The BODY can make
+   use of the macro `parse':
+
+	parse SPEC
+
+   which parses the input in the manner described by SPEC, in the context of
+   the parser context."
+
+  (let ((context (apply #'make-instance class initargs)))
+    (wrap-parser context
+		 `(macrolet ((parse (form)
+			       (expand-parser-spec ',context form)))
+		    ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Common parser context protocol.
+
+(export 'parser-at-eof-p)
+(defgeneric parser-at-eof-p (context)
+  (:documentation
+   "Return whether the parser has reached the end of its input.
+
+   Be careful: all of this is happening at macro expansion time."))
+
+(export 'parser-step)
+(defgeneric parser-step (context)
+  (:documentation
+   "Advance the parser to the next character.
+
+   Be careful: all of this is happening at macro-expansion time."))
+
+(defmethod expand-parser-spec (context (spec (eql :eof)))
+  "Tests succeeds if the parser has reached the end of its input.
+
+   The failure indicator is the keyword `:eof'."
+
+  `(if ,(parser-at-eof-p context)
+       (values :eof t nil)
+       (values '(:eof) nil nil)))
+
+;;;--------------------------------------------------------------------------
+;;; Useful macros for dealing with parsers.
+
+(export 'it)
+(export 'if-parse)
+(defmacro if-parse ((&key (result 'it) expected (consumedp (gensym "CP")))
+		    parser consequent &optional (alternative nil altp))
+  "Conditional parsing construction.
+
+   If PARSER succeeds, then evaluate CONSEQUENT with RESULT bound to the
+   result; otherwise evaluate ALTERNATIVE with EXPECTED bound to the
+   expected-item list.  If ALTERNATIVE is omitted, then propagate the failure
+   following the parser protocol."
+
+  (with-gensyms (value win)
+    `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+       (declare (ignorable ,consumedp))
+       (if ,win
+	   (let ((,result ,value))
+	     (declare (ignorable ,result))
+	     ,consequent)
+	   ,(cond ((not altp)
+		   `(values ,value nil ,consumedp))
+		  (expected
+		   `(let ((,expected ,value)) ,alternative))
+		  (t
+		   alternative))))))
+
+(export 'when-parse)
+(defmacro when-parse ((&optional (result 'it)) parser &body body)
+  "Convenience macro for conditional parsing.
+
+   If PARSER succeeds then evaluate BODY with RESULT bound to the result;
+   otherwise propagate the failure."
+  `(if-parse (:result ,result) ,parser (progn ,@body)))
+
+(export 'cond-parse)
+(defmacro cond-parse ((&key (result 'it) expected
+			    (consumedp (gensym "CP")))
+		      &body clauses)
+  "Frightening conditional parsing construct.
+
+   Each of the CLAUSES has the form (PARSER &rest FORMS); the special `fake'
+   parser form `t' may be used to describe a default action.  If the PARSER
+   succeeds then evaluate FORMS in order with RESULT bound to the parser
+   result (if there are no forms, then propagate the success); if the PARSER
+   fails without consuming input, then move onto the next clause.
+
+   If the default clause (if any) is reached, or a parser fails after
+   consuming input, then EXPECTED is bound to a list of failure indicators
+   and the default clause's FORMS are evaluated and with CONSUMEDP bound to a
+   generalized boolean indicating whether any input was consumed.  If there
+   is no default clause, and either some parser fails after consuming input,
+   or all of the parsers fail without consuming, then a failure is reported
+   and the input-consumption indicator is propagated.
+
+   If a parser fails after consuming input, then the failure indicators are
+   whatever that parser reported; if all the parsers fail without consuming
+   then the failure indicators are the union of the indicators reported by
+   the various parsers."
+
+  (with-gensyms (block fail failarg)
+    (labels ((walk (clauses failures)
+	       (cond ((null clauses)
+		      (values `(,fail nil (list ,@(reverse failures)))
+			      `(values (combine-parser-failures ,failarg)
+				       nil
+				       ,consumedp)))
+		     ((eq (caar clauses) t)
+		      (values `(,fail nil (list ,@(reverse failures)))
+			      `(,@(if expected
+				      `(let ((,expected
+					      (combine-parser-failures
+					       ,failarg))))
+				      `(progn))
+				  ,@(cdar clauses))))
+		     (t
+		      (with-gensyms (value win cp)
+			(multiple-value-bind (inner failbody)
+			    (walk (cdr clauses) (cons value failures))
+			  (values `(multiple-value-bind (,value ,win ,cp)
+				       (parse ,(caar clauses))
+				     (when ,win
+				       (return-from ,block
+					 (let ((,result ,value)
+					       (,consumedp ,cp))
+					   (declare (ignorable ,result
+							       ,consumedp))
+					   ,@(cdar clauses))))
+				     (when ,cp
+				       (,fail t (list ,value)))
+				     ,inner)
+				  failbody)))))))
+      (multiple-value-bind (inner failbody) (walk clauses nil)
+	`(block ,block
+	   (flet ((,fail (,consumedp ,failarg)
+		    (declare (ignorable ,consumedp ,failarg))
+		    ,failbody))
+	     ,inner))))))
+
+(export 'parser)
+(defmacro parser (bvl &body parser)
+  "Functional abstraction for parsers."
+  (multiple-value-bind (doc decls body) (parse-body parser)
+    `(lambda ,bvl ,@doc ,@decls (parse ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard parser forms.
+
+(export 'label)
+(defparse label (label parser)
+  "If PARSER fails, use LABEL as the expected outcome.
+
+   The LABEL is only evaluated if necessary."
+  (with-gensyms (value win consumedp)
+    `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+       (if ,win
+	   (values ,value ,win ,consumedp)
+	   (values (list ,label) nil ,consumedp)))))
+
+(defparse t (value)
+  "Succeed, without consuming input, with result VALUE."
+  `(values ,value t nil))
+
+(defparse when (cond &body parser)
+  "If CONDITION is true, then match PARSER; otherwise fail."
+  `(if ,cond (parse ,@parser) (values nil nil nil)))
+
+(defmethod expand-parser-spec (context (spec (eql t)))
+  "Always matches without consuming input."
+  '(values t t nil))
+
+(export 'seq)
+(defparse seq (binds &body body)
+  "Parse a sequence of heterogeneous items.
+
+   Syntax:
+
+	seq ( { ATOMIC-PARSER-FORM | ([VAR] PARSER-FORM) }* )
+	  { FORM }*
+
+   The behaviour is similar to `let*'.  The PARSER-FORMs are processed in
+   order, left to right.  If a parser succeeds, then its value is bound to
+   the corresponding VAR, and available within Lisp forms enclosed within
+   subsequent PARSER-FORMs and/or the body FORMs.  If any parser fails, then
+   the entire sequence fails.  If all of the parsers succeeds, then the FORMs
+   are evaluated as an implicit progn, and the sequence will succeed with the
+   result computed by the final FORM."
+
+  (with-gensyms (block consumedp)
+    (labels ((walk (binds lets ignores)
+	       (if (endp binds)
+		   `(let* ((,consumedp nil)
+			   ,@(nreverse lets))
+		      ,@(and ignores
+			     `((declare (ignore ,@(nreverse ignores)))))
+		      (values (progn ,@body) t ,consumedp))
+		   (destructuring-bind (x &optional (y nil yp))
+		       (if (listp (car binds))
+			   (car binds)
+			   (list (car binds)))
+		     (with-gensyms (var value win cp)
+		       (multiple-value-bind (var parser ignores)
+			   (if (and yp x)
+			       (values x y ignores)
+			       (values var (if yp y x) (cons var ignores)))
+			 (walk (cdr binds)
+			       (cons `(,var (multiple-value-bind
+						(,value ,win ,cp)
+						(parse ,parser)
+					      (when ,cp (setf ,consumedp t))
+					      (unless ,win
+						(return-from ,block
+						  (values ,value ,nil
+							  ,consumedp)))
+					      ,value))
+				   lets)
+			     ignores)))))))
+      `(block ,block ,(walk binds nil nil)))))
+
+(export 'and)
+(defparse and (:context (context t) &rest parsers)
+  "Parse a sequence of heterogeneous items, but ignore their values.
+
+   This is just like (and is implemented using) `seq' with all the bindings
+   set to `nil'.  The result is `nil'."
+  (with-gensyms (last)
+    (if (null parsers)
+	'(seq () nil)
+	(expand-parser-spec context
+			    `(seq (,@(mapcar (lambda (parser)
+					       `(nil ,parser))
+					     (butlast parsers))
+				     (,last ,(car (last parsers))))
+			       ,last)))))
+
+(export 'lisp)
+(defparse lisp (&rest forms)
+  "Evaluate FORMs, which should obey the parser protocol."
+  `(progn ,@forms))
+
+(export 'many)
+(defparse many ((acc init update
+		 &key (new 'it) (final acc) (min nil minp) max (commitp t))
+		parser &optional (sep nil sepp))
+  "Parse a sequence of homogeneous items.
+
+   The behaviour is similar to `do'.  Initially an accumulator ACC is
+   established, and bound to the value of INIT.  The PARSER is then evaluated
+   repeatedly.  Each time it succeeds, UPDATE is evaluated with NEW (defaults
+   to `it') bound to the result of the parse, and the value returned by
+   UPDATE is stored back into ACC.  If the PARSER fails, then the parse
+   ends.  The scope of ACC includes the UPDATE and FINAL forms, and the
+   PARSER and SEP parsers; it is updated by side effects, not rebound.
+
+   If a SEP parser is provided, then the behaviour changes as follows.
+   Before each attempt to parse a new item using PARSER, the parser SEP is
+   invoked.  If SEP fails then the parse ends; if SEP succeeds, and COMMITP
+   is true, then the PARSER must also succeed or the overall parse will
+   fail.  If COMMITP is false then a trailing SEP is permitted and ignored.
+
+   If MAX (which will be evaluated) is not nil, then it must be a number: the
+   parse ends automatically after PARSER has succeeded MAX times.  When the
+   parse has ended, if the PARSER succeeded fewer than MIN (which will be
+   evaluated) times then the parse fails.  Otherwise, the FINAL form (which
+   defaults to simply returning ACC) is evaluated and its value becomes the
+   result of the parse.  MAX defaults to nil -- i.e., no maximum; MIN
+   defaults to 1 if a SEP parser is given, or 0 if not.
+
+   Note that `many' cannot fail if MIN is zero."
+
+  ;; Once upon a time, this was a macro of almost infinite hairiness which
+  ;; tried to do everything itself, including inspecting its arguments for
+  ;; constant-ness to decide whether it could elide bits of code.  This
+  ;; became unsustainable.  Nowadays, it packages up its parser arguments
+  ;; into functions and calls some primitive functions to do the heavy
+  ;; lifting.
+  ;;
+  ;; The precise protocol between this macro and the backend functions is
+  ;; subject to change: don't rely on it.
+
+  (let* ((accvar (or acc (gensym "ACC-")))
+	 (func (if sepp '%many-sep '%many)))
+    `(let ((,accvar ,init))
+       (declare (ignorable ,accvar))
+       (,func (lambda (,new)
+		(declare (ignorable ,new))
+		(setf ,accvar ,update))
+	      (lambda ()
+		,final)
+	      (parser () ,parser)
+	      ,@(and sepp (list `(parser () ,sep)))
+	      ,@(and minp `(:min ,min))
+	      ,@(and max `(:max ,max))
+	      ,@(and (not (eq commitp t)) `(:commitp ,commitp))))))
+
+(export 'list)
+(defparse list ((&rest keys) parser &optional (sep nil sepp))
+  "Like MANY, but simply returns a list of the parser results."
+  (with-gensyms (acc)
+    `(parse (many (,acc nil (cons it ,acc) :final (nreverse ,acc) ,@keys)
+	      ,parser ,@(and sepp (list sep))))))
+
+(export 'skip-many)
+(defparse skip-many ((&rest keys) parser &optional (sep nil sepp))
+  "Like MANY, but ignores the results."
+  `(parse (many (nil nil nil ,@keys)
+	    ,parser ,@(and sepp (list sep)))))
+
+(export 'or)
+(defparse or (&rest parsers)
+  "Try a number of alternative parsers.
+
+   Each of the PARSERS in turn is tried.  If any succeeds, then its result
+   becomes the result of the parse.  If any parser fails after consuming
+   input, or if all of the parsers fail, then the overall parse fails, with
+   the union of the expected items from the individual parses."
+
+  (with-gensyms (fail cp failarg)
+    (labels ((walk (parsers failures)
+	       (if (null parsers)
+		   `(,fail nil (list ,@(reverse failures)))
+		   (with-gensyms (value win consumedp)
+		     `(multiple-value-bind (,value ,win ,consumedp)
+			  (parse ,(car parsers))
+			(cond (,win
+			       (values ,value ,win ,consumedp))
+			      (,consumedp
+			       (,fail t (list ,value)))
+			      (t
+			       ,(walk (cdr parsers)
+				      (cons value failures)))))))))
+      `(flet ((,fail (,cp ,failarg)
+		(values (combine-parser-failures ,failarg) nil ,cp)))
+	 ,(walk parsers nil)))))
+
+(export '?)
+(defparse ? (parser &optional (value nil))
+  "Matches PARSER or nothing; fails if PARSER fails after consuming input."
+  `(parse (or ,parser (t ,value))))
+
+;;;--------------------------------------------------------------------------
+;;; Pluggable parsers.
+
+(export 'call-pluggable-parser)
+(defun call-pluggable-parser (symbol &rest args)
+  "Call the pluggable parser denoted by SYMBOL.
+
+   A `pluggable parser' is an indirection point at which a number of
+   alternative parsers can be attached dynamically.  The parsers are tried in
+   some arbitrary order, so one should be careful to avoid ambiguities; each
+   is paseed the given ARGS.
+
+   If any parser succeeds then it determines the result; if any parser fails
+   having consumed input then the pluggable parser fails immediately.  If all
+   of the parsers fail without consuming input then the pluggable parser
+   fails with the union of the individual failure indicators."
+
+  (let ((expected nil))
+    (dolist (item (get symbol 'parser))
+      (multiple-value-bind (value winp consumedp) (apply (cdr item) args)
+	(when (or winp consumedp)
+	  (return-from call-pluggable-parser (values value winp consumedp)))
+	(push value expected)))
+    (values (combine-parser-failures expected) nil nil)))
+
+(export 'plug)
+(defparse plug (symbol &rest args)
+  "Call the pluggable parser denoted by SYMBOL.
+
+   This is just like the function `call-pluggable-parser', but the SYMBOL is
+   not evaluated."
+  `(call-pluggable-parser ',symbol ,@args))
+
+(export 'pluggable-parser-add)
+(defun pluggable-parser-add (symbol tag parser)
+  "Adds an element to a pluggable parser.
+
+   The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'-
+   comparable object which identifies the element.  The PARSER is a parser
+   function; it will be passed arguments via `pluggable-parser'.
+
+   If a parser with the given TAG is already attached to SYMBOL then the new
+   parser replaces the old one; otherwise it is added to the collection."
+
+  (let ((alist (get symbol 'parser)))
+    (aif (assoc tag alist)
+	 (setf (cdr it) parser)
+	 (setf (get symbol 'parser) (acons tag parser alist)))))
+
+(export 'define-pluggable-parser)
+(defmacro define-pluggable-parser (symbol tag (&rest bvl) &body body)
+  "Adds an element to a pluggable parser.
+
+   The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'-
+   comparable object which identifies the element.  Neither SYMBOL nor TAG is
+   evaluated.  The BODY is a parser expression; the BVL is a lambda list
+   describing how to bind the argumens supplied via `pluggable-parser'.
+
+   If a parser with the given TAG is already attached to SYMBOL then the new
+   parser replaces the old one; otherwise it is added to the collection."
+
+  `(pluggable-parser-add ',symbol ',tag (lambda ,bvl ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Rewindable parser context protocol.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+  (export 'parser-capture-place)
+  (defgeneric parser-capture-place (context)
+    (:documentation
+     "Capture the current position of a parser CONTEXT.
+
+   The return value may later be used with `parser-restore-place'.  Be
+   careful: all of this is happening at macro-expansion time.")
+    (:method (context)
+      (error "Parser context ~S doesn't support rewinding." context)))
+
+  (export 'parser-restore-place)
+  (defgeneric parser-restore-place (context place)
+    (:documentation
+     "`Rewind' the parser CONTEXT back to the captured PLACE.
+
+   The place was previously captured by `parser-capture-place'.  Be careful:
+   all of this is happening at macro-expansion time."))
+
+  (export 'parser-release-place)
+  (defgeneric parser-release-place (context place)
+    (:documentation
+     "Release a PLACE captured from the parser CONTEXT.
+
+   The place was previously captured by `parser-capture-place'.  The
+   underlying scanner can use this call to determine whether there are
+   outstanding captured places, and thereby optimize its behaviour.  Be
+   careful: all of this is happening at macro-expansion time.")
+    (:method (context place) nil))
+
+  (export 'parser-places-must-be-released-p)
+  (defgeneric parser-places-must-be-released-p (context)
+    (:documentation
+     "Answer whether places captured from the parser CONTEXT need releasing.
+
+   Some contexts -- well, actually, their run-time counterparts -- work
+   better if they can keep track of which places are captured, or at least if
+   there are captured places outstanding.  If this function returns true
+   (which is the default) then `with-parser-place' (and hence parser macros
+   such as `peek') will expand to `unwind-protect' forms in order to perform
+   the correct cleanup.  If it returns false, then the `unwind-protect' is
+   omitted so that the runtime code does't have to register cleanup
+   handlers.")
+    (:method (context) t)))
+
+(export 'with-parser-place)
+(defmacro with-parser-place ((place context) &body body)
+  "Evaluate BODY surrounded with a binding of PLACE to a captured place.
+
+   The surrounding code will release the PLACE properly on exit from the body
+   forms.  This is all happening at macro-expansion time."
+  ;; ... which means that it's a bit hairy.  Fortunately, the nested
+  ;; backquotes aren't that bad.
+  (once-only (context)
+    (with-gensyms (bodyfunc)
+      `(with-gensyms (,place)
+	 (flet ((,bodyfunc () ,@body))
+	   `(let ((,,place ,(parser-capture-place ,context)))
+	      ,(if (parser-places-must-be-released-p ,context)
+		   `(unwind-protect ,(,bodyfunc)
+			,(parser-release-place ,context ,place))
+		   (,bodyfunc))))))))
+
+(export 'peek)
+(defparse peek (:context (context t) parser)
+  "Attempt to run PARSER, but rewind the underlying source if it fails."
+  (with-gensyms (value win consumedp)
+    (with-parser-place (place context)
+      `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+	 (cond (,win
+		(values ,value ,win ,consumedp))
+	       (t
+		,(parser-restore-place context place)
+		(values ,value ,win nil)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Character parser context protocol.
+
+(export 'character-parser-context)
+(defclass character-parser-context ()
+  ()
+  (:documentation
+   "Base class for parsers which read one character at a time."))
+
+(export 'parser-current-char)
+(defgeneric parser-current-char (context)
+  (:documentation
+   "Return the parser's current character.
+
+   It is an error to invoke this operation if the parser is at end-of-file;
+   you must check this first.  Be careful: all of this is happening at
+   macro-expansion time."))
+
+(defparse if-char (:context (context character-parser-context)
+		   (&optional (char 'it)) condition consequent alternative)
+  "Basic character-testing parser.
+
+   If there is a current character, bind it to CHAR and evaluate the
+   CONDITION; if that is true, then step the parser and evaluate CONSEQUENT;
+   otherwise, if either we're at EOF or the CONDITION returns false, evaluate
+   ALTERNATIVE.  The result of `if-char' are the values returned by
+   CONSEQUENT or ALTERNATIVE."
+
+  (with-gensyms (block)
+    `(block ,block
+       (unless ,(parser-at-eof-p context)
+	 (let ((,char ,(parser-current-char context)))
+	   (when ,condition
+	     ,(parser-step context)
+	     (return-from ,block ,consequent))))
+       ,alternative)))
+
+(defmethod expand-parser-spec
+    ((context character-parser-context) (spec (eql :any)))
+  "Matches any character; result is the character.
+
+   The failure indicator is the keyword `:any'."
+  (expand-parser-spec context
+		      '(if-char () t
+			 (values it t t)
+			 (values '(:any) nil nil))))
+
+(export 'char)
+(defparse char (:context (context character-parser-context) char)
+  "Matches the character CHAR (evaluated); result is the character.
+
+   The failure indicator is CHAR."
+
+  (once-only (char)
+    (with-gensyms (it)
+      (expand-parser-spec context
+			  `(if-char (,it) (char= ,it ,char)
+			     (values ,it t t)
+			     (values (list ,char) nil nil))))))
+
+(defmethod expand-parser-spec
+    ((context character-parser-context) (char character))
+  (expand-parser-spec context `(char ,char)))
+
+(export 'satisfies)
+(defparse satisfies (:context (context character-parser-context) predicate)
+  "Matches a character that satisfies the PREDICATE
+
+   The PREDICATE is a function designator.  On success, the result is the
+   character.  The failure indicator is PREDICATE; you probably want to apply
+   a `label'."
+
+  (with-gensyms (it)
+    (expand-parser-spec context
+			`(if-char (,it) (,predicate ,it)
+			   (values ,it t t)
+			   (values '(,predicate) nil nil)))))
+
+(export 'not)
+(defparse not (:context (context character-parser-context) char)
+  "Matches any character other than CHAR; result is the character.
+
+   The failure indicator is (not CHAR)."
+
+  (once-only (char)
+    (with-gensyms (it)
+      (expand-parser-spec context
+			`(if-char (,it) (char/= ,it ,char)
+			   (values ,it t t)
+			   (values `((not ,,char)) nil nil))))))
+
+(export 'filter)
+(defparse filter (:context (context character-parser-context) predicate)
+  "Matches a character that satisfies the PREDICATE; result is the output of
+   PREDICATE.
+
+   The failure indicator is PREDICATE; you probably want to apply a `label'."
+
+  ;; Can't do this one with `if-char'.
+  (with-gensyms (block value)
+    `(block ,block
+       (unless ,(parser-at-eof-p context)
+	 (let ((,value (,predicate ,(parser-current-char context))))
+	   (when ,value
+	     ,(parser-step context)
+	     (return-from ,block (values ,value t t)))))
+       (values '(,predicate) nil nil))))
+
+(defmethod expand-parser-spec
+    ((context character-parser-context) (spec (eql :whitespace)))
+  "Matches any sequence of whitespace; result is nil.
+
+   Cannot fail."
+
+  `(progn
+     (cond ((and (not ,(parser-at-eof-p context))
+		 (whitespace-char-p ,(parser-current-char context)))
+	    (loop
+	      ,(parser-step context)
+	      (when (or ,(parser-at-eof-p context)
+			(not (whitespace-char-p
+			      ,(parser-current-char context))))
+		(return (values nil t t)))))
+	   (t
+	    (values nil t nil)))))
+
+(defmethod expand-parser-spec
+    ((context character-parser-context) (string string))
+  "Matches the constituent characters of STRING; result is the string.
+
+   The failure indicator is STRING; on failure, the input is rewound, so this
+   only works on rewindable contexts."
+
+  (with-gensyms (i)
+    (unless (typep string 'simple-string)
+      (setf string (make-array (length string) :initial-contents string)))
+    (with-parser-place (place context)
+      `(dotimes (,i ,(length string) (values ,string t
+					     ,(plusp (length string))))
+	 (when (or ,(parser-at-eof-p context)
+		   (char/= ,(parser-current-char context)
+			   (schar ,string ,i)))
+	   ,(parser-restore-place context place)
+	   (return (values '(,string) nil nil)))
+	 ,(parser-step context)))))
+
+;;;--------------------------------------------------------------------------
+;;; Token parser context protocol.
+
+(export 'token-parser-context)
+(defclass token-parser-context ()
+  ()
+  (:documentation
+   "Base class for parsers which read tokens with associated semantic values.
+
+   A token, according to the model suggested by this class, has a /type/,
+   which classifies the token and is the main contributer to guiding the
+   parse, and a /value/, which carries additional semantic information.
+
+   This may seem redundant given Lisp's dynamic type system; but it's not
+   actually capable of drawing sufficiently fine distinctions easily.  For
+   example, we can represent a symbol either as a string or a symbol; but
+   using strings conflicts with being able to represent string literals, and
+   using symbols looks ugly and they don't get GCed.  Similarly, it'd be
+   convenient to represent punctuation as characters, but that conflicts with
+   using them for character literals.  So, we introduce our own notion of
+   token type.
+
+   Token scanners are expected to signal end-of-file with a token of type
+   `:eof'."))
+
+(export 'parser-token-type)
+(defgeneric parser-token-type (context)
+  (:documentation
+   "Return the parser's current token type."))
+
+(export 'parser-token-value)
+(defgeneric parser-token-value (context)
+  (:documentation
+   "Return the parser's current token's semantic value."))
+
+(export 'token)
+(defparse token (:context (context token-parser-context)
+		 type &optional (value nil valuep) &key peekp)
+  "Match tokens of a particular type.
+
+   A token matches under the following conditions:
+
+     * If the value of TYPE is `t' then the match succeeds if and only if the
+       parser it not at end-of-file.
+
+     * If the value of TYPE is not `eql' to the token type then the match
+       fails.
+
+     * If VALUE is specified, and the value of VALUE is not `equal' to the
+       token semantic value then the match fails.
+
+     * Otherwise the match succeeds.
+
+   If the match is successful and the parser is not at end-of-file, and the
+   value of PEEKP is nil then the parser advances to the next token; the
+   result of the match is the token's value.
+
+   If the match fails then the failure indicator is either TYPE or (TYPE
+   VALUE), depending on whether a VALUE was specified."
+
+  (once-only (type value peekp)
+    (with-gensyms (tokty tokval)
+      `(let ((,tokty ,(parser-token-type context))
+	     (,tokval ,(parser-token-value context)))
+	 (if ,(if (eq type t)
+		  `(not (eq ,tokty :eof))
+		  (flet ((check-value (cond)
+			   (if valuep
+			       `(and ,cond (equal ,tokval ,value))
+			       cond)))
+		    (if (constantp type)
+			(check-value `(eql ,tokty ,type))
+			`(if (eq ,type t)
+			     (not (eq ,tokty :eof))
+			     ,(check-value `(eql ,tokty ,type))))))
+	     ,(let* ((result `(values ,tokval t ,(if (constantp peekp)
+						     (not peekp)
+						     `(not ,peekp))))
+		     (step (parser-step context)))
+		    (cond ((not (constantp peekp))
+			   `(multiple-value-prog1 ,result
+			      (unless ,peekp ,step)))
+			  (peekp
+			   result)
+			  (t
+			   `(multiple-value-prog1 ,result
+			      ,step))))
+	     (values (list ,(if valuep `(list ,type ,value) type))
+		     nil nil))))))
+
+(defmethod expand-parser-spec ((context token-parser-context) spec)
+  (if (atom spec)
+      (expand-parser-spec context `(token ,spec))
+      (call-next-method)))
+
+(defmethod expand-parser-spec ((context token-parser-context) (spec string))
+  (expand-parser-spec context `(token :id ,spec)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/proto-scanner.lisp b/src/parser/proto-scanner.lisp
new file mode 100644
index 0000000..87a382e
--- /dev/null
+++ b/src/parser/proto-scanner.lisp
@@ -0,0 +1,258 @@
+;;; -*-lisp-*-
+;;;
+;;; Scanner protocol definitions.
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Scanner context protocol.
+
+(export 'parser-scanner)
+(defgeneric parser-scanner (context)
+  (:documentation
+   "Return the symbol naming the CONTEXT's run-time scanner."))
+
+(export 'scanner-context)
+(defclass scanner-context ()
+  ((scanner :initarg :scanner :type symbol :reader parser-scanner))
+  (:documentation
+   "Base class for scanner contexts.
+
+   A scanner is simply an object maintaining the run-time state of a parsing
+   operation, in the same way as a parser context maintains the compile-time
+   state.  So the scanner context is a compile-time context which expands to
+   calls to use the run-time scanner.  See?
+
+   This class provides common compile-time behaviour for PARSER-AT-EOF-P and
+   friends by invoking corresponding methods on the scanner object at
+   run-time."))
+
+;;;--------------------------------------------------------------------------
+;;; Basic scanner protocol.
+
+(export 'scanner-at-eof-p)
+(defgeneric scanner-at-eof-p (scanner)
+  (:documentation
+   "Answer whether the SCANNER is at end-of-file.
+
+   It is an error to query the current item when at end-of-file."))
+
+(export 'scanner-step)
+(defgeneric scanner-step (scanner)
+  (:documentation
+   "Advance the SCANNER to the next item.
+
+   The precise nature of the items isn't known at this level, so a protocol
+   for accessing them is left for later."))
+
+;;;--------------------------------------------------------------------------
+;;; Scanner place-capture protocol.
+
+(export 'scanner-capture-place)
+(defgeneric scanner-capture-place (scanner)
+  (:documentation
+   "Capture the SCANNER's current place and return it.")
+  (:method (scanner)
+    (error "Scanner ~S doesn't support rewinding." scanner)))
+
+(export 'scanner-restore-place)
+(defgeneric scanner-restore-place (scanner place)
+  (:documentation
+   "`Rewind' the SCANNER to the captured PLACE.
+
+   The place was previously captured by `scanner-capture-place'."))
+
+(export 'scanner-release-place)
+(defgeneric scanner-release-place (scanner place)
+  (:documentation
+   "Release a PLACE captured from the SCANNER.
+
+   The place was previously captured by `scanner-capture-place'.")
+  (:method (scanner place) nil))
+
+(export 'with-scanner-place)
+(defmacro with-scanner-place ((place scanner) &body body)
+  "Evaluate BODY with PLACE bound to the captured current place.
+
+   Automatically releases the place when the BODY finishes.  Note that
+   if you wanted to circumvent the cleanup then you should have used
+   `with-parser-place', which does all of this in the meta-level."
+  (once-only (scanner)
+    `(let ((,place (scanner-capture-place ,scanner)))
+       (unwind-protect (progn ,@body)
+	 (scanner-release-place ,scanner ,place)))))
+
+;;;--------------------------------------------------------------------------
+;;; Character scanner protocol.
+
+(export 'character-scanner)
+(defclass character-scanner ()
+  ()
+  (:documentation "Base class for character scanners."))
+
+(export 'character-scanner-context)
+(defclass character-scanner-context
+    (scanner-context character-parser-context)
+  ()
+  (:documentation
+   "A context for a richer character-oriented scanner."))
+
+(export 'scanner-current-char)
+(defgeneric scanner-current-char (scanner)
+  (:documentation
+   "Returns the SCANNER's current character.
+
+   You advance to the next one using `scanner-step'."))
+
+(export 'scanner-unread)
+(defgeneric scanner-unread (scanner char)
+  (:documentation
+   "Rewind SCANNER by one character, specifically CHAR.
+
+   CHAR must be the character most recently stepped over by `scanner-step' --
+   it is an error to unread before the first call to `scanner-step'.  It is
+   also an error to unread after encountering end-of-file."))
+
+(export 'scanner-interval)
+(defgeneric scanner-interval (scanner place-a &optional place-b)
+  (:documentation
+   "Return the characters from PLACE-A up to (but not including) PLACE-B.
+
+   The characters are returned as a string.  If PLACE-B is omitted, return
+   the characters up to (but not including) the current position.  It is an
+   error if PLACE-B precedes PLACE-A or they are from different scanners."))
+
+(export '(scanner-filename scanner-line scanner-column))
+(defgeneric scanner-filename (scanner)
+  (:documentation "Return the filename backing the SCANNER.")
+  (:method (scanner) nil))
+(defgeneric scanner-line (scanner)
+  (:documentation "Return the SCANNER's current line number.")
+  (:method (scanner) nil))
+(defgeneric scanner-column (scanner)
+  (:documentation "Return the SCANNER's current column number.")
+  (:method (scanner) nil))
+
+(defun scanner-file-location (scanner)
+  "Capture the current location of the SCANNER.
+
+   This uses the generic functions `scanner-filename', `scanner-line' and
+   `scanner-column' to compute its result.  There are default methods on
+   these functions which make up dummy results.
+
+   There is a method for `file-location' defined on `character-scanner' which
+   simply calls this function; but since some scanners are structure-objects
+   rather than standard-objects they can't include `character-scanner' as a
+   superclass."
+  (make-file-location (scanner-filename scanner)
+		      (scanner-line scanner)
+		      (scanner-column scanner)))
+
+;;;--------------------------------------------------------------------------
+;;; Token scanner protocol.
+
+;; A place marker.
+
+(export '(token-scanner-place token-scanner-place-p))
+(defstruct token-scanner-place
+  "A link in the chain of lookahead tokens; capturable as a place.
+
+   If the scanner's place is captured, it starts to maintain a list of
+   lookahead tokens.  The list contains internal links -- it works out
+   slightly easier that way.  This is basically a simpler version of the
+   charbuf scanner (q.v.); most significantly, the chain links here do double
+   duty as place markers.
+
+   The details of this structure are not a defined part of the token scanner
+   protocol."
+
+  (next nil :type (or token-scanner-place null))
+  (type nil :read-only t)
+  (value nil :read-only t)
+  (line 1 :type fixnum :read-only t)
+  (column 0 :type fixnum :read-only t))
+
+;; The token scanner base class and parser context.
+
+(export '(token-scanner token-type token-value))
+(defclass token-scanner ()
+  ((type :reader token-type)
+   (value :reader token-value)
+   (captures :initform 0 :type fixnum)
+   (tail :initform nil :type (or token-scanner-place null))
+   (filename :initarg filename :type string :reader scanner-filename)
+   (line :initarg :line :initform 1 :type fixnum :accessor scanner-line)
+   (column :initarg :column :initform 0
+	   :type fixnum :accessor scanner-column))
+  (:documentation
+   "A rewindable scanner for tokenizing.
+
+   The scanner should be used via the parser protocol; see also the token
+   scanner protocol, which explains the model.
+
+   Subclasses must provide the detailed scanning behaviour -- most notably
+   the `scanner-token' generic function.  This function should also update
+   the `line' and `column' slots to track the position in the underlying
+   source, if appropriate, and also implement a method on `file-location' to
+   return the location.  This class will handle the remaining details, such
+   as dealing correctly with rewinding."))
+
+(export 'token-scanner-context)
+(defclass token-scanner-context (scanner-context token-parser-context)
+  ()
+  (:documentation
+   "A parser context for a richer token-based scanners."))
+
+;; Protocol.
+
+(export 'scanner-token)
+(defgeneric scanner-token (scanner)
+  (:documentation
+   "Internal protocol: read the next token from the SCANNER.
+
+   This function is called by `scanner-step' to actually read the next token
+   if necessary.  It should return two values: the token's `type' and its
+   `value'."))
+
+;;;--------------------------------------------------------------------------
+;;; Character scanner streams.
+;;;
+;;; This seems like an abstraction inversion, but it's important if we're to
+;;; `read' from a character scanner.
+
+(export 'character-scanner-stream)
+(defclass character-scanner-stream (fundamental-character-input-stream)
+  ((scanner :initarg :scanner))
+  (:documentation
+   "A stream which reads from a character scanner.
+
+   The SCANNER must implement the character scanner protcol, including
+   `scanner-current-char', `scanner-step', and `scanner-unread'; it is not
+   necessary that the scanner implement the place-capture protocol.
+
+   The stream can be made more efficient by implementing
+   `stream-read-sequence' and `stream-read-line' in a scanner-specific
+   manner."))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/proto-streams.lisp b/src/parser/proto-streams.lisp
new file mode 100644
index 0000000..bcce02a
--- /dev/null
+++ b/src/parser/proto-streams.lisp
@@ -0,0 +1,46 @@
+;;; -*-lisp-*-
+;;;
+;;; Additional stream protocol.
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Discovery of file names.
+
+(export 'stream-pathname)
+(defgeneric stream-pathname (stream)
+  (:documentation
+   "Returns the pathname of the file that STREAM is open on.
+
+   If STREAM is open on a file, then return the pathname of that file.
+   Otherwise return NIL.")
+
+  ;; Provide some default methods.  Most streams don't have a pathname.
+  ;; File-based streams provide a pathname, but it's usually been merged with
+  ;; *DEFAULT-PATHNAME-DEFAULTS* or some such, which has made it absolute,
+  ;; which isn't ideal.  We'll hack around this in more useful classes later.
+  (:method ((stream stream)) nil)
+  (:method ((stream file-stream)) (pathname stream)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/test-parser.lisp b/src/parser/test-parser.lisp
new file mode 100644
index 0000000..f25961e
--- /dev/null
+++ b/src/parser/test-parser.lisp
@@ -0,0 +1,444 @@
+;;; -*-lisp-*-
+;;;
+;;; Test parser infrastructure
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-test)
+
+(defclass test-parser (test-case)
+  ())
+(add-test *sod-test-suite* (get-suite test-parser))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defmacro assert-parse
+    ((string value winp consumedp &key (scanner (gensym "SCANNER-")))
+     &body parser)
+  (once-only (string value winp consumedp)
+    (with-gensyms (my-value my-winp my-consumedp label what)
+      `(let ((,scanner (make-string-scanner ,string)))
+	 (multiple-value-bind (,my-value ,my-winp ,my-consumedp)
+	     (with-parser-context
+		 (character-scanner-context :scanner ,scanner)
+	       (parse ,@parser))
+	   (flet ((,label (,what)
+		    (format nil "~A; parsing ~S with ~S"
+			    ,what ,string ',@parser)))
+	     (cond (,winp
+		    (assert-true ,my-winp (,label "winp"))
+		    (if (eq ,value t)
+			(assert-not-eql ,my-value nil
+					(,label "parser result"))
+			(assert-equal ,my-value ,value
+				      (,label "parser result"))))
+		   (t
+		    (assert-false ,my-winp (,label "winp"))
+		    (assert-true (and (null (set-difference ,my-value ,value
+							    :test #'equal))
+				      (null (set-difference ,value ,my-value
+							    :test #'equal)))
+				 (,label "failure indicator"))))
+	     (if ,consumedp
+		 (assert-true ,my-consumedp (,label "consumedp"))
+		 (assert-false ,my-consumedp (,label "consumedp")))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Simple parser tests.
+;;;
+;;; This lot causes SBCL to warn like a mad thing.  It's too clever for us,
+;;; and does half of the work at compile time!
+
+(def-test-method test-simple ((test test-parser) :run nil)
+  "Test simple atomic parsers, because we rely on them later."
+
+  ;; Characters match themselves.  For a character known only at run-time,
+  ;; use (char CH).
+  (assert-parse ("abcd" #\a t t) #\a)
+  (let ((ch #\b))
+    (assert-parse ("abcd" '(#\b) nil nil) (char ch)))
+
+  ;; A character can't match at EOF.
+  (assert-parse ("" '(#\z) nil nil) #\z)
+
+  ;; All characters match :any; but EOF isn't a character.
+  (assert-parse ("z" #\z t t) :any)
+  (assert-parse ("" '(:any) nil nil) :any)
+
+  ;; The parser (satisfies PREDICATE) succeeds if the PREDICATE returns
+  ;; true when applied to the current character.
+  (assert-parse ("a" #\a t t) (satisfies alpha-char-p))
+  (assert-parse ("0" '(alpha-char-p) nil nil) (satisfies alpha-char-p))
+
+  ;; The parser (not CHAR) matches a character other than CHAR; but it won't
+  ;; match EOF.
+  (assert-parse ("a" #\a t t) (not #\b))
+  (assert-parse ("b" '((not #\b)) nil nil) (not #\b))
+  (assert-parse ("" '((not #\b)) nil nil) (not #\b))
+
+  ;; But :eof matches only at EOF.
+  (assert-parse ("" :eof t nil) :eof)
+  (assert-parse ("abcd" '(:eof) nil nil) :eof)
+
+  ;; Strings match themselves without consuming if they fail.
+  (assert-parse ("abcd" "ab" t t) "ab")
+  (assert-parse ("abcd" '("cd") nil nil) "cd"))
+
+(def-test-method test-sequence ((test test-parser) :run nil)
+
+  ;; An empty sequence always succeeds and never consumes.  And provokes
+  ;; warnings: don't do this.
+  (assert-parse ("" :win t nil) (seq () :win))
+  (assert-parse ("abcd" :win t nil) (seq () :win))
+
+  ;; A `seq' matches the individual parsers in order, and binds their results
+  ;; to variables -- if given.  The result is the value of the body.  If any
+  ;; parser fails having consumed input, then input stays consumed.  There's
+  ;; no backtracking.
+  (assert-parse ("abcd" '(#\a . #\c) t t)
+    (seq ((foo #\a) #\b (bar #\c)) (cons foo bar)))
+  (assert-parse ("abcd" '(#\c) nil t)
+    (seq ((foo #\a) (bar #\c)) (cons foo bar)))
+  (assert-parse ("abcd" '(#\c) nil nil)
+    (seq ((bar #\c) (foo #\a)) (cons foo bar))))
+
+(def-test-method test-repeat ((test test-parser) :run nil)
+
+  ;; A `many' matches a bunch of similar things in a row.  You can compute a
+  ;; result using `do'-like accumulation.
+  (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc)) #\a))
+
+  ;; The default minimum is zero; so the parser always succeeds.
+  (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc)) #\b))
+
+  ;; You can provide an explicit minimum.  Then the match might fail.
+  (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min 2) #\a))
+  (assert-parse ("aabb" '(#\a) nil t) (many (acc 0 (1+ acc) :min 3) #\a))
+
+  ;; You can also provide an explicit maximum.  This will cause the parser to
+  ;; stop searching, but it can't make it fail.
+  (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max 3) #\a))
+
+  ;; You can provide both a maximum and a minimum at the same time.  If
+  ;; they're consistent, you won't be surprised.  If they aren't, then the
+  ;; maximum wins and the minimum is simply ignored (currently).
+  (assert-parse ("aaaaab" 4 t t)
+    (many (acc 0 (1+ acc) :min 3 :max 4) #\a))
+  (assert-parse ("aabbbb" '(#\a) nil t)
+    (many (acc 0 (1+ acc) :min 3 :max 4) #\a))
+  (assert-parse ("aaabbb" 3 t t)
+    (many (acc 0 (1+ acc) :min 3 :max 3) #\a))
+  (assert-parse ("aaabbb" 3 t t)
+    (many (acc 0 (1+ acc) :min 17 :max 3) #\a))
+
+  ;; You can provide a separator.  The `many' parser will look for the
+  ;; separator between each of the main items, but will ignore the results.
+  (assert-parse ("a,a,abc" 3 t t) (many (acc 0 (1+ acc)) #\a #\,))
+  (assert-parse ("a,a,abc" 2 t t) (many (acc 0 (1+ acc) :max 2) #\a #\,))
+
+  ;; If `many' sees a separator then by default it commits to finding another
+  ;; item; so this can cause a parse to fail.
+  (assert-parse ("a,a,bc" '(#\a) nil t) (many (acc 0 (1+ acc)) #\a #\,))
+  (assert-parse ("abc" 1 t t) (many (acc 0 (1+ acc)) #\a #\,))
+
+  ;; If you specify a separator then the default minimum number of
+  ;; repetitions becomes 1 rather than 0.  But you can override this
+  ;; explicitly.
+  (assert-parse ("bc" '(#\a) nil nil) (many (acc 0 (1+ acc)) #\a #\,))
+  (assert-parse ("bc" 0 t nil) (many (acc 0 (1+ acc) :min 0) #\a #\,))
+
+  ;; The parser will fail looking for a separator if there aren't enough
+  ;; items.
+  (assert-parse ("a,abc" '(#\,) nil t)
+    (many (acc 0 (1+ acc) :min 3) #\a #\,))
+
+  ;; You can override the commit-on-separator behaviour by using :commit.
+  ;; This makes a trailing separator legal (but optional), so it also affects
+  ;; the behaviour regarding maximum and minimum repetitions.  (Commitment is
+  ;; irrelevant if you don't have a separator.)
+  (assert-parse ("a,a,bc" 2 t t)
+    (many (acc 0 (1+ acc) :commitp nil) #\a #\,))
+  (assert-parse ("a,a,abc" 3 t t)
+    (many (acc 0 (1+ acc) :commitp nil) #\a #\,))
+  (assert-parse ("a,a,a,bc" 3 t t)
+    (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp t) #\a #\,))
+	  #\,)
+      n))
+  (assert-parse ("a,a,a,bc" 3 t t)
+    (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp nil) #\a #\,))
+	  #\b)
+      n))
+  (assert-parse ("a,a,bc" '(#\a) nil t)
+    (many (acc 0 (1+ acc) :min 3 :commitp nil) #\a #\,))
+
+  ;; The `many' parser won't backtrack.  The `many' eats as many `a's as
+  ;; possible; asking for another one is sure to fail.
+  (assert-parse ("aaaabc" '(#\a) nil t) (and (skip-many () #\a) #\a)))
+
+(def-test-method test-repeat-hairy ((test test-parser) :run nil)
+  ;; The `many' expander is very hairy and does magical things if it notices
+  ;; that some of its arguments are constants.  So here we test a number of
+  ;; the above things again, using variables so that it has to produce code
+  ;; which makes decisions at run-time.  (I've no doubt that SBCL will issue
+  ;; an infinite number of notes explaining how clever it is and how it can
+  ;; do it all at compile-time anyway.  Of course, suppressing these notes is
+  ;; the main reason `many' is so hairy anyway.)
+
+  (let ((zero 0) (two 2) (three 3) (yes t) (no nil))
+
+    ;; Minima.
+    (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :min zero) #\a))
+    (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc) :min zero) #\b))
+    (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min two) #\a))
+    (assert-parse ("aabb" '(#\a) nil t)
+      (many (acc 0 (1+ acc) :min three) #\a))
+
+    ;; Maxima.
+    (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :max no) #\a))
+    (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max three) #\a))
+
+    ;; And now together with separators and commitment.  Oh, my.
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (many (acc 0 (1+ acc) :commitp no) #\a #\,))
+    (assert-parse ("a,a,a,bc" '(#\a) nil t)
+      (many (acc 0 (1+ acc) :commitp yes) #\a #\,))
+    (assert-parse ("a,a,bc" '(#\a) nil t)
+      (many (acc 0 (1+ acc) :min three :commitp yes) #\a #\,))
+    (assert-parse ("a,a,bc" '(#\a) nil t)
+      (many (acc 0 (1+ acc) :min 3 :commitp yes) #\a #\,))
+    (assert-parse ("a,a,bc" '(#\a) nil t)
+      (many (acc 0 (1+ acc) :min three :commitp t) #\a #\,))
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (seq ((n (many (acc 0 (1+ acc) :max three :commitp no) #\a #\,)) #\b)
+	n))
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (seq ((n (many (acc 0 (1+ acc) :max three :commitp yes) #\a #\,)) #\,)
+	n))
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp no) #\a #\,)) #\b)
+	n))
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp yes) #\a #\,)) #\,)
+	n))
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (seq ((n (many (acc 0 (1+ acc) :max three :commitp nil) #\a #\,)) #\b)
+	n))
+    (assert-parse ("a,a,a,bc" 3 t t)
+      (seq ((n (many (acc 0 (1+ acc) :max three :commitp t) #\a #\,)) #\,)
+	n))))
+
+(def-test-method test-alternate ((test test-parser) :run nil)
+
+  ;; An `or' matches the first parser that either succeeds or fails having
+  ;; consumed input.
+  (assert-parse ("abcd" #\a t t) (or #\a #\b))
+  (assert-parse ("abcd" #\a t t) (or #\b #\a))
+  (assert-parse ("abcd" '(#\b #\c) nil nil) (or #\b #\c))
+
+  ;; Strings don't consume if they fail.
+  (assert-parse ("abcd" "ab" t t) (or "cd" "ab"))
+  (assert-parse ("abcd" "ab" t t) (or "ad" "ab"))
+  (assert-parse ("abcd" '("ad" "ac") nil nil) (or "ad" "ac"))
+
+  ;; But `seq' will if some component consumes.
+  (assert-parse ("abcd" '(#\d) nil t) (or (and #\a #\d) "ab"))
+  (assert-parse ("abcd" "ab" t t) (or (and #\c #\d) "ab"))
+
+  ;; We can tame this using `peek' which rewinds the source if its argument
+  ;; fails, so as to hide consumption of input.
+  (assert-parse ("abcd" "ab" t t) (or (peek (and #\a #\d)) "ab"))
+  (assert-parse ("abcd" '(#\a #\b "cd") t t)
+    (seq ((foo (peek (seq ((foo #\a) (bar #\b)) (list foo bar))))
+	  (bar "cd"))
+      (append foo (list bar))))
+
+  ;; Failure indicators are union'd if they all fail.
+  (assert-parse ("abcd" '(#\q #\x #\z) nil nil)
+    (or #\q (peek (and #\a (or #\x #\q))) #\z))
+
+  ;; But if any of them consumed input then you only get the indicators from
+  ;; the consuming branch, because we committed to it when we consumed the
+  ;; input.
+  (assert-parse ("abcd" '(#\x #\q) nil t)
+    (or #\q #\z (and #\a (or #\q #\x)))))
+
+;;;--------------------------------------------------------------------------
+;;; Some tests with a simple recursive parser.
+
+(defstruct (node
+	     (:predicate nodep)
+	     (:constructor make-node (left data right)))
+  "Structure type for a simple binary tree."
+  left data right)
+
+(defun parse-tree (scanner)
+  "Parse a textual representation into a simple binary tree.
+
+   The syntax is simple:
+
+	TREE ::= EMPTY | `(' TREE CHAR TREE `)'
+
+   There's an ambiguity in this syntax, at least if you have limited
+   lookahead: suppose you've just parsed the opening `(' of a TREE, and you
+   see another `(' -- is it the start of the non-empty left sub-TREE, or is
+   it the CHAR following an empty left sub-TREE?  We opt for the first choice
+   always."
+
+  ;; This came from another project, although it isn't actually used there.
+  ;; It exposed the weakness in an earlier design which prompted the addition
+  ;; of the CONSUMEDP flags to the parser protocol.
+
+  (with-parser-context (character-scanner-context :scanner scanner)
+    (labels ((tree ()
+	       (parse (or (seq (#\(
+				(left (tree))
+				(data :any)
+				(right (tree))
+				#\))
+			    (make-node left data right))
+			  (values nil t nil)))))
+      (parse (seq ((tree (tree)) :eof)
+	       tree)))))
+
+(defun parse-tree-lookahead (scanner)
+  "Parse a textual representation into a simple binary tree.
+
+   The syntax is simple, and, indeed, the grammar's the same as for
+   `sod-parse-tree':
+
+	TREE ::= EMPTY | `(' TREE CHAR TREE `)'
+
+   But the rules are different.  Instead of resolving the `ambiguity' between
+   TREE and CHAR when we find another `(' after the opening `(' of a TREE
+   deterministically in favour of TREE as `parse-tree' does, we try that
+   first, and backtrack if necessary."
+
+  ;; Bison can do this, but you have to persuade it to use the scary GLR
+  ;; parser algorithm
+
+  (with-parser-context (character-scanner-context :scanner scanner)
+    (labels ((tree ()
+	       (parse (or (peek (seq (#\(
+				      (left (tree))
+				      (data :any)
+				      (right (tree))
+				      #\))
+				  (make-node left data right)))
+			  (values nil t nil)))))
+      (parse (seq ((tree (tree)) :eof)
+	       tree)))))
+
+(def-test-method test-simple-tree-parser ((test test-parser) :run nil)
+  (assert-parse ("" nil t nil :scanner sc) (parse-tree sc))
+  (assert-parse ("((a)b((c)d(e)))" t t t :scanner sc) (parse-tree sc))
+  (assert-parse ("((a)b((c)d(e)))z" '(:eof) nil t :scanner sc)
+    (parse-tree sc))
+  (assert-parse ("((a)b((c)d(e))" '(#\)) nil t :scanner sc) (parse-tree sc))
+  (assert-parse ("(([)*(]))" t t t :scanner sc) (parse-tree sc))
+  (assert-parse ("((()-()))" '(#\)) nil t :scanner sc) (parse-tree sc))
+  (assert-parse ("((()-()))" t t t :scanner sc) (parse-tree-lookahead sc)))
+
+;;;--------------------------------------------------------------------------
+;;; Test expression parser.
+
+(defparse token (:context (context character-parser-context) parser)
+  (with-gensyms (value)
+    (expand-parser-spec context
+			`(seq ((,value ,parser) :whitespace) ,value))))
+
+(let ((add (binop "+" (x y 5) `(+ ,x ,y)))
+      (sub (binop "-" (x y 5) `(- ,x ,y)))
+      (mul (binop "*" (x y 7) `(* ,x ,y)))
+      (div (binop "/" (x y 7) `(/ ,x ,y)))
+      (eq (binop "=" (x y 3 :assoc nil) `(= ,x ,y)))
+      (ne (binop "/=" (x y 3 :assoc nil) `(/= ,x ,y)))
+      (lt (binop "<" (x y 3 :assoc nil) `(< ,x ,y)))
+      (gt (binop ">" (x y 3 :assoc nil) `(> ,x ,y)))
+      (and (binop "&" (x y 2) `(and ,x ,y)))
+      (or (binop "|" (x y 1) `(or ,x ,y)))
+      (expt (binop "**" (x y 8 :assoc :right) `(** ,x ,y)))
+      (neg (preop "-" (x 9) `(- ,x)))
+      (not (preop "!" (x 2) `(not ,x)))
+      (fact (postop "!" (x 10) `(! ,x)))
+      (lp (lparen #\))) (rp (rparen #\)))
+      (lb (lparen #\])) (rb (rparen #\])))
+  (defun test-parse-expr (string)
+    (with-parser-context (string-parser :string string)
+      (parse (seq (:whitespace
+		   (value (expr (:nestedp nestedp)
+			    (token (many (a 0 (+ (* a 10) it) :min 1)
+				     (filter digit-char-p)))
+			    (token (or (seq ("**") expt)
+				       (seq ("/=") ne)
+				       (seq (#\+) add)
+				       (seq (#\-) sub)
+				       (seq (#\*) mul)
+				       (seq (#\/) div)
+				       (seq (#\=) eq)
+				       (seq (#\<) lt)
+				       (seq (#\>) gt)
+				       (seq (#\&) and)
+				       (seq (#\|) or)))
+			    (token (or (seq (#\() lp)
+				       (seq (#\-) neg)
+				       (seq (#\!) not)))
+			    (token (or (seq (#\!) fact)
+				       (when nestedp (seq (#\)) rp))))))
+		   (next (or :any (t :eof))))
+	       (cons value next))))))
+
+(defun assert-expr-parse (string value winp consumedp)
+  (multiple-value-bind (v w c) (test-parse-expr string)
+    (flet ((message (what)
+	     (format nil "expression ~S; ~A" string what)))
+      (cond (winp (assert-true w (message "winp"))
+		  (assert-equal v value (message "value")))
+	    (t (assert-false w (message "winp"))
+	       (assert-equal v value (message "expected"))))
+      (assert-eql c consumedp (message "consumedp")))))
+
+(def-test-method test-expression-parser ((test test-parser) :run nil)
+  (assert-expr-parse "1 + 2 + 3" '((+ (+ 1 2) 3) . :eof) t t)
+  (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t)
+  (assert-expr-parse "1 * 2 + 3" '((+ (* 1 2) 3) . :eof) t t)
+  (assert-expr-parse "(1 + 2) * 3" '((* (+ 1 2) 3) . :eof) t t)
+  (assert-expr-parse "1 ** 2 ** 3" '((** 1 (** 2 3)) . :eof) t t)
+  (assert-expr-parse "1 + 2) * 3" '((+ 1 2) . #\)) t t)
+  (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t)
+
+  (assert-expr-parse "! 1 + 2 = 3 | 6 - 3 /= 12/6"
+		     '((or (not (= (+ 1 2) 3))
+			   (/= (- 6 3) (/ 12 6)))
+		       . :eof)
+		     t t)
+  (assert-expr-parse "! 1 > 2 & ! 4 < 6 | 3 < 4 & 9 > 10"
+		     '((or (and (not (> 1 2)) (not (< 4 6)))
+			   (and (< 3 4) (> 9 10)))
+		       . :eof)
+		     t t)
+
+  (assert-condition 'simple-error (test-parse-expr "(1 + 2"))
+  (assert-condition 'simple-error (test-parse-expr "(1 + 2]"))
+  (assert-condition 'simple-error (test-parse-expr "1 < 2 < 3")))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/test-scanner-charbuf.lisp b/src/parser/test-scanner-charbuf.lisp
new file mode 100644
index 0000000..299e552
--- /dev/null
+++ b/src/parser/test-scanner-charbuf.lisp
@@ -0,0 +1,353 @@
+;;; -*-lisp-*-
+;;;
+;;; Test for the charbuf scanner
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;; The charbuf scanner is a hairy beast and in need of a thorough going
+;;; over.
+
+(cl:in-package #:sod-test)
+
+;;;--------------------------------------------------------------------------
+;;; Tests of the low-level seeking and fetching machinery.
+
+(defclass charbuf-test (test-case) (scanner))
+(add-test *sod-test-suite* (get-suite charbuf-test))
+
+(defparameter *background-pattern*
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789."
+  "Basic pattern underlying our initial buffer contents.
+
+   The pattern is one character short of the base-64 sequence `A-Za-z0-9./',
+   with the aim of making its length be prime to the actual buffer length --
+   so that the pattern doesn't repeat exactly for many buffers.")
+(assert (= (gcd (length *background-pattern*) charbuf-size) 1))
+
+(defun make-pattern-string (start end)
+  "Return a string containing the buffer pattern between START and END.
+
+   The most interesting cases occur at the boundaries between buffers; so we
+   shall want to put recognizable patterns there.  The buffers are quite big
+   (we import `charbuf-size' off the books so that we don't actually have to
+   know exactly) but we should still fill with a repeating pattern so that we
+   can detect synchronization failures.
+
+   We fill most of the buffer with the `*background-pattern*', which has been
+   chosen so as not to align nicely with the buffer size.  Across the joins,
+   we write a string `<<N][N+1>>', where the boundary is between `]' and `[',
+   and the numbers N and N + 1 are the numbers, in words, of the respective
+   buffers."
+
+  (with-output-to-string (out)
+    (multiple-value-bind (n0 i0) (floor start charbuf-size)
+      (multiple-value-bind (n1 i1) (floor end charbuf-size)
+
+	(do ((n n0 (1+ n))) ((> n n1))
+	  (let* ((l (format nil "[~R>>" n))
+		 (r (format nil "<<~R]" n))
+		 (m (length l))
+		 (q (length *background-pattern*))
+		 (i (if (= n n0) i0 0))
+		 (e (if (= n n1) i1 charbuf-size))
+		 (k (min (- charbuf-size m) e)))
+	    (when (< i (length l))
+	      (write-string l out :start i :end (min e m))
+	      (setf i m))
+	    (do ((o (mod (+ (* charbuf-size n) i) q) 0))
+		((>= i k))
+	      (let ((p (min (- k i) (- q o))))
+		(write-string *background-pattern* out :start o :end (+ o p))
+		(incf i p)))
+	    (when (< k e)
+	      (write-string r out :start (- i k) :end (- e k)))))))))
+
+(defparameter *test-pattern* (make-pattern-string 0 10000)
+  "The pattern that our test scanner is reading.")
+
+(defmethod set-up ((test charbuf-test))
+  (with-slots (scanner) test
+    (let ((stream (make-string-input-stream *test-pattern*)))
+      (setf scanner (make-instance 'charbuf-scanner
+				   :stream stream
+				   :filename "<magic test>")))))
+
+(defun skip (scanner n)
+  (assert (>= n 0))
+  (charbuf-scanner-map scanner
+		       (lambda (buf start end)
+			 (declare (ignore buf))
+			 (let ((d (- end start)))
+			   (if (>= d n)
+			       (values t (+ start n))
+			       (progn (decf n d) (values nil 0)))))))
+
+(defun assert-string-next (scanner pos len)
+  "Assert that the next LEN characters from SCANNER are correct.
+
+   That is, that they match the corresponding LEN characters starting at
+   position POS as returned by `make-pattern-string'."
+  (let ((want (make-pattern-string pos (+ pos len))))
+    (dotimes (i len)
+      (assert-false (scanner-at-eof-p scanner))
+      (assert-eql (scanner-current-char scanner) (char want i))
+      (scanner-step scanner))))
+
+(def-test-method test-pattern ((test charbuf-test) :run nil)
+  ;; Make sure the pattern is what we expect.  This is a completely different
+  ;; (and considerably more stupid) way of generating the basic pattern up to
+  ;; a particular length.
+  (let* ((len (length *background-pattern*))
+	 (string ""))
+    (loop while (< (length string) len)
+	  do (setf string (concatenate 'string string *test-pattern*)))
+    (loop for n from 0
+	  for i from 0 by charbuf-size below len
+	  for l = (format nil "[~R>>" n) and r = (format nil "<<~R]" n)
+	  for e = (- (+ i charbuf-size) (length r))
+	  do (setf (subseq string i) l)
+	  when (< e len) do (setf (subseq string e) r))
+    (assert-equal (subseq string 0 len)
+		  (make-pattern-string 0 len))))
+
+(def-test-method test-read ((test charbuf-test) :run nil)
+  ;; Test reading from various places.
+  (with-slots (scanner) test
+    (loop for prev = 0 then (+ pos len)
+	  for (pos len) in '((0 10) (50 250) (4086 20)
+			     (5000 3192) (9800 200)) do
+	  (assert (>= pos prev))
+	  (skip scanner (- pos prev))
+	  (assert-string-next scanner pos len))
+    (assert-true (scanner-at-eof-p scanner))))
+
+(def-test-method test-unread ((test charbuf-test) :run nil)
+  ;; Torture test for `scanner-unread', which is distressingly hairy.
+  (with-slots (scanner) test
+
+    (flet ((test (here next skip there note)
+	     (assert-eql (scanner-current-char scanner) here
+			 (format nil "Here (~A)." note))
+	     (scanner-step scanner)
+	     (assert-eql (scanner-current-char scanner) next
+			 (format nil "Next (~A)." note))
+	     (scanner-unread scanner here)
+	     (with-scanner-place (place scanner)
+	       (assert-eql (scanner-current-char scanner) here
+			   (format nil "Here again (~A)." note))
+	       (scanner-step scanner)
+	       (assert-eql (scanner-current-char scanner) next
+			   (format nil "Next again (~A)." note))
+	       (skip scanner skip)
+	       (assert-eql (scanner-current-char scanner) there
+			   (format nil "There (~A)." note))
+	       (scanner-unread scanner there)
+	       (with-scanner-place (another-place scanner)
+		 (scanner-restore-place scanner place)
+		 (assert-eql (scanner-current-char scanner) here
+			     (format nil "Here restored (~A)." note))))))
+
+      (test #\[ #\z 51 #\0 "start")
+      (skip scanner 4095)
+      (test #\] #\[ 4096 #\[ "edge")
+
+      ;; Check behaviour at EOF.  Ought to test behaviour when EOF is on a
+      ;; buffer boundary too.
+      (skip scanner 5904)
+      (assert-false (scanner-at-eof-p scanner))
+      (assert-eql (scanner-current-char scanner) #\t "EOF.")
+      (scanner-step scanner)
+      (assert-true (scanner-at-eof-p scanner))
+      (scanner-unread scanner #\t)
+      (assert-false (scanner-at-eof-p scanner))
+      (assert-eql (scanner-current-char scanner) #\t "EOF again."))))
+
+(def-test-method test-rewind ((test charbuf-test) :run nil)
+  ;; Test reading, like before, but this time with rewinding.
+  (with-slots (scanner) test
+    (let* ((list '((0 10) (0 10000) (50 250) (4086 20)
+		   (4095 4097) (5000 3192) (9999 1)))
+	   (places (loop for prev = 0 then pos
+			 for (pos) in list
+			 do (skip scanner (- pos prev))
+			 collect (scanner-capture-place scanner))))
+      (loop for (pos len) in list
+	    for place in places do
+	    (scanner-restore-place scanner place)
+	    (assert-string-next scanner pos len))
+      (assert-true (scanner-at-eof-p scanner)))))
+
+(def-test-method test-interval ((test charbuf-test) :run nil)
+  ;; Test fetching intervals of text.
+  (with-slots (scanner) test
+    (let* ((posns '(0 12 4080 4110 5000 9000 10000))
+	   (places (loop for prev = 0 then pos
+			 for pos in posns
+			 do (skip scanner (- pos prev))
+			 collect (scanner-capture-place scanner))))
+      (loop for p0 in places
+	    for i0 in posns do
+	    (loop for p1 in places
+		  for i1 in posns do
+		  (if (< i1 i0)
+		      (assert-condition 'error (scanner-interval p0 p1))
+		      (assert-equal (scanner-interval scanner p0 p1)
+				    (make-pattern-string i0 i1)
+				    (format nil "Mismatch interval ~A .. ~A."
+					    i0 i1)))
+		  (assert-true (scanner-at-eof-p scanner)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Tests of the position tracking machinery.
+
+(defparameter *position-test-text*
+  ;; Use a roundabout method of getting tabs in there, so that they don't get
+  ;; screwed by strange editors and suchlike.
+  (substitute #\tab #\@ "Line one
+Line two is rather longer, but not noticeably more interesting.
+Line three explains that line four contains column numbers mod 10.
+012345678@6789@@2345678@012
+@@Line five is indented somewhat.")
+  "Text for the position-tracking test.
+
+   The text should /look/ like the following.  Note that this text here may
+   get trashed by tab/space conversions and whatever, and I've indented it so
+   that it doesn't look daft in the source; but the columns should remain
+   where they are.
+
+   0         1         2         3         4         5         6         7
+   0123456789012345678901234567890123456789012345678901234567890123456789012
+   Line one
+   Line two is rather longer, but not noticeably more interesting.
+   Line three explains that line four contains column numbers mod 10.
+   012345678       6789            2345678 012
+		   Line five is indented somewhat.
+
+   It would be nice at some point to add additional tests for edge cases
+   around buffer boundaries.  This isn't completely essential, though: the
+   current implementation manages positions fairly independently of the
+   buffering.")
+
+(defparameter *known-positions*
+  '(
+    ;; The first few line aren't actually very interesting.  We'll
+    ;; check the start and end positions, and maybe a few in the
+    ;; middle.  Note that a newline character is logically a part of
+    ;; the preceding line.
+    (0 #\L 1 0 #\i 1 1 0) (5 #\o 1 5 #\n 1 6 5) (8 #\newline 1 8 #\L 2 0 0)
+    (9 #\L 2 0 #\i 2 1 0) (72 #\newline 2 63 #\L 3 0 0)
+    (73 #\L 3 0 #\i 3 1 0) (139 #\newline 3 66 #\0 4 0 0)
+
+    ;; Now for the line with the fancy tabbings.
+    (140 #\0 4 0 #\1 4 1 0)
+    (148 #\8 4 8 #\tab 4 9 8)		; nothing so far
+    (149 #\tab 4 9 #\6 4 16 15)		; the tab itself just follows on
+    (150 #\6 4 16 #\7 4 17 16)		; but the char after is tabbed
+    (154 #\tab 4 20 #\tab 4 24 23)	; next tab position
+    (155 #\tab 4 24 #\2 4 32 31)	; two in a row
+    (156 #\2 4 32 #\3 4 33 32)		; should be here now
+    (162 #\8 4 38 #\tab 4 39 38)	; skip to the next bit
+    (163 #\tab 4 39 #\0 4 40 39)	; tab is here
+    (164 #\0 4 40 #\1 4 41 40)		; and doesn't move us much
+    (166 #\2 4 42 #\newline 4 43 42)	; last actual character on the line
+    (167 #\newline 4 43 #\tab 5 0 0)	; and the ending newline
+
+    ;; And the final line.
+    (168 #\tab 5 0 #\tab 5 8 7)		; first tab on next line
+    (169 #\tab 5 8 #\L 5 16 15)		; and the second
+    (170 #\L 5 16 #\i 5 17 16)		; beginning of the text
+    (200 #\. 5 46 :eof 5 47 46)		; last character in the stream
+    (201 :eof 5 47))			; but eof has a position too
+  "List of character positions, characters and line/column numbers.
+
+   The characters are there for sanity-checking purposes.  The format is
+
+	(INDEX CHAR LINE COLUMN NEXT-CHAR
+	 NEXT-LINE NEXT-COLUMN REWIND-COLUMN)
+
+   which asserts that the character at INDEX is CHAR, found at the given LINE
+   and COLUMN, that the next character is NEXT-CHAR, at the NEXT-LINE and
+   NEXT-COLUMN, and if one unreads from there, it will be (possibly
+   erroneously) claimed that the character at INDEX is at REWIND-COLUMN.
+   (Restoring a captured place shouldn't get the column wrong -- only
+   unreading.)
+
+   The symbol `:eof' means that there is no character at the given INDEX,
+   because the file has already ended.  However, EOF has a position which
+   should be correct, and it should be possible to unread from EOF.")
+
+(defclass charbuf-position-test (test-case) (scanner))
+(add-test *sod-test-suite* (get-suite charbuf-position-test))
+
+(defmethod set-up ((test charbuf-position-test))
+  (with-slots (scanner) test
+    (let ((stream (make-string-input-stream *position-test-text*)))
+      (setf scanner (make-instance 'charbuf-scanner
+				   :stream stream
+				   :filename "<position test>")))))
+
+(defun check-position (scanner pos char line column note)
+  (if (eq char :eof)
+      (assert-true (scanner-at-eof-p scanner)
+		   (format nil "EOF, position ~A (~A)." pos note))
+      (assert-eql char (scanner-current-char scanner)
+		  (format nil "Character, position ~A (~A)." pos note)))
+  (assert-eql line (scanner-line scanner)
+	      (format nil "Line number, position ~A (~A)." pos note))
+  (assert-eql column (scanner-column scanner)
+	      (format nil "Column number, position ~A (~A)." pos note)))
+
+(def-test-method test-simple-positions
+    ((test charbuf-position-test) :run nil)
+  (with-slots (scanner) test
+    (loop for prev = 0 then pos
+	  for (pos char line column) in *known-positions* do
+	  (loop repeat (- pos prev) do (scanner-step scanner))
+	  (check-position scanner pos char line column "simple"))))
+
+(def-test-method test-rewind-positions
+    ((test charbuf-position-test) :run nil)
+  (with-slots (scanner) test
+    (let ((places (loop for prev = 0 then pos
+			for (pos char line column) in *known-positions* do
+			(skip scanner (- pos prev))
+			(check-position scanner pos char line column "skip")
+			collect (scanner-capture-place scanner))))
+      (loop for place in places
+	    for (pos char line column
+		     next-char next-line next-column
+		     rewind-column)
+	    in *known-positions* do
+	    (scanner-restore-place scanner place)
+	    (check-position scanner pos char line column "rewind")
+	    (unless (eq char :eof)
+	      (scanner-step scanner)
+	      (check-position scanner (1+ pos) next-char
+			      next-line next-column "step")
+	      (scanner-unread scanner char)
+	      (check-position scanner pos char line rewind-column
+			      "unread")
+	      (scanner-step scanner)
+	      (check-position scanner (1+ pos) next-char
+			      next-line next-column "restep"))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-c-types.lisp b/src/proto-c-types.lisp
new file mode 100644
index 0000000..304562a
--- /dev/null
+++ b/src/proto-c-types.lisp
@@ -0,0 +1,259 @@
+;;; -*-lisp-*-
+;;;
+;;; Protocol for C type representation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Root classes and common access protocol.
+
+;; It seems more useful to put the root class here, so that we can provide
+;; methods specialized on it, e.g., PRINT-OBJECT.
+
+(export 'c-type)
+(defclass c-type ()
+  ()
+  (:documentation
+   "Base class for C type objects."))
+
+(export '(qualifiable-c-type c-type-qualifiers))
+(defclass qualifiable-c-type (c-type)
+  ((qualifiers :initarg :qualifiers :initform nil
+	       :type list :reader c-type-qualifiers))
+  (:documentation
+   "Base class for C types which can be qualified."))
+
+(export 'canonify-qualifiers)
+(defun canonify-qualifiers (qualifiers)
+  "Return a canonical list of qualifiers."
+  (delete-duplicates (sort (copy-list qualifiers) #'string<)))
+
+(export 'c-type-subtype)
+(defgeneric c-type-subtype (type)
+  (:documentation
+   "For compound types, return the base type."))
+
+;;;--------------------------------------------------------------------------
+;;; Comparison protocol.
+
+(export 'c-type-equal-p)
+(defgeneric c-type-equal-p (type-a type-b)
+  (:method-combination and)
+  (:documentation
+   "Answers whether two types TYPE-A and TYPE-B are structurally equal.
+
+   Here, `structurally equal' means that they have the same qualifiers,
+   similarly spelt names, and structurally equal components.")
+  (:method and (type-a type-b)
+    (eql (class-of type-a) (class-of type-b))))
+
+(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
+			       (type-b qualifiable-c-type))
+  (equal (canonify-qualifiers (c-type-qualifiers type-a))
+	 (canonify-qualifiers (c-type-qualifiers type-b))))
+
+;;;--------------------------------------------------------------------------
+;;; C syntax output protocol.
+
+(export 'pprint-c-type)
+(defgeneric pprint-c-type (type stream kernel)
+  (:documentation
+   "Pretty-printer for C types.
+
+   Print TYPE to STREAM.  In the middle of the declarator, call the function
+   KERNEL with one argument: whether it needs a leading space.")
+  (:method :around (type stream kernel)
+    (typecase kernel
+      (null (pprint-c-type type stream
+			   (lambda (stream prio spacep)
+			     (declare (ignore stream prio spacep))
+			     nil)))
+      ((or function symbol) (call-next-method))
+      (t (pprint-c-type type stream
+			(lambda (stream prio spacep)
+			  (declare (ignore prio))
+			  (when spacep
+			    (c-type-space stream))
+			  (princ kernel stream)))))))
+
+(export 'c-type-space)
+(defun c-type-space (stream)
+  "Print a space and a miser-mode newline to STREAM.
+
+   This is the right function to call in a PPRINT-C-TYPE kernel function when
+   the SPACEP argument is true."
+  (pprint-indent :block 2 stream)
+  (write-char #\space stream)
+  (pprint-newline :miser stream))
+
+(defun maybe-in-parens* (stream condition thunk)
+  "Helper function for the MAYBE-IN-PARENS macro."
+  (multiple-value-bind (prefix suffix)
+      (if condition (values "(" ")") (values "" ""))
+    (pprint-logical-block (stream nil :prefix prefix :suffix suffix)
+      (funcall thunk stream))))
+
+(export 'maybe-in-parens)
+(defmacro maybe-in-parens ((stream condition) &body body)
+  "Evaluate BODY; if CONDITION, write parens to STREAM around it.
+
+   This macro is useful for implementing the PPRINT-C-TYPE method on compound
+   types.  The BODY is evaluated in the context of a logical block printing
+   to STREAM.  If CONDITION is non-nil, then the block will have open/close
+   parens as its prefix and suffix; otherwise they will be empty.
+
+   The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
+  `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
+
+(export 'format-qualifiers)
+(defun format-qualifiers (quals)
+  "Return a string listing QUALS, with a space after each."
+  (format nil "~{~(~A~) ~}" quals))
+
+;;;--------------------------------------------------------------------------
+;;; S-expression notation protocol.
+
+(export 'print-c-type)
+(defgeneric print-c-type (stream type &optional colon atsign)
+  (:documentation
+   "Print an abbreviated syntax for TYPE to the STREAM.
+
+   This function is suitable for use in FORMAT's ~/.../ command."))
+
+(export 'expand-c-type-spec)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defgeneric expand-c-type-spec (spec)
+    (:documentation
+     "Expand SPEC into Lisp code to construct a C type.")
+    (:method ((spec list))
+      (expand-c-type-form (car spec) (cdr spec))))
+  (defgeneric expand-c-type-form (head tail)
+    (:documentation
+     "Expand a C type list beginning with HEAD.")
+    (:method ((name (eql 'lisp)) tail)
+      `(progn ,@tail))))
+
+(export 'c-type)
+(defmacro c-type (spec)
+  "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
+  (expand-c-type-spec spec))
+
+(export 'define-c-type-syntax)
+(defmacro define-c-type-syntax (name bvl &rest body)
+  "Define a C-type syntax function.
+
+   A function defined by BODY and with lambda-list BVL is associated with the
+   NAME.  When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
+   function with the argument list STUFF."
+  (with-gensyms (head tail)
+    (multiple-value-bind (doc decls body) (parse-body body)
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
+	 (defmethod expand-c-type-form ((,head (eql ',name)) ,tail)
+	   ,@doc
+	   (destructuring-bind ,bvl ,tail
+	     ,@decls
+	     ,@body))
+	 ',name))))
+
+(export 'c-type-alias)
+(defmacro c-type-alias (original &rest aliases)
+  "Make ALIASES behave the same way as the ORIGINAL type."
+  (with-gensyms (head tail)
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       ,@(mapcar (lambda (alias)
+		   `(defmethod expand-c-type-form
+			((,head (eql ',alias)) ,tail)
+		      (expand-c-type-form ',original ,tail)))
+		 aliases)
+       ',aliases)))
+
+(export 'defctype)
+(defmacro defctype (names value)
+  "Define NAMES all to describe the C-type VALUE.
+
+   NAMES can be a symbol (treated as a singleton list), or a list of symbols.
+   The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE.  It will
+   be expanded once at run-time."
+  (let* ((names (if (listp names) names (list names)))
+	 (namevar (gensym "NAME"))
+	 (typevar (symbolicate 'c-type- (car names))))
+    `(progn
+       (defparameter ,typevar ,(expand-c-type-spec value))
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+	 ,@(mapcar (lambda (name)
+		     `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
+			',typevar))
+		   names))
+       'names)))
+
+(export 'c-name-case)
+(defun c-name-case (name)
+  "Convert NAME to suitable case.
+
+   Strings are returned as-is; symbols are squashed to lower-case and hyphens
+   are replaced by underscores."
+  (typecase name
+    (symbol (with-output-to-string (out)
+	      (loop for ch across (symbol-name name)
+		    do (cond ((alpha-char-p ch)
+			      (write-char (char-downcase ch) out))
+			     ((or (digit-char-p ch)
+				  (char= ch #\_))
+			      (write-char ch out))
+			     ((char= ch #\-)
+			      (write-char #\_ out))
+			     (t
+			      (error "Bad character in C name ~S." name))))))
+    (t name)))
+
+;;;--------------------------------------------------------------------------
+;;; Function arguments.
+
+(export '(argument argumentp make-argument argument-name argument-type))
+(defstruct (argument (:constructor make-argument (name type))
+		     (:predicate argumentp))
+  "Simple structure representing a function argument."
+  name
+  type)
+
+(export 'commentify-argument-name)
+(defgeneric commentify-argument-name (name)
+  (:documentation
+   "Produce a `commentified' version of the argument.
+
+   The default behaviour is that temporary argument names are simply omitted
+   (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
+   printable representation of the argument.")
+  (:method ((name null)) nil)
+  (:method ((name t)) (format nil "/*~A*/" name)))
+
+;;;--------------------------------------------------------------------------
+;;; Printing objects.
+
+(defmethod print-object ((object c-type) stream)
+  (if *print-escape*
+      (format stream "~:@<C-TYPE ~/sod:print-c-type/~:>" object)
+      (pprint-c-type object stream nil)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-class-finalize.lisp b/src/proto-class-finalize.lisp
new file mode 100644
index 0000000..c7de255
--- /dev/null
+++ b/src/proto-class-finalize.lisp
@@ -0,0 +1,96 @@
+;;; -*-lisp-*-
+;;;
+;;; Class finalization protocol
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Protocol definition.
+
+(defgeneric compute-cpl (class)
+  (:documentation
+   "Returns the class precedence list for CLASS."))
+
+(defgeneric compute-chains (class)
+  (:documentation
+   "Compute the layout chains for CLASS.
+
+   Returns the following three values.
+
+     * the head of the class's primary chain;
+
+     * the class's primary chain as a list, most- to least-specific; and
+
+     * the complete collection of chains, as a list of lists, each most- to
+       least-specific, with the primary chain first.
+
+   These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots.
+
+   If the chains are ill-formed (i.e., not distinct) then an error is
+   signalled."))
+
+(defgeneric check-sod-class (class)
+  (:documentation
+   "Check the CLASS for validity.
+
+   This is done as part of class finalization.  The checks performed are as
+   follows.
+
+     * The class name and nickname, and the names of messages, obey the
+       rules (see VALID-NAME-P).
+
+     * The messages and slots have distinct names.
+
+     * The classes in the class-precedence-list have distinct nicknames.
+
+     * The chain-link is actually a proper (though not necessarily direct)
+       superclass.
+
+     * The chosen metaclass is actually a subclass of all of the
+       superclasses' metaclasses.
+
+   Returns true if all is well; false (and signals errors) if anything was
+   wrong."))
+
+(defgeneric finalize-sod-class (class)
+  (:documentation
+   "Computes all of the gory details about a class.
+
+   Once one has stopped inserting methods and slots and so on into a class,
+   one needs to finalize it to determine the layout structure and the class
+   precedence list and so on.  More precisely that gets done is this:
+
+     * Related classes (i.e., direct superclasses and the metaclass) are
+       finalized if they haven't been already.
+
+     * If you've been naughty and failed to store a list of slots or
+       whatever, then an empty list is inserted.
+
+     * The class precedence list is computed and stored.
+
+     * The class is checked for compiance with the well-formedness rules.
+
+     * The layout chains are computed."))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-class-layout.lisp b/src/proto-class-layout.lisp
new file mode 100644
index 0000000..bf1480b
--- /dev/null
+++ b/src/proto-class-layout.lisp
@@ -0,0 +1,320 @@
+;;; -*-lisp-*-
+;;;
+;;; Class layout protocol
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slot objects.
+
+(export '(effective-slot effective-slot-class
+	  effective-slot-direct-slot effective-slot-initializer))
+(defclass effective-slot ()
+  ((class :initarg :class :type sod-slot :reader effective-slot-class)
+   (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
+   (initializer :initarg :initializer :type (or sod-initializer null)
+		:reader effective-slot-initializer))
+  (:documentation
+   "Describes a slot and how it's meant to be initialized.
+
+   Specifically, an effective slot object states that in an instance of
+   CLASS, a particular SLOT is initializd by a particular INITIALIZER.  Note
+   that the CLASS is a subclass of the SLOT's defining class, and not
+   necessarily the same.
+
+   Effective slot objects are usually found in `islots' objects."))
+
+(export 'find-slot-initializer)
+(defgeneric find-slot-initializer (class slot)
+  (:documentation
+   "Return the most specific initializer for SLOT, starting from CLASS."))
+
+(export 'compute-effective-slot)
+(defgeneric compute-effective-slot (class slot)
+  (:documentation
+   "Construct an effective slot from the supplied direct slot.
+
+   SLOT is a direct slot defined on CLASS or one of its superclasses.
+   (Metaclass initializers are handled using a different mechanism.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout.
+
+;;; islots
+
+(export '(islots islots-class islots-subclass islots-slots))
+(defclass islots ()
+  ((class :initarg :class :type sod-class :reader islots-class)
+   (subclass :initarg :subclass :type sod-class :reader islots-subclass)
+   (slots :initarg :slots :type list :reader islots-slots))
+  (:documentation
+   "Contains effective slot definitions for a class's direct slots.
+
+   In detail: SLOTS is a list of effective slot objects corresponding to
+   CLASS's direct slots, and containing initializers computed relative to
+   SUBCLASS."))
+
+(export 'compute-islots)
+(defgeneric compute-islots (class subclass)
+  (:documentation
+   "Return `islots' for a particular CLASS and SUBCLASS.
+
+   Initializers for the slots should be taken from the most specific
+   superclass of SUBCLASS."))
+
+;;; vtable-pointer
+
+(export '(vtable-pointer vtable-pointer-class
+	  vtable-pointer-chain-head vtable-pointer-chain-tail))
+(defclass vtable-pointer ()
+  ((class :initarg :class :type sod-class :reader vtable-pointer-class)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader vtable-pointer-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader vtable-pointer-chain-tail))
+  (:documentation
+   "Represents a pointer to a class's vtable.
+
+   There's one of these for each of CLASS's chains.  This particular one
+   belongs to the chain headed by CHAIN-HEAD; the most specific superclass of
+   CLASS on that chain is CHAIN-TAIL.  (The tail is useful because we can --
+   and do -- use structure types defined by the tail class for non-primary
+   chains.)"))
+
+;;; ichain
+
+(export '(ichain ichain-class ichain-head ichain-tail ichain-body))
+(defclass ichain ()
+  ((class :initarg :class :type sod-class :reader ichain-class)
+   (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
+   (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
+   (body :initarg :body :type list :reader ichain-body))
+  (:documentation
+   "Contains instance data for a particular chain of superclasses.
+
+   In detail: describes instance data for one of CLASS's chains, specifically
+   the chain headed by CHAIN-HEAD.  The CHAIN-TAIL is the most specific
+   superclass of CLASS on the chain in question.  The BODY is a list of
+   layout objects to be included.
+
+   An `ilayout' object maintains a list of `ichain' objects, one for each of
+   a class's chains."))
+
+(export 'compute-ichain)
+(defgeneric compute-ichain (class chain)
+  (:documentation
+   "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.
+
+   The CHAIN is a list of classes, with the least specific first -- so the
+   chain head is the first element."))
+
+;;; ilayout
+
+(export '(ilayout ilayout-class ilayout-ichains))
+(defclass ilayout ()
+  ((class :initarg :class :type sod-class :reader ilayout-class)
+   (ichains :initarg :ichains :type list :reader ilayout-ichains))
+  (:documentation
+   "All of the instance layout for a class.
+
+   Describes the layout of an instance of CLASS.  The list ICHAINS contains
+   an `ichain' object for each chain of CLASS."))
+
+(export 'compute-ilayout)
+(defgeneric compute-ilayout (class)
+  (:documentation
+   "Compute and return an instance layout for CLASS."))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+(defclass vtmsgs ()
+  ((class :initarg :class :type sod-class :reader vtmsgs-class)
+   (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader vtmsgs-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader vtmsgs-chain-tail)
+   (entries :initarg :entries :type list :reader vtmsgs-entries))
+  (:documentation
+   "The message dispatch table for a particular class.
+
+   In detail, this lists the `method-entry' objects for the messages defined
+   by a particular CLASS, where the effective methods are specialized for the
+   SUBCLASS; the method entries adjust the instance pointer argument
+   appropriately for a call via the vtable for the chain headed by
+   CHAIN-HEAD.  The CHAIN-TAIL is the most specific superclass of SUBCLASS on
+   this chain.  The ENTRIES are a list of `method-entry' objects."))
+
+(export 'compte-vtmsgs)
+(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
+  (:documentation
+   "Return a VTMSGS object containing method entries for CLASS.
+
+   The CHAIN-HEAD describes which chain the method entries should be
+   constructed for.
+
+   The default method simply calls MAKE-METHOD-ENTRY for each of the methods
+   and wraps a VTMSGS object around them.  This ought to be enough for almost
+   all purposes."))
+
+;;; class-pointer
+
+(export '(class-pointer class-pointer-class class-pointer-chain-head
+	  class-pointer-metaclass class-pointer-meta-chain-head))
+(defclass class-pointer ()
+  ((class :initarg :class :type sod-class :reader class-pointer-class)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader class-pointer-chain-head)
+   (metaclass :initarg :metaclass :type sod-class
+	      :reader class-pointer-metaclass)
+   (meta-chain-head :initarg :meta-chain-head :type sod-class
+		    :reader class-pointer-meta-chain-head))
+  (:documentation
+   "Represents a pointer to a class object for the instance's class.
+
+   This is somewhat complicated because there are two degrees of freedom.  An
+   instance of `class-pointer' is a pointer from a vtable to an `ichain' of
+   the the class's metaclass instance.  In particular, `class-pointer'
+   instance represents a pointer in a vtable constructed for CLASS and
+   attached to the chain headed by CHAIN-HEAD; it points to an instance of
+   METACLASS, and specifically to the `ichain' substructure corresponding to
+   the chain headed by META-CHAIN-HEAD, which will be a superclass of
+   METACLASS.
+
+   I'm sorry if this is confusing."))
+
+(export 'make-class-pointer)
+(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
+  (:documentation
+   "Return a class pointer to a metaclass chain."))
+
+;;; base-offset
+
+(export '(base-offset base-offset-class base-offset-chain-head))
+(defclass base-offset ()
+  ((class :initarg :class :type sod-class :reader base-offset-class)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader base-offset-chain-head))
+  (:documentation
+   "The offset of this chain to the `ilayout' base.
+
+   We're generating a vtable for CLASS, attached to the chain headed by
+   CHAIN-HEAD.  Fortunately (and unlike `class-pointer'), the chain head can
+   do double duty, since it also identifies the `ichain' substructure of the
+   class's `ilayout' whose offset we're interested in."))
+
+(export 'make-base-offset)
+(defgeneric make-base-offset (class chain-head)
+  (:documentation
+   "Return the base offset object for CHAIN-HEAD ichain."))
+
+;;; chain-offset
+
+(export '(chain-offset chain-offset-class
+	  chain-offset-chain-head chain-offset-target-head))
+(defclass chain-offset ()
+  ((class :initarg :class :type sod-class :reader chain-offset-class)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader chain-offset-chain-head)
+   (target-head :initarg :target-head :type sod-class
+		:reader chain-offset-target-head))
+  (:documentation
+   "The offset to a different `ichain'.
+
+   We're generating a vtable for CLASS, attached to the chain headed by
+   CHAIN-HEAD.  This instance represents an offset to the (different) chain
+   headed by TARGET-HEAD.
+
+   This is, strictly speaking, redundant.  We could do as well by using the
+   base offset and finding the offset to the target class in the class
+   object's metadata; but that would either require a search or we'd have to
+   be able work out the target chain's index in the table."))
+
+(defgeneric make-chain-offset (class chain-head target-head)
+  (:documentation
+   "Return the offset from CHAIN-HEAD to TARGET-HEAD."))
+
+;;; vtable
+
+(export '(vtable vtable-class vtable-body
+	  vtable-chain-head vtable-chain-tail))
+(defclass vtable ()
+  ((class :initarg :class :type sod-class :reader vtable-class)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader vtable-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader vtable-chain-tail)
+   (body :initarg :body :type list :reader vtable-body))
+  (:documentation
+   "A vtable holds all of the per-chain static information for a class.
+
+   Each chain of CLASS has its own vtable; the `vtable' object remembers the
+   least specific (CHAIN-HEAD) and most specific (CHAIN-TAIL) superclasses of
+   CLASS on that chain.  (This is useful because we can reuse vtable
+   structure types from superclasses for chains other than the primary chain
+   -- i.e., the one in which CLASS itself appears.)
+
+   The BODY is a list of vtable items, including `vtmsgs' structures,
+   `chain-offset's, `class-pointers', and a `base-offset'."))
+
+(export 'compute-vtable-items)
+(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
+  (:documentation
+   "Emit vtable items for a superclass of CLASS.
+
+   This function is called for each superclass SUPER of CLASS reached on the
+   chain headed by CHAIN-HEAD.  The function should call EMIT for each
+   vtable item it wants to write.
+
+   The right way to check to see whether items have already been emitted
+   (e.g., has an offset to some other chain been emitted?) is as follows:
+
+     * In a method (ideally an `:around'-method) on `compute-vtable', bind a
+       special variable to an empty list or hash table.
+
+     * In a method on this function, check the variable or hash table.
+
+   This function is the real business end of `compute-vtable'."))
+
+(export 'compute-vtable)
+(defgeneric compute-vtable (class chain)
+  (:documentation
+   "Compute the vtable layout for a chain of CLASS.
+
+   The CHAIN is a list of classes, with the least specific first.
+
+   There is a default method which invokes `compute-vtable-items' to do the
+   difficult work."))
+
+(export 'compute-vtables)
+(defgeneric compute-vtables (class)
+  (:documentation
+   "Compute the vtable layouts for CLASS.
+
+   Returns a list of VTABLE objects in the order of CLASS's chains."))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-class-make.lisp b/src/proto-class-make.lisp
new file mode 100644
index 0000000..692da40
--- /dev/null
+++ b/src/proto-class-make.lisp
@@ -0,0 +1,293 @@
+;;; -*-lisp-*-
+;;;
+;;; Class construction protocol
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(export 'make-sod-class)
+(defun make-sod-class (name superclasses pset &optional location)
+  "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
+
+   This is the main constructor function for classes.  The protocol works as
+   follows.  The `:lisp-class' property in PSET is checked: if it exists, it
+   must be a symbol naming a (CLOS) class, which is used in place of
+   `sod-class'.  All of the arguments are then passed to `make-instance';
+   further behaviour is left to the standard CLOS instance construction
+   protocol; for example, `sod-class' defines an `:after'-method on
+   SHARED-INITIALIZE.
+
+   Minimal sanity checking is done during class construction; most of it is
+   left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
+
+   Unused properties in PSET are diagnosed as errors."
+
+  (with-default-error-location (location)
+    (let* ((pset (property-set pset))
+	   (class (make-instance (get-property pset :lisp-class :symbol
+					       'sod-class)
+				 :name name
+				 :superclasses superclasses
+				 :location (file-location location)
+				 :pset pset)))
+      (check-unused-properties pset)
+      class)))
+
+(export 'guess-metaclass)
+(defgeneric guess-metaclass (class)
+  (:documentation
+   "Determine a suitable metaclass for the CLASS.
+
+   The default behaviour is to choose the most specific metaclass of any of
+   the direct superclasses of CLASS, or to signal an error if that failed."))
+
+;;;--------------------------------------------------------------------------
+;;; Slots and slot initializers.
+
+(export 'make-sod-slot)
+(defgeneric make-sod-slot (class name type pset &optional location)
+  (:documentation
+   "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
+
+   This is the main constructor function for slots.  This is a generic
+   function primarily so that the CLASS can intervene in the construction
+   process.  The default method uses the `:lisp-class' property (defaulting
+   to `sod-slot') to choose a (CLOS) class to instantiate.  The slot is then
+   constructed by `make-instance' passing the arguments as initargs; further
+   behaviour is left to the standard CLOS instance construction protocol; for
+   example, `sod-slot' defines an `:after'-method on `shared-initialize'.
+
+   Unused properties on PSET are diagnosed as errors."))
+
+(export 'make-sod-instance-initializer)
+(defgeneric make-sod-instance-initializer
+    (class nick name value-kind value-form pset &optional location)
+  (:documentation
+   "Construct and attach an instance slot initializer, to CLASS.
+
+   This is the main constructor function for instance initializers.  This is
+   a generic function primarily so that the CLASS can intervene in the
+   construction process.  The default method looks up the slot using
+   `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to
+   actually make the initializer object, and adds it to the appropriate list
+   in CLASS.
+
+   Unused properties on PSET are diagnosed as errors."))
+
+(export 'make-sod-class-initializer)
+(defgeneric make-sod-class-initializer
+    (class nick name value-kind value-form pset &optional location)
+  (:documentation
+   "Construct and attach a class slot initializer, to CLASS.
+
+   This is the main constructor function for class initializers.  This is a
+   generic function primarily so that the CLASS can intervene in the
+   construction process.  The default method looks up the slot using
+   `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to
+   actually make the initializer object, and adds it to the appropriate list
+   in CLASS.
+
+   Unused properties on PSET are diagnosed as errors."))
+
+(export 'make-sod-initializer-using-slot)
+(defgeneric make-sod-initializer-using-slot
+    (class slot init-class value-kind value-form pset location)
+  (:documentation
+   "Common construction protocol for slot initializers.
+
+   This generic function does the common work for constructing instance and
+   class initializers.  It can usefully be specialized according to both the
+   class and slot types.  The default method uses the `:lisp-class' property
+   (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate.  The
+   slot is then constructed by `make-instance' passing the arguments as
+   initargs; further behaviour is left to the standard CLOS instance
+   construction protocol; for example, `sod-initializer' defines an
+   `:after'-method on `shared-initialize'.
+
+   Diagnosing unused properties is left for the caller (usually
+   `make-sod-instance-initializer' or `make-sod-class-initializer') to do.
+   The caller is also expected to have set `with-default-error-location' if
+   appropriate.
+
+   You are not expected to call this generic function directly; it's more
+   useful as a place to hang methods for custom initializer classes."))
+
+;;;--------------------------------------------------------------------------
+;;; Messages and methods.
+
+(export 'make-sod-message)
+(defgeneric make-sod-message (class name type pset &optional location)
+  (:documentation
+   "Construct and attach a new message with given NAME and TYPE, to CLASS.
+
+   This is the main constructor function for messages.  This is a generic
+   function primarily so that the CLASS can intervene in the construction
+   process.  The default method uses the `:lisp-class' property (defaulting
+   to `sod-message') to choose a (CLOS) class to instantiate.  The message is
+   then constructed by `make-instance' passing the arguments as initargs;
+   further behaviour is left to the standard CLOS instance construction
+   protocol; for example, `sod-message' defines an `:after'-method on
+   `shared-initialize'.
+
+   Unused properties on PSET are diagnosed as errors."))
+
+(export 'make-sod-method)
+(defgeneric make-sod-method
+    (class nick name type body pset &optional location)
+  (:documentation
+   "Construct and attach a new method to CLASS.
+
+   This is the main constructor function for methods.  This is a generic
+   function primarily so that the CLASS can intervene in the message lookup
+   process, though this is actually a fairly unlikely occurrence.
+
+   The default method looks up the message using `find-message-by-name',
+   invokes `make-sod-method-using-message' to make the method object, and
+   then adds the method to the class's list of methods.  This split allows
+   the message class to intervene in the class selection process, for
+   example.
+
+   Unused properties on PSET are diagnosed as errors."))
+
+(export 'make-sod-method-using-message)
+(defgeneric make-sod-method-using-message
+    (message class type body pset location)
+  (:documentation
+   "Main construction subroutine for method construction.
+
+   This is a generic function so that it can be specialized according to both
+   a class and -- more particularly -- a message.  The default method uses
+   the `:lisp-class' property (defaulting to the result of calling
+   `sod-message-method-class') to choose a (CLOS) class to instantiate.  The
+   method is then constructed by `make-instance' passing the arguments as
+   initargs; further behaviour is left to the standard CLOS instance
+   construction protocol; for example, `sod-method' defines an
+   `:after'-method on `shared-initialize'.
+
+   Diagnosing unused properties is left for the caller (usually
+   `make-sod-method') to do.  The caller is also expected to have set
+   `with-default-error-location' if appropriate.
+
+   You are not expected to call this generic function directly; it's more
+   useful as a place to hang methods for custom method classes."))
+
+(export 'sod-message-method-class)
+(defgeneric sod-message-method-class (message class pset)
+  (:documentation
+   "Return the preferred class for methods on MESSAGE.
+
+   The message can inspect the PSET to decide on a particular message.  A
+   `:lisp-class' property will usually override this decision: it's then the
+   programmer's responsibility to ensure that the selected method class is
+   appropriate."))
+
+(export 'check-message-type)
+(defgeneric check-message-type (message type)
+  (:documentation
+   "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.
+
+   This is separated out of `shared-initialize', where it's called, so that
+   it can be overridden conveniently by subclasses."))
+
+(export 'check-method-type)
+(defgeneric check-method-type (method message type)
+  (:documentation
+   "Check that TYPE is a suitable type for METHOD.  Signal errors if not.
+
+   This is separated out of `shared-initialize', where it's called, so that
+   it can be overridden conveniently by subclasses."))
+
+;;;--------------------------------------------------------------------------
+;;; Builder macros.
+
+(export 'define-sod-class)
+(defmacro define-sod-class (name (&rest superclasses) &body body)
+  "Construct a new SOD class called NAME in the current module.
+
+   The new class has the named direct SUPERCLASSES, which should be a list of
+   strings.
+
+   The BODY begins with a sequence of alternating keyword/value pairs
+   defining properties for the new class.  The keywords are (obviously) not
+   evaluated, but the value forms are.
+
+   The remainder of the BODY are a sequence of forms to be evaluated as an
+   implicit `progn'.  Additional macros are available to the BODY, to make
+   defining the class easier.
+
+   In the following, NAME is a string giving a C identifier; NICK is a string
+   giving the nickname of a superclass; TYPE is a C type using S-expression
+   notation.
+
+     * message NAME TYPE &rest PLIST
+
+     * method NICK NAME TYPE BODY &rest PLIST
+
+     * slot NAME TYPE &rest PLIST
+
+     * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST
+
+     * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"
+
+  (let ((plist nil)
+	(classvar (gensym "CLASS-")))
+    (loop
+      (when (or (null body)
+		(not (keywordp (car body))))
+	(return))
+      (push (pop body) plist)
+      (push (pop body) plist))
+    `(let ((,classvar (make-sod-class ,name
+				      (mapcar #'find-sod-class
+					      (list ,@superclasses))
+				      (make-property-set
+				       ,@(nreverse plist)))))
+       (macrolet ((message (name type &rest plist)
+		    `(make-sod-message ,',classvar ,name (c-type ,type)
+				       (make-property-set ,@plist)))
+		  (method (nick name type body &rest plist)
+		    `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
+				      ,body (make-property-set ,@plist)))
+		  (slot (name type &rest plist)
+		    `(make-sod-slot ,',classvar ,name (c-type ,type)
+				    (make-property-set ,@plist)))
+		  (instance-initializer
+		      (nick name value-kind value-form &rest plist)
+		    `(make-sod-instance-initializer ,',classvar ,nick ,name
+						    ,value-kind ,value-form
+						    (make-property-set
+						     ,@plist)))
+		  (class-initializer
+		      (nick name value-kind value-form &rest plist)
+		    `(make-sod-class-initializer ,',classvar ,nick ,name
+						 ,value-kind ,value-form
+						 (make-property-set
+						  ,@plist))))
+	 ,@body
+	 (finalize-sod-class ,classvar)
+	 (add-to-module *module* ,classvar)))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/codegen.lisp b/src/proto-codegen.lisp
similarity index 66%
rename from codegen.lisp
rename to src/proto-codegen.lisp
index fc6a408..24b8c38 100644
--- a/codegen.lisp
+++ b/src/proto-codegen.lisp
@@ -1,13 +1,13 @@
 ;;; -*-lisp-*-
 ;;;
-;;; Code generator for effective methods
+;;; Code generation protocol
 ;;;
 ;;; (c) 2009 Straylight/Edgeware
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Simple Object Definition system.
+;;; This file is part of the Sensble Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -28,53 +28,47 @@
 ;;;--------------------------------------------------------------------------
 ;;; Temporary names.
 
-(defclass temporary-name ()
-  ((tag :initarg :tag :reader temp-tag))
+;; Protocol.
+
+(export 'format-temporary-name)
+(defgeneric format-temporary-name (var stream)
   (:documentation
-   "Base class for temporary variable and argument names."))
+   "Write the name of a temporary variable VAR to STREAM."))
 
-(defclass temporary-argument (temporary-name) ())
-(defclass temporary-function (temporary-name) ())
+(export 'var-in-use-p)
+(defgeneric var-in-use-p (var)
+  (:documentation
+   "Answer whether VAR is currently being used.  See WITH-TEMPORARY-VAR.")
+  (:method (var)
+    "Non-temporary variables are always in use."
+    t))
+(defgeneric (setf var-in-use-p) (value var)
+  (:documentation
+   "Record whether VAR is currently being used.  See WITH-TEMPORARY-VAR."))
 
-(defclass temporary-variable (temporary-name)
-  ((in-use-p :initarg :in-use-p :initform nil
-	     :type boolean :accessor var-in-use-p)))
+;; Root class.
 
-(defmethod var-in-use-p ((var t))
-  "Non-temporary variables are always in use."
-  t)
+(export 'temporary-name)
+(defclass temporary-name ()
+  ((tag :initarg :tag :reader temp-tag))
+  (:documentation
+   "Base class for temporary variable and argument names."))
 
-(defmethod commentify-argument-name ((name temporary-name))
-  nil)
+;; Important variables.
 
 (defparameter *temporary-index* 0
   "Index for temporary name generation.
 
    This is automatically reset to zero before the output functions are
    invoked to write a file.  This way, we can ensure that the same output
-   file is always produced from the same input.")
+   file is always produced from the same input."
+  ;; FIXME: this is currently a lie.  Need some protocol to ensure that this
+  ;; happens.
+)
 
-(defun temporary-function ()
-  "Return a temporary function name."
-  (make-instance 'temporary-function
-		 :tag (prog1 *temporary-index* (incf *temporary-index*))))
-
-(defgeneric format-temporary-name (var stream)
-  (:method ((var temporary-name) stream)
-    (format stream "~A" (temp-tag var)))
-  (:method ((var temporary-argument) stream)
-    (format stream "sod__a~A" (temp-tag var)))
-  (:method ((var temporary-variable) stream)
-    (format stream "sod__v~A" (temp-tag var)))
-  (:method ((var temporary-function) stream)
-    (format stream "sod__f~A" (temp-tag var))))
-
-(defmethod print-object ((var temporary-name) stream)
-  (if *print-escape*
-      (print-unreadable-object (var stream :type t)
-	(prin1 (temp-tag var) stream))
-      (format-temporary-name var stream)))
+;; Important temporary names.
 
+(export '(*sod-ap* *sod-master-ap*))
 (defparameter *sod-ap*
   (make-instance 'temporary-name :tag "sod__ap"))
 (defparameter *sod-master-ap*
@@ -83,6 +77,9 @@
 ;;;--------------------------------------------------------------------------
 ;;; Instructions.
 
+;; Classes.
+
+(export 'inst)
 (defclass inst () ()
   (:documentation
    "A base class for instructions.
@@ -98,6 +95,7 @@
    This doesn't really do very much, but it acts as a handy marker for
    instruction subclasses."))
 
+(export 'inst-metric)
 (defgeneric inst-metric (inst)
   (:documentation
    "Returns a `metric' describing how complicated INST is.
@@ -111,6 +109,9 @@
    code fairly simply.")
   (:method (inst) 1))
 
+;; Instruction definition.
+
+(export 'definst)
 (defmacro definst (code (streamvar) args &body body)
   "Define an instruction type and describe how to output it.
 
@@ -153,6 +154,35 @@
 			 ,@(mappend #'list keys args)))
 	       (progn ,@body)))))))
 
+;; Important instruction classes.
+
+(export '(block-inst make-block-inst var-inst make-var-inst
+	  function-inst make-function-inst set-inst make-set-inst
+	  return-inst make-return-inst expr-inst make-expr-inst
+	  inst-decls inst-body inst-name inst-type inst-init inst-var
+	  inst-expr))
+
+(definst var (stream) (name type init)
+  (pprint-c-type type stream name)
+  (when init
+    (format stream " = ~A" init)))
+(definst set (stream) (var expr)
+  (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
+(definst return (stream) (expr)
+  (format stream "return~@[ (~A)~];" expr))
+(definst expr (stream) (expr)
+  (format stream "~A;" expr))
+(definst block (stream) (decls body)
+  (format stream "{~:@_~@<  ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
+	  decls body))
+(definst function (stream) (name type body)
+  (pprint-logical-block (stream nil)
+    (princ "static " stream)
+    (pprint-c-type type stream name)
+    (format stream "~:@_~A~:@_~:@_" body)))
+
+;; Formatting utilities.
+
 (defun format-compound-statement* (stream child morep thunk)
   "Underlying function for FORMAT-COMPOUND-STATEMENT."
   (cond ((typep child 'block-inst)
@@ -172,9 +202,10 @@
 	     (:space
 	      (write-char #\space stream)
 	      (pprint-newline :linear stream))
-	     (t
+	     ((t)
 	      (pprint-newline :mandatory stream)))))))
 
+(export 'format-compound-statement)
 (defmacro format-compound-statement
     ((stream child &optional morep) &body body)
   "Format a compound statement to STREAM.
@@ -186,106 +217,16 @@
 			       (lambda (,stream) ,@body)))
 
 ;;;--------------------------------------------------------------------------
-;;; Instruction types.
-
-;; Compound statements.
-
-(definst block (stream) (decls body)
-  (format stream "{~:@_~@<  ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
-	  decls body))
-
-(definst if (stream) (condition consequent alternative)
-  (format-compound-statement (stream consequent alternative)
-    (format stream "if (~A)" condition))
-  (when alternative
-    (format-compound-statement (stream alternative)
-      (write-string "else" stream))))
-
-(definst while (stream) (condition body)
-  (format-compound-statement (stream body)
-    (format stream "while (~A)" condition)))
-
-(definst do-while (stream) (body condition)
-  (format-compound-statement (stream body :space)
-    (write-string "do" stream))
-  (format stream "while (~A);" condition))
-
-;; Simple statements.
-
-(definst set (stream) (var expr)
-  (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
-
-(definst return (stream) (expr)
-  (format stream "return~@[ (~A)~];" expr))
-
-(definst expr (stream) (expr)
-  (format stream "~A;" expr))
-
-;; Special varargs hacks.
-
-(definst va-start (stream) (ap arg)
-  (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
+;;; Code generation.
 
-(definst va-copy (stream) (to from)
-  (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
+;; Accessors.
 
-(definst va-end (stream) (ap)
-  (format stream "va_end(~A);" ap))
-
-;; Declarations.  These should appear at the heads of BLOCK-INSTs.
-
-(definst var (stream) (name type init)
-  (pprint-c-type type stream name)
-  (when init
-    (format stream " = ~A" init)))
-
-;; Expressions.
-
-(definst call (stream) (func args)
-  (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
-
-;; Top level things.
-
-(definst function (stream) (name type body)
-  (pprint-logical-block (stream nil)
-    (princ "static " stream)
-    (pprint-c-type type stream name)
-    (format stream "~:@_~A~:@_~:@_" body)))
-
-;;;--------------------------------------------------------------------------
-;;; Code generator objects.
-
-(defclass basic-codegen ()
-  ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
-   (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
-   (temp-index :initarg :temp-index :initform 0
-	       :type fixnum :accessor codegen-temp-index))
-  (:documentation
-   "Base class for code generator state.
-
-   This contains the bare essentials for supporting the EMIT-INST and
-   ENSURE-VAR protocols; see the documentation for those generic functions
-   for more details.
-
-   This class isn't abstract.  A full CODEGEN object uses instances of this
-   to keep track of pending functions which haven't been completed yet.
-
-   Just in case that wasn't clear enough: this is nothing to do with the
-   BASIC language."))
-
-(defgeneric emit-inst (codegen inst)
+(export 'codegen-functions)
+(defgeneric codegen-functions (codegen)
   (:documentation
-   "Add INST to the end of CODEGEN's list of instructions.")
-  (:method ((codegen basic-codegen) inst)
-    (push inst (codegen-insts codegen))))
-
-(defgeneric emit-insts (codegen insts)
-  (:documentation
-   "Add a list of INSTS to the end of CODEGEN's list of instructions.")
-  (:method ((codegen basic-codegen) insts)
-    (setf (codegen-insts codegen)
-	  (revappend insts (codegen-insts codegen)))))
+   "Return the list of FUNCTION-INSTs of completed functions."))
 
+(export 'ensure-var)
 (defgeneric ensure-var (codegen name type &optional init)
   (:documentation
    "Add a variable to CODEGEN's list.
@@ -293,67 +234,52 @@
    The variable is called NAME (which should be comparable using EQUAL and
    print to an identifier) and has the given TYPE.  If INIT is present and
    non-nil it is an expression INST used to provide the variable with an
-   initial value.")
-  (:method ((codegen basic-codegen) name type &optional init)
-    (let* ((vars (codegen-vars codegen))
-	   (var (find name vars :key #'inst-name :test #'equal)))
-      (cond ((not var)
-	     (setf (codegen-vars codegen)
-		   (cons (make-var-inst name type init) vars)))
-	    ((not (c-type-equal-p type (inst-type var)))
-	     (error "(Internal) Redefining type for variable ~A." name)))
-      name)))
-
-(defclass codegen (basic-codegen)
-  ((functions :initform nil :type list :accessor codegen-functions)
-   (stack :initform nil :type list :accessor codegen-stack))
-  (:documentation
-   "A full-fat code generator which can generate and track functions.
+   initial value."))
 
-   This is the real deal.  Subclasses may which to attach additional state
-   for convenience's sake, but this class is self-contained.  It supports the
-   CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
+(export '(emit-inst emit-insts))
+(defgeneric emit-inst (codegen inst)
+  (:documentation
+   "Add INST to the end of CODEGEN's list of instructions."))
+(defgeneric emit-insts (codegen insts)
+  (:documentation
+   "Add a list of INSTS to the end of CODEGEN's list of instructions.")
+  (:method (codegen insts)
+    (dolist (inst insts) (emit-inst codegen inst))))
 
+(export 'codegen-push)
 (defgeneric codegen-push (codegen)
   (:documentation
    "Pushes the current code generation state onto a stack.
 
-   The state consists of the accumulated variables and instructions, i.e.,
-   what is representable by a BASIC-CODEGEN.")
-  (:method ((codegen codegen))
-    (with-slots (vars insts temp-index stack) codegen
-      (push (make-instance 'basic-codegen
-			   :vars vars
-			   :insts insts
-			   :temp-index temp-index)
-	    stack)
-      (setf vars nil insts nil temp-index 0))))
+   The state consists of the accumulated variables and instructions."))
 
+(export 'codegen-pop)
 (defgeneric codegen-pop (codegen)
   (:documentation
    "Pops a saved state off of the CODEGEN's stack.
 
    Returns the newly accumulated variables and instructions as lists, as
-   separate values.")
-  (:method ((codegen codegen))
-    (with-slots (vars insts temp-index stack) codegen
-      (multiple-value-prog1
-	  (values (nreverse vars) (nreverse insts))
-	(let ((sub (pop stack)))
-	  (setf vars (codegen-vars sub)
-		insts (codegen-insts sub)
-		temp-index (codegen-temp-index sub)))))))
+   separate values."))
 
+(export 'codegen-add-function)
 (defgeneric codegen-add-function (codegen function)
   (:documentation
    "Adds a function to CODEGEN's list.
 
    Actually, we're not picky: FUNCTION can be any kind of object that you're
-   willing to find in the list returned by CODEGEN-FUNCTIONS.")
-  (:method ((codegen codegen) function)
-    (with-slots (functions) codegen
-      (setf functions (nconc functions (list function))))))
+   willing to find in the list returned by CODEGEN-FUNCTIONS."))
+
+(export 'temporary-var)
+(defgeneric temporary-var (codegen type)
+  (:documentation
+   "Return the name of a temporary variable.
+
+   The temporary variable will have the given TYPE, and will be marked
+   in-use.  You should clear the in-use flag explicitly when you've finished
+   with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
+   automatically."))
 
+(export 'codegen-build-function)
 (defun codegen-build-function (codegen name type vars insts)
   "Build a function and add it to CODEGEN's list.
 
@@ -363,37 +289,26 @@
 					    (make-block-inst vars insts)))
   name)
 
+(export 'codegen-pop-block)
+(defgeneric codegen-pop-block (codegen)
+  (:documentation
+   "Makes a block (BLOCK-INST) out of the completed code in CODEGEN.")
+  (:method (codegen)
+    (multiple-value-bind (vars insts) (codegen-pop codegen)
+      (make-block-inst vars insts))))
+
+(export 'codegen-pop-function)
 (defgeneric codegen-pop-function (codegen name type)
   (:documentation
    "Makes a function out of the completed code in CODEGEN.
 
    The NAME can be any object you like.  The TYPE should be a function type
    object which includes argument names.  The return value is the NAME.")
-  (:method ((codegen codegen) name type)
+  (:method (codegen name type)
     (multiple-value-bind (vars insts) (codegen-pop codegen)
       (codegen-build-function codegen name type vars insts))))
 
-(defgeneric temporary-var (codegen type)
-  (:documentation
-   "Return the name of a temporary variable.
-
-   The temporary variable will have the given TYPE, and will be marked
-   in-use.  You should clear the in-use flag explicitly when you've finished
-   with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
-   automatically."))
-
-(defmethod temporary-var ((codegen basic-codegen) type)
-  (with-slots (vars temp-index) codegen
-    (or (find-if (lambda (var)
-		   (and (not (var-in-use-p (inst-name var)))
-			(c-type-equal-p type (inst-type var))))
-		 vars)
-	(let* ((name (make-instance 'temporary-variable
-				    :tag (prog1 temp-index
-					   (incf temp-index)))))
-	  (push (make-var-inst name type nil) vars)
-	  name))))
-
+(export 'with-temporary-var)
 (defmacro with-temporary-var ((codegen var type) &body body)
   "Evaluate BODY with VAR bound to a temporary variable name.
 
@@ -407,6 +322,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Code generation idioms.
 
+(export 'deliver-expr)
 (defun deliver-expr (codegen target expr)
   "Emit code to deliver the value of EXPR to the TARGET.
 
@@ -436,6 +352,7 @@
 		  (emit-inst codegen (make-return-inst nil)))
     (t (emit-inst codegen (make-set-inst target expr)))))
 
+(export 'convert-stmts)
 (defun convert-stmts (codegen target type func)
   "Invoke FUNC to deliver a value to a non-:RETURN target.
 
diff --git a/src/proto-lexer.lisp b/src/proto-lexer.lisp
new file mode 100644
index 0000000..9c78a9b
--- /dev/null
+++ b/src/proto-lexer.lisp
@@ -0,0 +1,216 @@
+;;; -*-lisp-*-
+;;;
+;;; Protocol for lexical analysis
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Accessors.
+
+(export 'lexer-char)
+(defgeneric lexer-char (lexer)
+  (:documentation
+   "Return the current lookahead character from the LEXER.
+
+   When the lexer is first created, there is no lookahead character: you must
+   `prime the pump' by calling NEXT-CHAR.  The lexer represents encountering
+   the end of its input stream by setting the lookahead character to nil.  At
+   this point it is still possible to push back characters."))
+
+(export '(token-type token-value))
+(defgeneric token-type (lexer)
+  (:documentation
+   "Return the type of the LEXER's current lookahead token
+
+   When the lexer is first created, there is no lookahead token: you must
+   `prime the pump' by calling NEXT-TOKEN."))
+(defgeneric token-value (lexer)
+  (:documentation
+   "Return the value of the LEXER's current lookahead token
+
+   When the lexer is first created, there is no lookahead token: you must
+   `prime the pump' by calling NEXT-TOKEN."))
+
+;;;--------------------------------------------------------------------------
+;;; Formatting tokens.
+
+(defgeneric format-token (token-type &optional token-value)
+  (:documentation
+   "Return a string describing a token with the specified type and value.")
+  (:method ((token-type (eql :eof)) &optional token-value)
+    (declare (ignore token-value))
+    "<end-of-file>")
+  (:method ((token-type (eql :string)) &optional token-value)
+    (declare (ignore token-value))
+    "<string-literal>")
+  (:method ((token-type (eql :char)) &optional token-value)
+    (declare (ignore token-value))
+    "<character-literal>")
+  (:method ((token-type (eql :id)) &optional token-value)
+    (format nil "<identifier~@[ `~A'~]>" token-value))
+  (:method ((token-type symbol) &optional token-value)
+    (declare (ignore token-value))
+    (check-type token-type keyword)
+    (format nil "`~(~A~)'" token-type))
+  (:method ((token-type character) &optional token-value)
+    (declare (ignore token-value))
+    (format nil "~:[<~:C>~;`~C'~]"
+	    (and (graphic-char-p token-type)
+		 (char/= token-type #\space))
+	    token-type)))
+
+;;;--------------------------------------------------------------------------
+;;; Reading and pushing back characters.
+
+(export 'next-char)
+(defgeneric next-char (lexer)
+  (:documentation
+   "Fetch the next character from the LEXER's input stream.
+
+   Read a character from the input stream, and store it in the LEXER's CHAR
+   slot.  The character stored is returned.  If characters have been pushed
+   back then pushed-back characters are used instead of the input stream.  If
+   there are no more characters to be read then the lookahead character is
+   nil.  Returns the new lookahead character.
+
+   (This function is primarily intended for the use of lexer subclasses.)"))
+
+(export 'pushback-char)
+(defgeneric pushback-char (lexer char)
+  (:documentation
+   "Push the CHAR back into the lexer.
+
+   Make CHAR be the current lookahead character (stored in the LEXER's CHAR
+   slot).  The previous lookahead character is pushed down, and will be made
+   available again once this character is consumed by NEXT-CHAR.
+
+   (This function is primarily intended for the use of lexer subclasses.)"))
+
+(defgeneric fixup-stream* (lexer thunk)
+  (:documentation
+   "Helper function for WITH-LEXER-STREAM.
+
+   This function does the main work for WITH-LEXER-STREAM.  The THUNK is
+   invoked on a single argument, the LEXER's underlying STREAM."))
+
+(export 'with-lexer-stream)
+(defmacro with-lexer-stream ((streamvar lexer) &body body)
+  "Evaluate BODY with STREAMVAR bound to the LEXER's input stream.
+
+   The STREAM is fixed up so that the next character read (e.g., using
+   READ-CHAR) will be the lexer's current lookahead character.  Once the BODY
+   completes, the next character in the stream is read and set as the
+   lookahead character.  It is an error if the lexer has pushed-back
+   characters (since these can't be pushed back into the input stream
+   properly)."
+
+  `(fixup-stream* ,lexer (lambda (,streamvar) ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Reading and pushing back tokens.
+
+(export 'scan-token)
+(defgeneric scan-token (lexer)
+  (:documentation
+   "Internal protocol for scanning tokens from an input stream.
+
+   Implementing a method on this function is the main responsibility of LEXER
+   subclasses; it is called by the user-facing NEXT-TOKEN function.
+
+   The method should consume characters (using NEXT-CHAR) as necessary, and
+   return two values: a token type and token value.  These will be stored in
+   the corresponding slots in the lexer object in order to provide the user
+   with one-token lookahead."))
+
+(export 'next-token)
+(defgeneric next-token (lexer)
+  (:documentation
+   "Scan a token from an input stream.
+
+   This function scans a token from an input stream.  Two values are
+   returned: a `token type' and a `token value'.  These are opaque to the
+   LEXER base class, but the intent is that the token type be significant to
+   determining the syntax of the input, while the token value carries any
+   additional information about the token's semantic content.  The token type
+   and token value are also made available for lookahead via accessors
+   TOKEN-TYPE and TOKEN-VALUE on the LEXER object.
+
+   The new lookahead token type and value are returned as two separate
+   values.
+
+   If tokens have been pushed back (see PUSHBACK-TOKEN) then they are
+   returned one by one instead of scanning the stream."))
+
+(export 'pushback-token)
+(defgeneric pushback-token (lexer token-type &optional token-value location)
+  (:documentation
+   "Push a token back into the lexer.
+
+   Make the given TOKEN-TYPE and TOKEN-VALUE be the current lookahead token.
+   The previous lookahead token is pushed down, and will be made available
+   agan once this new token is consumed by NEXT-TOKEN.  If LOCATION is
+   non-nil then FILE-LOCATION is saved and replaced by LOCATION.  The
+   TOKEN-TYPE and TOKEN-VALUE can be anything at all: for instance, they need
+   not be values which can actually be returned by NEXT-TOKEN."))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(export 'skip-spaces)
+(defgeneric skip-spaces (lexer)
+  (:documentation
+   "Skip over whitespace characters in the LEXER.
+
+   There must be a lookahead character; when the function returns, the
+   lookahead character will be a non-whitespace character or nil if there
+   were no non-whitespace characters remaining.  Returns the new lookahead
+   character."))
+
+(export 'require-token)
+(defun require-token
+    (lexer wanted-token-type &key (errorp t) (consumep t) default)
+  "Require a particular token to appear.
+
+   If the LEXER's current lookahead token has type WANTED-TOKEN-TYPE then
+   consume it (using NEXT-TOKEN) and return its value.  Otherwise, if the
+   token doesn't have the requested type then signal a continuable error
+   describing the situation and return DEFAULT (which defaults to nil).
+
+   If ERRORP is false then no error is signalled; this is useful for
+   consuming or checking for optional punctuation.  If CONSUMEP is false then
+   a matching token is not consumed; non-matching tokens are never consumed."
+
+  (with-slots (token-type token-value) lexer
+    (cond ((eql token-type wanted-token-type)
+	   (prog1 token-value
+	     (when consumep (next-token lexer))))
+	  (errorp
+	   (cerror* "Expected ~A but found ~A"
+		    (format-token wanted-token-type)
+		    (format-token token-type token-value))
+	   default)
+	  (t
+	   default))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-method.lisp b/src/proto-method.lisp
new file mode 100644
index 0000000..c9d19ea
--- /dev/null
+++ b/src/proto-method.lisp
@@ -0,0 +1,399 @@
+;;; -*-lisp-*-
+;;;
+;;; Method combination protocol
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods and entries.
+
+(export '(effective-method effective-method-message effective-method-class))
+(defclass effective-method ()
+  ((message :initarg :message :type sod-message
+	    :reader effective-method-message)
+   (class :initarg :class :type sod-class :reader effective-method-class))
+  (:documentation
+   "The behaviour invoked by sending a message to an instance of a class.
+
+   This class describes the behaviour when an instance of CLASS is sent
+   MESSAGE.
+
+   This is not a useful class by itself.  Message classes are expected to
+   define their own effective-method classes.
+
+   An effective method classce must accept a `:direct-methods' initarg, which
+   will be a list of applicable methods sorted in most-to-least specific
+   order.  (Either that or you have to add an overriding method to
+   `compute-sod-effective-method'."))
+
+(export 'message-effective-method-class)
+(defgeneric message-effective-method-class (message)
+  (:documentation
+   "Return the effective method class for the given MESSAGE.
+
+   This function is invoked by `compute-sod-effective-method'."))
+
+(export 'primary-method-class)
+(defgeneric primary-method-class (message)
+  (:documentation
+   "Return the name of the primary direct method class for MESSAGE.
+
+   This protocol is used by `simple-message' subclasses."))
+
+(export 'compute-sod-effective-method)
+(defgeneric compute-sod-effective-method (message class)
+  (:documentation
+   "Return the effective method when a CLASS instance receives MESSAGE.
+
+   The default method constructs an instance of the message's chosen
+   `message-effective-method-class', passing the MESSAGE, the CLASS and the
+   list of applicable methods as initargs to `make-instance'."))
+
+(export 'compute-effective-methods)
+(defgeneric compute-effective-methods (class)
+  (:documentation
+   "Return a list of all of the effective methods needed for CLASS.
+
+   The list needn't be in any particular order."))
+
+(export '(method-entry method-entry-effective-method
+	  method-entry-chain-head method-entry-chain-tail))
+(defclass method-entry ()
+  ((method :initarg :method :type effective-method
+	   :reader method-entry-effective-method)
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader method-entry-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader method-entry-chain-tail))
+  (:documentation
+   "An entry point into an effective method.
+
+   Specifically, this is the entry point to the effective method METHOD
+   invoked via the vtable for the chain headed by CHAIN-HEAD.  The CHAIN-TAIL
+   is the most specific class on this chain; this is useful because we can
+   reuse the types of method entries from superclasses on non-primary chains.
+
+   Each effective method may have several different method entries, because
+   an effective method can be called via vtables attached to different
+   chains, and such calls will pass instance pointers which point to
+   different `ichain' structures within the overall instance layout; it's the
+   job of the method entry to adjust the instance pointers correctly for the
+   rest of the effective method.
+
+   The boundaries between a method entry and the effective method
+   is (intentionally) somewhat fuzzy.  In extreme cases, the effective method
+   may not exist at all as a distinct entity in the output because its
+   content is duplicated in all of the method entry functions.  This is left
+   up to the effective method protocol."))
+
+(export 'make-method-entry)
+(defgeneric make-method-entry (effective-method chain-head chain-tail)
+  (:documentation
+   "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
+
+   There is no default method for this function.  (Maybe when the
+   effective-method/method-entry output protocol has settled down I'll know
+   what a sensible default action would be.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Protocol for messages and direct-methods.
+
+(export 'sod-message-argument-tail)
+(defgeneric sod-message-argument-tail (message)
+  (:documentation
+   "Return the argument tail for the message, with invented argument names.
+
+   No `me' argument is prepended; any `:ellipsis' is left as it is."))
+
+(export 'sod-message-no-varargs-tail)
+(defgeneric sod-message-no-varargs-tail (message)
+  (:documentation
+   "Return the argument tail for the message with `:ellipsis' substituted.
+
+   As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
+   However, an :ELLIPSIS is replaced by an argument of type `va_list', named
+   `sod__ap'."))
+
+(export 'sod-method-function-type)
+(defgeneric sod-method-function-type (method)
+  (:documentation
+   "Return the C function type for the direct method.
+
+   This is called during initialization of a direct method object, and the
+   result is cached.
+
+   A default method is provided (by `basic-direct-method') which simply
+   prepends an appropriate `me' argument to the user-provided argument list.
+   Fancy method classes may need to override this behaviour."))
+
+(export 'sod-method-next-method-type)
+(defgeneric sod-method-next-method-type (method)
+  (:documentation
+   "Return the C function type for the next-method trampoline.
+
+   This is called during initialization of a direct method object, and the
+   result is cached.  It should return a function type, not a pointer type.
+
+   A default method is provided (by `delegating-direct-method') which should
+   do the right job.  Very fancy subclasses might need to do something
+   different."))
+
+(export 'sod-method-function-name)
+(defgeneric sod-method-function-name (method)
+  (:documentation
+   "Return the C function name for the direct method."))
+
+(export 'varargs-message-p)
+(defun varargs-message-p (message)
+  "Answer whether the MESSAGE accepts a variable-length argument list.
+
+   We need to jump through some extra hoops in order to cope with varargs
+   messages, so this is useful to know."
+  (member :ellipsis (sod-message-argument-tail message)))
+
+;;;--------------------------------------------------------------------------
+;;; Protocol for effective methods and method entries.
+
+(export 'method-entry-function-type)
+(defgeneric method-entry-function-type (entry)
+  (:documentation
+   "Return the C function type for a method entry."))
+
+(export 'effective-method-basic-argument-names)
+(defgeneric effective-method-basic-argument-names (method)
+  (:documentation
+   "Return a list of argument names to be passed to direct methods.
+
+   The argument names are constructed from the message's arguments returned
+   by `sod-message-no-varargs-tail'.  The basic arguments are the ones
+   immediately derived from the programmer's explicitly stated arguments; the
+   `me' argument is not included, and neither are more exotic arguments added
+   as part of the method delegation protocol."))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
+
+;;; Enhanced code-generator class.
+
+(export '(method-codegen codegen-message codegen-class
+	  codegen-method codegen-target))
+(defclass method-codegen (codegen)
+  ((message :initarg :message :type sod-message :reader codegen-message)
+   (class :initarg :class :type sod-class :reader codegen-class)
+   (method :initarg :method :type effective-method :reader codegen-method)
+   (target :initarg :target :reader codegen-target))
+  (:documentation
+   "Augments CODEGEN with additional state regarding an effective method.
+
+   We store the effective method, and also its target class and owning
+   message, so that these values are readily available to the code-generating
+   functions."))
+
+;;; Protocol.
+
+(export 'compute-effective-method-body)
+(defgeneric compute-effective-method-body (method codegen target)
+  (:documentation
+   "Generates the body of an effective method.
+
+   Writes the function body to the code generator.  It can (obviously)
+   generate auxiliary functions if it needs to.
+
+   The arguments are as specified by the `sod-message-no-varargs-tail', with
+   an additional argument `sod__obj' of type pointer-to-ilayout.  The code
+   should deliver the result (if any) to the TARGET."))
+
+(export 'simple-method-body)
+(defgeneric simple-method-body (method codegen target)
+  (:documentation
+   "Generate the body of a simple effective method.
+
+   The function is invoked on an effective METHOD, with a CODEGEN to which it
+   should emit code delivering the method's value to TARGET."))
+
+;;; Additional instructions.
+
+(export 'convert-to-ilayout)
+(definst convert-to-ilayout (stream) (class chain-head expr)
+  (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
+	  class (sod-class-nickname chain-head) expr))
+
+;;; Utilities.
+
+(export 'invoke-method)
+(defun invoke-method (codegen target arguments-tail direct-method)
+  "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
+
+   The code is generated in the context of CODEGEN, which can be any instance
+   of the `codegen' class -- it needn't be an instance of `method-codegen'.
+   The DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of
+   argument expressions), preceded by a `me' argument of type pointer-to-
+   CLASS where CLASS is the class on which the method was defined.
+
+   If the message accepts a variable-length argument list then a copy of the
+   prevailing master argument pointer is provided in place of the
+   `:ellipsis'."
+
+  (let* ((message (sod-method-message direct-method))
+	 (class (sod-method-class direct-method))
+	 (function (sod-method-function-name direct-method))
+	 (arguments (cons (format nil "&sod__obj.~A.~A"
+				  (sod-class-nickname
+				   (sod-class-chain-head class))
+				  (sod-class-nickname class))
+			  arguments-tail)))
+    (if (varargs-message-p message)
+	(convert-stmts codegen target
+		       (c-type-subtype (sod-method-type direct-method))
+		       (lambda (var)
+			 (ensure-var codegen *sod-ap* (c-type va-list))
+			 (emit-inst codegen
+				    (make-va-copy-inst *sod-ap*
+						       *sod-master-ap*))
+			 (deliver-expr codegen var
+				       (make-call-inst function arguments))
+			 (emit-inst codegen
+				    (make-va-end-inst *sod-ap*))))
+	(deliver-expr codegen target (make-call-inst function arguments)))))
+
+(export 'ensure-ilayout-var)
+(defun ensure-ilayout-var (codegen super)
+  "Define a variable `sod__obj' pointing to the class's ilayout structure.
+
+   CODEGEN is a `method-codegen'.  The class in question is CODEGEN's class,
+   i.e., the target class for the effective method.  SUPER is one of the
+   class's superclasses; it is assumed that `me' is a pointer to a SUPER
+   (i.e., to SUPER's ichain within the ilayout)."
+
+  (let* ((class (codegen-class codegen))
+	 (super-head (sod-class-chain-head super)))
+    (ensure-var codegen "sod__obj"
+		(c-type (* (struct (ilayout-struct-tag class))))
+		(make-convert-to-ilayout-inst class super-head "me"))))
+
+(export 'make-trampoline)
+(defun make-trampoline (codegen super body)
+  "Construct a trampoline function and return its name.
+
+   CODEGEN is a `method-codegen'.  SUPER is a superclass of the CODEGEN
+   class.  We construct a new trampoline function (with an unimaginative
+   name) suitable for being passed to a direct method defined on SUPER as its
+   `next_method'.  In particular, it will have a `me' argument whose type is
+   pointer-to-SUPER.
+
+   The code of the function is generated by BODY, which will be invoked with
+   a single argument which is the TARGET to which it should deliver its
+   result.
+
+   The return value is the name of the generated function."
+
+  (let* ((message (codegen-message codegen))
+	 (message-type (sod-message-type message))
+	 (return-type (c-type-subtype message-type))
+	 (arguments (mapcar (lambda (arg)
+			      (if (eq (argument-name arg) *sod-ap*)
+				  (make-argument *sod-master-ap*
+						 (c-type va-list))
+				  arg))
+			    (sod-message-no-varargs-tail message))))
+    (codegen-push codegen)
+    (ensure-ilayout-var codegen super)
+    (funcall body (codegen-target codegen))
+    (codegen-pop-function codegen (temporary-function)
+			  (c-type (fun (lisp return-type)
+				       ("me" (* (class super)))
+				       . arguments)))))
+
+;;;--------------------------------------------------------------------------
+;;; Method entry protocol.
+
+(export 'effective-method-function-name)
+(defgeneric effective-method-function-name (method)
+  (:documentation
+   "Returns the function name of an effective method."))
+
+(export 'method-entry-function-name)
+(defgeneric method-entry-function-name (method chain-head)
+  (:documentation
+   "Returns the function name of a method entry.
+
+   The method entry is given as an effective method/chain-head pair, rather
+   than as a method entry object because we want the function name before
+   we've made the entry object."))
+
+(export 'compute-method-entry-functions)
+(defgeneric compute-method-entry-functions (method)
+  (:documentation
+   "Construct method entry functions.
+
+   Builds the effective method function (if there is one) and the necessary
+   method entries.  Returns a list of functions (i.e., `function-inst'
+   objects) which need to be defined in the generated source code."))
+
+;;;--------------------------------------------------------------------------
+;;; Invoking direct methods.
+
+(export 'invoke-delegation-chain)
+(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
+  "Invoke a chain of delegating methods.
+
+   CODEGEN is a `method-codegen'.  BASIC-TAIL is a list of argument
+   expressions to provide to the methods.  The result of the delegation chain
+   will be delivered to TARGET.
+
+   The CHAIN is a list of method objects (it's intended to be used with
+   `delegating-direct-method' objects).  The behaviour is as follows.  The
+   first method in the chain is invoked with the necessary arguments (see
+   below) including a `next_method' pointer.  If KERNEL is nil and there are
+   no more methods in the chain then the `next_method' pointer will be null;
+   otherwise it will point to a `trampoline' function, whose behaviour is to
+   call the remaining methods on the chain as a delegation chain.  The method
+   may choose to call this function with its arguments.  It will finally
+   return a value, which will be delivered to the TARGET.
+
+   If the chain is empty, then the code generated by KERNEL (given a TARGET
+   argument) will be invoked.  It is an error if both CHAIN and KERNEL are
+   nil."
+
+  (let* ((message (codegen-message codegen))
+	 (argument-tail (if (varargs-message-p message)
+			    (cons *sod-master-ap* basic-tail)
+			    basic-tail)))
+    (labels ((next-trampoline (method chain)
+	       (if (or kernel chain)
+		   (make-trampoline codegen (sod-method-class method)
+				    (lambda (target)
+				      (invoke chain target)))
+		   0))
+	     (invoke (chain target)
+	       (if (null chain)
+		   (funcall kernel target)
+		   (let* ((trampoline (next-trampoline (car chain)
+						       (cdr chain))))
+		     (invoke-method codegen target
+				    (cons trampoline argument-tail)
+				    (car chain))))))
+      (invoke chain target))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-module.lisp b/src/proto-module.lisp
new file mode 100644
index 0000000..aa167e4
--- /dev/null
+++ b/src/proto-module.lisp
@@ -0,0 +1,202 @@
+;;; -*-lisp-*-
+;;;
+;;; Module protocol definition
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Module environment.
+
+(defvar *module-bindings-alist* nil
+  "An alist of (SYMBOL . THUNK) pairs.
+
+   During module construction, each SYMBOL is special-bound to the value
+   returned by the corresponding THUNK.")
+
+(export 'add-module-binding)
+(defun add-module-binding (symbol thunk)
+  "Add a new module variable binding.
+
+   During module construction, SYMBOL will be special-bound to the value
+   returned by THUNK.  If you can, use `define-module-var' instead."
+  (aif (assoc symbol *module-bindings-alist*)
+       (setf (cdr it) thunk)
+       (asetf *module-bindings-alist* (acons symbol thunk it))))
+
+(export 'define-module-var)
+(defmacro define-module-var (name value-form &optional documentation)
+  "Add a new module variable binding.
+
+   During module construction, NAME will be special-bound to the value of
+   VALUE-FORM.  The NAME is proclaimed special, but is initially left
+   unbound."
+  `(progn
+     (defvar ,name)
+     ,@(and documentation
+	    `((setf (documentation ',name 'variable) ,documentation)))
+     (add-module-binding ',name (lambda () ,value-form))))
+
+(export 'call-with-module-environment)
+(defun call-with-module-environment (thunk)
+  "Invoke THUNK with a new collection of bindings for the module variables."
+  (progv
+      (mapcar #'car *module-bindings-alist*)
+      (mapcar (compose #'cdr #'funcall) *module-bindings-alist*)
+    (funcall thunk)))
+
+;;;--------------------------------------------------------------------------
+;;; The reset switch.
+
+(defvar *clear-the-decks-alist* nil
+  "List tracking functions to be called by `clear-the-decks'.")
+
+(export 'add-clear-the-decks-function)
+(defun add-clear-the-decks-function (symbol thunk)
+  "Add a function to the `clear-the-decks' list.
+
+   If a function tagged by SYMBOL already exists on the list, then that
+   function is replaced; otherwise a new function is added."
+  (aif (assoc symbol *clear-the-decks-alist*)
+       (setf (cdr it) thunk)
+       (asetf *clear-the-decks-alist* (acons symbol thunk it))))
+
+(export 'define-clear-the-decks)
+(defmacro define-clear-the-decks (name &body body)
+  "Add behaviour to `clear-the-decks'.
+
+   When `clear-the-decks' is called, the BODY will be evaluated as a progn.
+   The relative order of `clear-the-decks' operations is unspecified."
+  `(add-clear-the-decks-function ',name (lambda () ,@body)))
+
+(export 'clear-the-decks)
+(defun clear-the-decks ()
+  "Invoke a sequence of functions to reset the world."
+  (dolist (item *clear-the-decks-alist*)
+    (funcall (cdr item))))
+
+;;;--------------------------------------------------------------------------
+;;; Module construction protocol.
+
+(export '*module*)
+(defparameter *module* nil
+  "The current module under construction.
+
+   This is always an instance of MODULE.  Once we've finished constructing
+   it, we'll call `change-class' to turn it into an instance of whatever type
+   is requested in the module's `:lisp-class' property.")
+
+(export 'module-import)
+(defgeneric module-import (object)
+  (:documentation
+   "Import definitions into the current environment.
+
+   Instructs the OBJECT to import its definitions into the current
+   environment.  Modules pass the request on to their constituents.  There's
+   a default method which does nothing at all.
+
+   It's not usual to modify the current module.  Inserting things into the
+   `*module-type-map*' is a good plan.")
+  (:method (object) nil))
+
+(export 'add-to-module)
+(defgeneric add-to-module (module item)
+  (:documentation
+   "Add ITEM to the MODULE's list of accumulated items.
+
+   The module items participate in the `module-import' and `add-output-hooks'
+   protocols."))
+
+(export 'finalize-module)
+(defgeneric finalize-module (module)
+  (:documentation
+   "Finalizes a module, setting everything which needs setting.
+
+   This isn't necessary if you made the module by hand.  If you've
+   constructed it incrementally, then it might be a good plan.  In
+   particular, it will change the class (using `change-class') of the module
+   according to the class choice set in the module's `:lisp-class' property.
+   This has the side effects of calling `shared-initialize', setting the
+   module's state to T, and checking for unrecognized properties.  (Therefore
+   subclasses should add a method to `shared-initialize' taking care of
+   looking at interesting properties, just to make sure they're ticked
+   off.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Module objects.
+
+(export '(module module-name module-pset module-items module-dependencies))
+(defclass module ()
+  ((name :initarg :name :type pathname :reader module-name)
+   (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
+   (items :initarg :items :initform nil :type list :accessor module-items)
+   (dependencies :initarg :dependencies :initform nil
+		 :type list :accessor module-dependencies)
+   (state :initarg :state :initform nil :accessor module-state))
+  (:documentation
+   "A module is a container for the definitions made in a source file.
+
+   Modules are the fundamental units of translation.  The main job of a
+   module is to remember which definitions it contains, so that they can be
+   translated and written to output files.  The module contains the following
+   handy bits of information:
+
+     * A (path) name, which is the filename we used to find it.  The default
+       output filenames are derived from this.  (We use the file's truename
+       as the hash key to prevent multiple inclusion, and that's a different
+       thing.)
+
+     * A property list containing other useful things.
+
+     * A list of items which the module contains.
+
+     * A list of other modules that this one depends on.
+
+   Modules are usually constructed by the `read-module' function, though
+   there's nothing to stop fancy extensions building modules
+   programmatically."))
+
+(export 'define-module)
+(defmacro define-module
+    ((name &key (truename nil truenamep) (location nil locationp))
+     &body body)
+  "Define a new module.
+
+   The module will be called NAME; it will be included in the *module-map*
+   only if it has a TRUENAME (which defaults to the truename of NAME, or nil
+   if there is no file with that name).  The module is populated by
+   evaluating the BODY in a dynamic environment where *module* is bound to
+   the module under construction, and any other module variables are bound to
+   appropriate initial values -- see `*module-bindings-alist*' and
+   `define-module-var'.
+
+   Evaluation order irregularity: the TRUENAME and LOCATION arguments are
+   always evaluated in that order, regardless of their order in the macro
+   call site."
+
+  `(build-module ,name
+		 (lambda () ,@body)
+		 ,@(and truenamep `(:truename ,truename))
+		 ,@(and locationp `(:location ,location))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-output.lisp b/src/proto-output.lisp
new file mode 100644
index 0000000..2d62e51
--- /dev/null
+++ b/src/proto-output.lisp
@@ -0,0 +1,171 @@
+;;; -*-lisp-*-
+;;;
+;;; Output scheduling protocol
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(export '(sequencer-item make-sequencer-item sequencer-item-p
+	  sequencer-item-name sequencer-item-functions))
+(defstruct (sequencer-item
+	     (:constructor make-sequencer-item (name &optional functions)))
+  "Represents a distinct item to be sequenced by a `sequencer'.
+
+   A `sequencer-item' maintains a list of FUNCTIONS which are invoked when
+   the sequencer is invoked."
+  (name nil :read-only t)
+  (functions nil :type list))
+
+(export '(sequencer sequencer-constraints sequencer-table))
+(defclass sequencer ()
+  ((constraints :initarg :constraints :initform nil
+		:type list :accessor sequencer-constraints)
+   (table :initform (make-hash-table :test #'equal)
+	  :reader sequencer-table))
+  (:documentation
+   "A sequencer tracks items and invokes them in the proper order.
+
+   The job of a SEQUENCER object is threefold.  Firstly, it collects
+   sequencer items and stores them in its table indexed by name.  Secondly,
+   it gathers CONSTRAINTS, which impose an ordering on the items.  Thirdly,
+   it can be instructed to invoke the items in an order compatible with the
+   established constraints.
+
+   Sequencer item names may may any kind of object which can be compared with
+   EQUAL.  In particular, symbols, integers and strings are reasonable
+   choices for atomic names, and lists work well for compound names -- so
+   it's possible to construct a hierarchy."))
+
+(export 'ensure-sequencer-item)
+(defgeneric ensure-sequencer-item (sequencer name)
+  (:documentation
+   "Arrange that SEQUENCER has a sequencer-item called NAME.
+
+   Returns the corresponding SEQUENCER-ITEM object."))
+
+(export 'add-sequencer-constraint)
+(defgeneric add-sequencer-constraint (sequencer constraint)
+  (:documentation
+   "Attach the given CONSTRAINT to an SEQUENCER.
+
+   The CONSTRAINT should be a list of sequencer-item names; see
+   ENSURE-SEQUENCER-ITEM for what they look like.  Note that the names
+   needn't have been declared in advance; indeed, they needn't be mentioned
+   anywhere else at all."))
+
+(export 'add-sequencer-item-function)
+(defgeneric add-sequencer-item-function (sequencer name function)
+  (:documentation
+   "Arranges to call FUNCTION when the item called NAME is traversed.
+
+   More than one function can be associated with a given sequencer item.
+   They are called in the same order in which they were added.
+
+   Note that an item must be mentioned in at least one constraint in order to
+   be traversed by INVOKE-SEQUENCER-ITEMS.  If there are no special ordering
+   requirments for a particular item, then the trivial constraint (NAME) will
+   suffice."))
+
+(export 'invoke-sequencer-items)
+(defgeneric invoke-sequencer-items (sequencer &rest arguments)
+  (:documentation
+   "Invoke functions attached to the SEQUENCER's items in the right order.
+
+   Each function is invoked in turn with the list of ARGUMENTS.  The return
+   values of the functions are discarded."))
+
+;;;--------------------------------------------------------------------------
+;;; Output preparation.
+
+(defgeneric hook-output (object reason sequencer)
+  (:documentation
+   "Announces the intention to write SEQUENCER, with a particular REASON.
+
+   The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
+   can be matched using an EQL-specializer.  In response, OBJECT should add
+   any constrains and item functions that it wishes, and pass the
+   announcement to its sub-objects.  It is not uncommon for an object to pass
+   a reason to its sub-objects that is different from the REASON with which
+   it was itself invoked.")
+
+  (:method-combination progn)
+  (:method progn (object reason sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Useful syntax.
+
+(defmacro sequence-output
+    ((streamvar sequencer) &body clauses)
+  "Register output behaviour in a convenient manner.
+
+   The full syntax isn't quite as described:
+
+	sequence-output (STREAMVAR SEQUENCER)
+	  { :constrant CONSTRAINT }*
+	  CLAUSE*
+
+	STREAMVAR ::= a symbol
+	SEQUENCER ::= a sequencer object, evaluated
+	CONSTRAINT ::= ( ITEM-NAME* )
+	CLAUSE ::= (ITEM-NAME FORM*)
+	ITEM-NAME ::= an atom or a list of expressions
+
+   An ITEM-NAME may be a self-evaluating atom (in which case it stands for
+   itself, clearly), a symbol (in which case the corresponding variable value
+   is used) or a list of forms (in which case the name used is the list of
+   the corresponding values).
+
+   The behaviour is as follows.  The CONSTRAINTS, if any, are added to the
+   sequencer.  Then, for each CLAUSE, a function is attached to the named
+   sequencer item whose behaviour is to bind STREAMVAR to the output stream
+   and evaluate the FORMs as a progn."
+
+  (let ((seqvar (gensym "SEQ")))
+    (labels ((convert-item-name (name)
+	       (if (listp name)
+		   (cons 'list name)
+		   name))
+	     (convert-constraint (constraint)
+	       (cons 'list (mapcar #'convert-item-name constraint)))
+	     (process-body (clauses)
+	       (if (eq (car clauses) :constraint)
+		   (cons `(add-sequencer-constraint
+			   ,seqvar
+			   ,(convert-constraint (cadr clauses)))
+			 (process-body (cddr clauses)))
+		   (mapcar (lambda (clause)
+			     (let ((name (car clause))
+				   (body (cdr clause)))
+			       `(add-sequencer-item-function
+				 ,seqvar
+				 ,(convert-item-name name)
+				 (lambda (,streamvar)
+				   ,@body))))
+			   clauses))))
+      `(let ((,seqvar ,sequencer))
+	 ,@(process-body clauses)))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/proto-pset.lisp b/src/proto-pset.lisp
new file mode 100644
index 0000000..d4dc614
--- /dev/null
+++ b/src/proto-pset.lisp
@@ -0,0 +1,320 @@
+;;; -*-lisp-*-
+;;;
+;;; Protocol for property sets
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Property representation.
+
+(export 'property-key)
+(defun property-key (name)
+  "Convert NAME into a keyword.
+
+   If NAME isn't a symbol already, then flip its case (using
+   `frob-identifier'), and intern into the `keyword' package."
+  (etypecase name
+    (symbol name)
+    (string (intern (frob-identifier name) :keyword))))
+
+(export 'property-type)
+(defgeneric property-type (value)
+  (:documentation "Guess a sensible property type to use for VALUE.")
+  (:method ((value symbol)) :symbol)
+  (:method ((value integer)) :integer)
+  (:method ((value string)) :string)
+  (:method ((value character)) :char)
+  (:method (value) :other))
+
+(export '(property propertyp make-property
+	  p-name p-value p-type p-key p-seenp))
+(defstruct (property
+	     (:predicate propertyp)
+	     (:conc-name p-)
+	     (:constructor make-property
+	       (name value
+		&key (type (property-type value))
+		     ((:location %loc))
+		     seenp
+		&aux (key (property-key name))
+		     (location (file-location %loc)))))
+  "A simple structure for holding a property in a property set.
+
+   The main useful feature is the ability to tick off properties which have
+   been used, so that we can complain about unrecognized properties.
+
+   An explicit type tag is necessary because we need to be able to talk
+   distinctly about identifiers, strings and symbols, and we've only got two
+   obvious Lisp types to play with.  Sad, but true."
+
+  (name nil :type (or string symbol))
+  (value nil :type t)
+  (type nil :type symbol)
+  (location (file-location nil) :type file-location)
+  (key nil :type symbol)
+  (seenp nil :type boolean))
+
+(defun string-to-symbol
+    (string &key (package *package*) (swap-case t) (swap-hyphen t))
+  "Convert STRING to a symbol in PACKAGE.
+
+   Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
+   package; PACKAGE is used if there isn't a prefix.  A doubled colon allows
+   access to internal symbols, and will intern if necessary.  Note that
+   escape characters are /not/ processed; don't put colons in package names
+   if you want to use them from SOD property sets.
+
+   The portions of the string are modified by `frob-identifier'; the
+   arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
+   control this process."
+
+  (let* ((length (length string))
+	 (colon (position #\: string)))
+    (multiple-value-bind (start internalp)
+	(cond ((not colon) (values 0 t))
+	      ((and (< (1+ colon) length)
+		    (char= (char string (1+ colon)) #\:))
+	       (values (+ colon 2) t))
+	      (t
+	       (values (1+ colon) nil)))
+      (when colon
+	(let* ((package-name (if (zerop colon) "KEYWORD"
+				 (frob-identifier (subseq string 0 colon)
+						  :swap-case swap-case
+						  :swap-hyphen swap-hyphen)))
+	       (found (find-package package-name)))
+	  (unless found
+	    (error "Unknown package `~A'" package-name))
+	  (setf package found)))
+      (let ((name (frob-identifier (subseq string start)
+				   :swap-case swap-case
+				   :swap-hyphen swap-hyphen)))
+	(multiple-value-bind (symbol status)
+	    (funcall (if internalp #'intern #'find-symbol) name package)
+	  (cond ((or internalp (eq status :external))
+		 symbol)
+		((not status)
+		 (error "Symbol `~A' not found in package `~A'"
+			name (package-name package)))
+		(t
+		 (error "Symbol `~A' not external in package `~A'"
+			name (package-name package)))))))))
+
+(export 'coerce-property-value)
+(defgeneric coerce-property-value (value type wanted)
+  (:documentation
+   "Convert VALUE, a property of type TYPE, to be of type WANTED.
+
+   It's sensible to add additional methods to this function, but there are
+   all the ones we need.")
+
+  ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
+  ;; form.  Otherwise, if nothing else matched, then I guess we'll have to
+  ;; say it didn't work.
+  (:method (value type wanted)
+    (if (eql type wanted) value
+	(error "Incorrect type: expected ~A but found ~A" wanted type)))
+
+  ;; If the caller asks for type T then give him the raw thing.
+  (:method (value type (wanted (eql t)))
+    value))
+
+;;;--------------------------------------------------------------------------
+;;; Property set representation.
+
+(export '(pset psetp))
+(defstruct (pset (:predicate psetp)
+		 (:constructor %make-pset)
+		 (:conc-name %pset-))
+  "A property set.
+
+   Wrapped up in a structure so that we can define a print function."
+  (hash (make-hash-table) :type hash-table))
+
+(export '(make-pset pset-get pset-store pset-map))
+(declaim (inline make-pset pset-get pset-store pset-map))
+
+(defun make-pset ()
+  "Constructor for property sets."
+  (%make-pset))
+
+(defun pset-get (pset key)
+  "Look KEY up in PSET and return what we find.
+
+   If there's no property by that name, return NIL."
+  (values (gethash key (%pset-hash pset))))
+
+(defun pset-store (pset prop)
+  "Store property PROP in PSET.
+
+   Overwrite or replace any previous property with the same name.  Mutates
+   the property set."
+  (setf (gethash (p-key prop) (%pset-hash pset)) prop))
+
+(defun pset-map (func pset)
+  "Call FUNC for each property in PSET."
+  (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
+	   (%pset-hash pset)))
+
+(export 'with-pset-iterator)
+(defmacro with-pset-iterator ((name pset) &body body)
+  "Evaluate BODY with NAME bound to a macro returning properties from PSET.
+
+   Evaluating (NAME) returns a property object or nil if all properties have
+   been read."
+  (with-gensyms (next win key value)
+    `(with-hash-table-iterator (,next (%pset-hash ,pset))
+       (macrolet ((,name ()
+		    (multiple-value-bind (,win ,key ,value) (,next)
+		      (declare (ignore ,key))
+		      (and ,win ,value))))
+	 ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; `Cooked' property set operations.
+
+(export 'store-property)
+(defun store-property
+    (pset name value &key (type (property-type value)) location)
+  "Store a property in PSET."
+  (pset-store pset
+	      (make-property name value :type type :location location)))
+
+(export 'get-property)
+(defun get-property (pset name type &optional default)
+  "Fetch a property from a property set.
+
+   If a property NAME is not found in PSET, or if a property is found, but
+   its type doesn't match TYPE, then return DEFAULT and nil; otherwise return
+   the value and its file location.  In the latter case, mark the property as
+   having been used.
+
+   The value returned depends on the TYPE argument provided.  If you pass NIL
+   then you get back the entire PROPERTY object.  If you pass `t', then you
+   get whatever was left in the property set, uninterpreted.  Otherwise the
+   value is coerced to the right kind of thing (where possible) and returned.
+
+   If PSET is nil, then return DEFAULT."
+
+  (let ((prop (and pset (pset-get pset (property-key name)))))
+    (with-default-error-location ((and prop (p-location prop)))
+      (cond ((not prop)
+	     (values default nil))
+	    ((not type)
+	     (setf (p-seenp prop) t)
+	     (values prop (p-location prop)))
+	    (t
+	     (setf (p-seenp prop) t)
+	     (values (coerce-property-value (p-value prop)
+					    (p-type prop)
+					    type)
+		     (p-location prop)))))))
+
+(export 'add-property)
+(defun add-property
+    (pset name value &key (type (property-type value)) location)
+  "Add a property to PSET.
+
+   If a property with the same NAME already exists, report an error."
+
+  (with-default-error-location (location)
+    (let ((existing (get-property pset name nil)))
+      (when existing
+	(error "Property ~S already defined~@[ at ~A~]"
+	       name (p-location existing)))
+      (store-property pset name value :type type :location location))))
+
+(export 'make-property-set)
+(defun make-property-set (&rest plist)
+  "Make a new property set, with given properties.
+
+   This isn't the way to make properties when parsing, but it works well for
+   programmatic generation.  The arguments should form a property list
+   (alternating keywords and values is good).
+
+   An attempt is made to guess property types from the Lisp types of the
+   values.  This isn't always successful but it's not too bad.  The
+   alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing
+   into the set."
+
+  (property-set plist))
+
+(export 'property-set)
+(defgeneric property-set (thing)
+  (:documentation
+   "Convert THING into a property set.")
+  (:method ((pset pset)) pset)
+  (:method ((list list))
+    "Convert a list into a property set.  This works for alists and plists."
+    (multiple-value-bind (next name value)
+	(if (and list (consp (car list)))
+	    (values #'cdr #'caar #'cdar)
+	    (values #'cddr #'car #'cadr))
+      (do ((pset (make-pset))
+	   (list list (funcall next list)))
+	  ((endp list) pset)
+	(add-property pset (funcall name list) (funcall value list))))))
+
+(export 'check--unused-properties)
+(defun check-unused-properties (pset)
+  "Issue errors about unused properties in PSET."
+  (when pset
+    (pset-map (lambda (prop)
+		(unless (p-seenp prop)
+		  (cerror*-with-location (p-location prop)
+					 "Unknown property `~A'"
+					 (p-name prop))
+		  (setf (p-seenp prop) t)))
+	      pset)))
+
+;;;--------------------------------------------------------------------------
+;;; Utility macros.
+
+(defmacro default-slot-from-property
+    ((instance slot slot-names)
+     (pset property type
+      &optional (pvar (gensym "PROP-"))
+      &rest convert-forms)
+     &body default-forms)
+  "Initialize a slot from a property.
+
+   We initialize SLOT in INSTANCE.  In full: if PSET contains a property
+   called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
+   CONVERT-FORMS -- these default to just using the property value.  If
+   there's no property, and the slot is named in SLOT-NAMES and currently
+   unbound, then evaluate DEFAULT-FORMS and use their value to compute the
+   slot value."
+
+  (once-only (instance slot slot-names pset property type)
+    (with-gensyms (floc)
+      `(multiple-value-bind (,pvar ,floc)
+	   (get-property ,pset ,property ,type)
+	 (if ,floc
+	     (setf (slot-value ,instance ,slot)
+		   (with-default-error-location (,floc)
+		     ,@(or convert-forms `(,pvar))))
+	     (default-slot (,instance ,slot ,slot-names)
+	       ,@default-forms))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/scratch.lisp b/src/scratch.lisp
new file mode 100644
index 0000000..8862ac2
--- /dev/null
+++ b/src/scratch.lisp
@@ -0,0 +1,16 @@
+(in-package #:sod)
+
+(defun try-parse* (parser string)
+  (call-with-module-environment
+   (lambda ()
+     (let* ((char-scanner (make-string-scanner string))
+	    (scanner (make-instance 'sod-token-scanner
+				    :char-scanner char-scanner)))
+       (funcall parser scanner)))))
+
+(defmacro try-parse ((scanner string) &body parser)
+  `(try-parse* (lambda (,scanner)
+		 (with-parser-context
+		     (token-scanner-context :scanner ,scanner)
+		   ,@parser))
+	       ,string))
diff --git a/src/sod-test.asd b/src/sod-test.asd
new file mode 100644
index 0000000..17d6d40
--- /dev/null
+++ b/src/sod-test.asd
@@ -0,0 +1,76 @@
+;;; -*-lisp-*-
+;;;
+;;; Tests for the Simple Object Design translator
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:sod-test-sysdef
+  (:use #:common-lisp #:asdf))
+
+(cl:in-package #:sod-test-sysdef)
+
+;;;--------------------------------------------------------------------------
+;;; Definition.
+
+(defsystem sod-test
+
+  ;; Boring copyright stuff.
+  :version "1.0.0"
+  :author "Mark Wooding"
+  :license "GNU General Public License, version 2 or later"
+
+  ;; Documentation.
+  :description "Tests for the Sensible Object Design translator."
+
+  :long-description
+  "This system provides unit tests for the Sod translator."
+
+  :depends-on ("sod" "xlunit")
+
+  :components
+  ((:file "test-base")
+
+   ;; Test the parser edifice.
+   (:module "parser" :depends-on ("test-base") :components
+    ((:file "test-parser")
+     (:file "test-scanner-charbuf")))
+
+   ;; The actual tests.
+   (:file "test-c-types" :depends-on ("test-base"))
+   (:file "test-codegen" :depends-on ("test-base"))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+(defmethod perform ((op test-op) (system (eql (find-system "sod-test"))))
+  (operate 'load-op system)
+  (funcall (find-symbol "RUN-TESTS" "SOD-TEST")))
+
+;;;--------------------------------------------------------------------------
+;;; Hacks.
+
+(defmethod perform :around
+    ((op compile-op) (component (eql (find-system "sod-test"))))
+  (let ((*compile-file-failure-behaviour* :warn))
+    (call-next-method)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/sod.asd b/src/sod.asd
new file mode 100644
index 0000000..64f331b
--- /dev/null
+++ b/src/sod.asd
@@ -0,0 +1,162 @@
+;;; -*-lisp-*-
+;;;
+;;; System definition for the Simple Object Design translator
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:sod-sysdef
+  (:use #:common-lisp #:asdf))
+
+(cl:in-package #:sod-sysdef)
+
+;;;--------------------------------------------------------------------------
+;;; Definition.
+
+(defsystem sod
+
+  ;; Boring copyright stuff.
+  :version "1.0.0"
+  :author "Mark Wooding"
+  :license "GNU General Public License, version 2 or later"
+
+  ;; Documentation.
+  :description "A Sensible Object Design for C."
+
+  :long-description
+  "This system implements a fairly simple, yet powerful object system for
+   plain old C.  Its main features are as follows.
+
+     * Multiple inheritance, done properly (unlike C++, say), with a
+       superclass linearlization algorithm, and exactly one copy of any
+       superclass's slots.
+
+     * Method combinations, and multiple flavours of methods, to make mixin
+       classes more useful.
+
+     * The default method combination doesn't depend on the programmer
+       statically predicting which superclass's method to delegate to.
+       Multiple inheritance makes this approach (taken by C++) fail: the
+       right next method might be an unknown sibling, and two siblings might
+       be in either order depending on descendents.
+
+     * Minimal runtime support requirements, so that it's suitable for use
+       wherever C is -- e.g., interfacing to other languages."
+
+  :components
+  ((:file "utilities")
+
+   ;; Parser equipment.  This is way more elaborate than it needs to be, but
+   ;; it was interesting, and it may well get split off into a separate
+   ;; library.
+   (:module "parser" :depends-on ("utilities") :components
+    ((:file "package")
+
+     ;; File location protocol (including error reporting).
+     (:file "proto-floc" :depends-on ("package"))
+     (:file "impl-floc" :depends-on ("proto-floc"))
+
+     ;; Position-aware streams.
+     (:file "proto-streams" :depends-on ("package"))
+     (:file "impl-streams" :depends-on ("proto-streams" "proto-floc"))
+
+     ;; Scanner protocol, and various scanner implementations.
+     (:file "proto-scanner" :depends-on ("package"))
+     (:file "impl-scanner" :depends-on ("proto-scanner"))
+     (:file "impl-scanner-charbuf" :depends-on
+	    ("proto-scanner" "proto-floc" "proto-streams"))
+     (:file "impl-scanner-token" :depends-on ("proto-scanner"))
+
+     ;; Parser notation macro support.
+     (:file "proto-parser" :depends-on ("package"))
+     (:file "impl-parser" :depends-on ("proto-parser"))
+
+     ;; Expression parser support.
+     (:file "proto-parser-expr" :depends-on ("proto-parser"))
+     (:file "impl-parser-expr" :depends-on ("proto-parser-expr"))
+
+     ;; Stitching parsers to scanners.
+     (:file "impl-scanner-context" :depends-on
+	    ("proto-parser" "proto-scanner"))))
+
+   (:file "package" :depends-on ("parser"))
+
+   ;; C type representation protocol.
+   (:file "proto-c-types" :depends-on ("package"))
+   (:file "impl-c-types" :depends-on ("proto-c-types"))
+
+   ;; Property set protocol.
+   (:file "proto-pset" :depends-on ("package"))
+   (:file "impl-pset" :depends-on ("proto-pset"))
+
+   ;; Lexical analysis.
+   ;;(:file "proto-lexer" :depends-on ("parser"))
+   ;;(:file "impl-lexer" :depends-on ("proto-lexer"))
+
+   ;; Code generation protocol.
+   (:file "proto-codegen" :depends-on ("package"))
+   (:file "impl-codegen" :depends-on ("proto-codegen"))
+
+   ;; Modules.
+   (:file "proto-module" :depends-on ("package"))
+   (:file "impl-module" :depends-on
+	  ("proto-module" "proto-pset" "impl-c-types-class" "builtin"))
+   (:file "builtin" :depends-on ("proto-module" "proto-pset" "classes"
+				 "impl-c-types" "impl-c-types-class"))
+
+   ;; Output.
+   (:file "proto-output" :depends-on ("package"))
+   (:file "impl-output" :depends-on ("proto-output"))
+
+   ;; Class representation.
+   (:file "classes" :depends-on ("package" "proto-c-types"))
+   (:file "impl-c-types-class" :depends-on ("classes" "proto-module"))
+   (:file "class-utilities" :depends-on
+	  ("classes" "impl-codegen" "impl-pset"
+	   "impl-c-types" "impl-c-types-class"))
+
+   ;; Class construction.
+   (:file "proto-class-make" :depends-on ("class-utilities"))
+   (:file "impl-class-make" :depends-on ("proto-class-make"))
+
+   ;; Class layout.
+   (:file "proto-class-layout" :depends-on ("class-utilities"))
+   (:file "impl-class-layout" :depends-on
+	  ("proto-class-layout" "proto-method"))
+
+   ;; Class finalization.
+   (:file "proto-class-finalize" :depends-on ("class-utilities"))
+   (:file "impl-class-finalize" :depends-on ("proto-class-finalize"))
+
+   ;; Method generation.
+   (:file "proto-method" :depends-on ("class-utilities"))
+   (:file "impl-method" :depends-on ("proto-method"))
+
+   ;; Class output.
+   (:file "output-class" :depends-on ("proto-output" "classes"))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+(defmethod perform ((op test-op) (component (eql (find-system "sod"))))
+  (operate 'test-op "sod-test" :force t))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/test-base.lisp b/src/test-base.lisp
new file mode 100644
index 0000000..6e020cb
--- /dev/null
+++ b/src/test-base.lisp
@@ -0,0 +1,58 @@
+;;; -*-lisp-*-
+;;;
+;;; Package definition and other basic stuff for SOD tests
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:sod-test
+  (:use #:common-lisp
+
+	#+sbcl #:sb-mop
+	#+(or cmu clisp) #:mop
+	#+ecl #:mop
+
+	#:xlunit
+
+	#:sod-utilities #:sod-parser #:sod)
+
+  ;; Some internal symbols which are useful.  This is somewhat bletcherous.
+  (:import-from #:sod-parser #:charbuf-size))
+
+(cl:in-package #:sod-test)
+
+(defvar *sod-test-suite*
+  (make-instance 'test-suite
+		 :name "Sod master test suite"
+		 :description "Top-level test for the Sod translator."))
+
+(defun assert-princ (object string)
+  (let ((*print-right-margin* 77)
+	(print (princ-to-string object)))
+    (assert-equal print string
+		  (format nil "Assert princ: ~S ~_prints as `~A' ~_~
+			       rather than `~A'."
+			  object print string))))
+
+(defun run-tests ()
+  (textui-test-run *sod-test-suite*))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/test-c-types.lisp b/src/test-c-types.lisp
new file mode 100644
index 0000000..0c6a8b7
--- /dev/null
+++ b/src/test-c-types.lisp
@@ -0,0 +1,235 @@
+;;; -*-lisp-*-
+;;;
+;;; Test handling of C types
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-test)
+
+;;;--------------------------------------------------------------------------
+;;; Here we go.
+
+(defclass c-types-test (test-case) ())
+(add-test *sod-test-suite* (get-suite c-types-test))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun assert-cteqp (a b)
+  (unless (c-type-equal-p a b)
+    (failure "Assert equal C types: ~A ~_and ~A" a b)))
+
+(defun assert-not-cteqp (a b)
+  (when (c-type-equal-p a b)
+    (failure "Assert unequal C types: ~A ~_and ~A" a b)))
+
+(defun assert-pp-ctype (type kernel string)
+  (let* ((*print-right-margin* 77)
+	 (print (with-output-to-string (out)
+		  (pprint-c-type type out kernel))))
+    (assert-equal print string
+		  (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~
+			       rather than `~A'."
+			  type kernel print string))))
+
+;;;--------------------------------------------------------------------------
+;;; Simple types.
+
+(def-test-method intern-trivial-simple-type ((test c-types-test) :run nil)
+  (assert-eql (c-type "foo") (make-simple-type "foo")))
+
+(def-test-method intern-qualified-simple-type ((test c-types-test) :run nil)
+  (assert-eql (c-type ("foo" :const :volatile))
+	      (make-simple-type "foo" '(:volatile :const :volatile))))
+
+(def-test-method mismatch-simple-type ((test c-types-test) :run nil)
+  (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo")))
+
+(def-test-method print-simple-type ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type "foo") "f" "foo f"))
+
+(def-test-method print-simple-type-abs ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type "foo") nil "foo"))
+
+;;;--------------------------------------------------------------------------
+;;; Tagged types.
+
+(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
+  (assert-eql (c-type (struct "foo")) (make-struct-type "foo")))
+
+(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
+  (assert-eql (c-type (enum "foo" :const :volatile))
+	      (make-enum-type "foo" '(:volatile :const :volatile))))
+
+(def-test-method mismatch-tagged-type ((test c-types-test) :run nil)
+  (assert-not-cteqp (c-type (enum "foo" :restrict))
+		    (make-union-type "foo" '(:restrict))))
+
+(def-test-method print-struct-type ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f"))
+
+(def-test-method print-union-type-abs ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (union "foo")) nil "union foo"))
+
+;;;--------------------------------------------------------------------------
+;;; Pointer types.
+
+(def-test-method intern-trivial-pointer ((test c-types-test) :run nil)
+  (assert-eql (c-type (* "foo"))
+	      (make-pointer-type (make-simple-type "foo"))))
+
+(def-test-method intern-qualified-pointer ((test c-types-test) :run nil)
+  (assert-eql (c-type (* "foo" :const :volatile))
+	      (make-pointer-type (make-simple-type "foo")
+				 '(:volatile :const))))
+
+(def-test-method intern-double-indirection ((test c-types-test) :run nil)
+  (assert-eql (c-type (* (* "foo")))
+	      (make-pointer-type
+	       (make-pointer-type (make-simple-type "foo")))))
+
+(def-test-method non-intern-complex-pointer ((test c-types-test) :run nil)
+  ;; The protocol doesn't specify what we do here; but we want to avoid
+  ;; interning pointers to non-interned types in order to prevent the intern
+  ;; table filling up with cruft.  So test anyway.
+  (let ((a (c-type (* ([] "foo" 16))))
+	(b (make-pointer-type
+	    (make-array-type (make-simple-type "foo") '(16)))))
+    (assert-not-eql a b)
+    (assert-cteqp a b)))
+
+(def-test-method print-pointer ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (* char)) "p" "char *p"))
+
+(def-test-method print-qualified-pointer ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p"))
+
+(def-test-method print-pointer-abs ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (* char)) nil "char *"))
+
+(def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (* char :const)) nil "char *const"))
+
+;;;--------------------------------------------------------------------------
+;;; Array types.
+
+(def-test-method compare-simple-arrays ((test c-types-test) :run nil)
+  (assert-cteqp (c-type ([] int 10))
+		(make-array-type (make-simple-type "int") (list 10))))
+
+(def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil)
+  (assert-cteqp (c-type ([] int 10 4))
+		(c-type ([] ([] int 4) 10))))
+
+(def-test-method compare-multiarrays ((test c-types-test) :run nil)
+  (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8))
+		(c-type ([] ([] ([] int 6) 9 8 7) 10))))
+
+(def-test-method bad-compare-multiarrays ((test c-types-test) :run nil)
+  (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8))
+		    (c-type ([] ([] ([] int 6) 9 8 5) 10))))
+
+(def-test-method compare-misshaped ((test c-types-test) :run nil)
+  (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8))
+		    (c-type ([] ([] ([] int 6) 9 8 7) 10))))
+
+(def-test-method print-array ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo"
+		   "int foo[10][9][8][7][6]"))
+
+(def-test-method print-array-abs ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil
+		   "int[10][9][8][7][6]"))
+
+(def-test-method print-array-of-pointers ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type ([] (* char))) nil "char *[]"))
+
+(def-test-method print-pointer-to-array ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]"))
+
+;;;--------------------------------------------------------------------------
+;;; Function types.
+
+(def-test-method compare-simple-functions ((test c-types-test) :run nil)
+  ;; Argument names don't matter.
+  (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
+		(make-function-type (make-simple-type "int")
+				    (list
+				     (make-argument "foo"
+						    (make-simple-type "int"))
+				     (make-argument "bar"
+						    (c-type double))))))
+
+(def-test-method build-argument-tail ((test c-types-test) :run nil)
+  (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
+		(c-type (fun int ("foo" int)
+			     . (list (make-argument "bar"
+						    (c-type double)))))))
+
+(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
+  (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
+		    (c-type (fun int ("y" int) ("z" double)))))
+
+(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
+  (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
+		    (c-type (fun int ("y" int) ("z" double)))))
+
+(def-test-method print-signal ((test c-types-test) :run nil)
+  (assert-pp-ctype (c-type (fun (* (fun int (nil int)))
+				("signo" int)
+				("handler" (* (fun int (nil int))))))
+		  "signal"
+		  "int (*signal(int signo, int (*handler)(int)))(int)"))
+
+(def-test-method print-commentify ((test c-types-test) :run nil)
+  (assert-pp-ctype (commentify-function-type
+		    (c-type (fun int
+				 ("n" size-t)
+				 (nil string)
+				 ("format" const-string)
+				 :ellipsis)))
+		   "snprintf"
+		   (concatenate 'string
+				"int snprintf(size_t /*n*/, char *, "
+					     "const char */*format*/, "
+					     "...)")))
+
+(def-test-method commentify-non-recursive ((test c-types-test) :run nil)
+  ;; Also checks pretty-printing.
+  (assert-pp-ctype (commentify-function-type
+		    (c-type (fun int
+				 ("dirpath" const-string)
+				 ("fn" (* (fun int
+					       ("fpath" const-string)
+					       ("sb" (* (struct "stat"
+								:const)))
+					       ("typeflag" int))))
+				 ("nopenfd" int))))
+		   "ftw"
+		   (format nil "~
+int ftw(const char */*dirpath*/,
+        int (*/*fn*/)(const char *fpath,
+                      const struct stat *sb,
+                      int typeflag),
+        int /*nopenfd*/)")))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/test-codegen.lisp b/src/test-codegen.lisp
new file mode 100644
index 0000000..4f9aa05
--- /dev/null
+++ b/src/test-codegen.lisp
@@ -0,0 +1,121 @@
+;;; -*-lisp-*-
+;;;
+;;; Tests for code generator
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod-test)
+
+;;;--------------------------------------------------------------------------
+
+(defclass gcd-codegen-test (test-case)
+  (codegen))
+(add-test *sod-test-suite* (get-suite gcd-codegen-test))
+
+(defun make-gcd (codegen)
+
+  (codegen-push codegen)
+  (loop for (name init) in '(("aa" 1) ("bb" 0))
+	do (ensure-var codegen name (c-type int) init))
+  (codegen-push codegen)
+  (with-temporary-var (codegen r (c-type int))
+    (emit-inst codegen(make-set-inst r "u%v"))
+    (with-temporary-var (codegen q (c-type int))
+      (emit-inst codegen (make-set-inst q "u/v"))
+      (with-temporary-var (codegen a (c-type int))
+	(emit-insts codegen
+		    (list (make-set-inst a "aa")
+			  (make-set-inst "aa" "bb")
+			  (make-set-inst "bb"
+					 (format nil "~A - ~A*bb" a q))))))
+    (emit-insts codegen (list (make-set-inst "u" "v")
+			      (make-set-inst "v" r))))
+  (emit-inst codegen (make-while-inst "v" (codegen-pop-block codegen)))
+  (emit-inst codegen (make-if-inst "a" (make-set-inst "*a" "aa") nil))
+  (deliver-expr codegen :return "u")
+  (codegen-pop-function codegen "gcd"
+			(c-type (fun int
+				     ("u" int)
+				     ("v" int)
+				     ("a" (* int)))))
+
+  (codegen-push codegen)
+  (loop for (name init) in '(("u" "atoi(argv[1])")
+			     ("v" "atoi(argv[2])")
+			     ("a"))
+	do (ensure-var codegen name (c-type int) init))
+  (ensure-var codegen "g" (c-type int)
+	      (make-call-inst "gcd" (list "u" "v" "&a")))
+  (emit-inst codegen (make-expr-inst
+		      (make-call-inst "printf"
+				      (list "\"%d*%d == %d (mod %d)\\n\""
+					    "a" "u" "g" "v"))))
+  (deliver-expr codegen :return 0)
+  (codegen-pop-function codegen "main"
+			(c-type (fun int
+				     ("argc" int)
+				     ("argv" ([] string))))))
+
+(defmethod set-up ((test gcd-codegen-test))
+  (with-slots (codegen) test
+    (setf codegen (make-instance 'codegen))
+    (make-gcd codegen)))
+
+(def-test-method check-output ((test gcd-codegen-test) :run nil)
+  (assert-princ (codegen-functions (slot-value test 'codegen))
+		"(static int gcd(int u, int v, int *a)
+ {
+   int aa = 1;
+   int bb = 0;
+
+   while (v) {
+     int sod__v0;
+     int sod__v1;
+     int sod__v2;
+
+     sod__v0 = u%v;
+     sod__v1 = u/v;
+     sod__v2 = aa;
+     aa = bb;
+     bb = sod__v2 - sod__v1*bb;
+     u = v;
+     v = sod__v0;
+   }
+   if (a) *a = aa;
+   return (u);
+ }
+
+
+ static int main(int argc, char *argv[])
+ {
+   int u = atoi(argv[1]);
+   int v = atoi(argv[2]);
+   int a;
+   int g = gcd(u, v, &a);
+
+   printf(\"%d*%d == %d (mod %d)\\n\", a, u, g, v);
+   return (0);
+ }
+
+ )"))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/utilities.lisp b/src/utilities.lisp
new file mode 100644
index 0000000..15f9091
--- /dev/null
+++ b/src/utilities.lisp
@@ -0,0 +1,690 @@
+;;; -*-lisp-*-
+;;;
+;;; Various handy utilities
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD 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.
+;;;
+;;; SOD 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 SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:sod-utilities
+  (:use #:common-lisp
+
+	;; MOP from somewhere.
+	#+sbcl #:sb-mop
+	#+(or cmu clisp) #:mop
+	#+ecl #:clos))
+
+(cl:in-package #:sod-utilities)
+
+;;;--------------------------------------------------------------------------
+;;; Macro hacks.
+
+(export 'with-gensyms)
+(defmacro with-gensyms ((&rest binds) &body body)
+  "Evaluate BODY with variables bound to fresh symbols.
+
+   The BINDS are a list of entries (VAR [NAME]), and a singleton list can be
+   replaced by just a symbol; each VAR is bound to a fresh symbol generated
+   by (gensym NAME), where NAME defaults to the symbol-name of VAR."
+  `(let (,@(mapcar (lambda (bind)
+		     (multiple-value-bind (var name)
+			 (if (atom bind)
+			     (values bind (concatenate 'string
+					   (symbol-name bind) "-"))
+			     (destructuring-bind
+				 (var &optional
+				      (name (concatenate 'string
+					     (symbol-name var) "-")))
+				 bind
+			       (values var name)))
+		       `(,var (gensym ,name))))
+		   binds))
+     ,@body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun strip-quote (form)
+    "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO.
+
+   If FORM is a symbol whose constant value is `nil' then return `nil'.
+   Otherwise return FORM unchanged.  This makes it easier to inspect constant
+   things.  This is a utility for `once-only'."
+
+    (cond ((and (consp form)
+		(eq (car form) 'quote)
+		(cdr form)
+		(null (cddr form)))
+	   (let ((body (cadr form)))
+	     (if (or (not (or (consp body) (symbolp body)))
+		     (member body '(t nil))
+		     (keywordp body))
+		 body
+		 form)))
+	  ((and (symbolp form) (boundp form) (null (symbol-value form)))
+	   nil)
+	  (t
+	   form))))
+
+(export 'once-only)
+(defmacro once-only (binds &body body)
+  "Macro helper for preventing repeated evaluation.
+
+   The syntax is actually hairier than shown:
+
+	once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* )
+	  { FORM }*
+
+   So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list
+   can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR.
+   But before them you can have keyword arguments.  Only one is defined so
+   far.  See below for the crazy things that does.
+
+   The result of evaluating a ONCE-ONLY form is a form with the structure
+
+	(let ((#:GS1 VALUE-FORM1)
+	      ...
+	      (#:GSn VALUE-FORMn))
+	  STUFF)
+
+   where STUFF is the value of the BODY forms, as an implicit progn, in an
+   environment with the VARs bound to the corresponding gensyms.
+
+   As additional magic, if any of the VALUE-FORMs is actually constant (as
+   determined by inspection, and aided by `constantp' if an :environment is
+   supplied, then no gensym is constructed for it, and the VAR is bound
+   directly to the constant form.  Moreover, if the constant form looks like
+   (quote FOO) for a self-evaluating FOO then the outer layer of quoting is
+   stripped away."
+
+  ;; We need an extra layer of gensyms in our expansion: we'll want the
+  ;; expansion to examine the various VALUE-FORMs to find out whether they're
+  ;; constant without evaluating them repeatedly.  This also helps with
+  ;; another problem: we explicitly encourage the rebinding of a VAR
+  ;; (probably a macro argument) to a gensym which will be bound to the value
+  ;; of the form previously held in VAR itself -- so the gensym and value
+  ;; form must exist at the same time and we need two distinct variables.
+
+  (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-"))
+    (let ((env nil))
+
+      ;; First things first: let's pick up the keywords.
+      (loop
+	(unless (and binds (keywordp (car binds)))
+	  (return))
+	(ecase (pop binds)
+	  (:environment (setf env (pop binds)))))
+
+      ;; Now we'll investigate the bindings.  Turn each one into a list (VAR
+      ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note
+      ;; above.
+      (let ((canon (mapcar (lambda (bind)
+			     (multiple-value-bind (var form)
+				 (if (atom bind)
+				     (values bind bind)
+				     (destructuring-bind
+					 (var &optional (form var)) bind
+				       (values var form)))
+			       (list var form
+				     (gensym (format nil "T-~A-"
+						     (symbol-name var))))))
+			   binds)))
+
+	`(let* (,@(and env `((,envvar ,env)))
+		(,lets nil)
+		,@(mapcar (lambda (bind)
+			    (destructuring-bind (var form temp) bind
+			      (declare (ignore var))
+			      `(,temp ,form)))
+			  canon)
+		,@(mapcar (lambda (bind)
+			    (destructuring-bind (var form temp) bind
+			      (declare (ignore form))
+			      `(,var
+				(cond ((constantp ,temp
+						  ,@(and env `(,envvar)))
+				       (strip-quote ,temp))
+				      ((symbolp ,temp)
+				       ,temp)
+				      (t
+				       (let ((,sym (gensym
+						    ,(concatenate 'string
+						      (symbol-name var)
+						      "-"))))
+					 (push (list ,sym ,temp) ,lets)
+					 ,sym))))))
+			  canon))
+	   (flet ((,bodyfunc () ,@body))
+	     (if ,lets
+		 `(let (,@(nreverse ,lets)) ,(,bodyfunc))
+		 (,bodyfunc))))))))
+
+(export 'parse-body)
+(defun parse-body (body)
+  "Parse the BODY into a docstring, declarations and the body forms.
+
+   These are returned as three lists, so that they can be spliced into a
+   macro expansion easily.  The declarations are consolidated into a single
+   `declare' form."
+  (let ((decls nil)
+	(doc nil))
+    (loop
+      (cond ((null body) (return))
+	    ((and (consp (car body)) (eq (caar body) 'declare))
+	     (setf decls (append decls (cdr (pop body)))))
+	    ((and (stringp (car body)) (not doc) (cdr body))
+	     (setf doc (pop body)))
+	    (t (return))))
+    (values (and doc (list doc))
+	    (and decls (list (cons 'declare decls)))
+	    body)))
+
+;;;--------------------------------------------------------------------------
+;;; Anaphorics.
+
+(export 'it)
+
+(export 'aif)
+(defmacro aif (cond cons &optional (alt nil altp))
+  "If COND is not nil, evaluate CONS with `it' bound to the value of COND.
+
+   Otherwise, if given, evaluate ALT; `it' isn't bound in ALT."
+  (once-only (cond)
+    `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt)))))
+
+(export 'awhen)
+(defmacro awhen (cond &body body)
+  "If COND, evaluate BODY as a progn with `it' bound to the value of COND."
+  `(let ((it ,cond)) (when it ,@body)))
+
+(export 'acond)
+(defmacro acond (&rest clauses &environment env)
+  "Like COND, but with `it' bound to the value of the condition.
+
+   Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is
+   non-nil then evaluate the FORMs with `it' bound to the non-nil value, and
+   return the value of the last FORM; if there are no FORMs, then return `it'
+   itself.  If the CONDITION is nil then continue with the next clause; if
+   all clauses evaluate to nil then the result is nil."
+  (labels ((walk (clauses)
+	     (if (null clauses)
+		 `nil
+		 (once-only (:environment env (cond (caar clauses)))
+		   (if (and (constantp cond)
+			    (if (and (consp cond) (eq (car cond) 'quote))
+				(cadr cond) cond))
+		       (if (cdar clauses)
+			   `(let ((it ,cond))
+			      (declare (ignorable it))
+			      ,@(cdar clauses))
+			   cond)
+		       `(if ,cond
+			    ,(if (cdar clauses)
+				 `(let ((it ,cond))
+				    (declare (ignorable it))
+				    ,@(cdar clauses))
+				 cond)
+			    ,(walk (cdr clauses))))))))
+    (walk clauses)))
+
+(export '(acase aecase atypecase aetypecase))
+(defmacro acase (value &body clauses)
+  `(let ((it ,value)) (case it ,@clauses)))
+(defmacro aecase (value &body clauses)
+  `(let ((it ,value)) (ecase it ,@clauses)))
+(defmacro atypecase (value &body clauses)
+  `(let ((it ,value)) (typecase it ,@clauses)))
+(defmacro aetypecase (value &body clauses)
+  `(let ((it ,value)) (etypecase it ,@clauses)))
+
+(export 'asetf)
+(defmacro asetf (&rest places-and-values &environment env)
+  "Anaphoric update of places.
+
+   The PLACES-AND-VALUES are alternating PLACEs and VALUEs.  Each VALUE is
+   evaluated with IT bound to the current value stored in the corresponding
+   PLACE."
+  `(progn ,@(loop for (place value) on places-and-values by #'cddr
+		  collect (multiple-value-bind
+			      (temps inits newtemps setform getform)
+			      (get-setf-expansion place env)
+			    `(let* (,@(mapcar #'list temps inits)
+				    (it ,getform))
+			       (multiple-value-bind ,newtemps ,value
+				 ,setform))))))
+
+;;;--------------------------------------------------------------------------
+;;; MOP hacks (not terribly demanding).
+
+(export '(copy-instance copy-instance-using-class))
+(defgeneric copy-instance-using-class (class instance &rest initargs)
+  (:documentation
+   "Metaobject protocol hook for `copy-instance'.")
+  (:method ((class standard-class) instance &rest initargs)
+    (let ((copy (allocate-instance class)))
+      (dolist (slot (class-slots class))
+	(let ((name (slot-definition-name slot)))
+	  (when (slot-boundp instance name)
+	    (setf (slot-value copy name) (slot-value instance name)))))
+      (apply #'shared-initialize copy nil initargs))))
+(defun copy-instance (object &rest initargs)
+  "Construct and return a copy of OBJECT.
+
+   The new object has the same class as OBJECT, and the same slot values
+   except where overridden by INITARGS."
+  (apply #'copy-instance-using-class (class-of object) object initargs))
+
+;;;--------------------------------------------------------------------------
+;;; List utilities.
+
+(export 'make-list-builder)
+(defun make-list-builder (&optional initial)
+  "Return a simple list builder."
+
+  ;; The `builder' is just a cons cell whose cdr will be the list that's
+  ;; wanted.  Effectively, then, we have a list that's one item longer than
+  ;; we actually want.  The car of this extra initial cons cell is always the
+  ;; last cons in the list -- which is now well defined because there's
+  ;; always at least one.
+
+  (let ((builder (cons nil initial)))
+    (setf (car builder) (last builder))
+    builder))
+
+(export 'lbuild-add)
+(defun lbuild-add (builder item)
+  "Add an ITEM to the end of a list BUILDER."
+  (let ((new (cons item nil)))
+    (setf (cdar builder) new
+	  (car builder) new))
+  builder)
+
+(export 'lbuild-add-list)
+(defun lbuild-add-list (builder list)
+  "Add a LIST to the end of a list BUILDER.  The LIST will be clobbered."
+  (when list
+    (setf (cdar builder) list
+	  (car builder) (last list)))
+  builder)
+
+(export 'lbuild-list)
+(defun lbuild-list (builder)
+  "Return the constructed list."
+  (cdr builder))
+
+(export 'mappend)
+(defun mappend (function list &rest more-lists)
+  "Like a nondestructive MAPCAN.
+
+   Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
+   and return the result of appending all of the resulting lists."
+  (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+
+(export '(inconsistent-merge-error merge-error-candidates))
+(define-condition inconsistent-merge-error (error)
+  ((candidates :initarg :candidates
+	       :reader merge-error-candidates))
+  (:documentation
+   "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
+  (:report (lambda (condition stream)
+	     (format stream "Merge inconsistency: failed to decide among ~A."
+		     (merge-error-candidates condition)))))
+
+(export 'merge-lists)
+(defun merge-lists (lists &key pick (test #'eql))
+  "Return a merge of the given LISTS.
+
+   The resulting LIST contains the items of the given lists, with duplicates
+   removed.  The order of the resulting list is consistent with the orders of
+   the input LISTS in the sense that if A precedes B in some input list then
+   A will also precede B in the output list.  If the lists aren't consistent
+   (e.g., some list contains A followed by B, and another contains B followed
+   by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
+
+   Item equality is determined by TEST.
+
+   If there is an ambiguity at any point -- i.e., a choice between two or
+   more possible next items to emit -- then PICK is called to arbitrate.
+   PICK is called with two arguments: the list of candidate next items, and
+   the current output list.  It should return one of the candidate items.  If
+   PICK is omitted then an arbitrary choice is made.
+
+   The primary use of this function is in computing class precedence lists.
+   By building the input lists and selecting the PICK function appropriately,
+   a variety of different CPL algorithms can be implemented."
+
+  (do* ((lb (make-list-builder)))
+       ((null lists) (lbuild-list lb))
+
+    ;; The candidate items are the ones at the front of the input lists.
+    ;; Gather them up, removing duplicates.  If a candidate is somewhere in
+    ;; one of the other lists other than at the front then we reject it.  If
+    ;; we've just rejected everything, then we can make no more progress and
+    ;; the input lists were inconsistent.
+    (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
+	   (leasts (remove-if (lambda (item)
+				(some (lambda (list)
+					(member item (cdr list) :test test))
+				      lists))
+			      candidates))
+	   (winner (cond ((null leasts)
+			  (error 'inconsistent-merge-error
+				 :candidates candidates))
+			 ((null (cdr leasts))
+			  (car leasts))
+			 (pick
+			  (funcall pick leasts (lbuild-list lb)))
+			 (t (car leasts)))))
+
+      ;; Check that the PICK function isn't conning us.
+      (assert (member winner leasts :test test))
+
+      ;; Update the output list and remove the winning item from the input
+      ;; lists.  We know that it must be at the front of each input list
+      ;; containing it.  At this point, we discard input lists entirely when
+      ;; they run out of entries.  The loop ends when there are no more input
+      ;; lists left, i.e., when we've munched all of the input items.
+      (lbuild-add lb winner)
+      (setf lists (delete nil (mapcar (lambda (list)
+					(if (funcall test winner (car list))
+					    (cdr list)
+					    list))
+				      lists))))))
+
+(export 'categorize)
+(defmacro categorize ((itemvar items &key bind) categories &body body)
+  "Categorize ITEMS into lists and invoke BODY.
+
+   The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
+   will contain the current item.  The BIND argument is a list of LET*-like
+   clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
+   PREDICATE).
+
+   The behaviour of the macro is as follows.  ITEMVAR is assigned (not
+   bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
+   CATEGORIES list are evaluated in turn, in an environment containing
+   ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
+   At this point, the item is assigned to the category named by the
+   corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
+   error is signalled; a PREDICATE consisting only of T will (of course)
+   match anything; it is detected specially so as to avoid compiler warnings.
+
+   Once all of the ITEMS have been categorized in this fashion, the BODY is
+   evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
+   variable named after that symbol will be bound in the BODY's environment
+   to a list of the items in that category, in the same order in which they
+   were found in the list ITEMS.  The final values of the macro are the final
+   values of the BODY."
+
+  (let* ((cat-names (mapcar #'car categories))
+	 (cat-match-forms (mapcar #'cadr categories))
+	 (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string
+						   (symbol-name name) "-")))
+			   cat-names))
+	 (items-var (gensym "ITEMS-")))
+    `(let ((,items-var ,items)
+	   ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
+       (dolist (,itemvar ,items-var)
+	 (let* ,bind
+	   (cond ,@(mapcar (lambda (cat-match-form cat-var)
+			     `(,cat-match-form
+			       (push ,itemvar ,cat-var)))
+			   cat-match-forms cat-vars)
+		 ,@(and (not (member t cat-match-forms))
+			`((t (error "Failed to categorize ~A" ,itemvar)))))))
+       (let ,(mapcar (lambda (name var)
+		       `(,name (nreverse ,var)))
+		     cat-names cat-vars)
+	 ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Strings and characters.
+
+(export 'frob-identifier)
+(defun frob-identifier (string &key (swap-case t) (swap-hyphen t))
+  "Twiddles the case of STRING.
+
+   If all the letters in STRING are uppercase, and SWAP-CASE is true, then
+   switch them to lowercase; if they're all lowercase then switch them to
+   uppercase.  If there's a mix then leave them all alone.  At the same time,
+   if there are underscores but no hyphens, and SWAP-HYPHEN is true, then
+   switch them to hyphens, if there are hyphens and no underscores, switch
+   them underscores, and if there are both then leave them alone.
+
+   This is an invertible transformation, which turns vaguely plausible Lisp
+   names into vaguely plausible C names and vice versa.  Lisp names with
+   `funny characters' like stars and percent signs won't be any use, of
+   course."
+
+  ;; Work out what kind of a job we've got to do.  Gather flags: bit 0 means
+  ;; there are upper-case letters; bit 1 means there are lower-case letters;
+  ;; bit 2 means there are hyphens; bit 3 means there are underscores.
+  ;;
+  ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set
+  ;; if we have to frob case; bit 3 is set if we have to swap hyphens and
+  ;; underscores.  So use this to select functions which do bits of the
+  ;; mapping, and then compose them together.
+  (let* ((flags (reduce (lambda (state ch)
+			  (logior state
+				  (cond ((upper-case-p ch) 1)
+					((lower-case-p ch) 2)
+					((char= ch #\-) 4)
+					((char= ch #\_) 8)
+					(t 0))))
+			string
+			:initial-value 0))
+	 (mask (logxor flags (ash flags 1)))
+	 (letter (cond ((or (not swap-case) (not (logbitp 1 mask)))
+			(constantly nil))
+		       ((logbitp 0 flags)
+			(lambda (ch)
+			  (and (alpha-char-p ch) (char-downcase ch))))
+		       (t
+			(lambda (ch)
+			  (and (alpha-char-p ch) (char-upcase ch))))))
+	 (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen))
+			       (constantly nil))
+			      ((logbitp 2 flags)
+			       (lambda (ch) (and (char= ch #\-) #\_)))
+			      (t
+			       (lambda (ch) (and (char= ch #\_) #\-))))))
+
+    (if (logbitp 3 (logior mask (ash mask 2)))
+	(map 'string (lambda (ch)
+		       (or (funcall letter ch)
+			   (funcall uscore-hyphen ch)
+			   ch))
+	     string)
+	string)))
+
+(export 'whitespace-char-p)
+(declaim (inline whitespace-char-p))
+(defun whitespace-char-p (char)
+  "Returns whether CHAR is a whitespace character.
+
+   Whitespaceness is determined relative to the compile-time readtable, which
+   is probably good enough for most purposes."
+  (case char
+    (#.(loop for i below char-code-limit
+	     for ch = (code-char i)
+	     unless (with-input-from-string (in (string ch))
+		      (peek-char t in nil))
+	     collect ch) t)
+    (t nil)))
+
+(export 'update-position)
+(declaim (inline update-position))
+(defun update-position (char line column)
+  "Updates LINE and COLUMN appropriately for having read the character CHAR.
+
+   Returns the new LINE and COLUMN numbers."
+  (case char
+    ((#\newline #\vt #\page)
+     (values (1+ line) 0))
+    ((#\tab)
+     (values line (logandc2 (+ column 8) 7)))
+    (t
+     (values line (1+ column)))))
+
+(export 'backtrack-position)
+(declaim (inline backtrack-position))
+(defun backtrack-position (char line column)
+  "Updates LINE and COLUMN appropriately for having unread CHAR.
+
+   Well, actually an approximation for it; it will likely be wrong if the
+   last character was a tab.  But when the character is read again, it will
+   be correct."
+
+  ;; This isn't perfect: if the character doesn't actually match what was
+  ;; really read then it might not actually be possible: for example, if we
+  ;; push back a newline while in the middle of a line, or a tab while not at
+  ;; a tab stop.  In that case, we'll just lose, but hopefully not too badly.
+  (case char
+
+    ;; In the absence of better ideas, I'll set the column number to zero.
+    ;; This is almost certainly wrong, but with a little luck nobody will ask
+    ;; and it'll be all right soon.
+    ((#\newline #\vt #\page) (values (1- line) 0))
+
+    ;; Winding back a single space is sufficient.  If the position is
+    ;; currently on a tab stop then it'll advance back here next time.  If
+    ;; not, we're going to lose anyway because the previous character
+    ;; certainly couldn't have been a tab.
+    (#\tab (values line (1- column)))
+
+    ;; Anything else: just decrement the column and cross fingers.
+    (t (values line (1- column)))))
+
+;;;--------------------------------------------------------------------------
+;;; Functions.
+
+(export 'compose)
+(defun compose (function &rest more-functions)
+  "Composition of functions.  Functions are applied left-to-right.
+
+   This is the reverse order of the usual mathematical notation, but I find
+   it easier to read.  It's also slightly easier to work with in programs."
+  (labels ((compose1 (func-a func-b)
+	     (lambda (&rest args)
+	       (multiple-value-call func-b (apply func-a args)))))
+    (reduce #'compose1 more-functions :initial-value function)))
+
+;;;--------------------------------------------------------------------------
+;;; Symbols.
+
+(export 'symbolicate)
+(defun symbolicate (&rest symbols)
+  "Return a symbol named after the concatenation of the names of the SYMBOLS.
+
+   The symbol is interned in the current *PACKAGE*.  Trad."
+  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
+
+;;;--------------------------------------------------------------------------
+;;; Object printing.
+
+(export 'maybe-print-unreadable-object)
+(defmacro maybe-print-unreadable-object
+    ((object stream &rest args) &body body)
+  "Print helper for usually-unreadable objects.
+
+   If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
+   Otherwise just print using BODY."
+  (with-gensyms (print)
+    `(flet ((,print () ,@body))
+       (if *print-escape*
+	   (print-unreadable-object (,object ,stream ,@args)
+	     (,print))
+	   (,print)))))
+
+;;;--------------------------------------------------------------------------
+;;; Iteration macros.
+
+(export 'dosequence)
+(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
+		      &body body
+		      &environment env)
+  "Macro for iterating over general sequences.
+
+   Iterates over a (sub)sequence SEQ, delimited by START and END (which are
+   evaluated).  For each item of SEQ, BODY is invoked with VAR bound to the
+   item, and INDEXVAR (if requested) bound to the item's index.  (Note that
+   this is different from most iteration constructs in Common Lisp, which
+   work by mutating the variable.)
+
+   The loop is surrounded by an anonymous BLOCK and the loop body forms an
+   implicit TAGBODY, as is usual.  There is no result-form, however."
+
+  (once-only (:environment env seq start end)
+    (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
+
+      (flet ((loopguts (indexp listp endvar)
+	       ;; Build a DO-loop to do what we want.
+	       (let* ((do-vars nil)
+		      (end-condition (if endvar
+					 `(>= ,ivar ,endvar)
+					 `(endp ,seq)))
+		      (item (if listp
+				`(car ,seq)
+				`(aref ,seq ,ivar)))
+		      (body-call `(,bodyfunc ,item)))
+		 (when listp
+		   (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+			 do-vars))
+		 (when indexp
+		   (push `(,ivar ,start (1+ ,ivar)) do-vars))
+		 (when indexvar
+		   (setf body-call (append body-call (list ivar))))
+		 `(do ,do-vars (,end-condition) ,body-call))))
+
+	`(block nil
+	   (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+		    (tagbody ,@body)))
+	       (etypecase ,seq
+		 (vector
+		  (let ((,endvar (or ,end (length ,seq))))
+		    ,(loopguts t nil endvar)))
+		 (list
+		  (if ,end
+		      ,(loopguts t t end)
+		      ,(loopguts indexvar t nil))))))))))
+
+;;;--------------------------------------------------------------------------
+;;; CLOS hacking.
+
+(export 'default-slot)
+(defmacro default-slot ((instance slot &optional (slot-names t))
+			  &body value
+			  &environment env)
+  "If INSTANCE's slot named SLOT is unbound, set it to VALUE.
+
+   Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we
+   obey the `shared-initialize' protocol).  SLOT-NAMES defaults to `t', so
+   you can use it in `initialize-instance' or similar without ill effects.
+   Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
+   evaluated if it's needed."
+
+  (once-only (:environment env instance slot slot-names)
+    `(when ,(if (eq slot-names t)
+		  `(not (slot-boundp ,instance ,slot))
+		  `(and (not (slot-boundp ,instance ,slot))
+			(or (eq ,slot-names t)
+			    (member ,slot ,slot-names))))
+       (setf (slot-value ,instance ,slot)
+	     (progn ,@value)))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/chimaera.sod b/test/chimaera.sod
similarity index 80%
rename from chimaera.sod
rename to test/chimaera.sod
index d5507f8..cc56236 100644
--- a/chimaera.sod
+++ b/test/chimaera.sod
@@ -12,8 +12,6 @@ code h : includes {
 #include "sod.h"
 }
 
-lisp (write-line "Hello, world!") ;
-
 [nick = nml, link = SodObject]
 class Animal : SodObject {
   int tickles = 0;
@@ -26,12 +24,12 @@ class Animal : SodObject {
 
 class Lion : Animal {
   void bite(void) { puts("Munch!"); }
-  void nml.tickle(void) { me->_vt.bite(me); }
+  void nml.tickle(void) { me->_vt.lion.bite(me); }
 }
 
 class Goat : Animal {
   void butt(void) { puts("Bonk!"); }
-  void nml.tickle(void) { me->_vt.butt(me); }
+  void nml.tickle(void) { me->_vt.goat.butt(me); }
 }
 
 class Serpent : Animal {
@@ -39,9 +37,9 @@ class Serpent : Animal {
   void bite(void) { puts("Nom!"); }
   void nml.tickle(void) {
     if (SERPENT__CONV_NML(me)->nml.tickles > 2)
-      me->_vt.bite();
+      me->_vt.serpent.bite();
     else
-      me->_vt.hiss();
+      me->_vt.serpent.hiss();
   }
 }
 
diff --git a/utilities.lisp b/utilities.lisp
deleted file mode 100644
index 7e9e092..0000000
--- a/utilities.lisp
+++ /dev/null
@@ -1,411 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Various handy utilities
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD 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.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; List utilities.
-
-(defun mappend (function list &rest more-lists)
-  "Like a nondestructive MAPCAN.
-
-   Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
-   and return the result of appending all of the resulting lists."
-  (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
-
-(define-condition inconsistent-merge-error (error)
-  ((candidates :initarg :candidates
-	       :reader merge-error-candidates))
-  (:documentation
-   "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
-  (:report (lambda (condition stream)
-	     (format stream "Merge inconsistency: failed to decide among ~A."
-		     (merge-error-candidates condition)))))
-
-(defun merge-lists (lists &key pick (test #'eql))
-  "Return a merge of the given LISTS.
-
-   The resulting LIST contains the items of the given lists, with duplicates
-   removed.  The order of the resulting list is consistent with the orders of
-   the input LISTS in the sense that if A precedes B in some input list then
-   A will also precede B in the output list.  If the lists aren't consistent
-   (e.g., some list contains A followed by B, and another contains B followed
-   by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
-
-   Item equality is determined by TEST.
-
-   If there is an ambiguity at any point -- i.e., a choice between two or
-   more possible next items to emit -- then PICK is called to arbitrate.
-   PICK is called with two arguments: the list of candidate next items, and
-   the current output list.  It should return one of the candidate items.  If
-   PICK is omitted then an arbitrary choice is made.
-
-   The primary use of this function is in computing class precedence lists.
-   By building the input lists and selecting the PICK function appropriately,
-   a variety of different CPL algorithms can be implemented."
-
-  ;; In this loop, TAIL points to the last cons cell in the list.  This way
-  ;; we can build the list up forwards, so as not to make the PICK function
-  ;; interface be weird.  HEAD is a dummy cons cell inserted before the list,
-  ;; which gives TAIL something to point to initially.  (If we had locatives,
-  ;; I'd have TAIL point to the thing holding the final NIL, but we haven't;
-  ;; instead, it points to the cons cell whose cdr holds the final NIL --
-  ;; which means that we need to invent a cons cell if the list is empty.)
-  (do* ((head (cons nil nil))
-        (tail head))
-       ((null lists) (cdr head))
-
-    ;; The candidate items are the ones at the front of the input lists.
-    ;; Gather them up, removing duplicates.  If a candidate is somewhere in
-    ;; one of the other lists other than at the front then we reject it.  If
-    ;; we've just rejected everything, then we can make no more progress and
-    ;; the input lists were inconsistent.
-    (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
-           (leasts (remove-if (lambda (item)
-                                (some (lambda (list)
-                                        (member item (cdr list) :test test))
-                                      lists))
-                              candidates))
-           (winner (cond ((null leasts)
-                          (error 'inconsistent-merge-error
-				 :candidates candidates))
-                         ((null (cdr leasts))
-                          (car leasts))
-                         (pick
-                          (funcall pick leasts (cdr head)))
-			 (t (car leasts))))
-           (new (cons winner nil)))
-
-      ;; Check that the PICK function isn't conning us.
-      (assert (member winner leasts :test test))
-
-      ;; Update the output list and remove the winning item from the input
-      ;; lists.  We know that it must be at the front of each input list
-      ;; containing it.  At this point, we discard input lists entirely when
-      ;; they run out of entries.  The loop ends when there are no more input
-      ;; lists left, i.e., when we've munched all of the input items.
-      (setf (cdr tail) new
-            tail new
-            lists (delete nil (mapcar (lambda (list)
-					(if (funcall test winner (car list))
-					    (cdr list)
-					    list))
-				      lists))))))
-
-;;;--------------------------------------------------------------------------
-;;; Strings and characters.
-
-(defun frob-case (string)
-  "Twiddles the case of STRING.
-
-   If all the letters in STRING are uppercase, switch them to lowercase; if
-   they're all lowercase then switch them to uppercase.  If there's a mix
-   then leave them all alone.  This is an invertible transformation."
-
-  ;; Given that this operation is performed by the reader anyway, it's
-  ;; surprising that there isn't a Common Lisp function to do this built
-  ;; in.
-  (let ((flags (reduce (lambda (state ch)
-			 (logior state
-				 (cond ((upper-case-p ch) 1)
-				       ((lower-case-p ch) 2)
-				       (t 0))))
-		       string
-		       :initial-value 0)))
-
-    ;; Now FLAGS has bit 0 set if there are any upper-case characters, and
-    ;; bit 1 if there are lower-case.  So if it's zero there were no letters
-    ;; at all, and if it's three then there were both kinds; either way, we
-    ;; leave the string unchanged.  Otherwise we know how to flip the case.
-    (case flags
-      (1 (string-downcase string))
-      (2 (string-upcase string))
-      (t string))))
-
-(declaim (inline whitespace-char-p))
-(defun whitespace-char-p (char)
-  "Returns whether CHAR is a whitespace character.
-
-   Whitespaceness is determined relative to the compile-time readtable, which
-   is probably good enough for most purposes."
-  (case char
-    (#.(loop for i below char-code-limit
-	     for ch = (code-char i)
-	     unless (with-input-from-string (in (string ch))
-		      (peek-char t in nil))
-	     collect ch) t)
-    (t nil)))
-
-;;;--------------------------------------------------------------------------
-;;; Symbols.
-
-(defun symbolicate (&rest symbols)
-  "Return a symbol named after the concatenation of the names of the SYMBOLS.
-
-   The symbol is interned in the current *PACKAGE*.  Trad."
-  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
-
-;;;--------------------------------------------------------------------------
-;;; Object printing.
-
-(defmacro maybe-print-unreadable-object
-    ((object stream &rest args) &body body)
-  "Print helper for usually-unreadable objects.
-
-   If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
-   Otherwise just print using BODY."
-  (let ((func (gensym "PRINT")))
-    `(flet ((,func () ,@body))
-       (if *print-escape*
-	   (print-unreadable-object (,object ,stream ,@args)
-	     (,func))
-	   (,func)))))
-
-;;;--------------------------------------------------------------------------
-;;; Keyword arguments and lambda lists.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun transform-otherkeys-lambda-list (bvl)
-    "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
-
-   &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
-   (which must also be present); &ALLOW-OTHER-KEYS must not be present.
-
-   The behaviour is that
-
-     * the presence of non-listed keyword arguments is permitted, as if
-       &ALLOW-OTHER-KEYS had been provided, and
-
-     * a list of the keyword arguments other than the ones explicitly listed
-       is stored in the VAR.
-
-   The return value is a replacement BVL which binds the &OTHER-KEYS variable
-   as an &AUX parameter if necessary.
-
-   At least for now, fancy things like destructuring lambda-lists aren't
-   supported.  I suspect you'll get away with a specializing lambda-list."
-
-    (prog ((new-bvl nil)
-	   (rest-var nil)
-	   (keywords nil)
-	   (other-keys-var nil)
-	   (tail bvl))
-
-     find-rest
-       ;; Scan forwards until we find &REST or &KEY.  If we find the former,
-       ;; then remember the variable name.  If we find the latter first then
-       ;; there can't be a &REST argument, so we should invent one.  If we
-       ;; find neither then there's nothing to do.
-       (when (endp tail)
-	 (go ignore))
-       (let ((item (pop tail)))
-	 (push item new-bvl)
-	 (case item
-	   (&rest (when (endp tail)
-		    (error "Missing &REST argument name"))
-		  (setf rest-var (pop tail))
-		  (push rest-var new-bvl))
-	   (&aux (go ignore))
-	   (&key (unless rest-var
-		   (setf rest-var (gensym "REST"))
-		   (setf new-bvl (nconc (list '&key rest-var '&rest)
-					(cdr new-bvl))))
-		 (go scan-keywords)))
-	 (go find-rest))
-
-     scan-keywords
-       ;; Read keyword argument specs one-by-one.  For each one, stash it on
-       ;; the NEW-BVL list, and also parse it to extract the keyword, which
-       ;; we stash in KEYWORDS.  If we don't find &OTHER-KEYS then there's
-       ;; nothing for us to do.
-       (when (endp tail)
-	 (go ignore))
-       (let ((item (pop tail)))
-	 (push item new-bvl)
-	 (case item
-	   ((&aux &allow-other-keys) (go ignore))
-	   (&other-keys (go fix-tail)))
-	 (let ((keyword (if (symbolp item)
-			    (intern (symbol-name item) :keyword)
-			    (let ((var (car item)))
-			      (if (symbolp var)
-				  (intern (symbol-name var) :keyword)
-				  (car var))))))
-	   (push keyword keywords))
-	 (go scan-keywords))
-
-     fix-tail
-       ;; We found &OTHER-KEYS.  Pick out the &OTHER-KEYS var.
-       (pop new-bvl)
-       (when (endp tail)
-	 (error "Missing &OTHER-KEYS argument name"))
-       (setf other-keys-var (pop tail))
-       (push '&allow-other-keys new-bvl)
-
-       ;; There should be an &AUX next.  If there isn't, assume there isn't
-       ;; one and provide our own.  (This is safe as long as nobody else is
-       ;; expecting to plumb in lambda keywords too.)
-       (when (and (not (endp tail)) (eq (car tail) '&aux))
-	 (pop tail))
-       (push '&aux new-bvl)
-
-       ;; Add our shiny new &AUX argument.
-       (let ((keys-var (gensym "KEYS"))
-	     (list-var (gensym "LIST")))
-	 (push `(,other-keys-var (do ((,list-var nil)
-				      (,keys-var ,rest-var (cddr ,keys-var)))
-				     ((endp ,keys-var) (nreverse ,list-var))
-				   (unless (member (car ,keys-var)
-						   ',keywords)
-				     (setf ,list-var
-					   (cons (cadr ,keys-var)
-						 (cons (car ,keys-var)
-						       ,list-var))))))
-	       new-bvl))
-
-       ;; Done.
-       (return (nreconc new-bvl tail))
-
-     ignore
-       ;; Nothing to do.  Return the unmolested lambda-list.
-       (return bvl))))
-
-(defmacro lambda-otherkeys (bvl &body body)
-  "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
-  `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defun-otherkeys (name bvl &body body)
-  "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
-  `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defmethod-otherkeys (name &rest stuff)
-  "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
-  (do ((quals nil)
-       (stuff stuff (cdr stuff)))
-      ((listp (car stuff))
-       `(defmethod ,name ,@(nreverse quals)
-	    ,(transform-otherkeys-lambda-list (car stuff))
-	  ,@(cdr stuff)))
-    (push (car stuff) quals)))
-
-;;;--------------------------------------------------------------------------
-;;; Iteration macros.
-
-(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body)
-  "Macro for iterating over general sequences.
-
-   Iterates over a (sub)sequence SEQ, delimited by START and END (which are
-   evaluated).  For each item of SEQ, BODY is invoked with VAR bound to the
-   item, and INDEXVAR (if requested) bound to the item's index.  (Note that
-   this is different from most iteration constructs in Common Lisp, which
-   work by mutating the variable.)
-
-   The loop is surrounded by an anonymous BLOCK and the loop body forms an
-   implicit TAGBODY, as is usual.  There is no result-form, however."
-
-  (let ((seqvar (gensym "SEQ"))
-	(startvar (gensym "START"))
-	(endvar (gensym "END"))
-	(ivar (gensym "INDEX"))
-	(bodyfunc (gensym "BODY")))
-
-    (flet ((loopguts (indexp listp use-endp)
-	     ;; Build a DO-loop to do what we want.
-	     (let* ((do-vars nil)
-		    (end-condition (if use-endp
-				       `(endp ,seqvar)
-				       `(>= ,ivar ,endvar)))
-		    (item (if listp
-			      `(car ,seqvar)
-			      `(aref ,seqvar ,ivar)))
-		    (body-call `(,bodyfunc ,item)))
-	       (when listp
-		 (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar))
-		       do-vars))
-	       (when indexp
-		 (push `(,ivar ,startvar (1+ ,ivar)) do-vars))
-	       (when indexvar
-		 (setf body-call (append body-call (list ivar))))
-	       `(do ,do-vars (,end-condition) ,body-call))))
-
-      `(block nil
-	 (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
-		  (tagbody ,@body)))
-	   (let* ((,seqvar ,seq)
-		  (,startvar ,start))
-	     (etypecase ,seqvar
-	       (vector
-		(let ((,endvar (or ,end (length ,seqvar))))
-		  ,(loopguts t nil nil)))
-	       (list
-		(let ((,endvar ,end))
-		  (if ,endvar
-		      ,(loopguts t t nil)
-		      ,(loopguts indexvar t t)))))))))))
-
-;;;--------------------------------------------------------------------------
-;;; Meta-object hacking.
-
-(defgeneric copy-instance-using-class (class object &rest initargs)
-  (:documentation
-   "Return a copy of OBJECT.
-
-   OBJECT is assumed to be an instance of CLASS.  The copy returned is a
-   fresh instance whose slots have the same values as OBJECT except where
-   overridden by INITARGS.")
-
-  (:method ((class standard-class) object &rest initargs)
-    (let ((copy (apply #'allocate-instance class initargs)))
-      (dolist (slot (class-slots class))
-	(if (slot-boundp-using-class class object slot)
-	    (setf (slot-value-using-class class copy slot)
-		  (slot-value-using-class class object slot))
-	    (slot-makunbound-using-class class copy slot)))
-      (apply #'shared-initialize copy nil initargs)
-      copy)))
-
-(defun copy-instance (object &rest initargs)
-  "Return a copy of OBJECT.
-
-   The copy returned is a fresh instance whose slots have the same values as
-   OBJECT except where overridden by INITARGS."
-  (apply #'copy-instance-using-class (class-of object) object initargs))
-
-(defmacro default-slot ((instance slot) &body value &environment env)
-  "If INSTANCE's SLOT is unbound, set it to VALUE.
-
-   Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
-   evaluated if it's needed."
-
-  (let* ((quotep (constantp slot env))
-	 (instancevar (gensym "INSTANCE"))
-	 (slotvar (if quotep slot (gensym "SLOT"))))
-    `(let ((,instancevar ,instance)
-	   ,@(and (not quotep) `((,slotvar ,slot))))
-       (unless (slot-boundp ,instancevar ,slotvar)
-	 (setf (slot-value ,instancevar ,slotvar)
-	       (progn ,@value))))))
-
-;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0

