build: Provide a replacement (srfi srfi-37) when the user's one is broken.

* srfi/srfi-37.scm.in: New file, taken from Guile 2.0.9.
* m4/guix.m4: New macro.
* configure.ac: Use it.  Define Automake conditional `INSTALL_SRFI_37'.
* Makefile.am (nobase_nodist_guilemodule_DATA)[INSTALL_SRFI_37]: Add
  srfi/srfi-37.scm.
  (GOBJECTS)[INSTALL_SRFI_37]: Add srfi/srfi-37.go.
  (srfi/srfi-37.scm)[INSTALL_SRFI_37]: New target.
  (EXTRA_DIST): Add srfi/srfi-37.scm.in.

4 files changed, 270 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index ecda21c77f..ed3607300f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -74,12 +74,24 @@ MODULES =					\
 # first to avoid errors on systems where (gnutls) is unavailable.
 guix/scripts/download.go: guix/build/download.go
 
+
 GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go
 
 nobase_dist_guilemodule_DATA = $(MODULES)
+nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm
 
+# Do we need to provide our own non-broken (srfi srfi-37) module?
+if INSTALL_SRFI_37
+
+nobase_nodist_guilemodule_DATA += srfi/srfi-37.scm
+GOBJECTS += srfi/srfi-37.go
+
+srfi/srfi-37.scm: srfi/srfi-37.scm.in
+	$(MKDIR_P) srfi
+	cp "$<" "$@"
+
+endif INSTALL_SRFI_37
 
-nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm
 
 SCM_TESTS =					\
   tests/base32.scm				\
@@ -133,6 +145,7 @@ EXTRA_DIST =					\
   build-aux/download.scm			\
   build-aux/list-packages.scm			\
   build-aux/sync-synopses.scm			\
+  srfi/srfi-37.scm.in				\
   srfi/srfi-64.scm				\
   srfi/srfi-64.upstream.scm			\
   tests/test.drv				\
diff --git a/configure.ac b/configure.ac
index 80d35a4272..2700bb65ea 100644
--- a/configure.ac
+++ b/configure.ac
@@ -51,6 +51,10 @@ fi
 dnl Make sure we have a full-fledged Guile.
 GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
 
+dnl Check whether (srfi srfi-37) works, and provide our own if it doesn't.
+GUIX_CHECK_SRFI_37
+AM_CONDITIONAL([INSTALL_SRFI_37], [test "x$ac_cv_guix_srfi_37_broken" = xyes])
+
 AC_ARG_WITH([nix-prefix],
   [AS_HELP_STRING([--with-nix-prefix=DIR], [search for Nix in DIR])],
   [case "$withval" in
diff --git a/m4/guix.m4 b/m4/guix.m4
index 477b0e4eb3..63fa00be2f 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -115,3 +115,22 @@ AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [
     fi
   done
 ])
+
+dnl GUIX_CHECK_SRFI_37
+dnl
+dnl Check whether SRFI-37 suffers from <http://bugs.gnu.org/13176>.
+dnl This bug was fixed in Guile 2.0.9.
+AC_DEFUN([GUIX_CHECK_SRFI_37], [
+  AC_CACHE_CHECK([whether (srfi srfi-37) is affected by http://bugs.gnu.org/13176],
+    [ac_cv_guix_srfi_37_broken],
+    [if "$GUILE" -c "(use-modules (srfi srfi-37))			\
+       (sigaction SIGALRM (lambda _ (primitive-exit 1)))		\
+       (alarm 1)							\
+       (define opts (list (option '(#\I) #f #t (lambda _ #t))))		\
+       (args-fold '(\"-I\") opts (lambda _ (error)) (lambda _ #f) '())"
+     then
+       ac_cv_guix_srfi_37_broken=no
+     else
+       ac_cv_guix_srfi_37_broken=yes
+     fi])
+])
diff --git a/srfi/srfi-37.scm.in b/srfi/srfi-37.scm.in
new file mode 100644
index 0000000000..3f654af2ce
--- /dev/null
+++ b/srfi/srfi-37.scm.in
@@ -0,0 +1,233 @@
+;;; srfi-37.scm --- args-fold
+
+;; 	Copyright (C) 2007, 2008, 2013 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:
+;;
+;; 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)))
+;;
+;;; Code:
+
+
+;;;; 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))
+            ((pair? args)
+             (set! args (cdr args))
+             #f)
+	    (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)))
+          (begin
+            (set! args (cdr 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