ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

build-system: Add asdf-build-system.

Browse source 
* guix/build-system/asdf.scm: New file.
* guix/build/asdf-build-system.scm: New file.
* guix/build/lisp-utils.scm: New file.
* Makefile.am (MODULES): Add them.
* doc/guix.texi (Build Systems): Document 'asdf-build-system'.

Signed-off-by: 宋文武 <iyzsong@gmail.com>
This commit is contained in:
Andy Patterson 2016-10-07 17:57:08 -04:00 committed by 宋文武
parent 53aec0999f
commit a1b30f99a8
No known key found for this signature in database
GPG key ID: 26525665AE727D37
5 changed files with 1029 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -63,6 +63,7 @@ MODULES = \
guix/build-system/ant.scm \
guix/build-system/cmake.scm \
guix/build-system/emacs.scm \
guix/build-system/asdf.scm \
guix/build-system/glib-or-gtk.scm \
guix/build-system/gnu.scm \
guix/build-system/haskell.scm \
@ -84,6 +85,7 @@ MODULES = \
guix/build/download.scm \
guix/build/cmake-build-system.scm \
guix/build/emacs-build-system.scm \
guix/build/asdf-build-system.scm \
guix/build/git.scm \
guix/build/hg.scm \
guix/build/glib-or-gtk-build-system.scm \
@ -106,6 +108,7 @@ MODULES = \
guix/build/syscalls.scm \
guix/build/gremlin.scm \
guix/build/emacs-utils.scm \
guix/build/lisp-utils.scm \
guix/build/graft.scm \
guix/build/bournish.scm \
guix/build/qt-utils.scm \

57
doc/guix.texi
View file

