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

code tweaks

Browse Source
This commit is contained in:
Matthew Flatt 2013-04-11 05:48:20 -06:00
parent a9a20e9aa7
commit fd614991e6
7 changed files with 1217 additions and 1037 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/tests/racket/path.rktl
View File

@ -5,6 +5,15 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test (string->path "x.zo") path-replace-suffix "x.rkt" ".zo")
(test (string->path "x.zo") path-replace-suffix "x.rkt" #".zo")
(test (string->path "x.zo") path-replace-suffix "x" #".zo")
(test (string->path "x.o.zo") path-replace-suffix "x.o.rkt" #".zo")
(test (string->path "x_rkt.zo") path-add-suffix "x.rkt" ".zo")
(test (string->path "x_rkt.zo") path-add-suffix "x.rkt" #".zo")
(test (string->path "x.zo") path-add-suffix "x" #".zo")
(test (string->path "x.o_rkt.zo") path-add-suffix "x.o.rkt" #".zo")
(define (make-/tf p exn?)
(lambda args
(with-handlers ([exn? (lambda (x) #f)]

2066
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

18
src/racket/src/env.c
View File

@ -544,6 +544,10 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr
scheme_starting_up = 1; /* in case it's not set already */
#ifdef TIME_STARTUP_PROCESS
printf("pre-embedded @ %" PRIdPTR "\n", scheme_get_process_milliseconds());
#endif
scheme_add_embedded_builtins(env);
boot_module_resolver();
@ -1241,9 +1245,13 @@ Scheme_Env *scheme_get_bucket_home(Scheme_Bucket *b)
void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Env *e)
{
if (!((Scheme_Bucket_With_Home *)b)->home_link) {
Scheme_Object *link;
link = scheme_get_home_weak_link(e);
((Scheme_Bucket_With_Home *)b)->home_link = link;
if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK)
((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)e;
else {
Scheme_Object *link;
link = scheme_get_home_weak_link(e);
((Scheme_Bucket_With_Home *)b)->home_link = link;
}
}
}
@ -1302,11 +1310,11 @@ scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
b = scheme_bucket_from_table(env->toplevel, (const char *)sym);
b->val = obj;
ASSERT_IS_VARIABLE_BUCKET(b);
scheme_set_bucket_home(b, env);
if (constant && scheme_defining_primitives) {
((Scheme_Bucket_With_Flags *)b)->id = builtin_ref_counter++;
((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST);
((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST | GLOB_STRONG_HOME_LINK);
}
scheme_set_bucket_home(b, env);
} else
scheme_add_to_table(env->syntax, (const char *)sym, obj, constant);
}

3
src/racket/src/jit.c
View File

@ -1132,7 +1132,8 @@ static int generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int local
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int no_store, int extfl)
/* Move FPR0 onto C stack */
{
int sz, fpr0;
int sz;
int fpr0 USED_ONLY_SOMETIMES;
sz = MZ_FPUSEL(extfl, 2 * sizeof(double), sizeof(double));

4
src/racket/src/lightning/i386/core-common.h
View File

@ -245,7 +245,7 @@ static jit_state _jit;
# if defined(JIT_X86_64)
# define jit_extr_i_l(d, rs) (jit_lshi_l((d), (rs), 32), jit_rshi_l((d), (d), 32))
# else
# define jit_extr_i_l(d, rs) 0
# define jit_extr_i_l(d, rs) /* empty */
# endif
#endif
#ifndef jit_extr_c_ul
@ -258,7 +258,7 @@ static jit_state _jit;
# if defined(JIT_X86_64)
# define jit_extr_i_ul(d, rs) jit_andi_l((d), (rs), 0xFFFFFFFFUL)
# else
# define jit_extr_i_ul(d, rs) 0
# define jit_extr_i_ul(d, rs) /* empty */
# endif
#endif
#endif

75
src/racket/src/startup.inc
View File

@ -261,7 +261,7 @@
"(if(and(relative-path? program)"
"(let-values(((base name dir?)(split-path program)))"
"(eq? base 'relative)))"
"(let((paths-str(environment-variables-get(current-environment-variables)"
"(let((paths-str(environment-variables-ref(current-environment-variables)"
" #\"PATH\"))"
"(win-add(lambda(s)(if(eq?(system-type) 'windows) "
" (cons (bytes->path #\".\") s) "
@ -593,38 +593,41 @@
"(when(not base)"
" (raise-mismatch-error who \"cannot add a suffix to a root path: \" s))"
"(values base name))))"
"(define-values(path-adjust-suffix)"
"(lambda(name sep rest-bytes s sfx)"
"(let-values(((base name)(check-suffix-call s sfx name)))"
"(define bs(path-element->bytes name))"
"(define finish"
"(lambda(i sep i2)"
"(bytes->path-element"
"(bytes-append"
"(subbytes bs 0 i)"
" sep"
"(rest-bytes bs i2)"
"(if(string? sfx)"
"(string->bytes/locale sfx(char->integer #\\?))"
" sfx))"
"(if(path-for-some-system? s)"
"(path-convention-type s)"
"(system-path-convention-type)))))"
"(let((new-name(letrec-values(((loop)"
"(lambda(i)"
"(if(zero? i)"
" (finish (bytes-length bs) #\"\" (bytes-length bs))"
"(let-values(((i)(sub1 i)))"
"(if(eq?(char->integer #\\.)(bytes-ref bs i))"
"(finish i sep(add1 i))"
"(loop i)))))))"
"(loop(bytes-length bs)))))"
"(if(path? base)"
"(build-path base new-name)"
" new-name)))))"
"(define-values(path-replace-suffix)"
"(lambda(s sfx)"
"(let-values(((base name)(check-suffix-call s sfx 'path-replace-suffix)))"
"(let((new-name(bytes->path-element"
" (regexp-replace #rx#\"(?:[.][^.]*|)$\""
"(path-element->bytes name)"
"(if(string? sfx)"
"(string->bytes/locale sfx(char->integer #\\?))"
" sfx))"
"(if(path-for-some-system? s)"
"(path-convention-type s)"
"(system-path-convention-type)))))"
"(if(path? base)"
"(build-path base new-name)"
" new-name)))))"
" (path-adjust-suffix 'path-replace-suffix #\"\" (lambda (bs i) #\"\") s sfx)))"
"(define-values(path-add-suffix)"
"(lambda(s sfx)"
"(let-values(((base name)(check-suffix-call s sfx 'path-add-suffix)))"
"(let((new-name(bytes->path-element"
"(bytes-append"
" (regexp-replace* #rx#\"[.]\""
"(path-element->bytes name)"
" \"_\")"
"(if(string? sfx)"
"(string->bytes/locale sfx(char->integer #\\?))"
" sfx))"
"(if(path-for-some-system? s)"
"(path-convention-type s)"
"(system-path-convention-type)))))"
"(if(path? base)"
"(build-path base new-name)"
" new-name)))))"
" (path-adjust-suffix 'path-replace-suffix #\"_\" subbytes s sfx)))"
"(define-values(load/use-compiled)"
"(lambda(f)((current-load/use-compiled) f #f)))"
"(define-values(find-library-collection-paths)"
@ -636,7 +639,7 @@
"(cons-if(lambda(f r)(if f(cons f r) r))))"
"(path-list-string->path-list"
"(if user-too?"
"(let((c(environment-variables-get(current-environment-variables)"
"(let((c(environment-variables-ref(current-environment-variables)"
" #\"PLTCOLLECTS\")))"
"(if c"
"(bytes->string/locale c #\\?)"
@ -874,12 +877,14 @@
"(define-values(-prev-relto-dir) #f)"
"(define(split-relative-string s coll-mode?)"
"(let((l(let loop((s s))"
"(let((len(string-length s)))"
"(let iloop((i 0))"
"(cond"
" ((regexp-match #rx\"^(.*?)/(.*)$\" s)"
" =>(lambda(m)"
"(cons(cadr m)"
"(loop(caddr m)))))"
"(else(list s))))))"
"((= i len)(list s))"
"((char=? #\\/(string-ref s i))"
"(cons(substring s 0 i)"
"(loop(substring s(add1 i)))))"
"(else(iloop(add1 i)))))))))"
"(if coll-mode?"
" l"
"(let loop((l l))"

79
src/racket/src/startup.rktl
View File

@ -316,7 +316,7 @@
(if (and (relative-path? program)
(let-values ([(base name dir?) (split-path program)])
(eq? base 'relative)))
(let ([paths-str (environment-variables-get (current-environment-variables)
(let ([paths-str (environment-variables-ref (current-environment-variables)
#"PATH")]
[win-add (lambda (s) (if (eq? (system-type) 'windows)
(cons (bytes->path #".") s)
@ -684,41 +684,44 @@
(when (not base)
(raise-mismatch-error who "cannot add a suffix to a root path: " s))
(values base name))))
(define-values (path-adjust-suffix)
(lambda (name sep rest-bytes s sfx)
(let-values ([(base name) (check-suffix-call s sfx name)])
(define bs (path-element->bytes name))
(define finish
(lambda (i sep i2)
(bytes->path-element
(bytes-append
(subbytes bs 0 i)
sep
(rest-bytes bs i2)
(if (string? sfx)
(string->bytes/locale sfx (char->integer #\?))
sfx))
(if (path-for-some-system? s)
(path-convention-type s)
(system-path-convention-type)))))
(let ([new-name (letrec-values ([(loop)
(lambda (i)
(if (zero? i)
(finish (bytes-length bs) #"" (bytes-length bs))
(let-values ([(i) (sub1 i)])
(if (eq? (char->integer #\.) (bytes-ref bs i))
(finish i sep (add1 i))
(loop i)))))])
(loop (bytes-length bs)))])
(if (path? base)
(build-path base new-name)
new-name)))))
(define-values (path-replace-suffix)
(lambda (s sfx)
(let-values ([(base name) (check-suffix-call s sfx 'path-replace-suffix)])
(let ([new-name (bytes->path-element
(regexp-replace #rx#"(?:[.][^.]*|)$"
(path-element->bytes name)
(if (string? sfx)
(string->bytes/locale sfx (char->integer #\?))
sfx))
(if (path-for-some-system? s)
(path-convention-type s)
(system-path-convention-type)))])
(if (path? base)
(build-path base new-name)
new-name)))))
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
(define-values (path-add-suffix)
(lambda (s sfx)
(let-values ([(base name) (check-suffix-call s sfx 'path-add-suffix)])
(let ([new-name (bytes->path-element
(bytes-append
(regexp-replace* #rx#"[.]"
(path-element->bytes name)
"_")
(if (string? sfx)
(string->bytes/locale sfx (char->integer #\?))
sfx))
(if (path-for-some-system? s)
(path-convention-type s)
(system-path-convention-type)))])
(if (path? base)
(build-path base new-name)
new-name)))))
(path-adjust-suffix 'path-replace-suffix #"_" subbytes s sfx)))
(define-values (load/use-compiled)
(lambda (f) ((current-load/use-compiled) f #f)))
@ -732,7 +735,7 @@
[cons-if (lambda (f r) (if f (cons f r) r))])
(path-list-string->path-list
(if user-too?
(let ([c (environment-variables-get (current-environment-variables)
(let ([c (environment-variables-ref (current-environment-variables)
#"PLTCOLLECTS")])
(if c
(bytes->string/locale c #\?)
@ -1001,12 +1004,14 @@
(define (split-relative-string s coll-mode?)
(let ([l (let loop ([s s])
(cond
[(regexp-match #rx"^(.*?)/(.*)$" s)
=> (lambda (m)
(cons (cadr m)
(loop (caddr m))))]
[else (list s)]))])
(let ([len (string-length s)])
(let iloop ([i 0])
(cond
[(= i len) (list s)]
[(char=? #\/ (string-ref s i))
(cons (substring s 0 i)
(loop (substring s (add1 i))))]
[else (iloop (add1 i))]))))])
(if coll-mode?
l
(let loop ([l l])