01/06: build: Remove check for broken (srfi srfi-37).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1d97fd8cb60f0b5f386f834940f859ff0b0bcc71
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 29 21:26:36 2017 +0200

    build: Remove check for broken (srfi srfi-37).
    
    This was for Guile < 2.0.9 and we've been requiring 2.0.9+ for some time
    already.
    
    * configure.ac: Remove 'GUIX_CHECK_SRFI_37' use and 'INSTALL_SRFI_37'
    conditional.
    * Makefile.am: Remove code in "if INSTALL_SRFI_37".
    (EXTRA_DIST): Remove srfi/srfi-37.scm.in.
    * srfi/srfi-37.scm.in: Remove.
    * m4/guix.m4 (GUIX_CHECK_SRFI_37): Remove.
---
 Makefile.am         |  13 ---
 configure.ac        |   4 -
 m4/guix.m4          |  19 -----
 srfi/srfi-37.scm.in | 233 ----------------------------------------------------
 4 files changed, 269 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 4dfcd06..8a5aa2b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -250,18 +250,6 @@ nobase_dist_guilemodule_DATA =                             
        \
 nobase_nodist_guilemodule_DATA = guix/config.scm
 nobase_nodist_guileobject_DATA = $(GOBJECTS)
 
-# 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
-
 # Handy way to remove the .go files without removing all the rest.
 clean-go:
        -$(RM) -f $(GOBJECTS)
@@ -441,7 +429,6 @@ EXTRA_DIST =                                                
\
   build-aux/run-system-tests.scm                       \
   d3.v3.js                                             \
   graph.js                                             \
-  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 c937e94..2b75c90 100644
--- a/configure.ac
+++ b/configure.ac
@@ -111,10 +111,6 @@ AM_CONDITIONAL([HAVE_GUILE_GIT], [test "x$have_guile_git" 
= "xyes"])
 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])
-
 dnl Decompressors, for use by the substituter and other modules.
 AC_PATH_PROG([GZIP], [gzip])
 AC_PATH_PROG([BZIP2], [bzip2])
diff --git a/m4/guix.m4 b/m4/guix.m4
index e546b8f..add57f5 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -136,25 +136,6 @@ AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [
   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])
-])
-
 dnl GUIX_CHECK_UNBUFFERED_CBIP
 dnl
 dnl Check whether 'setbvuf' works on custom binary input ports (CBIPs), as is
diff --git a/srfi/srfi-37.scm.in b/srfi/srfi-37.scm.in
deleted file mode 100644
index 3f654af..0000000
--- a/srfi/srfi-37.scm.in
+++ /dev/null
@@ -1,233 +0,0 @@
-;;; 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