From 0d371c633f7308cfde2432d6119d386a5c63198c Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Sat, 9 May 2020 08:43:39 +0200 Subject: syscalls: Adjust 'sockaddr-in', 'sockaddr-in6' structs for the Hurd. * guix/build/syscalls.scm (sockaddr-in,sockaddr-in6): Rename to ... (sockaddr-in/linux, sockaddr-in6/linux): ... this. Rename introduced bindings as well. (write-socket-address!/linux,read-socket-address/linux): Rename from (write-socket-address!, read-socket-address): ... new switches between those and ... (write-socket-address!/hurd, read-socket-address/hurd): ... these new function. --- guix/build/syscalls.scm | 113 ++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 91 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ff008c5b78..8070c5546f 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1315,62 +1315,131 @@ (define ifreq-struct-size 40 32)) -(define-c-struct sockaddr-in ; - sizeof-sockaddrin +(define-c-struct sockaddr-in/linux ; + sizeof-sockaddr-in/linux (lambda (family port address) (make-socket-address family address port)) - read-sockaddr-in - write-sockaddr-in! + read-sockaddr-in/linux + write-sockaddr-in!/linux (family unsigned-short) (port (int16 ~ big)) (address (int32 ~ big))) -(define-c-struct sockaddr-in6 ; - sizeof-sockaddr-in6 +(define-c-struct sockaddr-in/hurd ; + sizeof-sockaddr-in/hurd + (lambda (len family port address zero) + (make-socket-address family address port)) + read-sockaddr-in/hurd + write-sockaddr-in!/hurd + (len uint8) + (family uint8) + (port (int16 ~ big)) + (address (int32 ~ big)) + (zero (array uint8 8))) + +(define-c-struct sockaddr-in6/linux ; + sizeof-sockaddr-in6/linux (lambda (family port flowinfo address scopeid) (make-socket-address family address port flowinfo scopeid)) - read-sockaddr-in6 - write-sockaddr-in6! + read-sockaddr-in6/linux + write-sockaddr-in6!/linux (family unsigned-short) (port (int16 ~ big)) (flowinfo (int32 ~ big)) (address (int128 ~ big)) (scopeid int32)) -(define (write-socket-address! sockaddr bv index) +(define-c-struct sockaddr-in6/hurd ; + sizeof-sockaddr-in6/hurd + (lambda (len family port flowinfo address scopeid) + (make-socket-address family address port flowinfo scopeid)) + read-sockaddr-in6/hurd + write-sockaddr-in6!/hurd + (len uint8) + (family uint8) + (port (int16 ~ big)) + (flowinfo (int32 ~ big)) + (address (int128 ~ big)) + (scopeid int32)) + +(define (write-socket-address!/linux sockaddr bv index) + "Write SOCKADDR, a socket address as returned by 'make-socket-address', to +bytevector BV at INDEX." + (let ((family (sockaddr:fam sockaddr))) + (cond ((= family AF_INET) + (write-sockaddr-in!/linux bv index + family + (sockaddr:port sockaddr) + (sockaddr:addr sockaddr))) + ((= family AF_INET6) + (write-sockaddr-in6!/linux bv index + family + (sockaddr:port sockaddr) + (sockaddr:flowinfo sockaddr) + (sockaddr:addr sockaddr) + (sockaddr:scopeid sockaddr))) + (else + (error "unsupported socket address" sockaddr))))) + +(define (write-socket-address!/hurd sockaddr bv index) "Write SOCKADDR, a socket address as returned by 'make-socket-address', to bytevector BV at INDEX." (let ((family (sockaddr:fam sockaddr))) (cond ((= family AF_INET) - (write-sockaddr-in! bv index - family - (sockaddr:port sockaddr) - (sockaddr:addr sockaddr))) + (write-sockaddr-in!/hurd bv index + sizeof-sockaddr-in/hurd + family + (sockaddr:port sockaddr) + (sockaddr:addr sockaddr) + '(0 0 0 0 0 0 0 0))) ((= family AF_INET6) - (write-sockaddr-in6! bv index - family - (sockaddr:port sockaddr) - (sockaddr:flowinfo sockaddr) - (sockaddr:addr sockaddr) - (sockaddr:scopeid sockaddr))) + (write-sockaddr-in6!/hurd bv index + sizeof-sockaddr-in6/hurd + family + (sockaddr:port sockaddr) + (sockaddr:flowinfo sockaddr) + (sockaddr:addr sockaddr) + (sockaddr:scopeid sockaddr))) (else (error "unsupported socket address" sockaddr))))) +(define write-socket-address! + (if (string-suffix? "linux-gnu" %host-type) + write-socket-address!/linux + write-socket-address!/hurd)) + (define PF_PACKET 17) ; (define AF_PACKET PF_PACKET) -(define* (read-socket-address bv #:optional (index 0)) +(define* (read-socket-address/linux bv #:optional (index 0)) + "Read a socket address from bytevector BV at INDEX." + (let ((family (bytevector-u16-native-ref bv index))) + (cond ((= family AF_INET) + (read-sockaddr-in/linux bv index)) + ((= family AF_INET6) + (read-sockaddr-in6/linux bv index)) + (else + ;; XXX: Unsupported address family, such as AF_PACKET. Return a + ;; vector such that the vector can at least call 'sockaddr:fam'. + (vector family))))) + +(define* (read-socket-address/hurd bv #:optional (index 0)) "Read a socket address from bytevector BV at INDEX." (let ((family (bytevector-u16-native-ref bv index))) (cond ((= family AF_INET) - (read-sockaddr-in bv index)) + (read-sockaddr-in/hurd bv index)) ((= family AF_INET6) - (read-sockaddr-in6 bv index)) + (read-sockaddr-in6/hurd bv index)) (else ;; XXX: Unsupported address family, such as AF_PACKET. Return a ;; vector such that the vector can at least call 'sockaddr:fam'. (vector family))))) +(define read-socket-address + (if (string-suffix? "linux-gnu" %host-type) + read-socket-address/linux + read-socket-address/hurd)) + (define %ioctl ;; The most terrible interface, live from Scheme. (syscall->procedure int "ioctl" (list int unsigned-long '*))) -- cgit v1.2.3 From 9db8836916d0e79f86ac63fbd9b77096d83abfa1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 May 2020 11:53:13 +0200 Subject: channels: 'build-from-source' restores '%guile-for-build'. Not restoring it would cause problems when running: guix time-machine --commit=6298c3ffd9654d3231a6f25390b056483e8f407c or similar because the target Guix would be built with 2.2, and then we'd erroneously go on and attempt build the profile with 2.2. This would fail because profile dependencies such as "guile-gdbm-ffi" now target 3.0. * guix/channels.scm (call-with-guile): New procedure. (with-guile): New macro. (build-from-source): Use it instead of calling 'set-guile-for-build' just once. This ensures that '%guile-for-build' is restored afterwards. --- guix/channels.scm | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index aca8302ba0..f0174de767 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -347,6 +347,21 @@ (define* (guile-for-source source #:optional (quirks %quirks)) (((predicate . guile) rest ...) (if (predicate source) (guile) (loop rest)))))) +(define (call-with-guile guile thunk) + (lambda (store) + (values (parameterize ((%guile-for-build + (if guile + (package-derivation store guile) + (%guile-for-build)))) + (run-with-store store (thunk))) + store))) + +(define-syntax-rule (with-guile guile exp ...) + "Set GUILE as the '%guile-for-build' parameter for the dynamic extent of +EXP, a series of monadic expressions." + (call-with-guile guile (lambda () + (mbegin %store-monad exp ...)))) + (define (with-trivial-build-handler mvalue) "Run MVALUE, a monadic value, with a \"trivial\" build handler installed that unconditionally resumes the continuation." @@ -385,10 +400,7 @@ (define script ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In ;; the future we'll fall back to a previous version of the protocol ;; when that happens. - (mbegin %store-monad - (mwhen guile - (set-guile-for-build guile)) - + (with-guile guile ;; BUILD is usually quite costly. Install a "trivial" build handler ;; so we don't bounce an outer build-accumulator handler that could ;; cause us to redo half of the BUILD computation several times just @@ -750,3 +762,7 @@ (define* (channel-news-for-commit channel new #:optional old) (if (= GIT_ENOTFOUND (git-error-code error)) '() (apply throw key error rest))))) + +;;; Local Variables: +;;; eval: (put 'with-guile 'scheme-indent-function 1) +;;; End: -- cgit v1.2.3 From 01611d141e966d7f1183106626bf96abf338c771 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 May 2020 10:04:39 +0200 Subject: quirks: Add patch for . Fixes . * guix/quirks.scm (%bug-41214-patch): New variable. (%patches): Add it. --- guix/quirks.scm | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/quirks.scm b/guix/quirks.scm index 483169e70d..d180bd2c09 100644 --- a/guix/quirks.scm +++ b/guix/quirks.scm @@ -19,6 +19,7 @@ (define-module (guix quirks) #:use-module ((guix build utils) #:select (substitute*)) #:use-module (srfi srfi-9) + #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:export (%quirks @@ -117,8 +118,42 @@ (define (add-missing-ice-9-threads-import source) (patch missing-ice-9-threads-import? add-missing-ice-9-threads-import))) +(define %bug-41214-patch + ;; Patch for . Around v1.0.0, (guix build + ;; compile) would use Guile 2.2 procedures to access the set of available + ;; compilation options. These procedures no longer exist in 3.0. + (let () + (define (accesses-guile-2.2-optimization-options? source commit) + (catch 'system-error + (lambda () + (match (call-with-input-file + (string-append source "/guix/build/compile.scm") + read) + (('define-module ('guix 'build 'compile) + _ ... + #:use-module ('language 'tree-il 'optimize) + #:use-module ('language 'cps 'optimize) + #:export ('%default-optimizations + '%lightweight-optimizations + 'compile-files)) + #t) + (_ #f))) + (const #f))) + + (define (build-with-guile-2.2 source) + (substitute* (string-append source "/" %self-build-file) + (("\\(default-guile\\)") + (object->string '(car (find-best-packages-by-name "guile" "2.2")))) + (("\\(find-best-packages-by-name \"guile-gcrypt\" #f\\)") + (object->string '(find-best-packages-by-name "guile2.2-gcrypt" #f)))) + #t) + + (patch accesses-guile-2.2-optimization-options? + build-with-guile-2.2))) + (define %patches ;; Bits of past Guix revisions can become incompatible with newer Guix and ;; Guile. This variable lists records for the Guix source tree that ;; apply to the Guix source. - (list %bug-41028-patch)) + (list %bug-41028-patch + %bug-41214-patch)) -- cgit v1.2.3 From 2b8a9cca017064a8db095395f9393ae076f7d8c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 May 2020 12:13:26 +0200 Subject: licenses: Update Zlib license URL. * guix/licenses.scm (zlib): Change URL. --- guix/licenses.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index a16d2241ad..bf72a33c92 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2014, 2015, 2017, 2019 Ludovic Courtès +;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020 Ludovic Courtès ;;; Copyright © 2013, 2015 Andreas Enge ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver @@ -644,7 +644,7 @@ (define zpl2.1 (define zlib (license "Zlib" - "http://www.gzip.org/zlib/zlib_license.html" + "https://zlib.net/zlib_license.html" "https://www.gnu.org/licenses/license-list#ZLib")) (define hpnd -- cgit v1.2.3 From d03001a31a6d460b712825640dba11e3f1a53a14 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Nov 2017 17:10:17 +0100 Subject: gexp: Compilers can now return lowerable objects. * guix/gexp.scm (lower-object): Iterate if LOWERED is a struct. (lower+expand-object): New procedure. (gexp->sexp): Use it. (define-gexp-compiler): Adjust docstring. --- guix/gexp.scm | 74 ++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 51 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 2a4b36519c..5c614f3e12 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -226,32 +226,62 @@ (define* (lower-object obj corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. OBJ must be an object that has an associated gexp compiler, such as a ." - (match (lookup-compiler obj) - (#f - (raise (condition (&gexp-input-error (input obj))))) - (lower - ;; Cache in STORE the result of lowering OBJ. - (mlet %store-monad ((target (if (eq? target 'current) - (current-target-system) - (return target))) - (graft? (grafting?))) - (mcached (let ((lower (lookup-compiler obj))) - (lower obj system target)) - obj - system target graft?))))) + (mlet %store-monad ((target (if (eq? target 'current) + (current-target-system) + (return target))) + (graft? (grafting?))) + (let loop ((obj obj)) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + ;; Cache in STORE the result of lowering OBJ. + (mcached (mlet %store-monad ((lowered (lower obj system target))) + (if (and (struct? lowered) + (not (derivation? lowered))) + (loop lowered) + (return lowered))) + obj + system target graft?)))))) + +(define* (lower+expand-object obj + #:optional (system (%current-system)) + #:key target (output "out")) + "Return as a value in %STORE-MONAD the output of object OBJ expands to for +SYSTEM and TARGET. Object such as , , or +expand to file names, but it's possible to expand to a plain data type." + (let loop ((obj obj) + (expand (and (struct? obj) (lookup-expander obj)))) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + (mlet* %store-monad ((graft? (grafting?)) + (lowered (mcached (lower obj system target) + obj + system target graft?))) + ;; LOWER might return something that needs to be further + ;; lowered. + (if (struct? lowered) + ;; If we lack an expander, delegate to that of LOWERED. + (if (not expand) + (loop lowered (lookup-expander lowered)) + (return (expand obj lowered output))) + (return lowered))))))) ;self-quoting (define-syntax define-gexp-compiler (syntax-rules (=> compiler expander) "Define NAME as a compiler for objects matching PREDICATE encountered in gexps. -In the simplest form of the macro, BODY must return a derivation for PARAM, an -object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is -#f except when cross-compiling.) +In the simplest form of the macro, BODY must return (1) a derivation for +a record of the specified type, for SYSTEM and TARGET (the latter of which is +#f except when cross-compiling), (2) another record that can itself be +compiled down to a derivation, or (3) an object of a primitive data type. The more elaborate form allows you to specify an expander: - (define-gexp-compiler something something? + (define-gexp-compiler something-compiler compiler => (lambda (param system target) ...) expander => (lambda (param drv output) ...)) @@ -1148,12 +1178,10 @@ (define* (reference->sexp ref #:optional native?) (or n? native?))) refs)) (($ (? struct? thing) output n?) - (let ((target (if (or n? native?) #f target)) - (expand (lookup-expander thing))) - (mlet %store-monad ((obj (lower-object thing system - #:target target))) - ;; OBJ must be either a derivation or a store file name. - (return (expand thing obj output))))) + (let ((target (if (or n? native?) #f target))) + (lower+expand-object thing system + #:target target + #:output output))) (($ (? self-quoting? x)) (return x)) (($ x) -- cgit v1.2.3 From 644cb40cd83eff8a5bcdbd2d63887daa18228f41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Nov 2017 10:16:22 +0100 Subject: gexp: Add 'let-system'. * guix/gexp.scm (): New record type. (let-system): New macro. (system-binding-compiler): New procedure. (default-expander): Add 'self-quoting?' case. (self-quoting?): New procedure. (lower-inputs): Add 'filterm'. Pass the result of 'mapm/accumulate-builds' through FILTERM. (gexp->sexp)[self-quoting?]: Remove. * tests/gexp.scm ("let-system", "let-system, target") ("let-system, ungexp-native, target") ("let-system, nested"): New tests. * doc/guix.texi (G-Expressions): Document it. --- .dir-locals.el | 1 + doc/guix.texi | 26 ++++++++++++++ guix/gexp.scm | 110 +++++++++++++++++++++++++++++++++++++++++++-------------- tests/gexp.scm | 54 ++++++++++++++++++++++++++++ 4 files changed, 165 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index ce305602f2..fcde914e60 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -85,6 +85,7 @@ (eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'with-extensions 'scheme-indent-function 1)) (eval . (put 'with-parameters 'scheme-indent-function 1)) + (eval . (put 'let-system 'scheme-indent-function 1)) (eval . (put 'with-database 'scheme-indent-function 2)) (eval . (put 'call-with-transaction 'scheme-indent-function 2)) diff --git a/doc/guix.texi b/doc/guix.texi index a36b9691fb..d043852ac3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8123,6 +8123,32 @@ the second case, the resulting script contains a @code{(string-append @dots{})} expression to construct the file name @emph{at run time}. @end deffn +@deffn {Scheme Syntax} let-system @var{system} @var{body}@dots{} +@deffnx {Scheme Syntax} let-system (@var{system} @var{target}) @var{body}@dots{} +Bind @var{system} to the currently targeted system---e.g., +@code{"x86_64-linux"}---within @var{body}. + +In the second case, additionally bind @var{target} to the current +cross-compilation target---a GNU triplet such as +@code{"arm-linux-gnueabihf"}---or @code{#f} if we are not +cross-compiling. + +@code{let-system} is useful in the occasional case where the object +spliced into the gexp depends on the target system, as in this example: + +@example +#~(system* + #+(let-system system + (cond ((string-prefix? "armhf-" system) + (file-append qemu "/bin/qemu-system-arm")) + ((string-prefix? "x86_64-" system) + (file-append qemu "/bin/qemu-system-x86_64")) + (else + (error "dunno!")))) + "-net" "user" #$image) +@end example +@end deffn + @deffn {Scheme Syntax} with-parameters ((@var{parameter} @var{value}) @dots{}) @var{exp} This macro is similar to the @code{parameterize} form for dynamically-bound @dfn{parameters} (@pxref{Parameters,,, guile, GNU diff --git a/guix/gexp.scm b/guix/gexp.scm index 5c614f3e12..78b8af6fbc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -37,6 +37,7 @@ (define-module (guix gexp) gexp? with-imported-modules with-extensions + let-system gexp-input gexp-input? @@ -195,7 +196,9 @@ (define (default-expander thing obj output) ((? derivation? drv) (derivation->output-path drv output)) ((? string? file) - file))) + file) + ((? self-quoting? obj) + obj))) (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." @@ -327,6 +330,52 @@ (define-gexp-compiler raw-derivation-file-compiler (derivation-file-name lowered) lowered))) + +;;; +;;; System dependencies. +;;; + +;; Binding form for the current system and cross-compilation target. +(define-record-type + (system-binding proc) + system-binding? + (proc system-binding-proc)) + +(define-syntax let-system + (syntax-rules () + "Introduce a system binding in a gexp. The simplest form is: + + (let-system system + (cond ((string=? system \"x86_64-linux\") ...) + (else ...))) + +which binds SYSTEM to the currently targeted system. The second form is +similar, but it also shows the cross-compilation target: + + (let-system (system target) + ...) + +Here TARGET is bound to the cross-compilation triplet or #f." + ((_ (system target) exp0 exp ...) + (system-binding (lambda (system target) + exp0 exp ...))) + ((_ system exp0 exp ...) + (system-binding (lambda (system target) + exp0 exp ...))))) + +(define-gexp-compiler system-binding-compiler + compiler => (lambda (binding system target) + (match binding + (($ proc) + (with-monad %store-monad + ;; PROC is expected to return a lowerable object. + ;; 'lower-object' takes care of residualizing it to a + ;; derivation or similar. + (return (proc system target)))))) + + ;; Delegate to the expander of the object returned by PROC. + expander => #f) + ;;; ;;; File declarations. @@ -706,6 +755,15 @@ (define (gexp-extensions gexp) list." (gexp-attribute gexp gexp-self-extensions)) +(define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean? char?))) + (define* (lower-inputs inputs #:key system target) "Turn any object from INPUTS into a derivation input for SYSTEM or a store @@ -714,23 +772,32 @@ (define* (lower-inputs inputs (define (store-item? obj) (and (string? obj) (store-path? obj))) + (define filterm + (lift1 (cut filter ->bool <>) %store-monad)) + (with-monad %store-monad - (mapm/accumulate-builds - (match-lambda - (((? struct? thing) sub-drv ...) - (mlet %store-monad ((obj (lower-object - thing system #:target target))) - (return (match obj - ((? derivation? drv) - (let ((outputs (if (null? sub-drv) - '("out") - sub-drv))) - (derivation-input drv outputs))) - ((? store-item? item) - item))))) - (((? store-item? item)) - (return item))) - inputs))) + (>>= (mapm/accumulate-builds + (match-lambda + (((? struct? thing) sub-drv ...) + (mlet %store-monad ((obj (lower-object + thing system #:target target))) + (return (match obj + ((? derivation? drv) + (let ((outputs (if (null? sub-drv) + '("out") + sub-drv))) + (derivation-input drv outputs))) + ((? store-item? item) + item) + ((? self-quoting?) + ;; Some inputs such as can lower to + ;; a self-quoting object that FILTERM will filter + ;; out. + #f))))) + (((? store-item? item)) + (return item))) + inputs) + filterm))) (define* (lower-reference-graphs graphs #:key system target) "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a @@ -1146,15 +1213,6 @@ (define* (gexp->sexp exp #:key (target (%current-target-system))) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" - (define (self-quoting? x) - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? keyword? pair? null? array? - number? boolean? char?))) - (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref diff --git a/tests/gexp.scm b/tests/gexp.scm index 6a42d3eb57..e073a7b816 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -321,6 +321,60 @@ (define (match-input thing) (string=? result (string-append (derivation->output-path drv) "/bin/touch")))))) +(test-equal "let-system" + (list `(begin ,(%current-system) #t) '(system-binding) '() + 'low '() '()) + (let* ((exp #~(begin + #$(let-system system system) + #t)) + (low (run-with-store %store (lower-gexp exp)))) + (list (lowered-gexp-sexp low) + (match (gexp-inputs exp) + (((($ (@@ (guix gexp) )) "out")) + '(system-binding)) + (x x)) + (gexp-native-inputs exp) + 'low + (lowered-gexp-inputs low) + (lowered-gexp-sources low)))) + +(test-equal "let-system, target" + (list `(list ,(%current-system) #f) + `(list ,(%current-system) "aarch64-linux-gnu")) + (let ((exp #~(list #$@(let-system (system target) + (list system target))))) + (list (gexp->sexp* exp) + (gexp->sexp* exp "aarch64-linux-gnu")))) + +(test-equal "let-system, ungexp-native, target" + `(here it is: ,(%current-system) #f) + (let ((exp #~(here it is: #+@(let-system (system target) + (list system target))))) + (gexp->sexp* exp "aarch64-linux-gnu"))) + +(test-equal "let-system, nested" + (list `(system* ,(string-append "qemu-system-" (%current-system)) + "-m" "256") + '() + '(system-binding)) + (let ((exp #~(system* + #+(let-system (system target) + (file-append (@@ (gnu packages virtualization) + qemu) + "/bin/qemu-system-" + system)) + "-m" "256"))) + (list (match (gexp->sexp* exp) + (('system* command rest ...) + `(system* ,(and (string-prefix? (%store-prefix) command) + (basename command)) + ,@rest)) + (x x)) + (gexp-inputs exp) + (match (gexp-native-inputs exp) + (((($ (@@ (guix gexp) )) "out")) + '(system-binding)) + (x x))))) (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) -- cgit v1.2.3 From 300a54bb984b92a36b68d7a672f2e11aa3dd2af1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 15 May 2020 22:22:03 +0200 Subject: utils: 'target-arm32?' & co. take an optional parameter. * guix/utils.scm (target-arm32?, target-aarch64?) (target-arm?, target-64bit?): Make 'target' an optional parameter. --- guix/utils.scm | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 3e8e59b8dc..d7b197fa44 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -490,18 +490,21 @@ (define* (target-mingw? #:optional (target (%current-target-system))) (and target (string-suffix? "-mingw32" target))) -(define (target-arm32?) - (string-prefix? "arm" (or (%current-target-system) (%current-system)))) +(define* (target-arm32? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "arm" target)) -(define (target-aarch64?) - (string-prefix? "aarch64" (or (%current-target-system) (%current-system)))) +(define* (target-aarch64? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "aarch64" target)) -(define (target-arm?) - (or (target-arm32?) (target-aarch64?))) +(define* (target-arm? #:optional (target (or (%current-target-system) + (%current-system)))) + (or (target-arm32? target) (target-aarch64? target))) -(define (target-64bit?) - (let ((system (or (%current-target-system) (%current-system)))) - (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64")))) +(define* (target-64bit? #:optional (system (or (%current-target-system) + (%current-system)))) + (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))) (define version-compare (let ((strverscmp -- cgit v1.2.3 From 5b77e9ca14ff7fc74b849492e96353939f29664b Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Wed, 6 May 2020 11:27:48 +0300 Subject: build: minify-build-system: Fail to install empty files. * guix/build/minify-build-system.scm (install): Produce an error if the minified file is zero bytes. --- guix/build/minify-build-system.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 563def88e9..92158a033f 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,8 +55,12 @@ (define* (install #:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (js (string-append out "/share/javascript/"))) (mkdir-p js) - (for-each (cut install-file <> js) - (find-files "guix/build" "\\.min\\.js$"))) + (for-each + (lambda (file) + (if (not (zero? (stat:size (stat file)))) + (install-file file js) + (error "File is empty: " file))) + (find-files "guix/build" "\\.min\\.js$"))) #t) (define %standard-phases -- cgit v1.2.3 From 9a27d84b7a22188d3029199ad3f6dd3b8eccae70 Mon Sep 17 00:00:00 2001 From: Ekaitz Zarraga Date: Sat, 16 May 2020 19:57:18 +0200 Subject: guix describe: Add '--list-formats' MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/describe.scm (%available-formats): New variable. (list-formats): New procedure. (%options, show-help): Add --list-formats * doc/guix.texi: Add --list-formats Signed-off-by: Ludovic Courtès --- doc/guix.texi | 3 +++ guix/scripts/describe.scm | 17 ++++++++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 34acc910f0..eef5b703fe 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4471,6 +4471,9 @@ produce a list of channel specifications in JSON format; produce a list of channel specifications in Recutils format. @end table +@item --list-formats +Display available formats for @option{--format} option. + @item --profile=@var{profile} @itemx -p @var{profile} Display information about @var{profile}. diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index f13f221da9..7a2dbc453a 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Oleg Pykhalov +;;; Copyright © 2020 Ekaitz Zarraga ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,14 +42,26 @@ (define-module (guix scripts describe) ;;; ;;; Command-line options. ;;; +(define %available-formats '("human" "channels" "json" "recutils")) + +(define (list-formats) + (display (G_ "The available formats are:\n")) + (newline) + (for-each (lambda (f) + (format #t " - ~a~%" f)) + %available-formats)) (define %options ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f (lambda (opt name arg result) - (unless (member arg '("human" "channels" "json" "recutils")) + (unless (member arg %available-formats) (leave (G_ "~a: unsupported output format~%") arg)) (alist-cons 'format (string->symbol arg) result))) + (option '("list-formats") #f #f + (lambda (opt name arg result) + (list-formats) + (exit 0))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) @@ -70,6 +83,8 @@ (define (show-help) Display information about the channels currently in use.\n")) (display (G_ " -f, --format=FORMAT display information in the given FORMAT")) + (display (G_ " + --list-formats display available formats")) (display (G_ " -p, --profile=PROFILE display information about PROFILE")) (newline) -- cgit v1.2.3 From 70e33ec795b42a497df342950469f65c8406988c Mon Sep 17 00:00:00 2001 From: Alex Sassmannshausen Date: Sat, 16 May 2020 15:32:45 +0200 Subject: build-system/guile: Expose #:scheme-file-regexp. * guix/build-system/guile.scm (%scheme-file-regexp): New variable. (guile-build): Accept #:scheme-file-regexp and pass it on to builder. --- guix/build-system/guile.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 3693014694..45e735b987 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -29,6 +29,10 @@ (define-module (guix build-system guile) #:export (%guile-build-system-modules guile-build-system)) +(define %scheme-file-regexp + ;; Regexp to match Scheme files. + "\\.(scm|sls)$") + (define %guile-build-system-modules ;; Build-side modules imported by default. `((guix build guile-build-system) @@ -80,6 +84,7 @@ (define* (guile-build store name inputs (system (%current-system)) (source-directory ".") not-compiled-file-regexp + (scheme-file-regexp %scheme-file-regexp) (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) (modules '((guix build guile-build-system) @@ -97,6 +102,7 @@ (define builder (source source)) #:source-directory ,source-directory + #:scheme-file-regexp ,scheme-file-regexp #:not-compiled-file-regexp ,not-compiled-file-regexp #:compile-flags ,compile-flags #:phases ,phases -- cgit v1.2.3 From 5e3d169945935b53325e6b738a307ba286751259 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 19 May 2020 23:14:30 +0200 Subject: publish: Improve performance by increasing buffer size. * guix/scripts/publish.scm (http-write): Increase socket send buffer. --- guix/scripts/publish.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index f5b2f5fd4e..a00f08f9d9 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -851,6 +851,7 @@ (define (http-write server client response body) size) client)) (output (response-port response))) + (setsockopt client SOL_SOCKET SO_SNDBUF (* 128 1024)) (if (file-port? output) (sendfile output input size) (dump-port input output)) -- cgit v1.2.3 From c3f1f09586967c3fefbb280014a4d46b57786696 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Thu, 7 May 2020 14:25:51 +0200 Subject: build: asdf-build-system: Use SBCL source in CL packages. * guix/build/asdf-build-system.scm (copy-files-to-output): Don't attempt to reset timestamps on files without write access. (install): When parent SBCL package is in the inputs, use its source. This way we get possibly patched sources in CL packages as well (e.g. for FFI). This is also useful for sources that generate files on load-op, like cl-unicode. * guix/build-system/asdf.scm (package-with-build-system): Forward the SBCL parent as a native input so that it can be used in the above install phase. --- guix/build-system/asdf.scm | 5 +++- guix/build/asdf-build-system.scm | 54 +++++++++++++++++++++++++++++++++++----- 2 files changed, 52 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f794bf006b..630b99e2bf 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -230,7 +230,10 @@ (define base-arguments ((#:phases phases) (list phases-transformer phases)))) (inputs (new-inputs package-inputs)) (propagated-inputs (new-propagated-inputs)) - (native-inputs (new-inputs package-native-inputs)) + (native-inputs (append (if target-is-source? + (list (list (package-name pkg) pkg)) + '()) + (new-inputs package-native-inputs))) (outputs (if target-is-source? '("out") (package-outputs pkg))))) diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index f3f4b49bcf..25dd031962 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -85,7 +85,8 @@ (define (copy-files-to-output out name) ;; files before compiling. (for-each (lambda (file) (let ((s (lstat file))) - (unless (eq? (stat:type s) 'symlink) + (unless (or (eq? (stat:type s) 'symlink) + (not (access? file W_OK))) (utime file 0 0 0 0)))) (find-files source #:directories? #t)) (copy-recursively source target #:keep-mtime? #t) @@ -97,12 +98,53 @@ (define (copy-files-to-output out name) (find-files target "\\.asd$")) #t)) -(define* (install #:key outputs #:allow-other-keys) - "Copy and symlink all the source files." +(define* (install #:key inputs outputs #:allow-other-keys) + "Copy and symlink all the source files. +The source files are taken from the corresponding compile package (e.g. SBCL) +if it's present in the native-inputs." (define output (assoc-ref outputs "out")) - (copy-files-to-output output - (package-name->name+version - (strip-store-file-name output)))) + (define package-name + (package-name->name+version + (strip-store-file-name output))) + (define (no-prefix pkgname) + (if (string-index pkgname #\-) + (string-drop pkgname (1+ (string-index pkgname #\-))) + pkgname)) + (define parent + (match (assoc package-name inputs + (lambda (key alist-car) + (let* ((alt-key (no-prefix key)) + (alist-car (no-prefix alist-car))) + (or (string=? alist-car key) + (string=? alist-car alt-key))))) + (#f #f) + (p (cdr p)))) + (define parent-name + (and parent + (package-name->name+version (strip-store-file-name parent)))) + (define parent-source + (and parent + (string-append parent "/share/common-lisp/" + (string-take parent-name + (string-index parent-name #\-)) + "-source"))) + + (define (first-subdirectory directory) ; From gnu-build-system. + "Return the file name of the first sub-directory of DIRECTORY." + (match (scandir directory + (lambda (file) + (and (not (member file '("." ".."))) + (file-is-directory? (string-append directory "/" + file))))) + ((first . _) first))) + (define source-directory + (if (and parent-source + (file-exists? parent-source)) + (string-append parent-source "/" (first-subdirectory parent-source)) + ".")) + + (with-directory-excursion source-directory + (copy-files-to-output output package-name))) (define* (copy-source #:key outputs asd-system-name #:allow-other-keys) "Copy the source to the library output." -- cgit v1.2.3