Merge branch 'master' into core-updates

11 files changed, 103 insertions, 322 deletions

diff --git a/Makefile.am b/Makefile.am
index 4dfcd06d0b..f6059d94bf 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					\
@@ -598,9 +585,6 @@ GUIXSD_IMAGE_BASE = guixsd-usb-install-$(PACKAGE_VERSION)
 # Prefix of the GuixSD VM image file name.
 GUIXSD_VM_IMAGE_BASE = guixsd-vm-image-$(PACKAGE_VERSION)
 
-# Size of the installation image (for x86_64 typically).
-GUIXSD_INSTALLATION_IMAGE_SIZE ?= 950MiB
-
 # Size of the VM image (for x86_64 typically).
 GUIXSD_VM_IMAGE_SIZE ?= 2GiB
 
@@ -648,7 +632,6 @@ release: dist
 	  image=`$(top_builddir)/pre-inst-env						\
 	    guix system disk-image							\
             --system=$$system								\
-	    --image-size=$(GUIXSD_INSTALLATION_IMAGE_SIZE)				\
 	    gnu/system/install.scm` ;							\
 	  if [ ! -f "$$image" ] ; then							\
 	    echo "failed to produced GuixSD installation image for $$system" >&2 ;	\
diff --git a/configure.ac b/configure.ac
index c937e948d3..2b75c900cc 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/doc/guix.texi b/doc/guix.texi
index 729ec081be..d61a5b7514 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7877,9 +7877,8 @@ that.
 The installation image described above was built using the @command{guix
 system} command, specifically:
 
-@c FIXME: 1G is too much; see <http://bugs.gnu.org/23077>.
 @example
-guix system disk-image --image-size=1G gnu/system/install.scm
+guix system disk-image gnu/system/install.scm
 @end example
 
 Have a look at @file{gnu/system/install.scm} in the source tree,
@@ -16187,8 +16186,9 @@ size of the image.
 @item vm-image
 @itemx disk-image
 Return a virtual machine or disk image of the operating system declared
-in @var{file} that stands alone.  Use the @option{--image-size} option
-to specify the size of the image.
+in @var{file} that stands alone.  By default, @command{guix system}
+estimates the size of the image needed to store the system, but you can
+use the @option{--image-size} option to specify a value.
 
 When using @code{vm-image}, the returned image is in qcow2 format, which
 the QEMU emulator can efficiently use. @xref{Running GuixSD in a VM},
@@ -16251,6 +16251,10 @@ of the given @var{size}.  @var{size} may be a number of bytes, or it may
 include a unit as a suffix (@pxref{Block size, size specifications,,
 coreutils, GNU Coreutils}).
 
+When this option is omitted, @command{guix system} computes an estimate
+of the image size as a function of the size of the system declared in
+@var{file}.
+
 @item --root=@var{file}
 @itemx -r @var{file}
 Make @var{file} a symlink to the result, and register it as a garbage
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 57619764ce..8f7fc3c9c4 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -27,6 +27,7 @@
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
   #:use-module (guix records)
+  #:use-module ((guix combinators) #:select (fold2))
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -46,6 +47,7 @@
             partition-flags
             partition-initializer
 
+            estimated-partition-size
             root-partition-initializer
             initialize-partition-table
             initialize-hard-disk))
@@ -71,19 +73,23 @@
                            output
                            (qemu (qemu-command)) (memory-size 512)
                            linux initrd
