diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2017-01-28 17:09:34 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2017-01-28 18:55:20 +0100 |
| commit | 55b2d921456e888f097bf4e43a3d25b112f3e563 (patch) | |
| tree | 5e2e834a2aa37f50dd27a33ae38a2f82c30091a7 | |
| parent | f9704f179a5160013c4a401dce3761714bba8e72 (diff) | |
Use 'mlambda' instead of 'memoize'.
* gnu/packages.scm (find-newest-available-packages): Use 'mlambda'
instead of (memoize (lambda ...) ...).
* gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Likewise.
* guix/build-system/gnu.scm (package-with-explicit-inputs)[rewritten-input]:
Likewise.
* guix/build-system/python.scm (package-with-explicit-python)[transform]:
Likewise.
* guix/derivations.scm (derivation->string): Likewise.
* guix/gnu-maintenance.scm (gnu-package?): Likewise.
* guix/modules.scm (module-file-dependencies): Likewise.
* guix/scripts/graph.scm (standard-package-set): Likewise.
* guix/scripts/lint.scm (official-gnu-packages*): Likewise.
* guix/store.scm (store-regexp*): Likewise.
* guix/utils.scm (location): Likewise.
| -rw-r--r-- | gnu/packages.scm | 31 | ||||
| -rw-r--r-- | gnu/packages/bootstrap.scm | 35 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 47 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 85 | ||||
| -rw-r--r-- | guix/derivations.scm | 88 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 83 | ||||
| -rw-r--r-- | guix/modules.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 9 | ||||
| -rw-r--r-- | guix/store.scm | 9 | ||||
| -rw-r--r-- | guix/utils.scm | 9 |
11 files changed, 208 insertions, 220 deletions
diff --git a/gnu/packages.scm b/gnu/packages.scm index ec2473422f4..0aa289d56c0 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm | |||
| @@ -235,28 +235,27 @@ decreasing version order." | |||
| 235 | matching))))) | 235 | matching))))) |
| 236 | 236 | ||
| 237 | (define find-newest-available-packages | 237 | (define find-newest-available-packages |
| 238 | (memoize | 238 | (mlambda () |
| 239 | (lambda () | 239 | "Return a vhash keyed by package names, and with |
| 240 | "Return a vhash keyed by package names, and with | ||
| 241 | associated values of the form | 240 | associated values of the form |
| 242 | 241 | ||
| 243 | (newest-version newest-package ...) | 242 | (newest-version newest-package ...) |
| 244 | 243 | ||
| 245 | where the preferred package is listed first." | 244 | where the preferred package is listed first." |
| 246 | 245 | ||
| 247 | ;; FIXME: Currently, the preferred package is whichever one | 246 | ;; FIXME: Currently, the preferred package is whichever one |
| 248 | ;; was found last by 'fold-packages'. Find a better solution. | 247 | ;; was found last by 'fold-packages'. Find a better solution. |
| 249 | (fold-packages (lambda (p r) | 248 | (fold-packages (lambda (p r) |
| 250 | (let ((name (package-name p)) | 249 | (let ((name (package-name p)) |
| 251 | (version (package-version p))) | 250 | (version (package-version p))) |
| 252 | (match (vhash-assoc name r) | 251 | (match (vhash-assoc name r) |
| 253 | ((_ newest-so-far . pkgs) | 252 | ((_ newest-so-far . pkgs) |
| 254 | (case (version-compare version newest-so-far) | 253 | (case (version-compare version newest-so-far) |
| 255 | ((>) (vhash-cons name `(,version ,p) r)) | 254 | ((>) (vhash-cons name `(,version ,p) r)) |
| 256 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) | 255 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) |
| 257 | ((<) r))) | 256 | ((<) r))) |
| 258 | (#f (vhash-cons name `(,version ,p) r))))) | 257 | (#f (vhash-cons name `(,version ,p) r))))) |
| 259 | vlist-null)))) | 258 | vlist-null))) |
| 260 | 259 | ||
| 261 | (define (find-best-packages-by-name name version) | 260 | (define (find-best-packages-by-name name version) |
| 262 | "If version is #f, return the list of packages named NAME with the highest | 261 | "If version is #f, return the list of packages named NAME with the highest |
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 7cde51fff80..c8d94c83036 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm | |||
| @@ -131,30 +131,29 @@ successful, or false to signal an error." | |||
| 131 | (license gpl3+))) | 131 | (license gpl3+))) |
| 132 | 132 | ||
| 133 | (define package-with-bootstrap-guile | 133 | (define package-with-bootstrap-guile |
| 134 | (memoize | 134 | (mlambda (p) |
| 135 | (lambda (p) | ||
| 136 | "Return a variant of P such that all its origins are fetched with | 135 | "Return a variant of P such that all its origins are fetched with |
| 137 | %BOOTSTRAP-GUILE." | 136 | %BOOTSTRAP-GUILE." |
| 138 | (define rewritten-input | 137 | (define rewritten-input |
| 139 | (match-lambda | 138 | (match-lambda |
| 140 | ((name (? origin? o)) | 139 | ((name (? origin? o)) |
| 141 | `(,name ,(bootstrap-origin o))) | 140 | `(,name ,(bootstrap-origin o))) |
| 142 | ((name (? package? p) sub-drvs ...) | 141 | ((name (? package? p) sub-drvs ...) |
| 143 | `(,name ,(package-with-bootstrap-guile p) ,@sub-drvs)) | 142 | `(,name ,(package-with-bootstrap-guile p) ,@sub-drvs)) |
| 144 | (x x))) | 143 | (x x))) |
| 145 | 144 | ||
| 146 | (package (inherit p) | 145 | (package (inherit p) |
| 147 | (source (match (package-source p) | 146 | (source (match (package-source p) |
| 148 | ((? origin? o) (bootstrap-origin o)) | 147 | ((? origin? o) (bootstrap-origin o)) |
| 149 | (s s))) | 148 | (s s))) |
| 150 | (inputs (map rewritten-input | 149 | (inputs (map rewritten-input |
| 151 | (package-inputs p))) | 150 | (package-inputs p))) |
| 152 | (native-inputs (map rewritten-input | 151 | (native-inputs (map rewritten-input |
| 153 | (package-native-inputs p))) | 152 | (package-native-inputs p))) |
| 154 | (propagated-inputs (map rewritten-input | 153 | (propagated-inputs (map rewritten-input |
| 155 | (package-propagated-inputs p))) | 154 | (package-propagated-inputs p))) |
| 156 | (replacement (and=> (package-replacement p) | 155 | (replacement (and=> (package-replacement p) |
| 157 | package-with-bootstrap-guile)))))) | 156 | package-with-bootstrap-guile))))) |
| 158 | 157 | ||
| 159 | (define* (glibc-dynamic-linker | 158 | (define* (glibc-dynamic-linker |
| 160 | #:optional (system (or (and=> (%current-target-system) | 159 | #:optional (system (or (and=> (%current-target-system) |
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index f05ddf91f5b..730e638c89c 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm | |||
| @@ -84,15 +84,15 @@ builder, or the distro's final Guile when GUILE is #f." | |||
| 84 | 84 | ||
| 85 | (let loop ((p p)) | 85 | (let loop ((p p)) |
| 86 | (define rewritten-input | 86 | (define rewritten-input |
| 87 | (memoize | 87 | (mlambda (input) |
| 88 | (match-lambda | 88 | (match input |
| 89 | ((name (? package? p) sub-drv ...) | 89 | ((name (? package? p) sub-drv ...) |
| 90 | ;; XXX: Check whether P's build system knows #:implicit-inputs, for | 90 | ;; XXX: Check whether P's build system knows #:implicit-inputs, for |
| 91 | ;; things like `cross-pkg-config'. | 91 | ;; things like `cross-pkg-config'. |
| 92 | (if (eq? (package-build-system p) gnu-build-system) | 92 | (if (eq? (package-build-system p) gnu-build-system) |
| 93 | (cons* name (loop p) sub-drv) | 93 | (cons* name (loop p) sub-drv) |
| 94 | (cons* name p sub-drv))) | 94 | (cons* name p sub-drv))) |
| 95 | (x x)))) | 95 | (x x)))) |
| 96 | 96 | ||
| 97 | (package (inherit p) | 97 | (package (inherit p) |
| 98 | (location (if (pair? loc) (source-properties->location loc) loc)) | 98 | (location (if (pair? loc) (source-properties->location loc) loc)) |
| @@ -393,22 +393,21 @@ packages that must not be referenced." | |||
| 393 | ;;; | 393 | ;;; |
| 394 | 394 | ||
| 395 | (define standard-cross-packages | 395 | (define standard-cross-packages |
| 396 | (memoize | 396 | (mlambda (target kind) |
| 397 | (lambda (target kind) | 397 | "Return the list of name/package tuples to cross-build for TARGET. KIND |
| 398 | "Return the list of name/package tuples to cross-build for TARGET. KIND | ||
| 399 | is one of `host' or `target'." | 398 | is one of `host' or `target'." |
| 400 | (let* ((cross (resolve-interface '(gnu packages cross-base))) | 399 | (let* ((cross (resolve-interface '(gnu packages cross-base))) |
| 401 | (gcc (module-ref cross 'cross-gcc)) | 400 | (gcc (module-ref cross 'cross-gcc)) |
| 402 | (binutils (module-ref cross 'cross-binutils)) | 401 | (binutils (module-ref cross 'cross-binutils)) |
| 403 | (libc (module-ref cross 'cross-libc))) | 402 | (libc (module-ref cross 'cross-libc))) |
| 404 | (case kind | 403 | (case kind |
| 405 | ((host) | 404 | ((host) |
| 406 | `(("cross-gcc" ,(gcc target | 405 | `(("cross-gcc" ,(gcc target |
| 407 | (binutils target) | 406 | (binutils target) |
| 408 | (libc target))) | 407 | (libc target))) |
| 409 | ("cross-binutils" ,(binutils target)))) | 408 | ("cross-binutils" ,(binutils target)))) |
| 410 | ((target) | 409 | ((target) |
| 411 | `(("cross-libc" ,(libc target))))))))) | 410 | `(("cross-libc" ,(libc target)))))))) |
| 412 | 411 | ||
| 413 | (define* (gnu-cross-build store name | 412 | (define* (gnu-cross-build store name |
| 414 | #:key | 413 | #:key |
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index bfe0eca9f60..383e8cb64a3 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm | |||
| @@ -87,49 +87,48 @@ pre-defined variants." | |||
| 87 | ;; Memoize the transformations. Failing to do that, we would build a huge | 87 | ;; Memoize the transformations. Failing to do that, we would build a huge |
| 88 | ;; object graph with lots of duplicates, which in turns prevents us from | 88 | ;; object graph with lots of duplicates, which in turns prevents us from |
| 89 | ;; benefiting from memoization in 'package-derivation'. | 89 | ;; benefiting from memoization in 'package-derivation'. |
| 90 | (memoize ;FIXME: use 'eq?' | 90 | (mlambda (p) ;XXX: use 'eq?' |
| 91 | (lambda (p) | 91 | (let* ((rewrite-if-package |
| 92 | (let* ((rewrite-if-package | 92 | (lambda (content) |
| 93 | (lambda (content) | 93 | ;; CONTENT may be a file name, in which case it is returned, |
| 94 | ;; CONTENT may be a file name, in which case it is returned, | 94 | ;; or a package, which is rewritten with the new PYTHON and |
| 95 | ;; or a package, which is rewritten with the new PYTHON and | 95 | ;; NEW-PREFIX. |
| 96 | ;; NEW-PREFIX. | 96 | (if (package? content) |
| 97 | (if (package? content) | 97 | (transform content) |
| 98 | (transform content) | 98 | content))) |
| 99 | content))) | 99 | (rewrite |
| 100 | (rewrite | 100 | (match-lambda |
| 101 | (match-lambda | 101 | ((name content . rest) |
| 102 | ((name content . rest) | 102 | (append (list name (rewrite-if-package content)) rest))))) |
| 103 | (append (list name (rewrite-if-package content)) rest))))) | 103 | |
| 104 | 104 | (cond | |
| 105 | (cond | 105 | ;; If VARIANT-PROPERTY is present, use that. |
| 106 | ;; If VARIANT-PROPERTY is present, use that. | 106 | ((and variant-property |
| 107 | ((and variant-property | 107 | (assoc-ref (package-properties p) variant-property)) |
| 108 | (assoc-ref (package-properties p) variant-property)) | 108 | => force) |
| 109 | => force) | 109 | |
| 110 | 110 | ;; Otherwise build the new package object graph. | |
| 111 | ;; Otherwise build the new package object graph. | 111 | ((eq? (package-build-system p) python-build-system) |
| 112 | ((eq? (package-build-system p) python-build-system) | 112 | (package |
| 113 | (package | 113 | (inherit p) |
| 114 | (inherit p) | 114 | (location (package-location p)) |
| 115 | (location (package-location p)) | 115 | (name (let ((name (package-name p))) |
| 116 | (name (let ((name (package-name p))) | 116 | (string-append new-prefix |
| 117 | (string-append new-prefix | 117 | (if (string-prefix? old-prefix name) |
| 118 | (if (string-prefix? old-prefix name) | 118 | (substring name |
| 119 | (substring name | 119 | (string-length old-prefix)) |
| 120 | (string-length old-prefix)) | 120 | name)))) |
| 121 | name)))) | 121 | (arguments |
| 122 | (arguments | 122 | (let ((python (if (promise? python) |
| 123 | (let ((python (if (promise? python) | 123 | (force python) |
| 124 | (force python) | 124 | python))) |
| 125 | python))) | 125 | (ensure-keyword-arguments (package-arguments p) |
| 126 | (ensure-keyword-arguments (package-arguments p) | 126 | `(#:python ,python)))) |
| 127 | `(#:python ,python)))) | 127 | (inputs (map rewrite (package-inputs p))) |
| 128 | (inputs (map rewrite (package-inputs p))) | 128 | (propagated-inputs (map rewrite (package-propagated-inputs p))) |
| 129 | (propagated-inputs (map rewrite (package-propagated-inputs p))) | 129 | (native-inputs (map rewrite (package-native-inputs p))))) |
| 130 | (native-inputs (map rewrite (package-native-inputs p))))) | 130 | (else |
| 131 | (else | 131 | p))))) |
| 132 | p)))))) | ||
| 133 | 132 | ||
| 134 | transform) | 133 | transform) |
| 135 | 134 | ||
diff --git a/guix/derivations.scm b/guix/derivations.scm index 056b1163b49..47a783f42f6 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm | |||
| @@ -557,12 +557,11 @@ that form." | |||
| 557 | (display ")" port)))) | 557 | (display ")" port)))) |
| 558 | 558 | ||
| 559 | (define derivation->string | 559 | (define derivation->string |
| 560 | (memoize | 560 | (mlambda (drv) |
| 561 | (lambda (drv) | 561 | "Return the external representation of DRV as a string." |
| 562 | "Return the external representation of DRV as a string." | 562 | (with-fluids ((%default-port-encoding "UTF-8")) |
| 563 | (with-fluids ((%default-port-encoding "UTF-8")) | 563 | (call-with-output-string |
| 564 | (call-with-output-string | 564 | (cut write-derivation drv <>))))) |
| 565 | (cut write-derivation drv <>)))))) | ||
| 566 | 565 | ||
| 567 | (define* (derivation->output-path drv #:optional (output "out")) | 566 | (define* (derivation->output-path drv #:optional (output "out")) |
| 568 | "Return the store path of its output OUTPUT. Raise a | 567 | "Return the store path of its output OUTPUT. Raise a |
| @@ -584,12 +583,14 @@ DRV." | |||
| 584 | 583 | ||
| 585 | (define derivation-path->output-path | 584 | (define derivation-path->output-path |
| 586 | ;; This procedure is called frequently, so memoize it. | 585 | ;; This procedure is called frequently, so memoize it. |
| 587 | (memoize | 586 | (let ((memoized (mlambda (path output) |
| 588 | (lambda* (path #:optional (output "out")) | 587 | (derivation->output-path (call-with-input-file path |
| 589 | "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store | 588 | read-derivation) |
| 589 | output)))) | ||
| 590 | (lambda* (path #:optional (output "out")) | ||
| 591 | "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store | ||
| 590 | path of its output OUTPUT." | 592 | path of its output OUTPUT." |
| 591 | (derivation->output-path (call-with-input-file path read-derivation) | 593 | (memoized path output)))) |
| 592 | output)))) | ||
| 593 | 594 | ||
| 594 | (define (derivation-path->output-paths path) | 595 | (define (derivation-path->output-paths path) |
| 595 | "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the | 596 | "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the |
| @@ -616,23 +617,21 @@ in SIZE bytes." | |||
| 616 | (loop (+ 1 i)))))) | 617 | (loop (+ 1 i)))))) |
| 617 | 618 | ||
| 618 | (define derivation-path->base16-hash | 619 | (define derivation-path->base16-hash |
| 619 | (memoize | 620 | (mlambda (file) |
| 620 | (lambda (file) | 621 | "Return a string containing the base16 representation of the hash of the |
| 621 | "Return a string containing the base16 representation of the hash of the | ||
| 622 | derivation at FILE." | 622 | derivation at FILE." |
| 623 | (call-with-input-file file | 623 | (call-with-input-file file |
| 624 | (compose bytevector->base16-string | 624 | (compose bytevector->base16-string |
| 625 | derivation-hash | 625 | derivation-hash |
| 626 | read-derivation))))) | 626 | read-derivation)))) |
| 627 | 627 | ||
| 628 | (define derivation-hash ; `hashDerivationModulo' in derivations.cc | 628 | (define derivation-hash ; `hashDerivationModulo' in derivations.cc |
| 629 | (memoize | 629 | (mlambda (drv) |
| 630 | (lambda (drv) | ||
| 631 | "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." | 630 | "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." |
| 632 | (match drv | 631 | (match drv |
| 633 | (($ <derivation> ((_ . ($ <derivation-output> path | 632 | (($ <derivation> ((_ . ($ <derivation-output> path |
| 634 | (? symbol? hash-algo) (? bytevector? hash) | 633 | (? symbol? hash-algo) (? bytevector? hash) |
| 635 | (? boolean? recursive?))))) | 634 | (? boolean? recursive?))))) |
| 636 | ;; A fixed-output derivation. | 635 | ;; A fixed-output derivation. |
| 637 | (sha256 | 636 | (sha256 |
| 638 | (string->utf8 | 637 | (string->utf8 |
| @@ -642,14 +641,14 @@ derivation at FILE." | |||
| 642 | ":" (bytevector->base16-string hash) | 641 | ":" (bytevector->base16-string hash) |
| 643 | ":" path)))) | 642 | ":" path)))) |
| 644 | (($ <derivation> outputs inputs sources | 643 | (($ <derivation> outputs inputs sources |
| 645 | system builder args env-vars) | 644 | system builder args env-vars) |
| 646 | ;; A regular derivation: replace the path of each input with that | 645 | ;; A regular derivation: replace the path of each input with that |
| 647 | ;; input's hash; return the hash of serialization of the resulting | 646 | ;; input's hash; return the hash of serialization of the resulting |
| 648 | ;; derivation. | 647 | ;; derivation. |
| 649 | (let* ((inputs (map (match-lambda | 648 | (let* ((inputs (map (match-lambda |
| 650 | (($ <derivation-input> path sub-drvs) | 649 | (($ <derivation-input> path sub-drvs) |
| 651 | (let ((hash (derivation-path->base16-hash path))) | 650 | (let ((hash (derivation-path->base16-hash path))) |
| 652 | (make-derivation-input hash sub-drvs)))) | 651 | (make-derivation-input hash sub-drvs)))) |
| 653 | inputs)) | 652 | inputs)) |
| 654 | (drv (make-derivation outputs | 653 | (drv (make-derivation outputs |
| 655 | (sort (coalesce-duplicate-inputs inputs) | 654 | (sort (coalesce-duplicate-inputs inputs) |
| @@ -662,7 +661,7 @@ derivation at FILE." | |||
| 662 | ;; the SHA256 port's `write' method gets called for every single | 661 | ;; the SHA256 port's `write' method gets called for every single |
| 663 | ;; character. | 662 | ;; character. |
| 664 | (sha256 | 663 | (sha256 |
| 665 | (string->utf8 (derivation->string drv))))))))) | 664 | (string->utf8 (derivation->string drv)))))))) |
| 666 | 665 | ||
| 667 | (define (store-path type hash name) ; makeStorePath | 666 | (define (store-path type hash name) ; makeStorePath |
| 668 | "Return the store path for NAME/HASH/TYPE." | 667 | "Return the store path for NAME/HASH/TYPE." |
| @@ -916,18 +915,17 @@ recursively." | |||
| 916 | (define rewritten-input | 915 | (define rewritten-input |
| 917 | ;; Rewrite the given input according to MAPPING, and return an input | 916 | ;; Rewrite the given input according to MAPPING, and return an input |
| 918 | ;; in the format used in 'derivation' calls. | 917 | ;; in the format used in 'derivation' calls. |
| 919 | (memoize | 918 | (mlambda (input loop) |
| 920 | (lambda (input loop) | 919 | (match input |
| 921 | (match input | 920 | (($ <derivation-input> path (sub-drvs ...)) |
| 922 | (($ <derivation-input> path (sub-drvs ...)) | 921 | (match (vhash-assoc path mapping) |
| 923 | (match (vhash-assoc path mapping) | 922 | ((_ . (? derivation? replacement)) |
| 924 | ((_ . (? derivation? replacement)) | 923 | (cons replacement sub-drvs)) |
| 925 | (cons replacement sub-drvs)) | 924 | ((_ . replacement) |
| 926 | ((_ . replacement) | 925 | (list replacement)) |
| 927 | (list replacement)) | 926 | (#f |
| 928 | (#f | 927 | (let* ((drv (loop (call-with-input-file path read-derivation)))) |
| 929 | (let* ((drv (loop (call-with-input-file path read-derivation)))) | 928 | (cons drv sub-drvs)))))))) |
| 930 | (cons drv sub-drvs))))))))) | ||
| 931 | 929 | ||
| 932 | (let loop ((drv drv)) | 930 | (let loop ((drv drv)) |
| 933 | (let* ((inputs (map (cut rewritten-input <> loop) | 931 | (let* ((inputs (map (cut rewritten-input <> loop) |
| @@ -1058,13 +1056,13 @@ system, imported, and appears under FINAL-PATH in the resulting store path." | |||
| 1058 | (define search-path* | 1056 | (define search-path* |
| 1059 | ;; A memoizing version of 'search-path' so 'imported-modules' does not end | 1057 | ;; A memoizing version of 'search-path' so 'imported-modules' does not end |
| 1060 | ;; up looking for the same files over and over again. | 1058 | ;; up looking for the same files over and over again. |
| 1061 | (memoize (lambda (path file) | 1059 | (mlambda (path file) |
| 1062 | "Search for FILE in PATH and memoize the result. Raise a | 1060 | "Search for FILE in PATH and memoize the result. Raise a |
| 1063 | '&file-search-error' condition if it could not be found." | 1061 | '&file-search-error' condition if it could not be found." |
| 1064 | (or (search-path path file) | 1062 | (or (search-path path file) |
| 1065 | (raise (condition | 1063 | (raise (condition |
| 1066 | (&file-search-error (file file) | 1064 | (&file-search-error (file file) |
| 1067 | (path path)))))))) | 1065 | (path path))))))) |
| 1068 | 1066 | ||
| 1069 | (define (module->source-file-name module) | 1067 | (define (module->source-file-name module) |
| 1070 | "Return the file name corresponding to MODULE, a Guile module name (a list | 1068 | "Return the file name corresponding to MODULE, a Guile module name (a list |
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 05ea19236bf..012f587525c 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm | |||
| @@ -165,49 +165,48 @@ found." | |||
| 165 | (official-gnu-packages))) | 165 | (official-gnu-packages))) |
| 166 | 166 | ||
| 167 | (define gnu-package? | 167 | (define gnu-package? |
| 168 | (memoize | 168 | (let ((official-gnu-packages (memoize official-gnu-packages))) |
| 169 | (let ((official-gnu-packages (memoize official-gnu-packages))) | 169 | (mlambda (package) |
| 170 | (lambda (package) | 170 | "Return true if PACKAGE is a GNU package. This procedure may access the |
| 171 | "Return true if PACKAGE is a GNU package. This procedure may access the | ||
| 172 | network to check in GNU's database." | 171 | network to check in GNU's database." |
| 173 | (define (mirror-type url) | 172 | (define (mirror-type url) |
| 174 | (let ((uri (string->uri url))) | 173 | (let ((uri (string->uri url))) |
| 175 | (and (eq? (uri-scheme uri) 'mirror) | 174 | (and (eq? (uri-scheme uri) 'mirror) |
| 176 | (cond | 175 | (cond |
| 177 | ((member (uri-host uri) | 176 | ((member (uri-host uri) |
| 178 | '("gnu" "gnupg" "gcc" "gnome")) | 177 | '("gnu" "gnupg" "gcc" "gnome")) |
| 179 | ;; Definitely GNU. | 178 | ;; Definitely GNU. |
| 180 | 'gnu) | 179 | 'gnu) |
| 181 | ((equal? (uri-host uri) "cran") | 180 | ((equal? (uri-host uri) "cran") |
| 182 | ;; Possibly GNU: mirror://cran could be either GNU R itself | 181 | ;; Possibly GNU: mirror://cran could be either GNU R itself |
| 183 | ;; or a non-GNU package. | 182 | ;; or a non-GNU package. |
| 184 | #f) | 183 | #f) |
| 185 | (else | 184 | (else |
| 186 | ;; Definitely non-GNU. | 185 | ;; Definitely non-GNU. |
| 187 | 'non-gnu))))) | 186 | 'non-gnu))))) |
| 188 | 187 | ||
| 189 | (define (gnu-home-page? package) | 188 | (define (gnu-home-page? package) |
| 190 | (letrec-syntax ((>> (syntax-rules () | 189 | (letrec-syntax ((>> (syntax-rules () |
| 191 | ((_ value proc) | 190 | ((_ value proc) |
| 192 | (and=> value proc)) | 191 | (and=> value proc)) |
| 193 | ((_ value proc rest ...) | 192 | ((_ value proc rest ...) |
| 194 | (and=> value | 193 | (and=> value |
| 195 | (lambda (next) | 194 | (lambda (next) |
| 196 | (>> (proc next) rest ...))))))) | 195 | (>> (proc next) rest ...))))))) |
| 197 | (>> package package-home-page | 196 | (>> package package-home-page |
| 198 | string->uri uri-host | 197 | string->uri uri-host |
| 199 | (lambda (host) | 198 | (lambda (host) |
| 200 | (member host '("www.gnu.org" "gnu.org")))))) | 199 | (member host '("www.gnu.org" "gnu.org")))))) |
| 201 | 200 | ||
| 202 | (or (gnu-home-page? package) | 201 | (or (gnu-home-page? package) |
| 203 | (let ((url (and=> (package-source package) origin-uri)) | 202 | (let ((url (and=> (package-source package) origin-uri)) |
| 204 | (name (package-upstream-name package))) | 203 | (name (package-upstream-name package))) |
| 205 | (case (and (string? url) (mirror-type url)) | 204 | (case (and (string? url) (mirror-type url)) |
| 206 | ((gnu) #t) | 205 | ((gnu) #t) |
| 207 | ((non-gnu) #f) | 206 | ((non-gnu) #f) |
| 208 | (else | 207 | (else |
| 209 | (and (member name (map gnu-package-name (official-gnu-packages))) | 208 | (and (member name (map gnu-package-name (official-gnu-packages))) |
| 210 | #t))))))))) | 209 | #t)))))))) |
| 211 | 210 | ||
| 212 | 211 | ||
| 213 | ;;; | 212 | ;;; |
diff --git a/guix/modules.scm b/guix/modules.scm index 2ff94007b5e..8c63f21a97e 100644 --- a/guix/modules.scm +++ b/guix/modules.scm | |||
| @@ -71,18 +71,17 @@ CLAUSES." | |||
| 71 | result))))) | 71 | result))))) |
| 72 | 72 | ||
| 73 | (define module-file-dependencies | 73 | (define module-file-dependencies |
| 74 | (memoize | 74 | (mlambda (file) |
| 75 | (lambda (file) | 75 | "Return the list of the names of modules that the Guile module in FILE |
| 76 | "Return the list of the names of modules that the Guile module in FILE | ||
| 77 | depends on." | 76 | depends on." |
| 78 | (call-with-input-file file | 77 | (call-with-input-file file |
| 79 | (lambda (port) | 78 | (lambda (port) |
| 80 | (match (read port) | 79 | (match (read port) |
| 81 | (('define-module name clauses ...) | 80 | (('define-module name clauses ...) |
| 82 | (extract-dependencies clauses)) | 81 | (extract-dependencies clauses)) |
| 83 | ;; XXX: R6RS 'library' form is ignored. | 82 | ;; XXX: R6RS 'library' form is ignored. |
| 84 | (_ | 83 | (_ |
| 85 | '()))))))) | 84 | '())))))) |
| 86 | 85 | ||
| 87 | (define (module-name->file-name module) | 86 | (define (module-name->file-name module) |
| 88 | "Return the file name for MODULE." | 87 | "Return the file name for MODULE." |
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 8c82d8978cd..9804d419293 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm | |||
| @@ -191,12 +191,11 @@ Dependencies may include packages, origin, and file names." | |||
| 191 | %store-monad)))) | 191 | %store-monad)))) |
| 192 | 192 | ||
| 193 | (define standard-package-set | 193 | (define standard-package-set |
| 194 | (memoize | 194 | (mlambda () |
| 195 | (lambda () | 195 | "Return the set of standard packages provided by GNU-BUILD-SYSTEM." |
| 196 | "Return the set of standard packages provided by GNU-BUILD-SYSTEM." | 196 | (match (standard-packages) |
| 197 | (match (standard-packages) | 197 | (((labels packages . output) ...) |
| 198 | (((labels packages . output) ...) | 198 | (list->setq packages))))) |
| 199 | (list->setq packages)))))) | ||
| 200 | 199 | ||
| 201 | (define (bag-node-edges-sans-bootstrap thing) | 200 | (define (bag-node-edges-sans-bootstrap thing) |
| 202 | "Like 'bag-node-edges', but pretend that the standard packages of | 201 | "Like 'bag-node-edges', but pretend that the standard packages of |
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index cb64dc8b2b2..0b38aac319e 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm | |||
| @@ -559,12 +559,11 @@ patch could not be found." | |||
| 559 | str))) | 559 | str))) |
| 560 | 560 | ||
| 561 | (define official-gnu-packages* | 561 | (define official-gnu-packages* |
| 562 | (memoize | 562 | (mlambda () |
| 563 | (lambda () | 563 | "A memoizing version of 'official-gnu-packages' that returns the empty |
| 564 | "A memoizing version of 'official-gnu-packages' that returns the empty | ||
| 565 | list when something goes wrong, such as a networking issue." | 564 | list when something goes wrong, such as a networking issue." |
| 566 | (let ((gnus (false-if-exception (official-gnu-packages)))) | 565 | (let ((gnus (false-if-exception (official-gnu-packages)))) |
| 567 | (or gnus '()))))) | 566 | (or gnus '())))) |
| 568 | 567 | ||
| 569 | (define (check-gnu-synopsis+description package) | 568 | (define (check-gnu-synopsis+description package) |
| 570 | "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and | 569 | "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and |
diff --git a/guix/store.scm b/guix/store.scm index 491cd5ac06a..cb3fbed912c 100644 --- a/guix/store.scm +++ b/guix/store.scm | |||
| @@ -1282,11 +1282,10 @@ valid inputs." | |||
| 1282 | (define store-regexp* | 1282 | (define store-regexp* |
| 1283 | ;; The substituter makes repeated calls to 'store-path-hash-part', hence | 1283 | ;; The substituter makes repeated calls to 'store-path-hash-part', hence |
| 1284 | ;; this optimization. | 1284 | ;; this optimization. |
| 1285 | (memoize | 1285 | (mlambda (store) |
| 1286 | (lambda (store) | 1286 | "Return a regexp matching a file in STORE." |
| 1287 | "Return a regexp matching a file in STORE." | 1287 | (make-regexp (string-append "^" (regexp-quote store) |
| 1288 | (make-regexp (string-append "^" (regexp-quote store) | 1288 | "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))) |
| 1289 | "/([0-9a-df-np-sv-z]{32})-([^/]+)$"))))) | ||
| 1290 | 1289 | ||
| 1291 | (define (store-path-package-name path) | 1290 | (define (store-path-package-name path) |
| 1292 | "Return the package name part of PATH, a file name in the store." | 1291 | "Return the package name part of PATH, a file name in the store." |
diff --git a/guix/utils.scm b/guix/utils.scm index 8aa2cb734dd..72dc0687a40 100644 --- a/guix/utils.scm +++ b/guix/utils.scm | |||
| @@ -771,11 +771,10 @@ be determined." | |||
| 771 | (column location-column)) ; 0-indexed column | 771 | (column location-column)) ; 0-indexed column |
| 772 | 772 | ||
| 773 | (define location | 773 | (define location |
| 774 | (memoize | 774 | (mlambda (file line column) |
| 775 | (lambda (file line column) | 775 | "Return the <location> object for the given FILE, LINE, and COLUMN." |
| 776 | "Return the <location> object for the given FILE, LINE, and COLUMN." | 776 | (and line column file |
| 777 | (and line column file | 777 | (make-location file line column)))) |
| 778 | (make-location file line column))))) | ||
| 779 | 778 | ||
| 780 | (define (source-properties->location loc) | 779 | (define (source-properties->location loc) |
| 781 | "Return a location object based on the info in LOC, an alist as returned | 780 | "Return a location object based on the info in LOC, an alist as returned |
