mes: getopt-long: fix multi-opt and unclumping.

* module/mes/getopt-long.scm (remove-if-not): Remove. (option-spec): Add value field. Update users. (expand-clumped-singles): Simplify, fix. (process-options): To get an option's value, use value instead of value-policy. Fixes multi-opt. * tests/getopt-long.test: New file. * make.scm (mes-tests): Add it. * check.sh (tests): Add it. * tests/getopt-long.test-guile: New symlink.
2018-01-02 07:05:41 +01:00 · 2018-01-02 07:05:41 +01:00 · b354da6f02
parent 81fdd4c35f
commit b354da6f02
8 changed files with 123 additions and 64 deletions
--- a/check.sh
+++ b/check.sh
@ -43,11 +43,12 @@ tests/syntax.test
 tests/pmatch.test
 tests/let-syntax.test
 tests/guile.test
+tests/getopt-long.test
 tests/psyntax.test
+tests/match.test
 "

-slow="
-tests/match.test
+slow_or_broken="
 tests/peg.test
 "

--- a/guile/mescc.scm
+++ b/guile/mescc.scm
@ -9,7 +9,7 @@ exec ${GUILE-guile} -L $GUILEDIR -C $GODIR -e '(mescc)' -s "$0" "$@"
 !#

 ;;; Mes --- The Maxwell Equations of Software
