10/28: build-system/asdf: Parameterize the lisp type and implementation globally.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository guix.

commit b4c9f0c50de39da253dadfde9e85de06d665cd1e
Author: Andy Patterson <address@hidden>
Date:   Mon Apr 3 09:01:27 2017 -0400

    build-system/asdf: Parameterize the lisp type and implementation globally.
    
    * guix/build-system/asdf.scm (asdf-build)[builder]: Parameterize %lisp-type
    and %lisp before invoking the build procedure. Don't pass #:lisp-type as an
    argument to said procedure.
    * guix/build/asdf-build-system.scm: Adjust accordingly.
    (source-install-prefix): Rename to %lisp-source-install-prefix.
    * guix/build/lisp-utils.scm: Adjust accordingly.
    (%lisp-type): New parameter.
    (bundle-install-prefix): Rename to %bundle-install-prefix.
    * gnu/packages/lisp.scm: Adjust accordingly.
---
 gnu/packages/lisp.scm            |  23 ++++---
 guix/build-system/asdf.scm       |  33 +++++-----
 guix/build/asdf-build-system.scm |  74 ++++++++++-----------
 guix/build/lisp-utils.scm        | 135 +++++++++++++++++++--------------------
 4 files changed, 128 insertions(+), 137 deletions(-)

diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm
index aedb245..ed8a043 100644
--- a/gnu/packages/lisp.scm
+++ b/gnu/packages/lisp.scm
@@ -856,11 +856,9 @@ from other CLXes around the net.")
      '(#:phases
        (modify-phases %standard-phases
          (add-after 'create-symlinks 'build-program
-           (lambda* (#:key lisp-type outputs inputs #:allow-other-keys)
+           (lambda* (#:key outputs #:allow-other-keys)
              (build-program
-              lisp-type
               (string-append (assoc-ref outputs "out") "/bin/stumpwm")
-              #:inputs inputs
               #:entry-program '((stumpwm:stumpwm) 0))))
          (add-after 'build-program 'create-desktop-file
            (lambda* (#:key outputs #:allow-other-keys)
@@ -1103,12 +1101,14 @@ multiple inspectors with independent history.")
 
          (prepend-to-source-registry
           (string-append (assoc-ref %outputs "out") "//"))
-         (build-image "sbcl"
-                      (string-append
-                       (assoc-ref %outputs "image")
-                       "/bin/slynk")
-                      #:inputs %build-inputs
-                      #:dependencies ',slynk-systems))))))
+
+         (parameterize ((%lisp-type "sbcl")
+                        (%lisp (string-append (assoc-ref %build-inputs "sbcl")
+                                              "/bin/sbcl")))
+           (build-image (string-append
+                         (assoc-ref %outputs "image")
+                         "/bin/slynk")
+                        #:dependencies ',slynk-systems)))))))
 
 (define-public ecl-slynk
   (package
@@ -1145,11 +1145,10 @@ multiple inspectors with independent history.")
        ((#:phases phases)
         `(modify-phases ,phases
            (replace 'build-program
-             (lambda* (#:key lisp-type inputs outputs #:allow-other-keys)
+             (lambda* (#:key outputs #:allow-other-keys)
                (let* ((out (assoc-ref outputs "out"))
                       (program (string-append out "/bin/stumpwm")))
-                 (build-program lisp-type program
-                                #:inputs inputs
+                 (build-program program
                                 #:entry-program '((stumpwm:stumpwm) 0)
                                 #:dependencies '("stumpwm"
                                                  ,@slynk-systems))
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index 1ef6f32..4afc6ef 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -273,21 +273,24 @@ set up using CL source package conventions."
     (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-type ,lisp-type
-                     #:asd-file ,asd-file
-                     #:system ,system
-                     #:tests? ,tests?
-                     #:phases ,phases
-                     #:outputs %outputs
-                     #:search-paths ',(map search-path-specification->sexp
-                                           search-paths)
-                     #:inputs %build-inputs)))
+         (parameterize ((%lisp (string-append
+                                (assoc-ref %build-inputs ,lisp-type)
+                                "/bin/" ,lisp-type))
+                        (%lisp-type ,lisp-type))
+           (asdf-build #:name ,name
+                       #:source ,(match (assoc-ref inputs "source")
+                                   (((? derivation? source))
+                                    (derivation->output-path source))
+                                   ((source) source)
+                                   (source source))
+                       #:asd-file ,asd-file
+                       #: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
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index c5f2c08..4305a86 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -43,8 +43,8 @@
 
 (define %object-prefix "/lib")
 
-(define (source-install-prefix lisp)
-  (string-append %source-install-prefix "/" lisp "-source"))
+(define (%lisp-source-install-prefix)
+  (string-append %source-install-prefix "/" (%lisp-type) "-source"))
 
 (define %system-install-prefix
   (string-append %source-install-prefix "/systems"))
@@ -56,28 +56,27 @@
   (output-path->package-name
    (assoc-ref outputs "out")))
 
-(define (lisp-source-directory output lisp name)
-  (string-append output (source-install-prefix lisp) "/" name))
+(define (lisp-source-directory output name)
+  (string-append output (%lisp-source-install-prefix) "/" name))
 
 (define (source-directory output name)
   (string-append output %source-install-prefix "/source/" name))
 
-(define (library-directory output lisp)
+(define (library-directory output)
   (string-append output %object-prefix
-                 "/" lisp))
+                 "/" (%lisp-type)))
 
 (define (output-translation source-path
-                            object-output
-                            lisp)
+                            object-output)
   "Return a translation for the system's source path
 to it's binary output."
   `((,source-path
      :**/ :*.*.*)
-    (,(library-directory object-output lisp)
+    (,(library-directory object-output)
      :**/ :*.*.*)))
 
-(define (source-asd-file output lisp name asd-file)
-  (string-append (lisp-source-directory output lisp name) "/" asd-file))
+(define (source-asd-file output name asd-file)
+  (string-append (lisp-source-directory output name) "/" asd-file))
 
 (define (library-output outputs)
   "If a `lib' output exists, build things there. Otherwise use `out'."
@@ -104,32 +103,29 @@ valid."
   "Copy and symlink all the source files."
   (copy-files-to-output (assoc-ref outputs "out") (outputs->name outputs)))
 
-(define* (copy-source #:key outputs lisp-type #:allow-other-keys)
+(define* (copy-source #:key outputs #:allow-other-keys)
   "Copy the source to the library output."
   (let* ((out (library-output outputs))
-         (name (remove-lisp-from-name (output-path->package-name out)
-                                      lisp-type))
+         (name (remove-lisp-from-name (output-path->package-name out)))
          (install-path (string-append out %source-install-prefix)))
     (copy-files-to-output out name)
     ;; Hide the files from asdf
     (with-directory-excursion install-path
-      (rename-file "source" (string-append lisp-type "-source"))
+      (rename-file "source" (string-append (%lisp-type) "-source"))
       (delete-file-recursively "systems")))
   #t)
 
-(define* (build #:key outputs inputs lisp-type asd-file
+(define* (build #:key outputs inputs asd-file
                 #:allow-other-keys)
   "Compile the system."
   (let* ((out (library-output outputs))
-         (name (remove-lisp-from-name (output-path->package-name out)
-                                      lisp-type))
-         (source-path (lisp-source-directory out lisp-type name))
+         (name (remove-lisp-from-name (output-path->package-name out)))
+         (source-path (lisp-source-directory out name))
          (translations (wrap-output-translations
                         `(,(output-translation source-path
-                                               out
-                                               lisp-type))))
+                                               out))))
          (asd-file (and=> asd-file
-                          (cut source-asd-file out lisp-type name <>))))
+                          (cut source-asd-file out name <>))))
 
     (setenv "ASDF_OUTPUT_TRANSLATIONS"
             (replace-escaped-macros (format #f "~S" translations)))
@@ -141,9 +137,7 @@ valid."
 
     (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
 
-    (parameterize ((%lisp (string-append
-                           (assoc-ref inputs lisp-type) "/bin/" lisp-type)))
-      (compile-system name lisp-type asd-file))
+    (compile-system name asd-file)
 
     ;; As above, ecl will sometimes create this even though it doesn't use it
 
@@ -152,48 +146,44 @@ valid."
         (delete-file-recursively cache-directory))))
   #t)
 
-(define* (check #:key lisp-type tests? outputs inputs asd-file
+(define* (check #:key tests? outputs inputs asd-file
                 #:allow-other-keys)
   "Test the system."
-  (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp-type))
+  (let* ((name (remove-lisp-from-name (outputs->name outputs)))
          (out (library-output outputs))
          (asd-file (and=> asd-file
-                          (cut source-asd-file out lisp-type name <>))))
+                          (cut source-asd-file out name <>))))
     (if tests?
-        (parameterize ((%lisp (string-append
-                               (assoc-ref inputs lisp-type) "/bin/" 
lisp-type)))
-          (test-system name lisp-type asd-file))
+        (test-system name asd-file)
         (format #t "test suite not run~%")))
   #t)
 
 (define* (create-asd-file #:key outputs
                           inputs
-                          lisp-type
                           asd-file
                           #:allow-other-keys)
   "Create a system definition file for the built system."
   (let*-values (((out) (library-output outputs))
                 ((full-name version) (package-name->name+version
                                       (strip-store-file-name out)))
-                ((name) (remove-lisp-from-name full-name lisp-type))
-                ((new-asd-file) (string-append (library-directory out 
lisp-type)
+                ((name) (remove-lisp-from-name full-name))
+                ((new-asd-file) (string-append (library-directory out)
                                                "/" name ".asd")))
 
     (make-asd-file new-asd-file
-                   #:lisp lisp-type
                    #:system name
                    #:version version
                    #:inputs inputs
                    #:system-asd-file asd-file))
   #t)
 
-(define* (symlink-asd-files #:key outputs lisp-type #:allow-other-keys)
+(define* (symlink-asd-files #:key outputs #:allow-other-keys)
   "Create an extra reference to the system in a convenient location."
   (let* ((out (library-output outputs)))
     (for-each
      (lambda (asd-file)
        (receive (new-asd-file asd-file-directory)
-           (bundle-asd-file out asd-file lisp-type)
+           (bundle-asd-file out asd-file)
          (mkdir-p asd-file-directory)
          (symlink asd-file new-asd-file)
          ;; Update the source registry for future phases which might want to
@@ -204,11 +194,11 @@ valid."
      (find-files (string-append out %object-prefix) "\\.asd$")))
   #t)
 
-(define* (cleanup-files #:key outputs lisp-type
+(define* (cleanup-files #:key outputs
                         #:allow-other-keys)
   "Remove any compiled files which are not a part of the final bundle."
   (let ((out (library-output outputs)))
-    (match lisp-type
+    (match (%lisp-type)
       ("sbcl"
        (for-each
         (lambda (file)
@@ -220,7 +210,7 @@ valid."
                  (append (find-files out "\\.fas$")
                          (find-files out "\\.o$")))))
 
-    (with-directory-excursion (library-directory out lisp-type)
+    (with-directory-excursion (library-directory out)
       (for-each
        (lambda (file)
          (rename-file file
@@ -235,9 +225,9 @@ valid."
                             (string<> ".." file)))))))
   #t)
 
-(define* (strip #:key lisp-type #:allow-other-keys #:rest args)
+(define* (strip #:rest args)
   ;; stripping sbcl binaries removes their entry program and extra systems
-  (or (string=? lisp-type "sbcl")
+  (or (string=? (%lisp-type) "sbcl")
       (apply (assoc-ref gnu:%standard-phases 'strip) args)))
 
 (define %standard-phases/source
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 4f1565b..148357b 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (guix build utils)
   #:export (%lisp
+            %lisp-type
             %source-install-prefix
             lisp-eval-program
             compile-system
@@ -33,7 +34,7 @@
             generate-executable-wrapper-system
             generate-executable-entry-point
             generate-executable-for-system
-            bundle-install-prefix
+            %bundle-install-prefix
             bundle-asd-file
             remove-lisp-from-name
             wrap-output-translations
@@ -54,24 +55,28 @@
   ;; File name of the Lisp compiler.
   (make-parameter "lisp"))
 
+(define %lisp-type
+  ;; String representing the class of implementation being used.
+  (make-parameter "lisp"))
+
 ;; The common parent for Lisp source files, as will as the symbolic
 ;; link farm for system definition (.asd) files.
 (define %source-install-prefix "/share/common-lisp")
 
-(define (bundle-install-prefix lisp)
-  (string-append %source-install-prefix "/" lisp "-bundle-systems"))
+(define (%bundle-install-prefix)
+  (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
 
 (define (remove-lisp-from-name name lisp)
   (string-drop name (1+ (string-length lisp))))
 
-(define (inputs->asd-file-map inputs lisp)
+(define (inputs->asd-file-map inputs)
   "Produce a hash table of the form (system . asd-file), where system is the
 name of an ASD system, and asd-file is the full path to its definition."
   (alist->hash-table
    (filter-map
     (match-lambda
       ((_ . path)
-       (let ((prefix (string-append path (bundle-install-prefix lisp))))
+       (let ((prefix (string-append path (%bundle-install-prefix))))
          (and (directory-exists? prefix)
               (match (find-files prefix "\\.asd$")
                 ((asd-file)
@@ -86,16 +91,16 @@ name of an ASD system, and asd-file is the full path to its 
definition."
     ,@translations
     :inherit-configuration))
 
-(define (lisp-eval-program lisp program)
+(define (lisp-eval-program 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)))
+                        (lisp-invoke (format #f "~S" program))))
+    (error "lisp-eval-program failed!" (%lisp) program)))
 
-(define (lisp-invoke lisp program)
+(define (lisp-invoke program)
   "Return a list of arguments for system* determining how to invoke LISP
 with PROGRAM."
-  (match lisp
+  (match (%lisp-type)
     ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
     ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))
     (_ (error "The LISP provided is not supported at this time."))))
@@ -109,26 +114,26 @@ with PROGRAM."
            ,system))
        systems))
 
-(define (compile-system system lisp asd-file)
+(define (compile-system system 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))))
-
-(define (system-dependencies lisp system asd-file)
+  (lisp-eval-program
+   `(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))))
+
+(define (system-dependencies system asd-file)
   "Return the dependencies of SYSTEM, as reported by
 asdf:system-depends-on.  First load the system's ASD-FILE, if necessary."
   (define deps-file ".deps.sexp")
@@ -157,56 +162,55 @@ asdf:system-depends-on.  First load the system's 
ASD-FILE, if necessary."
 
   (dynamic-wind
     (lambda _
-      (lisp-eval-program lisp program))
+      (lisp-eval-program program))
     (lambda _
       (call-with-input-file deps-file read))
     (lambda _
       (when (file-exists? deps-file)
         (delete-file deps-file)))))
 
-(define (compiled-system system lisp)
-  (match lisp
+(define (compiled-system system)
+  (match (%lisp-type)
     ("sbcl" (string-append system "--system"))
     (_ system)))
 
-(define* (generate-system-definition lisp system
+(define* (generate-system-definition system
                                      #:key version dependencies)
   `(asdf:defsystem
     ,system
     :class asdf/bundle:prebuilt-system
     :version ,version
     :depends-on ,dependencies
-    :components ((:compiled-file ,(compiled-system system lisp)))
-    ,@(if (string=? "ecl" lisp)
+    :components ((:compiled-file ,(compiled-system system)))
+    ,@(if (string=? "ecl" (%lisp-type))
           `(:lib ,(string-append system ".a"))
           '())))
 
-(define (test-system system lisp asd-file)
+(define (test-system system 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))))
+  (lisp-eval-program
+   `(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)
+(define (generate-executable-for-system type system)
   "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
@@ -249,7 +253,7 @@ ENTRY-PROGRAM for SYSTEM within the current directory."
                       (declare (ignorable arguments))
                       ,@entry-program))))))))
 
-(define (generate-dependency-links lisp registry system)
+(define (generate-dependency-links registry system)
   "Creates a program which populates asdf's source registry from REGISTRY, an
 alist of dependency names to corresponding asd files.  This allows the system
 to locate its dependent systems."
@@ -265,16 +269,15 @@ to locate its dependent systems."
            registry)))
 
 (define* (make-asd-file asd-file
-                        #:key lisp system version inputs
+                        #:key system version inputs
                         (system-asd-file #f))
   "Create an ASD-FILE for address@hidden, appending a program to allow the
 system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
   (define dependencies
-    (parameterize ((%lisp (string-append (assoc-ref inputs lisp) "/bin/" 
lisp)))
-      (system-dependencies lisp system system-asd-file)))
+    (system-dependencies system system-asd-file))
 
   (define lisp-input-map
-    (inputs->asd-file-map inputs lisp))
+    (inputs->asd-file-map inputs))
 
   (define registry
     (filter-map hash-get-handle
@@ -291,18 +294,18 @@ system to find its dependencies, as described by 
GENERATE-DEPENDENCY-LINKS."
       (display
        (replace-escaped-macros
         (format #f "~y~%~y~%"
-                (generate-system-definition lisp system
+                (generate-system-definition system
                                             #:version version
                                             #:dependencies dependencies)
-                (generate-dependency-links lisp registry system)))
+                (generate-dependency-links registry system)))
        port))))
 
-(define (bundle-asd-file output-path original-asd-file lisp)
+(define (bundle-asd-file output-path original-asd-file)
   "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
 OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd.  Returns two
 values: the asd file itself and the directory in which it resides."
   (let ((bundle-asd-path (string-append output-path
-                                        (bundle-install-prefix lisp))))
+                                        (%bundle-install-prefix))))
     (values (string-append bundle-asd-path "/" (basename original-asd-file))
             bundle-asd-path)))
 
@@ -317,7 +320,7 @@ which are not nested."
   (setenv "CL_SOURCE_REGISTRY"
           (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
 
-(define* (build-program lisp program #:key inputs
+(define* (build-program program #:key
                         (dependencies (list (basename program)))
                         entry-program
                         #:allow-other-keys)
@@ -325,8 +328,7 @@ which are not nested."
 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
+  (generate-executable program
                        #:dependencies dependencies
                        #:entry-program entry-program
                        #:type "program")
@@ -337,13 +339,12 @@ has been bound to the command-line arguments which were 
passed."
                    name)))
   #t)
 
-(define* (build-image lisp image #:key inputs
+(define* (build-image image #:key
                       (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
+  (generate-executable image
                        #:dependencies dependencies
                        #:entry-program '(nil)
                        #:type "image")
@@ -354,7 +355,7 @@ placing the result in IMAGE.image."
                    (string-append name ".image"))))
   #t)
 
-(define* (generate-executable lisp out-file #:key inputs
+(define* (generate-executable out-file #:key
                               dependencies
                               entry-program
                               type
@@ -380,9 +381,7 @@ executable."
                `(((,bin-directory :**/ :*.*.*)
                   (,bin-directory :**/ :*.*.*)))))))
 
-    (parameterize ((%lisp (string-append
-                           (assoc-ref inputs lisp) "/bin/" lisp)))
-      (generate-executable-for-system type name lisp))
+    (generate-executable-for-system type name)
 
     (delete-file (string-append bin-directory "/" name "-exec.asd"))
     (delete-file (string-append bin-directory "/" name "-exec.lisp"))))