mes: getopt-long: fix multi-opt and unclumping.
authorJan Nieuwenhuizen <janneke@gnu.org>
Tue, 2 Jan 2018 06:05:41 +0000 (07:05 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Tue, 2 Jan 2018 06:05:41 +0000 (07:05 +0100)
* 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.

check.sh
guile/mescc.scm
make.scm
module/mes/getopt-long.scm
scripts/mescc.mes
tests/base.test-guile
tests/getopt-long.test [new file with mode: 0755]
tests/getopt-long.test-guile [new symlink]

index 6312cf08af27a814c7599ff62ae119c4d17054c7..b37c5cb512fb5d4eb4dcc274dffcb0782f788ae8 100755 (executable)
--- 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
 "
 
index 770e8244b9135804d118958ef7344c9506f0075f..bcdbd50b27b58fef217f3fce60dcd0eab171570e 100755 (executable)
@@ -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))
index 3302c07ab11439269d4d90c849e4b7c62e6a1036..c43f0c4fd492e4643b4968cb281926720d45e2f2 100755 (executable)
--- 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?
index 7e394662e74f790354c0f65bb8c243c2dbdc2048..2c873eb77c94e82a4a7c41361c34ce2ea54dadaf 100644 (file)
@@ -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
   #: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
    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)))))
            (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
         (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)))
                          (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)))
          (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)))
                    (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))
                  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
index 0f3e591b270ca6c09b26293fa6b5a7a21c83d8b0..09d9d57eddafc82c202b15aa456070de72edff0e 100755 (executable)
@@ -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))
index c4982d51f3e72a1d2f179170f531d97f5b8919f7..98c517642f1c91e422235b31e10576cbcfc109a3 100755 (executable)
@@ -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
diff --git a/tests/getopt-long.test b/tests/getopt-long.test
new file mode 100755 (executable)
index 0000000..021822e
--- /dev/null
@@ -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)
diff --git a/tests/getopt-long.test-guile b/tests/getopt-long.test-guile
new file mode 120000 (symlink)
index 0000000..5631f4a
--- /dev/null
@@ -0,0 +1 @@
+base.test-guile
\ No newline at end of file