guix/gexp.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
   4 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix gexp)
  23   #:use-module (guix store)
  24   #:use-module (guix monads)
  25   #:use-module (guix derivations)
  26   #:use-module (guix grafts)
  27   #:use-module (guix utils)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-9)
  31   #:use-module (srfi srfi-9 gnu)
  32   #:use-module (srfi srfi-26)
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-35)
  35   #:use-module (ice-9 match)
  36   #:export (gexp
  37             gexp?
  38             with-imported-modules
  39             with-extensions
  40
  41             gexp-input
  42             gexp-input?
  43             gexp-input-thing
  44             gexp-input-output
  45             gexp-input-native?
  46
  47             local-file
  48             local-file?
  49             local-file-file
  50             local-file-absolute-file-name
  51             local-file-name
  52             local-file-recursive?
  53
  54             plain-file
  55             plain-file?
  56             plain-file-name
  57             plain-file-content
  58
  59             computed-file
  60             computed-file?
  61             computed-file-name
  62             computed-file-gexp
  63             computed-file-options
  64
  65             program-file
  66             program-file?
  67             program-file-name
  68             program-file-gexp
  69             program-file-guile
  70             program-file-module-path
  71
  72             scheme-file
  73             scheme-file?
  74             scheme-file-name
  75             scheme-file-gexp
  76
  77             file-append
  78             file-append?
  79             file-append-base
  80             file-append-suffix
  81
  82             raw-derivation-file
  83             raw-derivation-file?
  84
  85             with-parameters
  86             parameterized?
  87
  88             load-path-expression
  89             gexp-modules
  90
  91             lower-gexp
  92             lowered-gexp?
  93             lowered-gexp-sexp
  94             lowered-gexp-inputs
  95             lowered-gexp-sources
  96             lowered-gexp-guile
  97             lowered-gexp-load-path
  98             lowered-gexp-load-compiled-path
  99
 100             gexp->derivation
 101             gexp->file
 102             gexp->script
 103             text-file*
 104             mixed-text-file
 105             file-union
 106             directory-union
 107             imported-files
 108             imported-modules
 109             compiled-modules
 110
 111             define-gexp-compiler
 112             gexp-compiler?
 113             file-like?
 114             lower-object
 115
 116             lower-inputs
 117
 118             &gexp-error
 119             gexp-error?
 120             &gexp-input-error
 121             gexp-input-error?
 122             gexp-error-invalid-input))
 123
 124 ;;; Commentary:
 125 ;;;
 126 ;;; This module implements "G-expressions", or "gexps".  Gexps are like
 127 ;;; S-expressions (sexps), with two differences:
 128 ;;;
 129 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
 130 ;;;      replaced by the corresponding output file name; in addition, the
 131 ;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
 132 ;;;      the native code of a given package, in case of cross-compilation;
 133 ;;;
 134 ;;;   2. Gexps embed information about the derivations they refer to.
 135 ;;;
 136 ;;; Gexps make it easy to write to files Scheme code that refers to store
 137 ;;; items, or to write Scheme code to build derivations.
 138 ;;;
 139 ;;; Code:
 140
 141 ;; "G expressions".
 142 (define-record-type <gexp>
 143   (make-gexp references modules extensions proc)
 144   gexp?
 145   (references gexp-references)                    ;list of <gexp-input>
 146   (modules    gexp-self-modules)                  ;list of module names
 147   (extensions gexp-self-extensions)               ;list of lowerable things
 148   (proc       gexp-proc))                         ;procedure
 149
 150 (define (write-gexp gexp port)
 151   "Write GEXP on PORT."
 152   (display "#<gexp " port)
 153
 154   ;; Try to write the underlying sexp.  Now, this trick doesn't work when
 155   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
 156   ;; tries to use 'append' on that, which fails with wrong-type-arg.
 157   (false-if-exception
 158    (write (apply (gexp-proc gexp)
 159                  (gexp-references gexp))
 160           port))
 161   (format port " ~a>"
 162           (number->string (object-address gexp) 16)))
 163
 164 (set-record-type-printer! <gexp> write-gexp)
 165
 166 \f
 167 ;;;
 168 ;;; Methods.
 169 ;;;
 170
 171 ;; Compiler for a type of objects that may be introduced in a gexp.
 172 (define-record-type <gexp-compiler>
 173   (gexp-compiler type lower expand)
 174   gexp-compiler?
 175   (type       gexp-compiler-type)                 ;record type descriptor
 176   (lower      gexp-compiler-lower)
 177   (expand     gexp-compiler-expand))              ;#f | DRV -> sexp
 178
 179 (define-condition-type &gexp-error &error
 180   gexp-error?)
 181
 182 (define-condition-type &gexp-input-error &gexp-error
 183   gexp-input-error?
 184   (input gexp-error-invalid-input))
 185
 186
 187 (define %gexp-compilers
 188   ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
 189   (make-hash-table 20))
 190
 191 (define (default-expander thing obj output)
 192   "This is the default expander for \"things\" that appear in gexps.  It
 193 returns its output file name of OBJ's OUTPUT."
 194   (match obj
 195     ((? derivation? drv)
 196      (derivation->output-path drv output))
 197     ((? string? file)
 198      file)))
 199
 200 (define (register-compiler! compiler)
 201   "Register COMPILER as a gexp compiler."
 202   (hashq-set! %gexp-compilers
 203               (gexp-compiler-type compiler) compiler))
 204
 205 (define (lookup-compiler object)
 206   "Search for a compiler for OBJECT.  Upon success, return the three argument
 207 procedure to lower it; otherwise return #f."
 208   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 209          gexp-compiler-lower))
 210
 211 (define (file-like? object)
 212   "Return #t if OBJECT leads to a file in the store once unquoted in a
 213 G-expression; otherwise return #f."
 214   (and (struct? object) (->bool (lookup-compiler object))))
 215
 216 (define (lookup-expander object)
 217   "Search for an expander for OBJECT.  Upon success, return the three argument
 218 procedure to expand it; otherwise return #f."
 219   (and=> (hashq-ref %gexp-compilers (struct-vtable object))
 220          gexp-compiler-expand))
 221
 222 (define* (lower-object obj
 223                        #:optional (system (%current-system))
 224                        #:key (target 'current))
 225   "Return as a value in %STORE-MONAD the derivation or store item
 226 corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 227 OBJ must be an object that has an associated gexp compiler, such as a
 228 <package>."
 229   (mlet %store-monad ((target (if (eq? target 'current)
 230                                   (current-target-system)
 231                                   (return target)))
 232                       (graft? (grafting?)))
 233     (let loop ((obj obj))
 234       (match (lookup-compiler obj)
 235         (#f
 236          (raise (condition (&gexp-input-error (input obj)))))
 237         (lower
 238          ;; Cache in STORE the result of lowering OBJ.
 239          (mcached (mlet %store-monad ((lowered (lower obj system target)))
 240                     (if (and (struct? lowered)
 241                              (not (derivation? lowered)))
 242                         (loop lowered)
 243                         (return lowered)))
 244                   obj
 245                   system target graft?))))))
 246
 247 (define* (lower+expand-object obj
 248                               #:optional (system (%current-system))
 249                               #:key target (output "out"))
 250   "Return as a value in %STORE-MONAD the output of object OBJ expands to for
 251 SYSTEM and TARGET.  Object such as <package>, <file-append>, or <plain-file>
 252 expand to file names, but it's possible to expand to a plain data type."
 253   (let loop ((obj obj)
 254              (expand (and (struct? obj) (lookup-expander obj))))
 255     (match (lookup-compiler obj)
 256       (#f
 257        (raise (condition (&gexp-input-error (input obj)))))
 258       (lower
 259        (mlet* %store-monad ((graft?  (grafting?))
 260                             (lowered (mcached (lower obj system target)
 261                                               obj
 262                                               system target graft?)))
 263          ;; LOWER might return something that needs to be further
 264          ;; lowered.
 265          (if (struct? lowered)
 266              ;; If we lack an expander, delegate to that of LOWERED.
 267              (if (not expand)
 268                  (loop lowered (lookup-expander lowered))
 269                  (return (expand obj lowered output)))
 270              (return lowered)))))))               ;self-quoting
 271
 272 (define-syntax define-gexp-compiler
 273   (syntax-rules (=> compiler expander)
 274     "Define NAME as a compiler for objects matching PREDICATE encountered in
 275 gexps.
 276
 277 In the simplest form of the macro, BODY must return (1) a derivation for
 278 a record of the specified type, for SYSTEM and TARGET (the latter of which is
 279 #f except when cross-compiling), (2) another record that can itself be
 280 compiled down to a derivation, or (3) an object of a primitive data type.
 281
 282 The more elaborate form allows you to specify an expander:
 283
 284   (define-gexp-compiler something-compiler <something>
 285     compiler => (lambda (param system target) ...)
 286     expander => (lambda (param drv output) ...))
 287
 288 The expander specifies how an object is converted to its sexp representation."
 289     ((_ (name (param record-type) system target) body ...)
 290      (define-gexp-compiler name record-type
 291        compiler => (lambda (param system target) body ...)
 292        expander => default-expander))
 293     ((_ name record-type
 294         compiler => compile
 295         expander => expand)
 296      (begin
 297        (define name
 298          (gexp-compiler record-type compile expand))
 299        (register-compiler! name)))))
 300
 301 (define-gexp-compiler (derivation-compiler (drv <derivation>) system target)
 302   ;; Derivations are the lowest-level representation, so this is the identity
 303   ;; compiler.
 304   (with-monad %store-monad
 305     (return drv)))
 306
 307 ;; Expand to a raw ".drv" file for the lowerable object it wraps.  In other
 308 ;; words, this gives the raw ".drv" file instead of its build result.
 309 (define-record-type <raw-derivation-file>
 310   (raw-derivation-file obj)
 311   raw-derivation-file?
 312   (obj  raw-derivation-file-object))              ;lowerable object
 313
 314 (define-gexp-compiler raw-derivation-file-compiler <raw-derivation-file>
 315   compiler => (lambda (obj system target)
 316                 (mlet %store-monad ((obj (lower-object
 317                                           (raw-derivation-file-object obj)
 318                                           system #:target target)))
 319                   ;; Returning the .drv file name instead of the <derivation>
 320                   ;; record ensures that 'lower-gexp' will classify it as a
 321                   ;; "source" and not as an "input".
 322                   (return (if (derivation? obj)
 323                               (derivation-file-name obj)
 324                               obj))))
 325   expander => (lambda (obj lowered output)
 326                 (if (derivation? lowered)
 327                     (derivation-file-name lowered)
 328                     lowered)))
 329
 330 \f
 331 ;;;
 332 ;;; File declarations.
 333 ;;;
 334
 335 ;; A local file name.  FILE is the file name the user entered, which can be a
 336 ;; relative file name, and ABSOLUTE is a promise that computes its canonical
 337 ;; absolute file name.  We keep it in a promise to compute it lazily and avoid
 338 ;; repeated 'stat' calls.
 339 (define-record-type <local-file>
 340   (%%local-file file absolute name recursive? select?)
 341   local-file?
 342   (file       local-file-file)                    ;string
 343   (absolute   %local-file-absolute-file-name)     ;promise string
 344   (name       local-file-name)                    ;string
 345   (recursive? local-file-recursive?)              ;Boolean
 346   (select?    local-file-select?))                ;string stat -> Boolean
 347
 348 (define (true file stat) #t)
 349
 350 (define* (%local-file file promise #:optional (name (basename file))
 351                       #:key recursive? (select? true))
 352   ;; This intermediate procedure is part of our ABI, but the underlying
 353   ;; %%LOCAL-FILE is not.
 354   (%%local-file file promise name recursive? select?))
 355
 356 (define (absolute-file-name file directory)
 357   "Return the canonical absolute file name for FILE, which lives in the
 358 vicinity of DIRECTORY."
 359   (canonicalize-path
 360    (cond ((string-prefix? "/" file) file)
 361          ((not directory) file)
 362          ((string-prefix? "/" directory)
 363           (string-append directory "/" file))
 364          (else file))))
 365
 366 (define-syntax local-file
 367   (lambda (s)
 368     "Return an object representing local file FILE to add to the store; this
 369 object can be used in a gexp.  If FILE is a relative file name, it is looked
 370 up relative to the source file where this form appears.  FILE will be added to
 371 the store under NAME--by default the base name of FILE.
 372
 373 When RECURSIVE? is true, the contents of FILE are added recursively; if FILE
 374 designates a flat file and RECURSIVE? is true, its contents are added, and its
 375 permission bits are kept.
 376
 377 When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
 378 where FILE is the entry's absolute file name and STAT is the result of
 379 'lstat'; exclude entries for which SELECT? does not return true.
 380
 381 This is the declarative counterpart of the 'interned-file' monadic procedure.
 382 It is implemented as a macro to capture the current source directory where it
 383 appears."
 384     (syntax-case s ()
 385       ((_ file rest ...)
 386        (string? (syntax->datum #'file))
 387        ;; FILE is a literal, so resolve it relative to the source directory.
 388        #'(%local-file file
 389                       (delay (absolute-file-name file (current-source-directory)))
 390                       rest ...))
 391       ((_ file rest ...)
 392        ;; Resolve FILE relative to the current directory.
 393        #'(%local-file file
 394                       (delay (absolute-file-name file (getcwd)))
 395                       rest ...))
 396       ((_)
 397        #'(syntax-error "missing file name"))
 398       (id
 399        (identifier? #'id)
 400        ;; XXX: We could return #'(lambda (file . rest) ...).  However,
 401        ;; (syntax-source #'id) is #f so (current-source-directory) would not
 402        ;; work.  Thus, simply forbid this form.
 403        #'(syntax-error
 404           "'local-file' is a macro and cannot be used like this")))))
 405
 406 (define (local-file-absolute-file-name file)
 407   "Return the absolute file name for FILE, a <local-file> instance.  A
 408 'system-error' exception is raised if FILE could not be found."
 409   (force (%local-file-absolute-file-name file)))
 410
 411 (define-gexp-compiler (local-file-compiler (file <local-file>) system target)
 412   ;; "Compile" FILE by adding it to the store.
 413   (match file
 414     (($ <local-file> file (= force absolute) name recursive? select?)
 415      ;; Canonicalize FILE so that if it's a symlink, it is resolved.  Failing
 416      ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
 417      ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
 418      ;; just throw an error, both of which are inconvenient.
 419      (interned-file absolute name
 420                     #:recursive? recursive? #:select? select?))))
 421
 422 (define-record-type <plain-file>
 423   (%plain-file name content references)
 424   plain-file?
 425   (name        plain-file-name)                   ;string
 426   (content     plain-file-content)                ;string or bytevector
 427   (references  plain-file-references))            ;list (currently unused)
 428
 429 (define (plain-file name content)
 430   "Return an object representing a text file called NAME with the given
 431 CONTENT (a string) to be added to the store.
 432
 433 This is the declarative counterpart of 'text-file'."
 434   ;; XXX: For now just ignore 'references' because it's not clear how to use
 435   ;; them in a declarative context.
 436   (%plain-file name content '()))
 437
 438 (define-gexp-compiler (plain-file-compiler (file <plain-file>) system target)
 439   ;; "Compile" FILE by adding it to the store.
 440   (match file
 441     (($ <plain-file> name (and (? string?) content) references)
 442      (text-file name content references))
 443     (($ <plain-file> name (and (? bytevector?) content) references)
 444      (binary-file name content references))))
 445
 446 (define-record-type <computed-file>
 447   (%computed-file name gexp guile options)
 448   computed-file?
 449   (name       computed-file-name)                 ;string
 450   (gexp       computed-file-gexp)                 ;gexp
 451   (guile      computed-file-guile)                ;<package>
 452   (options    computed-file-options))             ;list of arguments
 453
 454 (define* (computed-file name gexp
 455                         #:key guile (options '(#:local-build? #t)))
 456   "Return an object representing the store item NAME, a file or directory
 457 computed by GEXP.  OPTIONS is a list of additional arguments to pass
 458 to 'gexp->derivation'.
 459
 460 This is the declarative counterpart of 'gexp->derivation'."
 461   (%computed-file name gexp guile options))
 462
 463 (define-gexp-compiler (computed-file-compiler (file <computed-file>)
 464                                               system target)
 465   ;; Compile FILE by returning a derivation whose build expression is its
 466   ;; gexp.
 467   (match file
 468     (($ <computed-file> name gexp guile options)
 469      (if guile
 470          (mlet %store-monad ((guile (lower-object guile system
 471                                                   #:target target)))
 472            (apply gexp->derivation name gexp #:guile-for-build guile
 473                   #:system system #:target target options))
 474          (apply gexp->derivation name gexp
 475                 #:system system #:target target options)))))
 476
 477 (define-record-type <program-file>
 478   (%program-file name gexp guile path)
 479   program-file?
 480   (name       program-file-name)                  ;string
 481   (gexp       program-file-gexp)                  ;gexp
 482   (guile      program-file-guile)                 ;package
 483   (path       program-file-module-path))          ;list of strings
 484
 485 (define* (program-file name gexp #:key (guile #f) (module-path %load-path))
 486   "Return an object representing the executable store item NAME that runs
 487 GEXP.  GUILE is the Guile package used to execute that script.  Imported
 488 modules of GEXP are looked up in MODULE-PATH.
 489
 490 This is the declarative counterpart of 'gexp->script'."
 491   (%program-file name gexp guile module-path))
 492
 493 (define-gexp-compiler (program-file-compiler (file <program-file>)
 494                                              system target)
 495   ;; Compile FILE by returning a derivation that builds the script.
 496   (match file
 497     (($ <program-file> name gexp guile module-path)
 498      (gexp->script name gexp
 499                    #:module-path module-path
 500                    #:guile (or guile (default-guile))
 501                    #:system system
 502                    #:target target))))
 503
 504 (define-record-type <scheme-file>
 505   (%scheme-file name gexp splice? load-path?)
 506   scheme-file?
 507   (name       scheme-file-name)                  ;string
 508   (gexp       scheme-file-gexp)                  ;gexp
 509   (splice?    scheme-file-splice?)               ;Boolean
 510   (load-path? scheme-file-set-load-path?))       ;Boolean
 511
 512 (define* (scheme-file name gexp #:key splice? (set-load-path? #t))
 513   "Return an object representing the Scheme file NAME that contains GEXP.
 514
 515 This is the declarative counterpart of 'gexp->file'."
 516   (%scheme-file name gexp splice? set-load-path?))
 517
 518 (define-gexp-compiler (scheme-file-compiler (file <scheme-file>)
 519                                             system target)
 520   ;; Compile FILE by returning a derivation that builds the file.
 521   (match file
 522     (($ <scheme-file> name gexp splice? set-load-path?)
 523      (gexp->file name gexp
 524                  #:set-load-path? set-load-path?
 525                  #:splice? splice?
 526                  #:system system
 527                  #:target target))))
 528
 529 ;; Appending SUFFIX to BASE's output file name.
 530 (define-record-type <file-append>
 531   (%file-append base suffix)
 532   file-append?
 533   (base   file-append-base)                    ;<package> | <derivation> | ...
 534   (suffix file-append-suffix))                 ;list of strings
 535
 536 (define (write-file-append file port)
 537   (match file
 538     (($ <file-append> base suffix)
 539      (format port "#<file-append ~s ~s>" base
 540              (string-join suffix)))))
 541
 542 (set-record-type-printer! <file-append> write-file-append)
 543
 544 (define (file-append base . suffix)
 545   "Return a <file-append> object that expands to the concatenation of BASE and
 546 SUFFIX."
 547   (%file-append base suffix))
 548
 549 (define-gexp-compiler file-append-compiler <file-append>
 550   compiler => (lambda (obj system target)
 551                 (match obj
 552                   (($ <file-append> base _)
 553                    (lower-object base system #:target target))))
 554   expander => (lambda (obj lowered output)
 555                 (match obj
 556                   (($ <file-append> base suffix)
 557                    (let* ((expand (lookup-expander base))
 558                           (base   (expand base lowered output)))
 559                      (string-append base (string-concatenate suffix)))))))
 560
 561 ;; Representation of SRFI-39 parameter settings in the dynamic scope of an
 562 ;; object lowering.
 563 (define-record-type <parameterized>
 564   (parameterized bindings thunk)
 565   parameterized?
 566   (bindings parameterized-bindings)             ;list of parameter/value pairs
 567   (thunk    parameterized-thunk))               ;thunk
 568
 569 (define-syntax-rule (with-parameters ((param value) ...) body ...)
 570   "Bind each PARAM to the corresponding VALUE for the extent during which BODY
 571 is lowered.  Consider this example:
 572
 573   (with-parameters ((%current-system \"x86_64-linux\"))
 574     coreutils)
 575
 576 It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
 577 x86_64-linux when COREUTILS is lowered."
 578   (parameterized (list (list param (lambda () value)) ...)
 579                  (lambda ()
 580                    body ...)))
 581
 582 (define-gexp-compiler compile-parameterized <parameterized>
 583   compiler =>
 584   (lambda (parameterized system target)
 585     (match (parameterized-bindings parameterized)
 586       (((parameters values) ...)
 587        (let ((fluids (map parameter-fluid parameters))
 588              (thunk  (parameterized-thunk parameterized)))
 589          ;; Install the PARAMETERS for the dynamic extent of THUNK.
 590          (with-fluids* fluids
 591            (map (lambda (thunk) (thunk)) values)
 592            (lambda ()
 593              ;; Special-case '%current-system' and '%current-target-system' to
 594              ;; make sure we get the desired effect.
 595              (let ((system (if (memq %current-system parameters)
 596                                (%current-system)
 597                                system))
 598                    (target (if (memq %current-target-system parameters)
 599                                (%current-target-system)
 600                                target)))
 601                (lower-object (thunk) system #:target target))))))))
 602
 603   expander => (lambda (parameterized lowered output)
 604                 (match (parameterized-bindings parameterized)
 605                   (((parameters values) ...)
 606                    (let ((fluids (map parameter-fluid parameters))
 607                          (thunk  (parameterized-thunk parameterized)))
 608                      ;; Install the PARAMETERS for the dynamic extent of THUNK.
 609                      (with-fluids* fluids
 610                        (map (lambda (thunk) (thunk)) values)
 611                        (lambda ()
 612                          ;; Delegate to the expander of the wrapped object.
 613                          (let* ((base   (thunk))
 614                                 (expand (lookup-expander base)))
 615                            (expand base lowered output)))))))))
 616
 617 \f
 618 ;;;
 619 ;;; Inputs & outputs.
 620 ;;;
 621
 622 ;; The input of a gexp.
 623 (define-record-type <gexp-input>
 624   (%gexp-input thing output native?)
 625   gexp-input?
 626   (thing     gexp-input-thing)       ;<package> | <origin> | <derivation> | ...
 627   (output    gexp-input-output)      ;string
 628   (native?   gexp-input-native?))    ;Boolean
 629
 630 (define (write-gexp-input input port)
 631   (match input
 632     (($ <gexp-input> thing output #f)
 633      (format port "#<gexp-input ~s:~a>" thing output))
 634     (($ <gexp-input> thing output #t)
 635      (format port "#<gexp-input native ~s:~a>" thing output))))
 636
 637 (set-record-type-printer! <gexp-input> write-gexp-input)
 638
 639 (define* (gexp-input thing                        ;convenience procedure
 640                      #:optional (output "out")
 641                      #:key native?)
 642   "Return a new <gexp-input> for the OUTPUT of THING; NATIVE? determines
 643 whether this should be considered a \"native\" input or not."
 644   (%gexp-input thing output native?))
 645
 646 ;; Reference to one of the derivation's outputs, for gexps used in
 647 ;; derivations.
 648 (define-record-type <gexp-output>
 649   (gexp-output name)
 650   gexp-output?
 651   (name gexp-output-name))
 652
 653 (define (write-gexp-output output port)
 654   (match output
 655     (($ <gexp-output> name)
 656      (format port "#<gexp-output ~a>" name))))
 657
 658 (set-record-type-printer! <gexp-output> write-gexp-output)
 659
 660 (define* (gexp-attribute gexp self-attribute #:optional (equal? equal?))
 661   "Recurse on GEXP and the expressions it refers to, summing the items
 662 returned by SELF-ATTRIBUTE, a procedure that takes a gexp.  Use EQUAL? as the
 663 second argument to 'delete-duplicates'."
 664   (if (gexp? gexp)
 665       (delete-duplicates
 666        (append (self-attribute gexp)
 667                (append-map (match-lambda
 668                              (($ <gexp-input> (? gexp? exp))
 669                               (gexp-attribute exp self-attribute))
 670                              (($ <gexp-input> (lst ...))
 671                               (append-map (lambda (item)
 672                                             (if (gexp? item)
 673                                                 (gexp-attribute item
 674                                                                 self-attribute)
 675                                                 '()))
 676                                           lst))
 677                              (_
 678                               '()))
 679                            (gexp-references gexp)))
 680        equal?)
 681       '()))                                       ;plain Scheme data type
 682
 683 (define (gexp-modules gexp)
 684   "Return the list of Guile module names GEXP relies on.  If (gexp? GEXP) is
 685 false, meaning that GEXP is a plain Scheme object, return the empty list."
 686   (define (module=? m1 m2)
 687     ;; Return #t when M1 equals M2.  Special-case '=>' specs because their
 688     ;; right-hand side may not be comparable with 'equal?': it's typically a
 689     ;; file-like object that embeds a gexp, which in turn embeds closure;
 690     ;; those closures may be 'eq?' when running compiled code but are unlikely
 691     ;; to be 'eq?' when running on 'eval'.  Ignore the right-hand side to
 692     ;; avoid this discrepancy.
 693     (match m1
 694       (((name1 ...) '=> _)
 695        (match m2
 696          (((name2 ...) '=> _) (equal? name1 name2))
 697          (_ #f)))
 698       (_
 699        (equal? m1 m2))))
 700
 701   (gexp-attribute gexp gexp-self-modules module=?))
 702
 703 (define (gexp-extensions gexp)
 704   "Return the list of Guile extensions (packages) GEXP relies on.  If (gexp?
 705 GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
 706 list."
 707   (gexp-attribute gexp gexp-self-extensions))
 708
 709 (define* (lower-inputs inputs
 710                        #:key system target)
 711   "Turn any object from INPUTS into a derivation input for SYSTEM or a store
 712 item (a \"source\"); return the corresponding input list as a monadic value.
 713 When TARGET is true, use it as the cross-compilation target triplet."
 714   (define (store-item? obj)
 715     (and (string? obj) (store-path? obj)))
 716
 717   (with-monad %store-monad
 718     (mapm/accumulate-builds
 719      (match-lambda
 720        (((? struct? thing) sub-drv ...)
 721         (mlet %store-monad ((obj (lower-object
 722                                   thing system #:target target)))
 723           (return (match obj
 724                     ((? derivation? drv)
 725                      (let ((outputs (if (null? sub-drv)
 726                                         '("out")
 727                                         sub-drv)))
 728                        (derivation-input drv outputs)))
 729                     ((? store-item? item)
 730                      item)))))
 731        (((? store-item? item))
 732         (return item)))
 733      inputs)))
 734
 735 (define* (lower-reference-graphs graphs #:key system target)
 736   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
 737 #:reference-graphs argument, lower it such that each INPUT is replaced by the
 738 corresponding <derivation-input> or store item."
 739   (match graphs
 740     (((file-names . inputs) ...)
 741      (mlet %store-monad ((inputs (lower-inputs inputs
 742                                                #:system system
 743                                                #:target target)))
 744        (return (map cons file-names inputs))))))
 745
 746 (define* (lower-references lst #:key system target)
 747   "Based on LST, a list of output names and packages, return a list of output
 748 names and file names suitable for the #:allowed-references argument to
 749 'derivation'."
 750   (with-monad %store-monad
 751     (define lower
 752       (match-lambda
 753        ((? string? output)
 754         (return output))
 755        (($ <gexp-input> thing output native?)
 756         (mlet %store-monad ((drv (lower-object thing system
 757                                                #:target (if native?
 758                                                             #f target))))
 759           (return (derivation->output-path drv output))))
 760        (thing
 761         (mlet %store-monad ((drv (lower-object thing system
 762                                                #:target target)))
 763           (return (derivation->output-path drv))))))
 764
 765     (mapm/accumulate-builds lower lst)))
 766
 767 (define default-guile-derivation
 768   ;; Here we break the abstraction by talking to the higher-level layer.
 769   ;; Thus, do the resolution lazily to hide the circular dependency.
 770   (let ((proc (delay
 771                 (let ((iface (resolve-interface '(guix packages))))
 772                   (module-ref iface 'default-guile-derivation)))))
 773     (lambda (system)
 774       ((force proc) system))))
 775
 776 ;; Representation of a gexp instantiated for a given target and system.
 777 ;; It's an intermediate representation between <gexp> and <derivation>.
 778 (define-record-type <lowered-gexp>
 779   (lowered-gexp sexp inputs sources guile load-path load-compiled-path)
 780   lowered-gexp?
 781   (sexp                lowered-gexp-sexp)         ;sexp
 782   (inputs              lowered-gexp-inputs)       ;list of <derivation-input>
 783   (sources             lowered-gexp-sources)      ;list of store items
 784   (guile               lowered-gexp-guile)        ;<derivation-input> | #f
 785   (load-path           lowered-gexp-load-path)    ;list of store items
 786   (load-compiled-path  lowered-gexp-load-compiled-path)) ;list of store items
 787
 788 (define* (imported+compiled-modules modules system
 789                                     #:key (extensions '())
 790                                     deprecation-warnings guile
 791                                     (module-path %load-path))
 792   "Return a pair where the first element is the imported MODULES and the
 793 second element is the derivation to compile them."
 794   (mcached equal?
 795            (mlet %store-monad ((modules  (if (pair? modules)
 796                                              (imported-modules modules
 797                                                                #:system system
 798                                                                #:module-path module-path)
 799                                              (return #f)))
 800                                (compiled (if (pair? modules)
 801                                              (compiled-modules modules
 802                                                                #:system system
 803                                                                #:module-path module-path
 804                                                                #:extensions extensions
 805                                                                #:guile guile
 806                                                                #:deprecation-warnings
 807                                                                deprecation-warnings)
 808                                              (return #f))))
 809              (return (cons modules compiled)))
 810            modules
 811            system extensions guile deprecation-warnings module-path))
 812
 813 (define* (lower-gexp exp
 814                      #:key
 815                      (module-path %load-path)
 816                      (system (%current-system))
 817                      (target 'current)
 818                      (graft? (%graft?))
 819                      (guile-for-build (%guile-for-build))
 820                      (effective-version "3.0")
 821
 822                      deprecation-warnings)
 823   "*Note: This API is subject to change; use at your own risk!*
 824
 825 Lower EXP, a gexp, instantiating it for SYSTEM and TARGET.  Return a
 826 <lowered-gexp> ready to be used.
 827
 828 Lowered gexps are an intermediate representation that's useful for
 829 applications that deal with gexps outside in a way that is disconnected from
 830 derivations--e.g., code evaluated for its side effects."
 831   (define %modules
 832     (delete-duplicates (gexp-modules exp)))
 833
 834   (define (search-path modules extensions suffix)
 835     (append (match modules
 836               ((? derivation? drv)
 837                (list (derivation->output-path drv)))
 838               (#f
 839                '())
 840               ((? store-path? item)
 841                (list item)))
 842             (map (lambda (extension)
 843                    (string-append (match extension
 844                                     ((? derivation? drv)
 845                                      (derivation->output-path drv))
 846                                     ((? store-path? item)
 847                                      item))
 848                                   suffix))
 849                  extensions)))
 850
 851   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
 852                        ;; '%current-target-system' to be looked up at >>=
 853                        ;; time.
 854                        (graft?    (set-grafting graft?))
 855
 856                        (system -> (or system (%current-system)))
 857                        (target -> (if (eq? target 'current)
 858                                       (%current-target-system)
 859                                       target))
 860                        (guile     (if guile-for-build
 861                                       (return guile-for-build)
 862                                       (default-guile-derivation system)))
 863                        (normals  (lower-inputs (gexp-inputs exp)
 864                                                #:system system
 865                                                #:target target))
 866                        (natives  (lower-inputs (gexp-native-inputs exp)
 867                                                #:system system
 868                                                #:target #f))
 869                        (inputs -> (append normals natives))
 870                        (sexp     (gexp->sexp exp
 871                                              #:system system
 872                                              #:target target))
 873                        (extensions -> (gexp-extensions exp))
 874                        (exts     (mapm %store-monad
 875                                        (lambda (obj)
 876                                          (lower-object obj system
 877                                                        #:target #f))
 878                                        extensions))
 879                        (modules+compiled (imported+compiled-modules
 880                                           %modules system
 881                                           #:extensions extensions
 882                                           #:deprecation-warnings
 883                                           deprecation-warnings
 884                                           #:guile guile
 885                                           #:module-path module-path))
 886                        (modules ->  (car modules+compiled))
 887                        (compiled -> (cdr modules+compiled)))
 888     (define load-path
 889       (search-path modules exts
 890                    (string-append "/share/guile/site/" effective-version)))
 891
 892     (define load-compiled-path
 893       (search-path compiled exts
 894                    (string-append "/lib/guile/" effective-version
 895                                   "/site-ccache")))
 896
 897     (mbegin %store-monad
 898       (set-grafting graft?)                       ;restore the initial setting
 899       (return (lowered-gexp sexp
 900                             `(,@(if (derivation? modules)
 901                                     (list (derivation-input modules))
 902                                     '())
 903                               ,@(if compiled
 904                                     (list (derivation-input compiled))
 905                                     '())
 906                               ,@(map derivation-input exts)
 907                               ,@(filter derivation-input? inputs))
 908                             (filter string? (cons modules inputs))
 909                             (derivation-input guile '("out"))
 910                             load-path
 911                             load-compiled-path)))))
 912
 913 (define* (gexp->derivation name exp
 914                            #:key
 915                            system (target 'current)
 916                            hash hash-algo recursive?
 917                            (env-vars '())
 918                            (modules '())
 919                            (module-path %load-path)
 920                            (guile-for-build (%guile-for-build))
 921                            (effective-version "3.0")
 922                            (graft? (%graft?))
 923                            references-graphs
 924                            allowed-references disallowed-references
 925                            leaked-env-vars
 926                            local-build? (substitutable? #t)
 927                            (properties '())
 928                            deprecation-warnings
 929                            (script-name (string-append name "-builder")))
 930   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 931 derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME.  When
 932 TARGET is true, it is used as the cross-compilation target triplet for
 933 packages referred to by EXP.
 934
 935 MODULES is deprecated in favor of 'with-imported-modules'.  Its meaning is to
 936 make MODULES available in the evaluation context of EXP; MODULES is a list of
 937 names of Guile modules searched in MODULE-PATH to be copied in the store,
 938 compiled, and made available in the load path during the execution of
 939 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 940
 941 EFFECTIVE-VERSION determines the string to use when adding extensions of
 942 EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
 943
 944 GRAFT? determines whether packages referred to by EXP should be grafted when
 945 applicable.
 946
 947 When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
 948 following forms:
 949
 950   (FILE-NAME PACKAGE)
 951   (FILE-NAME PACKAGE OUTPUT)
 952   (FILE-NAME DERIVATION)
 953   (FILE-NAME DERIVATION OUTPUT)
 954   (FILE-NAME STORE-ITEM)
 955
 956 The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
 957 an input of the build process of EXP.  In the build environment, each
 958 FILE-NAME contains the reference graph of the corresponding item, in a simple
 959 text format.
 960
 961 ALLOWED-REFERENCES must be either #f or a list of output names and packages.
 962 In the latter case, the list denotes store items that the result is allowed to
 963 refer to.  Any reference to another store item will lead to a build error.
 964 Similarly for DISALLOWED-REFERENCES, which can list items that must not be
 965 referenced by the outputs.
 966
 967 DEPRECATION-WARNINGS determines whether to show deprecation warnings while
 968 compiling modules.  It can be #f, #t, or 'detailed.
 969
 970 The other arguments are as for 'derivation'."
 971   (define outputs (gexp-outputs exp))
 972   (define requested-graft? graft?)
 973
 974   (define (graphs-file-names graphs)
 975     ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
 976     (map (match-lambda
 977            ((file-name . (? derivation-input? input))
 978             (cons file-name (first (derivation-input-output-paths input))))
 979            ((file-name . (? string? item))
 980             (cons file-name item)))
 981          graphs))
 982
 983   (define (add-modules exp modules)
 984     (if (null? modules)
 985         exp
 986         (make-gexp (gexp-references exp)
 987                    (append modules (gexp-self-modules exp))
 988                    (gexp-self-extensions exp)
 989                    (gexp-proc exp))))
 990
 991   (mlet* %store-monad ( ;; The following binding forces '%current-system' and
 992                        ;; '%current-target-system' to be looked up at >>=
 993                        ;; time.
 994                        (graft?    (set-grafting graft?))
 995
 996                        (system -> (or system (%current-system)))
 997                        (target -> (if (eq? target 'current)
 998                                       (%current-target-system)
 999                                       target))
1000                        (exp ->    (add-modules exp modules))
1001                        (lowered   (lower-gexp exp
1002                                               #:module-path module-path
1003                                               #:system system
1004                                               #:target target
1005                                               #:graft? requested-graft?
1006                                               #:guile-for-build
1007                                               guile-for-build
1008                                               #:effective-version
1009                                               effective-version
1010                                               #:deprecation-warnings
1011                                               deprecation-warnings))
1012
1013                        (graphs   (if references-graphs
1014                                      (lower-reference-graphs references-graphs
1015                                                              #:system system
1016                                                              #:target target)
1017                                      (return #f)))
1018                        (allowed  (if allowed-references
1019                                      (lower-references allowed-references
1020                                                        #:system system
1021                                                        #:target target)
1022                                      (return #f)))
1023                        (disallowed (if disallowed-references
1024                                        (lower-references disallowed-references
1025                                                          #:system system
1026                                                          #:target target)
1027                                        (return #f)))
1028                        (guile -> (lowered-gexp-guile lowered))
1029                        (builder  (text-file script-name
1030                                             (object->string
1031                                              (lowered-gexp-sexp lowered)))))
1032     (mbegin %store-monad
1033       (set-grafting graft?)                       ;restore the initial setting
1034       (raw-derivation name
1035                       (string-append (derivation-input-output-path guile)
1036                                      "/bin/guile")
1037                       `("--no-auto-compile"
1038                         ,@(append-map (lambda (directory)
1039                                         `("-L" ,directory))
1040                                       (lowered-gexp-load-path lowered))
1041                         ,@(append-map (lambda (directory)
1042                                         `("-C" ,directory))
1043                                       (lowered-gexp-load-compiled-path lowered))
1044                         ,builder)
1045                       #:outputs outputs
1046                       #:env-vars env-vars
1047                       #:system system
1048                       #:inputs `(,guile
1049                                  ,@(lowered-gexp-inputs lowered)
1050                                  ,@(match graphs
1051                                      (((_ . inputs) ...)
1052                                       (filter derivation-input? inputs))
1053                                      (#f '())))
1054                       #:sources `(,builder
1055                                   ,@(if (and (string? modules)
1056                                              (store-path? modules))
1057                                         (list modules)
1058                                         '())
1059                                   ,@(lowered-gexp-sources lowered)
1060                                   ,@(match graphs
1061                                       (((_ . inputs) ...)
1062                                        (filter string? inputs))
1063                                       (#f '())))
1064
1065                       #:hash hash #:hash-algo hash-algo #:recursive? recursive?
1066                       #:references-graphs (and=> graphs graphs-file-names)
1067                       #:allowed-references allowed
1068                       #:disallowed-references disallowed
1069                       #:leaked-env-vars leaked-env-vars
1070                       #:local-build? local-build?
1071                       #:substitutable? substitutable?
1072                       #:properties properties))))
1073
1074 (define* (gexp-inputs exp #:key native?)
1075   "Return the input list for EXP.  When NATIVE? is true, return only native
1076 references; otherwise, return only non-native references."
1077   ;; TODO: Return <gexp-input> records instead of tuples.
1078   (define (add-reference-inputs ref result)
1079     (match ref
1080       (($ <gexp-input> (? gexp? exp) _ #t)
1081        (if native?
1082            (append (gexp-inputs exp)
1083                    (gexp-inputs exp #:native? #t)
1084                    result)
1085            result))
1086       (($ <gexp-input> (? gexp? exp) _ #f)
1087        (append (gexp-inputs exp #:native? native?)
1088                result))
1089       (($ <gexp-input> (? string? str))
1090        (if (direct-store-path? str)
1091            (cons `(,str) result)
1092            result))
1093       (($ <gexp-input> (? struct? thing) output n?)
1094        (if (and (eqv? n? native?) (lookup-compiler thing))
1095            ;; THING is a derivation, or a package, or an origin, etc.
1096            (cons `(,thing ,output) result)
1097            result))
1098       (($ <gexp-input> (lst ...) output n?)
1099        (fold-right add-reference-inputs result
1100                    ;; XXX: For now, automatically convert LST to a list of
1101                    ;; gexp-inputs.  Inherit N?.
1102                    (map (match-lambda
1103                           ((? gexp-input? x)
1104                            (%gexp-input (gexp-input-thing x)
1105                                         (gexp-input-output x)
1106                                         n?))
1107                           (x
1108                            (%gexp-input x "out" n?)))
1109                         lst)))
1110       (_
1111        ;; Ignore references to other kinds of objects.
1112        result)))
1113
1114   (fold-right add-reference-inputs
1115               '()
1116               (gexp-references exp)))
1117
1118 (define gexp-native-inputs
1119   (cut gexp-inputs <> #:native? #t))
1120
1121 (define (gexp-outputs exp)
1122   "Return the outputs referred to by EXP as a list of strings."
1123   (define (add-reference-output ref result)
1124     (match ref
1125       (($ <gexp-output> name)
1126        (cons name result))
1127       (($ <gexp-input> (? gexp? exp))
1128        (append (gexp-outputs exp) result))
1129       (($ <gexp-input> (lst ...) output native?)
1130        ;; XXX: Automatically convert LST.
1131        (add-reference-output (map (match-lambda
1132                                    ((? gexp-input? x) x)
1133                                    (x (%gexp-input x "out" native?)))
1134                                   lst)
1135                              result))
1136       ((lst ...)
1137        (fold-right add-reference-output result lst))
1138       (_
1139        result)))
1140
1141   (delete-duplicates
1142    (add-reference-output (gexp-references exp) '())))
1143
1144 (define* (gexp->sexp exp #:key
1145                      (system (%current-system))
1146                      (target (%current-target-system)))
1147   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
1148 and in the current monad setting (system type, etc.)"
1149   (define (self-quoting? x)
1150     (letrec-syntax ((one-of (syntax-rules ()
1151                               ((_) #f)
1152                               ((_ pred rest ...)
1153                                (or (pred x)
1154                                    (one-of rest ...))))))
1155       (one-of symbol? string? keyword? pair? null? array?
1156               number? boolean? char?)))
1157
1158   (define* (reference->sexp ref #:optional native?)
1159     (with-monad %store-monad
1160       (match ref
1161         (($ <gexp-output> output)
1162          ;; Output file names are not known in advance but the daemon defines
1163          ;; an environment variable for each of them at build time, so use
1164          ;; that trick.
1165          (return `((@ (guile) getenv) ,output)))
1166         (($ <gexp-input> (? gexp? exp) output n?)
1167          (gexp->sexp exp
1168                      #:system system
1169                      #:target (if (or n? native?) #f target)))
1170         (($ <gexp-input> (refs ...) output n?)
1171          (mapm %store-monad
1172                (lambda (ref)
1173                  ;; XXX: Automatically convert REF to an gexp-input.
1174                  (reference->sexp
1175                   (if (gexp-input? ref)
1176                       ref
1177                       (%gexp-input ref "out" n?))
1178                   (or n? native?)))
1179                refs))
1180         (($ <gexp-input> (? struct? thing) output n?)
1181          (let ((target (if (or n? native?) #f target)))
1182            (lower+expand-object thing system
1183                                 #:target target
1184                                 #:output output)))
1185         (($ <gexp-input> (? self-quoting? x))
1186          (return x))
1187         (($ <gexp-input> x)
1188          (raise (condition (&gexp-input-error (input x)))))
1189         (x
1190          (return x)))))
1191
1192   (mlet %store-monad
1193       ((args (mapm %store-monad
1194                    reference->sexp (gexp-references exp))))
1195     (return (apply (gexp-proc exp) args))))
1196
1197 (define-syntax-rule (define-syntax-parameter-once name proc)
1198   ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME
1199   ;; does not get redefined.  This works around a race condition in a
1200   ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>.
1201   (eval-when (load eval expand compile)
1202     (define name
1203       (if (module-locally-bound? (current-module) 'name)
1204           (module-ref (current-module) 'name)
1205           (make-syntax-transformer 'name 'syntax-parameter
1206                                    (list proc))))))
1207
1208 (define-syntax-parameter-once current-imported-modules
1209   ;; Current list of imported modules.
1210   (identifier-syntax '()))
1211
1212 (define-syntax-rule (with-imported-modules modules body ...)
1213   "Mark the gexps defined in BODY... as requiring MODULES in their execution
1214 environment."
1215   (syntax-parameterize ((current-imported-modules
1216                          (identifier-syntax modules)))
1217     body ...))
1218
1219 (define-syntax-parameter-once current-imported-extensions
1220   ;; Current list of extensions.
1221   (identifier-syntax '()))
1222
1223 (define-syntax-rule (with-extensions extensions body ...)
1224   "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
1225 execution environment."
1226   (syntax-parameterize ((current-imported-extensions
1227                          (identifier-syntax extensions)))
1228     body ...))
1229
1230 (define-syntax gexp
1231   (lambda (s)
1232     (define (collect-escapes exp)
1233       ;; Return all the 'ungexp' present in EXP.
1234       (let loop ((exp    exp)
1235                  (result '()))
1236         (syntax-case exp (ungexp
1237                           ungexp-splicing
1238                           ungexp-native
1239                           ungexp-native-splicing)
1240           ((ungexp _)
1241            (cons exp result))
1242           ((ungexp _ _)
1243            (cons exp result))
1244           ((ungexp-splicing _ ...)
1245            (cons exp result))
1246           ((ungexp-native _ ...)
1247            (cons exp result))
1248           ((ungexp-native-splicing _ ...)
1249            (cons exp result))
1250           ((exp0 . exp)
1251            (let ((result (loop #'exp0 result)))
1252              (loop  #'exp result)))
1253           (_
1254            result))))
1255
1256     (define (escape->ref exp)
1257       ;; Turn 'ungexp' form EXP into a "reference".
1258       (syntax-case exp (ungexp ungexp-splicing
1259                         ungexp-native ungexp-native-splicing
1260                         output)
1261         ((ungexp output)
1262          #'(gexp-output "out"))
1263         ((ungexp output name)
1264          #'(gexp-output name))
1265         ((ungexp thing)
1266          #'(%gexp-input thing "out" #f))
1267         ((ungexp drv-or-pkg out)
1268          #'(%gexp-input drv-or-pkg out #f))
1269         ((ungexp-splicing lst)
1270          #'(%gexp-input lst "out" #f))
1271         ((ungexp-native thing)
1272          #'(%gexp-input thing "out" #t))
1273         ((ungexp-native drv-or-pkg out)
1274          #'(%gexp-input drv-or-pkg out #t))
1275         ((ungexp-native-splicing lst)
1276          #'(%gexp-input lst "out" #t))))
1277
1278     (define (substitute-ungexp exp substs)
1279       ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
1280       ;; the corresponding form in SUBSTS.
1281       (match (assoc exp substs)
1282         ((_ id)
1283          id)
1284         (_                                        ;internal error
1285          (with-syntax ((exp exp))
1286            #'(syntax-error "error: no 'ungexp' substitution" exp)))))
1287
1288     (define (substitute-ungexp-splicing exp substs)
1289       (syntax-case exp ()
1290         ((exp rest ...)
1291          (match (assoc #'exp substs)
1292            ((_ id)
1293             (with-syntax ((id id))
1294               #`(append id
1295                         #,(substitute-references #'(rest ...) substs))))
1296            (_
1297             #'(syntax-error "error: no 'ungexp-splicing' substitution"
1298                             exp))))))
1299
1300     (define (substitute-references exp substs)
1301       ;; Return a variant of EXP where all the cars of SUBSTS have been
1302       ;; replaced by the corresponding cdr.
1303       (syntax-case exp (ungexp ungexp-native
1304                         ungexp-splicing ungexp-native-splicing)
1305         ((ungexp _ ...)
1306          (substitute-ungexp exp substs))
1307         ((ungexp-native _ ...)
1308          (substitute-ungexp exp substs))
1309         (((ungexp-splicing _ ...) rest ...)
1310          (substitute-ungexp-splicing exp substs))
1311         (((ungexp-native-splicing _ ...) rest ...)
1312          (substitute-ungexp-splicing exp substs))
1313         ((exp0 . exp)
1314          #`(cons #,(substitute-references #'exp0 substs)
1315                  #,(substitute-references #'exp substs)))
1316         (x #''x)))
1317
1318     (syntax-case s (ungexp output)
1319       ((_ exp)
1320        (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
1321               (formals (generate-temporaries escapes))
1322               (sexp    (substitute-references #'exp (zip escapes formals)))
1323               (refs    (map escape->ref escapes)))
1324          #`(make-gexp (list #,@refs)
1325                       current-imported-modules
1326                       current-imported-extensions
1327                       (lambda #,formals
1328                         #,sexp)))))))
1329
1330 \f
1331 ;;;
1332 ;;; Module handling.
1333 ;;;
1334
1335 (define %utils-module
1336   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
1337   ;; other primitives below.  Note: We give the file name relative to this
1338   ;; file you are currently reading; 'search-path' could return a file name
1339   ;; relative to the current working directory.
1340   (local-file "build/utils.scm"
1341               "build-utils.scm"))
1342
1343 (define* (imported-files/derivation files
1344                                     #:key (name "file-import")
1345                                     (symlink? #f)
1346                                     (system (%current-system))
1347                                     (guile (%guile-for-build)))
1348   "Return a derivation that imports FILES into STORE.  FILES must be a list
1349 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1350 resulting store path.  FILE can be either a file name, or a file-like object,
1351 as returned by 'local-file' for example.  If SYMLINK? is true, create symlinks
1352 to the source files instead of copying them."
1353   (define file-pair
1354     (match-lambda
1355      ((final-path . (? string? file-name))
1356       (mlet %store-monad ((file (interned-file file-name
1357                                                (basename final-path))))
1358         (return (list final-path file))))
1359      ((final-path . file-like)
1360       (mlet %store-monad ((file (lower-object file-like system)))
1361         (return (list final-path file))))))
1362
1363   (mlet %store-monad ((files (mapm %store-monad file-pair files)))
1364     (define build
1365       (gexp
1366        (begin
1367          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1368          (use-modules (ice-9 match))
1369
1370          (mkdir (ungexp output)) (chdir (ungexp output))
1371          (for-each (match-lambda
1372                     ((final-path store-path)
1373                      (mkdir-p (dirname final-path))
1374                      ((ungexp (if symlink? 'symlink 'copy-file))
1375                       store-path final-path)))
1376                    '(ungexp files)))))
1377
1378     ;; TODO: Pass FILES as an environment variable so that BUILD remains
1379     ;; exactly the same regardless of FILES: less disk space, and fewer
1380     ;; 'add-to-store' RPCs.
1381     (gexp->derivation name build
1382                       #:system system
1383                       #:guile-for-build guile
1384                       #:local-build? #t
1385
1386                       ;; Avoid deprecation warnings about the use of the _IO*
1387                       ;; constants in (guix build utils).
1388                       #:env-vars
1389                       '(("GUILE_WARN_DEPRECATED" . "no")))))
1390
1391 (define* (imported-files files
1392                          #:key (name "file-import")
1393                          ;; The following parameters make sense when creating
1394                          ;; an actual derivation.
1395                          (system (%current-system))
1396                          (guile (%guile-for-build)))
1397   "Import FILES into the store and return the resulting derivation or store
1398 file name (a derivation is created if and only if some elements of FILES are
1399 file-like objects and not local file names.)  FILES must be a list
1400 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
1401 resulting store path.  FILE can be either a file name, or a file-like object,
1402 as returned by 'local-file' for example."
1403   (if (any (match-lambda
1404              ((_ . (? struct? source)) #t)
1405              (_ #f))
1406            files)
1407       (imported-files/derivation files #:name name
1408                                  #:symlink? derivation?
1409                                  #:system system #:guile guile)
1410       (interned-file-tree `(,name directory
1411                                   ,@(file-mapping->tree files)))))
1412
1413 (define* (imported-modules modules
1414                            #:key (name "module-import")
1415                            (system (%current-system))
1416                            (guile (%guile-for-build))
1417                            (module-path %load-path))
1418   "Return a derivation that contains the source files of MODULES, a list of
1419 module names such as `(ice-9 q)'.  All of MODULES must be either names of
1420 modules to be found in the MODULE-PATH search path, or a module name followed
1421 by an arrow followed by a file-like object.  For example:
1422
1423   (imported-modules `((guix build utils)
1424                       (guix gcrypt)
1425                       ((guix config) => ,(scheme-file …))))
1426
1427 In this example, the first two modules are taken from MODULE-PATH, and the
1428 last one is created from the given <scheme-file> object."
1429   (let ((files (map (match-lambda
1430                       (((module ...) '=> file)
1431                        (cons (module->source-file-name module)
1432                              file))
1433                       ((module ...)
1434                        (let ((f (module->source-file-name module)))
1435                          (cons f (search-path* module-path f)))))
1436                     modules)))
1437     (imported-files files #:name name
1438                     #:system system
1439                     #:guile guile)))
1440
1441 (define* (compiled-modules modules
1442                            #:key (name "module-import-compiled")
1443                            (system (%current-system))
1444                            target
1445                            (guile (%guile-for-build))
1446                            (module-path %load-path)
1447                            (extensions '())
1448                            (deprecation-warnings #f))
1449   "Return a derivation that builds a tree containing the `.go' files
1450 corresponding to MODULES.  All the MODULES are built in a context where
1451 they can refer to each other.  When TARGET is true, cross-compile MODULES for
1452 TARGET, a GNU triplet."
1453   (define total (length modules))
1454
1455   (mlet %store-monad ((modules (imported-modules modules
1456                                                  #:system system
1457                                                  #:guile guile
1458                                                  #:module-path
1459                                                  module-path)))
1460     (define build
1461       (gexp
1462        (begin
1463          (primitive-load (ungexp %utils-module))  ;for 'mkdir-p'
1464
1465          (use-modules (ice-9 ftw)
1466                       (ice-9 format)
1467                       (srfi srfi-1)
1468                       (srfi srfi-26)
1469                       (system base target)
1470                       (system base compile))
1471
1472          (define (regular? file)
1473            (not (member file '("." ".."))))
1474
1475          (define (process-entry entry output processed)
1476            (if (file-is-directory? entry)
1477                (let ((output (string-append output "/" (basename entry))))
1478                  (mkdir-p output)
1479                  (process-directory entry output processed))
1480                (let* ((base   (basename entry ".scm"))
1481                       (output (string-append output "/" base ".go")))
1482                  (format #t "[~2@a/~2@a] Compiling '~a'...~%"
1483                          (+ 1 processed (ungexp total))
1484                          (ungexp (* total 2))
1485                          entry)
1486
1487                  (ungexp-splicing
1488                   (if target
1489                       (gexp ((with-target (ungexp target)
1490                                (lambda ()
1491                                  (compile-file entry
1492                                                #:output-file output
1493                                                #:opts
1494                                                %auto-compilation-options)))))
1495                       (gexp ((compile-file entry
1496                                            #:output-file output
1497                                            #:opts %auto-compilation-options)))))
1498
1499                  (+ 1 processed))))
1500
1501          (define (process-directory directory output processed)
1502            (let ((entries (map (cut string-append directory "/" <>)
1503                                (scandir directory regular?))))
1504              (fold (cut process-entry <> output <>)
1505                    processed
1506                    entries)))
1507
1508          (define* (load-from-directory directory
1509                                        #:optional (loaded 0))
1510            "Load all the source files found in DIRECTORY."
1511            ;; XXX: This works around <https://bugs.gnu.org/15602>.
1512            (let ((entries (map (cut string-append directory "/" <>)
1513                                (scandir directory regular?))))
1514              (fold (lambda (file loaded)
1515                      (if (file-is-directory? file)
1516                          (load-from-directory file loaded)
1517                          (begin
1518                            (format #t "[~2@a/~2@a] Loading '~a'...~%"
1519                                    (+ 1 loaded) (ungexp (* 2 total))
1520                                    file)
1521                            (save-module-excursion
1522                             (lambda ()
1523                               (primitive-load file)))
1524                            (+ 1 loaded))))
1525                    loaded
1526                    entries)))
1527
1528          (setvbuf (current-output-port)
1529                   (cond-expand (guile-2.2 'line) (else _IOLBF)))
1530
1531          (define mkdir-p
1532            ;; Capture 'mkdir-p'.
1533            (@ (guix build utils) mkdir-p))
1534
1535          ;; Add EXTENSIONS to the search path.
1536          (set! %load-path
1537            (append (map (lambda (extension)
1538                           (string-append extension
1539                                          "/share/guile/site/"
1540                                          (effective-version)))
1541                         '((ungexp-native-splicing extensions)))
1542                    %load-path))
1543          (set! %load-compiled-path
1544            (append (map (lambda (extension)
1545                           (string-append extension "/lib/guile/"
1546                                          (effective-version)
1547                                          "/site-ccache"))
1548                         '((ungexp-native-splicing extensions)))
1549                    %load-compiled-path))
1550
1551          (set! %load-path (cons (ungexp modules) %load-path))
1552
1553          ;; Above we loaded our own (guix build utils) but now we may need to
1554          ;; load a compile a different one.  Thus, force a reload.
1555          (let ((utils (string-append (ungexp modules)
1556                                      "/guix/build/utils.scm")))
1557            (when (file-exists? utils)
1558              (load utils)))
1559
1560          (mkdir (ungexp output))
1561          (chdir (ungexp modules))
1562
1563          (load-from-directory ".")
1564          (process-directory "." (ungexp output) 0))))
1565
1566     ;; TODO: Pass MODULES as an environment variable.
1567     (gexp->derivation name build
1568                       #:system system
1569                       #:guile-for-build guile
1570                       #:local-build? #t
1571                       #:env-vars
1572                       (case deprecation-warnings
1573                         ((#f)
1574                          '(("GUILE_WARN_DEPRECATED" . "no")))
1575                         ((detailed)
1576                          '(("GUILE_WARN_DEPRECATED" . "detailed")))
1577                         (else
1578                          '())))))
1579
1580 \f
1581 ;;;
1582 ;;; Convenience procedures.
1583 ;;;
1584
1585 (define (default-guile)
1586   ;; Lazily resolve 'guile-3.0' (not 'guile-final' because this is for
1587   ;; programs returned by 'program-file' and we don't want to keep references
1588   ;; to several Guile packages).  This module must not refer to (gnu …)
1589   ;; modules directly, to avoid circular dependencies, hence this hack.
1590   (module-ref (resolve-interface '(gnu packages guile))
1591               'guile-3.0))
1592
1593 (define* (load-path-expression modules #:optional (path %load-path)
1594                                #:key (extensions '()) system target)
1595   "Return as a monadic value a gexp that sets '%load-path' and
1596 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
1597 are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
1598   (if (and (null? modules) (null? extensions))
1599       (with-monad %store-monad
1600         (return #f))
1601       (mlet %store-monad ((modules  (imported-modules modules
1602                                                       #:module-path path
1603                                                       #:system system))
1604                           (compiled (compiled-modules modules
1605                                                       #:extensions extensions
1606                                                       #:module-path path
1607                                                       #:system system
1608                                                       #:target target)))
1609         (return
1610          (gexp (eval-when (expand load eval)
1611                  ;; Augment the load paths and delete duplicates.  Do that
1612                  ;; without loading (srfi srfi-1) or anything.
1613                  (let ((extensions '((ungexp-splicing extensions)))
1614                        (prepend (lambda (items lst)
1615                                   ;; This is O(N²) but N is typically small.
1616                                   (let loop ((items items)
1617                                              (lst lst))
1618                                     (if (null? items)
1619                                         lst
1620                                         (loop (cdr items)
1621                                               (cons (car items)
1622                                                     (delete (car items) lst))))))))
1623                    (set! %load-path
1624                      (prepend (cons (ungexp modules)
1625                                     (map (lambda (extension)
1626                                            (string-append extension
1627                                                           "/share/guile/site/"
1628                                                           (effective-version)))
1629                                          extensions))
1630                               %load-path))
1631                    (set! %load-compiled-path
1632                      (prepend (cons (ungexp compiled)
1633                                     (map (lambda (extension)
1634                                            (string-append extension
1635                                                           "/lib/guile/"
1636                                                           (effective-version)
1637                                                           "/site-ccache"))
1638                                          extensions))
1639                               %load-compiled-path)))))))))
1640
1641 (define* (gexp->script name exp
1642                        #:key (guile (default-guile))
1643                        (module-path %load-path)
1644                        (system (%current-system))
1645                        (target 'current))
1646   "Return an executable script NAME that runs EXP using GUILE, with EXP's
1647 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
1648   (mlet* %store-monad ((target (if (eq? target 'current)
1649                                    (current-target-system)
1650                                    (return target)))
1651                        (set-load-path
1652                         (load-path-expression (gexp-modules exp)
1653                                               module-path
1654                                               #:extensions
1655                                               (gexp-extensions exp)
1656                                               #:system system
1657                                               #:target target)))
1658     (gexp->derivation name
1659                       (gexp
1660                        (call-with-output-file (ungexp output)
1661                          (lambda (port)
1662                            ;; Note: that makes a long shebang.  When the store
1663                            ;; is /gnu/store, that fits within the 128-byte
1664                            ;; limit imposed by Linux, but that may go beyond
1665                            ;; when running tests.
1666                            (format port
1667                                    "#!~a/bin/guile --no-auto-compile~%!#~%"
1668                                    (ungexp guile))
1669
1670                            (ungexp-splicing
1671                             (if set-load-path
1672                                 (gexp ((write '(ungexp set-load-path) port)))
1673                                 (gexp ())))
1674
1675                            (write '(ungexp exp) port)
1676                            (chmod port #o555))))
1677                       #:system system
1678                       #:target target
1679                       #:module-path module-path
1680
1681                       ;; These derivations are not worth offloading or
1682                       ;; substituting.
1683                       #:local-build? #t
1684                       #:substitutable? #f)))
1685
1686 (define* (gexp->file name exp #:key
1687                      (set-load-path? #t)
1688                      (module-path %load-path)
1689                      (splice? #f)
1690                      (system (%current-system))
1691                      (target 'current))
1692   "Return a derivation that builds a file NAME containing EXP.  When SPLICE?
1693 is true, EXP is considered to be a list of expressions that will be spliced in
1694 the resulting file.
1695
1696 When SET-LOAD-PATH? is true, emit code in the resulting file to set
1697 '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
1698 Lookup EXP's modules in MODULE-PATH."
1699   (define modules (gexp-modules exp))
1700   (define extensions (gexp-extensions exp))
1701
1702   (mlet* %store-monad
1703       ((target (if (eq? target 'current)
1704                    (current-target-system)
1705                    (return target)))
1706        (no-load-path? -> (or (not set-load-path?)
1707                              (and (null? modules)
1708                                   (null? extensions))))
1709        (set-load-path
1710         (load-path-expression modules module-path
1711                               #:extensions extensions
1712                               #:system system
1713                               #:target target)))
1714     (if no-load-path?
1715         (gexp->derivation name
1716                           (gexp
1717                            (call-with-output-file (ungexp output)
1718                              (lambda (port)
1719                                (for-each
1720                                 (lambda (exp)
1721                                   (write exp port))
1722                                 '(ungexp (if splice?
1723                                              exp
1724                                              (gexp ((ungexp exp)))))))))
1725                           #:local-build? #t
1726                           #:substitutable? #f
1727                           #:system system
1728                           #:target target)
1729         (gexp->derivation name
1730                           (gexp
1731                            (call-with-output-file (ungexp output)
1732                              (lambda (port)
1733                                (write '(ungexp set-load-path) port)
1734                                (for-each
1735                                 (lambda (exp)
1736                                   (write exp port))
1737                                 '(ungexp (if splice?
1738                                              exp
1739                                              (gexp ((ungexp exp)))))))))
1740                           #:module-path module-path
1741                           #:local-build? #t
1742                           #:substitutable? #f
1743                           #:system system
1744                           #:target target))))
1745
1746 (define* (text-file* name #:rest text)
1747   "Return as a monadic value a derivation that builds a text file containing
1748 all of TEXT.  TEXT may list, in addition to strings, objects of any type that
1749 can be used in a gexp: packages, derivations, local file objects, etc.  The
1750 resulting store file holds references to all these."
1751   (define builder
1752     (gexp (call-with-output-file (ungexp output "out")
1753             (lambda (port)
1754               (display (string-append (ungexp-splicing text)) port)))))
1755
1756   (gexp->derivation name builder
1757                     #:local-build? #t
1758                     #:substitutable? #f))
1759
1760 (define* (mixed-text-file name #:rest text)
1761   "Return an object representing store file NAME containing TEXT.  TEXT is a
1762 sequence of strings and file-like objects, as in:
1763
1764   (mixed-text-file \"profile\"
1765                    \"export PATH=\" coreutils \"/bin:\" grep \"/bin\")
1766
1767 This is the declarative counterpart of 'text-file*'."
1768   (define build
1769     (gexp (call-with-output-file (ungexp output "out")
1770             (lambda (port)
1771               (display (string-append (ungexp-splicing text)) port)))))
1772
1773   (computed-file name build))
1774
1775 (define (file-union name files)
1776   "Return a <computed-file> that builds a directory containing all of FILES.
1777 Each item in FILES must be a two-element list where the first element is the
1778 file name to use in the new directory, and the second element is a gexp
1779 denoting the target file.  Here's an example:
1780
1781   (file-union \"etc\"
1782               `((\"hosts\" ,(plain-file \"hosts\"
1783                                         \"127.0.0.1 localhost\"))
1784                 (\"bashrc\" ,(plain-file \"bashrc\"
1785                                          \"alias ls='ls --color'\"))
1786                 (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\"))))
1787
1788 This yields an 'etc' directory containing these two files."
1789   (computed-file name
1790                  (with-imported-modules '((guix build utils))
1791                    (gexp
1792                     (begin
1793                       (use-modules (guix build utils))
1794
1795                       (mkdir (ungexp output))
1796                       (chdir (ungexp output))
1797                       (ungexp-splicing
1798                        (map (match-lambda
1799                               ((target source)
1800                                (gexp
1801                                 (begin
1802                                   ;; Stat the source to abort early if it does
1803                                   ;; not exist.
1804                                   (stat (ungexp source))
1805
1806                                   (mkdir-p (dirname (ungexp target)))
1807                                   (symlink (ungexp source)
1808                                            (ungexp target))))))
1809                             files)))))))
1810
1811 (define* (directory-union name things
1812                           #:key (copy? #f) (quiet? #f)
1813                           (resolve-collision 'warn-about-collision))
1814   "Return a directory that is the union of THINGS, where THINGS is a list of
1815 file-like objects denoting directories.  For example:
1816
1817   (directory-union \"guile+emacs\" (list guile emacs))
1818
1819 yields a directory that is the union of the 'guile' and 'emacs' packages.
1820
1821 Call RESOLVE-COLLISION when several files collide, passing it the list of
1822 colliding files.  RESOLVE-COLLISION must return the chosen file or #f, in
1823 which case the colliding entry is skipped altogether.
1824
1825 When HARD-LINKS? is true, create hard links instead of symlinks.  When QUIET?
1826 is true, the derivation will not print anything."
1827   (define symlink
1828     (if copy?
1829         (gexp (lambda (old new)
1830                 (if (file-is-directory? old)
1831                     (symlink old new)
1832                     (copy-file old new))))
1833         (gexp symlink)))
1834
1835   (define log-port
1836     (if quiet?
1837         (gexp (%make-void-port "w"))
1838         (gexp (current-error-port))))
1839
1840   (match things
1841     ((one)
1842      ;; Only one thing; return it.
1843      one)
1844     (_
1845      (computed-file name
1846                     (with-imported-modules '((guix build union))
1847                       (gexp (begin
1848                               (use-modules (guix build union)
1849                                            (srfi srfi-1)) ;for 'first' and 'last'
1850
1851                               (union-build (ungexp output)
1852                                            '(ungexp things)
1853
1854                                            #:log-port (ungexp log-port)
1855                                            #:symlink (ungexp symlink)
1856                                            #:resolve-collision
1857                                            (ungexp resolve-collision)))))))))
1858
1859 \f
1860 ;;;
1861 ;;; Syntactic sugar.
1862 ;;;
1863
1864 (eval-when (expand load eval)
1865   (define* (read-ungexp chr port #:optional native?)
1866     "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
1867 true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
1868     (define unquote-symbol
1869       (match (peek-char port)
1870         (#\@
1871          (read-char port)
1872          (if native?
1873              'ungexp-native-splicing
1874              'ungexp-splicing))
1875         (_
1876          (if native?
1877              'ungexp-native
1878              'ungexp))))
1879
1880     (match (read port)
1881       ((? symbol? symbol)
1882        (let ((str (symbol->string symbol)))
1883          (match (string-index-right str #\:)
1884            (#f
1885             `(,unquote-symbol ,symbol))
1886            (colon
1887             (let ((name   (string->symbol (substring str 0 colon)))
1888                   (output (substring str (+ colon 1))))
1889               `(,unquote-symbol ,name ,output))))))
1890       (x
1891        `(,unquote-symbol ,x))))
1892
1893   (define (read-gexp chr port)
1894     "Read a 'gexp' form from PORT."
1895     `(gexp ,(read port)))
1896
1897   ;; Extend the reader
1898   (read-hash-extend #\~ read-gexp)
1899   (read-hash-extend #\$ read-ungexp)
1900   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
1901
1902 ;;; gexp.scm ends here