From: Andy Patterson <ajpatter@uwaterloo.ca>
To: guix-devel@gnu.org
Subject: [PATCH 01/12] build-system: Add asdf-build-system.
Date: Tue, 27 Sep 2016 00:15:21 -0400 [thread overview]
Message-ID: <20160927041532.27097-2-ajpatter@uwaterloo.ca> (raw)
In-Reply-To: <20160927041532.27097-1-ajpatter@uwaterloo.ca>
* guix/build-system/asdf.scm: New file.
* guix/build/asdf-build-system.scm: New file.
* guix/build/lisp-utils.scm: New file.
* Makefile.am: Add them.
* doc/guix.texi: Add section on 'asdf-build-system/source'.
---
Makefile.am | 3 +
doc/guix.texi | 53 +++++
guix/build-system/asdf.scm | 231 ++++++++++++++++++++++
guix/build/asdf-build-system.scm | 417 +++++++++++++++++++++++++++++++++++++++
guix/build/lisp-utils.scm | 240 ++++++++++++++++++++++
5 files changed, 944 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 43a33c8..a23e5fd 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 808fbdc..8e9b510 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2965,6 +2965,59 @@ 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 sbcl)}, implement
+build procedures for Common Lisp packages using the
+@url{https://common-lisp.net/project/asdf/, ``ASDF''} system.
+
+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 conventions to determine the roles of inputs in
+the build system. For binary packages, the package itself as well as its
+dependencies should end their name with the lisp implementation, such as
+@code{-sbcl} for @code{asdf-build-system/sbcl}. Additionally, the
+corresponding source package should be labelled using the same name as
+the package, but with this suffix dropped. If it cannot be labelled that
+way, the label can be overriden by the @code{#:source-input} parameter.
+
+One package should be defined for each ASDF system.
+
+The package outputs control whether or not executable programs and
+images are built alongside the package's usual output, using the
+@code{bin} and @code{image} outputs, respectively.
+
+Packages can also be built which combine other packages into an
+executable program or image only, without building another
+system. Specifying one of the @code{#:binary?} or @code{#:image?}
+parameters will produce this behaviour.
+
+When building an executable program, the @code{#:entry-program}
+parameter, which should be a list of Common Lisp expressions, must be
+used to specify what program should be run. In this program,
+@code{arguments} will be bound to the command-line arguments passed.
+
+The @code{#:image-dependencies} parameter can be used to add packages to
+the pre-loaded systems included in the executable program or
+image. @code{#:compile-dependencies} specifies a list of additional
+systems which should be loaded before a system is compiled. If the
+package depends on special systems exported by the implementation
+itself, the @code{#:special-dependencies} parameter should be used to
+specify them.
+
+If a package must modify its source while building, the
+@code{build-in-tree} parameter can specify an output in which the source
+will be stored after the package has been built.
+
+@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
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
new file mode 100644
index 0000000..401708f
--- /dev/null
+++ b/guix/build-system/asdf.scm
@@ -0,0 +1,231 @@
+;;; 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 (guix build asdf-build-system)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (%asdf-build-system-modules
+ asdf-build
+ asdf-build-system/sbcl
+ asdf-build-system/ecl
+ asdf-build-system/source))
+
+;; Commentary:
+;;
+;; Standard build procedure for asdf packages. This is implemented as an
+;; extension of 'gnu-build-system'.
+;;
+;; Code:
+
+(define %asdf-build-system-modules
+ `((guix build asdf-build-system)
+ (guix build lisp-utils)
+ ,@%gnu-build-system-modules))
+
+(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 '((guix build asdf-build-system)
+ (guix build utils)
+ (guix build lisp-utils))))
+ (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 (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))
+
+ (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 ''())
+ (entry-program #f)
+ (image-dependencies ''())
+ (compile-dependencies ''())
+ (source-input #f)
+ (build-in-tree #f)
+ (image? #f)
+ (binary? #f)
+ (test-only-systems ''())
+ (lisp lisp-implementation)
+ (phases `(@ (guix build asdf-build-system)
+ ,(string->symbol
+ (string-append "%standard-phases/" lisp))))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %asdf-build-system-modules)
+ (modules '((guix build asdf-build-system)
+ (guix build utils)
+ (guix build lisp-utils))))
+
+ (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
+ #:entry-program ,entry-program
+ #:image-dependencies ,image-dependencies
+ #:compile-dependencies ,compile-dependencies
+ #:source-input ,source-input
+ #:build-in-tree ,build-in-tree
+ #:image? ,image?
+ #:binary? ,binary?
+ #: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)))
+
+;;; 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..7229f32
--- /dev/null
+++ b/guix/build/asdf-build-system.scm
@@ -0,0 +1,417 @@
+;;; 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)
+ #:export (%standard-phases/sbcl
+ %standard-phases/ecl
+ %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
+ (string-append %install-prefix "/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 (wrap-source-registry registry)
+ `(:source-registry
+ ,@registry
+ :inherit-configuration))
+
+(define (wrap-output-translations translations)
+ `(:output-translations
+ ,@translations
+ :inherit-configuration))
+
+(define (source-directory output name)
+ (string-append output %source-install-prefix "/" name))
+
+(define (library-directory output lisp)
+ (string-append output %object-prefix
+ "/" lisp))
+
+(define (output-translation source-output
+ source-name
+ object-output
+ lisp)
+ "Return a translation for the system's source output
+to it's binary output."
+ `((,(source-directory source-output source-name)
+ :**/ :*.*.*)
+ (,(library-directory object-output lisp)
+ :**/ :*.*.*)))
+
+(define (source-registry source-path)
+ `(:tree ,source-path))
+
+(define (lisp-dependency-names lisp inputs)
+ (map first (lisp-dependencies lisp inputs)))
+
+(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 build-in-tree lisp
+ image? binary?
+ #:allow-other-keys)
+ "Copy the source to the output named by BUILD-IN-TREE."
+ (when (and build-in-tree (not image?) (not binary?))
+ (let* ((out (assoc-ref outputs "out"))
+ (name (remove-lisp-from-name (output-path->package-name out) lisp)))
+ (copy-files-to-output outputs build-in-tree name)))
+ #t)
+
+(define* (build #:key outputs inputs lisp
+ compile-dependencies
+ source-input
+ build-in-tree
+ image?
+ binary?
+ #:allow-other-keys)
+ "Compile the system."
+
+ (unless (or binary? image?)
+ (let* ((out (assoc-ref outputs "out"))
+ (name (remove-lisp-from-name (output-path->package-name out) lisp))
+ (source (cond
+ (source-input
+ (assoc-ref inputs source-input))
+ (build-in-tree (assoc-ref outputs build-in-tree))
+ (else (assoc-ref inputs name))))
+ (source-name (or source-input name))
+ (source-path (string-append source %source-install-prefix "/"
+ source-name))
+ (translations (wrap-output-translations
+ `(,(output-translation source
+ source-name
+ out
+ lisp))))
+ (registry (map (match-lambda
+ ((_ . path) (source-registry path)))
+ (lisp-dependencies lisp inputs))))
+
+ (setenv "ASDF_OUTPUT_TRANSLATIONS"
+ (replace-escaped-macros (format #f "~S" translations)))
+ (setenv "CL_SOURCE_REGISTRY"
+ (replace-escaped-macros
+ (format #f "~S" (wrap-source-registry
+ `(,(source-registry source-path)
+ ,@registry)))))
+
+ (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 compile-dependencies))
+
+ ;; 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
+ compile-dependencies
+ image?
+ binary?
+ #:allow-other-keys)
+ "Test the system."
+
+ (if (and tests? (not image?) (not binary?))
+ (parameterize ((%lisp (string-append
+ (assoc-ref inputs lisp) "/bin/" lisp)))
+ (test-system
+ (remove-lisp-from-name (outputs->name outputs) lisp)
+ lisp
+ compile-dependencies))
+ (format #t "test suite not run~%"))
+ #t)
+
+(define* (patch-asd-files #:key outputs
+ inputs
+ lisp
+ special-dependencies
+ image?
+ binary?
+ 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."
+ (unless (or image? binary?)
+ (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
+ image? binary?
+ #:allow-other-keys)
+ "Create an extra reference to the system in a convenient location."
+ (unless (or image? binary?)
+ (let* ((out (assoc-ref outputs "out")))
+ (for-each
+ (lambda (asd-file)
+ (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)))
+
+ (find-files out "\\.asd$"))))
+ #t)
+
+(define* (generate-binary #:key outputs
+ inputs
+ image-dependencies
+ entry-program
+ lisp
+ binary?
+ #:allow-other-keys)
+ "Generate a binary program for the system, either in \"bin\" if the package
+also contains a library system, or in \"out\" otherwise."
+ (define output (if binary? "out" "bin"))
+ (generate-executable #:outputs outputs
+ #:inputs inputs
+ #:image-dependencies image-dependencies
+ #:entry-program entry-program
+ #:lisp lisp
+ #:output output
+ #:needs-own-system? (not binary?)
+ #:type "program")
+ (and=>
+ (assoc-ref outputs output)
+ (lambda (bin)
+ (let* ((full-name (outputs->name outputs))
+ (name (if binary? full-name
+ (remove-lisp-from-name full-name lisp)))
+ (bin-directory (string-append bin "/bin")))
+ (with-directory-excursion bin-directory
+ (rename-file (string-append name "-exec")
+ name)))))
+ #t)
+
+(define* (generate-image #:key outputs
+ inputs
+ image-dependencies
+ lisp
+ image?
+ #:allow-other-keys)
+ "Generate an image for the system, possibly standalone, either in \"image\"
+if the package also contains a library system, or in \"out\" otherwise."
+ (define output (if image? "out" "image"))
+ (generate-executable #:outputs outputs
+ #:inputs inputs
+ #:image-dependencies image-dependencies
+ #:entry-program '(nil)
+ #:lisp lisp
+ #:output output
+ #:needs-own-system? (not image?)
+ #:type "image")
+ (and=>
+ (assoc-ref outputs output)
+ (lambda (image)
+ (let* ((full-name (outputs->name outputs))
+ (name (if image? full-name
+ (remove-lisp-from-name full-name lisp)))
+ (bin-directory (string-append image "/bin")))
+ (with-directory-excursion bin-directory
+ (rename-file (string-append name "-exec--all-systems.image")
+ (string-append name ".image"))))))
+ #t)
+
+(define* (generate-executable #:key outputs
+ image-dependencies
+ entry-program
+ lisp
+ output
+ inputs
+ type
+ needs-own-system?
+ #:allow-other-keys)
+ "Generate an executable by using asdf's TYPE-op, containing whithin the
+image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM in the case of an
+executable."
+ (and=>
+ (assoc-ref outputs output)
+ (lambda (out)
+ (let* ((bin-directory (string-append out "/bin"))
+ (full-name (outputs->name outputs))
+ (name (if needs-own-system?
+ (remove-lisp-from-name full-name lisp)
+ full-name)))
+ (mkdir-p out)
+ (with-directory-excursion out
+ (generate-executable-wrapper-system name
+ image-dependencies
+ needs-own-system?)
+ (generate-executable-entry-point name entry-program))
+
+ (setenv "CL_SOURCE_REGISTRY"
+ (replace-escaped-macros
+ (format
+ #f "~S"
+ (wrap-source-registry
+ `(,(source-registry (assoc-ref outputs "out"))
+ ,(source-registry out)
+ ,@(map (lambda (dependency)
+ (source-registry (assoc-ref inputs dependency)))
+ image-dependencies))))))
+
+ (setenv "ASDF_OUTPUT_TRANSLATIONS"
+ (replace-escaped-macros
+ (format
+ #f "~S"
+ (wrap-output-translations
+ `(((,out :**/ :*.*.*)
+ (,bin-directory :**/ :*.*.*)))))))
+
+ (parameterize ((%lisp (string-append
+ (assoc-ref inputs lisp) "/bin/" lisp)))
+ (generate-executable-for-system type name lisp))
+
+ (delete-file (string-append out "/" name "-exec.asd"))
+ (delete-file (string-append out "/" name "-exec.lisp"))))))
+
+(define* (cleanup-files/sbcl #:key outputs binary? image? lisp
+ #:allow-other-keys)
+ "Remove any compiled files which are not a part of the final bundle."
+ (unless (or binary? image?)
+ (let ((out (assoc-ref outputs "out")))
+ (for-each
+ (lambda (file)
+ (unless (string-suffix? "--system.fasl" file)
+ (delete-file file)))
+ (find-files out "\\.fasl$"))))
+ #t)
+
+(define* (cleanup-files/ecl #:key outputs binary? image?
+ #:allow-other-keys)
+ "Remove any compiled files which are not a part of the final bundle."
+ (unless (or binary? image?)
+ (let ((out (assoc-ref outputs "out")))
+ (for-each delete-file
+ (append (find-files out "\\.fas$")
+ (find-files out "\\.o$")))))
+ #t)
+
+(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)
+ (add-after 'check 'link-dependencies patch-asd-files)
+ (add-after 'link-dependencies 'create-symlinks symlink-asd-files)
+ (add-after 'create-symlinks 'cleanup cleanup-files/sbcl)
+ (add-after 'cleanup 'generate-binary generate-binary)
+ (add-after 'generate-binary 'generate-image generate-image)))
+
+(define %standard-phases/sbcl
+ (modify-phases %standard-phases
+ ;; stripping sbcl binaries removes their entry program and extra systems
+ (delete 'strip)))
+
+(define %standard-phases/ecl
+ (modify-phases %standard-phases
+ (replace 'cleanup cleanup-files/ecl)))
+
+(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..33755f7
--- /dev/null
+++ b/guix/build/lisp-utils.scm
@@ -0,0 +1,240 @@
+;;; 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)
+ #: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))
+
+;;; 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
+ (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-right name (1+ (string-length lisp))))
+
+(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 other-required-systems)
+ "Use a lisp implementation to compile SYSTEM using asdf. Loads
+OTHER-REQUIRED-SYSTEMS before beginning compilation."
+ (lisp-eval-program lisp
+ `(progn
+ (require :asdf)
+ ,@(asdf-load-all other-required-systems)
+ (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 other-required-systems)
+ "Use a lisp implementation to test SYSTEM using asdf. Loads
+OTHER-REQUIRED-SYSTEMS before beginning to test."
+ (lisp-eval-program lisp
+ `(progn
+ (require :asdf)
+ ,@(asdf-load-all other-required-systems)
+ (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
+ needs-system?)
+ "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 SYSTEM and all
+other DEPENDENCIES, which may not be depended on by the SYSTEM itself. SYSTEM
+will be excluded unless NEEDS-SYSTEM? is #t."
+ (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
+ ,@(if needs-system?
+ `(,(string->lisp-keyword system))
+ '())
+ ,@(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-suffix? 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/lib/LISP/<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))
--
2.10.0
next prev parent reply other threads:[~2016-09-27 4:15 UTC|newest]
Thread overview: 51+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-09-27 4:15 [PATCH 0/12]: Add asdf-build-system Andy Patterson
2016-09-27 4:15 ` Andy Patterson [this message]
2016-09-27 4:15 ` [PATCH 02/12] gnu: Add alexandria Andy Patterson
2016-10-08 12:43 ` Ludovic Courtès
2016-09-27 4:15 ` [PATCH 03/12] gnu: Add fiveam Andy Patterson
2016-10-08 12:48 ` Ludovic Courtès
2016-09-27 4:15 ` [PATCH 04/12] gnu: Add bordeaux-threads Andy Patterson
2016-09-27 4:15 ` [PATCH 05/12] gnu: Add trivial-gray-streams Andy Patterson
2016-09-27 4:15 ` [PATCH 06/12] gnu: Add flexi-streams Andy Patterson
2016-09-27 4:15 ` [PATCH 07/12] gnu: Add cl-ppcre Andy Patterson
2016-09-27 4:15 ` [PATCH 08/12] gnu: Add clx Andy Patterson
2016-09-27 4:15 ` [PATCH 09/12] gnu: Add stumpwm Andy Patterson
2016-09-27 4:15 ` [PATCH 10/12] gnu: Add slynk Andy Patterson
2016-10-08 12:59 ` Ludovic Courtès
2016-09-27 4:15 ` [PATCH 11/12] gnu: Add stumpwm-with-slynk-sbcl Andy Patterson
2016-09-27 4:15 ` [PATCH 12/12] gnu: Add stumpwm-with-slynk-image-sbcl Andy Patterson
2016-09-27 12:51 ` [PATCH 0/12]: Add asdf-build-system James Richardson
2016-09-29 2:30 ` Andy Patterson
2016-09-30 11:45 ` 宋文武
2016-10-03 2:41 ` Andy Patterson
2016-10-03 2:41 ` [PATCH v2 00/13]: " Andy Patterson
2016-10-03 2:41 ` [PATCH v2 01/13] build-system: " Andy Patterson
2016-10-05 4:55 ` 宋文武
2016-10-05 20:59 ` Andy Patterson
2016-10-07 8:07 ` Andy Patterson
2016-10-07 8:07 ` Andy Patterson
2016-10-07 12:44 ` Ludovic Courtès
2016-10-07 21:57 ` Andy Patterson
2016-10-08 12:39 ` Ludovic Courtès
2016-10-03 2:41 ` [PATCH v2 02/13] gnu: sbcl: Honour XDG_DATA_DIRS Andy Patterson
2016-10-03 2:41 ` [PATCH v2 03/13] gnu: ecl: " Andy Patterson
2016-10-03 2:41 ` [PATCH v2 04/13] gnu: Add cl-alexandria Andy Patterson
2016-10-03 2:41 ` [PATCH v2 05/13] gnu: Add cl-fiveam Andy Patterson
2016-10-03 2:41 ` [PATCH v2 06/13] gnu: Add cl-bordeaux-threads Andy Patterson
2016-10-03 2:41 ` [PATCH v2 07/13] gnu: Add cl-trivial-gray-streams Andy Patterson
2016-10-03 2:41 ` [PATCH v2 08/13] gnu: Add cl-flexi-streams Andy Patterson
2016-10-03 2:41 ` [PATCH v2 09/13] gnu: Add cl-ppcre Andy Patterson
2016-10-03 2:41 ` [PATCH v2 10/13] gnu: Add cl-clx Andy Patterson
2016-10-03 2:41 ` [PATCH v2 11/13] gnu: Add cl-stumpwm Andy Patterson
2016-10-07 8:07 ` Andy Patterson
2016-10-03 2:41 ` [PATCH v2 12/13] gnu: Add cl-slynk Andy Patterson
2016-10-07 8:07 ` Andy Patterson
2016-10-03 2:41 ` [PATCH v2 13/13] gnu: Add sbcl-stumpwm-with-slynk Andy Patterson
2016-10-07 8:07 ` Andy Patterson
2016-10-06 21:04 ` [PATCH v2 00/13]: Add asdf-build-system Ludovic Courtès
2016-10-07 0:59 ` 宋文武
2016-10-08 13:30 ` 宋文武
2016-10-08 13:00 ` [PATCH 0/12]: " Ludovic Courtès
2016-10-08 13:28 ` 宋文武
2016-10-10 17:54 ` Andy Patterson
2016-10-10 17:47 ` Andy Patterson
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20160927041532.27097-2-ajpatter@uwaterloo.ca \
--to=ajpatter@uwaterloo.ca \
--cc=guix-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).