From ddee4bb174ad62e6a9d7ecb49d69867fb2b4742c Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sat, 17 Oct 2009 01:10:34 +0100
Subject: [PATCH] Lots more has happened.

  * all reserved words are now banished
  * an ilayout now consists of, for each chain, a union of the ichains
    for each class on the chain -- makes referring to the bit which
    represents a superclass instance trivial; not yet hacked the
    effective method codegen to cope
  * unnecessary ichain and vt structures (ones which are copies of a
    superclass's) are suppressed -- we use the original directly
    (must document the new chain-tail tracking stuff); only one new
    ichain and vtable structure per class (though we still need all-new
    vtmsgs for each superclass).
  * header file output is complete and functional
---
 builtin.lisp        |   6 +-
 class-builder.lisp  |  15 +----
 class-defs.lisp     |   6 +-
 class-finalize.lisp |  19 ++++++-
 class-layout.lisp   | 135 +++++++++++++++++++++++++++------------------
 class-output.lisp   | 151 +++++++++++++++++++++++++++++++++------------------
 examples.lisp       | 114 +++++++++++++++++++-------------------
 lex.lisp            |   8 +--
 methods.lisp        |  33 ++++++++---
 module-output.lisp  | 126 ++++++++++++++++++++++++++++++++++++++++++
 module.lisp         |  55 ++++++++++++-------
 output.lisp         |  20 +------
 parse-c-types.lisp  | 154 ++++++++++++++++++++++++++++++----------------------
 sod.c               |   4 +-
 sod.h               |   2 +-
 15 files changed, 542 insertions(+), 306 deletions(-)
 create mode 100644 module-output.lisp

diff --git a/builtin.lisp b/builtin.lisp
index 26d384b..21fa1e3 100644
--- a/builtin.lisp
+++ b/builtin.lisp
@@ -187,12 +187,12 @@ static const SodClass *const ~A__cpl[] = {
 	      ,(lambda (class)
 		 (format nil "sizeof(struct ~A)"
 			 (ilayout-struct-tag class))))
-    ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
+    ("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)))))
+    ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
 	    :prepare-function 'output-init-function
 	    :initializer-function
 	    ,(lambda (class)
@@ -300,7 +300,7 @@ static const SodClass *const ~A__cpl[] = {
 
 (defun make-builtin-module ()
   (let ((module (make-instance 'module
-			       :name (make-pathname :name "BUILTIN"
+			       :name (make-pathname :name "SOD-BASE"
 						    :type "SOD"
 						    :case :common)
 			       :state nil))
diff --git a/class-builder.lisp b/class-builder.lisp
index 2d77d70..7acbeae 100644
--- a/class-builder.lisp
+++ b/class-builder.lisp
@@ -461,7 +461,7 @@
     (check-method-type method message type)))
 
 ;;;--------------------------------------------------------------------------
-;;; Builder macro.
+;;; Builder macros.
 
 (defmacro define-sod-class (name (&rest superclasses) &body body)
   (let ((plist nil)
@@ -500,17 +500,6 @@
 						  ,@plist))))
 	 ,@body
 	 (finalize-sod-class ,classvar)
-	 (record-sod-class ,classvar)))))
-
-#+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))
+	 (add-to-module *module* ,classvar)))))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/class-defs.lisp b/class-defs.lisp
index 8640cf5..512505b 100644
--- a/class-defs.lisp
+++ b/class-defs.lisp
@@ -53,6 +53,8 @@
 
    (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)
@@ -504,10 +506,6 @@
 	    (t
 	     (setf (c-type-class type) class))))))
 
-(defun sod-class-type (class)
-  "Returns the C type corresponding to CLASS."
-  (find-class-type (sod-class-name class)))
-
 (define-c-type-syntax class (name &rest quals)
   "Returns a type object for the named class."
   (if quals
diff --git a/class-finalize.lisp b/class-finalize.lisp
index cf1ff73..fa8cc7d 100644
--- a/class-finalize.lisp
+++ b/class-finalize.lisp
@@ -169,7 +169,7 @@
 	  (error "Invalid message name `~A' on class `~A'"
 		 (sod-message-name message) class))))
 
-      ;; Check that the slots and messages have distinct names.
+    ;; 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)))
@@ -191,6 +191,19 @@
 	(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
@@ -226,6 +239,10 @@
 		     (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))
diff --git a/class-layout.lisp b/class-layout.lisp
index df068ed..a37852e 100644
--- a/class-layout.lisp
+++ b/class-layout.lisp
@@ -99,7 +99,9 @@
 (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))
+	       :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."))
 
