Here is SRFI-37, args-fold, implemented by me from scratch in Scheme, including a manual section and a few tests. Patch does not include log entries, listed immediately below instead:
srfi/ChangeLog:
2007-07-14 Stephen Compall <[EMAIL PROTECTED]>
* srfi-37.scm: New file.
* Makefile.am: Add it.
test-suite/ChangeLog:
2007-07-14 Stephen Compall <[EMAIL PROTECTED]>
* tests/srfi-37.test: New file.
* Makefile.am: Add it.
doc/ref/ChangeLog:
2007-07-14 Stephen Compall <[EMAIL PROTECTED]>
* srfi-modules.texi: Describe SRFI-37 in a new subsection.
Index: doc/ref/srfi-modules.texi
===================================================================
RCS file: /sources/guile/guile/guile-core/doc/ref/srfi-modules.texi,v
retrieving revision 1.72
diff -u -d -u -r1.72 srfi-modules.texi
--- doc/ref/srfi-modules.texi 31 Jan 2007 20:58:20 -0000 1.72
+++ doc/ref/srfi-modules.texi 14 Jul 2007 08:23:01 -0000
@@ -37,6 +37,7 @@
* SRFI-19:: Time/Date library.
* SRFI-26:: Specializing parameters
* SRFI-31:: A special form `rec' for recursive evaluation
+* SRFI-37:: args-fold program argument processor
* SRFI-39:: Parameter objects
* SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits.
@@ -2401,6 +2402,93 @@
@end lisp
[EMAIL PROTECTED] SRFI-37
[EMAIL PROTECTED] SRFI-37 - args-fold
[EMAIL PROTECTED] SRFI-37
+
+This is a processor for GNU @code{getopt_long}-style program
+arguments. It provides an alternative, less declarative interface
+than @code{getopt-long} in @code{(ice-9 getopt-long)}
+(@pxref{getopt-long,,The (ice-9 getopt-long) Module}). Unlike
[EMAIL PROTECTED], it supports repeated options and any number of
+short and long names per option. Access it with:
+
[EMAIL PROTECTED]
+(use-modules (srfi srfi-37))
[EMAIL PROTECTED] lisp
+
[EMAIL PROTECTED] principally provides an @code{option} type and the
[EMAIL PROTECTED] function. To use the library, create a set of
+options with @code{option} and use it as a specification for invoking
[EMAIL PROTECTED]
+
+Here is an example of a simple argument processor for the typical
[EMAIL PROTECTED] and @samp{--help} options, which returns a backwards
+list of files given on the command line:
+
[EMAIL PROTECTED]
+(args-fold (cdr (program-arguments))
+ (let ((display-and-exit-proc
+ (lambda (msg)
+ (lambda (opt name arg loads)
+ (display msg) (quit)))))
+ (list (option '(#\v "version") #f #f
+ (display-and-exit-proc "Foo version 42.0\n"))
+ (option '(#\h "help") #f #f
+ (display-and-exit-proc
+ "Usage: foo scheme-file ..."))))
+ (lambda (opt name arg loads)
+ (error "Unrecognized option `~A'" name))
+ (lambda (op loads) (cons op loads))
+ '())
[EMAIL PROTECTED] lisp
+
[EMAIL PROTECTED] {Scheme Procedure} option names required-arg? optional-arg?
processor
+Return an object that specifies a single kind of program option.
+
[EMAIL PROTECTED] is a list of command-line option names, and should consist of
+characters for traditional @code{getopt} short options and strings for
[EMAIL PROTECTED] long options.
+
[EMAIL PROTECTED] and @var{optional-arg?} are mutually exclusive;
+one or both must be @code{#f}. If @var{required-arg?}, the option
+must be followed by an argument on the command line, such as
[EMAIL PROTECTED] for long options, or an error will be signalled.
+If @var{optional-arg?}, an argument will be taken if available.
+
[EMAIL PROTECTED] is a procedure that takes at least 3 arguments, called
+when @code{args-fold} encounters the option: the containing option
+object, the name used on the command line, and the argument given for
+the option (or @code{#f} if none). The rest of the arguments are
[EMAIL PROTECTED] ``seeds'', and the @var{processor} should return
+seeds as well.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} option-names opt
[EMAIL PROTECTED] {Scheme Procedure} option-required-arg? opt
[EMAIL PROTECTED] {Scheme Procedure} option-optional-arg? opt
[EMAIL PROTECTED] {Scheme Procedure} option-processor opt
+Return the specified field of @var{opt}, an option object, as
+described above for @code{option}.
[EMAIL PROTECTED] deffn
+
[EMAIL PROTECTED] {Scheme Procedure} args-fold args options
unrecognized-option-proc operand-proc seeds @dots{}
+Process @var{args}, a list of program arguments such as that returned
+by @code{(cdr (program-arguments))}, in order against @var{options}, a
+list of option objects as described above. All functions called take
+the ``seeds'', or the last multiple-values as multiple arguments,
+starting with @var{seeds}, and must return the new seeds. Return the
+final seeds.
+
+Call @code{unrecognized-option-proc}, which is like an option object's
+processor, for any options not found in @var{options}.
+
+Call @code{operand-proc} with any items on the command line that are
+not named options. This includes arguments after @samp{--}. It is
+called with the argument in question, as well as the seeds.
[EMAIL PROTECTED] deffn
+
+
@node SRFI-39
@subsection SRFI-39 - Parameters
@cindex SRFI-39
Index: srfi/Makefile.am
===================================================================
RCS file: /sources/guile/guile/guile-core/srfi/Makefile.am,v
retrieving revision 1.33
diff -u -d -u -r1.33 Makefile.am
--- srfi/Makefile.am 16 Apr 2006 23:18:55 -0000 1.33
+++ srfi/Makefile.am 14 Jul 2007 08:23:01 -0000
@@ -74,6 +74,7 @@
srfi-26.scm \
srfi-31.scm \
srfi-34.scm \
+ srfi-37.scm \
srfi-39.scm \
srfi-60.scm
Index: test-suite/Makefile.am
===================================================================
RCS file: /sources/guile/guile/guile-core/test-suite/Makefile.am,v
retrieving revision 1.40
diff -u -d -u -r1.40 Makefile.am
--- test-suite/Makefile.am 18 Nov 2006 18:14:55 -0000 1.40
+++ test-suite/Makefile.am 14 Jul 2007 08:23:01 -0000
@@ -76,6 +76,7 @@
tests/srfi-26.test \
tests/srfi-31.test \
tests/srfi-34.test \
+ tests/srfi-37.test \
tests/srfi-39.test \
tests/srfi-60.test \
tests/srfi-4.test \
--- /dev/null 2007-07-07 20:25:18.339081312 -0500
+++ srfi/srfi-37.scm 2007-07-13 22:30:41.000000000 -0500
@@ -0,0 +1,225 @@
+;;; srfi-37.scm --- args-fold
+
+;; Copyright (C) 2007 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 2.1 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
+
+To use this module with Guile, use (cdr (program-arguments)) as
+the ARGS argument to `args-fold'. Here is a short example:
+
+ (args-fold (cdr (program-arguments))
+ (let ((display-and-exit-proc
+ (lambda (msg)
+ (lambda (opt name arg)
+ (display msg) (quit) (values)))))
+ (list (option '(#\v "version") #f #f
+ (display-and-exit-proc "Foo version 42.0\n"))
+ (option '(#\h "help") #f #f
+ (display-and-exit-proc
+ "Usage: foo scheme-file ..."))))
+ (lambda (opt name arg)
+ (error "Unrecognized option `~A'" name))
+ (lambda (op) (load op) (values)))
+!#
+
+;;;; Module definition & exports
+(define-module (srfi srfi-37)
+ #:use-module (srfi srfi-9)
+ #:export (option option-names option-required-arg?
+ option-optional-arg? option-processor
+ args-fold))
+
+(cond-expand-provide (current-module) '(srfi-37))
+
+;;;; args-fold and periphery procedures
+
+;;; An option as answered by `option'. `names' is a list of
+;;; characters and strings, representing associated short-options and
+;;; long-options respectively that should use this option's
+;;; `processor' in an `args-fold' call.
+;;;
+;;; `required-arg?' and `optional-arg?' are mutually exclusive
+;;; booleans and indicate whether an argument must be or may be
+;;; provided. Besides the obvious, this affects semantics of
+;;; short-options, as short-options with a required or optional
+;;; argument cannot be followed by other short options in the same
+;;; program-arguments string, as they will be interpreted collectively
+;;; as the option's argument.
+;;;
+;;; `processor' is called when this option is encountered. It should
+;;; accept the containing option, the element of `names' (by `equal?')
+;;; encountered, the option's argument (or #f if none), and the seeds
+;;; as variadic arguments, answering the new seeds as values.
+(define-record-type srfi-37:option
+ (option names required-arg? optional-arg? processor)
+ option?
+ (names option-names)
+ (required-arg? option-required-arg?)
+ (optional-arg? option-optional-arg?)
+ (processor option-processor))
+
+(define (error-duplicate-option option-name)
+ (scm-error 'program-error "args-fold"
+ "Duplicate option name `~A~A'"
+ (list (if (char? option-name) #\- "--")
+ option-name)
+ #f))
+
+(define (build-options-lookup options)
+ "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
+to the containing options, signalling an error if a name is
+encountered more than once."
+ (let ((lookup (make-hash-table (* 2 (length options)))))
+ (for-each
+ (lambda (opt)
+ (for-each (lambda (name)
+ (let ((assoc (hash-create-handle!
+ lookup name #f)))
+ (if (cdr assoc)
+ (error-duplicate-option (car assoc))
+ (set-cdr! assoc opt))))
+ (option-names opt)))
+ options)
+ lookup))
+
+(define (args-fold args options unrecognized-option-proc
+ operand-proc . seeds)
+ "Answer the results of folding SEEDS as multiple values against the
+program-arguments in ARGS, as decided by the OPTIONS'
+`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
+ (let ((lookup (build-options-lookup options)))
+ ;; I don't like Guile's `error' here
+ (define (error msg . args)
+ (scm-error 'misc-error "args-fold" msg args #f))
+
+ (define (mutate-seeds! procedure . params)
+ (set! seeds (call-with-values
+ (lambda ()
+ (apply procedure (append params seeds)))
+ list)))
+
+ ;; Clean up the rest of ARGS, assuming they're all operands.
+ (define (rest-operands)
+ (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
+ args)
+ (set! args '()))
+
+ ;; Call OPT's processor with OPT, NAME, an argument to be decided,
+ ;; and the seeds. Depending on OPT's *-arg? specification, get
+ ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
+ ;; if no argument is allowed, call NO-ARG-PROC thunk.
+ (define (invoke-option-processor
+ opt name req-arg-proc opt-arg-proc no-arg-proc)
+ (mutate-seeds!
+ (option-processor opt) opt name
+ (cond ((option-required-arg? opt) (req-arg-proc))
+ ((option-optional-arg? opt) (opt-arg-proc))
+ (else (no-arg-proc) #f))))
+
+ ;; Compute and answer a short option argument, advancing ARGS as
+ ;; necessary, for the short option whose character is at POSITION
+ ;; in the current ARG.
+ (define (short-option-argument position)
+ (cond ((< (1+ position) (string-length (car args)))
+ (let ((result (substring (car args) (1+ position))))
+ (set! args (cdr args))
+ result))
+ ((pair? (cdr args))
+ (let ((result (cadr args)))
+ (set! args (cddr args))
+ result))
+ (else #f)))
+
+ ;; Interpret the short-option at index POSITION in (car ARGS),
+ ;; followed by the remaining short options in (car ARGS).
+ (define (short-option position)
+ (if (>= position (string-length (car args)))
+ (next-arg)
+ (let* ((opt-name (string-ref (car args) position))
+ (option-here (hash-ref lookup opt-name)))
+ (cond ((not option-here)
+ (mutate-seeds! unrecognized-option-proc
+ (option (list opt-name) #f #f
+ unrecognized-option-proc)
+ opt-name #f)
+ (short-option (1+ position)))
+ (else
+ (invoke-option-processor
+ option-here opt-name
+ (lambda ()
+ (or (short-option-argument position)
+ (error "Missing required argument after `-~A'"
opt-name)))
+ (lambda ()
+ ;; edge case: -xo -zf or -xo -- where opt-name=#\o
+ ;; GNU getopt_long resolves these like I do
+ (short-option-argument position))
+ (lambda () #f))
+ (if (not (or (option-required-arg? option-here)
+ (option-optional-arg? option-here)))
+ (short-option (1+ position))))))))
+
+ ;; Process the long option in (car ARGS). We make the
+ ;; interesting, possibly non-standard assumption that long option
+ ;; names might contain #\=, so keep looking for more #\= in (car
+ ;; ARGS) until we find a named option in lookup.
+ (define (long-option)
+ (let ((arg (car args)))
+ (let place-=-after ((start-pos 2))
+ (let* ((index (string-index arg #\= start-pos))
+ (opt-name (substring arg 2 (or index (string-length arg))))
+ (option-here (hash-ref lookup opt-name)))
+ (if (not option-here)
+ ;; look for a later #\=, unless there can't be one
+ (if index
+ (place-=-after (1+ index))
+ (mutate-seeds!
+ unrecognized-option-proc
+ (option (list opt-name) #f #f unrecognized-option-proc)
+ opt-name #f))
+ (invoke-option-processor
+ option-here opt-name
+ (lambda ()
+ (if index
+ (substring arg (1+ index))
+ (error "Missing required argument after `--~A'"
opt-name)))
+ (lambda () (and index (substring arg (1+ index))))
+ (lambda ()
+ (if index
+ (error "Extraneous argument after `--~A'"
opt-name))))))))
+ (set! args (cdr args)))
+
+ ;; Process the remaining in ARGS. Basically like calling
+ ;; `args-fold', but without having to regenerate `lookup' and the
+ ;; funcs above.
+ (define (next-arg)
+ (if (null? args)
+ (apply values seeds)
+ (let ((arg (car args)))
+ (cond ((or (not (char=? #\- (string-ref arg 0)))
+ (= 1 (string-length arg))) ;"-"
+ (mutate-seeds! operand-proc arg)
+ (set! args (cdr args)))
+ ((char=? #\- (string-ref arg 1))
+ (if (= 2 (string-length arg)) ;"--"
+ (begin (set! args (cdr args)) (rest-operands))
+ (long-option)))
+ (else (short-option 1)))
+ (next-arg))))
+
+ (next-arg)))
+
+;;; srfi-37.scm ends here
--- /dev/null 2007-07-07 20:25:18.339081312 -0500
+++ test-suite/tests/srfi-37.test 2007-07-13 22:59:42.000000000 -0500
@@ -0,0 +1,97 @@
+;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program 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 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-37)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-37))
+
+(with-test-prefix "SRFI-37"
+
+ (pass-if "empty calls with count-modified seeds"
+ (equal? (list 21 42)
+ (call-with-values
+ (lambda ()
+ (args-fold '("1" "3" "4") '()
+ (lambda (opt name arg seed seed2)
+ (values 1 2))
+ (lambda (op seed seed2)
+ (values (1+ seed) (+ 2 seed2)))
+ 18 36))
+ list)))
+
+ (pass-if "short opt params"
+ (let ((a-set #f) (b-set #f) (c-val #f) (d-val #f) (no-fail #t)
(no-operands #t))
+ (args-fold '("-abcdoit" "-ad" "whatev")
+ (list (option '(#\a) #f #f (lambda (opt name arg)
+ (set! a-set #t)
+ (values)))
+ (option '(#\b) #f #f (lambda (opt name arg)
+ (set! b-set #t)
+ (values)))
+ (option '("cdoit" #\c) #f #t
+ (lambda (opt name arg)
+ (set! c-val arg)
+ (values)))
+ (option '(#\d) #f #t
+ (lambda (opt name arg)
+ (set! d-val arg)
+ (values))))
+ (lambda (opt name arg) (set! no-fail #f) (values))
+ (lambda (oper) (set! no-operands #f) (values)))
+ (equal? '(#t #t "doit" "whatev" #t #t)
+ (list a-set b-set c-val d-val no-fail no-operands))))
+
+ (pass-if "single unrecognized long-opt"
+ (equal? "fake"
+ (args-fold '("--fake" "-i2")
+ (list (option '(#\i) #t #f
+ (lambda (opt name arg k) k)))
+ (lambda (opt name arg k) name)
+ (lambda (operand k) #f)
+ #f)))
+
+ (pass-if "long req'd/optional"
+ (equal? '(#f "bsquare" "apple")
+ (args-fold '("--x=pple" "--y=square" "--y")
+ (list (option '("x") #t #f
+ (lambda (opt name arg k)
+ (cons (string-append "a" arg) k)))
+ (option '("y") #f #t
+ (lambda (opt name arg k)
+ (cons (if arg
+ (string-append "b" arg)
+ #f) k))))
+ (lambda (opt name arg k) #f)
+ (lambda (opt name arg k) #f)
+ '())))
+
+ ;; this matches behavior of getopt_long in libc 2.4
+ (pass-if "short options absorb special markers in the next arg"
+ (let ((arg-proc (lambda (opt name arg k)
+ (acons name arg k))))
+ (equal? '((#\y . "-z") (#\x . "--") (#\z . #f))
+ (args-fold '("-zx" "--" "-y" "-z" "--")
+ (list (option '(#\x) #f #t arg-proc)
+ (option '(#\z) #f #f arg-proc)
+ (option '(#\y) #t #f arg-proc))
+ (lambda (opt name arg k) #f)
+ (lambda (opt name arg k) #f)
+ '()))))
+
+)
--
;;; Stephen Compall ** http://scompall.nocandysw.com/blog **
"Peta" is Greek for fifth; a petabyte is 10 to the fifth power, as
well as fifth in line after kilo, mega, giga, and tera.
-- Lee Gomes, performing every Wednesday in his tech column
"Portals" on page B1 of The Wall Street Journal
signature.asc
Description: This is a digitally signed message part
_______________________________________________ Guile-devel mailing list Guile-devel@gnu.org http://lists.gnu.org/mailman/listinfo/guile-devel