-                           make-disk-image? (disk-image-size 100)
+                           make-disk-image?
+                           (disk-image-size (* 100 (expt 2 20)))
                            (disk-image-format "qcow2")
                            (references-graphs '()))
   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
 the result to OUTPUT.
 
 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
-DISK-IMAGE-SIZE MiB resulting from the execution of BUILDER, which may access
-it via /dev/hda.
+DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
+access it via /dev/hda.
 
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
   (when make-disk-image?
+    (format #t "creating ~a image of ~,2f MiB...~%"
+            disk-image-format (/ disk-image-size (expt 2 20)))
+    (force-output)
     (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
                             output
                             (number->string disk-image-size)))
@@ -146,17 +152,11 @@ the #:references-graphs parameter of 'derivation'."
   (flags       partition-flags (default '()))
   (initializer partition-initializer (default (const #t))))
 
-(define (fold2 proc seed1 seed2 lst)              ;TODO: factorize
-  "Like `fold', but with a single list and two seeds."
-  (let loop ((result1 seed1)
-             (result2 seed2)
-             (lst     lst))
-    (if (null? lst)
-        (values result1 result2)
-        (call-with-values
-            (lambda () (proc (car lst) result1 result2))
-          (lambda (result1 result2)
-            (loop result1 result2 (cdr lst)))))))
+(define (estimated-partition-size graphs)
+  "Return the estimated size of a partition that can store the store items
+given by GRAPHS, a list of file names produced by #:references-graphs."
+  ;; Simply add a 20% overhead.
+  (round (* 1.2 (closure-size graphs))))
 
 (define* (initialize-partition-table device partitions
                                      #:key
@@ -192,8 +192,15 @@ actual /dev name based on DEVICE."
                (cons (partition-options head offset index)
                      result))))))
 
-  (format #t "creating partition table with ~a partitions...\n"
-          (length partitions))
+  (format #t "creating partition table with ~a partitions (~a)...\n"
+          (length partitions)
+          (string-join (map (compose (cut string-append <> " MiB")
+                                     number->string
+                                     (lambda (size)
+                                       (round (/ size (expt 2. 20))))
+                                     partition-size)
+                            partitions)
+                       ", "))
   (unless (zero? (apply system* "parted" "--script"
                         device "mklabel" label-type
                         (options partitions offset)))
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 9031d727ef..28a060fe54 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -363,8 +363,8 @@ It has been modified to remove all non-free binary blobs.")
 
 (define %intel-compatible-systems '("x86_64-linux" "i686-linux"))
 
-(define %linux-libre-version "4.11.7")
-(define %linux-libre-hash "0kliwdz4qqjz13pywhavxg19cy1mf6d1f52f6kgapc331309vad9")
+(define %linux-libre-version "4.11.8")
+(define %linux-libre-hash "1z35h6xr8gdzq31xv3dpdz6ddz4q3183fwvkmx8qd7h9bhy13aw6")
 
 (define-public linux-libre
   (make-linux-libre %linux-libre-version
@@ -373,20 +373,20 @@ It has been modified to remove all non-free binary blobs.")
                     #:configuration-file kernel-config))
 
 (define-public linux-libre-4.9
-  (make-linux-libre "4.9.34"
-                    "00jm3338kvhfj850lg3mvk680fmfw34mvwaq41lvxgb1z2xqqlz1"
+  (make-linux-libre "4.9.35"
+                    "0fs90jgb01jybkclngg5asvbs1y70f2abs395qcb3lxpx7zxhy1h"
                     %intel-compatible-systems
                     #:configuration-file kernel-config))
 
 (define-public linux-libre-4.4
-  (make-linux-libre "4.4.74"
-                    "04x2ki3s2jsjkkk6bld0rd9rsk8qqvrfsxawxzfa26mkq6pv87r2"
+  (make-linux-libre "4.4.75"
+                    "1h687flrdzlcd1ms5n2khm0mxybr8bj2jfnnm7qvy6ha2vsngb5b"
                     %intel-compatible-systems
                     #:configuration-file kernel-config))
 
 (define-public linux-libre-4.1
-  (make-linux-libre "4.1.41"
-                    "02mqfl899jxvrmxlh8lvcgvm3klwd8wbsdz4rr2gpchbggj4vgb2"
+  (make-linux-libre "4.1.42"
+                    "1g5jhn7cm6ixn7w8ciqm6qgxv7k1jg50v6k05hsvzvrqfpaxqlbz"
                     %intel-compatible-systems
                     #:configuration-file kernel-config))
 
diff --git a/gnu/system.scm b/gnu/system.scm
index 31f9320023..39f8465bcb 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -490,7 +490,7 @@ explicitly appear in OS."
          lsof                                 ;for Guix's 'list-runtime-roots'
          pciutils usbutils
          util-linux inetutils isc-dhcp
-         shadow                                   ;for 'passwd'
+         (@ (gnu packages admin) shadow)          ;for 'passwd'
 
          ;; wireless-tools is deprecated in favor of iw, but it's still what
          ;; many people are familiar with, so keep it around.
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 392737d078..7ac8696158 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -108,8 +108,7 @@
                                              (references-graphs #f)
                                              (memory-size 256)
                                              (disk-image-format "qcow2")
-                                             (disk-image-size
-                                              (* 100 (expt 2 20))))
+                                             (disk-image-size 'guess))
   "Evaluate EXP in a QEMU virtual machine running LINUX with INITRD (a
 derivation).  In the virtual machine, EXP has access to all its inputs from the
 store; it should put its output files in the `/xchg' directory, which is
@@ -118,7 +117,8 @@ runs with MEMORY-SIZE MiB of memory.
 
 When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
 DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
-return it.
+return it.  When DISK-IMAGE-SIZE is 'guess, estimate the image size based
+based on the size of the closure of REFERENCES-GRAPHS.
 
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs, as for `derivation'.  The files containing the reference graphs are
@@ -143,14 +143,18 @@ made available under the /xchg CIFS share."
             (use-modules (guix build utils)
                          (gnu build vm))
 
-            (let ((inputs  '#$(list qemu coreutils))
-                  (linux   (string-append #$linux "/"
-                                          #$(system-linux-image-file-name)))
-                  (initrd  (string-append #$initrd "/initrd"))
-                  (loader  #$loader)
-                  (graphs  '#$(match references-graphs
-                                (((graph-files . _) ...) graph-files)
-                                (_ #f))))
+            (let* ((inputs  '#$(list qemu coreutils))
+                   (linux   (string-append #$linux "/"
+                                           #$(system-linux-image-file-name)))
+                   (initrd  (string-append #$initrd "/initrd"))
+                   (loader  #$loader)
+                   (graphs  '#$(match references-graphs
+                                 (((graph-files . _) ...) graph-files)
+                                 (_ #f)))
+                   (size    #$(if (eq? 'guess disk-image-size)
+                                  #~(+ (* 70 (expt 2 20)) ;ESP
+                                       (estimated-partition-size graphs))
+                                  disk-image-size)))
 
               (set-path-environment-variable "PATH" '("bin") inputs)
 
@@ -160,7 +164,7 @@ made available under the /xchg CIFS share."
                                 #:memory-size #$memory-size
                                 #:make-disk-image? #$make-disk-image?
                                 #:disk-image-format #$disk-image-format
-                                #:disk-image-size #$disk-image-size
+                                #:disk-image-size size
                                 #:references-graphs graphs)))))
 
     (gexp->derivation name builder
@@ -174,7 +178,7 @@ made available under the /xchg CIFS share."
                      (name "qemu-image")
                      (system (%current-system))
                      (qemu qemu-minimal)
-                     (disk-image-size (* 100 (expt 2 20)))
+                     (disk-image-size 'guess)
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
                      file-system-label
@@ -201,7 +205,8 @@ the image."
                                                    (guix build utils)))
      #~(begin
          (use-modules (gnu build vm)
-                      (guix build utils))
+                      (guix build utils)
+                      (srfi srfi-26))
 
          (let ((inputs
                 '#$(append (list qemu parted e2fsprogs dosfstools)
@@ -227,9 +232,14 @@ the image."
                                #:copy-closures? #$copy-inputs?
                                #:register-closures? #$register-closures?
                                #:system-directory #$os-drv))
+                  (root-size  #$(if (eq? 'guess disk-image-size)
+                                    #~(estimated-partition-size
+                                       (map (cut string-append "/xchg/" <>)
+                                            graphs))
+                                    (- disk-image-size
+                                       (* 50 (expt 2 20)))))
                   (partitions (list (partition
-                                     (size #$(- disk-image-size
-                                                (* 50 (expt 2 20))))
+                                     (size root-size)
                                      (label #$file-system-label)
                                      (file-system #$file-system-type)
                                      (flags '(boot))
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index a296bdf78f..fe2eb6f69a 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,7 +20,9 @@
   #:use-module (guix build utils)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw)
   #:export (read-reference-graph
+            closure-size
             populate-store))
 
 ;;; Commentary:
@@ -46,6 +48,37 @@ The data at PORT is the format produced by #:references-graphs."
            (loop (read-line port)
                  result)))))
 
+(define (file-size file)
+  "Return the size of bytes of FILE, entering it if FILE is a directory."
+  (file-system-fold (const #t)
+                    (lambda (file stat result)    ;leaf
+                      (+ (stat:size stat) result))
+                    (lambda (directory stat result) ;down
+                      (+ (stat:size stat) result))
+                    (lambda (directory stat result) ;up
+                      result)
+                    (lambda (file stat result)    ;skip
+                      result)
+                    (lambda (file stat errno result)
+                      (format (current-error-port)
+                              "file-size: ~a: ~a~%" file
+                              (strerror errno))
+                      result)
+                    0
+                    file
+                    lstat))
+
+(define (closure-size reference-graphs)
+  "Return an estimate of the size of the closure described by
+REFERENCE-GRAPHS, a list of reference-graph files."
+  (define (graph-from-file file)
+    (call-with-input-file file read-reference-graph))
+
+  (define items
+    (delete-duplicates (append-map graph-from-file reference-graphs)))
+
+  (reduce + 0 (map file-size items)))
+
 (define* (populate-store reference-graphs target)
   "Populate the store under directory TARGET with the items specified in
 REFERENCE-GRAPHS, a list of reference-graph files."
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 35675cc018..7e20b10dad 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -854,7 +854,7 @@ Some ACTIONS support additional ARGS.\n"))
     (build-hook? . #t)
     (max-silent-time . 3600)
     (verbosity . 0)
-    (image-size . ,(* 900 (expt 2 20)))
+    (image-size . guess)
     (install-bootloader? . #t)))
 
 
diff --git a/m4/guix.m4 b/m4/guix.m4
index e546b8f4dd..add57f5262 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 3f654af2ce..0000000000
--- 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