mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-02-01 15:26:47 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

build-system: asdf: Switch from bundles to regular compilation.

Browse source 
* gnu/packages/lisp.scm (sbcl, ecl)[native-search-paths]: Add
  'XDG_CONFIG_DIRS'.
* guix/build-system/asdf.scm (asdf-build): Replace 'asd-file' and
  'asd-system-name' keywords by 'asd-files' and 'asd-systems'.
* guix/build/asdf-build-system.scm (%object-prefix,
  %lisp-source-install-prefix): Update variables.
  (install): Update variable.
  (main-system-name): New variable.
  (copy-source): Replace 'asd-file' and 'asd-system-name' keywords by
  'asd-files' and 'asd-systems'.
  (configure): New variable.
  (build, check): Replace 'asd-file' and 'asd-system-name' keywords by
  'asd-files' and 'asd-systems'.
  (create-asd-file, symlink-asd-files): Remove variables.
  (create-asdf-configuration): New variable.
  (cleanup-files): Update variable.
  (%standard-phases): Remove 'create-asd-file' and 'symlink-asd-files' phases.
  Add 'configure' and 'create-asdf-configuration' phases.
* guix/build/lisp-utils.scm (%bundle-install-prefix, normalize-dependency,
  inputs->asd-file-map, asdf-load-all, compile-system): Remove variables.
  (compile-systems): New variable.
  (system-dependencies, compiled-system, generate-system-definition): Remove
  variable.
  (test-system): Replace 'asd-file' parameter by 'asd-files'.
  (generate-executable-for-system): Update variable.
  (generate-dependency-links, make-asd-file, bundle-asd-file): Remove
  variables.
  (make-asdf-configuration): New variable.
  (build-program, build-image): Set 'XDG_CONFIG_DIRS'.
  (generate-executable): Update variable.
This commit is contained in:
Guillaume Le Vaillant 2020-09-07 14:57:57 +02:00
parent 140da556be
commit a13f45c150
No known key found for this signature in database
GPG key ID: 6BE8208ADF21FE3F
4 changed files with 158 additions and 294 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gnu/packages/lisp.scm
View file

