[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [PATCH v2 01/13] build-system: Add asdf-build-system.
|
From: |
Andy Patterson |
|
Subject: |
Re: [PATCH v2 01/13] build-system: Add asdf-build-system. |
|
Date: |
Fri, 7 Oct 2016 17:57:08 -0400 |
Hi.
On Fri, 07 Oct 2016 14:44:38 +0200
address@hidden (Ludovic Courtès) wrote:
> Hello,
>
> Adding my 2¢ as 宋文武 suggested. :-)
>
> Andy Patterson <address@hidden> skribis:
>
> > +(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.
>
> This code seems to be adapted from ‘package-with-python2’. It seems
> that ‘package-input-rewriting’ is too specific to be used here, but at
> any rate, we should keep an eye towards factorizing this and keep it
> as simple as possible to facilitate that.
>
I'm not sure what the right abstraction is to encompass both.
> Is #:variant-property necessary here? It was necessary in
> ‘package-with-python2’ due to python-2 and python-3 packages sometimes
> having a different set of dependencies. If it can be avoided here,
> it’s better. Otherwise that’s fine.
>
It's necessary any time the variant package must differ from what the
transformer would ordinarily produce, so that a package which needs to
include the variant knows how to find it in the recursive step. In our
case, ecl packages may need different phases or outputs for binary
generation.
Also, the dependencies could differ, for example stumpwm used to use
the built-in clx on ecl.
>
> (I haven’t followed closely, so apologies if this has already been
> discussed.)
>
> Note: Two spaces after end-of-sentence period please. :-)
>
Ok, fixed that elsewhere as well.
> > + (define target-is-source? (eq? 'asdf/source
> > + (build-system-name
> > to-build-system)))
>
> Rather:
>
> (eq? ast-build-system/source to-build-system)
>
> The name is purely for debugging purposes.
>
Ok.
> > +(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)))
>
> Probably uppercase: SBCL, ECL, ASDF.
>
Sure.
> > +(define* (strip #:key lisp #:allow-other-keys #:rest args)
> > + ;; stripping sbcl binaries removes their entry program and extra
> > systems
> > + (unless (string=? lisp "sbcl")
> > + (apply (assoc-ref gnu:%standard-phases 'strip) args))
> > + #t)
>
> Shouldn’t it be:
>
> (or (string=? lisp "sbcl")
> (apply …))
>
> ? Otherwise the real return value is discarded.
>
Right.
> > +(define %lisp
> > + (make-parameter "lisp"))
>
> Add a comment like “File name of the Lisp compiler.” (?).
>
Ok.
> > +(define %install-prefix "/share/common-lisp")
>
> What about “lib/common-lisp” for architecture-dependent files
> (binaries)? What do other distros do?
>
Binaries are placed in /lib/<lisp>/. /share/common-lisp is just used
for source or symlinked .asd files (as is the convention). The other
distributions I've seen which package Common Lisp libraries (Debian and
Gentoo) do not distribute binaries for systems, and what they do is
basically equivalent to the asdf-build-system/source. I
think /lib/<lisp>/ is a good place for binaries, since the
implementations place their extra included system binaries there,
roughly (/lib/sbcl/contrib; /lib/ecl-<version>).
> That’s it.
>
Cool. Fixes attached inline. Are the packages also OK? I'd like to
start fixing any problems with those as well.
> Thank you!
>
> Ludo’.
Thanks for your comments.
--
Andy
From 3794fd653bd07496f9e538b27fe5e1b7795b88af Mon Sep 17 00:00:00 2001
From: Andy Patterson <address@hidden>
Date: Mon, 26 Sep 2016 20:11:54 -0400
Subject: [PATCH v4 01/12] 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'.
---
Makefile.am | 3 +
doc/guix.texi | 57 +++++++
guix/build-system/asdf.scm | 360 +++++++++++++++++++++++++++++++++++++++
guix/build/asdf-build-system.scm | 282 ++++++++++++++++++++++++++++++
guix/build/lisp-utils.scm | 327 +++++++++++++++++++++++++++++++++++
5 files changed, 1029 insertions(+)
create mode 100644 guix/build-system/asdf.scm
create mode 100644 guix/build/asdf-build-system.scm
create mode 100644 guix/build/lisp-utils.scm
diff --git a/Makefile.am b/Makefile.am
index 1690a94..7f2281c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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 \
diff --git a/doc/guix.texi b/doc/guix.texi
index 9bd8b43..2be589e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2967,6 +2967,63 @@ that should be run during the @code{build} phase. By
default the
@end defvr
address@hidden {Scheme Variable} asdf-build-system/source
address@hidden {Scheme Variable} asdf-build-system/sbcl
address@hidden {Scheme Variable} asdf-build-system/ecl
+
+These variables, exported by @code{(guix build-system asdf)}, implement
+build procedures for Common Lisp packages using
address@hidden://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
address@hidden/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,
+
address@hidden
+(define-public sbcl-bordeaux-threads
+ (package
+ ...
+ (native-inputs `(("tests:cl-fiveam" ,sbcl-fiveam)))
+ ...))
address@hidden 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.
+
address@hidden 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
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
new file mode 100644
index 0000000..f28c098
--- /dev/null
+++ b/guix/build-system/asdf.scm
@@ -0,0 +1,360 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <address@hidden>
+;;;
+;;; 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
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
new file mode 100644
index 0000000..085d073
--- /dev/null
+++ b/guix/build/asdf-build-system.scm
@@ -0,0 +1,282 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <address@hidden>
+;;;
+;;; 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
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
new file mode 100644
index 0000000..55a07c7
--- /dev/null
+++ b/guix/build/lisp-utils.scm
@@ -0,0 +1,327 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <address@hidden>
+;;;
+;;; 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"))))
--
2.10.0
- Re: [PATCH v2 12/13] gnu: Add cl-slynk., (continued)
Re: [PATCH v2 00/13]: Add asdf-build-system., Ludovic Courtès, 2016/10/06
Re: [PATCH v2 00/13]: Add asdf-build-system., 宋文武, 2016/10/08