Merge branch 'master' into xorg-updates

3 files changed, 71 insertions, 73 deletions

diff --git a/gnu/packages.scm b/gnu/packages.scm
index c9efd0d691..6109d1f896 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -105,24 +105,29 @@
      (append environment `((,%distro-root-directory . "gnu/packages"))))))
 
 (define* (scheme-files directory)
-  "Return the list of Scheme files found under DIRECTORY."
-  (file-system-fold (const #t)                    ; enter?
-                    (lambda (path stat result)    ; leaf
-                      (if (string-suffix? ".scm" path)
-                          (cons path result)
-                          result))
-                    (lambda (path stat result)    ; down
-                      result)
-                    (lambda (path stat result)    ; up
-                      result)
-                    (const #f)                    ; skip
-                    (lambda (path stat errno result)
-                      (warning (_ "cannot access `~a': ~a~%")
-                               path (strerror errno))
-                      result)
-                    '()
-                    directory
-                    stat))
+  "Return the list of Scheme files found under DIRECTORY, recursively.  The
+returned list is sorted in alphabetical order."
+
+  ;; Sort entries so that 'fold-packages' works in a deterministic fashion
+  ;; regardless of details of the underlying file system.
+  (sort (file-system-fold (const #t)                   ; enter?
+                          (lambda (path stat result)   ; leaf
+                            (if (string-suffix? ".scm" path)
+                                (cons path result)
+                                result))
+                          (lambda (path stat result)   ; down
+                            result)
+                          (lambda (path stat result)   ; up
+                            result)
+                          (const #f)                   ; skip
+                          (lambda (path stat errno result)
+                            (warning (_ "cannot access `~a': ~a~%")
+                                     path (strerror errno))
+                            result)
+                          '()
+                          directory
+                          stat)
+        string<?))
 
 (define file-name->module-name
   (let ((not-slash (char-set-complement (char-set #\/))))
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 4bba7167ca..e8af9f8146 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -55,8 +55,7 @@ PYTHON-BUILD-SYSTEM, such that it is compiled with PYTHON instead.  The
 inputs are changed recursively accordingly.  If the name of P starts with
 OLD-PREFIX, this is replaced by NEW-PREFIX; otherwise, NEW-PREFIX is
 prepended to the name."
-  (let* ((build-system (package-build-system p))
-         (rewrite-if-package
+  (let* ((rewrite-if-package
           (lambda (content)
             ;; CONTENT may be a file name, in which case it is returned, or a
             ;; package, which is rewritten with the new PYTHON and NEW-PREFIX.
@@ -68,28 +67,23 @@ prepended to the name."
            (match-lambda
              ((name content . rest)
               (append (list name (rewrite-if-package content)) rest)))))
-    (package (inherit p)
-      (name
-        (let ((name (package-name p)))
-          (if (eq? build-system python-build-system)
-              (string-append new-prefix
-                             (if (string-prefix? old-prefix name)
-                                 (substring name (string-length old-prefix))
-                                 name))
-              name)))
-      (arguments
-        (let ((arguments (package-arguments p)))
-          (if (eq? build-system python-build-system)
-              (if (member #:python arguments)
-                  (substitute-keyword-arguments arguments ((#:python p) python))
-                  (append arguments `(#:python ,python)))
-              arguments)))
-      (inputs
-        (map rewrite (package-inputs p)))
-      (propagated-inputs
-        (map rewrite (package-propagated-inputs p)))
-      (native-inputs
-        (map rewrite (package-native-inputs p))))))
+
+    (if (eq? (package-build-system p) python-build-system)
+        (package (inherit p)
+          (name (let ((name (package-name p)))
+                  (string-append new-prefix
+                                 (if (string-prefix? old-prefix name)
+                                     (substring name (string-length old-prefix))
+                                     name))))
+          (arguments
+           (let ((arguments (package-arguments p)))
+             (if (member #:python arguments)
+                 (substitute-keyword-arguments arguments ((#:python p) python))
+                 (append arguments `(#:python ,python)))))
+          (inputs (map rewrite (package-inputs p)))
+          (propagated-inputs (map rewrite (package-propagated-inputs p)))
+          (native-inputs (map rewrite (package-native-inputs p))))
+        p)))
 
 (define package-with-python2
   (cut package-with-explicit-python <> (default-python2) "python-" "python2-"))
diff --git a/guix/packages.scm b/guix/packages.scm
index 07f6d0ccbc..2a9a55e12f 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -543,40 +544,38 @@ for the host system (\"native inputs\"), and not target inputs."
 recursively."
   (transitive-inputs (package-propagated-inputs package)))
 
-(define-syntax-rule (first-value exp)
-  "Truncate all but the first value returned by EXP."
-  (call-with-values (lambda () exp)
-    (lambda (result . _)
-      result)))
+(define-syntax define-memoized/v
+  (lambda (form)
+    "Define a memoized single-valued unary procedure with docstring.
+The procedure argument is compared to cached keys using `eqv?'."
+    (syntax-case form ()
+      ((_ (proc arg) docstring body body* ...)
+       (string? (syntax->datum #'docstring))
+       #'(define proc
+           (let ((cache (make-hash-table)))
+             (define (proc arg)
+               docstring
+               (match (hashv-get-handle cache arg)
+                 ((_ . value)
+                  value)
+                 (_
+                  (let ((result (let () body body* ...)))
+                    (hashv-set! cache arg result)
+                    result))))
+             proc))))))
 
-(define (package-transitive-supported-systems package)
+(define-memoized/v (package-transitive-supported-systems package)
   "Return the intersection of the systems supported by PACKAGE and those
 supported by its dependencies."
-  (first-value
-   (let loop ((package package)
-              (systems (package-supported-systems package))
-              (visited vlist-null))
-     (match (vhash-assq package visited)
-       ((_ . result)
-        (values (lset-intersection string=? systems result)
-                visited))
-       (#f
-        (call-with-values
-            (lambda ()
-              (fold2 (lambda (input systems visited)
-                       (match input
-                         ((label (? package? package) . _)
-                          (loop package systems visited))
-                         (_
-                          (values systems visited))))
-                     (lset-intersection string=?
-                                        systems
-                                        (package-supported-systems package))
-                     visited
-                     (package-direct-inputs package)))
-          (lambda (systems visited)
-            (values systems
-                    (vhash-consq package systems visited)))))))))
+  (fold (lambda (input systems)
+          (match input
+            ((label (? package? p) . _)
+             (lset-intersection
+              string=? systems (package-transitive-supported-systems p)))
+            (_
+             systems)))
+        (package-supported-systems package)
+        (package-direct-inputs package)))
 
 (define (bag-transitive-inputs bag)
   "Same as 'package-transitive-inputs', but applied to a bag."