getopts: new feature: cumulative options.

An option declared as (cumul <type>) indicates that it is of
type <type>, and that multiple occurrences of the option
produce values that are accumulated into a list.
The accumulation is in reverse order: the rightmost
occurrence ends up the first in the list.

* lisplib.c (getopts_set_entries): Add cumul to list of
interned symbols, so that the getopts.tl code isn't mistakenly
working with sys:cumul.

* share/txr/stdlib/getopts.tl (opt-parsed): New slot, cumul.
(opt-desc basic-type p, opt-desc list-type-p,  opt-desc
cumul-type-p): New methods.
(opt-desc check): Rework type validity check using the new
methods.
(opt-parsed convert-type): Support 'cumul type by
instantiating an opt-parsed object for the wrapped type,
and stealing its converted argument into the current object,
and setting the cumul flag.
(opts add-opt, option-base add-opt): Support options that have
the cumul flag set by accumulating list values. The code is
different due to different amounts of encapsulation. The opts
structure stores the raw opt-parsed objects, whereas
option-base just takes the decoded values.
(opthelp): Parse through the (cumul ...) type syntax, so
cumulative options are printed in the help text the same way
as if they were non-cumulative.

* txr.1: Documented.

3 files changed, 82 insertions, 14 deletions

diff --git a/lisplib.c b/lisplib.c
index 8fc31c9a..d1a2dd06 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -479,7 +479,7 @@ static val getopts_set_entries(val dlt, val fun)
   };
   val name_noload[] = {
     lit("short"), lit("long"), lit("helptext"), lit("type"),
-    lit("in-args"), lit("out-args"), nil
+    lit("in-args"), lit("out-args"), lit("cumul"), nil
   };
   set_dlt_entries(dlt, name, fun);
   intern_only(name_noload);
diff --git a/share/txr/stdlib/getopts.tl b/share/txr/stdlib/getopts.tl
index 25ae8463..b98a76dc 100644
--- a/share/txr/stdlib/getopts.tl
+++ b/share/txr/stdlib/getopts.tl
@@ -42,6 +42,7 @@
   arg  ;; string, integer, real, ...
   desc ;; opt-desc
   eff-type
+  cumul
   (:postinit (me) me.(convert-type)))
 
 (defstruct opts nil
@@ -65,12 +66,27 @@
 (defun sys:opt-dash (name)
   `@(if (> (length name) 1) "-")-@name`)
 
+(defmeth opt-desc basic-type-p (me type)
+  (or (functionp type) (fboundp type) (member type me.valid-types)))
+
+(defmeth opt-desc list-type-p (me type)
+  (tree-case type
+    ((indicator btype) (and (eq indicator 'list)
+                            me.(basic-type-p btype)))
+    (x nil)))
+
+(defmeth opt-desc cumul-type-p (me type)
+  (tree-case type
+    ((indicator btype) (and (eq indicator 'usr:cumul)
+                            (or me.(basic-type-p btype)
+                                me.(list-type-p btype))))
+    (x nil)))
+
 (defmeth opt-desc check (me)
-  (unless (or (functionp me.type)
-              (fboundp me.type)
-              (and (consp me.type) (eq (car me.type) 'list))
-              (member me.type me.valid-types))
-    (getopts-error "type must be a function or valid keyword, not ~s"
+  (unless (or me.(basic-type-p me.type)
+              me.(list-type-p me.type)
+              me.(cumul-type-p me.type))
+    (getopts-error "invalid option type specifier ~s"
                    me.type))
   (when me.long
     (when (< (length me.long) 2)
@@ -138,6 +154,12 @@
                                                                rec-type))
                                        pieces)))
                 (set me.arg (mapcar (usl arg) sub-opts))))
+           ((and (consp type) (eq (car type) 'cumul))
+              (let* ((rec-type (cadr type))
+                     (sub-opt (new (sys:opt-parsed me.name me.arg
+                                                   me.desc rec-type))))
+                (set me.arg sub-opt.arg
+                     me.cumul t)))
            ((or (symbolp type) (functionp type))
               (set me.arg (call type me.arg))))))))
 
