Merge branch 'master' into xorg-updates

gnu/packages.scm

@@ -105,8 +105,12 @@
      (append environment `((,%distro-root-directory . "gnu/packages"))))))
 
 (define* (scheme-files directory)
-  "Return the list of Scheme files found under DIRECTORY."
+  "Return the list of Scheme files found under DIRECTORY, recursively.  The
-  (file-system-fold (const #t)                    ; enter?
+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)
@@ -122,7 +126,8 @@
                             result)
                           '()
                           directory
-                    stat))
+                          stat)
+        string<?))
 
 (define file-name->module-name
   (let ((not-slash (char-set-complement (char-set #\/))))

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))
+  (let* ((rewrite-if-package
-         (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)))))
+
+    (if (eq? (package-build-system p) python-build-system)
         (package (inherit p)
-      (name
+          (name (let ((name (package-name p)))
-        (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))))
-              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)))
+                 (append arguments `(#:python ,python)))))
-              arguments)))
+          (inputs (map rewrite (package-inputs p)))
-      (inputs
+          (propagated-inputs (map rewrite (package-propagated-inputs p)))
-        (map rewrite (package-inputs p)))
+          (native-inputs (map rewrite (package-native-inputs p))))
-      (propagated-inputs
+        p)))
-        (map rewrite (package-propagated-inputs p)))
-      (native-inputs
-        (map rewrite (package-native-inputs p))))))
 
 (define package-with-python2
   (cut package-with-explicit-python <> (default-python2) "python-" "python2-"))

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)
+(define-syntax define-memoized/v
-  "Truncate all but the first value returned by EXP."
+  (lambda (form)
-  (call-with-values (lambda () exp)
+    "Define a memoized single-valued unary procedure with docstring.
-    (lambda (result . _)
+The procedure argument is compared to cached keys using `eqv?'."
-      result)))
+    (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
+  (fold (lambda (input systems)
-   (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) . _)
+            ((label (? package? p) . _)
-                          (loop package systems visited))
+             (lset-intersection
+              string=? systems (package-transitive-supported-systems p)))
             (_
-                          (values systems visited))))
+             systems)))
-                     (lset-intersection string=?
+        (package-supported-systems package)
-                                        systems
-                                        (package-supported-systems package))
-                     visited
         (package-direct-inputs package)))
-          (lambda (systems visited)
-            (values systems
-                    (vhash-consq package systems visited)))))))))
 
 (define (bag-transitive-inputs bag)
   "Same as 'package-transitive-inputs', but applied to a bag."