@@ -114,6 +116,7 @@
 (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.
@@ -167,17 +170,21 @@
 				(sod-class-slots class))))
 
 (defmethod compute-ichain ((class sod-class) chain)
-  (let* ((head (car 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 head))
+					: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 head
+		   :chain-head chain-head
+		   :chain-tail chain-tail
 		   :body (cons vtable-pointer islots))))
 
 (defmethod compute-ilayout ((class sod-class))
@@ -245,9 +252,10 @@
 (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-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.
 
@@ -265,7 +273,7 @@
 	    (method-entry-effective-method entry)
 	    (sod-class-nickname (method-entry-chain-head entry)))))
 
-(defgeneric make-method-entry (effective-method chain-head)
+(defgeneric make-method-entry (effective-method chain-head chain-tail)
   (:documentation
    "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
 
@@ -280,12 +288,14 @@
    (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 objects for the messages
-   defined on CLASS, customized for calling from the chain headed by
+   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)
@@ -295,7 +305,7 @@
 	    (vtmsgs-class vtmsgs)
 	    (vtmsgs-entries vtmsgs))))
 
-(defgeneric compute-vtmsgs (class subclass chain-head)
+(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
   (:documentation
    "Return a VTMSGS object containing method entries for CLASS.
 
@@ -382,6 +392,8 @@
   ((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.
@@ -416,16 +428,18 @@
 (defmethod compute-vtmsgs
     ((class sod-class)
      (subclass sod-class)
-     (chain-head 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))))
+	     (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)))))
 
@@ -462,7 +476,7 @@
 (defvar *done-metaclass-chains*)
 (defvar *done-instance-chains*)
 
-(defgeneric compute-vtable-items (class super chain-head emit)
+(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
   (:documentation
    "Emit vtable items for a superclass of CLASS.
 
@@ -482,7 +496,7 @@
 
 (defmethod compute-vtable-items
     ((class sod-class) (super sod-class) (chain-head sod-class)
-     (emit function))
+     (chain-tail sod-class) (emit function))
 
   ;; If this class introduces new metaclass chains, then emit pointers to
   ;; them.
@@ -511,10 +525,52 @@
 
   ;; Finally, if there are interesting methods, emit those too.
   (when (sod-class-messages super)
-    (funcall emit (compute-vtmsgs super class chain-head))))
+    (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-if #'sod-class-direct-superclasses
+			       (mapcar (lambda (super)
+					 (sod-class-chain-head 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)
@@ -524,17 +580,11 @@
 
       ;; Find the root chain in the metaclass and write a pointer.
       (let* ((metaclass (sod-class-metaclass class))
-	     (metaclass-chains (sod-class-chains metaclass))
-	     (metaclass-chain-heads (mapcar (lambda (chain)
-					      (sod-class-chain-head
-					       (car chain)))
-					    metaclass-chains))
-	     (metaclass-root-chain (find-if-not
-				    #'sod-class-direct-superclasses
-				    metaclass-chain-heads)))
-	(emit (make-class-pointer class chain-head
-				  metaclass metaclass-root-chain))
-	(push metaclass-root-chain *done-metaclass-chains*))
+	     (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))
@@ -548,6 +598,7 @@
 	    (compute-vtable-items class
 				  sub
 				  chain-head
+				  chain-tail
 				  #'emit)
 	    (push sub done-superclasses))))
 
@@ -555,6 +606,7 @@
       (make-instance 'vtable
 		     :class class
 		     :chain-head chain-head
+		     :chain-tail chain-tail
 		     :body (nreverse items)))))
 
 (defgeneric compute-effective-methods (class)
@@ -582,7 +634,10 @@
   (format nil "~A__islots" class))
 
 (defun ichain-struct-tag (class chain-head)
-  (format nil "~A__ichain_~A" class(sod-class-nickname 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))
@@ -596,28 +651,4 @@
 (defun vtable-name (class chain-head)
   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 
-;;;--------------------------------------------------------------------------
-;;; Hacks for now.
-
-(defclass hacky-effective-method (effective-method)
-  ((direct-methods :initarg :direct-methods)))
-
-(defmethod print-object ((method hacky-effective-method) stream)
-  (if *print-escape*
-      (print-unreadable-object (method stream :type t)
-	(format stream "~A ~_~A ~_~:<~@{~S~^ ~_~}~:>"
-		(effective-method-message method)
-		(effective-method-class method)
-		(slot-value method 'direct-methods)))
-      (call-next-method)))
-
-(defmethod message-effective-method-class ((message sod-message))
-  'hacky-effective-method)
-
-(defmethod make-method-entry
-    ((method hacky-effective-method) (chain-head sod-class))
-  (make-instance 'method-entry
-		 :method method
-		 :chain-head chain-head))
-
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/class-output.lisp b/class-output.lisp
index 8fdcc82..dc07665 100644
--- a/class-output.lisp
+++ b/class-output.lisp
@@ -74,10 +74,11 @@
      (class :vtmsgs :start) (class :vtmsgs :end)
      (class :vtables :start) (class :vtables :end)
      (class :vtable-externs) (class :vtable-externs-after)
-     (class :direct-methods)
+     (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
@@ -87,7 +88,20 @@
     ((class :banner)
      (banner (format nil "Class ~A" class) stream))
     ((class :vtable-externs-after)
-     (terpri stream)))
+     (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 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)
@@ -95,16 +109,18 @@
       (add-output-hooks slot 'populate-islots sequencer))
     (sequence-output (stream sequencer)
       ((class :islots :start)
-       (format stream "struct ~A {~%" (islots-struct-tag class)))
+       (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)
-    (dolist (method (sod-class-methods class))
-      (add-output-hooks method :declare-direct-methods sequencer))
     (sequence-output (stream sequencer)
-      ((class :direct-methods)
+      ((class :methods :start)
+       (format stream "/* Direct methods. */~%"))
+      ((class :methods :end)
        (terpri stream))))
 
   ;; Provide upcast macros which do the right thing.
@@ -112,14 +128,15 @@
     (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 (concatenate 'string "#define "
-					 "~:@(~A__CONV_~A~)(p) ((~A *)"
-					 "~:[SOD_XCHAIN(~A, p)~;p~])~%")
+	     (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))))))))
+		     (sod-class-nickname super-head))))
+	 (terpri stream)))))
 
   ;; Generate vtmsgs structure for all superclasses.
   (add-output-hooks (car (sod-class-vtables class))
@@ -127,8 +144,9 @@
 		    sequencer))
 
 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)
