- (lang (ensure-language (current-language)))
- (to (ensure-language to)))
- (catch 'nothing-at-all
- (lambda ()
- (call-with-compile-error-catch
- (lambda ()
- (call-with-output-file/atomic comp
- (lambda (port)
- (let ((print (language-printer to)))
- (print (compile (read-file-in file lang)
- #:from lang #:to to #:opts opts)
- port))))
- (format #t "wrote `~A'\n" comp))))
- (lambda (key . args)
- (format #t "ERROR: during compilation of ~A:\n" file)
- (display "ERROR: ")
- (apply format #t (cadr args) (caddr args))
- (newline)
- (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
- (delete-file comp)))))
-
-(define* (compile-and-load file #:key (to 'value) (opts '()))
- (let ((lang (ensure-language (current-language))))
- (compile (read-file-in file lang) #:to 'value #:opts opts)))
-
-(define (compiled-file-name file)
+ (in (open-input-file file)))
+ (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)))
+ comp))
+
+(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+ (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))