-;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@ -51,11 +51,11 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
 (define (parse-opts args)
  (let* ((option-spec
          '((c (single-char #\c))
-            (D (single-char #\D) (value #t))
+            (define (single-char #\D) (value #t))
            (E (single-char #\E))
            (g (single-char #\g))
            (help (single-char #\h))
-            (I (single-char #\I) (value #t))
+            (include (single-char #\I) (value #t))
            (o (single-char #\o) (value #t))
            (version (single-char #\V) (value #t))))
         (options (getopt-long args option-spec))
@ -127,8 +127,8 @@ Usage: mescc.scm [OPTION]... FILE...
                                           (preprocess? (string-append base ".E"))
                                           (else "a.out"))))
         (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
-         (defines (reverse (filter-map (multi-opt 'D) options)))
-         (includes (reverse (filter-map (multi-opt 'I) options))))
+         (defines (reverse (filter-map (multi-opt 'define) options)))
+         (includes (reverse (filter-map (multi-opt 'include) options))))
    (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options)
          (format (current-error-port) "output: ~a\n" out))
    (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files))
--- a/make.scm
+++ b/make.scm
@ -487,6 +487,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
    "tests/pmatch.test"
    "tests/let-syntax.test"
    "tests/guile.test"
+    "tests/getopt-long.test"
    "tests/psyntax.test"
    "tests/match.test"
    ;;sloooowwww/broken?
--- a/module/mes/getopt-long.scm
+++ b/module/mes/getopt-long.scm
@ -1,5 +1,5 @@
 ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
-;;; Copyright (C) 2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright (C) 2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@ -164,17 +164,13 @@
  #:use-module (srfi srfi-9)
  #:export (getopt-long option-ref))

-(define (remove-if-not pred l)
-  (let loop ((l l) (result '()))
-    (cond ((null? l) (reverse! result))
-	  ((not (pred (car l))) (loop (cdr l) result))
-	  (else (loop (cdr l) (cons (car l) result))))))
-
 (define-record-type option-spec
-  (%make-option-spec name required? option-spec->single-char predicate value-policy)
+  (%make-option-spec name value required? option-spec->single-char predicate value-policy)
  option-spec?
  (name
   option-spec->name set-option-spec-name!)
+  (value
+   option-spec->value set-option-spec-value!)
  (required?
   option-spec->required? set-option-spec-required?!)
  (option-spec->single-char
@ -185,7 +181,7 @@
   option-spec->value-policy set-option-spec-value-policy!))

 (define (make-option-spec name)
-  (%make-option-spec name #f #f #f #f))
+  (%make-option-spec name #f #f #f #f #f))

 (define (parse-option-spec desc)
  (let ((spec (make-option-spec (symbol->string (car desc)))))
@ -229,20 +225,19 @@
           (reverse ret-ls))                                    ;;; retval
          ((let ((opt (car opt-ls)))
             (and (eq? (string-ref opt 0) #\-)
-                  (let ((n (char->integer (string-ref opt 1))))
-                    (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
-                        (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
+                  (> (string-length opt) 1)
+                  (char-alphabetic? (string-ref opt 1))))
           (let* ((opt (car opt-ls))
                  (n (char->integer (string-ref opt 1)))
-                  (end (or (string-index opt (lambda (c) (not (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
-                                                                  (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
-                           (string-length opt)))
+                  (sub (substring opt 1 (string-length opt)))
+                  (end (string-index (substring opt 1 (string-length opt)) (negate char-alphabetic?)))
+                  (end (if end (1+ end) (string-length opt)))
                  (singles-string (substring opt 1 end))
                  (singles (reverse
                            (map (lambda (c)
                                   (string-append "-" (make-string 1 c)))
                                 (string->list singles-string))))
-                 (extra (substring opt end)))
+                  (extra (substring opt end)))
             (loop (cdr opt-ls)
                   (append (if (string=? "" extra)
                               singles
@ -265,14 +260,14 @@
        (sc-idx (map (lambda (spec)
                       (cons (make-string 1 (option-spec->single-char spec))
                             spec))
-                     (remove-if-not option-spec->single-char specs))))
+                     (filter option-spec->single-char specs))))
    (let loop ((argument-ls argument-ls) (found '()) (etc '()))
      (let ((eat! (lambda (spec ls)
                    (let ((val!loop (lambda (val n-ls n-found n-etc)
-                                      (set-option-spec-value-policy!
+                                      (set-option-spec-value!
                                       spec
                                       ;; handle multiple occurrances
-                                       (cond ((option-spec->value-policy spec)
+                                       (cond ((option-spec->value spec)
                                              => (lambda (cur)
                                                   ((if (list? cur) cons list)
                                                    val cur)))
@ -356,36 +351,36 @@
                         (cons (car argument-ls) etc)))))))))

 (define (getopt-long program-arguments option-desc-list)
-;;   "Process options, handling both long and short options, similar to
-;; the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
-;; similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
-;; list of option descriptions.  Each option description must satisfy the
-;; following grammar:
+  "Process options, handling both long and short options, similar to
+the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
+similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
+list of option descriptions.  Each option description must satisfy the
+following grammar:

-;;     <option-spec>           :: (<name> . <attribute-ls>)
-;;     <attribute-ls>          :: (<attribute> . <attribute-ls>)
-;;                                | ()
-;;     <attribute>             :: <required-attribute>
-;;                                | <arg-required-attribute>
-;;                                | <single-char-attribute>
-;;                                | <predicate-attribute>
-;;                                | <value-attribute>
-;;     <required-attribute>    :: (required? <boolean>)
-;;     <single-char-attribute> :: (single-char <char>)
-;;     <value-attribute>       :: (value #t)
-;;                                (value #f)
-;;                                (value optional)
-;;     <predicate-attribute>   :: (predicate <1-ary-function>)
+    <option-spec>           :: (<name> . <attribute-ls>)
+    <attribute-ls>          :: (<attribute> . <attribute-ls>)
+                               | ()
+    <attribute>             :: <required-attribute>
+                               | <arg-required-attribute>
+                               | <single-char-attribute>
+                               | <predicate-attribute>
+                               | <value-attribute>
+    <required-attribute>    :: (required? <boolean>)
+    <single-char-attribute> :: (single-char <char>)
+    <value-attribute>       :: (value #t)
+                               (value #f)
+                               (value optional)
+    <predicate-attribute>   :: (predicate <1-ary-function>)

-;;     The procedure returns an alist of option names and values.  Each
-;; option name is a symbol.  The option value will be '#t' if no value
-;; was specified.  There is a special item in the returned alist with a
-;; key of the empty list, (): the list of arguments that are not options
-;; or option values.
-;;     By default, options are not required, and option values are not
-;; required.  By default, single character equivalents are not supported;
-;; if you want to allow the user to use single character options, you need
-;; to add a `single-char' clause to the option description."
+    The procedure returns an alist of option names and values.  Each
+option name is a symbol.  The option value will be '#t' if no value
+was specified.  There is a special item in the returned alist with a
+key of the empty list, (): the list of arguments that are not options
+or option values.
+    By default, options are not required, and option values are not
+required.  By default, single character equivalents are not supported;
+if you want to allow the user to use single character options, you need
+to add a `single-char' clause to the option description."
  (let* ((specifications (map parse-option-spec option-desc-list))
 	 (pair (split-arg-list (cdr program-arguments)))
 	 (split-ls (expand-clumped-singles (car pair)))
@ -395,7 +390,7 @@
         (rest-ls (append (cdr found/etc) non-split-ls)))
    (for-each (lambda (spec)
                (let ((name (option-spec->name spec))
-                      (val (option-spec->value-policy spec)))
+                      (val (option-spec->value spec)))
                  (and (option-spec->required? spec)
                       (or (memq spec found)
                           (error "option must be specified:" name)))
@ -415,7 +410,7 @@
                   (let ((name (string->symbol (option-spec->name spec))))
                     (cons name
                           ;; handle multiple occurrances
-                           (let ((maybe-ls (option-spec->value-policy spec)))
+                           (let ((maybe-ls (option-spec->value spec)))
                             (if (list? maybe-ls)
                                 (let* ((look (assq name multi-count))
                                        (idx (cdr look))
@ -426,8 +421,8 @@
                 found)))))

 (define (option-ref options key default)
-;;   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
-;; The value is either a string or `#t'."
+  "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
+The value is either a string or `#t'."
  (or (assq-ref options key) default))

 ;;; getopt-long.scm ends here
--- a/scripts/mescc.mes
+++ b/scripts/mescc.mes
@ -64,13 +64,13 @@ exit $?
 (define (parse-opts args)
  (let* ((option-spec
          '((c (single-char #\c))
-            (D (single-char #\D) (value #t))
+            (define (single-char #\D) (value #t))
            (E (single-char #\E))
            (g (single-char #\g))
            (help (single-char #\h))
-            (I (single-char #\I) (value #t))
+            (include (single-char #\I) (value #t))
            (o (single-char #\o) (value #t))
-            (version (single-char #\V) (value #t))))
+            (version (single-char #\V))))
         (options (getopt-long args option-spec))
         (help? (option-ref options 'help #f))
         (files (option-ref options '() '()))
@ -141,8 +141,8 @@ Usage: mescc.mes [OPTION]... FILE...
                                           (preprocess? (string-append base ".E"))
                                           (else "a.out"))))
         (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
-         (defines (reverse (filter-map (multi-opt 'D) options)))
-         (includes (reverse (filter-map (multi-opt 'I) options))))
+         (defines (reverse (filter-map (multi-opt 'define) options)))
+         (includes (reverse (filter-map (multi-opt 'include) options))))
    (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options)
          (format (current-error-port) "output: ~a\n" out))
    (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files))
--- a/tests/base.test-guile
+++ b/tests/base.test-guile
@ -20,4 +20,4 @@

 test=$(dirname $0)/$(basename $0 -guile)
 GUILE=${GUILE-guile}
-cat guile/mes-0.scm module/mes/test.mes $test | exec $GUILE -s /dev/stdin
+cat guile/mes-0.scm module/mes/test.mes $test | exec $GUILE -L guile -s /dev/stdin
--- a/tests/getopt-long.test
+++ b/tests/getopt-long.test
@ -0,0 +1,61 @@
+#! /bin/sh
+# -*-scheme-*-
+MES=${MES-$(dirname $0)/../scripts/mes}
+echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $MES $MES_FLAGS "$@"
+#paredit:||
+exit $?
+!#
+
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(cond-expand
+ (guile
+  (use-modules (mes getopt-long)))
+ (mes
+  (mes-use-module (mes getopt-long))
+  (mes-use-module (mes test))))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(define option-spec '((help (single-char #\h))
+                      (include (single-char #\I) (value #t))
+                      (version (single-char #\V))))
+
+(pass-if-equal "getopt" '((() "bar"))
+  (getopt-long '("foo" "bar") option-spec))
+
+(pass-if-equal "getopt2" '((() "bar" "baz"))
+  (getopt-long '("foo" "bar" "baz") option-spec))
+
+(pass-if-equal "getopt --help" '((()) (help . #t))
+  (getopt-long '("foo" "--help") option-spec))
+
+(pass-if-equal "getopt -hVI5d" '((()) (include . "5d") (version . #t) (help . #t))
+  (getopt-long '("foo" "-hVI5d") option-spec))
+
+(pass-if-equal "getopt -I." '((()) (include . "."))
+  (getopt-long '("foo" "-I.") option-spec))
+
+(pass-if-equal "getopt -I foo ..." '((()) (include . "lib") (include . "include"))
+  (getopt-long '("foo" "-I" "include" "-I" "lib") option-spec))
+
+(result 'report)
--- a/tests/getopt-long.test-guile
+++ b/tests/getopt-long.test-guile
@ -0,0 +1 @@
+base.test-guile