-  (with-slots (ilayout vtables) class
+  (with-slots (ilayout vtables methods) class
     (add-output-hooks ilayout reason sequencer)
+    (dolist (method methods) (add-output-hooks method reason sequencer))
     (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
@@ -151,7 +169,9 @@
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)
-       (format stream "struct ~A {~%" (ilayout-struct-tag class)))
+       (format stream "/* Instance layout. */~%~
+		       struct ~A {~%"
+	       (ilayout-struct-tag class)))
       ((class :ilayout :end)
        (format stream "};~2%")))
     (dolist (ichain ichains)
@@ -159,38 +179,46 @@
 
 (defmethod add-output-hooks progn
     ((ichain ichain) (reason (eql :h)) sequencer)
-  (with-slots (class chain-head) ichain
-    (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 "struct ~A {~%" (ichain-struct-tag class chain-head)))
-      ((class :ichain chain-head :end)
-       (format stream "};~2%")))))
+  (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)
+		 (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)
-  (with-slots (class chain-head) ichain
+  (with-slots (class chain-head chain-tail) ichain
     (sequence-output (stream sequencer)
       ((class :ilayout :slots)
-       (format stream "  struct ~A ~A;~%"
-	       (ichain-struct-tag class chain-head)
+       (format stream "  union ~A ~A;~%"
+	       (ichain-union-tag chain-tail chain-head)
 	       (sod-class-nickname chain-head))))))
 
-(defmethod add-output-hooks progn ((ichain ichain) reason sequencer)
-  (with-slots (body) ichain
-    (dolist (item body) (add-output-hooks item reason sequencer))))
-
 (defmethod add-output-hooks progn
     ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
-  (with-slots (class chain-head) vtptr
+  (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 class chain-head))))))
+	       (vtable-struct-tag chain-tail chain-head))))))
 
 (defmethod add-output-hooks progn
     ((islots islots) (reason (eql :h)) sequencer)
@@ -209,26 +237,41 @@
     (dolist (item body) (add-output-hooks item reason sequencer))))
 
 (defmethod add-output-hooks 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 add-output-hooks progn
     ((vtable vtable) (reason (eql :h)) sequencer)
-  (with-slots (class chain-head) vtable
+  (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)
-      :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 "struct ~A {~%" (vtable-struct-tag class chain-head)))
-      ((class :vtable chain-head :end)
-       (format stream "};~2%"))
       ((class :vtable-externs)
        (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
-	       (vtable-struct-tag class chain-head)
+	       (vtable-struct-tag chain-tail chain-head)
 	       class (sod-class-nickname chain-head))))))
 
 (defmethod add-output-hooks progn
     ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
-  (with-slots (class subclass chain-head) vtmsgs
+  (with-slots (class subclass chain-head chain-tail) vtmsgs
     (sequence-output (stream sequencer)
       ((subclass :vtable chain-head :slots)
        (format stream "  struct ~A ~A;~%"
@@ -246,7 +289,10 @@
 		     (subclass :vtmsgs class :end)
 		     (subclass :vtmsgs :end))
 	((subclass :vtmsgs class :start)
-	 (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class)))
+	 (format stream "/* Messages protocol from class ~A */~%~
+			 struct ~A {~%"
+		 class
+		 (vtmsgs-struct-tag subclass class)))
 	((subclass :vtmsgs class :end)
 	 (format stream "};~2%"))))))
 
