[sod] / src / optparse.lisp

;;; -*-lisp-*-
;;;
;;; Option parser, standard issue
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (handler-bind ((warning #'muffle-warning))
    (cl:defpackage #:optparse
      (:use #:common-lisp #:sod-utilities))))

(cl:in-package #:optparse)

;;;--------------------------------------------------------------------------
;;; Program environment things.

(export 'exit)
(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning
						   sb-ext:compiler-note))
  (defun exit (&optional (code 0) &key abrupt)
    "End program, returning CODE to the caller."
    (declare (type (unsigned-byte 32) code)
	     )
    #.(car '(#+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)
	     (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*
	(let ((uiop-package (find-package :uiop))
	      (cll-package (find-package :cl-launch)))
	  (cons (or (and uiop-package
			 (funcall (intern "ARGV0" uiop-package)))
		    (and cll-package
			 (some (intern "GETENV" cll-package)
			       (list "__CL_ARGV0" "CL_LAUNCH_FILE")))
		    #+sbcl (car sb-ext:*posix-argv*)
		    #+cmu (car ext:*command-line-strings*)
		    #+clisp (aref (ext:argv) 0)
		    #+ecl (ext:argv 0)
		    "sod")
		(cond (uiop-package
		       (funcall (intern "COMMAND-LINE-ARGUMENTS"
					uiop-package)))
		      (cll-package
		       (symbol-value (intern "*ARGUMENTS*" cll-package)))
		      (t #.(or (car '(#+sbcl (cdr sb-ext:*posix-argv*)
				      #+cmu (cdr ext:*command-line-strings*)
				      #+clisp (coerce (subseq (ext:argv) 8)
					       'list)
				      #+ecl (loop for i from 1
						  below (ext:argc)
						  collect (ext:argv i))))
			       (error "Unsupported Lisp"))))))

	*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))

;;;--------------------------------------------------------------------------
;;; 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))
(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
  (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
			     (&key long-name tag negated-tag short-name
				   arg-name arg-optional-p documentation
				   &aux (%documentation documentation)))
	       (: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)
					&aux (%documentation
					      documentation))))
    "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))))
(define-access-wrapper opt-documentation opt-%documentation)

(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))
		       (%options options)
		       (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))
(define-access-wrapper op-options op-%options)

(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
	     (block ,name ,@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 (and max (>= 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 (and min (<= 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
   or 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."
  (multiple-value-bind (docs decls body) (parse-body body)
    `(progn
       (setf (get ',name 'optmacro) (lambda ,args
				      ,@docs ,@decls
				      (block ,name ,@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.

(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
  (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 (or (opt-short-name o)
			(opt-long-name o)))
	       (when newlinep
		 (terpri stream)
		 (setf newlinep nil))
	       (pprint-logical-block (stream nil)
		 (print-text doc stream))
	       (terpri stream))
	      (doc
	       (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
			   "~:[~;[~]~:[~0@*~:[ ~;~]~*~;=~]~A~0@*~:[~;]~]"
			   (opt-arg-optional-p o)
			   (opt-long-name 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.

(export '(*help* *version* *usage*))
(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 --------------------------------------------------