From mboxrd@z Thu Jan 1 00:00:00 1970 From: Andy Patterson Subject: [PATCH 01/12] build-system: Add asdf-build-system. Date: Tue, 27 Sep 2016 00:15:21 -0400 Message-ID: <20160927041532.27097-2-ajpatter@uwaterloo.ca> References: <20160927041532.27097-1-ajpatter@uwaterloo.ca> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:34721) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bojo9-00018g-2A for guix-devel@gnu.org; Tue, 27 Sep 2016 00:15:56 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bojo3-0002qt-Qu for guix-devel@gnu.org; Tue, 27 Sep 2016 00:15:51 -0400 Received: from mailservices.uwaterloo.ca ([129.97.128.141]:45644 helo=minos.uwaterloo.ca) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bojo3-0002pB-HY for guix-devel@gnu.org; Tue, 27 Sep 2016 00:15:47 -0400 In-Reply-To: <20160927041532.27097-1-ajpatter@uwaterloo.ca> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.org * 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 =3D \ 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 =3D \ 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 =3D \ 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 =20 @end defvr =20 +@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 =C2=A9 2016 Andy Patterson +;;; +;;; 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 (a= t +;;; 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 . + +(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 a= n +;; 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-specificatio= n->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 argument= s)))))) + +(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->se= xp + 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-sys= tem.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 =C2=A9 2016 Andy Patterson +;;; +;;; 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 (a= t +;;; 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 . + +(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 i= mages +;; 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 do= ne +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 on= ly +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=3D? 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 pa= ckage +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=3D> + (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 \"im= age\" +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=3D> + (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 th= e +image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM in the case of an +executable." + (and=3D> + (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 dependen= cy))) + 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 sys= tems + (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 =C2=A9 2016 Andy Patterson +;;; +;;; 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 (a= t +;;; 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 . + +(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 wrap= per +;;; systems for executables. Compile, test, and produce images for syste= ms 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 p= rogram +inside the current directory. The image or program will contain SYSTEM a= nd all +other DEPENDENCIES, which may not be depended on by the SYSTEM itself. S= YSTEM +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 depend= ent +systems from REGISTRY, an alist of the same form as %outputs, which cont= ains +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 l= isp) + "/" 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-M= ETHOD." + (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 con= vention +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/.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-fi= le)) + 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)) --=20 2.10.0