[PATCH v2 01/13] build-system: Add asdf-build-system.

[Andy Patterson <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                    |  60 ++++++
 guix/build-system/asdf.scm       | 385 +++++++++++++++++++++++++++++++++++++
 guix/build/asdf-build-system.scm | 400 +++++++++++++++++++++++++++++++++++++++
 guix/build/lisp-utils.scm        | 240 +++++++++++++++++++++++
 5 files changed, 1088 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 f5bbb92..53db367 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2965,6 +2965,66 @@ 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 begin their name with the lisp implementation,
+such as @code{sbcl-} for @code{asdf-build-system/sbcl}.  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 labelled using
+the same convention as python packages (see @ref{Python Modules}), using
+the @code{cl-} prefix.
+
+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.
+
+@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..eb8b7d9
--- /dev/null
+++ b/guix/build-system/asdf.scm
@@ -0,0 +1,385 @@
+;;; 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, a list 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/source
+                                 (build-system-name 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? (build-system-name from-build-system)
+         (build-system-name (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 #:entry-program
+                #:image-dependencies #:compile-dependencies #:image?
+                #:binary? #: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 ''())
+                  (entry-program #f)
+                  (image-dependencies ''())
+                  (compile-dependencies ''())
+                  (image? #f)
+                  (binary? #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
+                     #:entry-program ,entry-program
+                     #:image-dependencies ,image-dependencies
+                     #:compile-dependencies ,compile-dependencies
+                     #: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)))
+
+(define source-package->sbcl-package
+  (let* ((property 'sbcl-variant)
+         (transformer
+          (package-with-build-system asdf-build-system/source
+                                     asdf-build-system/sbcl
+                                     "cl-"
+                                     "sbcl-"
+                                     #:variant-property property
+                                     #:phases-transformer
+                                     'source-phases->sbcl-phases)))
+    (lambda (pkg)
+      (transformer
+       (strip-variant-as-necessary property pkg)))))
+
+(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..7554b54
--- /dev/null
+++ b/guix/build/asdf-build-system.scm
@@ -0,0 +1,400 @@
+;;; 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
+            %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 (wrap-source-registry registry)
+  `(:source-registry
+    ,@registry
+    :inherit-configuration))
+
+(define (wrap-output-translations translations)
+  `(:output-translations
+    ,@translations
+    :inherit-configuration))
+
+(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-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 lisp
+                      image? binary?
+                      #:allow-other-keys)
+  "Copy the source to \"out\"."
+  (unless (or binary? image?)
+    (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
+                compile-dependencies
+                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-path (lisp-source-directory out lisp name))
+           (translations (wrap-output-translations
+                          `(,(output-translation source-path
+                                                 out
+                                                 lisp)))))
+
+      (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))))))
+
+      (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 (string-append out %object-prefix) "\\.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))))))
+
+       (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 #: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")))
+      (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$")))))))
+  #t)
+
+(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)
+
+(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 'create-symlinks symlink-asd-files)
+    (add-after 'create-symlinks 'cleanup cleanup-files)
+    (add-after 'cleanup 'generate-binary generate-binary)
+    (add-after 'generate-binary 'generate-image generate-image)))
+
+(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..f67e38b
--- /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 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-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/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