summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/cmake-build-system.scm2
-rw-r--r--guix/build/compile.scm29
-rw-r--r--guix/build/emacs-build-system.scm2
-rw-r--r--guix/build/gnu-bootstrap.scm114
-rw-r--r--guix/build/gnu-build-system.scm14
-rw-r--r--guix/build/store-copy.scm1
-rw-r--r--guix/build/syscalls.scm81
-rw-r--r--guix/build/utils.scm103
8 files changed, 327 insertions, 19 deletions
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 9b1112f2d6..d1ff5071be 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -67,6 +67,8 @@
,@(if target
(list (string-append "-DCMAKE_C_COMPILER="
target "-gcc")
+ (string-append "-DCMAKE_CXX_COMPILER="
+ target "-g++")
(if (string-contains target "mingw")
"-DCMAKE_SYSTEM_NAME=Windows"
"-DCMAKE_SYSTEM_NAME=Linux"))
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index c4dbb6e34c..63f24fa7d4 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -84,9 +84,32 @@
(define (optimization-options file)
"Return the default set of optimizations options for FILE."
- (if (string-contains file "gnu/packages/")
- (optimizations-for-level 1) ;build faster
- (optimizations-for-level 3)))
+ (define (strip-option option lst)
+ (let loop ((lst lst)
+ (result '()))
+ (match lst
+ (()
+ (reverse result))
+ ((kw value rest ...)
+ (if (eq? kw option)
+ (append (reverse result) rest)
+ (loop rest (cons* value kw result)))))))
+
+ (define (override-option option value lst)
+ `(,option ,value ,@(strip-option option lst)))
+
+ (cond ((string-contains file "gnu/packages/")
+ ;; Level 0 is good enough but partial evaluation helps preserve the
+ ;; "macro writer's bill of rights".
+ (override-option #:partial-eval? #t
+ (optimizations-for-level 0)))
+ ((string-contains file "gnu/services/")
+ ;; '-O2 -Ono-letrectify' compiles about ~20% faster than '-O2' for
+ ;; large files like gnu/services/mail.scm.
+ (override-option #:letrectify? #f
+ (optimizations-for-level 2)))
+ (else
+ (optimizations-for-level 3))))
(define (scm->go file)
"Strip the \".scm\" suffix from FILE, and append \".go\"."
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 219310cf08..26ea59bc25 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -21,7 +21,7 @@
(define-module (guix build emacs-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
- #:use-module (guix build utils)
+ #:use-module ((guix build utils) #:hide (delete))
#:use-module (guix build emacs-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
diff --git a/guix/build/gnu-bootstrap.scm b/guix/build/gnu-bootstrap.scm
new file mode 100644
index 0000000000..1cb9dc5512
--- /dev/null
+++ b/guix/build/gnu-bootstrap.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+;; Commentary:
+;;
+;; These procedures can be used to adapt the GNU Build System to build
+;; pure Scheme packages targeting the bootstrap Guile.
+;;
+;; Code:
+
+(define-module (guix build gnu-bootstrap)
+ #:use-module (guix build utils)
+ #:use-module (system base compile)
+ #:export (bootstrap-configure
+ bootstrap-build
+ bootstrap-install))
+
+(define (bootstrap-configure version modules scripts)
+ "Create a procedure that configures an early bootstrap package. The
+procedure will search the MODULES directory and configure all of the
+'.in' files with VERSION. It will then search the SCRIPTS directory and
+configure all of the '.in' files with the bootstrap Guile and its module
+and object directories."
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (guile-dir (assoc-ref inputs "guile"))
+ (guile (string-append guile-dir "/bin/guile"))
+ (moddir (string-append out "/share/guile/site/"
+ (effective-version)))
+ (godir (string-append out "/lib/guile/"
+ (effective-version)
+ "/site-ccache")))
+ (for-each (lambda (template)
+ (format #t "Configuring ~a~%" template)
+ (let ((target (string-drop-right template 3)))
+ (copy-file template target)
+ (substitute* target
+ (("@VERSION@") version))))
+ (find-files modules
+ (lambda (fn st)
+ (string-suffix? ".in" fn))))
+ (for-each (lambda (template)
+ (format #t "Configuring ~a~%" template)
+ (let ((target (string-drop-right template 3)))
+ (copy-file template target)
+ (substitute* target
+ (("@GUILE@") guile)
+ (("@MODDIR@") moddir)
+ (("@GODIR@") godir))
+ (chmod target #o755)))
+ (find-files scripts
+ (lambda (fn st)
+ (string-suffix? ".in" fn))))
+ #t)))
+
+(define (bootstrap-build modules)
+ "Create a procedure that builds an early bootstrap package. The
+procedure will search the MODULES directory and compile all of the
+'.scm' files."
+ (lambda _
+ (add-to-load-path (getcwd))
+ (for-each (lambda (scm)
+ (let* ((base (string-drop-right scm 4))
+ (go (string-append base ".go"))
+ (dir (dirname scm)))
+ (format #t "Compiling ~a~%" scm)
+ (compile-file scm #:output-file go)))
+ (find-files modules "\\.scm$"))
+ #t))
+
+(define (bootstrap-install modules scripts)
+ "Create a procedure that installs an early bootstrap package. The
+procedure will install all of the '.scm' and '.go' files in the MODULES
+directory, and all the executable files in the SCRIPTS directory."
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (guile-dir (assoc-ref inputs "guile"))
+ (guile (string-append guile-dir "/bin/guile"))
+ (moddir (string-append out "/share/guile/site/"
+ (effective-version)))
+ (godir (string-append out "/lib/guile/"
+ (effective-version)
+ "/site-ccache")))
+ (for-each (lambda (scm)
+ (let* ((base (string-drop-right scm 4))
+ (go (string-append base ".go"))
+ (dir (dirname scm)))
+ (format #t "Installing ~a~%" scm)
+ (install-file scm (string-append moddir "/" dir))
+ (format #t "Installing ~a~%" go)
+ (install-file go (string-append godir "/" dir))))
+ (find-files modules "\\.scm$"))
+ (for-each (lambda (script)
+ (format #t "Installing ~a~%" script)
+ (install-file script (string-append out "/bin")))
+ (find-files scripts
+ (lambda (fn st)
+ (executable-file? fn))))
+ #t)))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 4df0bb4904..2e7dff2034 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -173,12 +174,16 @@ working directory."
\"autoreconf\". Otherwise do nothing."
;; Note: Run that right after 'unpack' so that the generated files are
;; visible when the 'patch-source-shebangs' phase runs.
- (if (not (file-exists? "configure"))
+ (define (script-exists? file)
+ (and (file-exists? file)
+ (not (file-is-directory? file))))
+
+ (if (not (script-exists? "configure"))
;; First try one of the BOOTSTRAP-SCRIPTS. If none exists, and it's
;; clearly an Autoconf-based project, run 'autoreconf'. Otherwise, do
;; nothing (perhaps the user removed or overrode the 'configure' phase.)
- (let ((script (find file-exists? bootstrap-scripts)))
+ (let ((script (find script-exists? bootstrap-scripts)))
;; GNU packages often invoke the 'git-version-gen' script from
;; 'configure.ac' so make sure it has a valid shebang.
(false-if-file-not-found
@@ -186,12 +191,15 @@ working directory."
(if script
(let ((script (string-append "./" script)))
+ (setenv "NOCONFIGURE" "true")
(format #t "running '~a'~%" script)
(if (executable-file? script)
(begin
(patch-shebang script)
(invoke script))
- (invoke "sh" script)))
+ (invoke "sh" script))
+ ;; Let's clean up after ourselves.
+ (unsetenv "NOCONFIGURE"))
(if (or (file-exists? "configure.ac")
(file-exists? "configure.in"))
(invoke "autoreconf" "-vif")
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 549aa4f28b..ad551bca98 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -35,6 +35,7 @@
read-reference-graph
+ file-size
closure-size
populate-store))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 73b439fb7d..ff008c5b78 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +24,7 @@
(define-module (guix build syscalls)
#:use-module (system foreign)
+ #:use-module (system base target)
#:use-module (rnrs bytevectors)
#:autoload (ice-9 binary-ports) (get-bytevector-n)
#:use-module (srfi srfi-1)
@@ -77,6 +79,8 @@
fdatasync
pivot-root
scandir*
+ getxattr
+ setxattr
fcntl-flock
lock-file
@@ -194,9 +198,14 @@
(* (sizeof* type) n))
((_ type)
(let-syntax ((v (lambda (s)
- (let ((val (sizeof type)))
- (syntax-case s ()
- (_ val))))))
+ ;; When compiling natively, call 'sizeof' at expansion
+ ;; time; otherwise, emit code to call it at run time.
+ (syntax-case s ()
+ (_
+ (if (= (target-word-size)
+ (with-target %host-type target-word-size))
+ (sizeof type)
+ #'(sizeof type)))))))
v))))
(define-syntax alignof*
@@ -208,9 +217,14 @@
(alignof* type))
((_ type)
(let-syntax ((v (lambda (s)
- (let ((val (alignof type)))
- (syntax-case s ()
- (_ val))))))
+ ;; When compiling natively, call 'sizeof' at expansion
+ ;; time; otherwise, emit code to call it at run time.
+ (syntax-case s ()
+ (_
+ (if (= (target-word-size)
+ (with-target %host-type target-word-size))
+ (alignof type)
+ #'(alignof type)))))))
v))))
(define-syntax align ;as found in (system foreign)
@@ -711,6 +725,49 @@ backend device."
(list (strerror err))
(list err))))))
+(define getxattr
+ (let ((proc (syscall->procedure ssize_t "getxattr"
+ `(* * * ,size_t))))
+ (lambda (file key)
+ "Get the extended attribute value for KEY on FILE."
+ (let-values (((size err)
+ ;; Get size of VALUE for buffer.
+ (proc (string->pointer/utf-8 file)
+ (string->pointer key)
+ (string->pointer "")
+ 0)))
+ (cond ((< size 0) #f)
+ ((zero? size) "")
+ ;; Get VALUE in buffer of SIZE. XXX actual size can race.
+ (else (let*-values (((buf) (make-bytevector size))
+ ((size err)
+ (proc (string->pointer/utf-8 file)
+ (string->pointer key)
+ (bytevector->pointer buf)
+ size)))
+ (if (>= size 0)
+ (utf8->string buf)
+ (throw 'system-error "getxattr" "~S: ~A"
+ (list file key (strerror err))
+ (list err))))))))))
+
+(define setxattr
+ (let ((proc (syscall->procedure int "setxattr"
+ `(* * * ,size_t ,int))))
+ (lambda* (file key value #:optional (flags 0))
+ "Set extended attribute KEY to VALUE on FILE."
+ (let*-values (((bv) (string->utf8 value))
+ ((ret err)
+ (proc (string->pointer/utf-8 file)
+ (string->pointer key)
+ (bytevector->pointer bv)
+ (bytevector-length bv)
+ flags)))
+ (unless (zero? ret)
+ (throw 'system-error "setxattr" "~S: ~A"
+ (list file key value (strerror err))
+ (list err)))))))
+
;;;
;;; Random.
@@ -1194,6 +1251,8 @@ bytes."
;;;
(define SIOCGIFCONF ;from <bits/ioctls.h>
+ ; <net/if.h>
+ ; <hurd/ioctl.h>
(if (string-contains %host-type "linux")
#x8912 ;GNU/Linux
#xf00801a4)) ;GNU/Hurd
@@ -1204,23 +1263,23 @@ bytes."
(define SIOCSIFFLAGS
(if (string-contains %host-type "linux")
#x8914 ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #x84804190)) ;GNU/Hurd
(define SIOCGIFADDR
(if (string-contains %host-type "linux")
#x8915 ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #xc08401a1)) ;GNU/Hurd
(define SIOCSIFADDR
(if (string-contains %host-type "linux")
#x8916 ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #x8084018c)) ;GNU/Hurd
(define SIOCGIFNETMASK
(if (string-contains %host-type "linux")
#x891b ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #xc08401a5)) ;GNU/Hurd
(define SIOCSIFNETMASK
(if (string-contains %host-type "linux")
#x891c ;GNU/Linux
- -1)) ;FIXME: GNU/Hurd?
+ #x80840196)) ;GNU/Hurd
(define SIOCADDRT
(if (string-contains %host-type "linux")
#x890B ;GNU/Linux
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index b8be73ead4..419c10195b 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -108,6 +108,8 @@
invoke/quiet
+ make-desktop-entry-file
+
locale-category->string))
@@ -892,7 +894,7 @@ transferred and the continuation of the transfer as a thunk."
(x x)))
(define patch-shebang
- (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
+ (let ((shebang-rx (make-regexp "^[[:blank:]]*(/[[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
(lambda* (file
#:optional
(path (search-path-as-string->list (getenv "PATH")))
@@ -1324,6 +1326,105 @@ not supported."
(&wrap-error (program prog)
(type 'no-interpreter-found)))))))))
+(define* (make-desktop-entry-file destination #:key
+ (type "Application") ; One of "Application", "Link" or "Directory".
+ (version "1.1")
+ name
+ (generic-name name)
+ (no-display #f)
+ comment
+ icon
+ (hidden #f)
+ only-show-in
+ not-show-in
+ (d-bus-activatable #f)
+ try-exec
+ exec
+ path
+ (terminal #f)
+ actions
+ mime-type
+ (categories "Application")
+ implements
+ keywords
+ (startup-notify #t)
+ startup-w-m-class
+ #:rest all-args)
+ "Create a desktop entry file at DESTINATION.
+You must specify NAME.
+
+Values can be booleans, numbers, strings or list of strings.
+
+Additionally, locales can be specified with an alist where the key is the
+locale. The #f key specifies the default. Example:
+
+ #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))
+
+produces
+
+ Name=I love Guix
+ Name[fr]=J'aime Guix
+
+For a complete description of the format, see the specifications at
+https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
+ (define (escape-semicolon s)
+ (string-join (string-split s #\;) "\\;"))
+ (define* (parse key value #:optional locale)
+ (set! value (match value
+ (#t "true")
+ (#f "false")
+ ((? number? n) n)
+ ((? string? s) (escape-semicolon s))
+ ((? list? value)
+ (catch 'wrong-type-arg
+ (lambda () (string-join (map escape-semicolon value) ";"))
+ (lambda args (error "List arguments can only contain strings: ~a" args))))
+ (_ (error "Value must be a boolean, number, string or list of strings"))))
+ (format #t "~a=~a~%"
+ (if locale
+ (format #f "~a[~a]" key locale)
+ key)
+ value))
+
+ (define key-error-message "This procedure only takes key arguments beside DESTINATION")
+
+ (unless name
+ (error "Missing NAME key argument"))
+ (unless (member #:type all-args)
+ (set! all-args (append (list #:type type) all-args)))
+ (mkdir-p (dirname destination))
+
+ (with-output-to-file destination
+ (lambda ()
+ (format #t "[Desktop Entry]~%")
+ (let loop ((args all-args))
+ (match args
+ (() #t)
+ ((_) (error key-error-message))
+ ((key value . ...)
+ (unless (keyword? key)
+ (error key-error-message))
+ (set! key
+ (string-join (map string-titlecase
+ (string-split (symbol->string
+ (keyword->symbol key))
+ #\-))
+ ""))
+ (match value
+ (((_ . _) . _)
+ (for-each (lambda (locale-subvalue)
+ (parse key
+ (if (and (list? (cdr locale-subvalue))
+ (= 1 (length (cdr locale-subvalue))))
+ ;; Support both proper and improper lists for convenience.
+ (cadr locale-subvalue)
+ (cdr locale-subvalue))
+ (car locale-subvalue)))
+ value))
+ (_
+ (parse key value)))
+ (loop (cddr args))))))))
+
;;;
;;; Locales.
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-11 05:40:40 +0000