;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; 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
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-(cl:defpackage #:optparse
- (:use #:common-lisp #:sod-utilities))
+(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)
-(defun exit (&optional (code 0) &key abrupt)
- "End program, returning CODE to the caller."
- (declare (type (unsigned-byte 32) code))
- #+sbcl (sb-ext:exit :code code :abort abrupt)
- #+cmu (if abrupt
- (unix::void-syscall ("_exit" c-call:int) code)
- (ext:quit code))
- #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
- #+ecl (ext:quit code)
-
- #-(or sbcl cmu clisp ecl)
- (progn
- (unless (zerop code)
- (format *error-output*
- "~&Exiting unsuccessfully with code ~D.~%" code))
+(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*))
Set `*command-line*' and `*program-name*'."
(setf *command-line*
- (or (when (member :cl-launch *features*)
- (let* ((cllpkg (find-package :cl-launch))
- (name (funcall (intern "GETENV" cllpkg)
- "CL_LAUNCH_FILE"))
- (args (symbol-value (intern "*ARGUMENTS*" cllpkg))))
- (if name
- (cons name args)
- args)))
- #+sbcl sb-ext:*posix-argv*
- #+cmu ext:*command-line-strings*
- #+clisp (loop with argv = (ext:argv)
- for i from 7 below (length argv)
- collect (aref argv i))
- #+ecl (loop from i below (ext:argc) collect (ext:argv i))
- '("<unknown-script>"))
+ (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*))))
(do-case2-like 'ecase vform clauses))
;;;--------------------------------------------------------------------------
-;;; Locatives.
-
-(export '(loc locp))
-(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
- "Locative data type. See `locf' and `ref'."
- (reader nil :type function)
- (writer nil :type function))
-
-(export 'locf)
-(defmacro locf (place &environment env)
- "Slightly cheesy locatives.
-
- (locf PLACE) returns an object which, using the `ref' function, can be
- used to read or set the value of PLACE. It's cheesy because it uses
- closures rather than actually taking the address of something. Also,
- unlike Zetalisp, we don't overload `car' to do our dirty work."
- (multiple-value-bind
- (valtmps valforms newtmps setform getform)
- (get-setf-expansion place env)
- `(let* (,@(mapcar #'list valtmps valforms))
- (make-loc (lambda () ,getform)
- (lambda (,@newtmps) ,setform)))))
-
-(export 'ref)
-(declaim (inline ref (setf ref)))
-(defun ref (loc)
- "Fetch the value referred to by a locative."
- (funcall (loc-reader loc)))
-(defun (setf ref) (new loc)
- "Store a new value in the place referred to by a locative."
- (funcall (loc-writer loc) new))
-
-(export 'with-locatives)
-(defmacro with-locatives (locs &body body)
- "Evaluate BODY with implicit locatives.
-
- LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
- symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
- defaults to SYM. As an abbreviation for a common case, LOCS may be a
- symbol instead of a list.
-
- The BODY is evaluated in an environment where each SYM is a symbol macro
- which expands to (ref LOC-EXPR) -- or, in fact, something similar which
- doesn't break if LOC-EXPR has side-effects. Thus, references, including
- `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
- Useful for covering over where something uses a locative."
- (setf locs (mapcar (lambda (item)
- (cond ((atom item) (list item item))
- ((null (cdr item)) (list (car item) (car item)))
- (t item)))
- (if (listp locs) locs (list locs))))
- (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
- (ll (mapcar #'cadr locs))
- (ss (mapcar #'car locs)))
- `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
- (symbol-macrolet (,@(mapcar (lambda (sym tmp)
- `(,sym (ref ,tmp))) ss tt))
- ,@body))))
-
-;;;--------------------------------------------------------------------------
;;; Standard error-reporting functions.
(export 'moan)
(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)
- (:constructor make-option
- (long-name short-name
- &optional arg-name
- &key (tag (intern (string-upcase long-name) :keyword))
- negated-tag
- arg-optional-p
- doc (documentation doc))))
- "Describes a command-line option. Slots:
+ (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.
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)))
+ 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
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
still allowed, and may be cuddled as usual. The default is
nil."
(args nil :type list)
- (options 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))
(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)
,@docs ,@decls
(declare (ignorable ,arg))
(with-locatives ,var
- ,@body))
+ (block ,name ,@body)))
',name))))
(defun parse-c-integer (string &key radix (start 0) end)
"Increments VAR by STEP (defaults to 1), but not greater than MAX (default
nil for no maximum). No errors are signalled."
(incf var step)
- (when (>= var max)
+ (when (and max (>= var max))
(setf var max)))
(export 'dec)
"Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
for no maximum). No errors are signalled."
(decf var step)
- (when (<= var min)
+ (when (and min (<= var min))
(setf var min)))
(export 'read)
RADIX may be nil to allow radix prefixes, or an integer between 2 and 36.
An option-parse-error is signalled if the ARG is not a valid integer, or
if it is not between MIN and MAX (either of which may be nil if no lower
- resp. upper bound is wanted)."
+ 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))
Option macros should produce a list of expressions producing one option
structure each."
- `(progn
- (setf (get ',name 'optmacro) (lambda ,args ,@body))
- ',name))
+ (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)
;;;--------------------------------------------------------------------------
;;; 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)
(dolist (o opts)
(let ((doc (opt-documentation o)))
(cond ((not o))
- ((not (opt-long-name 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))
- (t
+ (doc
(setf newlinep t)
(pprint-logical-block (stream nil :prefix " ")
- (format stream "~:[ ~;-~:*~C,~] --~A"
+ (format stream "~:[ ~;-~:*~C~:[~;,~]~:*~]~@[ --~A~]"
(opt-short-name o)
(opt-long-name o))
(when (opt-arg-name o)
- (format stream "~:[=~A~;[=~A]~]"
+ (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)
;;;--------------------------------------------------------------------------
;;; 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")
~mdw / sod / blobdiff