[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-36-g0b
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-36-g0bc86fc |
|
Date: |
Thu, 10 Feb 2011 12:36:24 +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=0bc86fcedcd19a1a388faa6505f822d57a30584c
The branch, master has been updated
via 0bc86fcedcd19a1a388faa6505f822d57a30584c (commit)
via 13f607c175b7df585a248145dfd7426334630ee7 (commit)
via cafb15e96ef6230e0724d31248622b5343cb8be7 (commit)
via 8b9b0af445d173031b7c2443e345fb98597cf296 (commit)
via 88c9420c1594c7a9ec3b2b771e97826e560f6460 (commit)
via 887fac45215f301e13d7c9521f4ff20ed1db9c81 (commit)
via 23f11f1dfd0e146f9e960f490d345057b375307c (commit)
via 7112a34d56ff0611220b0e9f024ad0fffbe3cdad (commit)
from cd4f274c622511ac9b45cd16d6e6a542bd07464c (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 0bc86fcedcd19a1a388faa6505f822d57a30584c
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 12:09:18 2011 +0100
getopt-long: arg parsing errors cause print and exit, not backtrace
* module/ice-9/getopt-long.scm (fatal-error): New helper. For errors
that come from the user -- i.e., not the grammar -- we will handle our
own error printing and call `exit' rather than relying on the root
catch handler. This is more friendly to the user than a Scheme
backtrace.
(parse-option-spec, process-options, getopt-long): Call `fatal-error'
as appropriate.
* test-suite/tests/getopt-long.test (pass-if-fatal-exception): New
helper, checks that a certain key was thrown to, and that suitable
output has been printed on an error port.
(deferr): Change to expect a 'quit key instead of 'misc-error. Update
exceptions to not match the beginning of the string, as that will be
the program name. Update tests to use pass-if-fatal-exception.
commit 13f607c175b7df585a248145dfd7426334630ee7
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 11:40:24 2011 +0100
getopt-long cleanups
* module/ice-9/getopt-long.scm (process-options): Use `match' in the
loop. Clean up `eat' to not take the option being processed.
commit cafb15e96ef6230e0724d31248622b5343cb8be7
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 11:31:30 2011 +0100
getopt-long cleanup
* module/ice-9/getopt-long.scm (process-options): Use more internal
definitions instead of let-bound functions to decrease the nesting
depth.
commit 8b9b0af445d173031b7c2443e345fb98597cf296
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 11:25:22 2011 +0100
getopt-long cleanup
* module/ice-9/getopt-long.scm (looks-like-an-option): Remove obtuse use
of "some".
commit 88c9420c1594c7a9ec3b2b771e97826e560f6460
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 11:22:17 2011 +0100
getopt-long uses match:substring from (ice-9 regex)
* module/ice-9/getopt-long.scm: Import (ice-9 regex), and use its
match:substring instead of our own.
commit 887fac45215f301e13d7c9521f4ff20ed1db9c81
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 11:19:02 2011 +0100
match-lambda in getopt-long
* module/ice-9/getopt-long.scm (parse-option-spec): Use match-lambda to
parse the grammar.
commit 23f11f1dfd0e146f9e960f490d345057b375307c
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 11:04:31 2011 +0100
getopt-long uses srfi-9 records internally
* module/ice-9/getopt-long.scm: #:keywords in the define-module block.
(option-spec): Define as a srfi-9 record instead of playing macro
games with boot-9 records.
commit 7112a34d56ff0611220b0e9f024ad0fffbe3cdad
Author: Andy Wingo <address@hidden>
Date: Thu Feb 10 10:40:57 2011 +0100
volatile locals in bootstrap evaluator
* libguile/eval.c (eval): For SCM_M_PROMPT, mark the locals needed after
a longjmp as volatile. Perhaps related to bug 32340.
-----------------------------------------------------------------------
Summary of changes:
libguile/eval.c | 5 +-
module/ice-9/getopt-long.scm | 328 +++++++++++++++++--------------------
test-suite/tests/getopt-long.test | 50 ++++--
3 files changed, 188 insertions(+), 195 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index 7852178..6f2020e 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -408,7 +408,10 @@ eval (SCM x, SCM env)
case SCM_M_PROMPT:
{
- SCM vm, prompt, handler, res;
+ SCM vm, res;
+ /* We need the prompt and handler values after a longjmp case,
+ so make sure they are volatile. */
+ volatile SCM handler, prompt;
vm = scm_the_vm ();
prompt = scm_c_make_prompt (eval (CAR (mx), env), SCM_VM_DATA (vm)->fp,
diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 891a2e3..1b170b4 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -1,4 +1,4 @@
-;;; Copyright (C) 1998, 2001, 2006, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 1998, 2001, 2006, 2009, 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
@@ -157,69 +157,62 @@
;;; Code:
(define-module (ice-9 getopt-long)
- :use-module ((ice-9 common-list) :select (some remove-if-not))
- :export (getopt-long option-ref))
+ #:use-module ((ice-9 common-list) #:select (remove-if-not))
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:export (getopt-long option-ref))
-(eval-when (eval load compile)
- ;; This binding is used both at compile-time and run-time.
- (define option-spec-fields '(name
- value
- required?
- single-char
- predicate
- value-policy)))
+(define %program-name (make-fluid))
+(define (program-name)
+ (or (fluid-ref %program-name) "guile"))
-(define option-spec (make-record-type 'option-spec option-spec-fields))
-(define make-option-spec (record-constructor option-spec option-spec-fields))
+(define (fatal-error fmt . args)
+ (format (current-error-port) "~a: " (program-name))
+ (apply format (current-error-port) fmt args)
+ (newline (current-error-port))
+ (exit 1))
-(eval-when (eval load compile)
- ;; The following procedures are used only at compile-time when expanding
- ;; `define-all-option-spec-accessors/modifiers' (see below).
+(define-record-type option-spec
+ (%make-option-spec name value required? 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->single-char set-option-spec-single-char!)
+ (predicate
+ option-spec->predicate set-option-spec-predicate!)
+ (value-policy
+ option-spec->value-policy set-option-spec-value-policy!))
- (define (define-one-option-spec-field-accessor field)
- `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
- (record-accessor option-spec ',field)))
-
- (define (define-one-option-spec-field-modifier field)
- `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
- (record-modifier option-spec ',field))))
-
-(defmacro define-all-option-spec-accessors/modifiers ()
- `(begin
- ,@(map define-one-option-spec-field-accessor option-spec-fields)
- ,@(map define-one-option-spec-field-modifier option-spec-fields)))
-
-(define-all-option-spec-accessors/modifiers)
-
-(define make-option-spec
- (let ((ctor (record-constructor option-spec '(name))))
- (lambda (name)
- (ctor name))))
+(define (make-option-spec name)
+ (%make-option-spec name #f #f #f #f #f))
(define (parse-option-spec desc)
(let ((spec (make-option-spec (symbol->string (car desc)))))
- (for-each (lambda (desc-elem)
- (let ((given (lambda () (cadr desc-elem))))
- (case (car desc-elem)
- ((required?)
- (set-option-spec-required?! spec (given)))
- ((value)
- (set-option-spec-value-policy! spec (given)))
- ((single-char)
- (or (char? (given))
- (error "`single-char' value must be a char!"))
- (set-option-spec-single-char! spec (given)))
- ((predicate)
- (set-option-spec-predicate!
- spec ((lambda (pred)
- (lambda (name val)
- (or (not val)
- (pred val)
- (error "option predicate failed:" name))))
- (given))))
- (else
- (error "invalid getopt-long option property:"
- (car desc-elem))))))
+ (for-each (match-lambda
+ (('required? val)
+ (set-option-spec-required?! spec val))
+ (('value val)
+ (set-option-spec-value-policy! spec val))
+ (('single-char val)
+ (or (char? val)
+ (error "`single-char' value must be a char!"))
+ (set-option-spec-single-char! spec val))
+ (('predicate pred)
+ (set-option-spec-predicate!
+ spec (lambda (name val)
+ (or (not val)
+ (pred val)
+ (fatal-error "option predicate failed: --~a"
+ name)))))
+ ((prop val)
+ (error "invalid getopt-long option property:" prop)))
(cdr desc))
spec))
@@ -235,11 +228,6 @@
(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
-(define (match-substring match which)
- ;; condensed from (ice-9 regex) `match:{substring,start,end}'
- (let ((sel (vector-ref match (1+ which))))
- (substring (vector-ref match 0) (car sel) (cdr sel))))
-
(define (expand-clumped-singles opt-ls)
;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
(let loop ((opt-ls opt-ls) (ret-ls '()))
@@ -251,8 +239,8 @@
(map (lambda (c)
(string-append "-" (make-string 1 c)))
(string->list
- (match-substring match 1)))))
- (extra (match-substring match 2)))
+ (match:substring match 1)))))
+ (extra (match:substring match 2)))
(loop (cdr opt-ls)
(append (if (string=? "" extra)
singles
@@ -262,11 +250,9 @@
(cons (car opt-ls) ret-ls))))))
(define (looks-like-an-option string)
- (some (lambda (rx)
- (regexp-exec rx string))
- `(,short-opt-rx
- ,long-opt-with-value-rx
- ,long-opt-no-value-rx)))
+ (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)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
@@ -281,77 +267,60 @@
spec))
(remove-if-not 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!
- 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)))
- (ERR:no-arg (lambda ()
- (error (string-append
- "option must be specified"
- " with argument:")
- (option-spec->name spec)))))
- (cond
- ((eq? 'optional (option-spec->value-policy spec))
- (if (or (null? (cdr ls))
- (looks-like-an-option (cadr ls)))
- (val!loop #t
- (cdr ls)
- (cons spec found)
- etc)
- (val!loop (cadr ls)
- (cddr ls)
- (cons spec found)
- etc)))
- ((eq? #t (option-spec->value-policy spec))
- (if (or (null? (cdr ls))
- (looks-like-an-option (cadr ls)))
- (ERR:no-arg)
- (val!loop (cadr ls)
- (cddr ls)
- (cons spec found)
- etc)))
- (else
- (val!loop #t
- (cdr ls)
- (cons spec found)
- etc)))))))
- (if (null? argument-ls)
- (cons found (reverse etc)) ;;; retval
- (cond ((regexp-exec short-opt-rx (car argument-ls))
- => (lambda (match)
- (let* ((c (match-substring match 1))
- (spec (or (assoc-ref sc-idx c)
- (error "no such option:" c))))
- (eat! spec argument-ls))))
- ((regexp-exec long-opt-no-value-rx (car argument-ls))
- => (lambda (match)
- (let* ((opt (match-substring match 1))
- (spec (or (assoc-ref idx opt)
- (error "no such option:" opt))))
- (eat! spec argument-ls))))
- ((regexp-exec long-opt-with-value-rx (car argument-ls))
- => (lambda (match)
- (let* ((opt (match-substring match 1))
- (spec (or (assoc-ref idx opt)
- (error "no such option:" opt))))
- (if (option-spec->value-policy spec)
- (eat! spec (append
- (list 'ignored
- (match-substring match 2))
- (cdr argument-ls)))
- (error "option does not support argument:"
- opt)))))
- (else
- (loop (cdr argument-ls)
- found
- (cons (car argument-ls) 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)))
+ ((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)))
+ (else
+ (val!loop #t ls (cons spec found) etc))))
+
+ (match argument-ls
+ (()
+ (cons found (reverse etc)))
+ ((opt . rest)
+ (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))))
+ ((regexp-exec long-opt-no-value-rx opt)
+ => (lambda (match)
+ (let* ((opt (match:substring match 1))
+ (spec (or (assoc-ref idx opt)
+ (fatal-error "no such option: --~a" opt))))
+ (eat! spec rest))))
+ ((regexp-exec long-opt-with-value-rx opt)
+ => (lambda (match)
+ (let* ((opt (match:substring match 1))
+ (spec (or (assoc-ref idx opt)
+ (fatal-error "no such option: --~a" opt))))
+ (if (option-spec->value-policy spec)
+ (eat! spec (cons (match:substring match 2) rest))
+ (fatal-error "option does not support argument: --~a"
+ opt)))))
+ (else
+ (loop rest found (cons opt etc)))))))))
(define (getopt-long program-arguments option-desc-list)
"Process options, handling both long and short options, similar to
@@ -384,44 +353,47 @@ or option values.
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)))
- (non-split-ls (cdr pair))
- (found/etc (process-options specifications split-ls))
- (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)))
- (and (option-spec->required? spec)
- (or (memq spec found)
- (error "option must be specified:" name)))
- (and (memq spec found)
- (eq? #t (option-spec->value-policy spec))
- (or val
- (error "option must be specified with argument:"
- 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)))))
+ (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)))
+ (non-split-ls (cdr pair))
+ (found/etc (process-options specifications split-ls))
+ (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)))
+ (and (option-spec->required? spec)
+ (or (memq spec found)
+ (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))))))
(define (option-ref options key default)
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
diff --git a/test-suite/tests/getopt-long.test
b/test-suite/tests/getopt-long.test
index 2c6f415..d7f5184 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -1,7 +1,7 @@
;;;; getopt-long.test --- long options processing -*- scheme -*-
;;;; Thien-Thi Nguyen <address@hidden> --- August 2001
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 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
@@ -21,15 +21,33 @@
(ice-9 getopt-long)
(ice-9 regex))
+(define-syntax pass-if-fatal-exception
+ (syntax-rules ()
+ ((_ name exn exp)
+ (let ((port (open-output-string)))
+ (with-error-to-port port
+ (lambda ()
+ (run-test
+ name #t
+ (lambda ()
+ (catch (car exn)
+ (lambda () exp #f)
+ (lambda (k . args)
+ (let ((output (get-output-string port)))
+ (close-port port)
+ (if (string-match (cdr exn) output)
+ #t
+ (error "Unexpected output" output)))))))))))))
+
(defmacro deferr (name-frag re)
(let ((name (symbol-append 'exception: name-frag)))
- `(define ,name (cons 'misc-error ,re))))
+ `(define ,name (cons 'quit ,re))))
-(deferr no-such-option "^no such option")
-(deferr option-predicate-failed "^option predicate failed")
-(deferr option-does-not-support-arg "^option does not support argument")
-(deferr option-must-be-specified "^option must be specified")
-(deferr option-must-have-arg "^option must be specified with argument")
+(deferr no-such-option "no such option")
+(deferr option-predicate-failed "option predicate failed")
+(deferr option-does-not-support-arg "option does not support argument")
+(deferr option-must-be-specified "option must be specified")
+(deferr option-must-have-arg "option must be specified with argument")
(with-test-prefix "exported procs"
(pass-if "`option-ref' defined" (defined? 'option-ref))
@@ -47,11 +65,11 @@
(equal? (test1 "foo" "bar" "--test=123")
'((() "bar") (test . "123"))))
- (pass-if-exception "invalid arg"
+ (pass-if-fatal-exception "invalid arg"
exception:option-predicate-failed
(test1 "foo" "bar" "--test=foo"))
- (pass-if-exception "option has no arg"
+ (pass-if-fatal-exception "option has no arg"
exception:option-must-have-arg
(test1 "foo" "bar" "--test"))
@@ -138,7 +156,7 @@
(equal? (test5 '() '())
'((()))))
- (pass-if-exception "not mentioned, given"
+ (pass-if-fatal-exception "not mentioned, given"
exception:no-such-option
(test5 '("--req") '((something))))
@@ -158,7 +176,7 @@
(equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
'((()) (req . "7"))))
- (pass-if-exception "specified required, not given"
+ (pass-if-fatal-exception "specified required, not given"
exception:option-must-be-specified
(test5 '() '((req (required? #t)))))
@@ -169,7 +187,7 @@
(define (test6 args specs)
(getopt-long (cons "foo" args) specs))
- (pass-if-exception "using \"=\" syntax"
+ (pass-if-fatal-exception "using \"=\" syntax"
exception:option-does-not-support-arg
(test6 '("--maybe=yes") '((maybe))))
@@ -193,15 +211,15 @@
(equal? (test7 '("--hmm=101"))
'((()) (hmm . "101"))))
- (pass-if-exception "short opt, arg not given"
+ (pass-if-fatal-exception "short opt, arg not given"
exception:option-must-have-arg
(test7 '("-H")))
- (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)"
+ (pass-if-fatal-exception "long non-\"=\" opt, arg not given (next arg an
option)"
exception:option-must-have-arg
(test7 '("--hmm" "--ignore")))
- (pass-if-exception "long \"=\" opt, arg not given"
+ (pass-if-fatal-exception "long \"=\" opt, arg not given"
exception:option-must-have-arg
(test7 '("--hmm")))
@@ -228,7 +246,7 @@
(pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
(pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang"))
- (pass-if-exception "bad ordering causes missing option"
+ (pass-if-fatal-exception "bad ordering causes missing option"
exception:option-must-have-arg
(test8 "-abc" "couth" "bang"))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-15-36-g0bc86fc,
Andy Wingo <=