X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/639bf3e507959ca53fef713306eb33f1074f1588..aacc689677316ebb1ea45bb8fb22f921ebaf97d5:/module/system/base/compile.scm diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 26dd29e20..db05d1790 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -1,6 +1,6 @@ ;;; High-level compiler interface -;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -26,43 +26,18 @@ #:use-module (ice-9 regex) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) - #:export (syntax-error - *current-language* - compiled-file-name compile-file compile-and-load + #:export (compiled-file-name + compile-file + compile-and-load + read-and-compile compile - decompile) - #:export-syntax (call-with-compile-error-catch)) + decompile)) -;;; -;;; Compiler environment -;;; - -(define (syntax-error loc msg exp) - (throw 'syntax-error-compile-time loc msg exp)) - -(define-macro (call-with-compile-error-catch thunk) - `(catch 'syntax-error-compile-time - ,thunk - (lambda (key loc msg exp) - (if (pair? loc) - (let ((file (or (assq-ref loc 'filename) "unknown file")) - (line (assq-ref loc 'line)) - (col (assq-ref loc 'column))) - (format (current-error-port) - "~A:~A:~A: ~A: ~A~%" file line col msg exp)) - (format (current-error-port) - "unknown location: ~A: ~S~%" msg exp))))) - ;;; ;;; Compiler ;;; -(define *current-language* (make-fluid)) -(fluid-set! *current-language* 'scheme) -(define (current-language) - (fluid-ref *current-language*)) - (define (call-once thunk) (let ((entered #f)) (dynamic-wind @@ -73,6 +48,7 @@ thunk (lambda () #t)))) +;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1) (define* (call-with-output-file/atomic filename proc #:optional reference) (let* ((template (string-append filename ".XXXXXX")) (tmp (mkstemp! template))) @@ -83,11 +59,9 @@ (proc tmp) (chmod tmp (logand #o0666 (lognot (umask)))) (close-port tmp) - (if reference - (let ((st (stat reference))) - (utime template (stat:atime st) (stat:mtime st)))) (rename-file template filename)) (lambda args + (close-port tmp) (delete-file template))))))) (define (ensure-language x) @@ -95,33 +69,50 @@ x (lookup-language x))) -;; Throws an exception if `dir' is not writable. The double-stat is OK, -;; as this is only used during compilation. -(define (ensure-writable-dir dir) - (if (file-exists? dir) - (if (access? dir W_OK) - #t - (error "directory not writable" dir)) - (begin - (ensure-writable-dir (dirname dir)) - (mkdir dir)))) - -(define (dsu-sort list key less) - (map cdr - (stable-sort (map (lambda (x) (cons (key x) x)) list) - (lambda (x y) (less (car x) (car y)))))) +;; Throws an exception if `dir' is not writable. The mkdir occurs +;; before the check, so that we avoid races (possibly due to parallel +;; compilation). +;; +(define (ensure-directory dir) + (catch 'system-error + (lambda () + (mkdir dir)) + (lambda (k subr fmt args rest) + (let ((errno (and (pair? rest) (car rest)))) + (cond + ((eqv? errno EEXIST) + ;; Assume it's a writable directory, to avoid TOCTOU errors, + ;; as well as UID/EUID mismatches that occur with access(2). + #t) + ((eqv? errno ENOENT) + (ensure-directory (dirname dir)) + (ensure-directory dir)) + (else + (throw k subr fmt args rest))))))) ;;; This function is among the trickiest I've ever written. I tried many ;;; variants. In the end, simple is best, of course. ;;; -;;; After turning this around a number of times, it seems that the the +;;; After turning this around a number of times, it seems that the ;;; desired behavior is that .go files should exist in a path, for ;;; searching. That is orthogonal to this function. For writing .go ;;; files, either you know where they should go, in which case you tell ;;; compile-file explicitly, as in the srcdir != builddir case; or you ;;; don't know, in which case this function is called, and we just put -;;; them in your own ccache dir in ~/.guile-ccache. +;;; them in your own ccache dir in ~/.cache/guile/ccache. +;;; +;;; See also boot-9.scm:load. (define (compiled-file-name file) + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. + (define (canonical->suffix canon) + (cond + ((string-prefix? "/" canon) canon) + ((and (> (string-length canon) 2) + (eqv? (string-ref canon 1) #\:)) + ;; Paths like C:... transform to /C... + (string-append "/" (substring canon 0 1) (substring canon 2))) + (else canon))) (define (compiled-extension) (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) @@ -132,36 +123,43 @@ (and %compile-fallback-path (let ((f (string-append %compile-fallback-path - ;; no need for '/' separator here, canonicalize-path - ;; will give us an absolute path - (canonicalize-path file) + (canonical->suffix (canonicalize-path file)) (compiled-extension)))) - (and (false-if-exception (ensure-writable-dir (dirname f))) + (and (false-if-exception (ensure-directory (dirname f))) f)))) (define* (compile-file file #:key (output-file #f) - (env #f) (from (current-language)) (to 'objcode) - (opts '())) - (let* ((comp (or output-file (compiled-file-name file))) - (in (open-input-file file)) - (enc (file-encoding in))) - (if enc - (set-port-encoding! in enc)) - (ensure-writable-dir (dirname comp)) - (call-with-output-file/atomic comp - (lambda (port) - ((language-printer (ensure-language to)) - (read-and-compile in #:env env #:from from #:to to #:opts opts) - port)) - file) - comp)) + (env (default-environment from)) + (opts '()) + (canonicalization 'relative)) + (with-fluids ((%file-port-name-canonicalization canonicalization)) + (let* ((comp (or output-file (compiled-file-name file) + (error "failed to create path for auto-compiled file" + file))) + (in (open-input-file file)) + (enc (file-encoding in))) + ;; Choose the input encoding deterministically. + (set-port-encoding! in (or enc "UTF-8")) -(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) - (read-and-compile (open-input-file file) - #:from from #:to to #:opts opts)) + (ensure-directory (dirname comp)) + (call-with-output-file/atomic comp + (lambda (port) + ((language-printer (ensure-language to)) + (read-and-compile in #:env env #:from from #:to to #:opts opts) + port)) + file) + comp))) + +(define* (compile-and-load file #:key (from (current-language)) (to 'value) + (env (current-module)) (opts '()) + (canonicalization 'relative)) + (with-fluids ((%file-port-name-canonicalization canonicalization)) + (read-and-compile (open-input-file file) + #:from from #:to to #:opts opts + #:env env))) ;;; @@ -184,27 +182,48 @@ (let lp ((in (reverse (or (lookup-compilation-order from to) (error "no way to compile" from "to" to)))) (lang to)) - (cond ((null? in) - (error "don't know how to join expressions" from to)) + (cond ((null? in) to) ((language-joiner lang) lang) (else (lp (cdr in) (caar in)))))) +(define (default-language-joiner lang) + (lambda (exps env) + (if (and (pair? exps) (null? (cdr exps))) + (car exps) + (error + "Multiple expressions read and compiled, but language has no joiner" + lang)))) + +(define (read-and-parse lang port cenv) + (let ((exp ((language-reader lang) port cenv))) + (cond + ((eof-object? exp) exp) + ((language-parser lang) => (lambda (parse) (parse exp))) + (else exp)))) + (define* (read-and-compile port #:key - (env #f) (from (current-language)) (to 'objcode) + (env (default-environment from)) (opts '())) (let ((from (ensure-language from)) (to (ensure-language to))) (let ((joint (find-language-joint from to))) - (with-fluids ((*current-language* from)) + (parameterize ((current-language from)) (let lp ((exps '()) (env #f) (cenv env)) - (let ((x ((language-reader (current-language)) port))) + (let ((x (read-and-parse (current-language) port cenv))) (cond ((eof-object? x) - (compile ((language-joiner joint) (reverse exps) env) - #:from joint #:to to #:env env #:opts opts)) + (close-port port) + (compile ((or (language-joiner joint) + (default-language-joiner joint)) + (reverse exps) + env) + #:from joint #:to to + ;; env can be false if no expressions were read. + #:env (or env (default-environment joint)) + #:opts opts)) (else ;; compile-fold instead of compile so we get the env too (receive (jexp jenv jcenv) @@ -213,9 +232,9 @@ (lp (cons jexp exps) jenv jcenv)))))))))) (define* (compile x #:key - (env #f) (from (current-language)) (to 'value) + (env (default-environment from)) (opts '())) (let ((warnings (memq #:warnings opts)))