[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-99-g153c4a
|
From: |
Neil Jerram |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-99-g153c4a4 |
|
Date: |
Thu, 26 May 2011 16:58:32 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=153c4a4afa4ca3ae6020a0d5ec34bbe62a62c568
The branch, stable-2.0 has been updated
via 153c4a4afa4ca3ae6020a0d5ec34bbe62a62c568 (commit)
via 9228f9eb956e8a7588c315239511fc4e08e16553 (commit)
via 6b4b4bfb0925adb2da66f4b49deb570da33c737d (commit)
via 0faf4b2a74b84a220eae6b822040ebd3c49e86a9 (commit)
via 1e2cc0b6304a4e1804791926db929f63ea082d1f (commit)
via ec7ea550f2acd6e7bbaf10f8e4a1e9915dc80cf8 (commit)
from af4081e9fd1d3bfaf4df906cac990c88e2e7cfa2 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 153c4a4afa4ca3ae6020a0d5ec34bbe62a62c568
Author: Neil Jerram <address@hidden>
Date: Thu May 12 23:16:05 2011 +0100
Emit a 1-based line number in error messages
* module/ice-9/boot-9.scm (exception-printers): Add 1 to the 0-based
line number.
commit 9228f9eb956e8a7588c315239511fc4e08e16553
Author: Neil Jerram <address@hidden>
Date: Sun May 8 22:51:07 2011 +0100
Reveal guile-tools's inner simplicity...
...by not using its own-rolled getopt, and moving the `list' function
to a separate script
* meta/guile-tools.in: Use (ice-9 getopt-long).
(directory-files, strip-extensions, unique, find-submodules,
list-scripts): Deleted (and moved to new `list.scm' file).
(getopt): Deleted.
(main): Use getopt-long. Default to calling the `list' script if no
script is specified.
* module/scripts/list.scm: New script.
* module/Makefile.am (SCRIPTS_SOURCES): Add list.scm.
commit 6b4b4bfb0925adb2da66f4b49deb570da33c737d
Author: Neil Jerram <address@hidden>
Date: Sun May 8 22:21:51 2011 +0100
Implement #:stop-at-first-non-option option for getopt-long
(For use by guile-tools)
* module/ice-9/getopt-long.scm: Use (ice-9 optargs) so we can use
define*.
(process-options): Add stop-at-first-non-option parameter. When
this is true, stop processing when we hit a non-option (so long as
that non-option isn't something that resulted from the unclumping of
a short option group).
(getopt-long): Add #:stop-at-first-non-option keyword; pass it on to
process-options.
* test-suite/tests/getopt-long.test ("stop-at-first-non-option"): New
test (for the above).
commit 0faf4b2a74b84a220eae6b822040ebd3c49e86a9
Author: Neil Jerram <address@hidden>
Date: Thu May 26 17:38:41 2011 +0100
Handle short option unclumping progressively, instead of all upfront
This is needed as a prerequisite for the following change that
introduces the stop-at-first-non-option option, because when that
option is used we don't know upfront how far through the command
line we should proceed with unclumping.
* module/ice-9/getopt-long.scm (expand-clumped-singles): Delete.
(process-options): Add a loop variable to indicate how many elements
at the start of `argument-ls' are known not to be clumped. When we
see a short option and this variable is <= 0, perform unclumping
(using code that used to be in expand-clumped-singles) and loop with
the variable > 0.
(getopt-long): Don't call expand-clumped-singles upfront here.
commit 1e2cc0b6304a4e1804791926db929f63ea082d1f
Author: Neil Jerram <address@hidden>
Date: Sun May 8 21:52:01 2011 +0100
Simplify getopt-long handling of option values, esp with multiple
occurrences
Basically, accumulate values in the `process-options' loop variables,
instead of using set-option-spec-value!
* module/ice-9/getopt-long.scm (option-spec): Delete the `value' slot.
(process-options): Delete `val!loop' and just use `loop' everywhere
instead. When adding an option spec to `found', add the
corresponding value too; hence `found' becomes an alist, where it
was previously a list of specs.
(getopt-long): Use assq-ref to get values out of `found'. Remove
unhittable error condition for detecting an option that requires an
explicit value, where a value wasn't supplied. This condition is
actually caught and handled in `process-options'. Rewrite the end
of the procedure much more simply.
commit ec7ea550f2acd6e7bbaf10f8e4a1e9915dc80cf8
Author: Neil Jerram <address@hidden>
Date: Sun May 8 21:36:54 2011 +0100
Fix "occurrances" typos in getopt-long code and test
* module/ice-9/getopt-long.scm (process-options, getopt-long): Change
to "occurrences".
* test-suite/tests/getopt-long.test ("multiple occurrences"): Same
again.
-----------------------------------------------------------------------
Summary of changes:
meta/guile-tools.in | 162 ++++++-------------------------------
module/Makefile.am | 1 +
module/ice-9/boot-9.scm | 2 +-
module/ice-9/getopt-long.scm | 113 +++++++++----------------
module/scripts/list.scm | 83 +++++++++++++++++++
test-suite/tests/getopt-long.test | 13 +++-
6 files changed, 163 insertions(+), 211 deletions(-)
create mode 100644 module/scripts/list.scm
diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index 7f156ff..2f335b8 100755
--- a/meta/guile-tools.in
+++ b/meta/guile-tools.in
@@ -24,7 +24,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0"
"$@"
;;;; Boston, MA 02110-1301 USA
(define-module (guile-tools)
- #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:use-module (ice-9 getopt-long)
#:autoload (ice-9 format) (format))
;; Hack to provide scripts with the bug-report address.
@@ -55,146 +55,34 @@ This is free software: you are free to change and
redistribute it.
There is NO WARRANTY, to the extent permitted by law.
" (version) (effective-version)))
-(define (directory-files dir)
- (if (and (file-exists? dir) (file-is-directory? dir))
- (let ((dir-stream (opendir dir)))
- (let loop ((new (readdir dir-stream))
- (acc '()))
- (if (eof-object? new)
- (begin
- (closedir dir-stream)
- acc)
- (loop (readdir dir-stream)
- (if (or (string=? "." new) ; ignore
- (string=? ".." new)) ; ignore
- acc
- (cons new acc))))))
- '()))
-
-(define (strip-extensions path)
- (or-map (lambda (ext)
- (and
- (string-suffix? ext path)
- (substring path 0
- (- (string-length path) (string-length ext)))))
- (append %load-compiled-extensions %load-extensions)))
-
-(define (unique l)
- (cond ((null? l) l)
- ((null? (cdr l)) l)
- ((equal? (car l) (cadr l)) (unique (cdr l)))
- (else (cons (car l) (unique (cdr l))))))
-
-(define (find-submodules head)
- (let ((shead (map symbol->string head)))
- (unique
- (sort
- (append-map (lambda (path)
- (fold (lambda (x rest)
- (let ((stripped (strip-extensions x)))
- (if stripped (cons stripped rest) rest)))
- '()
- (directory-files
- (fold (lambda (x y) (in-vicinity y x)) path
shead))))
- %load-path)
- string<?))))
-
-(define (list-scripts)
- (for-each (lambda (x)
- ;; would be nice to show a summary.
- (format #t "~A\n" x))
- (find-submodules '(scripts))))
-
(define (find-script s)
(resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
-(define (getopt args grammar)
- (define (fail)
- (format (current-error-port)
- "Try `guile-tools --help' for more information.~%")
- (exit 1))
-
- (define (unrecognized-arg arg)
- (format (current-error-port)
- "guile-tools: unrecognized option: `~a'~%" arg)
- (fail))
-
- (define (unexpected-value sym val)
- (format (current-error-port)
- "guile-tools: option `--~a' does not take an argument (given ~s)~%"
- sym val)
- (fail))
-
- (define (single-char-table grammar)
- (cond
- ((null? grammar) '())
- ((assq 'single-char (cdar grammar))
- => (lambda (form)
- (acons (cadr form) (car grammar)
- (single-char-table (cdr grammar)))))
- (else
- (single-char-table (cdr grammar)))))
-
- (let ((single (single-char-table grammar)))
- (let lp ((args (cdr args)) (options '()))
- (cond
- ((or (null? args) (equal? (car args) "-"))
- (values (reverse options) args))
- ((equal? (car args) "--")
- (values (reverse options) (cdr args)))
- ((string-prefix? "--" (car args))
- (let* ((str (car args))
- (eq (string-index str #\= 2))
- (sym (string->symbol
- (substring str 2 (or eq (string-length str)))))
- (val (and eq (substring str (1+ eq))))
- (spec (assq sym grammar)))
- (cond
- ((not spec)
- (unrecognized-arg (substring str 0 (or eq (string-length str)))))
- (val
- ;; no values for now
- (unexpected-value sym val))
- ((assq-ref (cdr spec) 'value)
- (error "options with values not supported right now"))
- (else
- (lp (cdr args) (acons sym #f options))))))
- ((string-prefix? "-" (car args))
- (let lp* ((chars (cdr (string->list (car args)))) (options options))
- (if (null? chars)
- (lp (cdr args) options)
- (let ((spec (assv-ref single (car chars))))
- (cond
- ((not spec)
- (unrecognized-arg (string #\- (car chars))))
- ((assq-ref (cdr spec) 'value)
- (error "options with values not supported right now"))
- (else
- (lp* (cdr chars) (acons (car spec) #f options))))))))
- (else (values (reverse options) args))))))
-
(define (main args)
(if (defined? 'setlocale)
(setlocale LC_ALL ""))
- (call-with-values (lambda () (getopt args *option-grammar*))
- (lambda (options args)
- (cond
- ((assq 'help options)
- (display-help)
- (exit 0))
- ((assq 'version options)
- (display-version)
- (exit 0))
- ((or (equal? args '())
- (equal? args '("list")))
- (list-scripts))
- ((find-script (car args))
- => (lambda (mod)
- (exit (apply (module-ref mod 'main) (cdr args)))))
- (else
- (format (current-error-port)
- "guile-tools: unknown script ~s~%" (car args))
- (format (current-error-port)
- "Try `guile-tools --help' for more information.~%")
- (exit 1))))))
+ (let ((options (getopt-long args *option-grammar*
+ #:stop-at-first-non-option #t)))
+ (cond
+ ((option-ref options 'help #f)
+ (display-help)
+ (exit 0))
+ ((option-ref options 'version #f)
+ (display-version)
+ (exit 0))
+ (else
+ (let ((args (option-ref options '() '())))
+ (cond ((find-script (if (null? args)
+ "list"
+ (car args)))
+ => (lambda (mod)
+ (exit (apply (module-ref mod 'main) (if (null? args)
+ '()
+ (cdr args))))))
+ (else
+ (format (current-error-port)
+ "guile-tools: unknown script ~s~%" (car args))
+ (format (current-error-port)
+ "Try `guile-tools --help' for more information.~%")
+ (exit 1))))))))
diff --git a/module/Makefile.am b/module/Makefile.am
index 42aff18..ddd4674 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -155,6 +155,7 @@ SCRIPTS_SOURCES = \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/lint.scm \
+ scripts/list.scm \
scripts/punify.scm \
scripts/read-scheme-source.scm \
scripts/read-text-outline.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 539eac9..1d14521 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -682,7 +682,7 @@ If there is no handler at all, Guile prints an error and
then exits."
(let ((filename (or (cadr source) "<unnamed port>"))
(line (caddr source))
(col (cdddr source)))
- (format port "~a:~a:~a: " filename line col))
+ (format port "~a:~a:~a: " filename (1+ line) col))
(format port "ERROR: "))))
(set! set-exception-printer!
diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 1b170b4..12f8c94 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -161,6 +161,7 @@
#:use-module (srfi srfi-9)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 optargs)
#:export (getopt-long option-ref))
(define %program-name (make-fluid))
@@ -179,8 +180,6 @@
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
@@ -228,33 +227,12 @@
(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
-(define (expand-clumped-singles opt-ls)
- ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
- (let loop ((opt-ls opt-ls) (ret-ls '()))
- (cond ((null? opt-ls)
- (reverse ret-ls)) ;;; retval
- ((regexp-exec short-opt-rx (car opt-ls))
- => (lambda (match)
- (let ((singles (reverse
- (map (lambda (c)
- (string-append "-" (make-string 1 c)))
- (string->list
- (match:substring match 1)))))
- (extra (match:substring match 2)))
- (loop (cdr opt-ls)
- (append (if (string=? "" extra)
- singles
- (cons extra singles))
- ret-ls)))))
- (else (loop (cdr opt-ls)
- (cons (car opt-ls) ret-ls))))))
-
(define (looks-like-an-option string)
(or (regexp-exec short-opt-rx string)
(regexp-exec long-opt-with-value-rx string)
(regexp-exec long-opt-no-value-rx string)))
-(define (process-options specs argument-ls)
+(define (process-options specs argument-ls stop-at-first-non-option)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of option specs for found options, while ETC
;; is an order-maintained list of elements in ARGUMENT-LS that are neither
@@ -266,32 +244,22 @@
(cons (make-string 1 (option-spec->single-char spec))
spec))
(remove-if-not option-spec->single-char specs))))
- (let loop ((argument-ls argument-ls) (found '()) (etc '()))
+ (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
(define (eat! spec ls)
- (define (val!loop val n-ls n-found n-etc)
- (set-option-spec-value!
- spec
- ;; handle multiple occurrances
- (cond ((option-spec->value spec)
- => (lambda (cur)
- ((if (list? cur) cons list)
- val cur)))
- (else val)))
- (loop n-ls n-found n-etc))
(cond
((eq? 'optional (option-spec->value-policy spec))
(if (or (null? ls)
(looks-like-an-option (car ls)))
- (val!loop #t ls (cons spec found) etc)
- (val!loop (car ls) (cdr ls) (cons spec found) etc)))
+ (loop (- unclumped 1) ls (acons spec #t found) etc)
+ (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
((eq? #t (option-spec->value-policy spec))
(if (or (null? ls)
(looks-like-an-option (car ls)))
(fatal-error "option must be specified with argument: --~a"
(option-spec->name spec))
- (val!loop (car ls) (cdr ls) (cons spec found) etc)))
+ (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
(else
- (val!loop #t ls (cons spec found) etc))))
+ (loop (- unclumped 1) ls (acons spec #t found) etc))))
(match argument-ls
(()
@@ -300,10 +268,24 @@
(cond
((regexp-exec short-opt-rx opt)
=> (lambda (match)
- (let* ((c (match:substring match 1))
- (spec (or (assoc-ref sc-idx c)
- (fatal-error "no such option: -~a" c))))
- (eat! spec rest))))
+ (if (> unclumped 0)
+ ;; Next option is known not to be clumped.
+ (let* ((c (match:substring match 1))
+ (spec (or (assoc-ref sc-idx c)
+ (fatal-error "no such option: -~a" c))))
+ (eat! spec rest))
+ ;; Expand a clumped group of short options.
+ (let* ((extra (match:substring match 2))
+ (unclumped-opts
+ (append (map (lambda (c)
+ (string-append "-" (make-string 1
c)))
+ (string->list
+ (match:substring match 1)))
+ (if (string=? "" extra) '() (list
extra)))))
+ (loop (length unclumped-opts)
+ (append unclumped-opts rest)
+ found
+ etc)))))
((regexp-exec long-opt-no-value-rx opt)
=> (lambda (match)
(let* ((opt (match:substring match 1))
@@ -319,10 +301,14 @@
(eat! spec (cons (match:substring match 2) rest))
(fatal-error "option does not support argument: --~a"
opt)))))
+ ((and stop-at-first-non-option
+ (<= unclumped 0))
+ (cons found (append (reverse etc) argument-ls)))
(else
- (loop rest found (cons opt etc)))))))))
+ (loop (- unclumped 1) rest found (cons opt etc)))))))))
-(define (getopt-long program-arguments option-desc-list)
+(define* (getopt-long program-arguments option-desc-list
+ #:key stop-at-first-non-option)
"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
@@ -356,44 +342,27 @@ to add a `single-char' clause to the option description."
(with-fluids ((%program-name (car program-arguments)))
(let* ((specifications (map parse-option-spec option-desc-list))
(pair (split-arg-list (cdr program-arguments)))
- (split-ls (expand-clumped-singles (car pair)))
+ (split-ls (car pair))
(non-split-ls (cdr pair))
- (found/etc (process-options specifications split-ls))
+ (found/etc (process-options specifications split-ls
+ stop-at-first-non-option))
(found (car found/etc))
(rest-ls (append (cdr found/etc) non-split-ls)))
(for-each (lambda (spec)
(let ((name (option-spec->name spec))
- (val (option-spec->value spec)))
+ (val (assq-ref found spec)))
(and (option-spec->required? spec)
- (or (memq spec found)
+ (or val
(fatal-error "option must be specified: --~a"
name)))
- (and (memq spec found)
- (eq? #t (option-spec->value-policy spec))
- (or val
- (fatal-error
- "option must be specified with argument: --~a"
- name)))
(let ((pred (option-spec->predicate spec)))
(and pred (pred name val)))))
specifications)
- (cons (cons '() rest-ls)
- (let ((multi-count (map (lambda (desc)
- (cons (car desc) 0))
- option-desc-list)))
- (map (lambda (spec)
- (let ((name (string->symbol (option-spec->name spec))))
- (cons name
- ;; handle multiple occurrances
- (let ((maybe-ls (option-spec->value spec)))
- (if (list? maybe-ls)
- (let* ((look (assq name multi-count))
- (idx (cdr look))
- (val (list-ref maybe-ls idx)))
- (set-cdr! look (1+ idx)) ; ugh!
- val)
- maybe-ls)))))
- found))))))
+ (for-each (lambda (spec+val)
+ (set-car! spec+val
+ (string->symbol (option-spec->name (car
spec+val)))))
+ found)
+ (cons (cons '() rest-ls) found))))
(define (option-ref options key default)
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
new file mode 100644
index 0000000..046d8f5
--- /dev/null
+++ b/module/scripts/list.scm
@@ -0,0 +1,83 @@
+;;; List --- List scripts that can be invoked by guile-tools -*- coding:
iso-8859-1 -*-
+
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guile-tools.
+
+;;; Code:
+
+(define-module (scripts list)
+ #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:export (list-scripts))
+
+
+(define (directory-files dir)
+ (if (and (file-exists? dir) (file-is-directory? dir))
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ; ignore
+ (string=? ".." new)) ; ignore
+ acc
+ (cons new acc))))))
+ '()))
+
+(define (strip-extensions path)
+ (or-map (lambda (ext)
+ (and
+ (string-suffix? ext path)
+ (substring path 0
+ (- (string-length path) (string-length ext)))))
+ (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) l)
+ ((equal? (car l) (cadr l)) (unique (cdr l)))
+ (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+ (let ((shead (map symbol->string head)))
+ (unique
+ (sort
+ (append-map (lambda (path)
+ (fold (lambda (x rest)
+ (let ((stripped (strip-extensions x)))
+ (if stripped (cons stripped rest) rest)))
+ '()
+ (directory-files
+ (fold (lambda (x y) (in-vicinity y x)) path
shead))))
+ %load-path)
+ string<?))))
+
+(define (list-scripts . args)
+ (for-each (lambda (x)
+ ;; would be nice to show a summary.
+ (format #t "~A\n" x))
+ (find-submodules '(scripts))))
+
+(define main list-scripts)
diff --git a/test-suite/tests/getopt-long.test
b/test-suite/tests/getopt-long.test
index d7f5184..4ae6048 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -252,7 +252,7 @@
)
-(with-test-prefix "multiple occurrances"
+(with-test-prefix "multiple occurrences"
(define (test9 . args)
(equal? (getopt-long (cons "foo" args)
@@ -288,4 +288,15 @@
)
+(with-test-prefix "stop-at-first-non-option"
+
+ (pass-if "guile-tools compile example"
+ (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o"
"eval.go")
+ '((help (single-char #\h))
+ (version (single-char #\v)))
+ #:stop-at-first-non-option #t)
+ '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go"))))
+
+ )
+
;;; getopt-long.test ends here
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-99-g153c4a4,
Neil Jerram <=