;;; Program environment things.
(export 'exit)
-(defun exit (&optional (code 0) &key abrupt)
- "End program, returning CODE to the caller."
- (declare (type (unsigned-byte 32) code))
- #.(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))
+(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>"
(export '(option optionp make-option
opt-short-name opt-long-name opt-tag opt-negated-tag
opt-arg-name opt-arg-optional-p opt-documentation))
-(defstruct (option
- (:predicate optionp)
- (:conc-name opt-)
- (:print-function
- (lambda (o s k)
- (declare (ignore k))
- (print-unreadable-object (o s :type t)
- (format s "~@[-~C, ~]~@[--~A~]~
+(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:
+ (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.
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)))
+ (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
;;;--------------------------------------------------------------------------
;;; Support stuff for help and usage messages.
-(defun print-text (string
- &optional (stream *standard-output*)
- &key (start 0) (end nil))
- "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
+(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))))))
+ (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)
~mdw / sod / commitdiff