@ -2967,6 +2967,63 @@ that should be run during the @code{build} phase. By default the
@end defvr
@defvr {Scheme Variable} asdf-build-system/source
@defvrx {Scheme Variable} asdf-build-system/sbcl
@defvrx {Scheme Variable} asdf-build-system/ecl
These variables, exported by @code{(guix build-system asdf)}, implement
build procedures for Common Lisp packages using
@url{https://common-lisp.net/project/asdf/, ``ASDF''}. ASDF is a system
definition facility for Common Lisp programs and libraries.
The @code{asdf-build-system/source} system installs the packages in
source form, and can be loaded using any common lisp implementation, via
ASDF. The others, such as @code{asdf-build-system/sbcl}, install binary
systems in the format which a particular implementation understands.
These build systems can also be used to produce executable programs, or
lisp images which contain a set of packages pre-loaded.
The build system uses naming conventions. For binary packages, the
package itself as well as its run-time dependencies should begin their
name with the lisp implementation, such as @code{sbcl-} for
@code{asdf-build-system/sbcl}. Beginning the input name with this
prefix will allow the build system to encode its location into the
resulting library, so that the input can be found at run-time.
If dependencies are used only for tests, it is convenient to use a
different prefix in order to avoid having a run-time dependency on such
systems. For example,
@example
(define-public sbcl-bordeaux-threads
(package
...
(native-inputs `(("tests:cl-fiveam" ,sbcl-fiveam)))
...))
@end example
Additionally, the corresponding source package should be labeled using
the same convention as python packages (see @ref{Python Modules}), using
the @code{cl-} prefix.
For binary packages, each system should be defined as a Guix package.
If one package @code{origin} contains several systems, package variants
can be created in order to build all the systems. Source packages,
which use @code{asdf-build-system/source}, may contain several systems.
In order to create executable programs and images, the build-side
procedures @code{build-program} and @code{build-image} can be used.
They should be called in a build phase after the @code{create-symlinks}
phase, so that the system which was just built can be used within the
resulting image. @code{build-program} requires a list of Common Lisp
expressions to be passed as the @code{#:entry-program} argument.
If the system is not defined within its own @code{.asd} file of the same
name, then the @code{#:asd-file} parameter should be used to specify
which file the system is defined in.
@end defvr
@defvr {Scheme Variable} cmake-build-system
This variable is exported by @code{(guix build-system cmake)}. It
implements the build procedure for packages using the

360
guix/build-system/asdf.scm Normal file
View file

@ -0,0 +1,360 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; 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/>.
(define-module (guix build-system asdf)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix search-paths)
#:use-module (guix build-system)
#:use-module (guix build-system gnu)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%asdf-build-system-modules
%asdf-build-modules
asdf-build
asdf-build-system/sbcl
asdf-build-system/ecl
asdf-build-system/source
sbcl-package->cl-source-package
sbcl-package->ecl-package))
;; Commentary:
;;
;; Standard build procedure for asdf packages. This is implemented as an
;; extension of 'gnu-build-system'.
;;
;; Code:
(define %asdf-build-system-modules
;; Imported build-side modules
`((guix build asdf-build-system)
(guix build lisp-utils)
,@%gnu-build-system-modules))
(define %asdf-build-modules
;; Used (visible) build-side modules
'((guix build asdf-build-system)
(guix build utils)
(guix build lisp-utils)))
(define (default-lisp implementation)
"Return the default package for the lisp IMPLEMENTATION."
;; Lazily resolve the binding to avoid a circular dependancy.
(let ((lisp-module (resolve-interface '(gnu packages lisp))))
(module-ref lisp-module implementation)))
(define* (lower/source name
#:key source inputs outputs native-inputs system target
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME"
(define private-keywords
'(#:target #:inputs #:native-inputs))
(and (not target)
(bag
(name name)
(system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
,@inputs
,@(standard-packages)))
(build-inputs native-inputs)
(outputs outputs)
(build asdf-build/source)
(arguments (strip-keyword-arguments private-keywords arguments)))))
(define* (asdf-build/source store name inputs
#:key source outputs
(phases '(@ (guix build asdf-build-system)
%standard-phases/source))
(search-paths '())
(system (%current-system))
(guile #f)
(imported-modules %asdf-build-system-modules)
(modules %asdf-build-modules))
(define builder
`(begin
(use-modules ,@modules)
(asdf-build/source #:name ,name
#:source ,(match (assoc-ref inputs "source")
(((? derivation? source))
(derivation->output-path source))
((source) source)
(source source))
#:system ,system
#:phases ,phases
#:outputs %outputs
#:search-paths ',(map search-path-specification->sexp
search-paths)
#:inputs %build-inputs)))
(define guile-for-build
(match guile
((? package?)
(package-derivation store guile system #:graft? #f))
(#f
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
(package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:inputs inputs
#:system system
#:modules imported-modules
#:outputs outputs
#:guile-for-build guile-for-build))
(define* (package-with-build-system from-build-system to-build-system
from-prefix to-prefix
#:key variant-property
phases-transformer)
"Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
and returns one using TO-BUILD-SYSTEM. If PKG was prefixed by FROM-PREFIX,
the resulting package will be prefixed by TO-PREFIX. Inputs of PKG are
recursively transformed using the same rule. The result's #:phases argument
will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the
build side to a procedure of one argument.
VARIANT-PROPERTY can be added to a package's properties to indicate that the
corresponding package promise should be used as the result of this
transformation. This allows the result to differ from what the transformation
would otherwise produce.
If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be
set up using CL source package conventions."
(define target-is-source? (eq? asdf-build-system/source to-build-system))
(define (transform-package-name name)
(if (string-prefix? from-prefix name)
(let ((new-name (string-drop name (string-length from-prefix))))
(if (string-prefix? to-prefix new-name)
new-name
(string-append to-prefix new-name)))
name))
(define (has-from-build-system? pkg)
(eq? from-build-system (package-build-system pkg)))
(define transform
(memoize
(lambda (pkg)
(define rewrite
(match-lambda
((name content . rest)
(let* ((is-package? (package? content))
(new-content (if is-package? (transform content) content))
(new-name (if (and is-package?
(string-prefix? from-prefix name))
(package-name new-content)
name)))
`(,new-name ,new-content ,@rest)))))
;; Special considerations for source packages: CL inputs become
;; propagated, and un-handled arguments are removed. Native inputs are
;; removed as are extraneous outputs.
(define new-propagated-inputs
(if target-is-source?
(map rewrite
(filter (match-lambda
((_ input . _)
(has-from-build-system? input)))
(package-inputs pkg)))
'()))
(define new-inputs
(if target-is-source?
(map rewrite
(filter (match-lambda
((_ input . _)
(not (has-from-build-system? input))))
(package-inputs pkg)))
(map rewrite (package-inputs pkg))))
(define base-arguments
(if target-is-source?
(strip-keyword-arguments
'(#:tests? #:special-dependencies #:asd-file
#:test-only-systems #:lisp)
(package-arguments pkg))
(package-arguments pkg)))
(cond
((and variant-property
(assoc-ref (package-properties pkg) variant-property))
=> force)
((has-from-build-system? pkg)
(package
(inherit pkg)
(location (package-location pkg))
(name (transform-package-name (package-name pkg)))
(build-system to-build-system)
(arguments
(substitute-keyword-arguments base-arguments
((#:phases phases) (list phases-transformer phases))))
(inputs new-inputs)
(propagated-inputs new-propagated-inputs)
(native-inputs (if target-is-source?
'()
(map rewrite (package-native-inputs pkg))))
(outputs (if target-is-source?
'("out")
(package-outputs pkg)))))
(else pkg)))))
transform)
(define (strip-variant-as-necessary variant pkg)
(define properties (package-properties pkg))
(if (assoc variant properties)
(package
(inherit pkg)
(properties (alist-delete variant properties)))
pkg))
(define (lower lisp-implementation)
(lambda* (name
#:key source inputs outputs native-inputs system target
(lisp (default-lisp (string->symbol lisp-implementation)))
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME"
(define private-keywords
'(#:target #:inputs #:native-inputs #:lisp))
(and (not target)
(bag
(name name)
(system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
,@inputs
,@(standard-packages)))
(build-inputs `((,lisp-implementation ,lisp)
,@native-inputs))
(outputs outputs)
(build (asdf-build lisp-implementation))
(arguments (strip-keyword-arguments private-keywords arguments))))))
(define (asdf-build lisp-implementation)
(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))
(search-paths '())
(system (%current-system))
(guile #f)
(imported-modules %asdf-build-system-modules)
(modules %asdf-build-modules))
(define builder
`(begin
(use-modules ,@modules)
(asdf-build #:name ,name
#:source ,(match (assoc-ref inputs "source")
(((? derivation? source))
(derivation->output-path source))
((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
#:outputs %outputs
#:search-paths ',(map search-path-specification->sexp
search-paths)
#:inputs %build-inputs)))
(define guile-for-build
(match guile
((? package?)
(package-derivation store guile system #:graft? #f))
(#f
(let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final)))
(package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder
#:inputs inputs
#:system system
#:modules imported-modules
#:outputs outputs
#:guile-for-build guile-for-build)))
(define asdf-build-system/sbcl
(build-system
(name 'asdf/sbcl)
(description "The build system for ASDF binary packages using SBCL")
(lower (lower "sbcl"))))
(define asdf-build-system/ecl
(build-system
(name 'asdf/ecl)
(description "The build system for ASDF binary packages using ECL")
(lower (lower "ecl"))))
(define asdf-build-system/source
(build-system
(name 'asdf/source)
(description "The build system for ASDF source packages")
(lower lower/source)))
(define sbcl-package->cl-source-package
(let* ((property 'cl-source-variant)
(transformer
(package-with-build-system asdf-build-system/sbcl
asdf-build-system/source
"sbcl-"
"cl-"
#:variant-property property
#:phases-transformer
'(const %standard-phases/source))))
(lambda (pkg)
(transformer
(strip-variant-as-necessary property pkg)))))
(define sbcl-package->ecl-package
(let* ((property 'ecl-variant)
(transformer
(package-with-build-system asdf-build-system/sbcl
asdf-build-system/ecl
"sbcl-"
"ecl-"
#:variant-property property
#:phases-transformer
'identity)))
(lambda (pkg)
(transformer
(strip-variant-as-necessary property pkg)))))
;;; asdf.scm ends here

282
guix/build/asdf-build-system.scm Normal file
View file

@ -0,0 +1,282 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; 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/>.
(define-module (guix build asdf-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
#:use-module (guix build utils)
#:use-module (guix build lisp-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:export (%standard-phases
%standard-phases/source
asdf-build
asdf-build/source))
;; Commentary:
;;
;; System for building ASDF packages; creating executable programs and images
;; from them.
;;
;; Code:
(define %object-prefix "/lib")
(define (source-install-prefix lisp)
(string-append %install-prefix "/" lisp "-source"))
(define %system-install-prefix
(string-append %install-prefix "/systems"))
(define (output-path->package-name path)
(package-name->name+version (strip-store-file-name path)))
(define (outputs->name outputs)
(output-path->package-name
(assoc-ref outputs "out")))
(define (lisp-source-directory output lisp name)
(string-append output (source-install-prefix lisp) "/" name))
(define (source-directory output name)
(string-append output %install-prefix "/source/" name))
(define (library-directory output lisp)
(string-append output %object-prefix
"/" lisp))
(define (output-translation source-path
object-output
lisp)
"Return a translation for the system's source path
to it's binary output."
`((,source-path
:**/ :*.*.*)
(,(library-directory object-output lisp)
:**/ :*.*.*)))
(define (source-asd-file output lisp name asd-file)
(string-append (lisp-source-directory output lisp name) "/" asd-file))
(define (copy-files-to-output outputs output name)
"Copy all files from OUTPUT to \"out\". Create an extra link to any
system-defining files in the source to a convenient location. This is done
before any compiling so that the compiled source locations will be valid."
(let* ((out (assoc-ref outputs output))
(source (getcwd))
(target (source-directory out name))
(system-path (string-append out %system-install-prefix)))
(copy-recursively source target)
(mkdir-p system-path)
(for-each
(lambda (file)
(symlink file
(string-append system-path "/" (basename file))))
(find-files target "\\.asd$"))
#t))
(define* (install #:key outputs #:allow-other-keys)
"Copy and symlink all the source files."
(copy-files-to-output outputs "out" (outputs->name outputs)))
(define* (copy-source #:key outputs lisp #:allow-other-keys)
"Copy the source to \"out\"."
(let* ((out (assoc-ref outputs "out"))
(name (remove-lisp-from-name (output-path->package-name out) lisp))
(install-path (string-append out %install-prefix)))
(copy-files-to-output outputs "out" name)
;; Hide the files from asdf
(with-directory-excursion install-path
(rename-file "source" (string-append lisp "-source"))
(delete-file-recursively "systems")))
#t)
(define* (build #:key outputs inputs lisp asd-file
#:allow-other-keys)
"Compile the system."
(let* ((out (assoc-ref outputs "out"))
(name (remove-lisp-from-name (output-path->package-name out) lisp))
(source-path (lisp-source-directory out lisp name))
(translations (wrap-output-translations
`(,(output-translation source-path
out
lisp))))
(asd-file (and=> asd-file (cut source-asd-file out lisp name <>))))
(setenv "ASDF_OUTPUT_TRANSLATIONS"
(replace-escaped-macros (format #f "~S" translations)))
;; We don't need this if we have the asd file, and it can mess with the
;; load ordering we're trying to enforce
(unless asd-file
(prepend-to-source-registry (string-append source-path "//")))
(setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
(parameterize ((%lisp (string-append
(assoc-ref inputs lisp) "/bin/" lisp)))
(compile-system name lisp 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)
(define* (check #:key lisp tests? outputs inputs asd-file
#:allow-other-keys)
"Test the system."
(let* ((name (remove-lisp-from-name (outputs->name outputs) lisp))
(out (assoc-ref outputs "out"))
(asd-file (and=> asd-file (cut source-asd-file out lisp name <>))))
(if tests?
(parameterize ((%lisp (string-append
(assoc-ref inputs lisp) "/bin/" lisp)))
(test-system name lisp asd-file))
(format #t "test suite not run~%")))
#t)
(define* (patch-asd-files #:key outputs
inputs
lisp
special-dependencies
test-only-systems
#: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 (assoc-ref outputs "out"))
(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)))
(for-each
(lambda (asd-file)
(patch-asd-file asd-file registry lisp
(append lisp-systems special-dependencies)))
(find-files out "\\.asd$")))
#t)
(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys)
"Create an extra reference to the system in a convenient location."
(let* ((out (assoc-ref outputs "out")))
(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)
(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 lisp
#:allow-other-keys)
"Remove any compiled files which are not a part of the final bundle."
(let ((out (assoc-ref outputs "out")))
(match lisp
("sbcl"
(for-each
(lambda (file)
(unless (string-suffix? "--system.fasl" file)
(delete-file file)))
(find-files out "\\.fasl$")))
("ecl"
(for-each delete-file
(append (find-files out "\\.fas$")
(find-files out "\\.o$")
(find-files out "\\.a$")))))
(with-directory-excursion (library-directory out lisp)
(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)
(define* (strip #:key lisp #:allow-other-keys #:rest args)
;; stripping sbcl binaries removes their entry program and extra systems
(or (string=? lisp "sbcl")
(apply (assoc-ref gnu:%standard-phases 'strip) args)))
(define %standard-phases/source
(modify-phases gnu:%standard-phases
(delete 'configure)
(delete 'check)
(delete 'build)
(replace 'install install)))
(define %standard-phases
(modify-phases gnu:%standard-phases
(delete 'configure)
(delete 'install)
(replace 'build build)
(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 'cleanup 'create-symlinks symlink-asd-files)))
(define* (asdf-build #:key inputs
(phases %standard-phases)
#:allow-other-keys
#:rest args)
(apply gnu:gnu-build
#:inputs inputs
#:phases phases
args))
(define* (asdf-build/source #:key inputs
(phases %standard-phases/source)
#:allow-other-keys
#:rest args)
(apply gnu:gnu-build
#:inputs inputs
#:phases phases
args))
;;; asdf-build-system.scm ends here

327
guix/build/lisp-utils.scm Normal file
View file

@ -0,0 +1,327 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; 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/>.
(define-module (guix build lisp-utils)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (guix build utils)
#:export (%lisp
%install-prefix
lisp-eval-program
compile-system
test-system
replace-escaped-macros
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))
;;; Commentary:
;;;
;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
;;; systems for executables. Compile, test, and produce images for systems and
;;; programs, and link them with their dependencies.
;;;
;;; Code:
(define %lisp
;; File name of the Lisp compiler.
(make-parameter "lisp"))
(define %install-prefix "/share/common-lisp")
(define (bundle-install-prefix lisp)
(string-append %install-prefix "/" lisp "-bundle-systems"))
(define (remove-lisp-from-name name lisp)
(string-drop name (1+ (string-length lisp))))
(define (wrap-output-translations translations)
`(:output-translations
,@translations
:inherit-configuration))
(define (lisp-eval-program lisp program)
"Evaluate PROGRAM with a given LISP implementation."
(unless (zero? (apply system*
(lisp-invoke lisp (format #f "~S" program))))
(error "lisp-eval-program failed!" lisp program)))
(define (lisp-invoke lisp program)
"Return a list of arguments for system* determining how to invoke LISP
with PROGRAM."
(match lisp
("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))
(define (asdf-load-all systems)
(map (lambda (system)
`(funcall
(find-symbol
(symbol-name :load-system)
(symbol-name :asdf))
,system))
systems))
(define (compile-system system lisp asd-file)
"Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE
first if SYSTEM is defined there."
(lisp-eval-program lisp
`(progn
(require :asdf)
(in-package :asdf)
,@(if asd-file
`((load ,asd-file))
'())
(in-package :cl-user)
(funcall (find-symbol
(symbol-name :operate)
(symbol-name :asdf))
(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 (test-system system lisp asd-file)
"Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first
if SYSTEM is defined there."
(lisp-eval-program lisp
`(progn
(require :asdf)
(in-package :asdf)
,@(if asd-file
`((load ,asd-file))
'())
(in-package :cl-user)
(funcall (find-symbol
(symbol-name :test-system)
(symbol-name :asdf))
,system))))
(define (string->lisp-keyword . strings)
"Return a lisp keyword for the concatenation of STRINGS."
(string->symbol (apply string-append ":" strings)))
(define (generate-executable-for-system type system lisp)
"Use LISP to generate an executable, whose TYPE can be \"image\" or
\"program\". The latter will always be standalone. Depends on having created
a \"SYSTEM-exec\" system which contains the entry program."
(lisp-eval-program
lisp
`(progn
(require :asdf)
(funcall (find-symbol
(symbol-name :operate)
(symbol-name :asdf))
(find-symbol
(symbol-name ,(string->lisp-keyword type "-op"))
(symbol-name :asdf))
,(string-append system "-exec")))))
(define (generate-executable-wrapper-system system dependencies)
"Generates a system which can be used by asdf to produce an image or program
inside the current directory. The image or program will contain
DEPENDENCIES."
(with-output-to-file (string-append system "-exec.asd")
(lambda _
(format #t "~y~%"
`(defsystem ,(string->lisp-keyword system "-exec")
:entry-point ,(string-append system "-exec:main")
:depends-on (:uiop
,@(map string->lisp-keyword
dependencies))
:components ((:file ,(string-append system "-exec"))))))))
(define (generate-executable-entry-point system entry-program)
"Generates an entry point program from the list of lisp statements
ENTRY-PROGRAM for SYSTEM within the current directory."
(with-output-to-file (string-append system "-exec.lisp")
(lambda _
(let ((system (string->lisp-keyword system "-exec")))
(format #t "~{~y~%~%~}"
`((defpackage ,system
(:use :cl)
(:export :main))
(in-package ,system)
(defun main ()
(let ((arguments uiop:*command-line-arguments*))
(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)))
`(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 (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-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 (bundle-asd-file output-path original-asd-file lisp)
"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 lisp))))
(values (string-append bundle-asd-path "/" (basename original-asd-file))
bundle-asd-path)))
(define (replace-escaped-macros string)
"Replace simple lisp forms that the guile writer escapes, for example by
replacing #{#p}# with #p. Should only be used to replace truly simple forms
which are not nested."
(regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
'pre 2 'post))
(define (prepend-to-source-registry path)
(setenv "CL_SOURCE_REGISTRY"
(string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
(define* (build-program lisp program #:key inputs
(dependencies (list (basename program)))
entry-program
#:allow-other-keys)
"Generate an executable program containing all DEPENDENCIES, and which will
execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it
will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
has been bound to the command-line arguments which were passed."
(generate-executable lisp program
#:inputs inputs
#:dependencies dependencies
#:entry-program entry-program
#:type "program")
(let* ((name (basename program))
(bin-directory (dirname program)))
(with-directory-excursion bin-directory
(rename-file (string-append name "-exec")
name)))
#t)
(define* (build-image lisp image #:key inputs
(dependencies (list (basename image)))
#:allow-other-keys)
"Generate an image, possibly standalone, which contains all DEPENDENCIES,
placing the result in IMAGE.image."
(generate-executable lisp image
#:inputs inputs
#:dependencies dependencies
#:entry-program '(nil)
#:type "image")
(let* ((name (basename image))
(bin-directory (dirname image)))
(with-directory-excursion bin-directory
(rename-file (string-append name "-exec--all-systems.image")
(string-append name ".image"))))
#t)
(define* (generate-executable lisp out-file #:key inputs
dependencies
entry-program
type
#:allow-other-keys)
"Generate an executable by using asdf's TYPE-op, containing whithin the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
executable."
(let* ((bin-directory (dirname out-file))
(name (basename out-file)))
(mkdir-p bin-directory)
(with-directory-excursion bin-directory
(generate-executable-wrapper-system name dependencies)
(generate-executable-entry-point name entry-program))
(prepend-to-source-registry
(string-append bin-directory "/"))
(setenv "ASDF_OUTPUT_TRANSLATIONS"
(replace-escaped-macros
(format
#f "~S"
(wrap-output-translations
`(((,bin-directory :**/ :*.*.*)
(,bin-directory :**/ :*.*.*)))))))
(parameterize ((%lisp (string-append
(assoc-ref inputs lisp) "/bin/" lisp)))
(generate-executable-for-system type name lisp))
(delete-file (string-append bin-directory "/" name "-exec.asd"))
(delete-file (string-append bin-directory "/" name "-exec.lisp"))))