nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

build-system/asdf: Use asdf to determine dependencies. 

This removes the need for conventions to determine which inputs are run-time
dependencies, and also the need to specify "special" dependencies.

* guix/build/lisp-utils.scm (patch-asd-file, lisp-dependencies)
(wrap-perform-method): Remove them.
(inputs->asd-file-map, system-dependencies, generate-system-definition)
(generate-dependency-links, make-asd-file): New procedures.
(lisp-eval-program): Add an error if no lisp matches.
(compile-system): Don't use asdf's in-built asd-file generator.
This commit is contained in:
Andy Patterson 2017-04-03 09:01:23 -04:00 committed by Ricardo Wurmus
parent 290bf612bb
commit 35189728cd
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
4 changed files with 141 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gnu/packages/lisp.scm
View File

@ -822,8 +822,6 @@ compatible with ANSI-compliant Common Lisp implementations.")
(substitute* "clx.asd"
(("\\(:file \"trapezoid\"\\)") ""))))))
(build-system asdf-build-system/sbcl)
(arguments
'(#:special-dependencies '("sb-bsd-sockets")))
(home-page "http://www.cliki.net/portable-clx")
(synopsis "X11 client library for Common Lisp")
(description "CLX is an X11 client library for Common Lisp. The code was
@ -855,8 +853,7 @@ from other CLXes around the net.")
("sbcl-clx" ,sbcl-clx)))
(outputs '("out" "lib"))
(arguments
'(#:special-dependencies '("sb-posix")
#:phases
'(#:phases
(modify-phases %standard-phases
(add-after 'create-symlinks 'build-program
(lambda* (#:key lisp outputs inputs #:allow-other-keys)

7
guix/build-system/asdf.scm
View File

@ -194,8 +194,7 @@ set up using CL source package conventions."
(define base-arguments
(if target-is-source?
(strip-keyword-arguments
'(#:tests? #:special-dependencies #:asd-file
#:test-only-systems #:lisp)
'(#:tests? #:asd-file #:lisp)
(package-arguments pkg))
(package-arguments pkg)))
@ -262,9 +261,7 @@ set up using CL source package conventions."
(lambda* (store name inputs
#:key source outputs
(tests? #t)
(special-dependencies ''())
(asd-file #f)
(test-only-systems ''())
(lisp lisp-implementation)
(phases '(@ (guix build asdf-build-system)
%standard-phases))
@ -284,9 +281,7 @@ set up using CL source package conventions."
((source) source)
(source source))
#:lisp ,lisp
#:special-dependencies ,special-dependencies
#:asd-file ,asd-file
#:test-only-systems ,test-only-systems
#:system ,system
#:tests? ,tests?
#:phases ,phases

49
guix/build/asdf-build-system.scm
View File

@ -21,6 +21,7 @@
#:use-module (guix build utils)
#:use-module (guix build lisp-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
@ -161,31 +162,25 @@ valid."
(format #t "test suite not run~%")))
#t)
(define* (patch-asd-files #:key outputs
(define* (create-asd-file #:key outputs
inputs
lisp
special-dependencies
test-only-systems
asd-file
#:allow-other-keys)
"Patch any asd files created by the compilation process so that they can
find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only
included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP
implementation itself provides."
(let* ((out (library-output outputs))
(name (remove-lisp-from-name (output-path->package-name out) lisp))
(registry (lset-difference
(lambda (input system)
(match input
((name . path) (string=? name system))))
(lisp-dependencies lisp inputs)
test-only-systems))
(lisp-systems (map first registry)))
"Create a system definition file for the built system."
(let*-values (((out) (library-output outputs))
((full-name version) (package-name->name+version
(strip-store-file-name out)))
((name) (remove-lisp-from-name full-name lisp))
((new-asd-file) (string-append (library-directory out lisp)
"/" name ".asd")))
(for-each
(lambda (asd-file)
(patch-asd-file asd-file registry lisp
(append lisp-systems special-dependencies)))
(find-files out "\\.asd$")))
(make-asd-file new-asd-file
#:lisp lisp
#:system name
#:version version
#:inputs inputs
#:system-asd-file asd-file))
#t)
(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys)
@ -193,9 +188,6 @@ implementation itself provides."
(let* ((out (library-output outputs)))
(for-each
(lambda (asd-file)
(substitute* asd-file
((";;; Built for.*") "") ; remove potential non-determinism
(("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" end)))
(receive (new-asd-file asd-file-directory)
(bundle-asd-file out asd-file lisp)
(mkdir-p asd-file-directory)
@ -205,12 +197,11 @@ implementation itself provides."
(prepend-to-source-registry
(string-append asd-file-directory "/"))))
(find-files (string-append out %object-prefix) "\\.asd$"))
)
(find-files (string-append out %object-prefix) "\\.asd$")))
#t)
(define* (cleanup-files #:key outputs lisp
#:allow-other-keys)
#:allow-other-keys)
"Remove any compiled files which are not a part of the final bundle."
(let ((out (library-output outputs)))
(match lisp
@ -261,8 +252,8 @@ implementation itself provides."
(add-before 'build 'copy-source copy-source)
(replace 'check check)
(replace 'strip strip)
(add-after 'check 'link-dependencies patch-asd-files)
(add-after 'link-dependencies 'cleanup cleanup-files)
(add-after 'check 'create-asd-file create-asd-file)
(add-after 'create-asd-file 'cleanup cleanup-files)
(add-after 'cleanup 'create-symlinks symlink-asd-files)))
(define* (asdf-build #:key inputs

179
guix/build/lisp-utils.scm
View File

@ -18,6 +18,7 @@
(define-module (guix build lisp-utils)
#:use-module (ice-9 format)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
@ -32,15 +33,14 @@
generate-executable-wrapper-system
generate-executable-entry-point
generate-executable-for-system
patch-asd-file
bundle-install-prefix
lisp-dependencies
bundle-asd-file
remove-lisp-from-name
wrap-output-translations
prepend-to-source-registry
build-program
build-image))
build-image
make-asd-file))
;;; Commentary:
;;;
@ -64,6 +64,23 @@
(define (remove-lisp-from-name name lisp)
(string-drop name (1+ (string-length lisp))))
(define (inputs->asd-file-map inputs lisp)
"Produce a hash table of the form (system . asd-file), where system is the
name of an ASD system, and asd-file is the full path to its definition."
(alist->hash-table
(filter-map
(match-lambda
((_ . path)
(let ((prefix (string-append path (bundle-install-prefix lisp))))
(and (directory-exists? prefix)
(match (find-files prefix "\\.asd$")
((asd-file)
(cons
(string-drop-right (basename asd-file) 4) ; drop ".asd"
asd-file))
(_ #f))))))
inputs)))
(define (wrap-output-translations translations)
`(:output-translations
,@translations
@ -80,7 +97,8 @@
with PROGRAM."
(match lisp
("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))
(_ (error "The LISP provided is not supported at this time."))))
(define (asdf-load-all systems)
(map (lambda (system)
@ -108,15 +126,61 @@ first if SYSTEM is defined there."
(find-symbol
(symbol-name :compile-bundle-op)
(symbol-name :asdf))
,system)
(funcall (find-symbol
(symbol-name :operate)
(symbol-name :asdf))
(find-symbol
(symbol-name :deliver-asd-op)
(symbol-name :asdf))
,system))))
(define (system-dependencies lisp system asd-file)
"Return the dependencies of SYSTEM, as reported by
asdf:system-depends-on. First load the system's ASD-FILE, if necessary."
(define deps-file ".deps.sexp")
(define program
`(progn
(require :asdf)
,@(if asd-file
`((let ((*package* (find-package :asdf)))
(load ,asd-file)))
'())
(with-open-file
(stream ,deps-file :direction :output)
(format stream
"~s~%"
(funcall
(find-symbol
(symbol-name :system-depends-on)
(symbol-name :asdf))
(funcall
(find-symbol
(symbol-name :find-system)
(symbol-name :asdf))
,system))))))
(dynamic-wind
(lambda _
(lisp-eval-program lisp program))
(lambda _
(call-with-input-file deps-file read))
(lambda _
(when (file-exists? deps-file)
(delete-file deps-file)))))
(define (compiled-system system lisp)
(match lisp
("sbcl" (string-append system "--system"))
(_ system)))
(define* (generate-system-definition lisp system
#:key version dependencies)
`(asdf:defsystem
,system
:class asdf/bundle:prebuilt-system
:version ,version
:depends-on ,dependencies
:components ((:compiled-file ,(compiled-system system lisp)))
,@(if (string=? "ecl" lisp)
`(:lib ,(string-append system ".a"))
'())))
(define (test-system system lisp asd-file)
"Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first
if SYSTEM is defined there."
@ -185,58 +249,53 @@ ENTRY-PROGRAM for SYSTEM within the current directory."
(declare (ignorable arguments))
,@entry-program))))))))
(define (wrap-perform-method lisp registry dependencies file-name)
"Creates a wrapper method which allows the system to locate its dependent
systems from REGISTRY, an alist of the same form as %outputs, which contains
lisp systems which the systems is dependent on. All DEPENDENCIES which the
system depends on will the be loaded before this system."
(let* ((system (string-drop-right (basename file-name) 4))
(system-symbol (string->lisp-keyword system)))
(define (generate-dependency-links lisp registry system)
"Creates a program which populates asdf's source registry from REGISTRY, an
alist of dependency names to corresponding asd files. This allows the system
to locate its dependent systems."
`(progn
(asdf/source-registry:ensure-source-registry)
,@(map (match-lambda
((name . asd-file)
`(setf
(gethash ,name
asdf/source-registry:*source-registry*)
,(string->symbol "#p")
,asd-file)))
registry)))
`(defmethod asdf:perform :before
(op (c (eql (asdf:find-system ,system-symbol))))
(asdf/source-registry:ensure-source-registry)
,@(map (match-lambda
((name . path)
(let ((asd-file (string-append path
(bundle-install-prefix lisp)
"/" name ".asd")))
`(setf
(gethash ,name
asdf/source-registry:*source-registry*)
,(string->symbol "#p")
,(bundle-asd-file path asd-file lisp)))))
registry)
,@(map (lambda (system)
`(asdf:load-system ,(string->lisp-keyword system)))
dependencies))))
(define* (make-asd-file asd-file
#:key lisp system version inputs
(system-asd-file #f))
"Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
(define dependencies
(parameterize ((%lisp (string-append (assoc-ref inputs lisp) "/bin/" lisp)))
(system-dependencies lisp system system-asd-file)))
(define (patch-asd-file asd-file registry lisp dependencies)
"Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD."
(chmod asd-file #o644)
(let ((port (open-file asd-file "a")))
(dynamic-wind
(lambda _ #t)
(lambda _
(display
(replace-escaped-macros
(format #f "~%~y~%"
(wrap-perform-method lisp registry
dependencies asd-file)))
port))
(lambda _ (close-port port))))
(chmod asd-file #o444))
(define lisp-input-map
(inputs->asd-file-map inputs lisp))
(define (lisp-dependencies lisp inputs)
"Determine which inputs are lisp system dependencies, by using the convention
that a lisp system dependency will resemble \"system-LISP\"."
(filter-map (match-lambda
((name . value)
(and (string-prefix? lisp name)
(string<> lisp name)
`(,(remove-lisp-from-name name lisp)
. ,value))))
inputs))
(define registry
(filter-map hash-get-handle
(make-list (if (eq? 'NIL dependencies)
0
(length dependencies))
lisp-input-map)
(if (eq? 'NIL dependencies)
'()
dependencies)))
(call-with-output-file asd-file
(lambda (port)
(display
(replace-escaped-macros
(format #f "~y~%~y~%"
(generate-system-definition lisp system
#:version version
#:dependencies dependencies)
(generate-dependency-links lisp registry system)))
port))))
(define (bundle-asd-file output-path original-asd-file lisp)
"Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in