From 1d8cc67a3f4ded443f5efc673a616883cbae9c50 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 24 Jul 2013 22:54:12 +0100
Subject: [PATCH] More WIP.

---
 src/.gitignore                       |    5 +
 src/class-layout-impl.lisp           |    3 +
 src/codegen-proto.lisp               |    5 +-
 src/dump-sod                         |    3 +
 src/frontend.lisp                    |   51 ++
 src/lexer-impl.lisp                  |    3 -
 src/lexer-proto.lisp                 |    3 +
 src/method-impl.lisp                 |    8 +
 src/module-proto.lisp                |    4 +-
 src/optparse.lisp                    | 1200 ++++++++++++++++++++++++++++++++++
 src/output-proto.lisp                |    3 +-
 src/package.lisp                     |    1 +
 src/parser/parser-expr-impl.lisp     |    2 +
 src/parser/parser-proto.lisp         |   16 +-
 src/parser/scanner-charbuf-impl.lisp |    9 +-
 src/parser/scanner-token-impl.lisp   |    1 +
 src/parser/streams-impl.lisp         |   12 +-
 src/pset-parse.lisp                  |    5 +-
 src/pset-proto.lisp                  |    1 +
 src/run-sod                          |    9 +
 src/sod.asd                          |   13 +-
 21 files changed, 1336 insertions(+), 21 deletions(-)
 create mode 100644 src/.gitignore
 create mode 100755 src/dump-sod
 create mode 100644 src/frontend.lisp
 create mode 100644 src/optparse.lisp
 create mode 100755 src/run-sod

