artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

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

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2018-01-02 07:05:41 +01:00
parent 81fdd4c35f
commit b354da6f02
8 changed files with 123 additions and 64 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
check.sh
View file

@ -43,11 +43,12 @@ tests/syntax.test
tests/pmatch.test tests/pmatch.test
tests/let-syntax.test tests/let-syntax.test
tests/guile.test tests/guile.test
tests/getopt-long.test
tests/psyntax.test tests/psyntax.test
tests/match.test
" "
slow=" slow_or_broken="
tests/match.test
tests/peg.test tests/peg.test
" "

10
guile/mescc.scm
View file

@ -9,7 +9,7 @@ exec ${GUILE-guile} -L $GUILEDIR -C $GODIR -e '(mescc)' -s "$0" "$@"
!# !#
;;; Mes --- The Maxwell Equations of Software ;;; 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. ;;; 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) (define (parse-opts args)
(let* ((option-spec (let* ((option-spec
'((c (single-char #\c)) '((c (single-char #\c))
(D (single-char #\D) (value #t)) (define (single-char #\D) (value #t))
(E (single-char #\E)) (E (single-char #\E))
(g (single-char #\g)) (g (single-char #\g))
(help (single-char #\h)) (help (single-char #\h))
(I (single-char #\I) (value #t)) (include (single-char #\I) (value #t))
(o (single-char #\o) (value #t)) (o (single-char #\o) (value #t))
(version (single-char #\V) (value #t)))) (version (single-char #\V) (value #t))))
(options (getopt-long args option-spec)) (options (getopt-long args option-spec))
@ -127,8 +127,8 @@ Usage: mescc.scm [OPTION]... FILE...
(preprocess? (string-append base ".E")) (preprocess? (string-append base ".E"))
(else "a.out")))) (else "a.out"))))
(multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o))))) (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
(defines (reverse (filter-map (multi-opt 'D) options))) (defines (reverse (filter-map (multi-opt 'define) options)))
(includes (reverse (filter-map (multi-opt 'I) options)))) (includes (reverse (filter-map (multi-opt 'include) options))))
(when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options) (when (getenv "MES_DEBUG") (format (current-error-port) "options=~s\n" options)
(format (current-error-port) "output: ~a\n" out)) (format (current-error-port) "output: ~a\n" out))
(if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files)) (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files))

1
make.scm
View file

@ -487,6 +487,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
"tests/pmatch.test" "tests/pmatch.test"
"tests/let-syntax.test" "tests/let-syntax.test"
"tests/guile.test" "tests/guile.test"
"tests/getopt-long.test"
"tests/psyntax.test" "tests/psyntax.test"
"tests/match.test" "tests/match.test"
;;sloooowwww/broken? ;;sloooowwww/broken?

95
module/mes/getopt-long.scm
View file

@ -1,5 +1,5 @@
;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc. ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -164,17 +164,13 @@
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:export (getopt-long option-ref)) #: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 (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? option-spec?
(name (name
option-spec->name set-option-spec-name!) option-spec->name set-option-spec-name!)
(value
option-spec->value set-option-spec-value!)
(required? (required?
option-spec->required? set-option-spec-required?!) option-spec->required? set-option-spec-required?!)
(option-spec->single-char (option-spec->single-char
@ -185,7 +181,7 @@
option-spec->value-policy set-option-spec-value-policy!)) option-spec->value-policy set-option-spec-value-policy!))
(define (make-option-spec name) (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) (define (parse-option-spec desc)
(let ((spec (make-option-spec (symbol->string (car desc))))) (let ((spec (make-option-spec (symbol->string (car desc)))))
@ -229,14 +225,13 @@
(reverse ret-ls)) ;;; retval (reverse ret-ls)) ;;; retval
((let ((opt (car opt-ls))) ((let ((opt (car opt-ls)))
(and (eq? (string-ref opt 0) #\-) (and (eq? (string-ref opt 0) #\-)
(let ((n (char->integer (string-ref opt 1)))) (> (string-length opt) 1)
(or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) (char-alphabetic? (string-ref opt 1))))
(and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
(let* ((opt (car opt-ls)) (let* ((opt (car opt-ls))
(n (char->integer (string-ref opt 1))) (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))) (sub (substring opt 1 (string-length opt)))
(and (>= n (char->integer #\a)) (<= n (char->integer #\z))))))) (end (string-index (substring opt 1 (string-length opt)) (negate char-alphabetic?)))
(string-length opt))) (end (if end (1+ end) (string-length opt)))
(singles-string (substring opt 1 end)) (singles-string (substring opt 1 end))
(singles (reverse (singles (reverse
(map (lambda (c) (map (lambda (c)
@ -265,14 +260,14 @@
(sc-idx (map (lambda (spec) (sc-idx (map (lambda (spec)
(cons (make-string 1 (option-spec->single-char spec)) (cons (make-string 1 (option-spec->single-char spec))
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 loop ((argument-ls argument-ls) (found '()) (etc '()))
(let ((eat! (lambda (spec ls) (let ((eat! (lambda (spec ls)
(let ((val!loop (lambda (val n-ls n-found n-etc) (let ((val!loop (lambda (val n-ls n-found n-etc)
(set-option-spec-value-policy! (set-option-spec-value!
spec spec
;; handle multiple occurrances ;; handle multiple occurrances
(cond ((option-spec->value-policy spec) (cond ((option-spec->value spec)
=> (lambda (cur) => (lambda (cur)
((if (list? cur) cons list) ((if (list? cur) cons list)
val cur))) val cur)))
@ -356,36 +351,36 @@
(cons (car argument-ls) etc))))))))) (cons (car argument-ls) etc)))))))))
(define (getopt-long program-arguments option-desc-list) (define (getopt-long program-arguments option-desc-list)
;; "Process options, handling both long and short options, similar to "Process options, handling both long and short options, similar to
;; the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
;; similar to what (program-arguments) returns. OPTION-DESC-LIST is a similar to what (program-arguments) returns. OPTION-DESC-LIST is a
;; list of option descriptions. Each option description must satisfy the list of option descriptions. Each option description must satisfy the
;; following grammar: following grammar:
;; <option-spec> :: (<name> . <attribute-ls>) <option-spec> :: (<name> . <attribute-ls>)
;; <attribute-ls> :: (<attribute> . <attribute-ls>) <attribute-ls> :: (<attribute> . <attribute-ls>)
;; | () | ()
;; <attribute> :: <required-attribute> <attribute> :: <required-attribute>
;; | <arg-required-attribute> | <arg-required-attribute>
;; | <single-char-attribute> | <single-char-attribute>
;; | <predicate-attribute> | <predicate-attribute>
;; | <value-attribute> | <value-attribute>
;; <required-attribute> :: (required? <boolean>) <required-attribute> :: (required? <boolean>)
;; <single-char-attribute> :: (single-char <char>) <single-char-attribute> :: (single-char <char>)
;; <value-attribute> :: (value #t) <value-attribute> :: (value #t)
;; (value #f) (value #f)
;; (value optional) (value optional)
;; <predicate-attribute> :: (predicate <1-ary-function>) <predicate-attribute> :: (predicate <1-ary-function>)
;; The procedure returns an alist of option names and values. Each 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 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 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 key of the empty list, (): the list of arguments that are not options
;; or option values. or option values.
;; By default, options are not required, and option values are not By default, options are not required, and option values are not
;; required. By default, single character equivalents are not supported; required. By default, single character equivalents are not supported;
;; if you want to allow the user to use single character options, you need if you want to allow the user to use single character options, you need
;; to add a `single-char' clause to the option description." to add a `single-char' clause to the option description."
(let* ((specifications (map parse-option-spec option-desc-list)) (let* ((specifications (map parse-option-spec option-desc-list))
(pair (split-arg-list (cdr program-arguments))) (pair (split-arg-list (cdr program-arguments)))
(split-ls (expand-clumped-singles (car pair))) (split-ls (expand-clumped-singles (car pair)))
@ -395,7 +390,7 @@
(rest-ls (append (cdr found/etc) non-split-ls))) (rest-ls (append (cdr found/etc) non-split-ls)))
(for-each (lambda (spec) (for-each (lambda (spec)
(let ((name (option-spec->name spec)) (let ((name (option-spec->name spec))
(val (option-spec->value-policy spec))) (val (option-spec->value spec)))
(and (option-spec->required? spec) (and (option-spec->required? spec)
(or (memq spec found) (or (memq spec found)
(error "option must be specified:" name))) (error "option must be specified:" name)))
@ -415,7 +410,7 @@
(let ((name (string->symbol (option-spec->name spec)))) (let ((name (string->symbol (option-spec->name spec))))
(cons name (cons name
;; handle multiple occurrances ;; handle multiple occurrances
(let ((maybe-ls (option-spec->value-policy spec))) (let ((maybe-ls (option-spec->value spec)))
(if (list? maybe-ls) (if (list? maybe-ls)
(let* ((look (assq name multi-count)) (let* ((look (assq name multi-count))
(idx (cdr look)) (idx (cdr look))
@ -426,8 +421,8 @@
found))))) found)))))
(define (option-ref options key default) (define (option-ref options key default)
;; "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
;; The value is either a string or `#t'." The value is either a string or `#t'."
(or (assq-ref options key) default)) (or (assq-ref options key) default))
;;; getopt-long.scm ends here ;;; getopt-long.scm ends here

10
scripts/mescc.mes
View file

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

2
tests/base.test-guile
View file

@ -20,4 +20,4 @@
test=$(dirname $0)/$(basename $0 -guile) test=$(dirname $0)/$(basename $0 -guile)
GUILE=${GUILE-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

61
tests/getopt-long.test Executable file
View file

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

1
tests/getopt-long.test-guile Symbolic link
View file

@ -0,0 +1 @@
base.test-guile