summaryrefslogtreecommitdiff
path: root/module/system/base/compile.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-06-03 09:02:48 +0200
committerAndy Wingo <wingo@pobox.com>2009-06-03 22:20:55 +0200
commitf3130a2ecf218f3709de13c10c54e8586fe0aef2 (patch)
treee01e9fe1aa53bf68d214018835f71c2481bdcb0f /module/system/base/compile.scm
parent4c9c9b9b9822658ee32a9561f56ac3b9d87b0fee (diff)
downloadguile-f3130a2ecf218f3709de13c10c54e8586fe0aef2.tar.gz
compiled-file-name tries to put the .go in the %load-compiled-path
* module/system/base/compile.scm (ensure-writable-dir): Rename from ensure-directory. (dsu-sort): Helper, does a decorate / sort / undecorate. (compiled-file-name): Refactor to only return a writable filename. The readable case is handled by load.c now, and the other case was silly. Hopefully it will do the right thing. (load-ensuring-compiled): Remove, load.c will call out to compile-file if necessary. (ensure-fallback-path): Remove, load.c will add the ~/.guile-ccache dir to the load-compiled path, which will prompt its creation if necessary.
Diffstat (limited to 'module/system/base/compile.scm')
-rw-r--r--module/system/base/compile.scm155
1 files changed, 57 insertions, 98 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index f995d908f..d5933edad 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -29,7 +29,6 @@
#:export (syntax-error
*current-language*
compiled-file-name compile-file compile-and-load
- load-ensuring-compiled
compile
decompile)
#:export-syntax (call-with-compile-error-catch))
@@ -93,12 +92,65 @@
x
(lookup-language x)))
-(define (ensure-directory dir)
- (or (file-exists? dir)
+;; 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-directory (dirname dir))
+ (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))))))
+
+(define (compiled-file-name file)
+ (let ((cext (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions)))))
+ (define (strip-source-extension path)
+ (let lp ((exts %load-extensions))
+ (cond ((null? exts) file)
+ ((string-null? (car exts)) (lp (cdr exts)))
+ ((string-suffix? (car exts) path)
+ (substring path 0
+ (- (string-length path)
+ (string-length (car exts)))))
+ (else (lp (cdr exts))))))
+ ;; there is some trickery here. if no %load-compiled-path is a
+ ;; prefix of `file', the stability of the sort makes us end up
+ ;; trying to write first to last dir in the path, which is usually
+ ;; the $HOME ccache dir.
+ (let lp ((paths (dsu-sort (reverse %load-compiled-path)
+ (lambda (x)
+ (if (string-prefix? x file)
+ (string-length x)
+ 0))
+ >)))
+ (if (null? paths)
+ (error "no writable path when compiling" file)
+ (let ((rpath (in-vicinity
+ (car paths)
+ (string-append
+ (strip-source-extension
+ (if (string-prefix? (car paths) file)
+ (substring file (1+ (string-length (car paths))))
+ (substring file 1)))
+ cext))))
+ (if (and (false-if-exception
+ (ensure-writable-dir (dirname rpath)))
+ (or (not (file-exists? rpath))
+ (access? rpath W_OK)))
+ rpath
+ (lp (cdr paths))))))))
+
(define* (compile-file file #:key
(output-file #f)
(env #f)
@@ -107,7 +159,7 @@
(opts '()))
(let ((comp (or output-file (compiled-file-name file)))
(in (open-input-file file)))
- (ensure-directory (dirname comp))
+ (ensure-writable-dir (dirname comp))
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
@@ -119,99 +171,6 @@
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts))
-(define* (load-ensuring-compiled source #:key (from 'scheme)
- (to 'value) (opts '()))
- (let ((compiled (compiled-file-name source #:readable #t)))
- (load-compiled
- (if (and compiled
- (>= (stat:mtime (stat compiled)) (stat:mtime (stat source))))
- compiled
- (let ((to-compile (compiled-file-name source #:writable #t)))
- (if compiled
- (warn "source file" source "newer than" compiled))
- (if (and compiled
- (not (string-equal? compiled to-compile))
- (file-exists? to-compile)
- (>= (stat:mtime (stat to-compile))
- (stat:mtime (stat compiled))))
- (warn "using local compiled copy" to-compile)
- (begin
- (format (current-error-port) ";;; Compiling ~s\n" source)
- (compile-file source #:output-file to-compile)
- (format (current-error-port) ";;; Success: ~s\n" to-compile)))
- to-compile)))))
-
-(define (ensure-fallback-path)
- (let ((home (or (getenv "HOME")
- (false-if-exception
- (passwd:dir (getpwuid (getuid)))))))
- (and home
- (let ((cache (in-vicinity home ".guile-ccache")))
- (cond
- ((and (access? cache (logior W_OK X_OK))
- (file-is-directory? cache))
- cache)
- ((not (file-exists? cache))
- (and (false-if-exception (mkdir cache))
- cache))
- (else #f))))))
-
-(define load-compiled-path
- (let ((fallback-path #f))
- (lambda ()
- (if (not fallback-path)
- (let ((cache-path (ensure-fallback-path)))
- (set! fallback-path
- (if cache-path
- (list cache-path)
- '()))))
- (append %load-path fallback-path))))
-
-(define* (compiled-file-name file #:key (writable #f) (readable #f))
- (let ((base (basename file))
- (cext (cond ((or (null? %load-compiled-extensions)
- (string-null? (car %load-compiled-extensions)))
- (warn "invalid %load-compiled-extensions"
- %load-compiled-extensions)
- ".go")
- (else (car %load-compiled-extensions)))))
- (define (strip-source-extension base)
- (let lp ((exts %load-extensions))
- (cond ((null? exts) (string-append file cext))
- ((string-null? (car exts)) (lp (cdr exts)))
- ((string-suffix? (car exts) base)
- (substring source 0
- (- (string-length source)
- (string-length (car exts)))))
- (else (lp (cdr exts))))))
- (define (strip-path file paths)
- (let lp ((paths paths))
- (cond ((null? paths) file)
- ((string-prefix? (car paths) file)
- (substring file (1+ (string-length (car paths)))))
- (else (lp (cdr paths))))))
- (let ((sibling (string-append (strip-source-extension file) cext)))
- (cond
- (writable
- ;; either put it right beside the original file, or in our
- ;; ccache. other things wind up not making sense.
- (cond
- ((or (not (file-exists? sibling)) (access? sibling W_OK))
- sibling)
- ((ensure-fallback-path)
- => (lambda (p)
- (string-append p "/" (strip-path sibling))))
- (else #f)))
- (readable
- (if (access? sibling R_OK)
- sibling
- (search-path (load-compiled-path)
- (strip-path (strip-source-extension file))
- %load-compiled-extensions #t)))
- (else
- sibling)))))
-
-
;;;
;;; Compiler interface