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.master
Ludovic Courtès
parent
95bbaa02aa
commit
1d97fd8cb6
13
Makefile.am
13
Makefile.am
|
|
@ -250,18 +250,6 @@ nobase_dist_guilemodule_DATA = \
|
||||||
nobase_nodist_guilemodule_DATA = guix/config.scm
|
nobase_nodist_guilemodule_DATA = guix/config.scm
|
||||||
nobase_nodist_guileobject_DATA = $(GOBJECTS)
|
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.
|
# Handy way to remove the .go files without removing all the rest.
|
||||||
clean-go:
|
clean-go:
|
||||||
-$(RM) -f $(GOBJECTS)
|
-$(RM) -f $(GOBJECTS)
|
||||||
|
|
@ -441,7 +429,6 @@ EXTRA_DIST = \
|
||||||
build-aux/run-system-tests.scm \
|
build-aux/run-system-tests.scm \
|
||||||
d3.v3.js \
|
d3.v3.js \
|
||||||
graph.js \
|
graph.js \
|
||||||
srfi/srfi-37.scm.in \
|
|
||||||
srfi/srfi-64.scm \
|
srfi/srfi-64.scm \
|
||||||
srfi/srfi-64.upstream.scm \
|
srfi/srfi-64.upstream.scm \
|
||||||
tests/test.drv \
|
tests/test.drv \
|
||||||
|
|
|
||||||
|
|
@ -111,10 +111,6 @@ AM_CONDITIONAL([HAVE_GUILE_GIT], [test "x$have_guile_git" = "xyes"])
|
||||||
dnl Make sure we have a full-fledged Guile.
|
dnl Make sure we have a full-fledged Guile.
|
||||||
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])
|
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.
|
dnl Decompressors, for use by the substituter and other modules.
|
||||||
AC_PATH_PROG([GZIP], [gzip])
|
AC_PATH_PROG([GZIP], [gzip])
|
||||||
AC_PATH_PROG([BZIP2], [bzip2])
|
AC_PATH_PROG([BZIP2], [bzip2])
|
||||||
|
|
|
||||||
19
m4/guix.m4
19
m4/guix.m4
|
|
@ -136,25 +136,6 @@ AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [
|
||||||
done
|
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 GUIX_CHECK_UNBUFFERED_CBIP
|
||||||
dnl
|
dnl
|
||||||
dnl Check whether 'setbvuf' works on custom binary input ports (CBIPs), as is
|
dnl Check whether 'setbvuf' works on custom binary input ports (CBIPs), as is
|
||||||
|
|
|
||||||
|
|
@ -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
|
|
||||||
Reference in New Issue