From a1b30f99a87b497ddc4ee5d6e50dc465ebb13f19 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Fri, 7 Oct 2016 17:57:08 -0400 Subject: build-system: Add asdf-build-system. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build-system/asdf.scm: New file. * guix/build/asdf-build-system.scm: New file. * guix/build/lisp-utils.scm: New file. * Makefile.am (MODULES): Add them. * doc/guix.texi (Build Systems): Document 'asdf-build-system'. Signed-off-by: 宋文武 --- guix/build/lisp-utils.scm | 327 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 327 insertions(+) create mode 100644 guix/build/lisp-utils.scm (limited to 'guix/build/lisp-utils.scm') diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm new file mode 100644 index 0000000000..55a07c7207 --- /dev/null +++ b/guix/build/lisp-utils.scm @@ -0,0 +1,327 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 (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 . + +(define-module (guix build lisp-utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (guix build utils) + #:export (%lisp + %install-prefix + lisp-eval-program + compile-system + test-system + replace-escaped-macros + generate-executable-wrapper-system + generate-executable-entry-point + generate-executable-for-system + patch-asd-file + bundle-install-prefix + lisp-dependencies + bundle-asd-file + remove-lisp-from-name + wrap-output-translations + prepend-to-source-registry + build-program + build-image)) + +;;; Commentary: +;;; +;;; Tools to evaluate lisp programs within a lisp session, generate wrapper +;;; systems for executables. Compile, test, and produce images for systems and +;;; programs, and link them with their dependencies. +;;; +;;; Code: + +(define %lisp + ;; File name of the Lisp compiler. + (make-parameter "lisp")) + +(define %install-prefix "/share/common-lisp") + +(define (bundle-install-prefix lisp) + (string-append %install-prefix "/" lisp "-bundle-systems")) + +(define (remove-lisp-from-name name lisp) + (string-drop name (1+ (string-length lisp)))) + +(define (wrap-output-translations translations) + `(:output-translations + ,@translations + :inherit-configuration)) + +(define (lisp-eval-program lisp program) + "Evaluate PROGRAM with a given LISP implementation." + (unless (zero? (apply system* + (lisp-invoke lisp (format #f "~S" program)))) + (error "lisp-eval-program failed!" lisp program))) + +(define (lisp-invoke lisp program) + "Return a list of arguments for system* determining how to invoke LISP +with PROGRAM." + (match lisp + ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program)) + ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")))) + +(define (asdf-load-all systems) + (map (lambda (system) + `(funcall + (find-symbol + (symbol-name :load-system) + (symbol-name :asdf)) + ,system)) + systems)) + +(define (compile-system system lisp asd-file) + "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE +first if SYSTEM is defined there." + (lisp-eval-program lisp + `(progn + (require :asdf) + (in-package :asdf) + ,@(if asd-file + `((load ,asd-file)) + '()) + (in-package :cl-user) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name :compile-bundle-op) + (symbol-name :asdf)) + ,system) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name :deliver-asd-op) + (symbol-name :asdf)) + ,system)))) + +(define (test-system system lisp asd-file) + "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first +if SYSTEM is defined there." + (lisp-eval-program lisp + `(progn + (require :asdf) + (in-package :asdf) + ,@(if asd-file + `((load ,asd-file)) + '()) + (in-package :cl-user) + (funcall (find-symbol + (symbol-name :test-system) + (symbol-name :asdf)) + ,system)))) + +(define (string->lisp-keyword . strings) + "Return a lisp keyword for the concatenation of STRINGS." + (string->symbol (apply string-append ":" strings))) + +(define (generate-executable-for-system type system lisp) + "Use LISP to generate an executable, whose TYPE can be \"image\" or +\"program\". The latter will always be standalone. Depends on having created +a \"SYSTEM-exec\" system which contains the entry program." + (lisp-eval-program + lisp + `(progn + (require :asdf) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name ,(string->lisp-keyword type "-op")) + (symbol-name :asdf)) + ,(string-append system "-exec"))))) + +(define (generate-executable-wrapper-system system dependencies) + "Generates a system which can be used by asdf to produce an image or program +inside the current directory. The image or program will contain +DEPENDENCIES." + (with-output-to-file (string-append system "-exec.asd") + (lambda _ + (format #t "~y~%" + `(defsystem ,(string->lisp-keyword system "-exec") + :entry-point ,(string-append system "-exec:main") + :depends-on (:uiop + ,@(map string->lisp-keyword + dependencies)) + :components ((:file ,(string-append system "-exec")))))))) + +(define (generate-executable-entry-point system entry-program) + "Generates an entry point program from the list of lisp statements +ENTRY-PROGRAM for SYSTEM within the current directory." + (with-output-to-file (string-append system "-exec.lisp") + (lambda _ + (let ((system (string->lisp-keyword system "-exec"))) + (format #t "~{~y~%~%~}" + `((defpackage ,system + (:use :cl) + (:export :main)) + + (in-package ,system) + + (defun main () + (let ((arguments uiop:*command-line-arguments*)) + (declare (ignorable arguments)) + ,@entry-program)))))))) + +(define (wrap-perform-method lisp registry dependencies file-name) + "Creates a wrapper method which allows the system to locate its dependent +systems from REGISTRY, an alist of the same form as %outputs, which contains +lisp systems which the systems is dependent on. All DEPENDENCIES which the +system depends on will the be loaded before this system." + (let* ((system (string-drop-right (basename file-name) 4)) + (system-symbol (string->lisp-keyword system))) + + `(defmethod asdf:perform :before + (op (c (eql (asdf:find-system ,system-symbol)))) + (asdf/source-registry:ensure-source-registry) + ,@(map (match-lambda + ((name . path) + (let ((asd-file (string-append path + (bundle-install-prefix lisp) + "/" name ".asd"))) + `(setf + (gethash ,name + asdf/source-registry:*source-registry*) + ,(string->symbol "#p") + ,(bundle-asd-file path asd-file lisp))))) + registry) + ,@(map (lambda (system) + `(asdf:load-system ,(string->lisp-keyword system))) + dependencies)))) + +(define (patch-asd-file asd-file registry lisp dependencies) + "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD." + (chmod asd-file #o644) + (let ((port (open-file asd-file "a"))) + (dynamic-wind + (lambda _ #t) + (lambda _ + (display + (replace-escaped-macros + (format #f "~%~y~%" + (wrap-perform-method lisp registry + dependencies asd-file))) + port)) + (lambda _ (close-port port)))) + (chmod asd-file #o444)) + +(define (lisp-dependencies lisp inputs) + "Determine which inputs are lisp system dependencies, by using the convention +that a lisp system dependency will resemble \"system-LISP\"." + (filter-map (match-lambda + ((name . value) + (and (string-prefix? lisp name) + (string<> lisp name) + `(,(remove-lisp-from-name name lisp) + . ,value)))) + inputs)) + +(define (bundle-asd-file output-path original-asd-file lisp) + "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in +OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/.asd. Returns two +values: the asd file itself and the directory in which it resides." + (let ((bundle-asd-path (string-append output-path + (bundle-install-prefix lisp)))) + (values (string-append bundle-asd-path "/" (basename original-asd-file)) + bundle-asd-path))) + +(define (replace-escaped-macros string) + "Replace simple lisp forms that the guile writer escapes, for example by +replacing #{#p}# with #p. Should only be used to replace truly simple forms +which are not nested." + (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string + 'pre 2 'post)) + +(define (prepend-to-source-registry path) + (setenv "CL_SOURCE_REGISTRY" + (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") "")))) + +(define* (build-program lisp program #:key inputs + (dependencies (list (basename program))) + entry-program + #:allow-other-keys) + "Generate an executable program containing all DEPENDENCIES, and which will +execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it +will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments' +has been bound to the command-line arguments which were passed." + (generate-executable lisp program + #:inputs inputs + #:dependencies dependencies + #:entry-program entry-program + #:type "program") + (let* ((name (basename program)) + (bin-directory (dirname program))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec") + name))) + #t) + +(define* (build-image lisp image #:key inputs + (dependencies (list (basename image))) + #:allow-other-keys) + "Generate an image, possibly standalone, which contains all DEPENDENCIES, +placing the result in IMAGE.image." + (generate-executable lisp image + #:inputs inputs + #:dependencies dependencies + #:entry-program '(nil) + #:type "image") + (let* ((name (basename image)) + (bin-directory (dirname image))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec--all-systems.image") + (string-append name ".image")))) + #t) + +(define* (generate-executable lisp out-file #:key inputs + dependencies + entry-program + type + #:allow-other-keys) + "Generate an executable by using asdf's TYPE-op, containing whithin the +image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an +executable." + (let* ((bin-directory (dirname out-file)) + (name (basename out-file))) + (mkdir-p bin-directory) + (with-directory-excursion bin-directory + (generate-executable-wrapper-system name dependencies) + (generate-executable-entry-point name entry-program)) + + (prepend-to-source-registry + (string-append bin-directory "/")) + + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros + (format + #f "~S" + (wrap-output-translations + `(((,bin-directory :**/ :*.*.*) + (,bin-directory :**/ :*.*.*))))))) + + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (generate-executable-for-system type name lisp)) + + (delete-file (string-append bin-directory "/" name "-exec.asd")) + (delete-file (string-append bin-directory "/" name "-exec.lisp")))) -- cgit v1.2.3