From b354da6f02e2e8f645869924390803b58c7eb6b8 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 2 Jan 2018 07:05:41 +0100 Subject: [PATCH] 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. --- check.sh | 5 +- guile/mescc.scm | 10 ++-- make.scm | 1 + module/mes/getopt-long.scm | 97 +++++++++++++++++------------------- scripts/mescc.mes | 10 ++-- tests/base.test-guile | 2 +- tests/getopt-long.test | 61 +++++++++++++++++++++++ tests/getopt-long.test-guile | 1 + 8 files changed, 123 insertions(+), 64 deletions(-) create mode 100755 tests/getopt-long.test create mode 120000 tests/getopt-long.test-guile diff --git a/check.sh b/check.sh index 6312cf08..b37c5cb5 100755 --- 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 " diff --git a/guile/mescc.scm b/guile/mescc.scm index 770e8244..bcdbd50b 100755 --- 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 +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; 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)) diff --git a/make.scm b/make.scm index 3302c07a..c43f0c4f 100755 --- 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? diff --git a/module/mes/getopt-long.scm b/module/mes/getopt-long.scm index 7e394662..2c873eb7 100644 --- 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 +;;; Copyright (C) 2017,2018 Jan Nieuwenhuizen ;;; ;; 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: -;; :: ( . ) -;; :: ( . ) -;; | () -;; :: -;; | -;; | -;; | -;; | -;; :: (required? ) -;; :: (single-char ) -;; :: (value #t) -;; (value #f) -;; (value optional) -;; :: (predicate <1-ary-function>) + :: ( . ) + :: ( . ) + | () + :: + | + | + | + | + :: (required? ) + :: (single-char ) + :: (value #t) + (value #f) + (value optional) + :: (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 diff --git a/scripts/mescc.mes b/scripts/mescc.mes index 0f3e591b..09d9d57e 100755 --- 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)) diff --git a/tests/base.test-guile b/tests/base.test-guile index c4982d51..98c51764 100755 --- 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 diff --git a/tests/getopt-long.test b/tests/getopt-long.test new file mode 100755 index 00000000..021822e2 --- /dev/null +++ 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 +;;; +;;; 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 . + +(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 index 00000000..5631f4a9 --- /dev/null +++ b/tests/getopt-long.test-guile @@ -0,0 +1 @@ +base.test-guile \ No newline at end of file