mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Split `load-in-vicinity' into small procedures.

Browse source 
* module/ice-9/boot-9.scm (load-in-vicinity)[compiled-extension]: New
  variable.
  [compiled-file-name]: Rename to...
  [fallback-file-name]: ... this; update caller.  Use COMPILED-EXTENSION.
  [more-recent?, compile, warn-about-exception]: New procedures.
  [fresh-compiled-file-name]: Use them.
This commit is contained in:
Ludovic Courtès 2012-11-26 22:41:23 +01:00
parent 6356e0dc2f
commit 9fbca4b32e
1 changed files with 54 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

89
module/ice-9/boot-9.scm
View file

@ -3569,6 +3569,10 @@ module '(ice-9 q) '(make-q q-length))}."
duplicate-case-datum bad-case-datum)))
(define* (load-in-vicinity dir path #:optional reader)
"Load source file PATH in vicinity of directory DIR. Use a pre-compiled
version of PATH when available, and auto-compile one when none is available,
reading PATH with READER."
(define (canonical->suffix canon)
(cond
((string-prefix? "/" canon) canon)
@ -3578,6 +3582,49 @@ module '(ice-9 q) '(make-q q-length))}."
(string-append "/" (substring canon 0 1) (substring canon 2)))
(else canon)))
(define compiled-extension
;; File name extension of compiled files.
(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 (more-recent? stat1 stat2)
;; Return #t when STAT1 has an mtime greater than that of STAT2.
(or (> (stat:mtime stat1) (stat:mtime stat2))
(and (= (stat:mtime stat1) (stat:mtime stat2))
(>= (stat:mtimensec stat1)
(stat:mtimensec stat2)))))
(define (fallback-file-name canon-path)
;; Return the in-cache compiled file name for source file CANON-PATH.
;; FIXME: would probably be better just to append SHA1(canon-path)
;; to the %compile-fallback-path, to avoid deep directory stats.
(and %compile-fallback-path
(string-append %compile-fallback-path
(canonical->suffix canon-path)
compiled-extension)))
(define (compile file)
;; Compile source FILE, lazily loading the compiler.
((module-ref (resolve-interface '(system base compile))
'compile-file)
file
#:opts %auto-compilation-options
#:env (current-module)))
(define (warn-about-exception key args)
(for-each (lambda (s)
(if (not (string-null? s))
(format (current-warning-port) ";;; ~a\n" s)))
(string-split
(call-with-output-string
(lambda (port) (print-exception port #f key args)))
#\newline)))
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
;; date, and auto-compilation is enabled, will try auto-compilation, just
@ -3587,32 +3634,16 @@ module '(ice-9 q) '(make-q q-length))}."
;; NB: Unless we need to compile the file, this function should not cause
;; (system base compile) to be loaded up. For that reason compiled-file-name
;; partially duplicates functionality from (system base compile).
;;
(define (compiled-file-name canon-path)
;; FIXME: would probably be better just to append SHA1(canon-path)
;; to the %compile-fallback-path, to avoid deep directory stats.
(and %compile-fallback-path
(string-append
%compile-fallback-path
(canonical->suffix canon-path)
(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 (fresh-compiled-file-name name go-path)
;; Return GO-PATH after making sure that it contains a freshly compiled
;; version of source file NAME; return #f on failure.
(catch #t
(lambda ()
(let* ((scmstat (stat name))
(gostat (and (not %fresh-auto-compile)
(stat go-path #f))))
(if (and gostat
(or (> (stat:mtime gostat) (stat:mtime scmstat))
(and (= (stat:mtime gostat) (stat:mtime scmstat))
(>= (stat:mtimensec gostat)
(stat:mtimensec scmstat)))))
(if (and gostat (more-recent? gostat scmstat))
go-path
(begin
(if gostat
@ -3623,26 +3654,14 @@ module '(ice-9 q) '(make-q q-length))}."
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
(format (current-warning-port) ";;; compiling ~a\n" name)
(let ((cfn
((module-ref
(resolve-interface '(system base compile))
'compile-file)
name
#:opts %auto-compilation-options
#:env (current-module))))
(let ((cfn (compile name)))
(format (current-warning-port) ";;; compiled ~a\n" cfn)
cfn))
(else #f))))))
(lambda (k . args)
(format (current-warning-port)
";;; WARNING: compilation of ~a failed:\n" name)
(for-each (lambda (s)
(if (not (string-null? s))
(format (current-warning-port) ";;; ~a\n" s)))
(string-split
(call-with-output-string
(lambda (port) (print-exception port #f k args)))
#\newline))
(warn-about-exception k args)
#f)))
(define (absolute-path? path)
@ -3651,7 +3670,7 @@ module '(ice-9 q) '(make-q q-length))}."
(define (load-absolute abs-path)
(let ((cfn (let ((canon (false-if-exception (canonicalize-path abs-path))))
(and canon
(let ((go-path (compiled-file-name canon)))
(let ((go-path (fallback-file-name canon)))
(and go-path
(fresh-compiled-file-name abs-path go-path)))))))
(if cfn
@ -3667,7 +3686,7 @@ module '(ice-9 q) '(make-q q-length))}."
(with-fluids ((current-reader reader)
(%file-port-name-canonicalization 'relative))
(cond
((or (absolute-path? path))
((absolute-path? path)
(load-absolute path))
((absolute-path? dir)
(load-absolute (in-vicinity dir path)))