@@ -259,19 +305,16 @@
     (add-output-hooks method reason sequencer)))
 
 (defmethod add-output-hooks progn
-    ((method effective-method) (reason (eql 'populate-vtmsgs)) sequencer)
-  (let* ((message (effective-method-message method))
+    ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
+  (let* ((method (method-entry-effective-method entry))
+	 (message (effective-method-message method))
 	 (class (effective-method-class method))
-	 (class-type (find-class-type (sod-class-name class)))
-	 (raw-type (sod-message-type message))
-	 (type (c-type (* (fun (lisp (c-type-subtype raw-type))
-			       ("/*me*/" (* (lisp class-type)))
-			       . (commentify-argument-names
-				  (c-function-arguments raw-type)))))))
+	 (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 type stream (sod-message-name message)))
+	 (pprint-c-type commented-type stream (sod-message-name message)))
        (terpri stream)))))
 
 (defmethod add-output-hooks progn
diff --git a/examples.lisp b/examples.lisp
index 92489dd..cda6bcf 100644
--- a/examples.lisp
+++ b/examples.lisp
@@ -1,60 +1,60 @@
 (set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
 
-(progn
-  (clear-the-decks)
-
-  (define-sod-class "Animal" ("SodObject")
-    :nick 'nml
-    :link '|SodObject|
-    (slot "tickles" int)
-    (instance-initializer "nml" "tickles" :single #{ 0 })
-    (message "tickle" (fun void))
-    (method "nml" "tickle" (fun void) #{
-       me->tickles++;
-     }
-     :role :before)
-    (method "nml" "tickle" (fun void) #{ }))
-
-  (define-sod-class "Lion" ("Animal")
-    :nick 'lion
-    :link '|Animal|
-    (message "bite" (fun void))
-    (method "lion" "bite" (fun void) nil)
-    (method "nml" "tickle" (fun void) #{
-       me->_vt->lion.bite(me);
-       CALL_NEXT_METHOD;
-     }))
-
-  (define-sod-class "Goat" ("Animal")
-    :nick 'goat
-    (message "butt" (fun void))
-    (method "goat" "butt" (fun void) nil)
-    (method "nml" "tickle" (fun void) #{
-       me->_vt->goat.bite(me);
-       CALL_NEXT_METHOD;
-     }))
-
-  (define-sod-class "Serpent" ("Animal")
-    :nick 'serpent
-    (message "bite" (fun void))
-    (method "serpent" "bite" (fun void) nil)
-    (message "hiss" (fun void))
-    (method "serpent" "hiss" (fun void) nil)
-    (method "nml" "tickle" (fun void) #{
-       if (me->tickles < 3) me->_vt->hiss(me);
-       else me->_vt->bite(me);
-       CALL_NEXT_METHOD;
-     }))
-
-  (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
-    :nick 'sir
-    :link '|Lion|)
-
-  (defparameter *chimaera* (find-sod-class "Chimaera"))
-  (defparameter *emeth* (find "tickle"
-			      (sod-class-effective-methods *chimaera*)
-			      :key (lambda (method)
-				     (sod-message-name
-				      (effective-method-message method)))
-			      :test #'string=)))
+(defparameter *chimaera-module*
+  (define-module ("chimaera.sod")
+
+    (define-sod-class "Animal" ("SodObject")
+      :nick 'nml
+      :link '|SodObject|
+      (slot "tickles" int)
+      (instance-initializer "nml" "tickles" :single #{ 0 })
+      (message "tickle" (fun void))
+      (method "nml" "tickle" (fun void) #{
+	 me->tickles++;
+       }
+       :role :before)
+      (method "nml" "tickle" (fun void) #{ }))
+
+    (define-sod-class "Lion" ("Animal")
+      :nick 'lion
+      :link '|Animal|
+      (message "bite" (fun void))
+      (method "lion" "bite" (fun void) nil)
+      (method "nml" "tickle" (fun void) #{
+	 me->_vt->lion.bite(me);
+	 CALL_NEXT_METHOD;
+       }))
+
+    (define-sod-class "Goat" ("Animal")
+      :nick 'goat
+      (message "butt" (fun void))
+      (method "goat" "butt" (fun void) nil)
+      (method "nml" "tickle" (fun void) #{
+	 me->_vt->goat.bite(me);
+	 CALL_NEXT_METHOD;
+       }))
+
+    (define-sod-class "Serpent" ("Animal")
+      :nick 'serpent
+      (message "bite" (fun void))
+      (method "serpent" "bite" (fun void) nil)
+      (message "hiss" (fun void))
+      (method "serpent" "hiss" (fun void) nil)
+      (method "nml" "tickle" (fun void) #{
+	 if (me->tickles < 3) me->_vt->hiss(me);
+	 else me->_vt->bite(me);
+	 CALL_NEXT_METHOD;
+       }))
+
+    (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
+      :nick 'sir
+      :link '|Lion|)
+
+    (defparameter *chimaera* (find-sod-class "Chimaera"))
+    (defparameter *emeth* (find "tickle"
+				(sod-class-effective-methods *chimaera*)
+				:key (lambda (method)
+				       (sod-message-name
+					(effective-method-message method)))
+				:test #'string=))))
 
diff --git a/lex.lisp b/lex.lisp
index 1583b11..2d1c4de 100644
--- a/lex.lisp
+++ b/lex.lisp
@@ -231,8 +231,7 @@
    "struct" "union" "enum"))
 
 (defclass sod-lexer (lexer)
-  ((keywords :initarg :keywords :initform *sod-keywords*
-	     :type hash-table :reader lexer-keywords))
+  ()
   (:documentation
    "Lexical analyser for the SOD lanuage.
 
@@ -310,9 +309,8 @@
 					   (char= ch #\_))))
 			  (return))))))
 
-	    ;; Check to see whether we match any keywords.
-	    (multiple-value-bind (keyword foundp) (gethash id keywords)
-	      (return (values (if foundp keyword :id) id)))))
+	    ;; Done.
+	    (return (values :id id))))
 
 	 ;; Pick out numbers.  Currently only integers, but we support
 	 ;; multiple bases.
diff --git a/methods.lisp b/methods.lisp
index 0fbb3f0..67033da 100644
--- a/methods.lisp
+++ b/methods.lisp
@@ -42,7 +42,7 @@
    However, an :ELLIPSIS is replaced by an argument of type `va_list', named
    `sod__ap'."))
 
-(defgeneric direct-method-function-type (method)
+(defgeneric sod-method-function-type (method)
   (:documentation
    "Return the C function type for the direct method.
 
@@ -53,7 +53,7 @@
    prepends an appropriate `me' argument to the user-provided argument list.
    Fancy method classes may need to override this behaviour."))
 
-(defgeneric direct-method-next-method-type (method)
+(defgeneric sod-method-next-method-type (method)
   (:documentation
    "Return the C function type for the next-method trampoline.
 
@@ -64,10 +64,14 @@
    the right job.  Very fancy subclasses might need to do something
    different."))
 
-(defgeneric direct-method-function-name (method)
+(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.
 
@@ -162,7 +166,7 @@
 		       ("me" (* (class (sod-method-class method))))
 		       . (c-function-arguments type))))))
 
-(defmethod direct-method-function-name ((method basic-direct-method))
+(defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots (class role message) method
     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 	    (sod-class-nickname (sod-message-class message))
@@ -377,7 +381,7 @@
 
   (let* ((message (sod-method-message direct-method))
 	 (class (sod-method-class direct-method))
-	 (function (direct-method-function-name direct-method))
+	 (function (sod-method-function-name direct-method))
 	 (arguments (cons (format nil "(~A *)&sod__obj.~A" class
 				  (sod-class-nickname
 				   (sod-class-chain-head class)))
@@ -444,7 +448,7 @@
     (codegen-pop-function codegen (temporary-function)
 			  (c-type (fun (lisp return-type)
 				       ("me" (* (class super)))
-				       . arguments))))))
+				       . arguments)))))
 
 (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
   "Invoke a chain of delegating methods.
@@ -705,8 +709,19 @@
   (setf (slot-value method 'functions)
 	(compute-method-entry-functions method)))
 
-(defmethod make-method-entry
-    ((method basic-effective-method) (chain-head sod-class))
-  (make-instance 'method-entry :method method :chain-head chain-head))
+(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))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/module-output.lisp b/module-output.lisp
new file mode 100644
index 0000000..3ec6aee
--- /dev/null
+++ b/module-output.lisp
@@ -0,0 +1,126 @@
+;;; -*-lisp-*-
+;;;
+;;; Output handling for modules
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun banner (title output &key (blank-line-p t))
+  (format output "~&/*----- ~A ~A*/~%"
+	  title
+	  (make-string (- 77 2 5 1 (length title) 1 2)
+		       :initial-element #\-))
+  (when blank-line-p
+    (terpri output)))
+
+(defun guard-name (filename)
+  "Return a sensible inclusion guard name for FILENAME."
+  (with-output-to-string (guard)
+    (let* ((pathname (make-pathname :name (pathname-name filename)
+				    :type (pathname-type filename)))
+	   (name (namestring pathname))
+	   (uscore t))
+      (dotimes (i (length name))
+	(let ((ch (char name i)))
+	  (cond ((alphanumericp ch)
+		 (write-char (char-upcase ch) guard)
+		 (setf uscore nil))
+		((not uscore)
+		 (write-char #\_ guard)
+		 (setf uscore t))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Driving output.
+
+(defun guess-output-file (module type)
+  (merge-pathnames (make-pathname :type type :case :common)
+		   (module-name module)))
+
+(defun output-module (module reason stream)
+  (let ((sequencer (make-instance 'sequencer)))
+    (add-output-hooks module reason sequencer)
+    (invoke-sequencer-items sequencer stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Main output protocol implementation.
+
+(defmethod add-output-hooks progn ((module module) reason sequencer)
+  (dolist (item (module-items module))
+    (add-output-hooks item reason sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Header output.
+
+(defmethod add-output-hooks progn
+    ((module module) (reason (eql :h)) sequencer)
+  (sequence-output (stream sequencer)
+    :constraint (:prologue
+		 (:guard :start)
+		 (:typedefs :start) :typedefs (:typedefs :end)
+		 (:includes :start) :includes (:includes :end)
+		 (:classes :start) (:classes :end)
+		 (:guard :end)
+		 :epilogue)
+
+    (:prologue
+     (format stream "~
+/* -*-c-*-
+ *
+ * Header file generated by SOD for ~A
+ */~2%"
+	     (namestring (module-name module))))
+
+    ((:guard :start)
+     (format stream "~
+#ifndef ~A
+#define ~:*~A
+
+#ifdef __cplusplus
+  extern \"C\" {
+#endif~2%"
+	     (or (get-property (module-pset module) :guard :id)
+		 (guard-name (or (stream-pathname stream)
+				 (guess-output-file module "H"))))))
+    ((:guard :end)
+     (banner "That's all, folks" stream)
+     (format stream "~
+#ifdef __cplusplus
+  }
+#endif
+
+#endif~%"))
+
+    ((:typedefs :start)
+     (banner "Forward type declarations" stream))
+    ((:typedefs :end)
+     (terpri stream))
+
+    ((:includes :start)
+     (banner "External header files" stream))
+    ((:includes :end)
+     (terpri stream))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/module.lisp b/module.lisp
index 36b2c85..5d05365 100644
--- a/module.lisp
+++ b/module.lisp
@@ -131,6 +131,30 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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.
 
@@ -152,26 +176,17 @@
 
   ;; Make a new module.  Be careful to remove the module from the map if we
   ;; didn't succeed in constructing it.
-  (let ((*module* (make-instance 'module
-				 :name pathname
-				 :state (file-location location)))
-	(*type-map* (make-hash-table :test #'equal)))
-    (module-import *builtin-module*)
-    (setf (gethash truename *module-map*) *module*)
-    (unwind-protect
-	 (with-open-file (f-stream pathname :direction :input)
-	   (let* ((*module* (make-instance 'module :name pathname))
-		  (pai-stream (make-instance 'position-aware-input-stream
-					     :stream f-stream
-					     :file pathname))
-		  (lexer (make-instance 'sod-lexer :stream pai-stream)))
-	     (with-default-error-location (lexer)
-	       (next-char lexer)
-	       (next-token lexer)
-	       (parse-module lexer *module*)
-	       (finalize-module *module*))))
-      (unless (eq (module-state *module*) t)
-	(remhash truename *module-map*)))))
+  (define-module (pathname :location location :truename truename)
+    (let ((*readtable* (copy-readtable)))
+      (with-open-file (f-stream pathname :direction :input)
+	(let* ((pai-stream (make-instance 'position-aware-input-stream
+					  :stream f-stream
+					  :file pathname))
+	       (lexer (make-instance 'sod-lexer :stream pai-stream)))
+	  (with-default-error-location (lexer)
+	    (next-char lexer)
+	    (next-token lexer)
+	    (parse-module lexer *module*)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Module parsing protocol.
diff --git a/output.lisp b/output.lisp
index 05be7f8..b0df32b 100644
--- a/output.lisp
+++ b/output.lisp
@@ -152,14 +152,6 @@
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
 
-(defun banner (title output &key (blank-line-p t))
-  (format output "~&~%/*----- ~A ~A*/~%"
-	  title
-	  (make-string (- 77 2 5 1 (length title) 1 2)
-		       :initial-element #\-))
-  (when blank-line-p
-    (terpri output)))
-
 ;;;--------------------------------------------------------------------------
 ;;; Header output.
 
@@ -191,17 +183,7 @@
 #endif~%"
 		(namestring (module-name module))
 		(or (getf (module-plist module) 'include-guard)
-		    (with-output-to-string (guard)
-		      (let ((name (namestring file))
-			    (uscore t))
-			(dotimes (i (length name))
-			  (let ((ch (char name i)))
-			    (cond ((alphanumericp ch)
-				   (write-char (char-upcase ch) guard)
-				   (setf uscore nil))
-				  ((not uscore)
-				   (write-char #\_ guard)
-				   (setf uscore t)))))))))
+		    ))
 
 	  ;; Forward declarations of all the structures and types.  Nothing
 	  ;; interesting gets said here; this is just so that the user code
diff --git a/parse-c-types.lisp b/parse-c-types.lisp
index d273045..3613965 100644
--- a/parse-c-types.lisp
+++ b/parse-c-types.lisp
@@ -45,13 +45,49 @@
 ;;; groups the other three kinds together and calls them all `type
 ;;; specifiers' (6.7.2).
 
+;; Let's not repeat ourselves.
+(macrolet ((define-declaration-specifiers (&rest defs)
+	     (let ((mappings nil)
+		   (deftypes nil)
+		   (hashvar (gensym "HASH"))
+		   (keyvar (gensym "KEY"))
+		   (valvar (gensym "VAL")))
+	       (dolist (def defs)
+		 (destructuring-bind (kind &rest clauses) def
+		   (let ((maps (mapcar (lambda (clause)
+					 (if (consp clause)
+					     clause
+					     (cons (string-downcase clause)
+						   clause)))
+				       clauses)))
+		     (push `(deftype ,(symbolicate 'decl- kind) ()
+			      '(member ,@(mapcar #'cdr maps)))
+			   deftypes)
+		     (setf mappings (nconc (remove-if-not #'car maps)
+					   mappings)))))
+	       `(progn
+		  ,@(nreverse deftypes)
+		  (defparameter *declspec-map*
+		    (let ((,hashvar (make-hash-table :test #'equal)))
+		      (mapc (lambda (,keyvar ,valvar)
+			      (setf (gethash ,keyvar ,hashvar) ,valvar))
+			    ',(mapcar #'car mappings)
+			    ',(mapcar #'cdr mappings))
+		      ,hashvar))))))
+  (define-declaration-specifiers
+    (type :char :int :float :double :void)
+    (size :short :long (nil . :long-long))
+    (sign :signed :unsigned)
+    (qualifier :const :restrict :volatile)
+    (tagged :enum :struct :union)))
+
 (defstruct (declspec
 	     (:predicate declspecp))
   "Represents a declaration specifier being built."
   (qualifiers nil :type list)
-  (sign nil :type (member nil :signed :unsigned))
-  (size nil :type (member nil :short :long :long-long))
-  (type nil :type (or (member nil :int :char :float :double :void) c-type)))
+  (sign nil :type (or decl-sign null))
+  (size nil :type (or decl-size null))
+  (type nil :type (or decl-type c-type null)))
 
 (defun check-declspec (spec)
   "Check that the declaration specifiers in SPEC are a valid combination.
@@ -204,71 +240,58 @@
 
 (defun declaration-specifier-p (lexer)
   "Answer whether the current token might be a declaration specifier."
-  (case (token-type lexer)
-    ((:const :volatile :restrict
-      :signed :unsigned
-      :short :long
-      :void :char :int :float :double
-      :enum :struct :union)
-     t)
-    (:id
-     (gethash (token-value lexer) *type-map*))
-    (t
-     nil)))
+  (and (eq (token-type lexer) :id)
+       (let ((id (token-value lexer)))
+	 (or (gethash id *declspec-map*)
+	     (gethash id *type-map*)))))
 
 (defun parse-c-type (lexer)
   "Parse declaration specifiers from LEXER and return a C-TYPE."
 
   (let ((spec (make-declspec))
-	(found-any nil))
-    (loop
-      (let ((tok (token-type lexer)))
-	(labels ((update (func value)
-		   (let ((new (funcall func spec value)))
-		     (cond (new (setf spec new))
-			   (t (cerror*
-	   "Invalid declaration specifier ~(~A~) after `~{~A~^ ~}' (ignored)"
-			       (format-token tok (token-value lexer))
-			       (declspec-keywords spec t))
-			      nil))))
-		 (tagged (class)
-		   (let ((kind tok))
-		     (setf tok (next-token lexer))
-		     (if (eql tok :id)
-			 (when (update #'update-declspec-type
-				       (make-instance
-					class
-					:tag (token-value lexer)))
-			   (setf found-any t))
-			 (cerror* "Expected ~(~A~) tag; found ~A"
-				  kind (format-token lexer))))))
-	  (case tok
-	    ((:const :volatile :restrict)
-	     (update #'update-declspec-qualifiers tok))
-	    ((:signed :unsigned)
-	     (when (update #'update-declspec-sign tok)
-	       (setf found-any t)))
-	    ((:short :long)
-	     (when (update #'update-declspec-size tok)
-	       (setf found-any t)))
-	    ((:void :char :int :float :double)
-	     (when (update #'update-declspec-type tok)
-	       (setf found-any t)))
-	    (:enum (tagged 'c-enum-type))
-	    (:struct (tagged 'c-struct-type))
-	    (:union (tagged 'c-union-type))
-	    (:id
-	     (let ((ty (gethash (token-value lexer) *type-map*)))
-	       (when (or found-any (not ty))
-		 (return))
-	       (when (update #'update-declspec-type ty)
-		 (setf found-any t))))
-	    (t
-	     (return))))
-	(setf tok (next-token lexer))))
-    (unless found-any
-      (cerror* "Missing type name (guessing at `int')"))
-    (declspec-c-type spec)))
+	(found-any nil)
+	tok)
+    (flet ((token (&optional (ty (next-token lexer)))
+	     (setf tok
+		   (or (and (eq ty :id)
+			    (gethash (token-value lexer) *declspec-map*))
+		       ty)))
+	   (update (func value)
+	     (let ((new (funcall func spec value)))
+	       (cond (new (setf spec new))
+		     (t (cerror* "Invalid declaration specifier ~(~A~) ~
+				  following `~{~A~^ ~}' (ignored)"
+				 (format-token tok (token-value lexer))
+				 (declspec-keywords spec t))
+			nil)))))
+      (token (token-type lexer))
+      (loop
+	(typecase tok
+	  (decl-qualifier (update #'update-declspec-qualifiers tok))
+	  (decl-sign (when (update #'update-declspec-sign tok)
+		       (setf found-any t)))
+	  (decl-size (when (update #'update-declspec-size tok)
+		       (setf found-any t)))
+	  (decl-type (when (update #'update-declspec-type tok)
+		       (setf found-any t)))
+	  (decl-tagged (let ((class (ecase tok
+				      (:enum 'c-enum-type)
+				      (:struct 'c-struct-type)
+				      (:union 'c-union-type))))
+			 (let ((tag (require-token lexer :id)))
+			   (when tag
+			     (update #'update-declspec-type
+				     (make-instance class :tag tag))))))
+	  ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*)))
+		       (when (or found-any (not ty))
+			 (return))
+		       (when (update #'update-declspec-type ty)
+			 (setf found-any t))))
+	  (t (return)))
+	(token))
+      (unless found-any
+	(cerror* "Missing type name (guessing at `int')"))
+      (declspec-c-type spec))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing declarators.
@@ -491,15 +514,14 @@
 (with-input-from-string (in "
 //  int stat(struct stat *st)
 //  void foo(void)
-//  int vsnprintf(size_t n, char *buf, va_list ap)
+  int vsnprintf(size_t n, char *buf, va_list ap)
 //  size_t size_t;
 //  int (*signal(int sig, int (*handler)(int s)))(int t)
 ")
   (let* ((stream (make-instance 'position-aware-input-stream
 				:file "<string>"
 				:stream in))
-	 (lex (make-instance 'sod-lexer :stream stream
-			     :keywords *sod-keywords*)))
+	 (lex (make-instance 'sod-lexer :stream stream)))
     (next-char lex)
     (next-token lex)
     (let ((ty (parse-c-type lex)))
diff --git a/sod.c b/sod.c
index ad20974..24a6429 100644
--- a/sod.c
+++ b/sod.c
@@ -26,7 +26,7 @@
 
 /*----- Header files ------------------------------------------------------*/
 
-#include <sod.h>
+#include "sod.h"
 
 /*----- Main code ---------------------------------------------------------*/
 
@@ -60,7 +60,7 @@ static const struct sod_chain *find_chain(const SodClass *sub,
    * and we're done.  Otherwise it isn't, and we lose.  We also lose if no
    * matching chain is found.
    */
-  for (chain = sub->cls.chains, lim = chain + sub->cls.n_chains;
+  for (chain = sub->cls.chains, limit = chain + sub->cls.n_chains;
        chain < limit; chain++) {
     if (chain->classes[0] != head)
       continue;
diff --git a/sod.h b/sod.h
index 9fa972d..cb56244 100644
--- a/sod.h
+++ b/sod.h
@@ -36,7 +36,7 @@
 #include <stdarg.h>
 #include <stddef.h>
 
-#include <sod-base.h>
+#include "sod-base.h"
 
 /*----- Data structures ---------------------------------------------------*/
 
-- 
2.11.0