summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/gexp.scm31
-rw-r--r--tests/gexp.scm54
2 files changed, 33 insertions, 52 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8e80d4adbe4..7a3228ec2e6 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1006,13 +1006,9 @@ derivations--e.g., code evaluated for its side effects."
1006 (guile (if guile-for-build 1006 (guile (if guile-for-build
1007 (return guile-for-build) 1007 (return guile-for-build)
1008 (default-guile-derivation system))) 1008 (default-guile-derivation system)))
1009 (normals (lower-inputs (gexp-inputs exp) 1009 (inputs (lower-inputs (gexp-inputs exp)
1010 #:system system 1010 #:system system
1011 #:target target)) 1011 #:target target))
1012 (natives (lower-inputs (gexp-native-inputs exp)
1013 #:system system
1014 #:target #f))
1015 (inputs -> (append normals natives))
1016 (sexp (gexp->sexp exp 1012 (sexp (gexp->sexp exp
1017 #:system system 1013 #:system system
1018 #:target target)) 1014 #:target target))
@@ -1218,26 +1214,26 @@ The other arguments are as for 'derivation'."
1218 #:substitutable? substitutable? 1214 #:substitutable? substitutable?
1219 #:properties properties)))) 1215 #:properties properties))))
1220 1216
1221(define* (gexp-inputs exp #:key native?) 1217(define (gexp-inputs exp)
1222 "Return the list of <gexp-input> for EXP. When NATIVE? is true, return only 1218 "Return the list of <gexp-input> for EXP."
1223native references; otherwise, return only non-native references." 1219 (define set-gexp-input-native?
1220 (match-lambda
1221 (($ <gexp-input> thing output)
1222 (%gexp-input thing output #t))))
1223
1224 (define (add-reference-inputs ref result) 1224 (define (add-reference-inputs ref result)
1225 (match ref 1225 (match ref
1226 (($ <gexp-input> (? gexp? exp) _ #t) 1226 (($ <gexp-input> (? gexp? exp) _ #t)
1227 (if native? 1227 (append (map set-gexp-input-native? (gexp-inputs exp))
1228 (append (gexp-inputs exp)
1229 (gexp-inputs exp #:native? #t)
1230 result)
1231 result))
1232 (($ <gexp-input> (? gexp? exp) _ #f)
1233 (append (gexp-inputs exp #:native? native?)
1234 result)) 1228 result))
1229 (($ <gexp-input> (? gexp? exp) _ #f)
1230 (append (gexp-inputs exp) result))
1235 (($ <gexp-input> (? string? str)) 1231 (($ <gexp-input> (? string? str))
1236 (if (direct-store-path? str) 1232 (if (direct-store-path? str)
1237 (cons ref result) 1233 (cons ref result)
1238 result)) 1234 result))
1239 (($ <gexp-input> (? struct? thing) output n?) 1235 (($ <gexp-input> (? struct? thing) output n?)
1240 (if (and (eqv? n? native?) (lookup-compiler thing)) 1236 (if (lookup-compiler thing)
1241 ;; THING is a derivation, or a package, or an origin, etc. 1237 ;; THING is a derivation, or a package, or an origin, etc.
1242 (cons ref result) 1238 (cons ref result)
1243 result)) 1239 result))
@@ -1261,9 +1257,6 @@ native references; otherwise, return only non-native references."
1261 '() 1257 '()
1262 (gexp-references exp))) 1258 (gexp-references exp)))
1263 1259
1264(define gexp-native-inputs
1265 (cut gexp-inputs <> #:native? #t))
1266
1267(define (gexp-outputs exp) 1260(define (gexp-outputs exp)
1268 "Return the outputs referred to by EXP as a list of strings." 1261 "Return the outputs referred to by EXP as a list of strings."
1269 (define (add-reference-output ref result) 1262 (define (add-reference-output ref result)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index f742c5db763..0bd1237316e 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -51,8 +51,6 @@
51;; For white-box testing. 51;; For white-box testing.
52(define (gexp-inputs x) 52(define (gexp-inputs x)
53 ((@@ (guix gexp) gexp-inputs) x)) 53 ((@@ (guix gexp) gexp-inputs) x))
54(define (gexp-native-inputs x)
55 ((@@ (guix gexp) gexp-native-inputs) x))
56(define (gexp-outputs x) 54(define (gexp-outputs x)
57 ((@@ (guix gexp) gexp-outputs) x)) 55 ((@@ (guix gexp) gexp-outputs) x))
58(define (gexp->sexp . x) 56(define (gexp->sexp . x)
@@ -64,7 +62,8 @@
64 #:guile-for-build (%guile-for-build))) 62 #:guile-for-build (%guile-for-build)))
65 63
66(define (gexp-input->tuple input) 64(define (gexp-input->tuple input)
67 (list (gexp-input-thing input) (gexp-input-output input))) 65 (list (gexp-input-thing input) (gexp-input-output input)
66 (gexp-input-native? input)))
68 67
69(define %extension-package 68(define %extension-package
70 ;; Example of a package to use when testing 'with-extensions'. 69 ;; Example of a package to use when testing 'with-extensions'.
@@ -347,7 +346,7 @@
347 (string-append (derivation->output-path drv) 346 (string-append (derivation->output-path drv)
348 "/bin/touch")))))) 347 "/bin/touch"))))))
349(test-equal "let-system" 348(test-equal "let-system"
350 (list `(begin ,(%current-system) #t) '(system-binding) '() 349 (list `(begin ,(%current-system) #t) '(system-binding)
351 'low '() '()) 350 'low '() '())
352 (let* ((exp #~(begin 351 (let* ((exp #~(begin
353 #$(let-system system system) 352 #$(let-system system system)
@@ -361,7 +360,6 @@
361 (string=? (gexp-input-output input) "out") 360 (string=? (gexp-input-output input) "out")
362 '(system-binding))) 361 '(system-binding)))
363 (x x)) 362 (x x))
364 (gexp-native-inputs exp)
365 'low 363 'low
366 (lowered-gexp-inputs low) 364 (lowered-gexp-inputs low)
367 (lowered-gexp-sources low)))) 365 (lowered-gexp-sources low))))
@@ -383,7 +381,6 @@
383(test-equal "let-system, nested" 381(test-equal "let-system, nested"
384 (list `(system* ,(string-append "qemu-system-" (%current-system)) 382 (list `(system* ,(string-append "qemu-system-" (%current-system))
385 "-m" "256") 383 "-m" "256")
386 '()
387 '(system-binding)) 384 '(system-binding))
388 (let ((exp #~(system* 385 (let ((exp #~(system*
389 #+(let-system (system target) 386 #+(let-system (system target)
@@ -398,12 +395,12 @@
398 (basename command)) 395 (basename command))
399 ,@rest)) 396 ,@rest))
400 (x x)) 397 (x x))
401 (gexp-inputs exp) 398 (match (gexp-inputs exp)
402 (match (gexp-native-inputs exp)
403 ((input) 399 ((input)
404 (and (eq? (struct-vtable (gexp-input-thing input)) 400 (and (eq? (struct-vtable (gexp-input-thing input))
405 (@@ (guix gexp) <system-binding>)) 401 (@@ (guix gexp) <system-binding>))
406 (string=? (gexp-input-output input) "out") 402 (string=? (gexp-input-output input) "out")
403 (gexp-input-native? input)
407 '(system-binding))) 404 '(system-binding)))
408 (x x))))) 405 (x x)))))
409 406
@@ -422,31 +419,26 @@
422 (bu (derivation->output-path 419 (bu (derivation->output-path
423 (package-cross-derivation %store binutils target)))) 420 (package-cross-derivation %store binutils target))))
424 (and (lset= equal? 421 (and (lset= equal?
425 `((,%bootstrap-guile "out") (,glibc "out")) 422 `((,%bootstrap-guile "out" #t)
426 (map gexp-input->tuple (gexp-native-inputs exp))) 423 (,coreutils "out" #f)
427 (lset= equal? 424 (,glibc "out" #t)
428 `((,coreutils "out") (,binutils "out")) 425 (,binutils "out" #f))
429 (map gexp-input->tuple (gexp-inputs exp))) 426 (map gexp-input->tuple (gexp-inputs exp)))
430 (equal? `(list ,guile ,cu ,libc ,bu) 427 (equal? `(list ,guile ,cu ,libc ,bu)
431 (gexp->sexp* exp target))))) 428 (gexp->sexp* exp target)))))
432 429
433(test-equal "ungexp + ungexp-native, nested" 430(test-equal "ungexp + ungexp-native, nested"
434 (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) 431 `((,%bootstrap-guile "out" #f) (,coreutils "out" #t))
435 (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) 432 (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils)))
436 (ungexp %bootstrap-guile))))) 433 (ungexp %bootstrap-guile)))))
437 (list (map gexp-input->tuple (gexp-inputs exp)) 434 (map gexp-input->tuple (gexp-inputs exp))))
438 '<>
439 (map gexp-input->tuple (gexp-native-inputs exp)))))
440 435
441(test-equal "ungexp + ungexp-native, nested, special mixture" 436(test-equal "ungexp + ungexp-native, nested, special mixture"
442 `(() <> ((,coreutils "out"))) 437 `((,coreutils "out" #t))
443 438
444 ;; (gexp-native-inputs exp) used to return '(), wrongfully.
445 (let* ((foo (gexp (foo (ungexp-native coreutils)))) 439 (let* ((foo (gexp (foo (ungexp-native coreutils))))
446 (exp (gexp (bar (ungexp foo))))) 440 (exp (gexp (bar (ungexp foo)))))
447 (list (map gexp-input->tuple (gexp-inputs exp)) 441 (map gexp-input->tuple (gexp-inputs exp))))
448 '<>
449 (map gexp-input->tuple (gexp-native-inputs exp)))))
450 442
451(test-assert "input list" 443(test-assert "input list"
452 (let ((exp (gexp (display 444 (let ((exp (gexp (display
@@ -456,7 +448,7 @@
456 (cu (derivation->output-path 448 (cu (derivation->output-path
457 (package-derivation %store coreutils)))) 449 (package-derivation %store coreutils))))
458 (and (lset= equal? 450 (and (lset= equal?
459 `((,%bootstrap-guile "out") (,coreutils "out")) 451 `((,%bootstrap-guile "out" #f) (,coreutils "out" #f))
460 (map gexp-input->tuple (gexp-inputs exp))) 452 (map gexp-input->tuple (gexp-inputs exp)))
461 (equal? `(display '(,guile ,cu)) 453 (equal? `(display '(,guile ,cu))
462 (gexp->sexp* exp))))) 454 (gexp->sexp* exp)))))
@@ -475,10 +467,8 @@
475 (xbu (derivation->output-path 467 (xbu (derivation->output-path
476 (package-cross-derivation %store binutils target)))) 468 (package-cross-derivation %store binutils target))))
477 (and (lset= equal? 469 (and (lset= equal?
478 `((,%bootstrap-guile "out") (,coreutils "out")) 470 `((,%bootstrap-guile "out" #t) (,coreutils "out" #t)
479 (map gexp-input->tuple (gexp-native-inputs exp))) 471 (,glibc "out" #f) (,binutils "out" #f))
480 (lset= equal?
481 `((,glibc "out") (,binutils "out"))
482 (map gexp-input->tuple (gexp-inputs exp))) 472 (map gexp-input->tuple (gexp-inputs exp)))
483 (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) 473 (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
484 (gexp->sexp* exp target))))) 474 (gexp->sexp* exp target)))))
@@ -492,7 +482,7 @@
492 (package-derivation %store %bootstrap-guile)))) 482 (package-derivation %store %bootstrap-guile))))
493 (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) 483 (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs))))))
494 (and (lset= equal? 484 (and (lset= equal?
495 `((,glibc "debug") (,%bootstrap-guile "out")) 485 `((,glibc "debug" #f) (,%bootstrap-guile "out" #f))
496 (map gexp-input->tuple (gexp-inputs exp))) 486 (map gexp-input->tuple (gexp-inputs exp)))
497 (equal? (gexp->sexp* exp) 487 (equal? (gexp->sexp* exp)
498 `(list ,@(cons 5 outputs)))))) 488 `(list ,@(cons 5 outputs))))))
@@ -502,18 +492,16 @@
502 %bootstrap-guile)) 492 %bootstrap-guile))
503 (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) 493 (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
504 (and (lset= equal? 494 (and (lset= equal?
505 `((,glibc "debug") (,%bootstrap-guile "out")) 495 `((,glibc "debug" #t) (,%bootstrap-guile "out" #t))
506 (map gexp-input->tuple (gexp-native-inputs exp))) 496 (map gexp-input->tuple (gexp-inputs exp)))
507 (null? (gexp-inputs exp))
508 (equal? (gexp->sexp* exp) ;native 497 (equal? (gexp->sexp* exp) ;native
509 (gexp->sexp* exp "mips64el-linux"))))) 498 (gexp->sexp* exp "mips64el-linux")))))
510 499
511(test-assert "gexp list splicing + ungexp-splicing" 500(test-assert "gexp list splicing + ungexp-splicing"
512 (let* ((inner (gexp (ungexp-native glibc))) 501 (let* ((inner (gexp (ungexp-native glibc)))
513 (exp (gexp (list (ungexp-splicing (list inner)))))) 502 (exp (gexp (list (ungexp-splicing (list inner))))))
514 (and (equal? `((,glibc "out")) 503 (and (equal? `((,glibc "out" #t))
515 (map gexp-input->tuple (gexp-native-inputs exp))) 504 (map gexp-input->tuple (gexp-inputs exp)))
516 (null? (gexp-inputs exp))
517 (equal? (gexp->sexp* exp) ;native 505 (equal? (gexp->sexp* exp) ;native
518 (gexp->sexp* exp "mips64el-linux"))))) 506 (gexp->sexp* exp "mips64el-linux")))))
519 507