Merge branch 'master' of git.racket-lang.org:plt
This commit is contained in:
commit
88820fc4a4
|
@ -197,9 +197,7 @@
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(define l (pth-cmd))
|
(define l (pth-cmd))
|
||||||
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
|
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
|
||||||
["HOME" (home-dir (current-worker))])
|
["HOME" (make-fresh-home-dir)])
|
||||||
; XXX Maybe this should destroy the old home and copy in a new one
|
|
||||||
; Otherwise it is a source of randomness
|
|
||||||
(with-temporary-directory
|
(with-temporary-directory
|
||||||
(run/collect/wait/log log-pth
|
(run/collect/wait/log log-pth
|
||||||
#:timeout pth-timeout
|
#:timeout pth-timeout
|
||||||
|
@ -234,14 +232,6 @@
|
||||||
(build-path log-dir "src" "build" "set-browser.ss")
|
(build-path log-dir "src" "build" "set-browser.ss")
|
||||||
mzscheme-path
|
mzscheme-path
|
||||||
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
|
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
|
||||||
; Make home directories
|
|
||||||
(cache/file/timestamp
|
|
||||||
(build-path rev-dir "homedir-dup")
|
|
||||||
(lambda ()
|
|
||||||
(notify! "Copying home directory for each worker")
|
|
||||||
(for ([i (in-range (number-of-cpus))])
|
|
||||||
(with-handlers ([exn:fail? void])
|
|
||||||
(copy-directory/files (hash-ref (current-env) "HOME") (home-dir i))))))
|
|
||||||
; And go
|
; And go
|
||||||
(notify! "Starting testing")
|
(notify! "Starting testing")
|
||||||
(test-directory collects-pth top-sema)
|
(test-directory collects-pth top-sema)
|
||||||
|
@ -250,10 +240,11 @@
|
||||||
(notify! "Stopping testing")
|
(notify! "Stopping testing")
|
||||||
(stop-job-queue! test-workers))
|
(stop-job-queue! test-workers))
|
||||||
|
|
||||||
(define (home-dir i)
|
(define (make-fresh-home-dir)
|
||||||
(format "~a~a"
|
(define new-dir (make-temporary-file "home~a" 'directory))
|
||||||
(hash-ref (current-env) "HOME")
|
(with-handlers ([exn:fail? void])
|
||||||
i))
|
(copy-directory/files (hash-ref (current-env) "HOME") new-dir))
|
||||||
|
(path->string new-dir))
|
||||||
|
|
||||||
(define (recur-many i r f)
|
(define (recur-many i r f)
|
||||||
(if (zero? i)
|
(if (zero? i)
|
||||||
|
|
|
@ -557,7 +557,8 @@
|
||||||
(define name (path->string rev-pth))
|
(define name (path->string rev-pth))
|
||||||
(define url (format "~a/" name))
|
(define url (format "~a/" name))
|
||||||
(define rev (string->number name))
|
(define rev (string->number name))
|
||||||
(define log (read-cache (revision-commit-msg rev)))
|
(define log-pth (revision-commit-msg rev))
|
||||||
|
(define log (read-cache log-pth))
|
||||||
(define committer (svn-rev-log-author log))
|
(define committer (svn-rev-log-author log))
|
||||||
(define commit-msg (string-first-line (svn-rev-log-msg log)))
|
(define commit-msg (string-first-line (svn-rev-log-msg log)))
|
||||||
(define title
|
(define title
|
||||||
|
@ -566,7 +567,7 @@
|
||||||
commit-msg))
|
commit-msg))
|
||||||
(define (no-rendering-row)
|
(define (no-rendering-row)
|
||||||
(define mtime
|
(define mtime
|
||||||
(file-or-directory-modify-seconds (build-path builds-pth rev-pth)))
|
(file-or-directory-modify-seconds log-pth))
|
||||||
|
|
||||||
`(tr ([class "dir"]
|
`(tr ([class "dir"]
|
||||||
[title ,title])
|
[title ,title])
|
||||||
|
|
|
@ -1,30 +1,31 @@
|
||||||
#lang scheme
|
#lang scheme
|
||||||
(require "dirstruct.ss"
|
(require "status.ss")
|
||||||
"status.ss")
|
|
||||||
|
|
||||||
(define (rewrite-status s)
|
(define (rewrite-status #:rewrite rewrite-string s)
|
||||||
(if (current-rev)
|
(match s
|
||||||
(local [(define from (number->string (current-rev)))]
|
[(struct exit (start end command-line output-log code))
|
||||||
(match s
|
(make-exit start end
|
||||||
[(struct exit (start end command-line output-log code))
|
(rewrite-strings #:rewrite rewrite-string command-line)
|
||||||
(make-exit start end (rewrite-strings from command-line) (rewrite-events from output-log) code)]
|
(rewrite-events #:rewrite rewrite-string output-log)
|
||||||
[(struct timeout (start end command-line output-log))
|
code)]
|
||||||
(make-timeout start end (rewrite-strings from command-line) (rewrite-events from output-log))]))
|
[(struct timeout (start end command-line output-log))
|
||||||
s))
|
(make-timeout start end
|
||||||
|
(rewrite-strings #:rewrite rewrite-string command-line)
|
||||||
|
(rewrite-events #:rewrite rewrite-string output-log))]))
|
||||||
|
|
||||||
(define (rewrite-strings from los)
|
(define (rewrite-strings #:rewrite rewrite-string los)
|
||||||
(map (curry rewrite-string from) los))
|
(map rewrite-string los))
|
||||||
(define (rewrite-events from loe)
|
(define (rewrite-events #:rewrite rewrite-string loe)
|
||||||
(map (rewrite-event from) loe))
|
(map (rewrite-event #:rewrite rewrite-string) loe))
|
||||||
(define (rewrite-event from)
|
(define (rewrite-event #:rewrite rewrite-bytes)
|
||||||
(match-lambda
|
(match-lambda
|
||||||
[(struct stdout (b)) (make-stdout (rewrite-bytes from b))]
|
[(struct stdout (b)) (make-stdout (rewrite-bytes b))]
|
||||||
[(struct stderr (b)) (make-stderr (rewrite-bytes from b))]))
|
[(struct stderr (b)) (make-stderr (rewrite-bytes b))]))
|
||||||
|
|
||||||
(define (rewrite-string from s)
|
|
||||||
(regexp-replace* from s "<current-rev>"))
|
|
||||||
|
|
||||||
(define rewrite-bytes rewrite-string)
|
(define rewrite-string/c
|
||||||
|
((or/c string? bytes?) . -> . (or/c string? bytes?)))
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[rewrite-status (status? . -> . status?)])
|
[rewrite-string/c contract?]
|
||||||
|
[rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)])
|
|
@ -2,6 +2,7 @@
|
||||||
(require "status.ss"
|
(require "status.ss"
|
||||||
"notify.ss"
|
"notify.ss"
|
||||||
"rewriting.ss"
|
"rewriting.ss"
|
||||||
|
"dirstruct.ss"
|
||||||
"cache.ss")
|
"cache.ss")
|
||||||
|
|
||||||
(define (command+args+env->command+args
|
(define (command+args+env->command+args
|
||||||
|
@ -97,6 +98,17 @@
|
||||||
|
|
||||||
final-status))
|
final-status))
|
||||||
|
|
||||||
|
(define-syntax regexp-replace**
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ () s) s]
|
||||||
|
[(_ ([pat0 subst0]
|
||||||
|
[pat subst]
|
||||||
|
...)
|
||||||
|
s)
|
||||||
|
(regexp-replace* pat0
|
||||||
|
(regexp-replace** ([pat subst] ...) s)
|
||||||
|
subst0)]))
|
||||||
|
|
||||||
(define (run/collect/wait/log log-path command
|
(define (run/collect/wait/log log-path command
|
||||||
#:timeout timeout
|
#:timeout timeout
|
||||||
#:env env
|
#:env env
|
||||||
|
@ -105,8 +117,20 @@
|
||||||
(cache/file
|
(cache/file
|
||||||
log-path
|
log-path
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
(define rev (number->string (current-rev)))
|
||||||
|
(define home (hash-ref env "HOME"))
|
||||||
|
(define tmp (hash-ref env "TMPDIR"))
|
||||||
|
(define cwd (path->string (current-directory)))
|
||||||
|
(define (rewrite s)
|
||||||
|
(regexp-replace** ([rev "<current-rev>"]
|
||||||
|
[home "<home>"]
|
||||||
|
[tmp "<tmp>"]
|
||||||
|
[cwd "<cwd>"])
|
||||||
|
s))
|
||||||
|
|
||||||
(set! ran? #t)
|
(set! ran? #t)
|
||||||
(rewrite-status
|
(rewrite-status
|
||||||
|
#:rewrite rewrite
|
||||||
(run/collect/wait
|
(run/collect/wait
|
||||||
#:timeout timeout
|
#:timeout timeout
|
||||||
#:env env
|
#:env env
|
||||||
|
|
|
@ -36,6 +36,7 @@ static void register_traversers(void);
|
||||||
# endif
|
# endif
|
||||||
|
|
||||||
static void *place_start_proc(void *arg);
|
static void *place_start_proc(void *arg);
|
||||||
|
static void *place_start_proc_after_stack(void *data_arg, void *stack_base);
|
||||||
|
|
||||||
# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env)
|
# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env)
|
||||||
|
|
||||||
|
@ -608,6 +609,14 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base
|
||||||
|
|
||||||
static void *place_start_proc(void *data_arg) {
|
static void *place_start_proc(void *data_arg) {
|
||||||
void *stack_base;
|
void *stack_base;
|
||||||
|
void *rc;
|
||||||
|
stack_base = PROMPT_STACK(stack_base);
|
||||||
|
rc = place_start_proc_after_stack(data_arg, stack_base);
|
||||||
|
stack_base = NULL;
|
||||||
|
return rc;
|
||||||
|
}
|
||||||
|
|
||||||
|
static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
|
||||||
Place_Start_Data *place_data;
|
Place_Start_Data *place_data;
|
||||||
Scheme_Object *place_main;
|
Scheme_Object *place_main;
|
||||||
Scheme_Object *a[2], *channel;
|
Scheme_Object *a[2], *channel;
|
||||||
|
@ -615,7 +624,6 @@ static void *place_start_proc(void *data_arg) {
|
||||||
long rc = 0;
|
long rc = 0;
|
||||||
ptid = mz_proc_thread_self();
|
ptid = mz_proc_thread_self();
|
||||||
|
|
||||||
stack_base = PROMPT_STACK(stack_base);
|
|
||||||
place_data = (Place_Start_Data *) data_arg;
|
place_data = (Place_Start_Data *) data_arg;
|
||||||
data_arg = NULL;
|
data_arg = NULL;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user