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/build-system') 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 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/build-system') 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