1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
3 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (use-modules (system base target)
27 '(unsupported-warning format unbound-variable arity-mismatch))
29 (define host (getenv "host"))
31 (define srcdir (getenv "srcdir"))
33 (define (relative-file file)
34 (if (string-prefix? (string-append srcdir "/") file)
35 (string-drop file (+ 1 (string-length srcdir)))
38 (define (file-mtime<? f1 f2)
39 (< (stat:mtime (stat f1))
40 (stat:mtime (stat f2))))
42 (define (scm->go file)
43 (let* ((relative (relative-file file))
44 (without-extension (string-drop-right relative 4)))
45 (string-append without-extension ".go")))
47 (define (file-needs-compilation? file)
48 (let ((go (scm->go file)))
49 (or (not (file-exists? go))
50 (file-mtime<? go file))))
52 (define (file->module file)
53 (let* ((relative (relative-file file))
54 (module-path (string-drop-right relative 4)))
56 (string-split module-path #\/))))
58 ;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
59 ;;; files to be compiled first. We do this via resolve-interface so that the
60 ;;; top-level of each file (module) is only executed once.
61 (define (load-module-file file)
62 (let ((module (file->module file)))
63 (format #t " LOAD ~a~%" module)
64 (resolve-interface module)))
66 (define (compile-file* file output-mutex)
67 (let ((go (scm->go file)))
68 (with-mutex output-mutex
69 (format #t " GUILEC ~a~%" go)
71 (mkdir-p (dirname go))
72 (with-fluids ((*current-warning-prefix* ""))
77 #:opts `(#:warnings ,warnings)))))))
79 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
80 ;; opportunity to run upon SIGINT and to remove temporary output files.
87 (let ((files (filter file-needs-compilation? files)))
88 (for-each load-module-file files)
89 (let ((mutex (make-mutex)))
90 ;; Make sure compilation related modules are loaded before starting to
91 ;; compile files in parallel.
93 (par-for-each (lambda (file)
94 (compile-file* file mutex))
98 ;;; eval: (put 'with-target 'scheme-indent-function 1)