;;; High-level compiler interface
-;; Copyright (C) 2001, 2009, 2010 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
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
- #:export (syntax-error
- *current-language*
- compiled-file-name
+ #: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)))))
-
-\f
;;;
;;; 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
thunk
(lambda () #t))))
+;; (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)))
(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)
- (stat:atimensec st) (stat:mtimensec st))))
(rename-file template filename))
(lambda args
(delete-file template)))))))
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))))
+;; 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)))
(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
(from (current-language))
(to 'objcode)
(env (default-environment from))
- (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))
+ (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"))
+
+ (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 'scheme) (to 'value)
- (env (current-module)) (opts '()))
- (read-and-compile (open-input-file file)
- #:from from #:to to #:opts opts
- #:env env))
+ (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)))
\f
;;;
(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
(from (current-language))
(to 'objcode)
(let ((joint (find-language-joint from to)))
(with-fluids ((*current-language* from))
(let lp ((exps '()) (env #f) (cenv env))
- (let ((x ((language-reader (current-language)) port cenv)))
+ (let ((x (read-and-parse (current-language) port cenv)))
(cond
((eof-object? x)
- (compile ((language-joiner joint) (reverse exps) env)
+ (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))