lib/sod-hosted.c (sod_makev): Use two statements rather than tricky expression.

[sod] / src / optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index 5017fe4..d03b9cc 100644 (file)
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -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 #: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,19 +34,22 @@
 ;;; 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))
-  #.(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 '(*program-name* *command-line*))
 (defvar *program-name* "<unknown>"


@@ -151,34 +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
-                (&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.
 
    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.


@@ -208,13 +217,13 @@
                text.
 
    Usually, one won't use `make-option', but use the `option' macro instead."
                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
 (define-access-wrapper opt-documentation opt-%documentation)
 
 (export '(option-parser option-parser-p make-option-parser


@@ -672,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))


@@ -895,40 +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)