TakeV/guix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

build: asdf-build-system: Use SBCL source in CL packages.

Browse source 
* 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.
This commit is contained in:
Pierre Neidhardt 2020-05-07 14:25:51 +02:00
parent a0828560b5
commit c3f1f09586
No known key found for this signature in database
GPG key ID: 9BDCF497A4BBCC7F
2 changed files with 52 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
guix/build-system/asdf.scm
View file

@ -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)))))

54
guix/build/asdf-build-system.scm
View file

@ -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."