@ -298,7 +298,10 @@ (define-public ecl
(native-search-paths (native-search-paths
(list (search-path-specification (list (search-path-specification
(variable "XDG_DATA_DIRS") (variable "XDG_DATA_DIRS")
(files '("share"))))) (files '("share")))
(search-path-specification
(variable "XDG_CONFIG_DIRS")
(files '("etc")))))
(home-page "http://ecls.sourceforge.net/") (home-page "http://ecls.sourceforge.net/")
(synopsis "Embeddable Common Lisp") (synopsis "Embeddable Common Lisp")
(description "ECL is an implementation of the Common Lisp language as (description "ECL is an implementation of the Common Lisp language as
@ -546,7 +549,10 @@ (define (quoted-path input path)
(native-search-paths (native-search-paths
(list (search-path-specification (list (search-path-specification
(variable "XDG_DATA_DIRS") (variable "XDG_DATA_DIRS")
(files '("share"))))) (files '("share")))
(search-path-specification
(variable "XDG_CONFIG_DIRS")
(files '("etc")))))
(home-page "http://www.sbcl.org/") (home-page "http://www.sbcl.org/")
(synopsis "Common Lisp implementation") (synopsis "Common Lisp implementation")
(description "Steel Bank Common Lisp (SBCL) is a high performance Common (description "Steel Bank Common Lisp (SBCL) is a high performance Common

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

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> ;;; Copyright © 2019, 2020 Guillaume Le Vaillant <glv@posteo.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -54,12 +54,14 @@ (define %asdf-build-system-modules
;; Imported build-side modules ;; Imported build-side modules
`((guix build asdf-build-system) `((guix build asdf-build-system)
(guix build lisp-utils) (guix build lisp-utils)
(guix build union)
,@%gnu-build-system-modules)) ,@%gnu-build-system-modules))
(define %asdf-build-modules (define %asdf-build-modules
;; Used (visible) build-side modules ;; Used (visible) build-side modules
'((guix build asdf-build-system) '((guix build asdf-build-system)
(guix build utils) (guix build utils)
(guix build union)
(guix build lisp-utils))) (guix build lisp-utils)))
(define (default-lisp implementation) (define (default-lisp implementation)
@ -210,7 +212,7 @@ (define (new-inputs inputs-getter)
(define base-arguments (define base-arguments
(if target-is-source? (if target-is-source?
(strip-keyword-arguments (strip-keyword-arguments
'(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file)
(package-arguments pkg)) (package-arguments pkg))
(package-arguments pkg))) (package-arguments pkg)))
@ -278,8 +280,8 @@ (define (asdf-build lisp-type)
(lambda* (store name inputs (lambda* (store name inputs
#:key source outputs #:key source outputs
(tests? #t) (tests? #t)
(asd-file #f) (asd-files ''())
(asd-system-name #f) (asd-systems ''())
(test-asd-file #f) (test-asd-file #f)
(phases '(@ (guix build asdf-build-system) (phases '(@ (guix build asdf-build-system)
%standard-phases)) %standard-phases))
@ -289,12 +291,24 @@ (define (asdf-build lisp-type)
(imported-modules %asdf-build-system-modules) (imported-modules %asdf-build-system-modules)
(modules %asdf-build-modules)) (modules %asdf-build-modules))
(define system-name ;; FIXME: The definitions of 'systems' and 'files' are pretty hacky.
(or asd-system-name ;; Is there a more elegant way to do it?
(string-drop (define systems
;; NAME is the value returned from `package-full-name'. (if (null? (cadr asd-systems))
(hyphen-separated-name->name+version name) `(quote
(1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix. ,(list
(string-drop
;; NAME is the value returned from `package-full-name'.
(hyphen-separated-name->name+version name)
(1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix.
asd-systems))
(define files
(if (null? (cadr asd-files))
`(quote ,(map (lambda (system)
(string-append system ".asd"))
(cadr systems)))
asd-files))
(define builder (define builder
`(begin `(begin
@ -309,8 +323,8 @@ (define builder
(derivation->output-path source)) (derivation->output-path source))
((source) source) ((source) source)
(source source)) (source source))
#:asd-file ,(or asd-file (string-append system-name ".asd")) #:asd-files ,files
#:asd-system-name ,system-name #:asd-systems ,systems
#:test-asd-file ,test-asd-file #:test-asd-file ,test-asd-file
#:system ,system #:system ,system
#:tests? ,tests? #:tests? ,tests?

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

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -19,6 +20,7 @@
(define-module (guix build asdf-build-system) (define-module (guix build asdf-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module ((guix build gnu-build-system) #:prefix gnu:)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build union)
#:use-module (guix build lisp-utils) #:use-module (guix build lisp-utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
@ -41,14 +43,22 @@ (define-module (guix build asdf-build-system)
;; ;;
;; Code: ;; Code:
(define %object-prefix "/lib") (define %object-prefix "/lib/common-lisp")
(define (%lisp-source-install-prefix) (define (%lisp-source-install-prefix)
(string-append %source-install-prefix "/" (%lisp-type) "-source")) (string-append %source-install-prefix "/" (%lisp-type)))
(define %system-install-prefix (define %system-install-prefix
(string-append %source-install-prefix "/systems")) (string-append %source-install-prefix "/systems"))
(define (main-system-name output)
(let ((package-name (package-name->name+version
(strip-store-file-name output)))
(lisp-prefix (string-append (%lisp-type) "-")))
(if (string-prefix? lisp-prefix package-name)
(string-drop package-name (string-length lisp-prefix))
package-name)))
(define (lisp-source-directory output name) (define (lisp-source-directory output name)
(string-append output (%lisp-source-install-prefix) "/" name)) (string-append output (%lisp-source-install-prefix) "/" name))
@ -126,8 +136,7 @@ (define parent-source
(and parent (and parent
(string-append parent "/share/common-lisp/" (string-append parent "/share/common-lisp/"
(string-take parent-name (string-take parent-name
(string-index parent-name #\-)) (string-index parent-name #\-)))))
"-source")))
(define (first-subdirectory directory) ; From gnu-build-system. (define (first-subdirectory directory) ; From gnu-build-system.
"Return the file name of the first sub-directory of DIRECTORY." "Return the file name of the first sub-directory of DIRECTORY."
@ -146,122 +155,87 @@ (define source-directory
(with-directory-excursion source-directory (with-directory-excursion source-directory
(copy-files-to-output output package-name))) (copy-files-to-output output package-name)))
(define* (copy-source #:key outputs asd-system-name #:allow-other-keys) (define* (copy-source #:key outputs asd-systems #:allow-other-keys)
"Copy the source to the library output." "Copy the source to the library output."
(let* ((out (library-output outputs)) (let* ((out (library-output outputs))
(install-path (string-append out %source-install-prefix))) (install-path (string-append out %source-install-prefix))
(copy-files-to-output out asd-system-name) (system-name (main-system-name out)))
(copy-files-to-output out system-name)
;; Hide the files from asdf ;; Hide the files from asdf
(with-directory-excursion install-path (with-directory-excursion install-path
(rename-file "source" (string-append (%lisp-type) "-source")) (rename-file "source" (%lisp-type))
(delete-file-recursively "systems"))) (delete-file-recursively "systems")))
#t) #t)
(define* (build #:key outputs inputs asd-file asd-system-name (define* (configure #:key inputs #:allow-other-keys)
;; Create a directory having the configuration files for
;; all the dependencies in 'etc/common-lisp/'.
(let ((out (string-append (getcwd) "/.cl-union")))
(match inputs
(((name . directories) ...)
(union-build out (filter directory-exists? directories)
#:create-all-directories? #t
#:log-port (%make-void-port "w"))))
(setenv "CL_UNION" out)
(setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
#t)
(define* (build #:key outputs inputs asd-files asd-systems
#:allow-other-keys) #:allow-other-keys)
"Compile the system." "Compile the system."
(let* ((out (library-output outputs)) (let* ((out (library-output outputs))
(source-path (lisp-source-directory out asd-system-name)) (system-name (main-system-name out))
(source-path (string-append out (%lisp-source-install-prefix)))
(translations (wrap-output-translations (translations (wrap-output-translations
`(,(output-translation source-path `(,(output-translation source-path
out)))) out))))
(asd-file (source-asd-file out asd-system-name asd-file))) (asd-files (map (lambda (asd-file)
(source-asd-file out system-name asd-file))
asd-files)))
(setenv "ASDF_OUTPUT_TRANSLATIONS" (setenv "ASDF_OUTPUT_TRANSLATIONS"
(replace-escaped-macros (format #f "~S" translations))) (replace-escaped-macros (format #f "~S" translations)))
(setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
(compile-systems asd-systems asd-files))
(compile-system asd-system-name asd-file)
;; As above, ecl will sometimes create this even though it doesn't use it
(let ((cache-directory (string-append out "/.cache")))
(when (directory-exists? cache-directory)
(delete-file-recursively cache-directory))))
#t) #t)
(define* (check #:key tests? outputs inputs asd-file asd-system-name (define* (check #:key tests? outputs inputs asd-files asd-systems
test-asd-file test-asd-file
#:allow-other-keys) #:allow-other-keys)
"Test the system." "Test the system."
(let* ((out (library-output outputs)) (let* ((out (library-output outputs))
(asd-file (source-asd-file out asd-system-name asd-file)) (system-name (main-system-name out))
(asd-files (map (lambda (asd-file)
(source-asd-file out system-name asd-file))
asd-files))
(test-asd-file (test-asd-file
(and=> test-asd-file (and=> test-asd-file
(cut source-asd-file out asd-system-name <>)))) (cut source-asd-file out system-name <>))))
(if tests? (if tests?
(test-system asd-system-name asd-file test-asd-file) (test-system (first asd-systems) asd-files test-asd-file)
(format #t "test suite not run~%"))) (format #t "test suite not run~%")))
#t) #t)
(define* (create-asd-file #:key outputs (define* (create-asdf-configuration #:key inputs outputs #:allow-other-keys)
inputs "Create the ASDF configuration files for the built systems."
asd-file (let* ((system-name (main-system-name (assoc-ref outputs "out")))
asd-system-name (out (library-output outputs))
#:allow-other-keys) (conf-dir (string-append out "/etc/common-lisp"))
"Create a system definition file for the built system." (deps-conf-dir (string-append (getenv "CL_UNION") "/etc/common-lisp"))
(let*-values (((out) (library-output outputs)) (source-dir (lisp-source-directory out system-name))
((_ version) (package-name->name+version (lib-dir (string-append (library-directory out) "/" system-name)))
(strip-store-file-name out))) (make-asdf-configuration system-name conf-dir deps-conf-dir
((new-asd-file) (string-append source-dir lib-dir)
(library-directory out) #t))
"/" (normalize-string asd-system-name)
".asd")))
(make-asd-file new-asd-file
#:system asd-system-name
#:version version
#:inputs inputs
#:system-asd-file asd-file))
#t)
(define* (symlink-asd-files #:key outputs #:allow-other-keys)
"Create an extra reference to the system in a convenient location."
(let* ((out (library-output outputs)))
(for-each
(lambda (asd-file)
(receive (new-asd-file asd-file-directory)
(bundle-asd-file out asd-file)
(mkdir-p asd-file-directory)
(symlink asd-file new-asd-file)
;; Update the source registry for future phases which might want to
;; use the newly compiled system.
(prepend-to-source-registry
(string-append asd-file-directory "/"))))
(find-files (string-append out %object-prefix) "\\.asd$")))
#t)
(define* (cleanup-files #:key outputs (define* (cleanup-files #:key outputs
#:allow-other-keys) #:allow-other-keys)
"Remove any compiled files which are not a part of the final bundle." "Remove any compiled files which are not a part of the final bundle."
(let ((out (library-output outputs))) (let* ((out (library-output outputs))
(match (%lisp-type) (cache-directory (string-append out "/.cache")))
("sbcl" ;; Remove the cache directory in case the lisp implementation wrote
(for-each ;; something in there when compiling or testing a system.
(lambda (file) (when (directory-exists? cache-directory)
(unless (string-suffix? "--system.fasl" file) (delete-file-recursively cache-directory)))
(delete-file file)))
(find-files out "\\.fasl$")))
("ecl"
(for-each delete-file
(append (find-files out "\\.fas$")
(find-files out "\\.o$")))))
(with-directory-excursion (library-directory out)
(for-each
(lambda (file)
(rename-file file
(string-append "./" (basename file))))
(find-files "."))
(for-each delete-file-recursively
(scandir "."
(lambda (file)
(and
(directory-exists? file)
(string<> "." file)
(string<> ".." file)))))))
#t) #t)
(define* (strip #:rest args) (define* (strip #:rest args)
@ -280,15 +254,14 @@ (define %standard-phases/source
(define %standard-phases (define %standard-phases
(modify-phases gnu:%standard-phases (modify-phases gnu:%standard-phases
(delete 'bootstrap) (delete 'bootstrap)
(delete 'configure) (replace 'configure configure)
(delete 'install) (add-before 'configure 'copy-source copy-source)
(replace 'build build) (replace 'build build)
(add-before 'build 'copy-source copy-source)
(replace 'check check) (replace 'check check)
(replace 'strip strip) (add-after 'check 'create-asdf-configuration create-asdf-configuration)
(add-after 'check 'create-asd-file create-asd-file) (add-after 'create-asdf-configuration 'cleanup cleanup-files)
(add-after 'create-asd-file 'cleanup cleanup-files) (delete 'install)
(add-after 'cleanup 'create-symlinks symlink-asd-files))) (replace 'strip strip)))
(define* (asdf-build #:key inputs (define* (asdf-build #:key inputs
(phases %standard-phases) (phases %standard-phases)

241
guix/build/lisp-utils.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -28,19 +29,17 @@ (define-module (guix build lisp-utils)
%lisp-type %lisp-type
%source-install-prefix %source-install-prefix
lisp-eval-program lisp-eval-program
compile-system compile-systems
test-system test-system
replace-escaped-macros replace-escaped-macros
generate-executable-wrapper-system generate-executable-wrapper-system
generate-executable-entry-point generate-executable-entry-point
generate-executable-for-system generate-executable-for-system
%bundle-install-prefix
bundle-asd-file
wrap-output-translations wrap-output-translations
prepend-to-source-registry prepend-to-source-registry
build-program build-program
build-image build-image
make-asd-file make-asdf-configuration
valid-char-set valid-char-set
normalize-string normalize-string
library-output)) library-output))
@ -65,9 +64,6 @@ (define %lisp-type
;; link farm for system definition (.asd) files. ;; link farm for system definition (.asd) files.
(define %source-install-prefix "/share/common-lisp") (define %source-install-prefix "/share/common-lisp")
(define (%bundle-install-prefix)
(string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
(define (library-output outputs) (define (library-output outputs)
"If a `lib' output exists, build things there. Otherwise use `out'." "If a `lib' output exists, build things there. Otherwise use `out'."
(or (assoc-ref outputs "lib") (assoc-ref outputs "out"))) (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
@ -81,38 +77,6 @@ (define (normalize-string str)
"Replace invalid characters in STR with a hyphen." "Replace invalid characters in STR with a hyphen."
(string-join (string-tokenize str valid-char-set) "-")) (string-join (string-tokenize str valid-char-set) "-"))
(define (normalize-dependency dependency)
"Normalize the name of DEPENDENCY. Handles dependency definitions of the
dependency-def form described by
<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
Assume that any symbols in DEPENDENCY will be in upper-case."
(match dependency
((':VERSION name rest ...)
`(:version ,(normalize-string name) ,@rest))
((':FEATURE feature-specification dependency-specification)
`(:feature
,feature-specification
,(normalize-dependency dependency-specification)))
((? string? name) (normalize-string name))
(require-specification require-specification)))
(define (inputs->asd-file-map inputs)
"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))))
(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) (define (wrap-output-translations translations)
`(:output-translations `(:output-translations
,@translations ,@translations
@ -143,70 +107,26 @@ (define (lisp-invocation program)
"--eval" "(quit)")) "--eval" "(quit)"))
(_ (error "The LISP provided is not supported at this time.")))) (_ (error "The LISP provided is not supported at this time."))))
(define (asdf-load-all systems) (define (compile-systems systems asd-files)
(map (lambda (system) "Use a lisp implementation to compile the SYSTEMS using asdf.
`(asdf:load-system ,system)) Load ASD-FILES first."
systems))
(define (compile-system system asd-file)
"Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE
first."
(lisp-eval-program (lisp-eval-program
`((require :asdf) `((require :asdf)
(asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) ,@(map (lambda (asd-file)
(asdf:operate 'asdf:compile-bundle-op ,system)))) `(asdf:load-asd (truename ,asd-file)))
asd-files)
,@(map (lambda (system)
`(asdf:compile-system ,system))
systems))))
(define (system-dependencies system asd-file) (define (test-system system asd-files test-asd-file)
"Return the dependencies of SYSTEM, as reported by "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILES first.
asdf:system-depends-on. First load the system's ASD-FILE."
(define deps-file ".deps.sexp")
(define program
`((require :asdf)
(asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
(with-open-file
(stream ,deps-file :direction :output)
(format stream
"~s~%"
(asdf:system-depends-on
(asdf:find-system ,system))))))
(dynamic-wind
(lambda _
(lisp-eval-program program))
(lambda _
(call-with-input-file deps-file read))
(lambda _
(when (file-exists? deps-file)
(delete-file deps-file)))))
(define (compiled-system system)
(let ((system (basename system))) ; this is how asdf handles slashes
(match (%lisp-type)
("sbcl" (string-append system "--system"))
(_ system))))
(define* (generate-system-definition system
#:key version dependencies component?)
`(asdf:defsystem
,(normalize-string system)
,@(if component?
'(:class asdf/bundle:prebuilt-system)
'())
:version ,version
:depends-on ,dependencies
,@(if component?
`(:components ((:compiled-file ,(compiled-system system))))
'())
,@(if (string=? "ecl" (%lisp-type))
`(:lib ,(string-append system ".a"))
'())))
(define (test-system system asd-file test-asd-file)
"Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first.
Also load TEST-ASD-FILE if necessary." Also load TEST-ASD-FILE if necessary."
(lisp-eval-program (lisp-eval-program
`((require :asdf) `((require :asdf)
(asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) ,@(map (lambda (asd-file)
`(asdf:load-asd (truename ,asd-file)))
asd-files)
,@(if test-asd-file ,@(if test-asd-file
`((asdf:load-asd (truename ,test-asd-file))) `((asdf:load-asd (truename ,test-asd-file)))
;; Try some likely files. ;; Try some likely files.
@ -237,6 +157,7 @@ (define* (generate-executable-for-system type system #:key compress?)
:executable t :executable t
:compression t)) :compression t))
'()) '())
(asdf:load-asd (truename ,(string-append system "-exec.asd")))
(asdf:operate ',type ,(string-append system "-exec"))))) (asdf:operate ',type ,(string-append system "-exec")))))
(define (generate-executable-wrapper-system system dependencies) (define (generate-executable-wrapper-system system dependencies)
@ -271,79 +192,30 @@ (define (generate-executable-entry-point system entry-program)
(declare (ignorable arguments)) (declare (ignorable arguments))
,@entry-program)))))))) ,@entry-program))))))))
(define (generate-dependency-links registry system) (define (make-asdf-configuration name conf-dir deps-conf-dir source-dir lib-dir)
"Creates a program which populates asdf's source registry from REGISTRY, an (let ((registry-dir (string-append
alist of dependency names to corresponding asd files. This allows the system conf-dir "/source-registry.conf.d"))
to locate its dependent systems." (translations-dir (string-append
`(progn conf-dir "/asdf-output-translations.conf.d"))
(asdf/source-registry:ensure-source-registry) (deps-registry-dir (string-append
,@(map (match-lambda deps-conf-dir "/source-registry.conf.d"))
((name . asd-file) (deps-translations-dir (string-append
`(setf deps-conf-dir
(gethash ,name "/asdf-output-translations.conf.d")))
asdf/source-registry:*source-registry*) (mkdir-p registry-dir)
,(string->symbol "#p") (when (directory-exists? deps-registry-dir)
,asd-file))) (copy-recursively deps-registry-dir registry-dir))
registry))) (with-output-to-file (string-append registry-dir "/50-" name ".conf")
(lambda _
(format #t "~y~%" `(:tree ,source-dir))))
(define* (make-asd-file asd-file (mkdir-p translations-dir)
#:key system version inputs (when (directory-exists? deps-translations-dir)
(system-asd-file #f)) (copy-recursively deps-translations-dir translations-dir))
"Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the (with-output-to-file (string-append translations-dir "/50-" name ".conf")
system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS." (lambda _
(define dependencies (format #t "~y~%" `((,source-dir :**/ :*.*.*)
(let ((deps (,lib-dir :**/ :*.*.*)))))))
(system-dependencies system system-asd-file)))
(if (eq? 'NIL deps)
'()
(map normalize-dependency deps))))
(define lisp-input-map
(inputs->asd-file-map inputs))
(define dependency-name
(match-lambda
((':version name _ ...) name)
((':feature _ dependency-specification)
(dependency-name dependency-specification))
((? string? name) name)
(_ #f)))
(define registry
(filter-map hash-get-handle
(make-list (length dependencies)
lisp-input-map)
(map dependency-name dependencies)))
;; Ensure directory exists, which might not be the case for an .asd without components.
(mkdir-p (dirname asd-file))
(call-with-output-file asd-file
(lambda (port)
(display
(replace-escaped-macros
(format #f "~y~%~y~%"
(generate-system-definition
system
#:version version
#:dependencies dependencies
;; Some .asd don't have components, and thus they don't generate any .fasl.
#:component? (match (%lisp-type)
("sbcl" (pair? (find-files (dirname asd-file)
"--system\\.fasl$")))
("ecl" (pair? (find-files (dirname asd-file)
"\\.fasb$")))
(_ (error "The LISP provided is not supported at this time."))))
(generate-dependency-links registry system)))
port))))
(define (bundle-asd-file output-path original-asd-file)
"Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two
values: the asd file itself and the directory in which it resides."
(let ((bundle-asd-path (string-append output-path
(%bundle-install-prefix))))
(values (string-append bundle-asd-path "/" (basename original-asd-file))
bundle-asd-path)))
(define (replace-escaped-macros string) (define (replace-escaped-macros string)
"Replace simple lisp forms that the guile writer escapes, for example by "Replace simple lisp forms that the guile writer escapes, for example by
@ -368,6 +240,7 @@ (define* (build-program program outputs #:key
has been bound to the command-line arguments which were passed. Link in any has been bound to the command-line arguments which were passed. Link in any
asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
retained." retained."
(setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc"))
(generate-executable program (generate-executable program
#:dependencies dependencies #:dependencies dependencies
#:dependency-prefixes dependency-prefixes #:dependency-prefixes dependency-prefixes
@ -388,6 +261,7 @@ (define* (build-image image outputs #:key
"Generate an image, possibly standalone, which contains all DEPENDENCIES, "Generate an image, possibly standalone, which contains all DEPENDENCIES,
placing the result in IMAGE.image. Link in any asd files from placing the result in IMAGE.image. Link in any asd files from
DEPENDENCY-PREFIXES to ensure references to those libraries are retained." DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
(setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc"))
(generate-executable image (generate-executable image
#:dependencies dependencies #:dependencies dependencies
#:dependency-prefixes dependency-prefixes #:dependency-prefixes dependency-prefixes
@ -416,20 +290,15 @@ (define* (generate-executable out-file #:key
(mkdir-p bin-directory) (mkdir-p bin-directory)
(with-directory-excursion bin-directory (with-directory-excursion bin-directory
(generate-executable-wrapper-system name dependencies) (generate-executable-wrapper-system name dependencies)
(generate-executable-entry-point name entry-program)) (generate-executable-entry-point name entry-program)
(setenv "ASDF_OUTPUT_TRANSLATIONS"
(prepend-to-source-registry (replace-escaped-macros
(string-append bin-directory "/")) (format
#f "~S"
(setenv "ASDF_OUTPUT_TRANSLATIONS" (wrap-output-translations
(replace-escaped-macros `(((,bin-directory :**/ :*.*.*)
(format (,bin-directory :**/ :*.*.*)))))))
#f "~S" (generate-executable-for-system type name #:compress? compress?))
(wrap-output-translations
`(((,bin-directory :**/ :*.*.*)
(,bin-directory :**/ :*.*.*)))))))
(generate-executable-for-system type name #:compress? compress?)
(let* ((after-store-prefix-index (let* ((after-store-prefix-index
(string-index out-file #\/ (string-index out-file #\/
@ -445,9 +314,11 @@ (define* (generate-executable out-file #:key
(symlink asd-file (symlink asd-file
(string-append hidden-asd-links (string-append hidden-asd-links
"/" (basename asd-file)))) "/" (basename asd-file))))
(find-files (string-append path (%bundle-install-prefix)) (find-files (string-append path %source-install-prefix "/"
(%lisp-type))
"\\.asd$"))) "\\.asd$")))
dependency-prefixes)) dependency-prefixes))
(delete-file (string-append bin-directory "/" name "-exec.asd")) (delete-file (string-append bin-directory "/" name "-exec.asd"))
(delete-file (string-append bin-directory "/" name "-exec.lisp")))) (delete-file (string-append bin-directory "/" name "-exec.lisp"))
(delete-file (string-append bin-directory "/" name "-exec.fasl"))))