doc/syntax.tex: Delete (wrong) duplicate rule for <argument-declarator>.

[sod] / src / optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index a2ac2906ecd96b2b7379ed8a72b13cf044119121..22345951af7fe1d56410174cdbd80cd3702fa722 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


@@ -24,7 +24,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (cl:defpackage #:optparse
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (cl:defpackage #:optparse

-  (:use #:common-lisp #:cl-launch #:sod-utilities))
+  (:use #:common-lisp #:sod-utilities))

 
 (cl:in-package #:optparse)
 
 
 (cl:in-package #:optparse)
 


@@ -35,19 +35,16 @@ (export 'exit)
 (defun exit (&optional (code 0) &key abrupt)
   "End program, returning CODE to the caller."
   (declare (type (unsigned-byte 32) code))
 (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))
-    (abort)))
+  #.(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>"


@@ -62,13 +59,31 @@ (defun set-command-line-arguments ()
    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*))))
 


@@ -150,15 +165,19 @@ (defstruct (option
                          (opt-long-name o)
                          (opt-arg-optional-p o)
                          (opt-arg-name o)
                          (opt-long-name o)
                          (opt-arg-optional-p o)
                          (opt-arg-name o)

-                         (opt-documentation o)))))
-            (:constructor %make-option)
+                         (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
             (: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))))
+                      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
   "Describes a command-line option.  Slots:
 
    LONG-NAME   The option's long name.  If this is null, the `option' is


@@ -195,7 +214,8 @@ (defstruct (option
   (short-name nil :type (or null character))
   (arg-name nil :type (or null string))
   (arg-optional-p 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)))
+  (%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 +230,7 @@ (defstruct (option-parser
                       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 +264,7 @@ (defstruct (option-parser
                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 +274,7 @@ (defstruct (option-parser
   (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 +558,7 @@      (defun ,func (,var ,arg ,@args)
           ,@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)


@@ -727,9 +749,12 @@ (defmacro defoptmacro (name args &body body)
 
    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)