guix/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
   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 utils)
  23   #:use-module (guix config)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-11)
  27   #:use-module (srfi srfi-26)
  28   #:use-module (srfi srfi-39)
  29   #:use-module (srfi srfi-60)
  30   #:use-module (rnrs bytevectors)
  31   #:use-module ((rnrs io ports) #:select (put-bytevector))
  32   #:use-module ((guix build utils) #:select (dump-port))
  33   #:use-module ((guix build syscalls) #:select (errno))
  34   #:use-module (ice-9 vlist)
  35   #:use-module (ice-9 format)
  36   #:autoload   (ice-9 popen)  (open-pipe*)
  37   #:autoload   (ice-9 rdelim) (read-line)
  38   #:use-module (ice-9 regex)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 format)
  41   #:use-module (system foreign)
  42   #:export (bytevector->base16-string
  43             base16-string->bytevector
  44
  45             %nixpkgs-directory
  46             nixpkgs-derivation
  47             nixpkgs-derivation*
  48
  49             compile-time-value
  50             fcntl-flock
  51             memoize
  52             strip-keyword-arguments
  53             default-keyword-arguments
  54             substitute-keyword-arguments
  55
  56             <location>
  57             location
  58             location?
  59             location-file
  60             location-line
  61             location-column
  62             source-properties->location
  63
  64             gnu-triplet->nix-system
  65             %current-system
  66             %current-target-system
  67             version-compare
  68             version>?
  69             version-prefix
  70             version-major+minor
  71             guile-version>?
  72             package-name->name+version
  73             string-tokenize*
  74             string-replace-substring
  75             file-extension
  76             file-sans-extension
  77             call-with-temporary-output-file
  78             with-atomic-file-output
  79             fold2
  80             fold-tree
  81             fold-tree-leaves
  82
  83             filtered-port
  84             compressed-port
  85             decompressed-port
  86             call-with-decompressed-port
  87             compressed-output-port
  88             call-with-compressed-output-port))
  89
  90 \f
  91 ;;;
  92 ;;; Compile-time computations.
  93 ;;;
  94
  95 (define-syntax compile-time-value
  96   (syntax-rules ()
  97     "Evaluate the given expression at compile time.  The expression must
  98 evaluate to a simple datum."
  99     ((_ exp)
 100      (let-syntax ((v (lambda (s)
 101                        (let ((val exp))
 102                          (syntax-case s ()
 103                            (_ #`'#,(datum->syntax s val)))))))
 104        v))))
 105
 106 \f
 107 ;;;
 108 ;;; Base 16.
 109 ;;;
 110
 111 (define (bytevector->base16-string bv)
 112   "Return the hexadecimal representation of BV's contents."
 113   (define len
 114     (bytevector-length bv))
 115
 116   (let-syntax ((base16-chars (lambda (s)
 117                                (syntax-case s ()
 118                                  (_
 119                                   (let ((v (list->vector
 120                                             (unfold (cut > <> 255)
 121                                                     (lambda (n)
 122                                                       (format #f "~2,'0x" n))
 123                                                     1+
 124                                                     0))))
 125                                     v))))))
 126     (define chars base16-chars)
 127     (let loop ((i len)
 128                (r '()))
 129       (if (zero? i)
 130           (string-concatenate r)
 131           (let ((i (- i 1)))
 132             (loop i
 133                   (cons (vector-ref chars (bytevector-u8-ref bv i)) r)))))))
 134
 135 (define base16-string->bytevector
 136   (let ((chars->value (fold (lambda (i r)
 137                               (vhash-consv (string-ref (number->string i 16)
 138                                                        0)
 139                                            i r))
 140                             vlist-null
 141                             (iota 16))))
 142     (lambda (s)
 143       "Return the bytevector whose hexadecimal representation is string S."
 144       (define bv
 145         (make-bytevector (quotient (string-length s) 2) 0))
 146
 147       (string-fold (lambda (chr i)
 148                      (let ((j (quotient i 2))
 149                            (v (and=> (vhash-assv chr chars->value) cdr)))
 150                        (if v
 151                            (if (zero? (logand i 1))
 152                                (bytevector-u8-set! bv j
 153                                                    (arithmetic-shift v 4))
 154                                (let ((w (bytevector-u8-ref bv j)))
 155                                  (bytevector-u8-set! bv j (logior v w))))
 156                            (error "invalid hexadecimal character" chr)))
 157                      (+ i 1))
 158                    0
 159                    s)
 160       bv)))
 161
 162
 163 \f
 164 ;;;
 165 ;;; Filtering & pipes.
 166 ;;;
 167
 168 (define (filtered-port command input)
 169   "Return an input port where data drained from INPUT is filtered through
 170 COMMAND (a list).  In addition, return a list of PIDs that the caller must
 171 wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
 172 buffered data is lost."
 173   (let loop ((input input)
 174              (pids  '()))
 175     (if (file-port? input)
 176         (match (pipe)
 177           ((in . out)
 178            (match (primitive-fork)
 179              (0
 180               (dynamic-wind
 181                 (const #f)
 182                 (lambda ()
 183                   (close-port in)
 184                   (close-port (current-input-port))
 185                   (dup2 (fileno input) 0)
 186                   (close-port (current-output-port))
 187                   (dup2 (fileno out) 1)
 188                   (catch 'system-error
 189                     (lambda ()
 190                       (apply execl (car command) command))
 191                     (lambda args
 192                       (format (current-error-port)
 193                               "filtered-port: failed to execute '~{~a ~}': ~a~%"
 194                               command (strerror (system-error-errno args))))))
 195                 (lambda ()
 196                   (primitive-_exit 1))))
 197              (child
 198               (close-port out)
 199               (values in (cons child pids))))))
 200
 201         ;; INPUT is not a file port, so fork just for the sake of tunneling it
 202         ;; through a file port.
 203         (match (pipe)
 204           ((in . out)
 205            (match (primitive-fork)
 206              (0
 207               (dynamic-wind
 208                 (const #t)
 209                 (lambda ()
 210                   (close-port in)
 211                   (dump-port input out))
 212                 (lambda ()
 213                   (false-if-exception (close out))
 214                   (primitive-_exit 0))))
 215              (child
 216               (close-port out)
 217               (loop in (cons child pids)))))))))
 218
 219 (define (decompressed-port compression input)
 220   "Return an input port where INPUT is decompressed according to COMPRESSION,
 221 a symbol such as 'xz."
 222   (match compression
 223     ((or #f 'none) (values input '()))
 224     ('bzip2        (filtered-port `(,%bzip2 "-dc") input))
 225     ('xz           (filtered-port `(,%xz "-dc") input))
 226     ('gzip         (filtered-port `(,%gzip "-dc") input))
 227     (else          (error "unsupported compression scheme" compression))))
 228
 229 (define (compressed-port compression input)
 230   "Return an input port where INPUT is decompressed according to COMPRESSION,
 231 a symbol such as 'xz."
 232   (match compression
 233     ((or #f 'none) (values input '()))
 234     ('bzip2        (filtered-port `(,%bzip2 "-c") input))
 235     ('xz           (filtered-port `(,%xz "-c") input))
 236     ('gzip         (filtered-port `(,%gzip "-c") input))
 237     (else          (error "unsupported compression scheme" compression))))
 238
 239 (define (call-with-decompressed-port compression port proc)
 240   "Call PROC with a wrapper around PORT, a file port, that decompresses data
 241 read from PORT according to COMPRESSION, a symbol such as 'xz."
 242   (let-values (((decompressed pids)
 243                 (decompressed-port compression port)))
 244     (dynamic-wind
 245       (const #f)
 246       (lambda ()
 247         (proc decompressed))
 248       (lambda ()
 249         (close-port decompressed)
 250         (unless (every (compose zero? cdr waitpid) pids)
 251           (error "decompressed-port failure" pids))))))
 252
 253 (define (filtered-output-port command output)
 254   "Return an output port.  Data written to that port is filtered through
 255 COMMAND and written to OUTPUT, an output file port.  In addition, return a
 256 list of PIDs to wait for.  OUTPUT must be unbuffered; otherwise, any buffered
 257 data is lost."
 258   (match (pipe)
 259     ((in . out)
 260      (match (primitive-fork)
 261        (0
 262         (dynamic-wind
 263           (const #f)
 264           (lambda ()
 265             (close-port out)
 266             (close-port (current-input-port))
 267             (dup2 (fileno in) 0)
 268             (close-port (current-output-port))
 269             (dup2 (fileno output) 1)
 270             (catch 'system-error
 271               (lambda ()
 272                 (apply execl (car command) command))
 273               (lambda args
 274                 (format (current-error-port)
 275                         "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
 276                         command (strerror (system-error-errno args))))))
 277           (lambda ()
 278             (primitive-_exit 1))))
 279        (child
 280         (close-port in)
 281         (values out (list child)))))))
 282
 283 (define (compressed-output-port compression output)
 284   "Return an output port whose input is compressed according to COMPRESSION,
 285 a symbol such as 'xz, and then written to OUTPUT.  In addition return a list
 286 of PIDs to wait for."
 287   (match compression
 288     ((or #f 'none) (values output '()))
 289     ('bzip2        (filtered-output-port `(,%bzip2 "-c") output))
 290     ('xz           (filtered-output-port `(,%xz "-c") output))
 291     ('gzip         (filtered-output-port `(,%gzip "-c") output))
 292     (else          (error "unsupported compression scheme" compression))))
 293
 294 (define (call-with-compressed-output-port compression port proc)
 295   "Call PROC with a wrapper around PORT, a file port, that compresses data
 296 that goes to PORT according to COMPRESSION, a symbol such as 'xz."
 297   (let-values (((compressed pids)
 298                 (compressed-output-port compression port)))
 299     (dynamic-wind
 300       (const #f)
 301       (lambda ()
 302         (proc compressed))
 303       (lambda ()
 304         (close-port compressed)
 305         (unless (every (compose zero? cdr waitpid) pids)
 306           (error "compressed-output-port failure" pids))))))
 307
 308 \f
 309 ;;;
 310 ;;; Nixpkgs.
 311 ;;;
 312
 313 (define %nixpkgs-directory
 314   (make-parameter
 315    ;; Capture the build-time value of $NIXPKGS.
 316    (or %nixpkgs
 317        (and=> (getenv "NIXPKGS")
 318               (lambda (val)
 319                 ;; Bail out when passed an empty string, otherwise
 320                 ;; `nix-instantiate' will sit there and attempt to read
 321                 ;; from its standard input.
 322                 (if (string=? val "")
 323                     #f
 324                     val))))))
 325
 326 (define* (nixpkgs-derivation attribute #:optional (system (%current-system)))
 327   "Return the derivation path of ATTRIBUTE in Nixpkgs."
 328   (let* ((p (open-pipe* OPEN_READ (or (getenv "NIX_INSTANTIATE")
 329                                       %nix-instantiate)
 330                         "-A" attribute (%nixpkgs-directory)
 331                         "--argstr" "system" system))
 332          (l (read-line p))
 333          (s (close-pipe p)))
 334     (and (zero? (status:exit-val s))
 335          (not (eof-object? l))
 336          l)))
 337
 338 (define-syntax-rule (nixpkgs-derivation* attribute)
 339   "Evaluate the given Nixpkgs derivation at compile-time."
 340   (compile-time-value (nixpkgs-derivation attribute)))
 341
 342 \f
 343 ;;;
 344 ;;; Advisory file locking.
 345 ;;;
 346
 347 (define %struct-flock
 348   ;; 'struct flock' from <fcntl.h>.
 349   (list short                                     ; l_type
 350         short                                     ; l_whence
 351         size_t                                    ; l_start
 352         size_t                                    ; l_len
 353         int))                                     ; l_pid
 354
 355 (define F_SETLKW
 356   ;; On Linux-based systems, this is usually 7, but not always
 357   ;; (exceptions include SPARC.)  On GNU/Hurd, it's 9.
 358   (compile-time-value
 359    (cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
 360          ((string-contains %host-type "linux") 7) ; *-linux-gnu
 361          (else 9))))                              ; *-gnu*
 362
 363 (define F_SETLK
 364   ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
 365   (compile-time-value
 366    (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
 367          ((string-contains %host-type "linux") 6) ; *-linux-gnu
 368          (else 8))))                              ; *-gnu*
 369
 370 (define F_xxLCK
 371   ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
 372   (compile-time-value
 373    (cond ((string-contains %host-type "sparc") #(1 2 3))    ; sparc-*-linux-gnu
 374          ((string-contains %host-type "hppa")  #(1 2 3))    ; hppa-*-linux-gnu
 375          ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
 376          (else                                 #(1 2 3))))) ; *-gnu*
 377
 378 (define fcntl-flock
 379   (let* ((ptr  (dynamic-func "fcntl" (dynamic-link)))
 380          (proc (pointer->procedure int ptr `(,int ,int *))))
 381     (lambda* (fd-or-port operation #:key (wait? #t))
 382       "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
 383 must be a symbol, one of 'read-lock, 'write-lock, or 'unlock.  When WAIT? is
 384 true, block until the lock is acquired; otherwise, thrown an 'flock-error'
 385 exception if it's already taken."
 386       (define (operation->int op)
 387         (case op
 388           ((read-lock)  (vector-ref F_xxLCK 0))
 389           ((write-lock) (vector-ref F_xxLCK 1))
 390           ((unlock)     (vector-ref F_xxLCK 2))
 391           (else         (error "invalid fcntl-flock operation" op))))
 392
 393       (define fd
 394         (if (port? fd-or-port)
 395             (fileno fd-or-port)
 396             fd-or-port))
 397
 398       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
 399       ;; standard ABI; crossing fingers.
 400       (let ((err (proc fd
 401                        (if wait?
 402                            F_SETLKW               ; lock & wait
 403                            F_SETLK)               ; non-blocking attempt
 404                        (make-c-struct %struct-flock
 405                                       (list (operation->int operation)
 406                                             SEEK_SET
 407                                             0 0   ; whole file
 408                                             0)))))
 409         (or (zero? err)
 410
 411             ;; Presumably we got EAGAIN or so.
 412             (throw 'flock-error (errno)))))))
 413
 414 \f
 415 ;;;
 416 ;;; Miscellaneous.
 417 ;;;
 418
 419 (define (memoize proc)
 420   "Return a memoizing version of PROC."
 421   (let ((cache (make-hash-table)))
 422     (lambda args
 423       (let ((results (hash-ref cache args)))
 424         (if results
 425             (apply values results)
 426             (let ((results (call-with-values (lambda ()
 427                                                (apply proc args))
 428                              list)))
 429               (hash-set! cache args results)
 430               (apply values results)))))))
 431
 432 (define (strip-keyword-arguments keywords args)
 433   "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
 434   (let loop ((args   args)
 435              (result '()))
 436     (match args
 437       (()
 438        (reverse result))
 439       (((? keyword? kw) arg . rest)
 440        (loop rest
 441              (if (memq kw keywords)
 442                  result
 443                  (cons* arg kw result))))
 444       ((head . tail)
 445        (loop tail (cons head result))))))
 446
 447 (define (default-keyword-arguments args defaults)
 448   "Return ARGS augmented with any keyword/value from DEFAULTS for
 449 keywords not already present in ARGS."
 450   (let loop ((defaults defaults)
 451              (args     args))
 452     (match defaults
 453       ((kw value rest ...)
 454        (loop rest
 455              (if (assoc-ref kw args)
 456                  args
 457                  (cons* kw value args))))
 458       (()
 459        args))))
 460
 461 (define-syntax substitute-keyword-arguments
 462   (syntax-rules ()
 463     "Return a new list of arguments where the value for keyword arg KW is
 464 replaced by EXP.  EXP is evaluated in a context where VAR is boud to the
 465 previous value of the keyword argument."
 466     ((_ original-args ((kw var) exp) ...)
 467      (let loop ((args    original-args)
 468                 (before '()))
 469        (match args
 470          ((kw var rest (... ...))
 471           (loop rest (cons* exp kw before)))
 472          ...
 473          ((x rest (... ...))
 474           (loop rest (cons x before)))
 475          (()
 476           (reverse before)))))))
 477
 478 (define (gnu-triplet->nix-system triplet)
 479   "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
 480 returned by `config.guess'."
 481   (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
 482                         =>
 483                         (lambda (m)
 484                           (string-append "i686-" (match:substring m 1))))
 485                        (else triplet))))
 486     (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
 487            =>
 488            (lambda (m)
 489              ;; Nix omits `-gnu' for GNU/Linux.
 490              (string-append (match:substring m 1) "-linux")))
 491           ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
 492            =>
 493            (lambda (m)
 494              ;; Nix strip the version number from names such as `gnu0.3',
 495              ;; `darwin10.2.0', etc., and always strips the vendor part.
 496              (string-append (match:substring m 1) "-"
 497                             (match:substring m 3))))
 498           (else triplet))))
 499
 500 (define %current-system
 501   ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
 502   ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
 503   (make-parameter %system))
 504
 505 (define %current-target-system
 506   ;; Either #f or a GNU triplet representing the target system we are
 507   ;; cross-building to.
 508   (make-parameter #f))
 509
 510 (define version-compare
 511   (let ((strverscmp
 512          (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
 513                         (error "could not find `strverscmp' (from GNU libc)"))))
 514            (pointer->procedure int sym (list '* '*)))))
 515     (lambda (a b)
 516       "Return '> when A denotes a newer version than B,
 517 '< when A denotes a older version than B,
 518 or '= when they denote equal versions."
 519       (let ((result (strverscmp (string->pointer a) (string->pointer b))))
 520         (cond ((positive? result) '>)
 521               ((negative? result) '<)
 522               (else '=))))))
 523
 524 (define (version-prefix version-string num-parts)
 525   "Truncate version-string to the first num-parts components of the version.
 526 For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\""
 527   (string-join (take (string-split version-string #\.) num-parts) "."))
 528
 529
 530 (define (version-major+minor version-string)
 531   "Return \"<major>.<minor>\", where major and minor are the major and
 532 minor version numbers from version-string."
 533   (version-prefix version-string 2))
 534
 535 (define (version>? a b)
 536   "Return #t when A denotes a newer version than B."
 537   (eq? '> (version-compare a b)))
 538
 539 (define (guile-version>? str)
 540   "Return #t if the running Guile version is greater than STR."
 541   ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
 542   ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
 543   (version>? (string-append (major-version) "."
 544                             (minor-version) "."
 545                             (micro-version))
 546              str))
 547
 548 (define (package-name->name+version name)
 549   "Given NAME, a package name like \"foo-0.9.1b\", return two values:
 550 \"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
 551 #f are returned.  The first hyphen followed by a digit is considered to
 552 introduce the version part."
 553   ;; See also `DrvName' in Nix.
 554
 555   (define number?
 556     (cut char-set-contains? char-set:digit <>))
 557
 558   (let loop ((chars   (string->list name))
 559              (prefix '()))
 560     (match chars
 561       (()
 562        (values name #f))
 563       ((#\- (? number? n) rest ...)
 564        (values (list->string (reverse prefix))
 565                (list->string (cons n rest))))
 566       ((head tail ...)
 567        (loop tail (cons head prefix))))))
 568
 569 (define (file-extension file)
 570   "Return the extension of FILE or #f if there is none."
 571   (let ((dot (string-rindex file #\.)))
 572     (and dot (substring file (+ 1 dot) (string-length file)))))
 573
 574 (define (file-sans-extension file)
 575   "Return the substring of FILE without its extension, if any."
 576   (let ((dot (string-rindex file #\.)))
 577     (if dot
 578         (substring file 0 dot)
 579         file)))
 580
 581 (define (string-tokenize* string separator)
 582   "Return the list of substrings of STRING separated by SEPARATOR.  This is
 583 like `string-tokenize', but SEPARATOR is a string."
 584   (define (index string what)
 585     (let loop ((string string)
 586                (offset 0))
 587       (cond ((string-null? string)
 588              #f)
 589             ((string-prefix? what string)
 590              offset)
 591             (else
 592              (loop (string-drop string 1) (+ 1 offset))))))
 593
 594   (define len
 595     (string-length separator))
 596
 597   (let loop ((string string)
 598              (result  '()))
 599     (cond ((index string separator)
 600            =>
 601            (lambda (offset)
 602              (loop (string-drop string (+ offset len))
 603                    (cons (substring string 0 offset)
 604                          result))))
 605           (else
 606            (reverse (cons string result))))))
 607
 608 (define* (string-replace-substring str substr replacement
 609                                    #:optional
 610                                    (start 0)
 611                                    (end (string-length str)))
 612   "Replace all occurrences of SUBSTR in the START--END range of STR by
 613 REPLACEMENT."
 614   (match (string-length substr)
 615     (0
 616      (error "string-replace-substring: empty substring"))
 617     (substr-length
 618      (let loop ((start  start)
 619                 (pieces (list (substring str 0 start))))
 620        (match (string-contains str substr start end)
 621          (#f
 622           (string-concatenate-reverse
 623            (cons (substring str start) pieces)))
 624          (index
 625           (loop (+ index substr-length)
 626                 (cons* replacement
 627                        (substring str start index)
 628                        pieces))))))))
 629
 630 (define (call-with-temporary-output-file proc)
 631   "Call PROC with a name of a temporary file and open output port to that
 632 file; close the file and delete it when leaving the dynamic extent of this
 633 call."
 634   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 635          (template  (string-append directory "/guix-file.XXXXXX"))
 636          (out       (mkstemp! template)))
 637     (dynamic-wind
 638       (lambda ()
 639         #t)
 640       (lambda ()
 641         (proc template out))
 642       (lambda ()
 643         (false-if-exception (close out))
 644         (false-if-exception (delete-file template))))))
 645
 646 (define (with-atomic-file-output file proc)
 647   "Call PROC with an output port for the file that is going to replace FILE.
 648 Upon success, FILE is atomically replaced by what has been written to the
 649 output port, and PROC's result is returned."
 650   (let* ((template (string-append file ".XXXXXX"))
 651          (out      (mkstemp! template)))
 652     (with-throw-handler #t
 653       (lambda ()
 654         (let ((result (proc out)))
 655           (close out)
 656           (rename-file template file)
 657           result))
 658       (lambda (key . args)
 659         (false-if-exception (delete-file template))))))
 660
 661 (define fold2
 662   (case-lambda
 663     ((proc seed1 seed2 lst)
 664      "Like `fold', but with a single list and two seeds."
 665      (let loop ((result1 seed1)
 666                 (result2 seed2)
 667                 (lst     lst))
 668        (if (null? lst)
 669            (values result1 result2)
 670            (call-with-values
 671                (lambda () (proc (car lst) result1 result2))
 672              (lambda (result1 result2)
 673                (loop result1 result2 (cdr lst)))))))
 674     ((proc seed1 seed2 lst1 lst2)
 675      "Like `fold', but with a two lists and two seeds."
 676      (let loop ((result1 seed1)
 677                 (result2 seed2)
 678                 (lst1    lst1)
 679                 (lst2    lst2))
 680        (if (or (null? lst1) (null? lst2))
 681            (values result1 result2)
 682            (call-with-values
 683                (lambda () (proc (car lst1) (car lst2) result1 result2))
 684              (lambda (result1 result2)
 685                (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
 686
 687 (define (fold-tree proc init children roots)
 688   "Call (PROC NODE RESULT) for each node in the tree that is reachable from
 689 ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
 690 are traversed is not specified, however, each node is visited only once, based
 691 on an eq? check.  Children of a node to be visited are generated by
 692 calling (CHILDREN NODE), the result of which should be a list of nodes that
 693 are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
 694   (let loop ((result init)
 695              (seen vlist-null)
 696              (lst roots))
 697     (match lst
 698       (() result)
 699       ((head . tail)
 700        (if (not (vhash-assq head seen))
 701            (loop (proc head result)
 702                  (vhash-consq head #t seen)
 703                  (match (children head)
 704                    ((or () #f) tail)
 705                    (children (append tail children))))
 706            (loop result seen tail))))))
 707
 708 (define (fold-tree-leaves proc init children roots)
 709   "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
 710   (fold-tree
 711    (lambda (node result)
 712      (match (children node)
 713        ((or () #f) (proc node result))
 714        (else result)))
 715    init children roots))
 716
 717 \f
 718 ;;;
 719 ;;; Source location.
 720 ;;;
 721
 722 ;; A source location.
 723 (define-record-type <location>
 724   (make-location file line column)
 725   location?
 726   (file          location-file)                   ; file name
 727   (line          location-line)                   ; 1-indexed line
 728   (column        location-column))                ; 0-indexed column
 729
 730 (define location
 731   (memoize
 732    (lambda (file line column)
 733      "Return the <location> object for the given FILE, LINE, and COLUMN."
 734      (and line column file
 735           (make-location file line column)))))
 736
 737 (define (source-properties->location loc)
 738   "Return a location object based on the info in LOC, an alist as returned
 739 by Guile's `source-properties', `frame-source', `current-source-location',
 740 etc."
 741   (let ((file (assq-ref loc 'filename))
 742         (line (assq-ref loc 'line))
 743         (col  (assq-ref loc 'column)))
 744     ;; In accordance with the GCS, start line and column numbers at 1.  Note
 745     ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
 746     (location file (and line (+ line 1)) col)))