debian/changelog: Prepare for next version.

[sod] / src / optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index a2ac290..d03b9cc 100644 (file)
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- 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
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by


@@ -23,8 +23,10 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; 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 #:cl-launch #: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)
 
 
 (cl:in-package #:optparse)
 


@@ -32,21 +34,21 @@
 ;;; Program environment things.
 
 (export 'exit)
 ;;; 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*))
     (abort)))
 
 (export '(*program-name* *command-line*))


@@ -62,13 +64,31 @@
    Set `*command-line*' and `*program-name*'."
 
   (setf *command-line*
    Set `*command-line*' and `*program-name*'."
 
   (setf *command-line*

-       (cons (or (getenv "CL_LAUNCH_FILE")
-                 #+sbcl (car sb-ext:*posix-argv*)
-                 #+cmu (car ext:*command-line-strings*)
-                 #+clisp (aref (ext:argv) 0)
-                 #+ecl (ext:argv 0)
-                 #-(or sbcl cmu clisp ecl) "sod")
-             *arguments*)
+       (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*))))
 
 
        *program-name* (pathname-name (car *command-line*))))
 


@@ -136,30 +156,38 @@
 (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))
 (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~]"
                             ~*~@[~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.
 
    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.


@@ -188,14 +216,15 @@
                wrapped.  If nil, the option is omitted from the 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
 
 (export '(option-parser option-parser-p make-option-parser
          op-options op-non-option op-long-only-p op-numeric-p


@@ -210,6 +239,7 @@
                       negated-numeric-p
                       long-only-p
                  &aux (args (cons nil argstmp))
                       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
                       (next args)
                       (negated-p (or negated-numeric-p
                                      (some #'opt-negated-tag


@@ -243,7 +273,7 @@
                still allowed, and may be cuddled as usual.  The default is
                nil."
   (args nil :type list)
                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))
   (non-option :skip :type (or function (member :skip :stop :return)))
   (next nil :type list)
   (short-opt nil :type (or null string))


@@ -253,6 +283,7 @@
   (numeric-p nil :type t)
   (negated-numeric-p nil :type t)
   (negated-p nil :type t))
   (numeric-p nil :type t)
   (negated-numeric-p nil :type t)
   (negated-p nil :type t))

+(define-access-wrapper op-options op-%options)

 
 (export 'option-parse-error)
 (define-condition option-parse-error (error simple-condition)
 
 (export 'option-parse-error)
 (define-condition option-parse-error (error simple-condition)


@@ -536,7 +567,7 @@
           ,@docs ,@decls
           (declare (ignorable ,arg))
           (with-locatives ,var
           ,@docs ,@decls
           (declare (ignorable ,arg))
           (with-locatives ,var

-            ,@body))
+            (block ,name ,@body)))

         ',name))))
 
 (defun parse-c-integer (string &key radix (start 0) end)
         ',name))))
 
 (defun parse-c-integer (string &key radix (start 0) end)


@@ -650,7 +681,7 @@
    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
    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))
   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
     (unless (and v (>= end (length arg)))
       (option-parse-error "Bad integer `~A'" arg))


@@ -727,9 +758,12 @@
 
    Option macros should produce a list of expressions producing one option
    structure each."
 
    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)
 
 (export 'parse-option-form)
 (eval-when (:compile-toplevel :load-toplevel :execute)


@@ -870,43 +904,41 @@
 ;;;--------------------------------------------------------------------------
 ;;; Support stuff for help and usage messages.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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."
    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)
 
 (export 'simple-usage)
 (defun simple-usage (opts &optional mandatory-args)


@@ -975,22 +1007,25 @@
     (dolist (o opts)
       (let ((doc (opt-documentation o)))
        (cond ((not o))
     (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))
               (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 "  ")
               (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)
                         (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-arg-optional-p o)

+                          (opt-long-name o)

                           (opt-arg-name o)))
                 (write-string "  " stream)
                 (pprint-tab :line 30 1 stream)
                           (opt-arg-name o)))
                 (write-string "  " stream)
                 (pprint-tab :line 30 1 stream)