;;;--------------------------------------------------------------------------
;;; 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.")
"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"))))))
-
+ (setf *command-line* (cons (uiop:argv0) uiop:*command-line-arguments*)
*program-name* (pathname-name (car *command-line*))))
;;;--------------------------------------------------------------------------
(defun die (&rest args)
"Report an error message and exit."
(apply #'moan args)
- (exit 1))
+ (uiop:quit 1))
;;;--------------------------------------------------------------------------
;;; The main option parser.
(lambda (o s k)
(declare (ignore k))
(print-unreadable-object (o s :type t)
- (format s "~@[-~C, ~]~@[--~A~]~
- ~*~@[~2:*~:[=~A~;[=~A]~]~]~
- ~@[ ~S~]"
+ (format s "~*~:[~2:*~:[~3*~@[~S~]~
+ ~;~
+ ~:*-~C~
+ ~2*~@[~:*~:[ ~A~;[~A]~]~]~
+ ~@[ ~S~]~]~
+ ~;~
+ ~2:*~@[-~C, ~]--~A~
+ ~*~@[~:*~:[=~A~;[=~A]~]~]~
+ ~@[ ~S~]~]"
(opt-short-name o)
(opt-long-name o)
(opt-arg-optional-p o)
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.
+ 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
+ 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-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
DOCUMENTATION
The help text for this option. It is automatically line-
- wrapped. If nil, the option is omitted from the help
+ wrapped. If `nil', the option is omitted from the help
text.
Usually, one won't use `make-option', but use the `option' macro instead."
(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))
+ 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)
+ (non-option (if (uiop:getenv "POSIXLY_CORRECT") :stop
+ :skip))
((:numericp numeric-p))
negated-numeric-p
long-only-p
NON-OPTION Behaviour when encountering a non-option argument. The
default is :skip. Allowable values are:
- :skip -- pretend that it appeared after the option
+ `:skip' -- pretend that it appeared after the option
arguments; this is the default behaviour of GNU getopt
- :stop -- stop parsing options, leaving the remaining
+ `:stop' -- stop parsing options, leaving the remaining
command line unparsed
- :return -- return :non-option and the argument word
+ `: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.)
+ 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-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."
+ `nil'."
(args nil :type list)
(%options nil :type list)
(non-option :skip :type (or function (member :skip :stop :return)))
Probably not that useful."))
(defun option-parse-error (msg &rest args)
- "Signal an option-parse-error with the given message and arguments."
+ "Signal an `option-parse-error' with the given message and arguments."
(error (make-condition 'option-parse-error
:format-control msg
:format-arguments args)))
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
+ `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
(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)))
(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) #\-)
(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)
(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)
(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."
+ 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
(let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
(multiple-value-bind (docs decls body) (parse-body body)
`(progn
- (setf (get ',name 'opthandler) ',func)
+ (setf (get ',name 'opthandler-function) ',func)
(defun ,func (,var ,arg ,@args)
,@docs ,@decls
(declare (ignorable ,arg))
(block ,name ,@body)))
',name))))
+(export 'opthandler)
+(defmethod documentation ((symbol symbol) (doc-type (eql 'opthandler)))
+ (let ((func (get symbol 'opthandler-function)))
+ (and func (documentation func 'function))))
+(defmethod (setf documentation)
+ (string (symbol symbol) (doc-type (eql 'opthandler)))
+ (let ((func (get symbol 'optmacro-function)))
+ (unless func (error "No option handler defined with name `~S'." symbol))
+ (setf (documentation func 'function) string)))
+
(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."
+ 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
(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."
+ "Call an option HANDLER.
+
+ The handler is invoked to update the locative LOC, given an
+ option-argument ARG, and the remaining ARGS."
(apply (if (functionp handler) handler
- (fdefinition (get handler 'opthandler)))
+ (fdefinition (get handler 'opthandler-function)))
loc arg args))
;;;--------------------------------------------------------------------------
(export 'set)
(defopthandler set (var) (&optional (value t))
- "Sets VAR to VALUE; defaults to 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."
+ "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."
+ "Increments VAR by STEP (defaults to 1).
+
+ If MAX is not `nil' then VAR will not be made larger than MAX. 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."
+ "Decrements VAR by STEP (defaults to 1).
+
+ If MIN is not `nil', then VAR will not be made smaller than MIN. No
+ errors are signalled."
(decf var step)
(when (and min (<= var min))
(setf var min)))
"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."
+ 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)
"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)."
+ 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))
(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
+ 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."
(defmacro defoptmacro (name args &body body)
"Defines an option macro NAME.
- Option macros should produce a list of expressions producing one option
+ 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)))
+ (setf (get ',name 'optmacro-function)
+ (lambda ,args
+ ,@docs ,@decls
+ (block ,name ,@body)))
',name)))
+(export 'optmacro)
+(defmethod documentation ((symbol symbol) (doc-type (eql 'optmacro)))
+ (let ((func (get symbol 'optmacro-function)))
+ (and func (documentation func t))))
+(defmethod (setf documentation)
+ (string (symbol symbol) (doc-type (eql 'optmacro)))
+ (let ((func (get symbol 'optmacro-function)))
+ (unless func (error "No option macro defined with name `~S'." symbol))
+ (setf (documentation func t) string)))
+
(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)))))))))
+ (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-function)))
+ (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:
+ "A 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.
((and (consp form) (symbolp (car form)))
(values (car form) (cdr form)))
(t (values nil nil)))
- (let ((macro (and sym (get sym 'optmacro))))
+ (let ((macro (and sym (get sym 'optmacro-function))))
(if macro
(apply macro args)
(list (parse-option-form form))))))
(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."
+ "Print and line-break STRING to a pretty-printed STREAM.
+
+ The string is broken 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))
(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."
+ "Build a simple usage list.
+
+ The usage list is constructed from a list OPTS of `option' values, and
+ a list MANDATORY-ARGS of mandatory argument names; the latter defaults to
+ `nil' if omitted."
(let (short-simple long-simple short-arg long-arg)
(dolist (o opts)
(cond ((not (and (opt-documentation o)
(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."
+ "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)))
(export 'die-usage)
(defun die-usage ()
(do-usage *error-output*)
- (exit 1))
+ (uiop:quit 1))
(defun opt-help (arg)
(declare (ignore arg))
(null nil)
((or function symbol) (terpri) (funcall *help*)))
(format t "~&")
- (exit 0))
+ (uiop:quit 0))
(defun opt-version (arg)
(declare (ignore arg))
(format t "~A, version ~A~%" *program-name* *version*)
- (exit 0))
+ (uiop:quit 0))
(defun opt-usage (arg)
(declare (ignore arg))
(do-usage)
- (exit 0))
+ (uiop:quit 0))
(export 'help-options)
(defoptmacro help-options (&key (short-help #\h)
(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."
+ "Sets up all the required things a program needs to have to parse options.
+
+ This is a simple shorthand for setting `*program-name*', `*help*',
+ `*version*', `*options*', and `*usage*' from the corresponding arguments.
+ If an argument is not given then the corresponding variable is left alone.
+
+ The USAGE argument should be a list of mandatory argument names to pass to
+ `simple-usage'; FULL-USAGE should be a complete usage-token list. An
+ error will be signalled if both USAGE and FULL-USAGE are provided."
(when progp (setf *program-name* program-name))
(when helpp (setf *help* help))
(when versionp (setf *version* version))
~mdw / sod / blobdiff