chiark - git - mdw - sod/blob - src/optparse.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Option parser, standard issue
   4 ;;;
   5 ;;; (c) 2005 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:defpackage #:optparse
  27   (:use #:common-lisp #:sod-utilities))
  28
  29 (cl:in-package #:optparse)
  30
  31 ;;;--------------------------------------------------------------------------
  32 ;;; Program environment things.
  33
  34 (export 'exit)
  35 (defun exit (&optional (code 0) &key abrupt)
  36   "End program, returning CODE to the caller."
  37   (declare (type (unsigned-byte 32) code))
  38   #+sbcl (sb-ext:exit :code code :abort abrupt)
  39   #+cmu (if abrupt
  40             (unix::void-syscall ("_exit" c-call:int) code)
  41             (ext:quit code))
  42   #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
  43   #+ecl (ext:quit code)
  44
  45   #-(or sbcl cmu clisp ecl)
  46   (progn
  47     (unless (zerop code)
  48       (format *error-output*
  49               "~&Exiting unsuccessfully with code ~D.~%" code))
  50     (abort)))
  51
  52 (export '(*program-name* *command-line*))
  53 (defvar *program-name* "<unknown>"
  54   "Program name, as retrieved from the command line.")
  55 (defvar *command-line* nil
  56   "A list of command-line arguments, including the program name.")
  57
  58 (export 'set-command-line-arguments)
  59 (defun set-command-line-arguments ()
  60   "Retrieve command-line arguments.
  61
  62    Set `*command-line*' and `*program-name*'."
  63
  64   (setf *command-line*
  65         (or (when (member :cl-launch *features*)
  66               (let* ((cllpkg (find-package :cl-launch))
  67                      (name (funcall (intern "GETENV" cllpkg)
  68                                     "CL_LAUNCH_FILE"))
  69                      (args (symbol-value (intern "*ARGUMENTS*" cllpkg))))
  70                 (if name
  71                     (cons name args)
  72                     args)))
  73             #+sbcl sb-ext:*posix-argv*
  74             #+cmu ext:*command-line-strings*
  75             #+clisp (loop with argv = (ext:argv)
  76                           for i from 7 below (length argv)
  77                           collect (aref argv i))
  78             #+ecl (loop from i below (ext:argc) collect (ext:argv i))
  79             '("<unknown-script>"))
  80
  81         *program-name* (pathname-name (car *command-line*))))
  82
  83 ;;;--------------------------------------------------------------------------
  84 ;;; Fancy conditionals.
  85
  86 (eval-when (:compile-toplevel :load-toplevel :execute)
  87   (defun do-case2-like (kind vform clauses)
  88     "Helper function for `case2' and `ecase2'."
  89     (with-gensyms (scrutinee argument)
  90       `(multiple-value-bind (,scrutinee ,argument) ,vform
  91          (declare (ignorable ,argument))
  92          (,kind ,scrutinee
  93            ,@(mapcar (lambda (clause)
  94                        (destructuring-bind
  95                            (cases (&optional varx vary) &rest forms)
  96                            clause
  97                          `(,cases
  98                            ,@(if varx
  99                                  (list `(let ((,(or vary varx) ,argument)
 100                                               ,@(and vary
 101                                                      `((,varx ,scrutinee))))
 102                                           ,@forms))
 103                                  forms))))
 104                      clauses))))))
 105
 106 (defmacro case2 (vform &body clauses)
 107   "Switch based on the first value of a form, capturing the second value.
 108
 109    VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
 110    The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
 111    standard `case' clause has the form (CASES FORMS...).  The `case2' form
 112    evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
 113    order, just like `case'.  If there is a match, then the corresponding
 114    FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
 115    the SCRUTINEE (where specified).  Note the bizarre defaulting behaviour:
 116    ARGVAR is less optional than SCRUVAR."
 117   (do-case2-like 'case vform clauses))
 118
 119 (defmacro ecase2 (vform &body clauses)
 120   "Like `case2', but signals an error if no clause matches the SCRUTINEE."
 121   (do-case2-like 'ecase vform clauses))
 122
 123 ;;;--------------------------------------------------------------------------
 124 ;;; Locatives.
 125
 126 (export '(loc locp))
 127 (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
 128   "Locative data type.  See `locf' and `ref'."
 129   (reader nil :type function)
 130   (writer nil :type function))
 131
 132 (export 'locf)
 133 (defmacro locf (place &environment env)
 134   "Slightly cheesy locatives.
 135
 136    (locf PLACE) returns an object which, using the `ref' function, can be
 137    used to read or set the value of PLACE.  It's cheesy because it uses
 138    closures rather than actually taking the address of something.  Also,
 139    unlike Zetalisp, we don't overload `car' to do our dirty work."
 140   (multiple-value-bind
 141       (valtmps valforms newtmps setform getform)
 142       (get-setf-expansion place env)
 143     `(let* (,@(mapcar #'list valtmps valforms))
 144        (make-loc (lambda () ,getform)
 145                  (lambda (,@newtmps) ,setform)))))
 146
 147 (export 'ref)
 148 (declaim (inline ref (setf ref)))
 149 (defun ref (loc)
 150   "Fetch the value referred to by a locative."
 151   (funcall (loc-reader loc)))
 152 (defun (setf ref) (new loc)
 153   "Store a new value in the place referred to by a locative."
 154   (funcall (loc-writer loc) new))
 155
 156 (export 'with-locatives)
 157 (defmacro with-locatives (locs &body body)
 158   "Evaluate BODY with implicit locatives.
 159
 160    LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
 161    symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
 162    defaults to SYM.  As an abbreviation for a common case, LOCS may be a
 163    symbol instead of a list.
 164
 165    The BODY is evaluated in an environment where each SYM is a symbol macro
 166    which expands to (ref LOC-EXPR) -- or, in fact, something similar which
 167    doesn't break if LOC-EXPR has side-effects.  Thus, references, including
 168    `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
 169    Useful for covering over where something uses a locative."
 170   (setf locs (mapcar (lambda (item)
 171                        (cond ((atom item) (list item item))
 172                              ((null (cdr item)) (list (car item) (car item)))
 173                              (t item)))
 174                      (if (listp locs) locs (list locs))))
 175   (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
 176         (ll (mapcar #'cadr locs))
 177         (ss (mapcar #'car locs)))
 178     `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
 179        (symbol-macrolet (,@(mapcar (lambda (sym tmp)
 180                                      `(,sym (ref ,tmp))) ss tt))
 181          ,@body))))
 182
 183 ;;;--------------------------------------------------------------------------
 184 ;;; Standard error-reporting functions.
 185
 186 (export 'moan)
 187 (defun moan (msg &rest args)
 188   "Report an error message in the usual way."
 189   (format *error-output* "~&~A: ~?~%" *program-name* msg args))
 190
 191 (export 'die)
 192 (defun die (&rest args)
 193   "Report an error message and exit."
 194   (apply #'moan args)
 195   (exit 1))
 196
 197 ;;;--------------------------------------------------------------------------
 198 ;;; The main option parser.
 199
 200 (export '*options*)
 201 (defvar *options* nil
 202   "The default list of command-line options.")
 203
 204 (export '(option optionp make-option
 205           opt-short-name opt-long-name opt-tag opt-negated-tag
 206           opt-arg-name opt-arg-optional-p opt-documentation))
 207 (defstruct (option
 208              (:predicate optionp)
 209              (:conc-name opt-)
 210              (:print-function
 211               (lambda (o s k)
 212                 (declare (ignore k))
 213                 (print-unreadable-object (o s :type t)
 214                   (format s "~@[-~C, ~]~@[--~A~]~
 215                              ~*~@[~2:*~:[=~A~;[=~A]~]~]~
 216                              ~@[ ~S~]"
 217                           (opt-short-name o)
 218                           (opt-long-name o)
 219                           (opt-arg-optional-p o)
 220                           (opt-arg-name o)
 221                           (opt-documentation o)))))
 222              (:constructor %make-option)
 223              (:constructor make-option
 224                  (long-name short-name
 225                   &optional arg-name
 226                   &key (tag (intern (string-upcase long-name) :keyword))
 227                        negated-tag
 228                        arg-optional-p
 229                        doc (documentation doc))))
 230   "Describes a command-line option.  Slots:
 231
 232    LONG-NAME    The option's long name.  If this is null, the `option' is
 233                 just a banner to be printed in the program's help text.
 234
 235    TAG          The value to be returned if this option is encountered.  If
 236                 this is a function, instead, the function is called with the
 237                 option's argument or nil.
 238
 239    NEGATED-TAG  As for TAG, but used if the negated form of the option is
 240                 found.  If this is nil (the default), the option cannot be
 241                 negated.
 242
 243    SHORT-NAME   The option's short name.  This must be a single character, or
 244                 nil if the option has no short name.
 245
 246    ARG-NAME     The name of the option's argument, a string.  If this is nil,
 247                 the option doesn't accept an argument.  The name is shown in
 248                 the help text.
 249
 250    ARG-OPTIONAL-P
 251                 If non-nil, the option's argument is optional.  This is
 252                 ignored unless ARG-NAME is non-null.
 253
 254    DOCUMENTATION
 255                 The help text for this option.  It is automatically line-
 256                 wrapped.  If nil, the option is omitted from the help
 257                 text.
 258
 259    Usually, one won't use make-option, but use the option macro instead."
 260   (long-name nil :type (or null string))
 261   (tag nil :type t)
 262   (negated-tag nil :type t)
 263   (short-name nil :type (or null character))
 264   (arg-name nil :type (or null string))
 265   (arg-optional-p nil :type t)
 266   (documentation nil :type (or null string)))
 267
 268 (export '(option-parser option-parser-p make-option-parser
 269           op-options op-non-option op-long-only-p op-numeric-p
 270           op-negated-numeric-p op-negated-p))
 271 (defstruct (option-parser
 272              (:conc-name op-)
 273              (:constructor make-option-parser
 274                  (&key ((:args argstmp) (cdr *command-line*))
 275                        (options *options*)
 276                        (non-option :skip)
 277                        ((:numericp numeric-p))
 278                        negated-numeric-p
 279                        long-only-p
 280                   &aux (args (cons nil argstmp))
 281                        (next args)
 282                        (negated-p (or negated-numeric-p
 283                                       (some #'opt-negated-tag
 284                                             options))))))
 285   "An option parser object.  Slots:
 286
 287    ARGS         The arguments to be parsed.  Usually this will be
 288                 *command-line*.
 289
 290    OPTIONS      List of option structures describing the acceptable options.
 291
 292    NON-OPTION   Behaviour when encountering a non-option argument.  The
 293                 default is :skip.  Allowable values are:
 294                   :skip -- pretend that it appeared after the option
 295                     arguments; this is the default behaviour of GNU getopt
 296                   :stop -- stop parsing options, leaving the remaining
 297                     command line unparsed
 298                   :return -- return :non-option and the argument word
 299
 300    NUMERIC-P    Non-nil tag (as for options) if numeric options (e.g., -43)
 301                 are to be allowed.  The default is nil.  (Anomaly: the
 302                 keyword for this argument is :numericp.)
 303
 304    NEGATED-NUMERIC-P
 305                 Non-nil tag (as for options) if numeric options (e.g., -43)
 306                 can be negated.  This is not the same thing as a negative
 307                 numeric option!
 308
 309    LONG-ONLY-P  A misnomer inherited from GNU getopt.  Whether to allow
 310                 long options to begin with a single dash.  Short options are
 311                 still allowed, and may be cuddled as usual.  The default is
 312                 nil."
 313   (args nil :type list)
 314   (options nil :type list)
 315   (non-option :skip :type (or function (member :skip :stop :return)))
 316   (next nil :type list)
 317   (short-opt nil :type (or null string))
 318   (short-opt-index 0 :type fixnum)
 319   (short-opt-neg-p nil :type t)
 320   (long-only-p nil :type t)
 321   (numeric-p nil :type t)
 322   (negated-numeric-p nil :type t)
 323   (negated-p nil :type t))
 324
 325 (export 'option-parse-error)
 326 (define-condition option-parse-error (error simple-condition)
 327   ()
 328   (:documentation
 329    "Indicates an error found while parsing options.
 330
 331    Probably not that useful."))
 332
 333 (defun option-parse-error (msg &rest args)
 334   "Signal an option-parse-error with the given message and arguments."
 335   (error (make-condition 'option-parse-error
 336                          :format-control msg
 337                          :format-arguments args)))
 338
 339 (export 'option-parse-remainder)
 340 (defun option-parse-remainder (op)
 341   "Returns the unparsed remainder of the command line."
 342   (cdr (op-args op)))
 343
 344 (export 'option-parse-return)
 345 (defun option-parse-return (tag &optional argument)
 346   "Force a return from `option-parse-next' with TAG and ARGUMENT.
 347
 348    This should only be called from an option handler."
 349   (throw 'option-parse-return (values tag argument)))
 350
 351 (export 'option-parse-next)
 352 (defun option-parse-next (op)
 353   "Parse and handle the next option from the command-line.
 354
 355    This is the main option-parsing function.  OP is an option-parser object,
 356    initialized appropriately.  Returns two values, OPT and ARG: OPT is the
 357    tag of the next option read, and ARG is the argument attached to it, or
 358    nil if there was no argument.  If there are no more options, returns nil
 359    twice.  Options whose TAG is a function aren't returned; instead, the tag
 360    function is called, with the option argument (or nil) as the only
 361    argument.  It is safe for tag functions to throw out of
 362    `option-parse-next', if they desparately need to.  (This is the only way
 363    to actually get `option-parse-next' to return a function value, should
 364    that be what you want.  See `option-parse-return' for a way of doing
 365    this.)
 366
 367    While `option-parse-next' is running, there is a restart `skip-option'
 368    which moves on to the next option.  Error handlers should use this to
 369    resume after parsing errors."
 370   (labels ((ret (opt &optional arg)
 371              (return-from option-parse-next (values opt arg)))
 372            (finished ()
 373              (setf (op-next op) nil)
 374              (ret nil nil))
 375            (peek-arg ()
 376              (cadr (op-next op)))
 377            (more-args-p ()
 378              (and (op-next op)
 379                   (cdr (op-next op))))
 380            (skip-arg ()
 381              (setf (op-next op) (cdr (op-next op))))
 382            (eat-arg ()
 383              (setf (cdr (op-next op)) (cddr (op-next op))))
 384            (get-arg ()
 385              (prog1 (peek-arg) (eat-arg)))
 386
 387            (process-option (o name negp &key arg argfunc)
 388              (cond ((not (opt-arg-name o))
 389                     (when arg
 390                       (option-parse-error
 391                        "Option `~A' does not accept arguments"
 392                        name)))
 393                    (arg)
 394                    (argfunc
 395                     (setf arg (funcall argfunc)))
 396                    ((opt-arg-optional-p o))
 397                    ((more-args-p)
 398                     (setf arg (get-arg)))
 399                    (t
 400                     (option-parse-error "Option `~A' requires an argument"
 401                                         name)))
 402              (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
 403                (if (functionp how)
 404                    (funcall how arg)
 405                    (ret how arg))))
 406
 407            (process-long-option (arg start negp)
 408              (when (and (not negp)
 409                         (op-negated-p op)
 410                         (> (length arg) (+ start 3))
 411                         (string= arg "no-"
 412                                  :start1 start :end1 (+ start 3)))
 413                (incf start 3)
 414                (setf negp t))
 415              (let* ((matches nil)
 416                     (eqpos (position #\= arg :start start))
 417                     (len (or eqpos (length arg)))
 418                     (optname (subseq arg 0 len))
 419                     (len-2 (- len start)))
 420                (dolist (o (op-options op))
 421                  (cond ((or (not (stringp (opt-long-name o)))
 422                             (and negp (not (opt-negated-tag o)))
 423                             (< (length (opt-long-name o)) len-2)
 424                             (string/= optname (opt-long-name o)
 425                                       :start1 start :end2 len-2)))
 426                        ((= (length (opt-long-name o)) len-2)
 427                         (setf matches (list o))
 428                         (return))
 429                        (t
 430                         (push o matches))))
 431                (cond ((null matches)
 432                       (option-parse-error "Unknown option `~A'" optname))
 433                      ((cdr matches)
 434                       (option-parse-error
 435                        #.(concatenate 'string
 436                                       "Ambiguous long option `~A' -- "
 437                                       "could be any of:"
 438                                       "~{~%~8T--~A~}")
 439                        optname
 440                        (mapcar #'opt-long-name matches))))
 441                (process-option (car matches)
 442                                optname
 443                                negp
 444                                :arg (and eqpos
 445                                          (subseq arg (1+ eqpos)))))))
 446
 447     (catch 'option-parse-return
 448       (loop
 449         (with-simple-restart (skip-option "Skip this bogus option.")
 450           (cond
 451             ;;
 452             ;; We're embroiled in short options: handle them.
 453             ((op-short-opt op)
 454              (if (>= (op-short-opt-index op) (length (op-short-opt op)))
 455                  (setf (op-short-opt op) nil)
 456                  (let* ((str (op-short-opt op))
 457                         (i (op-short-opt-index op))
 458                         (ch (char str i))
 459                         (negp (op-short-opt-neg-p op))
 460                         (name (format nil "~C~A" (if negp #\+ #\-) ch))
 461                         (o (find ch (op-options op) :key #'opt-short-name)))
 462                    (incf i)
 463                    (setf (op-short-opt-index op) i)
 464                    (when (or (not o)
 465                              (and negp (not (opt-negated-tag o))))
 466                      (option-parse-error "Unknown option `~A'" name))
 467                    (process-option o
 468                                    name
 469                                    negp
 470                                    :argfunc
 471                                    (and (< i (length str))
 472                                         (lambda ()
 473                                           (prog1
 474                                               (subseq str i)
 475                                             (setf (op-short-opt op)
 476                                                   nil))))))))
 477             ;;
 478             ;; End of the list.  Say we've finished.
 479             ((not (more-args-p))
 480              (finished))
 481             ;;
 482             ;; Process the next option.
 483             (t
 484              (let ((arg (peek-arg)))
 485                (cond
 486                  ;;
 487                  ;; Non-option.  Decide what to do.
 488                  ((or (<= (length arg) 1)
 489                       (and (char/= (char arg 0) #\-)
 490                            (or (char/= (char arg 0) #\+)
 491                                (not (op-negated-p op)))))
 492                   (case (op-non-option op)
 493                     (:skip (skip-arg))
 494                     (:stop (finished))
 495                     (:return (eat-arg)
 496                              (ret :non-option arg))
 497                     (t (eat-arg)
 498                        (funcall (op-non-option op) arg))))
 499                  ;;
 500                  ;; Double-hyphen.  Stop right now.
 501                  ((string= arg "--")
 502                   (eat-arg)
 503                   (finished))
 504                  ;;
 505                  ;; Numbers.  Check these before long options, since `--43'
 506                  ;; is not a long option.
 507                  ((and (op-numeric-p op)
 508                        (or (char= (char arg 0) #\-)
 509                            (op-negated-numeric-p op))
 510                        (or (and (digit-char-p (char arg 1))
 511                                 (every #'digit-char-p (subseq arg 2)))
 512                            (and (or (char= (char arg 1) #\-)
 513                                     (char= (char arg 1) #\+))
 514                                 (>= (length arg) 3)
 515                                 (digit-char-p (char arg 2))
 516                                 (every #'digit-char-p (subseq arg 3)))))
 517                   (eat-arg)
 518                   (let ((negp (char= (char arg 0) #\+))
 519                         (num (parse-integer arg :start 1)))
 520                     (when (and negp (eq (op-negated-numeric-p op) :-))
 521                       (setf num (- num))
 522                       (setf negp nil))
 523                     (let ((how (if negp
 524                                    (op-negated-numeric-p op)
 525                                    (op-numeric-p op))))
 526                       (if (functionp how)
 527                           (funcall how num)
 528                           (ret (if negp :negated-numeric :numeric) num)))))
 529                  ;;
 530                  ;; Long option.  Find the matching option-spec and process
 531                  ;; it.
 532                  ((and (char= (char arg 0) #\-)
 533                        (char= (char arg 1) #\-))
 534                   (eat-arg)
 535                   (process-long-option arg 2 nil))
 536                  ;;
 537                  ;; Short options.  All that's left.
 538                  (t
 539                   (eat-arg)
 540                   (let ((negp (char= (char arg 0) #\+))
 541                         (ch (char arg 1)))
 542                     (cond ((and (op-long-only-p op)
 543                                 (not (member ch (op-options op)
 544                                              :key #'opt-short-name)))
 545                            (process-long-option arg 1 negp))
 546                           (t
 547                            (setf (op-short-opt op) arg
 548                                  (op-short-opt-index op) 1
 549                                  (op-short-opt-neg-p op) negp))))))))))))))
 550
 551 (export 'option-parse-try)
 552 (defmacro option-parse-try (&body body)
 553   "Report errors encountered while parsing options, and try to continue.
 554
 555    Also establishes a restart `stop-parsing'.  Returns t if parsing completed
 556    successfully, or nil if errors occurred."
 557   (with-gensyms (retcode)
 558     `(let ((,retcode t))
 559        (restart-case
 560            (handler-bind
 561                ((option-parse-error
 562                  (lambda (cond)
 563                    (setf ,retcode nil)
 564                    (moan "~A" cond)
 565                    (dolist (rn '(skip-option stop-parsing))
 566                      (let ((r (find-restart rn)))
 567                        (when r (invoke-restart r)))))))
 568              ,@body)
 569          (stop-parsing ()
 570            :report "Give up parsing options."
 571            (setf ,retcode nil)))
 572        ,retcode)))
 573
 574 (export 'with-unix-error-reporting)
 575 (defmacro with-unix-error-reporting ((&key) &body body)
 576   "Evaluate BODY with errors reported in the standard Unix fashion."
 577   (with-gensyms (cond)
 578     `(handler-case
 579          (progn ,@body)
 580        (simple-condition (,cond)
 581          (apply #'die
 582                 (simple-condition-format-control ,cond)
 583                 (simple-condition-format-arguments ,cond)))
 584        (error (,cond)
 585          (die "~A" ,cond)))))
 586
 587 ;;;--------------------------------------------------------------------------
 588 ;;; Standard option handlers.
 589
 590 (export 'defopthandler)
 591 (defmacro defopthandler (name (var &optional (arg (gensym)))
 592                          (&rest args)
 593                          &body body)
 594   "Define an option handler function NAME.
 595
 596    Option handlers update a generalized variable, which may be referred to as
 597    VAR in the BODY, based on some parameters (the ARGS) and the value of an
 598    option-argument named ARG."
 599   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
 600     (multiple-value-bind (docs decls body) (parse-body body)
 601       `(progn
 602          (setf (get ',name 'opthandler) ',func)
 603          (defun ,func (,var ,arg ,@args)
 604            ,@docs ,@decls
 605            (declare (ignorable ,arg))
 606            (with-locatives ,var
 607              ,@body))
 608          ',name))))
 609
 610 (defun parse-c-integer (string &key radix (start 0) end)
 611   "Parse (a substring of) STRING according to the standard C rules.
 612
 613    Well, almost: the 0 and 0x prefixes are accepted, but so too are
 614    0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted, for any
 615    radix between 2 and 36.  Prefixes are only accepted if RADIX is nil.
 616    Returns two values: the integer parsed (or nil if there wasn't enough for
 617    a sensible parse), and the index following the characters of the integer."
 618   (unless end (setf end (length string)))
 619   (labels ((simple (i r goodp sgn)
 620              (multiple-value-bind
 621                  (a i)
 622                  (if (and (< i end)
 623                           (digit-char-p (char string i) r))
 624                      (parse-integer string
 625                                     :start i :end end
 626                                     :radix r
 627                                     :junk-allowed t)
 628                      (values nil i))
 629                (values (if a (* sgn a) (and goodp 0)) i)))
 630
 631            (get-radix (i r sgn)
 632              (cond (r (simple i r nil sgn))
 633                    ((>= i end) (values nil i))
 634                    ((and (char= (char string i) #\0)
 635                          (>= (- end i) 2))
 636                     (case (char string (1+ i))
 637                       (#\x (simple (+ i 2) 16 nil sgn))
 638                       (#\o (simple (+ i 2) 8 nil sgn))
 639                       (#\b (simple (+ i 2) 2 nil sgn))
 640                       (t (simple (1+ i) 8 t sgn))))
 641                    (t
 642                     (multiple-value-bind
 643                         (r i)
 644                         (simple i 10 nil +1)
 645                       (cond ((not r) (values nil i))
 646                             ((and (< i end)
 647                                   (char= (char string i) #\_)
 648                                   (<= 2 r 36))
 649                              (simple (1+ i) r nil sgn))
 650                             (t
 651                              (values (* r sgn) i))))))))
 652
 653     (cond ((>= start end) (values nil start))
 654           ((char= (char string start) #\-)
 655            (get-radix (1+ start) radix -1))
 656           ((char= (char string start) #\+)
 657            (get-radix (1+ start) radix +1))
 658           (t
 659            (get-radix start radix +1)))))
 660
 661 (export 'invoke-option-handler)
 662 (defun invoke-option-handler (handler loc arg args)
 663   "Call HANDLER, giving it LOC to update, the option-argument ARG, and the
 664    remaining ARGS."
 665   (apply (if (functionp handler) handler
 666              (fdefinition (get handler 'opthandler)))
 667          loc arg args))
 668
 669 ;;;--------------------------------------------------------------------------
 670 ;;; Built-in option handlers.
 671
 672 (export 'set)
 673 (defopthandler set (var) (&optional (value t))
 674   "Sets VAR to VALUE; defaults to t."
 675   (setf var value))
 676
 677 (export 'clear)
 678 (defopthandler clear (var) (&optional (value nil))
 679   "Sets VAR to VALUE; defaults to nil."
 680   (setf var value))
 681
 682 (export 'inc)
 683 (defopthandler inc (var) (&optional max (step 1))
 684   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
 685    nil for no maximum).  No errors are signalled."
 686   (incf var step)
 687   (when (and max (>= var max))
 688     (setf var max)))
 689
 690 (export 'dec)
 691 (defopthandler dec (var) (&optional min (step 1))
 692   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
 693    for no maximum).  No errors are signalled."
 694   (decf var step)
 695   (when (and min (<= var min))
 696     (setf var min)))
 697
 698 (export 'read)
 699 (defopthandler read (var arg) ()
 700   "Stores in VAR the Lisp object found by reading the ARG.
 701
 702    Evaluation is forbidden while reading ARG.  If there is an error during
 703    reading, an error of type option-parse-error is signalled."
 704   (handler-case
 705       (let ((*read-eval* nil))
 706         (multiple-value-bind (x end) (read-from-string arg t)
 707           (unless (>= end (length arg))
 708             (option-parse-error "Junk at end of argument `~A'" arg))
 709           (setf var x)))
 710     (error (cond)
 711       (option-parse-error (format nil "~A" cond)))))
 712
 713 (export 'int)
 714 (defopthandler int (var arg) (&key radix min max)
 715   "Stores in VAR the integer read from the ARG.
 716
 717    Integers are parsed according to C rules, which is normal in Unix; the
 718    RADIX may be nil to allow radix prefixes, or an integer between 2 and 36.
 719    An option-parse-error is signalled if the ARG is not a valid integer, or
 720    if it is not between MIN and MAX (either of which may be nil if no lower
 721    resp. upper bound is wanted)."
 722   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
 723     (unless (and v (>= end (length arg)))
 724       (option-parse-error "Bad integer `~A'" arg))
 725     (when (or (and min (< v min))
 726               (and max (> v max)))
 727       (option-parse-error
 728        #.(concatenate 'string
 729                       "Integer ~A out of range "
 730                       "(must have ~@[~D <= ~]x~@[ <= ~D~])")
 731        arg min max))
 732     (setf var v)))
 733
 734 (export 'string)
 735 (defopthandler string (var arg) ()
 736   "Stores ARG in VAR, just as it is."
 737   (setf var arg))
 738
 739 (export 'keyword)
 740 (defopthandler keyword (var arg) (&optional (valid t))
 741   "Converts ARG into a keyword.
 742
 743    If VALID is t, then any ARG string is acceptable: the argument is
 744    uppercased and interned in the keyword package.  If VALID is a list, then
 745    we ensure that ARG matches one of the elements of the list; unambigious
 746    abbreviations are allowed."
 747   (etypecase valid
 748     ((member t)
 749      (setf var (intern (string-upcase arg) :keyword)))
 750     (list
 751      (let ((matches nil)
 752            (guess (string-upcase arg))
 753            (len (length arg)))
 754        (dolist (k valid)
 755          (let* ((kn (symbol-name k))
 756                 (klen (length kn)))
 757            (cond ((string= kn guess)
 758                   (setf matches (list k))
 759                   (return))
 760                  ((and (< len klen)
 761                        (string= guess kn :end2 len))
 762                   (push k matches)))))
 763        (cond
 764          ((null matches)
 765           (option-parse-error #.(concatenate 'string
 766                                              "Argument `~A' invalid: "
 767                                              "must be one of:"
 768                                              "~{~%~8T~(~A~)~}")
 769                               arg valid))
 770          ((null (cdr matches))
 771           (setf var (car matches)))
 772          (t
 773           (option-parse-error #.(concatenate 'string
 774                                              "Argument `~A' ambiguous: "
 775                                              "may be any of:"
 776                                              "~{~%~8T~(~A~)~}")
 777                               arg matches)))))))
 778
 779 (export 'list)
 780 (defopthandler list (var arg) (&optional handler &rest handler-args)
 781   "Collect ARGs in a list at VAR.
 782
 783    ARGs are translated by the HANDLER first, if specified.  If not, it's as
 784    if you asked for `string'."
 785   (when handler
 786     (invoke-option-handler handler (locf arg) arg handler-args))
 787   (setf var (nconc var (list arg))))
 788
 789 ;;;--------------------------------------------------------------------------
 790 ;;; Option descriptions.
 791
 792 (export 'defoptmacro)
 793 (defmacro defoptmacro (name args &body body)
 794   "Defines an option macro NAME.
 795
 796    Option macros should produce a list of expressions producing one option
 797    structure each."
 798   `(progn
 799      (setf (get ',name 'optmacro) (lambda ,args ,@body))
 800      ',name))
 801
 802 (export 'parse-option-form)
 803 (eval-when (:compile-toplevel :load-toplevel :execute)
 804   (defun parse-option-form (form)
 805     "Does the heavy lifting for parsing an option form.
 806
 807    See the docstring for the `option' macro for details of the syntax."
 808   (flet ((doc (form)
 809            (cond ((stringp form) form)
 810                  ((null (cdr form)) (car form))
 811                  (t `(format nil ,@form))))
 812          (docp (form)
 813            (or (stringp form)
 814                (and (consp form)
 815                     (stringp (car form))))))
 816     (cond ((stringp form)
 817            `(%make-option :documentation ,form))
 818           ((not (listp form))
 819            (error "option form must be string or list"))
 820           ((and (docp (car form)) (null (cdr form)))
 821            `(%make-option :documentation ,(doc (car form))))
 822           (t
 823            (let (long-name short-name
 824                  arg-name arg-optional-p
 825                  tag negated-tag
 826                  doc)
 827              (dolist (f form)
 828                (cond ((and (or (not tag) (not negated-tag))
 829                            (or (keywordp f)
 830                                (and (consp f)
 831                                     (member (car f) '(lambda function)))))
 832                       (if tag
 833                           (setf negated-tag f)
 834                           (setf tag f)))
 835                      ((and (not long-name)
 836                            (or (rationalp f)
 837                                (symbolp f)
 838                                (stringp f)))
 839                       (setf long-name (if (stringp f) f
 840                                           (format nil "~(~A~)" f))))
 841                      ((and (not short-name)
 842                            (characterp f))
 843                       (setf short-name f))
 844                      ((and (not doc)
 845                            (docp f))
 846                       (setf doc (doc f)))
 847                      ((and (consp f) (symbolp (car f)))
 848                       (case (car f)
 849                         (:short-name (setf short-name (cadr f)))
 850                         (:long-name (setf long-name (cadr f)))
 851                         (:tag (setf tag (cadr f)))
 852                         (:negated-tag (setf negated-tag (cadr f)))
 853                         (:arg (setf arg-name (cadr f)))
 854                         (:opt-arg (setf arg-name (cadr f))
 855                                   (setf arg-optional-p t))
 856                         (:doc (setf doc (doc (cdr f))))
 857                         (t (let ((handler (get (car f) 'opthandler)))
 858                              (unless handler
 859                                (error "No handler `~S' defined." (car f)))
 860                              (let* ((var (cadr f))
 861                                     (arg (gensym))
 862                                     (thunk `#'(lambda (,arg)
 863                                                 (,handler (locf ,var)
 864                                                           ,arg
 865                                                           ,@(cddr f)))))
 866                                (if tag
 867                                    (setf negated-tag thunk)
 868                                    (setf tag thunk)))))))
 869                      (t
 870                       (error "Unexpected thing ~S in option form." f))))
 871              `(make-option ,long-name ,short-name ,arg-name
 872                            ,@(and arg-optional-p `(:arg-optional-p t))
 873                            ,@(and tag `(:tag ,tag))
 874                            ,@(and negated-tag `(:negated-tag ,negated-tag))
 875                            ,@(and doc `(:documentation ,doc)))))))))
 876
 877 (export 'options)
 878 (defmacro options (&rest optlist)
 879   "More convenient way of initializing options.  The OPTLIST is a list of
 880    OPTFORMS.  Each OPTFORM is one of the following:
 881
 882    STRING       A banner to print.
 883
 884    SYMBOL or (SYMBOL STUFF...)
 885                 If SYMBOL is an optform macro, the result of invoking it.
 886
 887    (...)        A full option-form.  See below.
 888
 889    Full option-forms are a list of the following kinds of items.
 890
 891    (:short-name CHAR)
 892    (:long-name STRING)
 893    (:arg STRING)
 894    (:tag TAG)
 895    (:negated-tag TAG)
 896    (:doc STRING)
 897                 Set the appropriate slot of the option to the given value.
 898                 The argument is evaluated.
 899
 900    (:doc FORMAT-CONTROL ARGUMENTS...)
 901                 As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
 902
 903    KEYWORD, (function ...), (lambda ...)
 904                 If no TAG is set yet, then as a TAG; otherwise as the
 905                 NEGATED-TAG.
 906
 907    STRING (or SYMBOL or RATIONAL)
 908                 If no LONG-NAME seen yet, then the LONG-NAME.  For symbols
 909                 and rationals, the item is converted to a string and squashed
 910                 to lower-case.
 911
 912    CHARACTER    If no SHORT-NAME, then the SHORT-NAME.
 913
 914    STRING or (STRING STUFF...)
 915                 If no DOCUMENTATION set yet, then the DOCUMENTATION string,
 916                 as for (:doc STRING STUFF...)
 917
 918    (:opt-arg NAME)
 919                 Set the ARG-NAME, and also set ARG-OPTIONAL-P.
 920
 921    (HANDLER VAR ARGS...)
 922                 If no TAG is set yet, attach the HANDLER to this option,
 923                 giving it ARGS.  Otherwise, set the NEGATED-TAG."
 924
 925   `(list ,@(mapcan (lambda (form)
 926                      (multiple-value-bind
 927                          (sym args)
 928                          (cond ((symbolp form) (values form nil))
 929                                ((and (consp form) (symbolp (car form)))
 930                                 (values (car form) (cdr form)))
 931                                (t (values nil nil)))
 932                        (let ((macro (and sym (get sym 'optmacro))))
 933                          (if macro
 934                              (apply macro args)
 935                              (list (parse-option-form form))))))
 936                    optlist)))
 937
 938 ;;;--------------------------------------------------------------------------
 939 ;;; Support stuff for help and usage messages.
 940
 941 (defun print-text (string
 942                    &optional
 943                    (stream *standard-output*)
 944                    &key
 945                    (start 0)
 946                    (end nil))
 947   "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
 948    newlines in the obvious way.  Stuff between square brackets is not broken:
 949    this makes usage messages work better."
 950   (let ((i start)
 951         (nest 0)
 952         (splitp nil))
 953     (flet ((emit ()
 954              (write-string string stream :start start :end i)
 955              (setf start i)))
 956       (unless end (setf end (length string)))
 957       (loop
 958          (unless (< i end)
 959            (emit)
 960            (return))
 961          (let ((ch (char string i)))
 962            (cond ((char= ch #\newline)
 963                   (emit)
 964                   (incf start)
 965                   (pprint-newline :mandatory stream))
 966                  ((whitespace-char-p ch)
 967                   (when (zerop nest)
 968                     (setf splitp t)))
 969                  (t
 970                   (when splitp
 971                     (emit)
 972                     (pprint-newline :fill stream))
 973                   (setf splitp nil)
 974                   (case ch
 975                     (#\[ (incf nest))
 976                     (#\] (when (plusp nest) (decf nest))))))
 977            (incf i))))))
 978
 979 (export 'simple-usage)
 980 (defun simple-usage (opts &optional mandatory-args)
 981   "Build a simple usage list from a list of options, and (optionally)
 982    mandatory argument names."
 983   (let (short-simple long-simple short-arg long-arg)
 984     (dolist (o opts)
 985       (cond ((not (and (opt-documentation o)
 986                        (opt-long-name o))))
 987             ((and (opt-short-name o) (opt-arg-name o))
 988              (push o short-arg))
 989             ((opt-short-name o)
 990              (push o short-simple))
 991             ((opt-arg-name o)
 992              (push o long-arg))
 993             (t
 994              (push o long-simple))))
 995     (list
 996      (nconc (and short-simple
 997                  (list (format nil "[-~{~C~}]"
 998                                (sort (mapcar #'opt-short-name short-simple)
 999                                      #'char<))))
1000             (and long-simple
1001                  (mapcar (lambda (o)
1002                            (format nil "[--~A]" (opt-long-name o)))
1003                          (sort long-simple #'string< :key #'opt-long-name)))
1004             (and short-arg
1005                  (mapcar (lambda (o)
1006                            (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
1007                                    (opt-arg-optional-p o)
1008                                    (opt-short-name o)
1009                                    (opt-arg-name o)))
1010                          (sort short-arg #'char-lessp
1011                                :key #'opt-short-name)))
1012             (and long-arg
1013                  (mapcar (lambda (o)
1014                            (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
1015                                    (opt-arg-optional-p o)
1016                                    (opt-long-name o)
1017                                    (opt-arg-name o)))
1018                          (sort long-arg #'string-lessp
1019                                :key #'opt-long-name)))
1020             (if (listp mandatory-args)
1021                 mandatory-args
1022                 (list mandatory-args))))))
1023
1024 (export 'show-usage)
1025 (defun show-usage (prog usage &optional (stream *standard-output*))
1026   "Basic usage-showing function.
1027
1028    PROG is the program name, probably from `*program-name*'.  USAGE is a list
1029    of possible usages of the program, each of which is a list of items to be
1030    supplied by the user.  In simple cases, a single string is sufficient."
1031   (pprint-logical-block (stream nil :prefix "Usage: ")
1032     (dolist (u (if (listp usage) usage (list usage)))
1033       (pprint-logical-block (stream nil
1034                                     :prefix (concatenate 'string prog " "))
1035         (format stream "~{~A~^ ~:_~}" (if (listp u) u (list u))))))
1036   (terpri stream))
1037
1038 (defun show-options-help (opts &optional (stream *standard-output*))
1039   "Write help for OPTS to the STREAM.
1040
1041    This is the core of the `show-help' function."
1042   (let (newlinep)
1043     (dolist (o opts)
1044       (let ((doc (opt-documentation o)))
1045         (cond ((not o))
1046               ((not (opt-long-name o))
1047                (when newlinep
1048                  (terpri stream)
1049                  (setf newlinep nil))
1050                (pprint-logical-block (stream nil)
1051                  (print-text doc stream))
1052                (terpri stream))
1053               (t
1054                (setf newlinep t)
1055                (pprint-logical-block (stream nil :prefix "  ")
1056                  (format stream "~:[   ~;-~:*~C,~] --~A"
1057                          (opt-short-name o)
1058                          (opt-long-name o))
1059                  (when (opt-arg-name o)
1060                    (format stream "~:[=~A~;[=~A]~]"
1061                            (opt-arg-optional-p o)
1062                            (opt-arg-name o)))
1063                  (write-string "  " stream)
1064                  (pprint-tab :line 30 1 stream)
1065                  (pprint-indent :block 30 stream)
1066                  (print-text doc stream))
1067                (terpri stream)))))))
1068
1069 (export 'show-help)
1070 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
1071   "Basic help-showing function.
1072
1073    PROG is the program name, probably from `*program-name*'.  VER is the
1074    program's version number.  USAGE is a list of the possible usages of the
1075    program, each of which may be a list of items to be supplied.  OPTS is the
1076    list of supported options, as provided to the options parser.  STREAM is
1077    the stream to write on."
1078   (format stream "~A, version ~A~2%" prog ver)
1079   (show-usage prog usage stream)
1080   (terpri stream)
1081   (show-options-help opts stream))
1082
1083 (export 'sanity-check-option-list)
1084 (defun sanity-check-option-list (opts)
1085   "Check the option list OPTS for basic sanity.  Reused short and long option
1086    names are diagnosed.  Maybe other problems will be reported later.
1087    Returns a list of warning strings."
1088   (let ((problems nil)
1089         (longs (make-hash-table :test #'equal))
1090         (shorts (make-hash-table)))
1091     (flet ((problem (msg &rest args)
1092              (push (apply #'format nil msg args) problems)))
1093       (dolist (o opts)
1094         (push o (gethash (opt-long-name o) longs))
1095         (push o (gethash (opt-short-name o) shorts)))
1096       (maphash (lambda (k v)
1097                  (when (and k (cdr v))
1098                    (problem "Long name `--~A' reused in ~S" k v)))
1099                longs)
1100       (maphash (lambda (k v)
1101                  (when (and k (cdr v))
1102                    (problem "Short name `-~C' reused in ~S" k v)))
1103                shorts)
1104       problems)))
1105
1106 ;;;--------------------------------------------------------------------------
1107 ;;; Full program descriptions.
1108
1109 (export '(*help* *version* *usage*))
1110 (defvar *help* nil "Help text describing the program.")
1111 (defvar *version* "<unreleased>" "The program's version number.")
1112 (defvar *usage* nil "A usage summary string")
1113
1114 (export 'do-usage)
1115 (defun do-usage (&optional (stream *standard-output*))
1116   (show-usage *program-name* *usage* stream))
1117
1118 (export 'die-usage)
1119 (defun die-usage ()
1120   (do-usage *error-output*)
1121   (exit 1))
1122
1123 (defun opt-help (arg)
1124   (declare (ignore arg))
1125   (show-help *program-name* *version* *usage* *options*)
1126   (typecase *help*
1127     (string (terpri) (write-string *help*))
1128     (null nil)
1129     ((or function symbol) (terpri) (funcall *help*)))
1130   (format t "~&")
1131   (exit 0))
1132 (defun opt-version (arg)
1133   (declare (ignore arg))
1134   (format t "~A, version ~A~%" *program-name* *version*)
1135   (exit 0))
1136 (defun opt-usage (arg)
1137   (declare (ignore arg))
1138   (do-usage)
1139   (exit 0))
1140
1141 (export 'help-options)
1142 (defoptmacro help-options (&key (short-help #\h)
1143                                 (short-version #\v)
1144                                 (short-usage #\u))
1145   "Inserts a standard help options collection in an options list."
1146   (flet ((shortform (char)
1147            (and char (list char))))
1148     (mapcar
1149      #'parse-option-form
1150      `("Help options"
1151        (,@(shortform short-help) "help" #'opt-help
1152         "Show this help message.")
1153        (,@(shortform short-version) "version" #'opt-version
1154         ("Show ~A's version number." *program-name*))
1155        (,@(shortform short-usage) "usage" #'opt-usage
1156         ("Show a very brief usage summary for ~A." *program-name*))))))
1157
1158 (export 'define-program)
1159 (defun define-program (&key
1160                        (program-name nil progp)
1161                        (help nil helpp)
1162                        (version nil versionp)
1163                        (usage nil usagep)
1164                        (full-usage nil fullp)
1165                        (options nil optsp))
1166   "Sets up all the required things a program needs to have to parse options
1167    and respond to them properly."
1168   (when progp (setf *program-name* program-name))
1169   (when helpp (setf *help* help))
1170   (when versionp (setf *version* version))
1171   (when optsp (setf *options* options))
1172   (cond ((and usagep fullp) (error "conflicting options"))
1173         (usagep (setf *usage* (simple-usage *options* usage)))
1174         (fullp (setf *usage* full-usage))))
1175
1176 (export 'do-options)
1177 (defmacro do-options ((&key (parser '(make-option-parser)))
1178                       &body clauses)
1179   "Handy all-in-one options parser macro.
1180
1181    PARSER defaults to a new options parser using the preset default options
1182    structure.  The CLAUSES are `case2'-like clauses to match options, and
1183    must be exhaustive.  If there is a clause (nil (REST) FORMS...) then the
1184    FORMS are evaluated after parsing is done with REST bound to the remaining
1185    command-line arguments."
1186   (once-only (parser)
1187     `(progn
1188        (loop
1189          (,(if (find t clauses :key #'car) 'case2 'ecase2)
1190              (option-parse-next ,parser)
1191            ((nil) () (return))
1192            ,@(remove-if #'null clauses :key #'car)))
1193        ,@(let ((tail (find nil clauses :key #'car)))
1194            (and tail
1195                 (destructuring-bind ((&optional arg) &rest forms) (cdr tail)
1196                   (if arg
1197                       (list `(let ((,arg (option-parse-remainder ,parser)))
1198                               ,@forms))
1199                       forms)))))))
1200
1201 ;;;----- That's all, folks --------------------------------------------------