suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added support for automatic compilation of source files to drscheme

Browse Source 
svn: r12356
This commit is contained in:
Robby Findler 2008-11-08 18:34:39 +00:00
parent b0a0c8c2ce
commit 1490cd1c4d
5 changed files with 153 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/compiler/cm.ss
View File

@ -10,6 +10,7 @@
make-caching-managed-compile-zo
trust-existing-zos
manager-compile-notify-handler
current-path->compilation-dir
(rename-out [trace manager-trace-handler]))
(define manager-compile-notify-handler (make-parameter void))
@ -17,6 +18,8 @@
(define indent (make-parameter ""))
(define trust-existing-zos (make-parameter #f))
(define current-path->compilation-dir (make-parameter #f))
(define (trace-printf fmt . args)
(let ([t (trace)])
(unless (eq? t void)
@ -30,16 +33,22 @@
(define (get-compilation-dir+name mode path)
(let-values ([(base name must-be-dir?) (split-path path)])
(values (if (eq? 'relative base) mode (build-path base mode))
name)))
(values
(cond
[(current-path->compilation-dir)
=>
(λ (f) (f path))]
[(eq? 'relative base) mode]
[else (build-path base mode)])
name)))
(define (get-compilation-path mode path)
(let-values ([(dir name) (get-compilation-dir+name mode path)])
(build-path dir name)))
(define (get-compilation-dir mode path)
(let-values ([(base name-suffix must-be-dir?) (split-path path)])
(if (eq? 'relative base) mode (build-path base mode))))
(let-values ([(dir name) (get-compilation-dir+name mode path)])
dir))
(define (touch path)
(close-output-port (open-output-file path #:exists 'append)))
@ -295,13 +304,18 @@
[orig-load (current-load)]
[orig-registry (namespace-module-registry (current-namespace))]
[default-handler (current-load/use-compiled)]
[orig-path->compilation-dir-handler (current-path->compilation-dir)]
[modes (use-compiled-file-paths)])
(define (compilation-manager-load-handler path mod-name)
(cond [(not mod-name)
(trace-printf "skipping: ~a mod-name ~s" path mod-name)]
[(not (member (car modes) (use-compiled-file-paths)))
(trace-printf "skipping: ~a compiled-paths ~s"
path (use-compiled-file-paths))]
[(or (null? (use-compiled-file-paths))
(not (equal? (car modes)
(car (use-compiled-file-paths)))))
(trace-printf "skipping: ~a compiled-paths's first element changed; current value ~s, first element was ~s"
path
(use-compiled-file-paths)
(car modes))]
[(not (eq? compilation-manager-load-handler
(current-load/use-compiled)))
(trace-printf "skipping: ~a current-load/use-compiled changed ~s"
@ -317,6 +331,11 @@
(trace-printf "skipping: ~a orig-registry ~s current-registry ~s"
path orig-registry
(namespace-module-registry (current-namespace)))]
[(not (eq? (current-path->compilation-dir)
orig-path->compilation-dir-handler))
(trace-printf "skipping: ~a orig path->compilation-dir-handler ~s current path->compilation-dir-handler ~s"
orig-path->compilation-dir-handler
(current-path->compilation-dir))]
[else
(trace-printf "processing: ~a" path)
(compile-root (car modes) path cache read-syntax)

74
collects/drscheme/private/rep.ss
View File

@ -25,12 +25,14 @@ TODO
scheme/pretty
scheme/unit
scheme/list
"drsig.ss"
string-constants
setup/xref
scheme/gui/base
framework
browser/external)
browser/external
"drsig.ss"
"zo-cache.ss")
(provide rep@ with-stacktrace-name)
@ -1293,7 +1295,7 @@ TODO
;; set this relatively late, so that the
;; setup code for the language doesn't use it
;(current-load/use-compiled drscheme-load/use-compiled-handler)
(current-load/use-compiled drscheme-load/use-compiled-handler)
;; after this returns, future event dispatches
;; will use the user's break parameterization
@ -1703,65 +1705,19 @@ TODO
(define drscheme-load/use-compiled-handler
(let ([ol (current-load/use-compiled)])
(λ (path mod) ;; =User=
(verify-file-saved path)
(cond
[(already-a-compiled-file? path)
(ol path mod)]
[else
(error 'drscheme-load/use-compiled-handler
"time to compile! ~s" path)]))))
;; =User=
(define (verify-file-saved path)
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(let ([s (make-semaphore 0)])
(queue-callback
(λ () ;; =Kernel= =Handler=
(let ([frame (send (group:get-the-frame-group) locate-file path)])
(when frame
(send frame offer-to-save-file path)))
(semaphore-post s)))
(semaphore-wait s))))
(parameterize ([current-eventspace drscheme:init:system-eventspace])
(let ([s (make-semaphore 0)])
(queue-callback
(λ () ;; =Kernel= =Handler=
(let ([frame (send (group:get-the-frame-group) locate-file path)])
(when frame
(send frame offer-to-save-file path)))
(semaphore-post s)))
(semaphore-wait s)))
;; =User=
(define (already-a-compiled-file? path)
(let* ([filename (file-name-from-path path)]
[base (path-only path)]
[extension (and filename base (filename-extension filename))]
[basename (and extension
(let ([pbs (path->bytes filename)])
(subbytes pbs
0
(- (bytes-length pbs)
(bytes-length extension)
1 ;; extra one for '.' in there
))))]
[fm (file-or-directory-modify-seconds path)]
[newer-exists?
(λ (pot-path)
(and (file-exists? pot-path)
(< fm (file-or-directory-modify-seconds pot-path))))])
(and basename
(ormap
(λ (c-f-p)
(or (newer-exists? (build-path base c-f-p
(bytes->path
(bytes-append basename #"_" extension #".zo"))))
(ormap
(λ (ext)
(newer-exists? (build-path base
c-f-p
"native"
(system-library-subpath)
(bytes->path
(bytes-append basename #"_" extension ext)))))
'(#".so" #".dll" #".dylib"))))
(use-compiled-file-paths)))))
(build-and-load-zo-file ol path mod))))
(define (path->cache-zo-file-path path)
(apply build-path
(cdr (explode-path path))))
;; insert-error-in-text : (is-a?/c text%)

100
collects/drscheme/private/zo-cache.ss Normal file
View File

@ -0,0 +1,100 @@
#lang scheme/base
(require scheme/path
scheme/file
compiler/cm)
#|
All of this code runs on the user's parameterization/thread
|#
(provide build-and-load-zo-file)
(define (build-and-load-zo-file original-load/use-compiled-handler path mod)
(cond
[(or (not (filename-extension path))
(already-a-compiled-file? path))
;; if there is no extension, just give up.
;; if there is a compiled file that look up to date
;; in the usual place, use it.
(original-load/use-compiled-handler path mod)]
[else
;; otherwise do some managed compilation
(parameterize ([current-path->compilation-dir path->cache-path])
(managed-compile-zo path))
;; and then load the compiled file
(let-values ([(base name dir) (split-path path)])
(original-load/use-compiled-handler
(build-path (path->cache-path path) (compiled-name name #".zo"))
mod))]))
;; path->cache-path : path[w/extension] -> path
;; returns the location of the cached zo file that corresponds to its input
(define (path->cache-path path)
(cond
[(already-a-compiled-file? path)
(let ([mode (car (use-compiled-file-paths))])
(let-values ([(base name must-be-dir?) (split-path path)])
(cond
[(eq? 'relative base) mode]
[else (build-path base mode)])))]
[else
(apply build-path
(find-system-path 'addon-dir)
(version)
"drscheme-zo-cache"
(remove-last (cdr (explode-path (normalize-path path))))
#;(replace-last-with-zo (cdr (explode-path (normalize-path path)))))]))
(define (remove-last lst) (reverse (cdr (reverse lst))))
(define (replace-last-with-zo lst)
(cond
[(null? (cdr lst))
(list (compiled-name (car lst)))]
[else (cons (car lst) (replace-last-with-zo (cdr lst)))]))
(define (exists-and-is-newer? orig-path candidate-path)
(and (file-exists? candidate-path)
(< (file-or-directory-modify-seconds orig-path)
(file-or-directory-modify-seconds candidate-path))))
(define (already-a-compiled-file? path)
(let* ([filename (file-name-from-path path)]
[base (path-only path)]
[file-zo-name (and filename (compiled-name filename #".zo"))]
[fm (file-or-directory-modify-seconds path)]
[newer-exists?
(λ (pot-path)
(and (file-exists? pot-path)
(< fm (file-or-directory-modify-seconds pot-path))))])
(and file-zo-name
(ormap
(λ (c-f-p)
(or (newer-exists? (build-path base c-f-p file-zo-name))
(newer-exists? (build-path base
c-f-p
"native"
(system-library-subpath)
(compiled-name filename (system-type 'so-suffix))))))
(use-compiled-file-paths)))))
;; compiled-name : path [bytes] -> path or #f
;; returns #f if the path does not have an extension.
;; otherwise, returns an appropriately modified filename, extended with new-extension
(define (compiled-name path new-extension)
(let* ([extension (filename-extension path)]
[basename (and extension
(let ([pbs (path->bytes path)])
(subbytes pbs
0
(- (bytes-length pbs)
(bytes-length extension)
1 ;; extra one for '.' in there
))))])
(and basename
(bytes->path
(bytes-append basename #"_" extension new-extension)))))

1
collects/framework/private/editor.ss
View File

@ -202,6 +202,7 @@
(file-exists? filename)
(file-or-directory-modify-seconds filename)))))
(inner (void) after-load-file success?))
(define/public (save-file-out-of-date?)
(and last-saved-file-time
(let ([fn (get-filename)])

9
collects/scribblings/mzc/make.scrbl
View File

@ -241,6 +241,15 @@ A parameter for a procedure of one argument that is called to report
compilation-manager actions, such as checking a file. The argument to
the procedure is a string.}
@defparam[current-path->compilation-dir path->compilation-dir (or/c #f (-> path? path?))]{
This parameter controls the location where compiled .zo files are
saved. It is called with the path of a @tt{.ss} file and is expected
to return a path where the @tt{.zo} and @tt{.dep} file can be saved.
If it is @scheme[#f], then @scheme[use-compiled-file-paths] is used.
}
@; ----------------------------------------------------------------------
@section{Compilation Manager Hook for Syntax Transformers}