@@ -150,6 +172,11 @@
     (error "opts: cannot set option ~s to ~s: no such option" key val)))
 
 (defmeth opts add-opt (me opt)
+  (when opt.cumul
+    (let* ((old-opt [me.opt-hash (or opt.desc.long
+                                     opt.desc.short)])
+           (old-arg (if old-opt old-opt.arg)))
+      (set opt.arg (cons opt.arg old-arg))))
   (whenlet ((n opt.desc.short))
     (set [me.opt-hash n] opt))
   (whenlet ((n opt.desc.long))
@@ -248,16 +275,19 @@
         (undocumented (keep-if (op null @1.helptext) opt-desc-list)))
     (put-line "\nOptions:\n")
     (each ((od sorted))
-      (let* ((type (cond
-                     ((keywordp od.type) (upcase-str (symbol-name od.type)))
-                     ((and (consp od.type) (eq (car od.type) 'list))
-                        (let ((ts (upcase-str (symbol-name (cadr od.type)))))
+      (let* ((type (if (and (consp od.type) (eq (car od.type) 'cumul))
+                     (cadr od.type)
+                     od.type))
+             (tstr (cond
+                     ((keywordp type) (upcase-str (symbol-name type)))
+                     ((and (consp type) (eq (car type) 'list))
+                        (let ((ts (upcase-str (symbol-name (cadr type)))))
                           `@ts[,@ts...]`))
                      (t "ARG")))
              (long (if od.long
-                     `--@{od.long}@(if od.arg-p `=@type`)`))
+                     `--@{od.long}@(if od.arg-p `=@tstr`)`))
              (short (if od.short
-                      `-@{od.short}@(if od.arg-p ` @type`)`))
+                      `-@{od.short}@(if od.arg-p ` @tstr`)`))
              (ls (cond
                    ((and long short) `@{long 21} (@short)`)
                    (long long)
@@ -348,7 +378,11 @@
   (:static slot-hash)
   (:static opt-desc-list)
   (:method add-opt (me opt)
-    (slotset me [me.slot-hash (or opt.desc.long opt.desc.short)] opt.arg))
+    (let* ((sl [me.slot-hash (or opt.desc.long opt.desc.short)])
+           (arg (if opt.cumul
+                  (cons opt.arg (slot me sl))
+                  opt.arg)))
+      (slotset me sl arg)))
   (:method getopts (me args)
     (set me.in-args args me.out-args args)
     (let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me)))
diff --git a/txr.1 b/txr.1
index fec2dcd9..9875d439 100644
--- a/txr.1
+++ b/txr.1
@@ -57203,7 +57203,41 @@ and converted accordingly. The option's argument is then a list object
 whose elements are the converted pieces. For instance
 .code "(list :dec)"
 will convert a list of comma-separated decimal integer tokens into
-a list of integer objects.
+a list of integer objects. The
+.code list
+option type does not nest.
+.meIP (cumul << type )
+If the type is specified as a compound form headed by the
+.code cumul
+symbol, it indicates that if the option is specified multiple times,
+the values coming from the multiple occurrences are accumulated into a list.
+The
+.meta type
+argument may be a
+.code list
+type, exemplified by
+.code "(cumul (list :dec))"
+or a basic type, such as
+.codn "(cumul :str)" .
+However, this type specifier does not nest. Combinations such as
+.code "(cumul (cumul ...)"
+and
+.code "(list (cumul ...))"
+are invalid.
+The option values are accumulated in reverse order, so that the rightmost
+repetition becomes the first item in the list. For instance, if the
+.code -x
+option has type
+.codn "(cumul :dec)" ,
+and the arguments presented for parsing are
+.codn "(\(dq-x\(dq \(dq1\(dq \(dq-x\(dq \(dq2\(dq)" ,
+then the option's value will be
+.codn "(2 1)" .
+If a
+.codn list -typed
+option is cumulative, then the option value will be a list of lists.
+Each repetition of the option produces a list, and the lists are accumulated.
+
 .RE
 
 .IP