diff --git a/src/.gitignore b/src/.gitignore
new file mode 100644
index 0000000..88c5233
--- /dev/null
+++ b/src/.gitignore
@@ -0,0 +1,5 @@
+*.fas
+*.fasl
+*.lib
+*.img
+sod
diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp
index 68c989b..3a5b5cd 100644
--- a/src/class-layout-impl.lisp
+++ b/src/class-layout-impl.lisp
@@ -130,6 +130,7 @@
 
 (defmethod slot-unbound
     (clos-class (class sod-class) (slot-name (eql 'effective-methods)))
+  (declare (ignore clos-class))
   (setf (slot-value class 'effective-methods)
 	(compute-effective-methods class)))
 
@@ -207,6 +208,7 @@
 
 (defmethod slot-unbound
     (clos-class (class sod-class) (slot-name (eql 'ilayout)))
+  (declare (ignore clos-class))
   (setf (slot-value class 'ilayout)
 	(compute-ilayout class)))
 
@@ -389,6 +391,7 @@
 
 (defmethod slot-unbound
     (clos-class (class sod-class) (slot-name (eql 'vtables)))
+  (declare (ignore clos-class))
   (setf (slot-value class 'vtables)
 	(compute-vtables class)))
 
diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 4b3b49d..4b38521 100644
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -41,6 +41,7 @@
    "Answer whether VAR is currently being used.  See `with-temporary-var'.")
   (:method (var)
     "Non-temporary variables are always in use."
+    (declare (ignore var))
     t))
 (defgeneric (setf var-in-use-p) (value var)
   (:documentation
@@ -107,7 +108,9 @@
    This isn't intended to be a particularly rigorous definition.  Its purpose
    is to allow code generators to make decisions about inlining or calling
    code fairly simply.")
-  (:method (inst) 1))
+  (:method (inst)
+    (declare (ignore inst))
+    1))
 
 ;; Instruction definition.
 
diff --git a/src/dump-sod b/src/dump-sod
new file mode 100755
index 0000000..d0bef2d
--- /dev/null
+++ b/src/dump-sod
@@ -0,0 +1,3 @@
+#! /bin/sh -ex
+
+cl-launch -o sod -d "$(pwd)/sod.img" -s sod +I -r sod:main "$@"
diff --git a/src/frontend.lisp b/src/frontend.lisp
new file mode 100644
index 0000000..b1fb0d9
--- /dev/null
+++ b/src/frontend.lisp
@@ -0,0 +1,51 @@
+;;; -*-lisp-*-
+;;;
+;;; User interface
+;;;
+;;; (c) 2013 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)
+
+;;;--------------------------------------------------------------------------
+;;; The main program.
+
+(export 'main)
+(defun main ()
+  (set-command-line-arguments)
+
+  (define-program
+    :help "Probably ought to write this."
+    :version "0.1.0"
+    :usage nil
+    :options (options
+	      (help-options :short-version #\V)
+	      "Crazy options"
+	      ))
+
+  (unless (option-parse-try
+	    (do-options ()
+	      (nil (rest)
+		(format t "My arguments are ~S~%" rest))))
+    (die-usage))
+  (exit))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/lexer-impl.lisp b/src/lexer-impl.lisp
index 6fc6fcc..ba1f7c1 100644
--- a/src/lexer-impl.lisp
+++ b/src/lexer-impl.lisp
@@ -39,9 +39,6 @@
 ;;;--------------------------------------------------------------------------
 ;;; Indicators and error messages.
 
-(defvar *indicator-map* (make-hash-table)
-  "Hash table mapping indicator objects to human-readable descriptions.")
-
 (defun show-char (stream char &optional colonp atsignp)
   "Format CHAR to STREAM in a readable way.
 
diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index af2e535..d2181e1 100644
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -40,6 +40,9 @@
 ;;;--------------------------------------------------------------------------
 ;;; Indicators and error messages.
 
+(defvar *indicator-map* (make-hash-table)
+  "Hash table mapping indicator objects to human-readable descriptions.")
+
 (export 'define-indicator)
 (defun define-indicator (indicator description)
   "Associate an INDICATOR with its textual DESCRIPTION.
diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index b74994f..b657b8b 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -46,6 +46,7 @@
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'argument-tail)))
+  (declare (ignore class))
   (let ((seq 0))
     (setf (slot-value message 'argument-tail)
 	  (mapcar (lambda (arg)
@@ -59,6 +60,7 @@
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'no-varargs-tail)))
+  (declare (ignore class))
   (setf (slot-value message 'no-varargs-tail)
 	(mapcar (lambda (arg)
 		  (if (eq arg :ellipsis)
@@ -125,6 +127,7 @@
 
 (defmethod slot-unbound
     (class (method basic-direct-method) (slot-name (eql 'function-type)))
+  (declare (ignore class))
   (let ((type (sod-method-type method)))
     (setf (slot-value method 'function-type)
 	  (c-type (fun (lisp (c-type-subtype type))
@@ -184,6 +187,7 @@
 (defmethod slot-unbound (class
 			 (method delegating-direct-method)
 			 (slot-name (eql 'next-method-type)))
+  (declare (ignore class))
   (let* ((message (sod-method-message method))
 	 (type (sod-message-type message)))
     (setf (slot-value method 'next-method-type)
@@ -194,6 +198,7 @@
 (defmethod slot-unbound (class
 			 (method delegating-direct-method)
 			 (slot-name (eql 'function-type)))
+  (declare (ignore class))
   (let* ((message (sod-method-message method))
 	 (type (sod-method-type method))
 	 (method-args (c-function-arguments type)))
@@ -238,6 +243,7 @@
 (defmethod slot-unbound (class
 			 (method basic-effective-method)
 			 (slot-name (eql 'basic-argument-names)))
+  (declare (ignore class))
   (let ((message (effective-method-message method)))
     (setf (slot-value method 'basic-argument-names)
 	  (subst *sod-master-ap* *sod-ap*
@@ -255,6 +261,7 @@
 
 (defmethod slot-unbound
     (class (method basic-effective-method) (slot-name (eql 'functions)))
+  (declare (ignore class))
   (setf (slot-value method 'functions)
 	(compute-method-entry-functions method)))
 
@@ -285,6 +292,7 @@
 
 (defmethod shared-initialize :after
     ((codegen method-codegen) slot-names &key)
+  (declare (ignore slot-names))
   (with-slots (message target) codegen
     (setf target
 	  (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
diff --git a/src/module-proto.lisp b/src/module-proto.lisp
index 28af7bd..cce9b86 100644
--- a/src/module-proto.lisp
+++ b/src/module-proto.lisp
@@ -118,7 +118,9 @@
 
    It's not usual to modify the current module.  Inserting things into the
    `*module-type-map*' is a good plan.")
-  (:method (object) nil))
+  (:method (object)
+    (declare (ignore object))
+    nil))
 
 (export 'add-to-module)
 (defgeneric add-to-module (module item)
diff --git a/src/optparse.lisp b/src/optparse.lisp
new file mode 100644
index 0000000..38a3ae4
--- /dev/null
+++ b/src/optparse.lisp
@@ -0,0 +1,1200 @@
+;;; -*-lisp-*-
+;;;
+;;; Option parser, standard issue
+;;;
+;;; (c) 2005 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 #:optparse
+  (:use #:common-lisp #:sod-utilities))
+
+(cl:in-package #:optparse)
+
+;;;--------------------------------------------------------------------------
+;;; Program environment things.
+
+(export 'exit)
+(defun exit (&optional (code 0) &key abrupt)
+  "End program, returning CODE to the caller."
+  (declare (type (unsigned-byte 32) code))
+  #+sbcl (sb-ext:exit :code code :abort abrupt)
+  #+cmu (if abrupt
+	    (unix::void-syscall ("_exit" c-call:int) code)
+	    (ext:quit code))
+  #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
+  #+ecl (ext:quit code)
+
+  #-(or sbcl cmu clisp ecl)
+  (progn
+    (unless (zerop code)
+      (format *error-output*
+	      "~&Exiting unsuccessfully with code ~D.~%" code))
+    (abort)))
+
+(export '(*program-name* *command-line*))
+(defvar *program-name* "<unknown>"
+  "Program name, as retrieved from the command line.")
+(defvar *command-line* nil
+  "A list of command-line arguments, including the program name.")
+
+(export 'set-command-line-arguments)
+(defun set-command-line-arguments ()
+  "Retrieve command-line arguments.
+
+   Set `*command-line*' and `*program-name*'."
+
+  (setf *command-line*
+	(or (when (member :cl-launch *features*)
+	      (let* ((cllpkg (find-package :cl-launch))
+		     (name (funcall (intern "GETENV" cllpkg)
+				    "CL_LAUNCH_FILE"))
+		     (args (symbol-value (intern "*ARGUMENTS*" cllpkg))))
+		(if name
+		    (cons name args)
+		    args)))
+	    #+sbcl sb-ext:*posix-argv*
+	    #+cmu ext:*command-line-strings*
+	    #+clisp (loop with argv = (ext:argv)
+			  for i from 7 below (length argv)
+			  collect (aref argv i))
+	    #+ecl (loop from i below (ext:argc) collect (ext:argv i))
+	    '("<unknown-script>"))
+
+	*program-name* (pathname-name (car *command-line*))))
+
+;;;--------------------------------------------------------------------------
+;;; Fancy conditionals.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun do-case2-like (kind vform clauses)
+    "Helper function for `case2' and `ecase2'."
+    (with-gensyms (scrutinee argument)
+      `(multiple-value-bind (,scrutinee ,argument) ,vform
+	 (declare (ignorable ,argument))
+	 (,kind ,scrutinee
+	   ,@(mapcar (lambda (clause)
+		       (destructuring-bind
+			   (cases (&optional varx vary) &rest forms)
+			   clause
+			 `(,cases
+			   ,@(if varx
+				 (list `(let ((,(or vary varx) ,argument)
+					      ,@(and vary
+						     `((,varx ,scrutinee))))
+					  ,@forms))
+				 forms))))
+		     clauses))))))
+
+(defmacro case2 (vform &body clauses)
+  "Switch based on the first value of a form, capturing the second value.
+
+   VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
+   The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+   standard `case' clause has the form (CASES FORMS...).  The `case2' form
+   evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+   order, just like `case'.  If there is a match, then the corresponding
+   FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+   the SCRUTINEE (where specified).  Note the bizarre defaulting behaviour:
+   ARGVAR is less optional than SCRUVAR."
+  (do-case2-like 'case vform clauses))
+
+(defmacro ecase2 (vform &body clauses)
+  "Like `case2', but signals an error if no clause matches the SCRUTINEE."
+  (do-case2-like 'ecase vform clauses))
+
+;;;--------------------------------------------------------------------------
+;;; Locatives.
+
+(export '(loc locp))
+(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
+  "Locative data type.  See `locf' and `ref'."
+  (reader nil :type function)
+  (writer nil :type function))
+
+(export 'locf)
+(defmacro locf (place &environment env)
+  "Slightly cheesy locatives.
+
+   (locf PLACE) returns an object which, using the `ref' function, can be
+   used to read or set the value of PLACE.  It's cheesy because it uses
+   closures rather than actually taking the address of something.  Also,
+   unlike Zetalisp, we don't overload `car' to do our dirty work."
+  (multiple-value-bind
+      (valtmps valforms newtmps setform getform)
+      (get-setf-expansion place env)
+    `(let* (,@(mapcar #'list valtmps valforms))
+       (make-loc (lambda () ,getform)
+		 (lambda (,@newtmps) ,setform)))))
+
+(export 'ref)
+(declaim (inline ref (setf ref)))
+(defun ref (loc)
+  "Fetch the value referred to by a locative."
+  (funcall (loc-reader loc)))
+(defun (setf ref) (new loc)
+  "Store a new value in the place referred to by a locative."
+  (funcall (loc-writer loc) new))
+
+(export 'with-locatives)
+(defmacro with-locatives (locs &body body)
+  "Evaluate BODY with implicit locatives.
+
+   LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
+   symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
+   defaults to SYM.  As an abbreviation for a common case, LOCS may be a
+   symbol instead of a list.
+
+   The BODY is evaluated in an environment where each SYM is a symbol macro
+   which expands to (ref LOC-EXPR) -- or, in fact, something similar which
+   doesn't break if LOC-EXPR has side-effects.  Thus, references, including
+   `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
+   Useful for covering over where something uses a locative."
+  (setf locs (mapcar (lambda (item)
+		       (cond ((atom item) (list item item))
+			     ((null (cdr item)) (list (car item) (car item)))
+			     (t item)))
+		     (if (listp locs) locs (list locs))))
+  (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
+	(ll (mapcar #'cadr locs))
+	(ss (mapcar #'car locs)))
+    `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
+       (symbol-macrolet (,@(mapcar (lambda (sym tmp)
+				     `(,sym (ref ,tmp))) ss tt))
+	 ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard error-reporting functions.
+
+(export 'moan)
+(defun moan (msg &rest args)
+  "Report an error message in the usual way."
+  (format *error-output* "~&~A: ~?~%" *program-name* msg args))
+
+(export 'die)
+(defun die (&rest args)
+  "Report an error message and exit."
+  (apply #'moan args)
+  (exit 1))
+
+;;;--------------------------------------------------------------------------
+;;; The main option parser.
+
+(export '*options*)
+(defvar *options* nil
+  "The default list of command-line options.")
+
+(export '(option optionp make-option
+	  opt-short-name opt-long-name opt-tag opt-negated-tag
+	  opt-arg-name opt-arg-optional-p opt-documentation))
+(defstruct (option
+	     (:predicate optionp)
+	     (:conc-name opt-)
+	     (:print-function
+	      (lambda (o s k)
+		(declare (ignore k))
+		(print-unreadable-object (o s :type t)
+		  (format s "~@[-~C, ~]~@[--~A~]~
+			     ~*~@[~2:*~:[=~A~;[=~A]~]~]~
+			     ~@[ ~S~]"
+			  (opt-short-name o)
+			  (opt-long-name o)
+			  (opt-arg-optional-p o)
+			  (opt-arg-name o)
+			  (opt-documentation o)))))
+	     (:constructor %make-option)
+	     (:constructor make-option
+		 (long-name short-name
+		  &optional arg-name
+		  &key (tag (intern (string-upcase long-name) :keyword))
+		       negated-tag
+		       arg-optional-p
+		       doc (documentation doc))))
+  "Describes a command-line option.  Slots:
+
+   LONG-NAME	The option's long name.  If this is null, the `option' is
+		just a banner to be printed in the program's help text.
+
+   TAG          The value to be returned if this option is encountered.  If
+		this is a function, instead, the function is called with the
+		option's argument or nil.
+
+   NEGATED-TAG  As for TAG, but used if the negated form of the option is
+		found.  If this is nil (the default), the option cannot be
+		negated.
+
+   SHORT-NAME   The option's short name.  This must be a single character, or
+		nil if the option has no short name.
+
+   ARG-NAME     The name of the option's argument, a string.  If this is nil,
+		the option doesn't accept an argument.  The name is shown in
+		the help text.
+
+   ARG-OPTIONAL-P
+		If non-nil, the option's argument is optional.  This is
+		ignored unless ARG-NAME is non-null.
+
+   DOCUMENTATION
+		The help text for this option.  It is automatically line-
+		wrapped.  If nil, the option is omitted from the help
+		text.
+
+   Usually, one won't use make-option, but use the option macro instead."
+  (long-name nil :type (or null string))
+  (tag nil :type t)
+  (negated-tag nil :type t)
+  (short-name nil :type (or null character))
+  (arg-name nil :type (or null string))
+  (arg-optional-p nil :type t)
+  (documentation nil :type (or null string)))
+
+(export '(option-parser option-parser-p make-option-parser
+	  op-options op-non-option op-long-only-p op-numeric-p
+	  op-negated-numeric-p op-negated-p))
+(defstruct (option-parser
+	     (:conc-name op-)
+	     (:constructor make-option-parser
+		 (&key ((:args argstmp) (cdr *command-line*))
+		       (options *options*)
+		       (non-option :skip)
+		       ((:numericp numeric-p))
+		       negated-numeric-p
+		       long-only-p
+		  &aux (args (cons nil argstmp))
+		       (next args)
+		       (negated-p (or negated-numeric-p
+				      (some #'opt-negated-tag
+					    options))))))
+  "An option parser object.  Slots:
+
+   ARGS		The arguments to be parsed.  Usually this will be
+		*command-line*.
+
+   OPTIONS      List of option structures describing the acceptable options.
+
+   NON-OPTION   Behaviour when encountering a non-option argument.  The
+		default is :skip.  Allowable values are:
+		  :skip -- pretend that it appeared after the option
+		    arguments; this is the default behaviour of GNU getopt
+		  :stop -- stop parsing options, leaving the remaining
+		    command line unparsed
+		  :return -- return :non-option and the argument word
+
+   NUMERIC-P    Non-nil tag (as for options) if numeric options (e.g., -43)
+		are to be allowed.  The default is nil.  (Anomaly: the
+		keyword for this argument is :numericp.)
+
+   NEGATED-NUMERIC-P
+		Non-nil tag (as for options) if numeric options (e.g., -43)
+		can be negated.  This is not the same thing as a negative
+		numeric option!
+
+   LONG-ONLY-P  A misnomer inherited from GNU getopt.  Whether to allow
+		long options to begin with a single dash.  Short options are
+		still allowed, and may be cuddled as usual.  The default is
+		nil."
+  (args nil :type list)
+  (options nil :type list)
+  (non-option :skip :type (or function (member :skip :stop :return)))
+  (next nil :type list)
+  (short-opt nil :type (or null string))
+  (short-opt-index 0 :type fixnum)
+  (short-opt-neg-p nil :type t)
+  (long-only-p nil :type t)
+  (numeric-p nil :type t)
+  (negated-numeric-p nil :type t)
+  (negated-p nil :type t))
+
+(export 'option-parse-error)
+(define-condition option-parse-error (error simple-condition)
+  ()
+  (:documentation
+   "Indicates an error found while parsing options.
+
+   Probably not that useful."))
+
+(defun option-parse-error (msg &rest args)
+  "Signal an option-parse-error with the given message and arguments."
+  (error (make-condition 'option-parse-error
+			 :format-control msg
+			 :format-arguments args)))
+
+(export 'option-parse-remainder)
+(defun option-parse-remainder (op)
+  "Returns the unparsed remainder of the command line."
+  (cdr (op-args op)))
+
+(export 'option-parse-return)
+(defun option-parse-return (tag &optional argument)
+  "Force a return from `option-parse-next' with TAG and ARGUMENT.
+
+   This should only be called from an option handler."
+  (throw 'option-parse-return (values tag argument)))
+
+(export 'option-parse-next)
+(defun option-parse-next (op)
+  "Parse and handle the next option from the command-line.
+
+   This is the main option-parsing function.  OP is an option-parser object,
+   initialized appropriately.  Returns two values, OPT and ARG: OPT is the
+   tag of the next option read, and ARG is the argument attached to it, or
+   nil if there was no argument.  If there are no more options, returns nil
+   twice.  Options whose TAG is a function aren't returned; instead, the tag
+   function is called, with the option argument (or nil) as the only
+   argument.  It is safe for tag functions to throw out of
+   `option-parse-next', if they desparately need to.  (This is the only way
+   to actually get `option-parse-next' to return a function value, should
+   that be what you want.  See `option-parse-return' for a way of doing
+   this.)
+
+   While `option-parse-next' is running, there is a restart `skip-option'
+   which moves on to the next option.  Error handlers should use this to
+   resume after parsing errors."
+  (labels ((ret (opt &optional arg)
+	     (return-from option-parse-next (values opt arg)))
+	   (finished ()
+	     (setf (op-next op) nil)
+	     (ret nil nil))
+	   (peek-arg ()
+	     (cadr (op-next op)))
+	   (more-args-p ()
+	     (and (op-next op)
+		  (cdr (op-next op))))
+	   (skip-arg ()
+	     (setf (op-next op) (cdr (op-next op))))
+	   (eat-arg ()
+	     (setf (cdr (op-next op)) (cddr (op-next op))))
+	   (get-arg ()
+	     (prog1 (peek-arg) (eat-arg)))
+
+	   (process-option (o name negp &key arg argfunc)
+	     (cond ((not (opt-arg-name o))
+		    (when arg
+		      (option-parse-error
+		       "Option `~A' does not accept arguments"
+		       name)))
+		   (arg)
+		   (argfunc
+		    (setf arg (funcall argfunc)))
+		   ((opt-arg-optional-p o))
+		   ((more-args-p)
+		    (setf arg (get-arg)))
+		   (t
+		    (option-parse-error "Option `~A' requires an argument"
+					name)))
+	     (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
+	       (if (functionp how)
+		   (funcall how arg)
+		   (ret how arg))))
+
+	   (process-long-option (arg start negp)
+	     (when (and (not negp)
+			(op-negated-p op)
+			(> (length arg) (+ start 3))
+			(string= arg "no-"
+				 :start1 start :end1 (+ start 3)))
+	       (incf start 3)
+	       (setf negp t))
+	     (let* ((matches nil)
+		    (eqpos (position #\= arg :start start))
+		    (len (or eqpos (length arg)))
+		    (optname (subseq arg 0 len))
+		    (len-2 (- len start)))
+	       (dolist (o (op-options op))
+		 (cond ((or (not (stringp (opt-long-name o)))
+			    (and negp (not (opt-negated-tag o)))
+			    (< (length (opt-long-name o)) len-2)
+			    (string/= optname (opt-long-name o)
+				      :start1 start :end2 len-2)))
+		       ((= (length (opt-long-name o)) len-2)
+			(setf matches (list o))
+			(return))
+		       (t
+			(push o matches))))
+	       (cond ((null matches)
+		      (option-parse-error "Unknown option `~A'" optname))
+		     ((cdr matches)
+		      (option-parse-error
+		       #.(concatenate 'string
+				      "Ambiguous long option `~A' -- "
+				      "could be any of:"
+				      "~{~%~8T--~A~}")
+		       optname
+		       (mapcar #'opt-long-name matches))))
+	       (process-option (car matches)
+			       optname
+			       negp
+			       :arg (and eqpos
+					 (subseq arg (1+ eqpos)))))))
+
+    (catch 'option-parse-return
+      (loop
+	(with-simple-restart (skip-option "Skip this bogus option.")
+	  (cond
+	    ;;
+	    ;; We're embroiled in short options: handle them.
+	    ((op-short-opt op)
+	     (if (>= (op-short-opt-index op) (length (op-short-opt op)))
+		 (setf (op-short-opt op) nil)
+		 (let* ((str (op-short-opt op))
+			(i (op-short-opt-index op))
+			(ch (char str i))
+			(negp (op-short-opt-neg-p op))
+			(name (format nil "~C~A" (if negp #\+ #\-) ch))
+			(o (find ch (op-options op) :key #'opt-short-name)))
+		   (incf i)
+		   (setf (op-short-opt-index op) i)
+		   (when (or (not o)
+			     (and negp (not (opt-negated-tag o))))
+		     (option-parse-error "Unknown option `~A'" name))
+		   (process-option o
+				   name
+				   negp
+				   :argfunc
+				   (and (< i (length str))
+					(lambda ()
+					  (prog1
+					      (subseq str i)
+					    (setf (op-short-opt op)
+						  nil))))))))
+	    ;;
+	    ;; End of the list.  Say we've finished.
+	    ((not (more-args-p))
+	     (finished))
+	    ;;
+	    ;; Process the next option.
+	    (t
+	     (let ((arg (peek-arg)))
+	       (cond
+		 ;;
+		 ;; Non-option.  Decide what to do.
+		 ((or (<= (length arg) 1)
+		      (and (char/= (char arg 0) #\-)
+			   (or (char/= (char arg 0) #\+)
+			       (not (op-negated-p op)))))
+		  (case (op-non-option op)
+		    (:skip (skip-arg))
+		    (:stop (finished))
+		    (:return (eat-arg)
+			     (ret :non-option arg))
+		    (t (eat-arg)
+		       (funcall (op-non-option op) arg))))
+		 ;;
+		 ;; Double-hyphen.  Stop right now.
+		 ((string= arg "--")
+		  (eat-arg)
+		  (finished))
+		 ;;
+		 ;; Numbers.  Check these before long options, since `--43'
+		 ;; is not a long option.
+		 ((and (op-numeric-p op)
+		       (or (char= (char arg 0) #\-)
+			   (op-negated-numeric-p op))
+		       (or (and (digit-char-p (char arg 1))
+				(every #'digit-char-p (subseq arg 2)))
+			   (and (or (char= (char arg 1) #\-)
+				    (char= (char arg 1) #\+))
+				(>= (length arg) 3)
+				(digit-char-p (char arg 2))
+				(every #'digit-char-p (subseq arg 3)))))
+		  (eat-arg)
+		  (let ((negp (char= (char arg 0) #\+))
+			(num (parse-integer arg :start 1)))
+		    (when (and negp (eq (op-negated-numeric-p op) :-))
+		      (setf num (- num))
+		      (setf negp nil))
+		    (let ((how (if negp
+				   (op-negated-numeric-p op)
+				   (op-numeric-p op))))
+		      (if (functionp how)
+			  (funcall how num)
+			  (ret (if negp :negated-numeric :numeric) num)))))
+		 ;;
+		 ;; Long option.  Find the matching option-spec and process
+		 ;; it.
+		 ((and (char= (char arg 0) #\-)
+		       (char= (char arg 1) #\-))
+		  (eat-arg)
+		  (process-long-option arg 2 nil))
+		 ;;
+		 ;; Short options.  All that's left.
+		 (t
+		  (eat-arg)
+		  (let ((negp (char= (char arg 0) #\+))
+			(ch (char arg 1)))
+		    (cond ((and (op-long-only-p op)
+				(not (member ch (op-options op)
+					     :key #'opt-short-name)))
+			   (process-long-option arg 1 negp))
+			  (t
+			   (setf (op-short-opt op) arg
+				 (op-short-opt-index op) 1
+				 (op-short-opt-neg-p op) negp))))))))))))))
+
+(export 'option-parse-try)
+(defmacro option-parse-try (&body body)
+  "Report errors encountered while parsing options, and try to continue.
+
+   Also establishes a restart `stop-parsing'.  Returns t if parsing completed
+   successfully, or nil if errors occurred."
+  (with-gensyms (retcode)
+    `(let ((,retcode t))
+       (restart-case
+	   (handler-bind
+	       ((option-parse-error
+		 (lambda (cond)
+		   (setf ,retcode nil)
+		   (moan "~A" cond)
+		   (dolist (rn '(skip-option stop-parsing))
+		     (let ((r (find-restart rn)))
+		       (when r (invoke-restart r)))))))
+	     ,@body)
+	 (stop-parsing ()
+	   :report "Give up parsing options."
+	   (setf ,retcode nil)))
+       ,retcode)))
+
+(export 'with-unix-error-reporting)
+(defmacro with-unix-error-reporting ((&key) &body body)
+  "Evaluate BODY with errors reported in the standard Unix fashion."
+  (with-gensyms (cond)
+    `(handler-case
+	 (progn ,@body)
+       (simple-condition (,cond)
+	 (apply #'die
+		(simple-condition-format-control ,cond)
+		(simple-condition-format-arguments ,cond)))
+       (error (,cond)
+	 (die "~A" ,cond)))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard option handlers.
+
+(export 'defopthandler)
+(defmacro defopthandler (name (var &optional (arg (gensym)))
+			 (&rest args)
+			 &body body)
+  "Define an option handler function NAME.
+
+   Option handlers update a generalized variable, which may be referred to as
+   VAR in the BODY, based on some parameters (the ARGS) and the value of an
+   option-argument named ARG."
+  (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
+    (multiple-value-bind (docs decls body) (parse-body body)
+      `(progn
+	 (setf (get ',name 'opthandler) ',func)
+	 (defun ,func (,var ,arg ,@args)
+	   ,@docs ,@decls
+	   (declare (ignorable ,arg))
+	   (with-locatives ,var
+	     ,@body))
+	 ',name))))
+
+(defun parse-c-integer (string &key radix (start 0) end)
+  "Parse (a substring of) STRING according to the standard C rules.
+
+   Well, almost: the 0 and 0x prefixes are accepted, but so too are
+   0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted, for any
+   radix between 2 and 36.  Prefixes are only accepted if RADIX is nil.
+   Returns two values: the integer parsed (or nil if there wasn't enough for
+   a sensible parse), and the index following the characters of the integer."
+  (unless end (setf end (length string)))
+  (labels ((simple (i r goodp sgn)
+	     (multiple-value-bind
+		 (a i)
+		 (if (and (< i end)
+			  (digit-char-p (char string i) r))
+		     (parse-integer string
+				    :start i :end end
+				    :radix r
+				    :junk-allowed t)
+		     (values nil i))
+	       (values (if a (* sgn a) (and goodp 0)) i)))
+
+	   (get-radix (i r sgn)
+	     (cond (r (simple i r nil sgn))
+		   ((>= i end) (values nil i))
+		   ((and (char= (char string i) #\0)
+			 (>= (- end i) 2))
+		    (case (char string (1+ i))
+		      (#\x (simple (+ i 2) 16 nil sgn))
+		      (#\o (simple (+ i 2) 8 nil sgn))
+		      (#\b (simple (+ i 2) 2 nil sgn))
+		      (t (simple (1+ i) 8 t sgn))))
+		   (t
+		    (multiple-value-bind
+			(r i)
+			(simple i 10 nil +1)
+		      (cond ((not r) (values nil i))
+			    ((and (< i end)
+				  (char= (char string i) #\_)
+				  (<= 2 r 36))
+			     (simple (1+ i) r nil sgn))
+			    (t
+			     (values (* r sgn) i))))))))
+
+    (cond ((>= start end) (values nil start))
+	  ((char= (char string start) #\-)
+	   (get-radix (1+ start) radix -1))
+	  ((char= (char string start) #\+)
+	   (get-radix (1+ start) radix +1))
+	  (t
+	   (get-radix start radix +1)))))
+
+(export 'invoke-option-handler)
+(defun invoke-option-handler (handler loc arg args)
+  "Call HANDLER, giving it LOC to update, the option-argument ARG, and the
+   remaining ARGS."
+  (apply (if (functionp handler) handler
+	     (fdefinition (get handler 'opthandler)))
+	 loc arg args))
+
+;;;--------------------------------------------------------------------------
+;;; Built-in option handlers.
+
+(export 'set)
+(defopthandler set (var) (&optional (value t))
+  "Sets VAR to VALUE; defaults to t."
+  (setf var value))
+
+(export 'clear)
+(defopthandler clear (var) (&optional (value nil))
+  "Sets VAR to VALUE; defaults to nil."
+  (setf var value))
+
+(export 'inc)
+(defopthandler inc (var) (&optional max (step 1))
+  "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
+   nil for no maximum).  No errors are signalled."
+  (incf var step)
+  (when (>= var max)
+    (setf var max)))
+
+(export 'dec)
+(defopthandler dec (var) (&optional min (step 1))
+  "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
+   for no maximum).  No errors are signalled."
+  (decf var step)
+  (when (<= var min)
+    (setf var min)))
+
+(export 'read)
+(defopthandler read (var arg) ()
+  "Stores in VAR the Lisp object found by reading the ARG.
+
+   Evaluation is forbidden while reading ARG.  If there is an error during
+   reading, an error of type option-parse-error is signalled."
+  (handler-case
+      (let ((*read-eval* nil))
+	(multiple-value-bind (x end) (read-from-string arg t)
+	  (unless (>= end (length arg))
+	    (option-parse-error "Junk at end of argument `~A'" arg))
+	  (setf var x)))
+    (error (cond)
+      (option-parse-error (format nil "~A" cond)))))
+
+(export 'int)
+(defopthandler int (var arg) (&key radix min max)
+  "Stores in VAR the integer read from the ARG.
+
+   Integers are parsed according to C rules, which is normal in Unix; the
+   RADIX may be nil to allow radix prefixes, or an integer between 2 and 36.
+   An option-parse-error is signalled if the ARG is not a valid integer, or
+   if it is not between MIN and MAX (either of which may be nil if no lower
+   resp. upper bound is wanted)."
+  (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
+    (unless (and v (>= end (length arg)))
+      (option-parse-error "Bad integer `~A'" arg))
+    (when (or (and min (< v min))
+	      (and max (> v max)))
+      (option-parse-error
+       #.(concatenate 'string
+		      "Integer ~A out of range "
+		      "(must have ~@[~D <= ~]x~@[ <= ~D~])")
+       arg min max))
+    (setf var v)))
+
+(export 'string)
+(defopthandler string (var arg) ()
+  "Stores ARG in VAR, just as it is."
+  (setf var arg))
+
+(export 'keyword)
+(defopthandler keyword (var arg) (&optional (valid t))
+  "Converts ARG into a keyword.
+
+   If VALID is t, then any ARG string is acceptable: the argument is
+   uppercased and interned in the keyword package.  If VALID is a list, then
+   we ensure that ARG matches one of the elements of the list; unambigious
+   abbreviations are allowed."
+  (etypecase valid
+    ((member t)
+     (setf var (intern (string-upcase arg) :keyword)))
+    (list
+     (let ((matches nil)
+	   (guess (string-upcase arg))
+	   (len (length arg)))
+       (dolist (k valid)
+	 (let* ((kn (symbol-name k))
+		(klen (length kn)))
+	   (cond ((string= kn guess)
+		  (setf matches (list k))
+		  (return))
+		 ((and (< len klen)
+		       (string= guess kn :end2 len))
+		  (push k matches)))))
+       (cond
+	 ((null matches)
+	  (option-parse-error #.(concatenate 'string
+					     "Argument `~A' invalid: "
+					     "must be one of:"
+					     "~{~%~8T~(~A~)~}")
+			      arg valid))
+	 ((null (cdr matches))
+	  (setf var (car matches)))
+	 (t
+	  (option-parse-error #.(concatenate 'string
+					     "Argument `~A' ambiguous: "
+					     "may be any of:"
+					     "~{~%~8T~(~A~)~}")
+			      arg matches)))))))
+
+(export 'list)
+(defopthandler list (var arg) (&optional handler &rest handler-args)
+  "Collect ARGs in a list at VAR.
+
+   ARGs are translated by the HANDLER first, if specified.  If not, it's as
+   if you asked for `string'."
+  (when handler
+    (invoke-option-handler handler (locf arg) arg handler-args))
+  (setf var (nconc var (list arg))))
+
+;;;--------------------------------------------------------------------------
+;;; Option descriptions.
+
+(export 'defoptmacro)
+(defmacro defoptmacro (name args &body body)
+  "Defines an option macro NAME.
+
+   Option macros should produce a list of expressions producing one option
+   structure each."
+  `(progn
+     (setf (get ',name 'optmacro) (lambda ,args ,@body))
+     ',name))
+
+(export 'parse-option-form)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun parse-option-form (form)
+    "Does the heavy lifting for parsing an option form.
+
+   See the docstring for the `option' macro for details of the syntax."
+  (flet ((doc (form)
+	   (cond ((stringp form) form)
+		 ((null (cdr form)) (car form))
+		 (t `(format nil ,@form))))
+	 (docp (form)
+	   (or (stringp form)
+	       (and (consp form)
+		    (stringp (car form))))))
+    (cond ((stringp form)
+	   `(%make-option :documentation ,form))
+	  ((not (listp form))
+	   (error "option form must be string or list"))
+	  ((and (docp (car form)) (null (cdr form)))
+	   `(%make-option :documentation ,(doc (car form))))
+	  (t
+	   (let (long-name short-name
+		 arg-name arg-optional-p
+		 tag negated-tag
+		 doc)
+	     (dolist (f form)
+	       (cond ((and (or (not tag) (not negated-tag))
+			   (or (keywordp f)
+			       (and (consp f)
+				    (member (car f) '(lambda function)))))
+		      (if tag
+			  (setf negated-tag f)
+			  (setf tag f)))
+		     ((and (not long-name)
+			   (or (rationalp f)
+			       (symbolp f)
+			       (stringp f)))
+		      (setf long-name (if (stringp f) f
+					  (format nil "~(~A~)" f))))
+		     ((and (not short-name)
+			   (characterp f))
+		      (setf short-name f))
+		     ((and (not doc)
+			   (docp f))
+		      (setf doc (doc f)))
+		     ((and (consp f) (symbolp (car f)))
+		      (case (car f)
+			(:short-name (setf short-name (cadr f)))
+			(:long-name (setf long-name (cadr f)))
+			(:tag (setf tag (cadr f)))
+			(:negated-tag (setf negated-tag (cadr f)))
+			(:arg (setf arg-name (cadr f)))
+			(:opt-arg (setf arg-name (cadr f))
+				  (setf arg-optional-p t))
+			(:doc (setf doc (doc (cdr f))))
+			(t (let ((handler (get (car f) 'opthandler)))
+			     (unless handler
+			       (error "No handler `~S' defined." (car f)))
+			     (let* ((var (cadr f))
+				    (arg (gensym))
+				    (thunk `#'(lambda (,arg)
+						(,handler (locf ,var)
+							  ,arg
+							  ,@(cddr f)))))
+			       (if tag
+				   (setf negated-tag thunk)
+				   (setf tag thunk)))))))
+		     (t
+		      (error "Unexpected thing ~S in option form." f))))
+	     `(make-option ,long-name ,short-name ,arg-name
+			   ,@(and arg-optional-p `(:arg-optional-p t))
+			   ,@(and tag `(:tag ,tag))
+			   ,@(and negated-tag `(:negated-tag ,negated-tag))
+			   ,@(and doc `(:documentation ,doc)))))))))
+
+(export 'options)
+(defmacro options (&rest optlist)
+  "More convenient way of initializing options.  The OPTLIST is a list of
+   OPTFORMS.  Each OPTFORM is one of the following:
+
+   STRING	A banner to print.
+
+   SYMBOL or (SYMBOL STUFF...)
+		If SYMBOL is an optform macro, the result of invoking it.
+
+   (...)	A full option-form.  See below.
+
+   Full option-forms are a list of the following kinds of items.
+
+   (:short-name CHAR)
+   (:long-name STRING)
+   (:arg STRING)
+   (:tag TAG)
+   (:negated-tag TAG)
+   (:doc STRING)
+		Set the appropriate slot of the option to the given value.
+		The argument is evaluated.
+
+   (:doc FORMAT-CONTROL ARGUMENTS...)
+		As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
+
+   KEYWORD, (function ...), (lambda ...)
+		If no TAG is set yet, then as a TAG; otherwise as the
+		NEGATED-TAG.
+
+   STRING (or SYMBOL or RATIONAL)
+		If no LONG-NAME seen yet, then the LONG-NAME.  For symbols
+		and rationals, the item is converted to a string and squashed
+		to lower-case.
+
+   CHARACTER	If no SHORT-NAME, then the SHORT-NAME.
+
+   STRING or (STRING STUFF...)
+		If no DOCUMENTATION set yet, then the DOCUMENTATION string,
+		as for (:doc STRING STUFF...)
+
+   (:opt-arg NAME)
+		Set the ARG-NAME, and also set ARG-OPTIONAL-P.
+
+   (HANDLER VAR ARGS...)
+		If no TAG is set yet, attach the HANDLER to this option,
+		giving it ARGS.  Otherwise, set the NEGATED-TAG."
+
+  `(list ,@(mapcan (lambda (form)
+		     (multiple-value-bind
+			 (sym args)
+			 (cond ((symbolp form) (values form nil))
+			       ((and (consp form) (symbolp (car form)))
+				(values (car form) (cdr form)))
+			       (t (values nil nil)))
+		       (let ((macro (and sym (get sym 'optmacro))))
+			 (if macro
+			     (apply macro args)
+			     (list (parse-option-form form))))))
+		   optlist)))
+
+;;;--------------------------------------------------------------------------
+;;; Support stuff for help and usage messages.
+
+(defun print-text (string
+		   &optional
+		   (stream *standard-output*)
+		   &key
+		   (start 0)
+		   (end nil))
+  "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
+   newlines in the obvious way.  Stuff between square brackets is not broken:
+   this makes usage messages work better."
+  (let ((i start)
+	(nest 0)
+	(splitp nil))
+    (flet ((emit ()
+	     (write-string string stream :start start :end i)
+	     (setf start i)))
+      (unless end (setf end (length string)))
+      (loop
+	 (unless (< i end)
+	   (emit)
+	   (return))
+	 (let ((ch (char string i)))
+	   (cond ((char= ch #\newline)
+		  (emit)
+		  (incf start)
+		  (pprint-newline :mandatory stream))
+		 ((whitespace-char-p ch)
+		  (when (zerop nest)
+		    (setf splitp t)))
+		 (t
+		  (when splitp
+		    (emit)
+		    (pprint-newline :fill stream))
+		  (setf splitp nil)
+		  (case ch
+		    (#\[ (incf nest))
+		    (#\] (when (plusp nest) (decf nest))))))
+	   (incf i))))))
+
+(export 'simple-usage)
+(defun simple-usage (opts &optional mandatory-args)
+  "Build a simple usage list from a list of options, and (optionally)
+   mandatory argument names."
+  (let (short-simple long-simple short-arg long-arg)
+    (dolist (o opts)
+      (cond ((not (and (opt-documentation o)
+		       (opt-long-name o))))
+	    ((and (opt-short-name o) (opt-arg-name o))
+	     (push o short-arg))
+	    ((opt-short-name o)
+	     (push o short-simple))
+	    ((opt-arg-name o)
+	     (push o long-arg))
+	    (t
+	     (push o long-simple))))
+    (list
+     (nconc (and short-simple
+		 (list (format nil "[-~{~C~}]"
+			       (sort (mapcar #'opt-short-name short-simple)
+				     #'char<))))
+	    (and long-simple
+		 (mapcar (lambda (o)
+			   (format nil "[--~A]" (opt-long-name o)))
+			 (sort long-simple #'string< :key #'opt-long-name)))
+	    (and short-arg
+		 (mapcar (lambda (o)
+			   (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
+				   (opt-arg-optional-p o)
+				   (opt-short-name o)
+				   (opt-arg-name o)))
+			 (sort short-arg #'char-lessp
+			       :key #'opt-short-name)))
+	    (and long-arg
+		 (mapcar (lambda (o)
+			   (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
+				   (opt-arg-optional-p o)
+				   (opt-long-name o)
+				   (opt-arg-name o)))
+			 (sort long-arg #'string-lessp
+			       :key #'opt-long-name)))
+	    (if (listp mandatory-args)
+		mandatory-args
+		(list mandatory-args))))))
+
+(export 'show-usage)
+(defun show-usage (prog usage &optional (stream *standard-output*))
+  "Basic usage-showing function.
+
+   PROG is the program name, probably from `*program-name*'.  USAGE is a list
+   of possible usages of the program, each of which is a list of items to be
+   supplied by the user.  In simple cases, a single string is sufficient."
+  (pprint-logical-block (stream nil :prefix "Usage: ")
+    (dolist (u (if (listp usage) usage (list usage)))
+      (pprint-logical-block (stream nil
+				    :prefix (concatenate 'string prog " "))
+	(format stream "~{~A~^ ~:_~}" (if (listp u) u (list u))))))
+  (terpri stream))
+
+(defun show-options-help (opts &optional (stream *standard-output*))
+  "Write help for OPTS to the STREAM.
+
+   This is the core of the `show-help' function."
+  (let (newlinep)
+    (dolist (o opts)
+      (let ((doc (opt-documentation o)))
+	(cond ((not o))
+	      ((not (opt-long-name o))
+	       (when newlinep
+		 (terpri stream)
+		 (setf newlinep nil))
+	       (pprint-logical-block (stream nil)
+		 (print-text doc stream))
+	       (terpri stream))
+	      (t
+	       (setf newlinep t)
+	       (pprint-logical-block (stream nil :prefix "  ")
+		 (format stream "~:[   ~;-~:*~C,~] --~A"
+			 (opt-short-name o)
+			 (opt-long-name o))
+		 (when (opt-arg-name o)
+		   (format stream "~:[=~A~;[=~A]~]"
+			   (opt-arg-optional-p o)
+			   (opt-arg-name o)))
+		 (write-string "  " stream)
+		 (pprint-tab :line 30 1 stream)
+		 (pprint-indent :block 30 stream)
+		 (print-text doc stream))
+	       (terpri stream)))))))
+
+(export 'show-help)
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+  "Basic help-showing function.
+
+   PROG is the program name, probably from `*program-name*'.  VER is the
+   program's version number.  USAGE is a list of the possible usages of the
+   program, each of which may be a list of items to be supplied.  OPTS is the
+   list of supported options, as provided to the options parser.  STREAM is
+   the stream to write on."
+  (format stream "~A, version ~A~2%" prog ver)
+  (show-usage prog usage stream)
+  (terpri stream)
+  (show-options-help opts stream))
+
+(export 'sanity-check-option-list)
+(defun sanity-check-option-list (opts)
+  "Check the option list OPTS for basic sanity.  Reused short and long option
+   names are diagnosed.  Maybe other problems will be reported later.
+   Returns a list of warning strings."
+  (let ((problems nil)
+	(longs (make-hash-table :test #'equal))
+	(shorts (make-hash-table)))
+    (flet ((problem (msg &rest args)
+	     (push (apply #'format nil msg args) problems)))
+      (dolist (o opts)
+	(push o (gethash (opt-long-name o) longs))
+	(push o (gethash (opt-short-name o) shorts)))
+      (maphash (lambda (k v)
+		 (when (and k (cdr v))
+		   (problem "Long name `--~A' reused in ~S" k v)))
+	       longs)
+      (maphash (lambda (k v)
+		 (when (and k (cdr v))
+		   (problem "Short name `-~C' reused in ~S" k v)))
+	       shorts)
+      problems)))
+
+;;;--------------------------------------------------------------------------
+;;; Full program descriptions.
+
+(defvar *help* nil "Help text describing the program.")
+(defvar *version* "<unreleased>" "The program's version number.")
+(defvar *usage* nil "A usage summary string")
+
+(export 'do-usage)
+(defun do-usage (&optional (stream *standard-output*))
+  (show-usage *program-name* *usage* stream))
+
+(export 'die-usage)
+(defun die-usage ()
+  (do-usage *error-output*)
+  (exit 1))
+
+(defun opt-help (arg)
+  (declare (ignore arg))
+  (show-help *program-name* *version* *usage* *options*)
+  (typecase *help*
+    (string (terpri) (write-string *help*))
+    (null nil)
+    ((or function symbol) (terpri) (funcall *help*)))
+  (format t "~&")
+  (exit 0))
+(defun opt-version (arg)
+  (declare (ignore arg))
+  (format t "~A, version ~A~%" *program-name* *version*)
+  (exit 0))
+(defun opt-usage (arg)
+  (declare (ignore arg))
+  (do-usage)
+  (exit 0))
+
+(export 'help-options)
+(defoptmacro help-options (&key (short-help #\h)
+				(short-version #\v)
+				(short-usage #\u))
+  "Inserts a standard help options collection in an options list."
+  (flet ((shortform (char)
+	   (and char (list char))))
+    (mapcar
+     #'parse-option-form
+     `("Help options"
+       (,@(shortform short-help) "help" #'opt-help
+	"Show this help message.")
+       (,@(shortform short-version) "version" #'opt-version
+	("Show ~A's version number." *program-name*))
+       (,@(shortform short-usage) "usage" #'opt-usage
+	("Show a very brief usage summary for ~A." *program-name*))))))
+
+(export 'define-program)
+(defun define-program (&key
+		       (program-name nil progp)
+		       (help nil helpp)
+		       (version nil versionp)
+		       (usage nil usagep)
+		       (full-usage nil fullp)
+		       (options nil optsp))
+  "Sets up all the required things a program needs to have to parse options
+   and respond to them properly."
+  (when progp (setf *program-name* program-name))
+  (when helpp (setf *help* help))
+  (when versionp (setf *version* version))
+  (when optsp (setf *options* options))
+  (cond ((and usagep fullp) (error "conflicting options"))
+	(usagep (setf *usage* (simple-usage *options* usage)))
+	(fullp (setf *usage* full-usage))))
+
+(export 'do-options)
+(defmacro do-options ((&key (parser '(make-option-parser)))
+		      &body clauses)
+  "Handy all-in-one options parser macro.
+
+   PARSER defaults to a new options parser using the preset default options
+   structure.  The CLAUSES are `case2'-like clauses to match options, and
+   must be exhaustive.  If there is a clause (nil (REST) FORMS...) then the
+   FORMS are evaluated after parsing is done with REST bound to the remaining
+   command-line arguments."
+  (once-only (parser)
+    `(progn
+       (loop
+	 (,(if (find t clauses :key #'car) 'case2 'ecase2)
+	     (option-parse-next ,parser)
+	   ((nil) () (return))
+	   ,@(remove-if #'null clauses :key #'car)))
+       ,@(let ((tail (find nil clauses :key #'car)))
+	   (and tail
+		(destructuring-bind ((&optional arg) &rest forms) (cdr tail)
+		  (if arg
+		      (list `(let ((,arg (option-parse-remainder ,parser)))
+			      ,@forms))
+		      forms)))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/src/output-proto.lisp b/src/output-proto.lisp
index af293ee..5b00dcf 100644
--- a/src/output-proto.lisp
+++ b/src/output-proto.lisp
@@ -112,7 +112,8 @@
    it was itself invoked.")
 
   (:method-combination progn)
-  (:method progn (object reason sequencer)))
+  (:method progn (object reason sequencer)
+    (declare (ignore object reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Useful syntax.
diff --git a/src/package.lisp b/src/package.lisp
index 60da8ea..75dc7fd 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -26,6 +26,7 @@
 (cl:defpackage #:sod
   (:use #:common-lisp
 	#:sod-utilities
+	#:optparse
 	#:sod-parser))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/src/parser/parser-expr-impl.lisp b/src/parser/parser-expr-impl.lisp
index 89b0f58..e0c681b 100644
--- a/src/parser/parser-expr-impl.lisp
+++ b/src/parser/parser-expr-impl.lisp
@@ -165,9 +165,11 @@
     (cerror* "Parse error: missing `~A'" tag)))
 
 (defmethod operator-push-action (left (right open-parenthesis))
+  (declare (ignore left))
   :push)
 
 (defmethod operator-push-action ((left open-parenthesis) right)
+  (declare (ignore right))
   :push)
 
 ;;;--------------------------------------------------------------------------
diff --git a/src/parser/parser-proto.lisp b/src/parser/parser-proto.lisp
index 4242dfe..d458e70 100644
--- a/src/parser/parser-proto.lisp
+++ b/src/parser/parser-proto.lisp
@@ -103,13 +103,16 @@
     (:documentation
      "Expand a parser list-form given by HEAD and TAIL, in CONTEXT.")
     (:method (context head tail)
+      (declare (ignore context))
       (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)))
+    (:method (context form)
+      (declare (ignore context))
+      form)))
 
 (export 'defparse)
 (defmacro defparse (name bvl &body body)
@@ -147,6 +150,7 @@
 	`(defmethod expand-parser-form
 	     ((,context ,ctxclass) (,head (eql ',name)) ,tail)
 	   ,@doc
+	   (declare (ignorable ,context))
 	   (block ,name
 	     (destructuring-bind ,bvl ,tail
 	       ,@decls
@@ -331,10 +335,12 @@
 
 (defmethod expand-parser-spec (context (spec (eql t)))
   "Always matches without consuming input."
+  (declare (ignore context))
   '(values t t nil))
 
 (defmethod expand-parser-spec (context (spec (eql nil)))
   "Always fails without consuming input.  The failure indicator is `:fail'."
+  (declare (ignore context))
   '(values '(:fail) nil nil))
 
 (export 'seq)
@@ -600,7 +606,9 @@
    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))
+    (:method (context place)
+      (declare (ignore context place))
+      nil))
 
   (export 'parser-places-must-be-released-p)
   (defgeneric parser-places-must-be-released-p (context)
@@ -615,7 +623,9 @@
    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)))
+    (:method (context)
+      (declare (ignore context))
+      t)))
 
 (export 'with-parser-place)
 (defmacro with-parser-place ((place context) &body body)
diff --git a/src/parser/scanner-charbuf-impl.lisp b/src/parser/scanner-charbuf-impl.lisp
index 9cafc3d..86dc999 100644
--- a/src/parser/scanner-charbuf-impl.lisp
+++ b/src/parser/scanner-charbuf-impl.lisp
@@ -28,8 +28,9 @@
 ;;;--------------------------------------------------------------------------
 ;;; Infrastructure types.
 
-(defconstant charbuf-size 4096
-  "Number of characters in a character buffer.")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant charbuf-size 4096
+    "Number of characters in a character buffer."))
 
 (deftype charbuf ()
   "Type of character buffers."
@@ -330,6 +331,7 @@
 	    tail link))))
 
 (defmethod scanner-release-place ((scanner charbuf-scanner) place)
+  (declare (ignore place))
   (with-slots (captures) scanner
     (decf captures)))
 
@@ -399,7 +401,8 @@
   (make-instance 'charbuf-scanner-stream :scanner scanner))
 
 (defmethod stream-read-sequence
-    ((stream charbuf-scanner-stream) (seq string) &optional (start 0) end)
+    ((stream charbuf-scanner-stream) (seq string)
+     #+clisp &key #-clisp &optional (start 0) end)
   (with-slots (scanner) stream
     (unless end (setf end (length seq)))
     (let ((i start) (n (- end start)))
diff --git a/src/parser/scanner-token-impl.lisp b/src/parser/scanner-token-impl.lisp
index bf5e394..9535d3d 100644
--- a/src/parser/scanner-token-impl.lisp
+++ b/src/parser/scanner-token-impl.lisp
@@ -73,6 +73,7 @@
 	  tail place)))
 
 (defmethod scanner-release-place ((scanner token-scanner) place)
+  (declare (ignore place))
   (with-slots (captures) scanner
     (decf captures)))
 
diff --git a/src/parser/streams-impl.lisp b/src/parser/streams-impl.lisp
index d62429a..d84bee4 100644
--- a/src/parser/streams-impl.lisp
+++ b/src/parser/streams-impl.lisp
@@ -120,7 +120,8 @@
     (clear-input ustream)))
 
 (defmethod stream-read-sequence
-    ((stream proxy-input-stream) seq &optional (start 0) end)
+    ((stream proxy-input-stream) seq
+     #+clisp &key #-clisp &optional (start 0) end)
   (with-slots (ustream) stream
     (read-sequence seq ustream :start start :end end)))
 
@@ -144,7 +145,8 @@
     (force-output ustream)))
 
 (defmethod stream-write-sequence
-    ((stream proxy-output-stream) seq &optional (start 0) end)
+    ((stream proxy-output-stream) seq
+     #+clisp &key #-clisp &optional (start 0) end)
   (with-slots (ustream) stream
     (write-sequence seq ustream :start start :end end)))
 
@@ -306,7 +308,8 @@
   (call-next-method))
 
 (defmethod stream-read-sequence
-    ((stream position-aware-input-stream) seq &optional (start 0) end)
+    ((stream position-aware-input-stream) seq
+     #+clisp &key #-clisp &optional (start 0) end)
   (declare (ignore end))
   (let ((pos (call-next-method)))
     (with-position (stream)
@@ -345,7 +348,8 @@
    insertion of some user code."))
 
 (defmethod stream-write-sequence
-    ((stream position-aware-output-stream) seq &optional (start 0) end)
+    ((stream position-aware-output-stream) seq
+     #+clisp &key #-clisp &optional (start 0) end)
   (with-position (stream)
     (dosequence (ch seq :start start :end end)
       (update ch))
diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index ff59551..f81ce92 100644
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -98,8 +98,9 @@
 			    (let* ((stream (make-scanner-stream scanner))
 				   (sexp (read stream t)))
 			      (scanner-step scanner)
-			      (values (cons (property-type sexp) sexp)
-				      t t)))
+			      (multiple-value-bind (type value)
+				  (decode-property sexp)
+				(values (cons type value) t t))))
 			   (t
 			    (values (list :int :id :char :string #\?)
 				    nil nil)))))
diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp
index e98c908..0c133d6 100644
--- a/src/pset-proto.lisp
+++ b/src/pset-proto.lisp
@@ -147,6 +147,7 @@
 
   ;; If the caller asks for type T then give him the raw thing.
   (:method (value type (wanted (eql t)))
+    (declare (ignore type))
     value))
 
 ;;;--------------------------------------------------------------------------
diff --git a/src/run-sod b/src/run-sod
new file mode 100755
index 0000000..f4b6e65
--- /dev/null
+++ b/src/run-sod
@@ -0,0 +1,9 @@
+#! /bin/sh
+":"; exec cl-launch -X -l "sbcl clisp cmucl ecl" -s asdf -- "$0" "$0" "$@" || exit 1 # -*-lisp-*-
+
+(handler-bind ((warning (lambda (cond)
+			  (declare (ignore cond))
+			  (invoke-restart 'muffle-warning))))
+  (asdf:operate 'asdf:load-op "sod"))
+
+(funcall (intern "MAIN" (find-package "SOD")))
diff --git a/src/sod.asd b/src/sod.asd
index d295c08..b635d83 100644
--- a/src/sod.asd
+++ b/src/sod.asd
@@ -63,6 +63,7 @@
 
   :components
   ((:file "utilities")
+   (:file "optparse" :depends-on ("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
@@ -97,7 +98,7 @@
      (:file "scanner-context-impl" :depends-on
 	    ("parser-proto" "scanner-proto"))))
 
-   (:file "package" :depends-on ("parser"))
+   (:file "package" :depends-on ("utilities" "optparse" "parser"))
 
    ;; Lexical analysis.
    (:file "lexer-proto" :depends-on ("package" "parser"))
@@ -107,7 +108,8 @@
    ;; C type representation protocol.
    (:file "c-types-proto" :depends-on ("package"))
    (:file "c-types-impl" :depends-on ("c-types-proto"))
-   (:file "c-types-parse" :depends-on ("c-types-proto" "fragment-parse"))
+   (:file "c-types-parse" :depends-on
+	  ("c-types-proto" "c-types-class-impl" "fragment-parse"))
 
    ;; Property set protocol.
    (:file "pset-proto" :depends-on ("package"))
@@ -159,12 +161,17 @@
    (:file "method-impl" :depends-on ("method-proto"))
 
    ;; Class output.
-   (:file "class-output" :depends-on ("output-proto" "classes"))))
+   (:file "class-output" :depends-on ("output-proto" "classes"))
+
+   ;; User interface.
+   (:file "frontend" :depends-on
+	  ("optparse" "module-proto" "module-parse"))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Testing.
 
 (defmethod perform ((op test-op) (component (eql (find-system "sod"))))
+  (declare (ignore op component))
   (operate 'test-op "sod-test" :force t))
 
 ;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0