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

fixed name for case-lambda, especially in stack traces

Browse Source 
svn: r2169
This commit is contained in:
Matthew Flatt 2006-02-08 13:43:07 +00:00
parent 76cc78649f
commit 4884ac0cab
3 changed files with 31 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
src/mzscheme/src/fun.c
View File

@ -875,6 +875,26 @@ Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code
return name;
}
Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec)
{
Scheme_Object *name;
name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
if (name && SCHEME_SYMBOLP(name)) {
name = combine_name_with_srcloc(name, code, 0);
} else {
name = rec[drec].value_name;
if (!name || SCHEME_FALSEP(name)) {
name = scheme_source_to_name(code);
if (name)
name = combine_name_with_srcloc(name, code, 1);
} else {
name = combine_name_with_srcloc(name, code, 0);
}
}
return name;
}
Scheme_Object *
scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
Scheme_Compile_Info *rec, int drec)
@ -931,21 +951,8 @@ scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
forms = scheme_datum_to_syntax(forms, code, code, 0, 0);
forms = scheme_add_env_renames(forms, frame, env);
name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
if (name && SCHEME_SYMBOLP(name)) {
name = combine_name_with_srcloc(name, code, 0);
data->name = name;
} else {
name = rec[drec].value_name;
if (!name || SCHEME_FALSEP(name)) {
name = scheme_source_to_name(code);
if (name)
name = combine_name_with_srcloc(name, code, 1);
} else {
name = combine_name_with_srcloc(name, code, 0);
}
data->name = name;
}
name = scheme_build_closure_name(code, rec, drec);
data->name = name;
scheme_compile_rec_done_local(rec, drec);

3
src/mzscheme/src/schpriv.h
View File

@ -1769,7 +1769,6 @@ Scheme_Object *scheme_make_closure_compilation(Scheme_Comp_Env *env,
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list,
int strip_values);
Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info);
Scheme_App_Rec *scheme_malloc_application(int n);
@ -1778,6 +1777,8 @@ void scheme_finish_application(Scheme_App_Rec *app);
Scheme_Object *scheme_jit_expr(Scheme_Object *);
Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Letrec *lr);
Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec);
#define SCHEME_SYNTAX(obj) SCHEME_PTR1_VAL(obj)
#define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj)

11
src/mzscheme/src/syntax.c
View File

@ -1612,7 +1612,7 @@ static Scheme_Object *case_lambda_jit(Scheme_Object *expr)
if (!seqin->native_code) {
Scheme_Case_Lambda *seqout;
Scheme_Native_Closure_Data *ndata;
Scheme_Object *val;
Scheme_Object *val, *name;
int i, cnt, size, all_closed = 1;
cnt = seqin->count;
@ -1622,6 +1622,10 @@ static Scheme_Object *case_lambda_jit(Scheme_Object *expr)
seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size);
memcpy(seqout, seqin, size);
name = seqin->name;
if (SCHEME_BOXP(name))
name = SCHEME_BOX_VAL(name);
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (SCHEME_PROCP(val)) {
@ -1629,6 +1633,7 @@ static Scheme_Object *case_lambda_jit(Scheme_Object *expr)
val = (Scheme_Object *)((Scheme_Closure *)val)->code;
seqout->array[i] = val;
}
((Scheme_Closure_Data *)val)->name = name;
if (((Scheme_Closure_Data *)val)->closure_size)
all_closed = 0;
}
@ -1775,9 +1780,7 @@ case_lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env,
form = SCHEME_STX_CDR(form);
name = rec[drec].value_name;
if (!name || SCHEME_FALSEP(name))
name = scheme_source_to_name(orig_form);
name = scheme_build_closure_name(orig_form, rec, drec);
if (SCHEME_STX_NULLP(form)) {
/* Case where there are no cases... */