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 38a3ae4689f58bcb13d34222278dbd268dc9bf44..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


@@ -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,21 +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*

-       (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*))))
 
 
        *program-name* (pathname-name (car *command-line*))))
 


@@ -120,66 +127,6 @@ (defmacro ecase2 (vform &body clauses)
   "Like `case2', but signals an error if no clause matches the SCRUTINEE."
   (do-case2-like 'ecase vform clauses))
 
   "Like `case2', but signals an error if no clause matches the SCRUTINEE."
   (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Standard error-reporting functions.
 


@@ -218,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


@@ -263,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


@@ -278,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


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


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


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


@@ -684,7 +638,7 @@ (defopthandler inc (var) (&optional max (step 1))
   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
    nil for no maximum).  No errors are signalled."
   (incf var step)
   "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)
     (setf var max)))
 
 (export 'dec)


@@ -692,7 +646,7 @@ (defopthandler dec (var) (&optional min (step 1))
   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
    for no maximum).  No errors are signalled."
   (decf var step)
   "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)
     (setf var min)))
 
 (export 'read)


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


@@ -1106,6 +1063,7 @@ (defun sanity-check-option-list (opts)
 ;;;--------------------------------------------------------------------------
 ;;; Full program descriptions.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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")
 (defvar *help* nil "Help text describing the program.")
 (defvar *version* "<unreleased>" "The program's version number.")
 (defvar *usage* nil "A usage summary string")