diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/glib-or-gtk.scm | 3 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 2 | ||||
| -rw-r--r-- | guix/build/emacs-utils.scm | 10 | ||||
| -rw-r--r-- | guix/build/glib-or-gtk-build-system.scm | 99 | ||||
| -rw-r--r-- | guix/derivations.scm | 1 | ||||
| -rw-r--r-- | guix/download.scm | 24 | ||||
| -rw-r--r-- | guix/elf.scm | 1045 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 8 | ||||
| -rw-r--r-- | guix/import/gnu.scm | 2 | ||||
| -rw-r--r-- | guix/licenses.scm | 13 | ||||
| -rw-r--r-- | guix/monads.scm | 33 | ||||
| -rw-r--r-- | guix/packages.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 58 | ||||
| -rw-r--r-- | guix/store.scm | 4 | ||||
| -rw-r--r-- | guix/ui.scm | 5 | ||||
| -rw-r--r-- | guix/utils.scm | 10 |
21 files changed, 1284 insertions, 77 deletions
diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 51e0c419e3..8091311879 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -122,6 +122,7 @@ "bin" "sbin")) (phases '(@ (guix build glib-or-gtk-build-system) %standard-phases)) + (glib-or-gtk-wrap-excluded-outputs ''()) (system (%current-system)) (imported-modules %default-imported-modules) (modules %default-modules) @@ -153,6 +154,8 @@ #:search-paths ',(map search-path-specification->sexp search-paths) #:phases ,phases + #:glib-or-gtk-wrap-excluded-outputs + ,glib-or-gtk-wrap-excluded-outputs #:configure-flags ,configure-flags #:make-flags ,make-flags #:out-of-source? ,out-of-source? diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 78348e9cf7..4bba7167ca 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -86,6 +86,8 @@ prepended to the name." arguments))) (inputs (map rewrite (package-inputs p))) + (propagated-inputs + (map rewrite (package-propagated-inputs p))) (native-inputs (map rewrite (package-native-inputs p)))))) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 10ef3c8d0f..0cff28b45b 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +21,7 @@ #:export (%emacs emacs-batch-eval emacs-batch-edit-file + emacs-generate-autoloads emacs-substitute-sexps emacs-substitute-variables)) @@ -47,6 +49,14 @@ (format #f "--eval=~S" expr))) (error "emacs-batch-edit-file failed!" file expr))) +(define (emacs-generate-autoloads name directory) + "Generate autoloads for Emacs package NAME placed in DIRECTORY." + (let* ((file (string-append directory "/" name "-autoloads.el")) + (expr `(let ((backup-inhibited t) + (generated-autoload-file ,file)) + (update-directory-autoloads ,directory)))) + (emacs-batch-eval expr))) + (define-syntax emacs-substitute-sexps (syntax-rules () "Substitute the S-expression immediately following the first occurrence of diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index 1d87a4cf27..9351a70a0e 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:export (%standard-phases glib-or-gtk-build)) @@ -36,14 +38,14 @@ (define (directory-included? directory directories-list) "Is DIRECTORY included in DIRECTORIES-LIST?" - (fold (lambda (s p) (or (string-ci=? s directory) p)) + (fold (lambda (s p) (or (string-ci=? s directory) p)) #f directories-list)) (define (gtk-module-directories inputs) "Check for the existence of \"libdir/gtk-v.0\" in INPUTS. Return a list with all found directories." - (let* ((version - (if (string-match "gtk\\+-3" + (let* ((version + (if (string-match "gtk\\+-3" (or (assoc-ref inputs "gtk+") (assoc-ref inputs "source") "gtk+-3")) ; we default to version 3 @@ -54,7 +56,7 @@ with all found directories." (let* ((in (match input ((_ . dir) dir) (_ ""))) - (libdir + (libdir (string-append in "/lib/gtk-" version))) (if (and (directory-exists? libdir) (not (directory-included? libdir prev))) @@ -77,49 +79,68 @@ a list with all found directories." (fold glib-schemas '() inputs)) -(define* (wrap-all-programs #:key inputs outputs #:allow-other-keys) +(define* (wrap-all-programs #:key inputs outputs + (glib-or-gtk-wrap-excluded-outputs '()) + #:allow-other-keys) "Implement phase \"glib-or-gtk-wrap\": look for GSettings schemas and gtk+-v.0 libraries and create wrappers with suitably set environment variables -if found." - (let* ((out (assoc-ref outputs "out")) - (bindir (string-append out "/bin")) - (bin-list (find-files bindir ".*")) - (schemas (schemas-directories (acons "out" out inputs))) - (schemas-env-var - (if (not (null? schemas)) - `("XDG_DATA_DIRS" ":" prefix ,schemas) - #f)) - (gtk-mod-dirs (gtk-module-directories (acons "out" out inputs))) - (gtk-mod-env-var - (if (not (null? gtk-mod-dirs)) - `("GTK_PATH" ":" prefix ,gtk-mod-dirs) - #f))) - (cond - ((and schemas-env-var gtk-mod-env-var) - (map (lambda (prog) - (wrap-program prog schemas-env-var gtk-mod-env-var)) - bin-list)) - (schemas-env-var - (map (lambda (prog) (wrap-program prog schemas-env-var)) bin-list)) - (gtk-mod-env-var - (map (lambda (prog) (wrap-program prog gtk-mod-env-var)) bin-list))))) +if found. -(define* (compile-glib-schemas #:key inputs outputs #:allow-other-keys) +Wrapping is not applied to outputs whose name is listed in +GLIB-OR-GTK-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not +to contain any GLib or GTK+ binaries, and where wrapping would gratuitously +add a dependency of that output on GLib and GTK+." + (define handle-output + (match-lambda + ((output . directory) + (unless (member output glib-or-gtk-wrap-excluded-outputs) + (let* ((bindir (string-append directory "/bin")) + (bin-list (find-files bindir ".*")) + (schemas (schemas-directories + (alist-cons output directory inputs))) + (gtk-mod-dirs (gtk-module-directories + (alist-cons output directory inputs))) + (schemas-env-var + (if (not (null? schemas)) + `("XDG_DATA_DIRS" ":" prefix ,schemas) + #f)) + (gtk-mod-env-var + (if (not (null? gtk-mod-dirs)) + `("GTK_PATH" ":" prefix ,gtk-mod-dirs) + #f))) + (cond + ((and schemas-env-var gtk-mod-env-var) + (for-each (cut wrap-program <> schemas-env-var gtk-mod-env-var) + bin-list)) + (schemas-env-var + (for-each (cut wrap-program <> schemas-env-var) + bin-list)) + (gtk-mod-env-var + (for-each (cut wrap-program <> gtk-mod-env-var) + bin-list)))))))) + + (for-each handle-output outputs) + #t) + +(define* (compile-glib-schemas #:key outputs #:allow-other-keys) "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas if needed." - (let* ((out (assoc-ref outputs "out")) - (schemasdir (string-append out "/share/glib-2.0/schemas"))) - (if (and (directory-exists? schemasdir) - (not (file-exists? - (string-append schemasdir "/gschemas.compiled")))) - (system* "glib-compile-schemas" schemasdir) - #t))) + (every (match-lambda + ((output . directory) + (let ((schemasdir (string-append directory + "/share/glib-2.0/schemas"))) + (if (and (directory-exists? schemasdir) + (not (file-exists? + (string-append schemasdir "/gschemas.compiled")))) + (zero? (system* "glib-compile-schemas" schemasdir)) + #t)))) + outputs)) (define %standard-phases (alist-cons-after - 'install 'glib-or-gtk-wrap wrap-all-programs - (alist-cons-after - 'install 'glib-or-gtk-compile-schemas compile-glib-schemas + 'install 'glib-or-gtk-wrap wrap-all-programs + (alist-cons-after + 'install 'glib-or-gtk-compile-schemas compile-glib-schemas gnu:%standard-phases))) (define* (glib-or-gtk-build #:key inputs (phases %standard-phases) diff --git a/guix/derivations.scm b/guix/derivations.scm index b1ba573190..69cef1a4cd 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -37,6 +37,7 @@ derivation-inputs derivation-sources derivation-system + derivation-builder derivation-builder-arguments derivation-builder-environment-vars derivation-file-name diff --git a/guix/download.scm b/guix/download.scm index 947da004ae..4c111dd2b5 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -61,15 +61,23 @@ ,@(map (cut string-append <> "/gcc") gnu-mirrors)) (gnupg "ftp://gd.tuwien.ac.at/privacy/gnupg/" - "ftp://gnupg.x-zone.org/pub/gnupg/" - "ftp://ftp.gnupg.cz/pub/gcrypt/" - "ftp://sunsite.dk/pub/security/gcrypt/" - "http://gnupg.wildyou.net/" - "http://ftp.gnupg.zone-h.org/" - "ftp://ftp.jyu.fi/pub/crypt/gcrypt/" - "ftp://trumpetti.atm.tut.fi/gcrypt/" + "ftp://mirrors.dotsrc.org/gcrypt/" "ftp://mirror.cict.fr/gnupg/" - "ftp://ftp.strasbourg.linuxfr.org/pub/gnupg/") + "http://artfiles.org/gnupg.org" + "ftp://ftp.franken.de/pub/crypt/mirror/ftp.gnupg.org/gcrypt/" + "ftp://ftp.freenet.de/pub/ftp.gnupg.org/gcrypt/" + "http://www.crysys.hu/" + "ftp://ftp.hi.is/pub/mirrors/gnupg/" + "ftp://ftp.heanet.ie/mirrors/ftp.gnupg.org/gcrypt/" + "ftp://ftp.bit.nl/mirror/gnupg/" + "ftp://ftp.surfnet.nl/pub/security/gnupg/" + "ftp://ftp.iasi.roedu.net/pub/mirrors/ftp.gnupg.org/" + "ftp://ftp.sunet.se/pub/security/gnupg/" + "ftp://mirror.switch.ch/mirror/gnupg/" + "ftp://mirror.tje.me.uk/pub/mirrors/ftp.gnupg.org/" + "ftp://ftp.mirrorservice.org/sites/ftp.gnupg.org/gcrypt/" + "ftp://ftp.ring.gr.jp/pub/net/gnupg/" + "ftp://ftp.gnupg.org/gcrypt/") (gnome "http://ftp.belnet.be/ftp.gnome.org/" "http://ftp.linux.org.uk/mirrors/ftp.gnome.org/" diff --git a/guix/elf.scm b/guix/elf.scm new file mode 100644 index 0000000000..a4b0e819a5 --- /dev/null +++ b/guix/elf.scm @@ -0,0 +1,1045 @@ +;;; Guile ELF reader and writer + +;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This file was taken from the Guile 2.1 branch, where it is known as +;;; (system vm elf), and renamed to (guix elf). It will be unneeded when Guix +;;; switches to Guile 2.1/2.2. +;;; +;;; A module to read and write Executable and Linking Format (ELF) +;;; files. +;;; +;;; This module exports a number of record types that represent the +;;; various parts that make up ELF files. Fundamentally this is the +;;; main header, the segment headers (program headers), and the section +;;; headers. It also exports bindings for symbolic constants and +;;; utilities to parse and write special kinds of ELF sections. +;;; +;;; See elf(5) for more information on ELF. +;;; +;;; Code: + +(define-module (guix elf) + #:use-module (rnrs bytevectors) + #:use-module (system foreign) + #:use-module (system base target) + #:use-module (srfi srfi-9) + #:use-module (ice-9 receive) + #:use-module (ice-9 vlist) + #:export (has-elf-header? + + (make-elf* . make-elf) + elf? + elf-bytes elf-word-size elf-byte-order + elf-abi elf-type elf-machine-type + elf-entry elf-phoff elf-shoff elf-flags elf-ehsize + elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx + + ELFOSABI_NONE ELFOSABI_HPUX ELFOSABI_NETBSD ELFOSABI_GNU + ELFOSABI_SOLARIS ELFOSABI_AIX ELFOSABI_IRIX ELFOSABI_FREEBSD + ELFOSABI_TRU64 ELFOSABI_MODESTO ELFOSABI_OPENBSD + ELFOSABI_ARM_AEABI ELFOSABI_ARM ELFOSABI_STANDALONE + + ET_NONE ET_REL ET_EXEC ET_DYN ET_CORE + + EM_NONE EM_SPARC EM_386 EM_MIPS EM_PPC EM_PPC64 EM_ARM EM_SH + EM_SPARCV9 EM_IA_64 EM_X86_64 + + elf-header-len elf-header-shoff-offset + write-elf-header + + (make-elf-segment* . make-elf-segment) + elf-segment? + elf-segment-index + elf-segment-type elf-segment-offset elf-segment-vaddr + elf-segment-paddr elf-segment-filesz elf-segment-memsz + elf-segment-flags elf-segment-align + + elf-program-header-len write-elf-program-header + + PT_NULL PT_LOAD PT_DYNAMIC PT_INTERP PT_NOTE PT_SHLIB + PT_PHDR PT_TLS PT_NUM PT_LOOS PT_GNU_EH_FRAME PT_GNU_STACK + PT_GNU_RELRO + + PF_R PF_W PF_X + + (make-elf-section* . make-elf-section) + elf-section? + elf-section-index + elf-section-name elf-section-type elf-section-flags + elf-section-addr elf-section-offset elf-section-size + elf-section-link elf-section-info elf-section-addralign + elf-section-entsize + + elf-section-header-len elf-section-header-addr-offset + elf-section-header-offset-offset + write-elf-section-header + + (make-elf-symbol* . make-elf-symbol) + elf-symbol? + elf-symbol-name elf-symbol-value elf-symbol-size + elf-symbol-info elf-symbol-other elf-symbol-shndx + elf-symbol-binding elf-symbol-type elf-symbol-visibility + + elf-symbol-len elf-symbol-value-offset write-elf-symbol + + SHN_UNDEF + + SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA + SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB + SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY + SHT_GROUP SHT_SYMTAB_SHNDX SHT_NUM SHT_LOOS SHT_HIOS + SHT_LOPROC SHT_HIPROC SHT_LOUSER SHT_HIUSER + + SHF_WRITE SHF_ALLOC SHF_EXECINSTR SHF_MERGE SHF_STRINGS + SHF_INFO_LINK SHF_LINK_ORDER SHF_OS_NONCONFORMING SHF_GROUP + SHF_TLS + + DT_NULL DT_NEEDED DT_PLTRELSZ DT_PLTGOT DT_HASH DT_STRTAB + DT_SYMTAB DT_RELA DT_RELASZ DT_RELAENT DT_STRSZ DT_SYMENT + DT_INIT DT_FINI DT_SONAME DT_RPATH DT_SYMBOLIC DT_REL + DT_RELSZ DT_RELENT DT_PLTREL DT_DEBUG DT_TEXTREL DT_JMPREL + DT_BIND_NOW DT_INIT_ARRAY DT_FINI_ARRAY DT_INIT_ARRAYSZ + DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING + DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE + DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY + DT_GUILE_VM_VERSION DT_GUILE_FRAME_MAPS DT_HIGUILE + DT_LOOS DT_HIOS DT_LOPROC DT_HIPROC + + string-table-ref + + STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU + STB_HIOS STB_LOPROC STB_HIPROC + + STT_NOTYPE STT_OBJECT STT_FUNC STT_SECTION STT_FILE + STT_COMMON STT_TLS STT_NUM STT_LOOS STT_GNU STT_HIOS + STT_LOPROC STT_HIPROC + + STV_DEFAULT STV_INTERNAL STV_HIDDEN STV_PROTECTED + + NT_GNU_ABI_TAG NT_GNU_HWCAP NT_GNU_BUILD_ID NT_GNU_GOLD_VERSION + + parse-elf + elf-segment elf-segments + elf-section elf-sections elf-section-by-name elf-sections-by-name + elf-symbol-table-len elf-symbol-table-ref + + parse-elf-note + elf-note-name elf-note-desc elf-note-type)) + +;; #define EI_NIDENT 16 + +;; typedef struct { +;; unsigned char e_ident[EI_NIDENT]; +;; uint16_t e_type; +;; uint16_t e_machine; +;; uint32_t e_version; +;; ElfN_Addr e_entry; +;; ElfN_Off e_phoff; +;; ElfN_Off e_shoff; +;; uint32_t e_flags; +;; uint16_t e_ehsize; +;; uint16_t e_phentsize; +;; uint16_t e_phnum; +;; uint16_t e_shentsize; +;; uint16_t e_shnum; +;; uint16_t e_shstrndx; +;; } ElfN_Ehdr; + +(define elf32-header-len 52) +(define elf64-header-len 64) +(define (elf-header-len word-size) + (case word-size + ((4) elf32-header-len) + ((8) elf64-header-len) + (else (error "invalid word size" word-size)))) +(define (elf-header-shoff-offset word-size) + (case word-size + ((4) 32) + ((8) 40) + (else (error "bad word size" word-size)))) + +(define ELFCLASS32 1) ; 32-bit objects +(define ELFCLASS64 2) ; 64-bit objects + +(define ELFDATA2LSB 1) ; 2's complement, little endian +(define ELFDATA2MSB 2) ; 2's complement, big endian + +(define EV_CURRENT 1) ; Current version + +(define ELFOSABI_NONE 0) ; UNIX System V ABI */ +(define ELFOSABI_HPUX 1) ; HP-UX +(define ELFOSABI_NETBSD 2) ; NetBSD. +(define ELFOSABI_GNU 3) ; Object uses GNU ELF extensions. +(define ELFOSABI_SOLARIS 6) ; Sun Solaris. +(define ELFOSABI_AIX 7) ; IBM AIX. +(define ELFOSABI_IRIX 8) ; SGI Irix. +(define ELFOSABI_FREEBSD 9) ; FreeBSD. +(define ELFOSABI_TRU64 10) ; Compaq TRU64 UNIX. +(define ELFOSABI_MODESTO 11) ; Novell Modesto. +(define ELFOSABI_OPENBSD 12) ; OpenBSD. +(define ELFOSABI_ARM_AEABI 64) ; ARM EABI +(define ELFOSABI_ARM 97) ; ARM +(define ELFOSABI_STANDALONE 255) ; Standalone (embedded) application + +(define ET_NONE 0) ; No file type +(define ET_REL 1) ; Relocatable file +(define ET_EXEC 2) ; Executable file +(define ET_DYN 3) ; Shared object file +(define ET_CORE 4) ; Core file + +;; +;; Machine types +;; +;; Just a sampling of these values. We could include more, but the +;; important thing is to recognize architectures for which we have a +;; native compiler. Recognizing more common machine types is icing on +;; the cake. +;; +(define EM_NONE 0) ; No machine +(define EM_SPARC 2) ; SUN SPARC +(define EM_386 3) ; Intel 80386 +(define EM_MIPS 8) ; MIPS R3000 big-endian +(define EM_PPC 20) ; PowerPC +(define EM_PPC64 21) ; PowerPC 64-bit +(define EM_ARM 40) ; ARM +(define EM_SH 42) ; Hitachi SH +(define EM_SPARCV9 43) ; SPARC v9 64-bit +(define EM_IA_64 50) ; Intel Merced +(define EM_X86_64 62) ; AMD x86-64 architecture + +(define cpu-mapping (make-hash-table)) +(for-each (lambda (pair) + (hashq-set! cpu-mapping (car pair) (cdr pair))) + `((none . ,EM_NONE) + (sparc . ,EM_SPARC) ; FIXME: map 64-bit to SPARCV9 ? + (i386 . ,EM_386) + (mips . ,EM_MIPS) + (ppc . ,EM_PPC) + (ppc64 . ,EM_PPC64) + (arm . ,EM_ARM) ; FIXME: there are more arm cpu variants + (sh . ,EM_SH) ; FIXME: there are more sh cpu variants + (ia64 . ,EM_IA_64) + (x86_64 . ,EM_X86_64))) + +(define SHN_UNDEF 0) + +(define host-machine-type + (hashq-ref cpu-mapping + (string->symbol (car (string-split %host-type #\-))) + EM_NONE)) + +(define host-word-size + (sizeof '*)) + +(define host-byte-order + (native-endianness)) + +(define (has-elf-header? bv) + (and + ;; e_ident + (>= (bytevector-length bv) 16) + (= (bytevector-u8-ref bv 0) #x7f) + (= (bytevector-u8-ref bv 1) (char->integer #\E)) + (= (bytevector-u8-ref bv 2) (char->integer #\L)) + (= (bytevector-u8-ref bv 3) (char->integer #\F)) + (cond + ((= (bytevector-u8-ref bv 4) ELFCLASS32) + (>= (bytevector-length bv) elf32-header-len)) + ((= (bytevector-u8-ref bv 4) ELFCLASS64) + (>= (bytevector-length bv) elf64-header-len)) + (else #f)) + (or (= (bytevector-u8-ref bv 5) ELFDATA2LSB) + (= (bytevector-u8-ref bv 5) ELFDATA2MSB)) + (= (bytevector-u8-ref bv 6) EV_CURRENT) + ;; Look at ABI later. + (= (bytevector-u8-ref bv 8) 0) ; ABI version + ;; The rest of the e_ident is padding. + + ;; e_version + (let ((byte-order (if (= (bytevector-u8-ref bv 5) ELFDATA2LSB) + (endianness little) + (endianness big)))) + (= (bytevector-u32-ref bv 20 byte-order) EV_CURRENT)))) + +(define-record-type <elf> + (make-elf bytes word-size byte-order abi type machine-type + entry phoff shoff flags ehsize + phentsize phnum shentsize shnum shstrndx) + elf? + (bytes elf-bytes) + (word-size elf-word-size) + (byte-order elf-byte-order) + (abi elf-abi) + (type elf-type) + (machine-type elf-machine-type) + (entry elf-entry) + (phoff elf-phoff) + (shoff elf-shoff) + (flags elf-flags) + (ehsize elf-ehsize) + (phentsize elf-phentsize) + (phnum elf-phnum) + (shentsize elf-shentsize) + (shnum elf-shnum) + (shstrndx elf-shstrndx)) + +(define* (make-elf* #:key (bytes #f) + (byte-order (target-endianness)) + (word-size (target-word-size)) + (abi ELFOSABI_STANDALONE) + (type ET_DYN) + (machine-type EM_NONE) + (entry 0) + (phoff (elf-header-len word-size)) + (shoff -1) + (flags 0) + (ehsize (elf-header-len word-size)) + (phentsize (elf-program-header-len word-size)) + (phnum 0) + (shentsize (elf-section-header-len word-size)) + (shnum 0) + (shstrndx SHN_UNDEF)) + (make-elf bytes word-size byte-order abi type machine-type + entry phoff shoff flags ehsize + phentsize phnum shentsize shnum shstrndx)) + +(define (parse-elf32 bv byte-order) + (make-elf bv 4 byte-order + (bytevector-u8-ref bv 7) + (bytevector-u16-ref bv 16 byte-order) + (bytevector-u16-ref bv 18 byte-order) + (bytevector-u32-ref bv 24 byte-order) + (bytevector-u32-ref bv 28 byte-order) + (bytevector-u32-ref bv 32 byte-order) + (bytevector-u32-ref bv 36 byte-order) + (bytevector-u16-ref bv 40 byte-order) + (bytevector-u16-ref bv 42 byte-order) + (bytevector-u16-ref bv 44 byte-order) + (bytevector-u16-ref bv 46 byte-order) + (bytevector-u16-ref bv 48 byte-order) + (bytevector-u16-ref bv 50 byte-order))) + +(define (write-elf-ident bv class data abi) + (bytevector-u8-set! bv 0 #x7f) + (bytevector-u8-set! bv 1 (char->integer #\E)) + (bytevector-u8-set! bv 2 (char->integer #\L)) + (bytevector-u8-set! bv 3 (char->integer #\F)) + (bytevector-u8-set! bv 4 class) + (bytevector-u8-set! bv 5 data) + (bytevector-u8-set! bv 6 EV_CURRENT) + (bytevector-u8-set! bv 7 abi) + (bytevector-u8-set! bv 8 0) ; ABI version + (bytevector-u8-set! bv 9 0) ; Pad to 16 bytes. + (bytevector-u8-set! bv 10 0) + (bytevector-u8-set! bv 11 0) + (bytevector-u8-set! bv 12 0) + (bytevector-u8-set! bv 13 0) + (bytevector-u8-set! bv 14 0) + (bytevector-u8-set! bv 15 0)) + +(define (write-elf32-header bv elf) + (let ((byte-order (elf-byte-order elf))) + (write-elf-ident bv ELFCLASS32 + (case byte-order + ((little) ELFDATA2LSB) + ((big) ELFDATA2MSB) + (else (error "unknown endianness" byte-order))) + (elf-abi elf)) + (bytevector-u16-set! bv 16 (elf-type elf) byte-order) + (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order) + (bytevector-u32-set! bv 20 EV_CURRENT byte-order) + (bytevector-u32-set! bv 24 (elf-entry elf) byte-order) + (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order) + (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order) + (bytevector-u32-set! bv 36 (elf-flags elf) byte-order) + (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order) + (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order) + (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order) + (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order) + (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order) + (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order))) + +(define (parse-elf64 bv byte-order) + (make-elf bv 8 byte-order + (bytevector-u8-ref bv 7) + (bytevector-u16-ref bv 16 byte-order) + (bytevector-u16-ref bv 18 byte-order) + (bytevector-u64-ref bv 24 byte-order) + (bytevector-u64-ref bv 32 byte-order) + (bytevector-u64-ref bv 40 byte-order) + (bytevector-u32-ref bv 48 byte-order) + (bytevector-u16-ref bv 52 byte-order) + (bytevector-u16-ref bv 54 byte-order) + (bytevector-u16-ref bv 56 byte-order) + (bytevector-u16-ref bv 58 byte-order) + (bytevector-u16-ref bv 60 byte-order) + (bytevector-u16-ref bv 62 byte-order))) + +(define (write-elf64-header bv elf) + (let ((byte-order (elf-byte-order elf))) + (write-elf-ident bv ELFCLASS64 + (case byte-order + ((little) ELFDATA2LSB) + ((big) ELFDATA2MSB) + (else (error "unknown endianness" byte-order))) + (elf-abi elf)) + (bytevector-u16-set! bv 16 (elf-type elf) byte-order) + (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order) + (bytevector-u32-set! bv 20 EV_CURRENT byte-order) + (bytevector-u64-set! bv 24 (elf-entry elf) byte-order) + (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order) + (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order) + (bytevector-u32-set! bv 48 (elf-flags elf) byte-order) + (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order) + (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order) + (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order) + (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order) + (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order) + (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order))) + +(define (parse-elf bv) + (cond + ((has-elf-header? bv) + (let ((class (bytevector-u8-ref bv 4)) + (byte-order (let ((data (bytevector-u8-ref bv 5))) + (cond + ((= data ELFDATA2LSB) (endianness little)) + ((= data ELFDATA2MSB) (endianness big)) + (else (error "unhandled byte order" data)))))) + (cond + ((= class ELFCLASS32) (parse-elf32 bv byte-order)) + ((= class ELFCLASS64) (parse-elf64 bv byte-order)) + (else (error "unhandled class" class))))) + (else + (error "Invalid ELF" bv)))) + +(define* (write-elf-header bv elf) + ((case (elf-word-size elf) + ((4) write-elf32-header) + ((8) write-elf64-header) + (else (error "unknown word size" (elf-word-size elf)))) + bv elf)) + +;; +;; Segment types +;; +(define PT_NULL 0) ; Program header table entry unused +(define PT_LOAD 1) ; Loadable program segment +(define PT_DYNAMIC 2) ; Dynamic linking information +(define PT_INTERP 3) ; Program interpreter +(define PT_NOTE 4) ; Auxiliary information +(define PT_SHLIB 5) ; Reserved +(define PT_PHDR 6) ; Entry for header table itself +(define PT_TLS 7) ; Thread-local storage segment +(define PT_NUM 8) ; Number of defined types +(define PT_LOOS #x60000000) ; Start of OS-specific +(define PT_GNU_EH_FRAME #x6474e550) ; GCC .eh_frame_hdr segment +(define PT_GNU_STACK #x6474e551) ; Indicates stack executability +(define PT_GNU_RELRO #x6474e552) ; Read-only after relocation + +;; +;; Segment flags +;; +(define PF_X (ash 1 0)) ; Segment is executable +(define PF_W (ash 1 1)) ; Segment is writable +(define PF_R (ash 1 2)) ; Segment is readable + +(define-record-type <elf-segment> + (make-elf-segment index type offset vaddr paddr filesz memsz flags align) + elf-segment? + (index elf-segment-index) + (type elf-segment-type) + (offset elf-segment-offset) + (vaddr elf-segment-vaddr) + (paddr elf-segment-paddr) + (filesz elf-segment-filesz) + (memsz elf-segment-memsz) + (flags elf-segment-flags) + (align elf-segment-align)) + +(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr 0) + (paddr 0) (filesz 0) (memsz filesz) + (flags (logior PF_W PF_R)) + (align 8)) + (make-elf-segment index type offset vaddr paddr filesz memsz flags align)) + +;; typedef struct { +;; uint32_t p_type; +;; Elf32_Off p_offset; +;; Elf32_Addr p_vaddr; +;; Elf32_Addr p_paddr; +;; uint32_t p_filesz; +;; uint32_t p_memsz; +;; uint32_t p_flags; +;; uint32_t p_align; +;; } Elf32_Phdr; + +(define (parse-elf32-program-header index bv offset byte-order) + (if (<= (+ offset 32) (bytevector-length bv)) + (make-elf-segment index + (bytevector-u32-ref bv offset byte-order) + (bytevector-u32-ref bv (+ offset 4) byte-order) + (bytevector-u32-ref bv (+ offset 8) byte-order) + (bytevector-u32-ref bv (+ offset 12) byte-order) + (bytevector-u32-ref bv (+ offset 16) byte-order) + (bytevector-u32-ref bv (+ offset 20) byte-order) + (bytevector-u32-ref bv (+ offset 24) byte-order) + (bytevector-u32-ref bv (+ offset 28) byte-order)) + (error "corrupt ELF (offset out of range)" offset))) + +(define (write-elf32-program-header bv offset byte-order seg) + (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order) + (bytevector-u32-set! bv (+ offset 4) (elf-segment-offset seg) byte-order) + (bytevector-u32-set! bv (+ offset 8) (elf-segment-vaddr seg) byte-order) + (bytevector-u32-set! bv (+ offset 12) (elf-segment-paddr seg) byte-order) + (bytevector-u32-set! bv (+ offset 16) (elf-segment-filesz seg) byte-order) + (bytevector-u32-set! bv (+ offset 20) (elf-segment-memsz seg) byte-order) + (bytevector-u32-set! bv (+ offset 24) (elf-segment-flags seg) byte-order) + (bytevector-u32-set! bv (+ offset 28) (elf-segment-align seg) byte-order)) + + +;; typedef struct { +;; uint32_t p_type; +;; uint32_t p_flags; +;; Elf64_Off p_offset; +;; Elf64_Addr p_vaddr; +;; Elf64_Addr p_paddr; +;; uint64_t p_filesz; +;; uint64_t p_memsz; +;; uint64_t p_align; +;; } Elf64_Phdr; + +;; NB: position of `flags' is different! + +(define (parse-elf64-program-header index bv offset byte-order) + (if (<= (+ offset 56) (bytevector-length bv)) + (make-elf-segment index + (bytevector-u32-ref bv offset byte-order) + (bytevector-u64-ref bv (+ offset 8) byte-order) + (bytevector-u64-ref bv (+ offset 16) byte-order) + (bytevector-u64-ref bv (+ offset 24) byte-order) + (bytevector-u64-ref bv (+ offset 32) byte-order) + (bytevector-u64-ref bv (+ offset 40) byte-order) + (bytevector-u32-ref bv (+ offset 4) byte-order) + (bytevector-u64-ref bv (+ offset 48) byte-order)) + (error "corrupt ELF (offset out of range)" offset))) + +(define (write-elf64-program-header bv offset byte-order seg) + (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order) + (bytevector-u64-set! bv (+ offset 8) (elf-segment-offset seg) byte-order) + (bytevector-u64-set! bv (+ offset 16) (elf-segment-vaddr seg) byte-order) + (bytevector-u64-set! bv (+ offset 24) (elf-segment-paddr seg) byte-order) + (bytevector-u64-set! bv (+ offset 32) (elf-segment-filesz seg) byte-order) + (bytevector-u64-set! bv (+ offset 40) (elf-segment-memsz seg) byte-order) + (bytevector-u32-set! bv (+ offset 4) (elf-segment-flags seg) byte-order) + (bytevector-u64-set! bv (+ offset 48) (elf-segment-align seg) byte-order)) + +(define (write-elf-program-header bv offset byte-order word-size seg) + ((case word-size + ((4) write-elf32-program-header) + ((8) write-elf64-program-header) + (else (error "invalid word size" word-size))) + bv offset byte-order seg)) + +(define (elf-program-header-len word-size) + (case word-size + ((4) 32) + ((8) 56) + (else (error "bad word size" word-size)))) + +(define (elf-segment elf n) + (if (not (< -1 n (elf-phnum elf))) + (error "bad segment number" n)) + ((case (elf-word-size elf) + ((4) parse-elf32-program-header) + ((8) parse-elf64-program-header) + (else (error "unhandled pointer size"))) + (elf-bytes elf) + (+ (elf-phoff elf) (* n (elf-phentsize elf))) + (elf-byte-order elf))) + +(define (elf-segments elf) + (let lp ((n (elf-phnum elf)) (out '())) + (if (zero? n) + out + (lp (1- n) (cons (elf-segment elf (1- n)) out))))) + +(define-record-type <elf-section> + (make-elf-section index name type flags + addr offset size link info addralign entsize) + elf-section? + (index elf-section-index) + (name elf-section-name) + (type elf-section-type) + (flags elf-section-flags) + (addr elf-section-addr) + (offset elf-section-offset) + (size elf-section-size) + (link elf-section-link) + (info elf-section-info) + (addralign elf-section-addralign) + (entsize elf-section-entsize)) + +(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type SHT_PROGBITS) + (flags SHF_ALLOC) (addr 0) (offset 0) (size 0) + (link 0) (info 0) (addralign 8) (entsize 0)) + (make-elf-section index name type flags addr offset size link info addralign + entsize)) + +;; typedef struct { +;; uint32_t sh_name; +;; uint32_t sh_type; +;; uint32_t sh_flags; +;; Elf32_Addr sh_addr; +;; Elf32_Off sh_offset; +;; uint32_t sh_size; +;; uint32_t sh_link; +;; uint32_t sh_info; +;; uint32_t sh_addralign; +;; uint32_t sh_entsize; +;; } Elf32_Shdr; + +(define (parse-elf32-section-header index bv offset byte-order) + (if (<= (+ offset 40) (bytevector-length bv)) + (make-elf-section index + (bytevector-u32-ref bv offset byte-order) + (bytevector-u32-ref bv (+ offset 4) byte-order) + (bytevector-u32-ref bv (+ offset 8) byte-order) + (bytevector-u32-ref bv (+ offset 12) byte-order) + (bytevector-u32-ref bv (+ offset 16) byte-order) + (bytevector-u32-ref bv (+ offset 20) byte-order) + (bytevector-u32-ref bv (+ offset 24) byte-order) + (bytevector-u32-ref bv (+ offset 28) byte-order) + (bytevector-u32-ref bv (+ offset 32) byte-order) + (bytevector-u32-ref bv (+ offset 36) byte-order)) + (error "corrupt ELF (offset out of range)" offset))) + +(define (write-elf32-section-header bv offset byte-order sec) + (bytevector-u32-set! bv offset (elf-section-name sec) byte-order) + (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order) + (bytevector-u32-set! bv (+ offset 8) (elf-section-flags sec) byte-order) + (bytevector-u32-set! bv (+ offset 12) (elf-section-addr sec) byte-order) + (bytevector-u32-set! bv (+ offset 16) (elf-section-offset sec) byte-order) + (bytevector-u32-set! bv (+ offset 20) (elf-section-size sec) byte-order) + (bytevector-u32-set! bv (+ offset 24) (elf-section-link sec) byte-order) + (bytevector-u32-set! bv (+ offset 28) (elf-section-info sec) byte-order) + (bytevector-u32-set! bv (+ offset 32) (elf-section-addralign sec) byte-order) + (bytevector-u32-set! bv (+ offset 36) (elf-section-entsize sec) byte-order)) + + +;; typedef struct { +;; uint32_t sh_name; +;; uint32_t sh_type; +;; uint64_t sh_flags; +;; Elf64_Addr sh_addr; +;; Elf64_Off sh_offset; +;; uint64_t sh_size; +;; uint32_t sh_link; +;; uint32_t sh_info; +;; uint64_t sh_addralign; +;; uint64_t sh_entsize; +;; } Elf64_Shdr; + +(define (elf-section-header-len word-size) + (case word-size + ((4) 40) + ((8) 64) + (else (error "bad word size" word-size)))) + +(define (elf-section-header-addr-offset word-size) + (case word-size + ((4) 12) + ((8) 16) + (else (error "bad word size" word-size)))) + +(define (elf-section-header-offset-offset word-size) + (case word-size + ((4) 16) + ((8) 24) + (else (error "bad word size" word-size)))) + +(define (parse-elf64-section-header index bv offset byte-order) + (if (<= (+ offset 64) (bytevector-length bv)) + (make-elf-section index + (bytevector-u32-ref bv offset byte-order) + (bytevector-u32-ref bv (+ offset 4) byte-order) + (bytevector-u64-ref bv (+ offset 8) byte-order) + (bytevector-u64-ref bv (+ offset 16) byte-order) + (bytevector-u64-ref bv (+ offset 24) byte-order) + (bytevector-u64-ref bv (+ offset 32) byte-order) + (bytevector-u32-ref bv (+ offset 40) byte-order) + (bytevector-u32-ref bv (+ offset 44) byte-order) + (bytevector-u64-ref bv (+ offset 48) byte-order) + (bytevector-u64-ref bv (+ offset 56) byte-order)) + (error "corrupt ELF (offset out of range)" offset))) + +(define (write-elf64-section-header bv offset byte-order sec) + (bytevector-u32-set! bv offset (elf-section-name sec) byte-order) + (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order) + (bytevector-u64-set! bv (+ offset 8) (elf-section-flags sec) byte-order) + (bytevector-u64-set! bv (+ offset 16) (elf-section-addr sec) byte-order) + (bytevector-u64-set! bv (+ offset 24) (elf-section-offset sec) byte-order) + (bytevector-u64-set! bv (+ offset 32) (elf-section-size sec) byte-order) + (bytevector-u32-set! bv (+ offset 40) (elf-section-link sec) byte-order) + (bytevector-u32-set! bv (+ offset 44) (elf-section-info sec) byte-order) + (bytevector-u64-set! bv (+ offset 48) (elf-section-addralign sec) byte-order) + (bytevector-u64-set! bv (+ offset 56) (elf-section-entsize sec) byte-order)) + +(define (elf-section elf n) + (if (not (< -1 n (elf-shnum elf))) + (error "bad section number" n)) + ((case (elf-word-size elf) + ((4) parse-elf32-section-header) + ((8) parse-elf64-section-header) + (else (error "unhandled pointer size"))) + n + (elf-bytes elf) + (+ (elf-shoff elf) (* n (elf-shentsize elf))) + (elf-byte-order elf))) + +(define (write-elf-section-header bv offset byte-order word-size sec) + ((case word-size + ((4) write-elf32-section-header) + ((8) write-elf64-section-header) + (else (error "invalid word size" word-size))) + bv offset byte-order sec)) + +(define (elf-sections elf) + (let lp ((n (elf-shnum elf)) (out '())) + (if (zero? n) + out + (lp (1- n) (cons (elf-section elf (1- n)) out))))) + +;; +;; Section Types +;; +(define SHT_NULL 0) ; Section header table entry unused +(define SHT_PROGBITS 1) ; Program data +(define SHT_SYMTAB 2) ; Symbol table +(define SHT_STRTAB 3) ; String table +(define SHT_RELA 4) ; Relocation entries with addends +(define SHT_HASH 5) ; Symbol hash table +(define SHT_DYNAMIC 6) ; Dynamic linking information +(define SHT_NOTE 7) ; Notes +(define SHT_NOBITS 8) ; Program space with no data (bss) +(define SHT_REL 9) ; Relocation entries, no addends +(define SHT_SHLIB 10) ; Reserved +(define SHT_DYNSYM 11) ; Dynamic linker symbol table +(define SHT_INIT_ARRAY 14) ; Array of constructors +(define SHT_FINI_ARRAY 15) ; Array of destructors +(define SHT_PREINIT_ARRAY 16) ; Array of pre-constructors +(define SHT_GROUP 17) ; Section group +(define SHT_SYMTAB_SHNDX 18) ; Extended section indeces +(define SHT_NUM 19) ; Number of defined types. +(define SHT_LOOS #x60000000) ; Start OS-specific. +(define SHT_HIOS #x6fffffff) ; End OS-specific type +(define SHT_LOPROC #x70000000) ; Start of processor-specific +(define SHT_HIPROC #x7fffffff) ; End of processor-specific +(define SHT_LOUSER #x80000000) ; Start of application-specific +(define SHT_HIUSER #x8fffffff) ; End of application-specific + +;; +;; Section Flags +;; +(define SHF_WRITE (ash 1 0)) ; Writable +(define SHF_ALLOC (ash 1 1)) ; Occupies memory during execution +(define SHF_EXECINSTR (ash 1 2)) ; Executable +(define SHF_MERGE (ash 1 4)) ; Might be merged +(define SHF_STRINGS (ash 1 5)) ; Contains nul-terminated strings +(define SHF_INFO_LINK (ash 1 6)) ; `sh_info' contains SHT index +(define SHF_LINK_ORDER (ash 1 7)) ; Preserve order after combining +(define SHF_OS_NONCONFORMING (ash 1 8)) ; Non-standard OS specific handling required +(define SHF_GROUP (ash 1 9)) ; Section is member of a group. +(define SHF_TLS (ash 1 10)) ; Section hold thread-local data. + +;; +;; Dynamic entry types. The DT_GUILE types are non-standard. +;; +(define DT_NULL 0) ; Marks end of dynamic section +(define DT_NEEDED 1) ; Name of needed library +(define DT_PLTRELSZ 2) ; Size in bytes of PLT relocs +(define DT_PLTGOT 3) ; Processor defined value +(define DT_HASH 4) ; Address of symbol hash table +(define DT_STRTAB 5) ; Address of string table +(define DT_SYMTAB 6) ; Address of symbol table +(define DT_RELA 7) ; Address of Rela relocs +(define DT_RELASZ 8) ; Total size of Rela relocs +(define DT_RELAENT 9) ; Size of one Rela reloc +(define DT_STRSZ 10) ; Size of string table +(define DT_SYMENT 11) ; Size of one symbol table entry +(define DT_INIT 12) ; Address of init function +(define DT_FINI 13) ; Address of termination function +(define DT_SONAME 14) ; Name of shared object +(define DT_RPATH 15) ; Library search path (deprecated) +(define DT_SYMBOLIC 16) ; Start symbol search here +(define DT_REL 17) ; Address of Rel relocs +(define DT_RELSZ 18) ; Total size of Rel relocs +(define DT_RELENT 19) ; Size of one Rel reloc +(define DT_PLTREL 20) ; Type of reloc in PLT +(define DT_DEBUG 21) ; For debugging ; unspecified +(define DT_TEXTREL 22) ; Reloc might modify .text +(define DT_JMPREL 23) ; Address of PLT relocs +(define DT_BIND_NOW 24) ; Process relocations of object +(define DT_INIT_ARRAY 25) ; Array with addresses of init fct +(define DT_FINI_ARRAY 26) ; Array with addresses of fini fct +(define DT_INIT_ARRAYSZ 27) ; Size in bytes of DT_INIT_ARRAY +(define DT_FINI_ARRAYSZ 28) ; Size in bytes of DT_FINI_ARRAY +(define DT_RUNPATH 29) ; Library search path +(define DT_FLAGS 30) ; Flags for the object being loaded +(define DT_ENCODING 32) ; Start of encoded range +(define DT_PREINIT_ARRAY 32) ; Array with addresses of preinit fc +(define DT_PREINIT_ARRAYSZ 33) ; size in bytes of DT_PREINIT_ARRAY +(define DT_NUM 34) ; Number used +(define DT_LOGUILE #x37146000) ; Start of Guile-specific +(define DT_GUILE_GC_ROOT #x37146000) ; Offset of GC roots +(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots +(define DT_GUILE_ENTRY #x37146002) ; Address of entry thunk +(define DT_GUILE_VM_VERSION #x37146003) ; Bytecode version +(define DT_GUILE_FRAME_MAPS #x37146004) ; Offset of .guile.frame-maps +(define DT_HIGUILE #x37146fff) ; End of Guile-specific +(define DT_LOOS #x6000000d) ; Start of OS-specific +(define DT_HIOS #x6ffff000) ; End of OS-specific +(define DT_LOPROC #x70000000) ; Start of processor-specific +(define DT_HIPROC #x7fffffff) ; End of processor-specific + + +(define (string-table-ref bv offset) + (let lp ((end offset)) + (if (zero? (bytevector-u8-ref bv end)) + (let ((out (make-bytevector (- end offset)))) + (bytevector-copy! bv offset out 0 (- end offset)) + (utf8->string out)) + (lp (1+ end))))) + +(define (elf-section-by-name elf name) + (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf))))) + (let lp ((n (elf-shnum elf))) + (and (> n 0) + (let ((section (elf-section elf (1- n)))) + (if (equal? (string-table-ref (elf-bytes elf) + (+ off (elf-section-name section))) + name) + section + (lp (1- n)))))))) + +(define (elf-sections-by-name elf) + (let* ((sections (elf-sections elf)) + (off (elf-section-offset (list-ref sections (elf-shstrndx elf))))) + (map (lambda (section) + (cons (string-table-ref (elf-bytes elf) + (+ off (elf-section-name section))) + section)) + sections))) + +(define-record-type <elf-symbol> + (make-elf-symbol name value size info other shndx) + elf-symbol? + (name elf-symbol-name) + (value elf-symbol-value) + (size elf-symbol-size) + (info elf-symbol-info) + (other elf-symbol-other) + (shndx elf-symbol-shndx)) + +(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0) + (binding STB_LOCAL) (type STT_NOTYPE) + (info (logior (ash binding 4) type)) + (visibility STV_DEFAULT) (other visibility) + (shndx SHN_UNDEF)) + (make-elf-symbol name value size info other shndx)) + +;; typedef struct { +;; uint32_t st_name; +;; Elf32_Addr st_value; +;; uint32_t st_size; +;; unsigned char st_info; +;; unsigned char st_other; +;; uint16_t st_shndx; +;; } Elf32_Sym; + +(define (elf-symbol-len word-size) + (case word-size + ((4) 16) + ((8) 24) + (else (error "bad word size" word-size)))) + +(define (elf-symbol-value-offset word-size) + (case word-size + ((4) 4) + ((8) 8) + (else (error "bad word size" word-size)))) + +(define (parse-elf32-symbol bv offset stroff byte-order) + (if (<= (+ offset 16) (bytevector-length bv)) + (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order))) + (if stroff + (string-table-ref bv (+ stroff name)) + name)) + (bytevector-u32-ref bv (+ offset 4) byte-order) + (bytevector-u32-ref bv (+ offset 8) byte-order) + (bytevector-u8-ref bv (+ offset 12)) + (bytevector-u8-ref bv (+ offset 13)) + (bytevector-u16-ref bv (+ offset 14) byte-order)) + (error "corrupt ELF (offset out of range)" offset))) + +(define (write-elf32-symbol bv offset byte-order sym) + (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order) + (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order) + (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order) + (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym)) + (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym)) + (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order)) + +;; typedef struct { +;; uint32_t st_name; +;; unsigned char st_info; +;; unsigned char st_other; +;; uint16_t st_shndx; +;; Elf64_Addr st_value; +;; uint64_t st_size; +;; } Elf64_Sym; + +(define (parse-elf64-symbol bv offset stroff byte-order) + (if (<= (+ offset 24) (bytevector-length bv)) + (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order))) + (if stroff + (string-table-ref bv (+ stroff name)) + name)) + (bytevector-u64-ref bv (+ offset 8) byte-order) + (bytevector-u64-ref bv (+ offset 16) byte-order) + (bytevector-u8-ref bv (+ offset 4)) + (bytevector-u8-ref bv (+ offset 5)) + (bytevector-u16-ref bv (+ offset 6) byte-order)) + (error "corrupt ELF (offset out of range)" offset))) + +(define (write-elf64-symbol bv offset byte-order sym) + (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order) + (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym)) + (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym)) + (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order) + (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order) + (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order)) + +(define (write-elf-symbol bv offset byte-order word-size sym) + ((case word-size + ((4) write-elf32-symbol) + ((8) write-elf64-symbol) + (else (error "invalid word size" word-size))) + bv offset byte-order sym)) + +(define (elf-symbol-table-len section) + (let ((len (elf-section-size section)) + (entsize (elf-section-entsize section))) + (unless (and (not (zero? entsize)) (zero? (modulo len entsize))) + (error "bad symbol table" section)) + (/ len entsize))) + +(define* (elf-symbol-table-ref elf section n #:optional strtab) + (let ((bv (elf-bytes elf)) + (byte-order (elf-byte-order elf)) + (stroff (and strtab (elf-section-offset strtab))) + (base (elf-section-offset section)) + (len (elf-section-size section)) + (entsize (elf-section-entsize section))) + (unless (<= (* (1+ n) entsize) len) + (error "out of range symbol table access" section n)) + (case (elf-word-size elf) + ((4) + (unless (<= 16 entsize) + (error "bad entsize for symbol table" section)) + (parse-elf32-symbol bv (+ base (* n entsize)) stroff byte-order)) + ((8) + (unless (<= 24 entsize) + (error "bad entsize for symbol table" section)) + (parse-elf64-symbol bv (+ base (* n entsize)) stroff byte-order)) + (else (error "bad word size" elf))))) + +;; Legal values for ST_BIND subfield of st_info (symbol binding). + +(define STB_LOCAL 0) ; Local symbol +(define STB_GLOBAL 1) ; Global symbol +(define STB_WEAK 2) ; Weak symbol +(define STB_NUM 3) ; Number of defined types. +(define STB_LOOS 10) ; Start of OS-specific +(define STB_GNU_UNIQUE 10) ; Unique symbol. +(define STB_HIOS 12) ; End of OS-specific +(define STB_LOPROC 13) ; Start of processor-specific +(define STB_HIPROC 15) ; End of processor-specific + +;; Legal values for ST_TYPE subfield of st_info (symbol type). + +(define STT_NOTYPE 0) ; Symbol type is unspecified +(define STT_OBJECT 1) ; Symbol is a data object +(define STT_FUNC 2) ; Symbol is a code object +(define STT_SECTION 3) ; Symbol associated with a section +(define STT_FILE 4) ; Symbol's name is file name +(define STT_COMMON 5) ; Symbol is a common data object +(define STT_TLS 6) ; Symbol is thread-local data objec +(define STT_NUM 7) ; Number of defined types. +(define STT_LOOS 10) ; Start of OS-specific +(define STT_GNU_IFUNC 10) ; Symbol is indirect code object +(define STT_HIOS 12) ; End of OS-specific +(define STT_LOPROC 13) ; Start of processor-specific +(define STT_HIPROC 15) ; End of processor-specific + +;; Symbol visibility specification encoded in the st_other field. + +(define STV_DEFAULT 0) ; Default symbol visibility rules +(define STV_INTERNAL 1) ; Processor specific hidden class +(define STV_HIDDEN 2) ; Sym unavailable in other modules +(define STV_PROTECTED 3) ; Not preemptible, not exported + +(define (elf-symbol-binding sym) + (ash (elf-symbol-info sym) -4)) + +(define (elf-symbol-type sym) + (logand (elf-symbol-info sym) #xf)) + +(define (elf-symbol-visibility sym) + (logand (elf-symbol-other sym) #x3)) + +(define NT_GNU_ABI_TAG 1) +(define NT_GNU_HWCAP 2) +(define NT_GNU_BUILD_ID 3) +(define NT_GNU_GOLD_VERSION 4) + +(define-record-type <elf-note> + (make-elf-note name desc type) + elf-note? + (name elf-note-name) + (desc elf-note-desc) + (type elf-note-type)) + +(define (parse-elf-note elf section) + (let ((bv (elf-bytes elf)) + (byte-order (elf-byte-order elf)) + (offset (elf-section-offset section))) + (unless (<= (+ offset 12) (bytevector-length bv)) + (error "corrupt ELF (offset out of range)" offset)) + (let ((namesz (bytevector-u32-ref bv offset byte-order)) + (descsz (bytevector-u32-ref bv (+ offset 4) byte-order)) + (type (bytevector-u32-ref bv (+ offset 8) byte-order))) + (unless (<= (+ offset 12 namesz descsz) (bytevector-length bv)) + (error "corrupt ELF (offset out of range)" offset)) + (let ((name (make-bytevector (1- namesz))) + (desc (make-bytevector descsz))) + (bytevector-copy! bv (+ offset 12) name 0 (1- namesz)) + (bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz) + (make-elf-note (utf8->string name) desc type))))) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index ee84446549..0528e9f253 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -233,12 +233,14 @@ stored." (values "ftp.gnu.org" (string-append "/gnu/" project))))) (define (sans-extension tarball) - "Return TARBALL without its .tar.* extension." - (let ((end (string-contains tarball ".tar"))) + "Return TARBALL without its .tar.* or .zip extension." + (let ((end (or (string-contains tarball ".tar") + (string-contains tarball ".zip")))) (substring tarball 0 end))) (define %tarball-rx - (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\.")) + ;; Note: .zip files are notably used for freefont-ttf. + (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.(tar\\.|zip$)")) (define %alpha-tarball-rx (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 763b8d2a12..1947f489fb 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -84,7 +84,7 @@ ,(string-append ".tar." archive-type))) (sha256 (base32 - ,(bytevector->base32-string (file-sha256 tarball)))))) + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) (build-system gnu-build-system) (synopsis ,(gnu-package-doc-summary package)) (description ,(gnu-package-doc-description package)) diff --git a/guix/licenses.scm b/guix/licenses.scm index 3a21f4f5cf..86f3ae4e82 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -40,7 +40,8 @@ ibmpl1.0 imlib2 lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ - mpl2.0 + mpl1.1 mpl2.0 + ncsa openldap2.8 openssl psfl public-domain qpl @@ -239,11 +240,21 @@ which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/lgpl.html" "https://www.gnu.org/licenses/license-list#LGPLv3")) +(define mpl1.1 + (license "MPL 1.1" + "http://directory.fsf.org/wiki/License:MPLv1.1" + "https://www.gnu.org/licenses/license-list#MPL")) + (define mpl2.0 (license "MPL 2.0" "http://directory.fsf.org/wiki/License:MPLv2.0" "https://www.gnu.org/licenses/license-list#MPL-2.0")) +(define ncsa + (license "NCSA/University of Illinois Open Source License" + "http://directory.fsf.org/wiki/License:IllinoisNCSA" + "https://www.gnu.org/licenses/license-list#NCSA")) + (define openssl (license "OpenSSL" "http://directory.fsf.org/wiki/License:OpenSSL" diff --git a/guix/monads.scm b/guix/monads.scm index b419ba066a..65683e65de 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -39,7 +39,9 @@ mlet mlet* mbegin - lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift + mwhen + munless + lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift listm foldm mapm @@ -173,9 +175,15 @@ form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as body ...))))))) (define-syntax mbegin - (syntax-rules () + (syntax-rules (%current-monad) "Bind the given monadic expressions in sequence, returning the result of the last one." + ((_ %current-monad mexp) + mexp) + ((_ %current-monad mexp rest ...) + (>>= mexp + (lambda (unused-value) + (mbegin %current-monad rest ...)))) ((_ monad mexp) (with-monad monad mexp)) @@ -185,6 +193,26 @@ the last one." (lambda (unused-value) (mbegin monad rest ...))))))) +(define-syntax mwhen + (syntax-rules () + "When CONDITION is true, evaluate EXP0..EXP* as in an 'mbegin'. When +CONDITION is false, return *unspecified* in the current monad." + ((_ condition exp0 exp* ...) + (if condition + (mbegin %current-monad + exp0 exp* ...) + (return *unspecified*))))) + +(define-syntax munless + (syntax-rules () + "When CONDITION is false, evaluate EXP0..EXP* as in an 'mbegin'. When +CONDITION is true, return *unspecified* in the current monad." + ((_ condition exp0 exp* ...) + (if condition + (return *unspecified*) + (mbegin %current-monad + exp0 exp* ...))))) + (define-syntax define-lift (syntax-rules () ((_ liftn (args ...)) @@ -194,6 +222,7 @@ the last one." (with-monad monad (return (proc args ...)))))))) +(define-lift lift0 ()) (define-lift lift1 (a)) (define-lift lift2 (a b)) (define-lift lift3 (a b c)) diff --git a/guix/packages.scm b/guix/packages.scm index 67a767106e..07f6d0ccbc 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -376,7 +376,7 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." (add-to-store store (basename patch) #t "sha256" patch)) ((? origin?) - (package-source-derivation store patch))))) + (package-source-derivation store patch system))))) (iota (length patches)) patches)) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 84904e29da..781ffc5f58 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -293,6 +293,11 @@ the input port." (define (guix-archive . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 7b7f419f3a..26e9f42774 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -119,7 +119,9 @@ options handled by 'set-build-options-from-command-line', and listed in (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " - -c, --cores=N allow the use of up to N CPU cores for the build"))) + -c, --cores=N allow the use of up to N CPU cores for the build")) + (display (_ " + -M, --max-jobs=N allow at most N build jobs"))) (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given @@ -128,6 +130,7 @@ options handled by 'set-build-options-from-command-line', and listed in (set-build-options store #:keep-failed? (assoc-ref opts 'keep-failed?) #:build-cores (or (assoc-ref opts 'cores) 0) + #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:use-build-hook? (assoc-ref opts 'build-hook?) @@ -192,7 +195,15 @@ options handled by 'set-build-options-from-command-line', and listed in (let ((c (false-if-exception (string->number arg)))) (if c (apply values (alist-cons 'cores c result) rest) - (leave (_ "~a: not a number~%") arg))))))) + (leave (_ "not a number: '~a' option argument: ~a~%") + name arg))))) + (option '(#\M "max-jobs") #t #f + (lambda (opt name arg result . rest) + (let ((c (false-if-exception (string->number arg)))) + (if c + (apply values (alist-cons 'max-jobs c result) rest) + (leave (_ "not a number: '~a' option argument: ~a~%") + name arg))))))) ;;; @@ -390,6 +401,11 @@ arguments with packages that use the specified source." (define (guix-build . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 81bad963f6..c388b0c52c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -213,6 +213,12 @@ packages." ;; Entry point. (define (guix-environment . args) (define (parse-options) + ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 3a72053766..21dc66cb75 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -668,6 +668,11 @@ removed from MANIFEST." (define (guix-package . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result arg-handler) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index ddca76d370..9c96411630 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -175,7 +175,7 @@ to the caller without emitting an error message." %fetch-timeout 0) (begin - (warning (_ "while fetching ~a: server is unresponsive~%") + (warning (_ "while fetching ~a: server is somewhat slow~%") (uri->string uri)) (warning (_ "try `--no-substitutes' if the problem persists~%")) @@ -758,6 +758,10 @@ substituter disabled~%") progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) + + ;; Skip a line after what 'progress-proc' printed. + (newline (current-error-port)) + (every (compose zero? cdr waitpid) pids)))) (("--version") (show-version-and-exit "guix substitute-binary")) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 398a5a371b..27404772b7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -131,6 +131,27 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) +(define (install-grub* grub.cfg device target) + "This is a variant of 'install-grub' with error handling, lifted in +%STORE-MONAD" + (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (temp-gc-root (string-append gc-root ".new")) + (delete-file (lift1 delete-file %store-monad)) + (make-symlink (lift2 switch-symlinks %store-monad)) + (rename (lift2 rename-file %store-monad))) + (mbegin %store-monad + ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when + ;; 'install-grub' completes (being a bit paranoid.) + (make-symlink temp-gc-root grub.cfg) + + (munless (false-if-exception (install-grub grub.cfg device target)) + (delete-file temp-gc-root) + (leave (_ "failed to install GRUB on device '~a'~%") device)) + + ;; Register GRUB.CFG as a GC root so that its dependencies (background + ;; image, font, etc.) are not reclaimed. + (rename temp-gc-root gc-root)))) + (define* (install os-drv target #:key (log-port (current-output-port)) grub? grub.cfg device) @@ -151,18 +172,19 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." ;; Copy items to the new store. (copy-closure to-copy target #:log-port log-port))))) - (mlet* %store-monad ((os-dir -> (derivation->output-path os-drv)) - (% (maybe-copy os-dir))) + (let ((os-dir (derivation->output-path os-drv)) + (format (lift format %store-monad)) + (populate (lift2 populate-root-file-system %store-monad))) - ;; Create a bunch of additional files. - (format log-port "populating '~a'...~%" target) - (populate-root-file-system os-dir target) + (mbegin %store-monad + (maybe-copy os-dir) - (when grub? - (unless (false-if-exception (install-grub grub.cfg device target)) - (leave (_ "failed to install GRUB on device '~a'~%") device))) + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate os-dir target) - (return #t))) + (mwhen grub? + (install-grub* grub.cfg device target))))) ;;; @@ -334,14 +356,11 @@ boot directly to the kernel or to the bootloader." (case action ((reconfigure) - (mlet %store-monad ((% (switch-to-system os))) - (when grub? - (unless (false-if-exception - (install-grub (derivation->output-path grub.cfg) - device "/")) - (leave (_ "failed to install GRUB on device '~a'~%") - device))) - (return #t))) + (mbegin %store-monad + (switch-to-system os) + (mwhen grub? + (install-grub* (derivation->output-path grub.cfg) + device "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") @@ -467,6 +486,11 @@ Build the operating system declared in FILE according to ACTION.\n")) (define (guix-system . args) (define (parse-options) ;; Return the alist of option values. + (append (parse-options-from args) + (parse-options-from (environment-build-options)))) + + (define (parse-options-from args) + ;; Actual parsing takes place here. (args-fold* args %options (lambda (opt name arg result) (leave (_ "~A: unrecognized option~%") name)) diff --git a/guix/store.scm b/guix/store.scm index bc4c641583..571cc060d3 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -435,14 +435,14 @@ encoding conversion errors." (define* (set-build-options server #:key keep-failed? keep-going? fallback? (verbosity 0) - (max-build-jobs (current-processor-count)) + (max-build-jobs 1) timeout (max-silent-time 3600) (use-build-hook? #t) (build-verbosity 0) (log-type 0) (print-build-trace #t) - (build-cores 1) + (build-cores (current-processor-count)) (use-substitutes? #t) (binary-caches '())) ; client "untrusted" cache URLs ;; Must be called after `open-connection'. diff --git a/guix/ui.scm b/guix/ui.scm index 69b073da50..c77e04172e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -64,6 +64,7 @@ string->generations string->duration args-fold* + environment-build-options run-guix-command program-name guix-warning-port @@ -712,6 +713,10 @@ reporting." (leave (_ "invalid argument: ~a~%") (apply format #f msg args))))) +(define (environment-build-options) + "Return additional build options passed as environment variables." + (arguments-from-environment-variable "GUIX_BUILD_OPTIONS")) + (define (show-guix-usage) (format (current-error-port) (_ "Try `guix --help' for more information.~%")) diff --git a/guix/utils.scm b/guix/utils.scm index 9b802b6fb3..d0d2e8a3d4 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -72,6 +72,7 @@ package-name->name+version string-tokenize* string-replace-substring + arguments-from-environment-variable file-extension file-sans-extension call-with-temporary-output-file @@ -627,6 +628,15 @@ REPLACEMENT." (substring str start index) pieces)))))))) +(define (arguments-from-environment-variable variable) + "Retrieve value of environment variable denoted by string VARIABLE in the +form of a list of strings (`char-set:graphic' tokens) suitable for consumption +by `args-fold', if VARIABLE is defined, otherwise return an empty list." + (let ((env (getenv variable))) + (if env + (string-tokenize env char-set:graphic) + '()))) + (define (call-with-temporary-output-file proc) "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this |