diff options
| -rw-r--r-- | guix/packages.scm | 61 |
1 files changed, 30 insertions, 31 deletions
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." |