build-system: Add asdf-build-system.
* 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:
parent
53aec0999f
commit
a1b30f99a8
|
@ -63,6 +63,7 @@ MODULES = \
|
||||||
guix/build-system/ant.scm \
|
guix/build-system/ant.scm \
|
||||||
guix/build-system/cmake.scm \
|
guix/build-system/cmake.scm \
|
||||||
guix/build-system/emacs.scm \
|
guix/build-system/emacs.scm \
|
||||||
|
guix/build-system/asdf.scm \
|
||||||
guix/build-system/glib-or-gtk.scm \
|
guix/build-system/glib-or-gtk.scm \
|
||||||
guix/build-system/gnu.scm \
|
guix/build-system/gnu.scm \
|
||||||
guix/build-system/haskell.scm \
|
guix/build-system/haskell.scm \
|
||||||
|
@ -84,6 +85,7 @@ MODULES = \
|
||||||
guix/build/download.scm \
|
guix/build/download.scm \
|
||||||
guix/build/cmake-build-system.scm \
|
guix/build/cmake-build-system.scm \
|
||||||
guix/build/emacs-build-system.scm \
|
guix/build/emacs-build-system.scm \
|
||||||
|
guix/build/asdf-build-system.scm \
|
||||||
guix/build/git.scm \
|
guix/build/git.scm \
|
||||||
guix/build/hg.scm \
|
guix/build/hg.scm \
|
||||||
guix/build/glib-or-gtk-build-system.scm \
|
guix/build/glib-or-gtk-build-system.scm \
|
||||||
|
@ -106,6 +108,7 @@ MODULES = \
|
||||||
guix/build/syscalls.scm \
|
guix/build/syscalls.scm \
|
||||||
guix/build/gremlin.scm \
|
guix/build/gremlin.scm \
|
||||||
guix/build/emacs-utils.scm \
|
guix/build/emacs-utils.scm \
|
||||||
|
guix/build/lisp-utils.scm \
|
||||||
guix/build/graft.scm \
|
guix/build/graft.scm \
|
||||||
guix/build/bournish.scm \
|
guix/build/bournish.scm \
|
||||||
guix/build/qt-utils.scm \
|
guix/build/qt-utils.scm \
|
||||||
|
|
|
@ -2967,6 +2967,63 @@ that should be run during the @code{build} phase. By default the
|
||||||
|
|
||||||
@end defvr
|
@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
|
@defvr {Scheme Variable} cmake-build-system
|
||||||
This variable is exported by @code{(guix build-system cmake)}. It
|
This variable is exported by @code{(guix build-system cmake)}. It
|
||||||
implements the build procedure for packages using the
|
implements the build procedure for packages using the
|
||||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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"))))
|
Loading…
Reference in New Issue