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/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
"

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

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/let-syntax.test"
"tests/guile.test"
"tests/getopt-long.test"
"tests/psyntax.test"
"tests/match.test"
;;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) 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,14 +225,13 @@
(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)
@ -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

10
scripts/mescc.mes
View file

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

2
tests/base.test-guile
View file

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

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