code clean-up and gdb macros from Kevin
svn: r11015
This commit is contained in:
Matthew Flatt
parent
ea0a7cdfb5
commit
14983c8f39
|
|
@ -50,13 +50,6 @@ int wx_in_terminal; /* dummy */
|
|||
# endif
|
||||
#endif
|
||||
|
||||
#ifdef MPW_CPLUS
|
||||
extern "C" { typedef int (*ACTUAL_MAIN_PTR)(int argc, char **argv); }
|
||||
# define CAST_ACTUAL_MAIN (ACTUAL_MAIN_PTR)
|
||||
#else
|
||||
# define CAST_ACTUAL_MAIN /* empty */
|
||||
#endif
|
||||
|
||||
#ifdef wx_msw
|
||||
/* Hack: overwrite "y" with "n" in binary to disable checking for another
|
||||
instance of the same app. */
|
||||
|
|
@ -237,21 +230,6 @@ static void run_from_cmd_line(int argc, char **argv, Scheme_Env *(*mk_basic_env)
|
|||
run_from_cmd_line(argc, argv, mk_basic_env, do_main_loop);
|
||||
}
|
||||
|
||||
int actual_main(int argc, char **argv)
|
||||
{
|
||||
int r;
|
||||
|
||||
wxCreateApp();
|
||||
|
||||
r = wxEntry(argc, argv);
|
||||
|
||||
#ifdef wx_msw
|
||||
mred_clean_up_gdi_objects();
|
||||
#endif
|
||||
|
||||
return r;
|
||||
}
|
||||
|
||||
static int main_after_stack(int argc, char *argv[])
|
||||
{
|
||||
int rval;
|
||||
|
|
@ -280,15 +258,17 @@ static int main_after_stack(int argc, char *argv[])
|
|||
wxDrop_GetArgs(&argc, &argv, &wx_in_terminal);
|
||||
#endif
|
||||
|
||||
scheme_set_actual_main(actual_main);
|
||||
mred_set_run_from_cmd_line(run_from_cmd_line);
|
||||
mred_set_finish_cmd_line_run(finish_cmd_line_run);
|
||||
|
||||
rval = scheme_image_main(argc, argv);
|
||||
wxCreateApp();
|
||||
|
||||
rval = wxEntry(argc, argv);
|
||||
|
||||
/* This line ensures that __gc_var_stack__ is the
|
||||
val of GC_variable_stack in scheme_image_main. */
|
||||
argv = NULL;
|
||||
#ifdef wx_msw
|
||||
mred_clean_up_gdi_objects();
|
||||
#endif
|
||||
|
||||
return rval;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -341,3 +341,8 @@ unix-cygwin-install-3m:
|
|||
|
||||
unix-cygwin-install-3m-final:
|
||||
$(MAKE) unix-install-3m-final
|
||||
|
||||
# Generate plt-gdbinit ----------------------------------------
|
||||
|
||||
mz-gdbinit: $(srcdir)/mk-gdbinit.ss $(srcdir)/src/stypes.h
|
||||
mzscheme $(srcdir)/mk-gdbinit.ss
|
||||
|
|
|
|||
|
|
@ -47,7 +47,6 @@ OBJS = salloc.@LTO@ \
|
|||
file.@LTO@ \
|
||||
fun.@LTO@ \
|
||||
hash.@LTO@ \
|
||||
image.@LTO@ \
|
||||
jit.@LTO@ \
|
||||
list.@LTO@ \
|
||||
module.@LTO@ \
|
||||
|
|
@ -91,7 +90,6 @@ XSRCS = $(XSRCDIR)/salloc.c \
|
|||
$(XSRCDIR)/file.c \
|
||||
$(XSRCDIR)/fun.c \
|
||||
$(XSRCDIR)/hash.c \
|
||||
$(XSRCDIR)/image.c \
|
||||
$(XSRCDIR)/jit.c \
|
||||
$(XSRCDIR)/list.c \
|
||||
$(XSRCDIR)/module.c \
|
||||
|
|
@ -164,8 +162,6 @@ $(XSRCDIR)/fun.c: ../src/fun.@LTO@ $(XFORMDEP)
|
|||
$(XFORM) $(XSRCDIR)/fun.c $(SRCDIR)/fun.c
|
||||
$(XSRCDIR)/hash.c: ../src/hash.@LTO@ $(XFORMDEP)
|
||||
$(XFORM) $(XSRCDIR)/hash.c $(SRCDIR)/hash.c
|
||||
$(XSRCDIR)/image.c: ../src/image.@LTO@ $(XFORMDEP)
|
||||
$(XFORM) $(XSRCDIR)/image.c $(SRCDIR)/image.c
|
||||
$(XSRCDIR)/jit.c: ../src/jit.@LTO@ $(XFORMDEP)
|
||||
$(XFORM) $(XSRCDIR)/jit.c $(SRCDIR)/jit.c
|
||||
$(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP)
|
||||
|
|
@ -246,8 +242,6 @@ fun.@LTO@: $(XSRCDIR)/fun.c
|
|||
$(CC) $(CFLAGS) -c $(XSRCDIR)/fun.c -o fun.@LTO@
|
||||
hash.@LTO@: $(XSRCDIR)/hash.c
|
||||
$(CC) $(CFLAGS) -c $(XSRCDIR)/hash.c -o hash.@LTO@
|
||||
image.@LTO@: $(XSRCDIR)/image.c
|
||||
$(CC) $(CFLAGS) -c $(XSRCDIR)/image.c -o image.@LTO@
|
||||
jit.@LTO@: $(XSRCDIR)/jit.c
|
||||
$(CC) $(CFLAGS) -c $(XSRCDIR)/jit.c -o jit.@LTO@
|
||||
list.@LTO@: $(XSRCDIR)/list.c
|
||||
|
|
|
|||
|
|
@ -1703,11 +1703,6 @@ MZ_EXTERN void scheme_check_threads(void);
|
|||
MZ_EXTERN void scheme_wake_up(void);
|
||||
MZ_EXTERN int scheme_get_external_event_fd(void);
|
||||
|
||||
/* image dump enabling startup: */
|
||||
MZ_EXTERN int scheme_image_main(int argc, char **argv);
|
||||
MZ_EXTERN int (*scheme_actual_main)(int argc, char **argv);
|
||||
MZ_EXTERN void scheme_set_actual_main(int (*m)(int argc, char **argv));
|
||||
|
||||
/* GC registration: */
|
||||
MZ_EXTERN void scheme_set_stack_base(void *base, int no_auto_statics);
|
||||
MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics);
|
||||
|
|
|
|||
|
|
@ -196,7 +196,6 @@ static void user_break_hit(int ignore)
|
|||
/* Forward declarations: */
|
||||
static void do_scheme_rep(Scheme_Env *);
|
||||
static int cont_run(FinishArgs *f);
|
||||
int actual_main(int argc, char *argv[]);
|
||||
|
||||
#if defined(WINDOWS_UNICODE_SUPPORT) && !defined(__CYGWIN32__)
|
||||
# define MAIN wmain
|
||||
|
|
@ -254,7 +253,7 @@ static int main_after_dlls(int argc, MAIN_char **argv)
|
|||
}
|
||||
|
||||
/************************ main_after_stack *************************/
|
||||
/* Phase 1 setup, then call actual_main (indirectly) */
|
||||
/* Setup, parse command-line, and go to cont_run */
|
||||
|
||||
static int main_after_stack(void *data)
|
||||
{
|
||||
|
|
@ -272,8 +271,6 @@ static int main_after_stack(void *data)
|
|||
oskit_prepare(&argc, &argv);
|
||||
#endif
|
||||
|
||||
scheme_set_actual_main(actual_main);
|
||||
|
||||
#ifdef WINDOWS_UNICODE_MAIN
|
||||
{
|
||||
char *a;
|
||||
|
|
@ -295,34 +292,20 @@ static int main_after_stack(void *data)
|
|||
}
|
||||
#endif
|
||||
|
||||
rval = scheme_image_main(argc, argv); /* calls actual_main */
|
||||
|
||||
/* This line ensures that __gc_var_stack__ is the
|
||||
val of GC_variable_stack in scheme_image_main. */
|
||||
argv = NULL;
|
||||
return rval;
|
||||
}
|
||||
|
||||
|
||||
/************************* actual_main *****************************/
|
||||
/* Phase 2 setup, then parse command-line and go to cont_run */
|
||||
|
||||
int actual_main(int argc, char *argv[])
|
||||
{
|
||||
int exit_val;
|
||||
|
||||
#ifndef NO_USER_BREAK_HANDLER
|
||||
MZ_SIGSET(SIGINT, user_break_hit);
|
||||
#endif
|
||||
|
||||
exit_val = run_from_cmd_line(argc, argv, scheme_basic_env, cont_run);
|
||||
rval = run_from_cmd_line(argc, argv, scheme_basic_env, cont_run);
|
||||
|
||||
scheme_immediate_exit(exit_val);
|
||||
return exit_val; /* shouldn't happen! */
|
||||
scheme_immediate_exit(rval);
|
||||
|
||||
/* shouldn't get here */
|
||||
return rval;
|
||||
}
|
||||
|
||||
/************************* cont_run *****************************/
|
||||
/* Phase 3 setup (none), then go to do_scheme_rep */
|
||||
/************************* cont_run ******************************/
|
||||
/* Go to do_scheme_rep */
|
||||
|
||||
static int cont_run(FinishArgs *f)
|
||||
{
|
||||
|
|
@ -330,7 +313,7 @@ static int cont_run(FinishArgs *f)
|
|||
}
|
||||
|
||||
/************************* do_scheme_rep *****************************/
|
||||
/* Finally, do a read-eval-print-loop */
|
||||
/* Finally, do a read-eval-print-loop */
|
||||
|
||||
static void do_scheme_rep(Scheme_Env *env)
|
||||
{
|
||||
|
|
|
|||
258
src/mzscheme/mk-gdbinit.ss
Normal file
258
src/mzscheme/mk-gdbinit.ss
Normal file
|
|
@ -0,0 +1,258 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; This script generates "mz-gdbinit" to the current directory.
|
||||
;; It's normally run via `make mz-gdbinit', in which case
|
||||
;; putting
|
||||
;; source mz-gdbinit
|
||||
;; in your "~/.gdbinit" file causes it to be loaded.
|
||||
|
||||
;; The "mz-gdbinit" file is generated so that it can use specific
|
||||
;; type-tag constants from "stypes.h", in case the debugging info
|
||||
;; can't see them. If "stypes.h" changes, then "mz-gdbinit" needs
|
||||
;; to be re-built.
|
||||
|
||||
(require scheme/runtime-path)
|
||||
|
||||
(define-runtime-path stypes-path "src/stypes.h")
|
||||
|
||||
(define template #<<EOS
|
||||
define pso
|
||||
psox $arg0 0
|
||||
end
|
||||
document pso
|
||||
Print Scheme Object
|
||||
end
|
||||
|
||||
define indent
|
||||
set $i = $arg0
|
||||
while $i > 0
|
||||
printf " "
|
||||
set $i = $i - 1
|
||||
end
|
||||
end
|
||||
|
||||
define psox
|
||||
set $O = ((Scheme_Object*) ($arg0))
|
||||
indent $arg1
|
||||
if (((int)$arg0) & 0x1)
|
||||
set $OT = <<scheme_integer_type>>
|
||||
else
|
||||
set $OT = $O->type
|
||||
end
|
||||
printf "Scheme_Object %p type=%d\n", $O, $OT
|
||||
indent $arg1
|
||||
psoq $O $arg1
|
||||
end
|
||||
|
||||
define psoq
|
||||
indent $arg1
|
||||
if (((int)$arg0) & 0x1)
|
||||
printf "fixnum %d", (((int)$arg0) >> 1)
|
||||
else
|
||||
set $O = ((Scheme_Object*) ($arg0))
|
||||
set $OT = $O->type
|
||||
if ( $OT == <<scheme_toplevel_type>> )
|
||||
set $TL = ((Scheme_Toplevel*) ($O))
|
||||
printf "scheme_toplevel_type depth=%d position=%d", $TL->depth, $TL->position
|
||||
end
|
||||
if ( $OT == <<scheme_syntax_type>> )
|
||||
set $SSO = ((Scheme_Simple_Object*) ($O))
|
||||
set $index = $SSO->u.ptr_int_val.pint
|
||||
set $object = (Scheme_Object *) $SSO->u.ptr_int_val.ptr
|
||||
printf "scheme_syntax_type index=%d\n", $index
|
||||
pso $object $arg1+1
|
||||
end
|
||||
if ( $OT == <<scheme_application2_type>> )
|
||||
printf "scheme_application2_type\n"
|
||||
set $AP = ((Scheme_App2_Rec*) ($O))
|
||||
set $RATOR = $AP->rator
|
||||
set $RAND = $AP->rand
|
||||
indent $arg1
|
||||
printf "rator="
|
||||
pso $RATOR $arg1+1
|
||||
indent $arg1
|
||||
printf "rand="
|
||||
pso $RAND $arg1+1
|
||||
end
|
||||
if ( $OT == <<scheme_sequence_type>> )
|
||||
printf "scheme_sequence\n"
|
||||
set $seq = ((Scheme_Sequence *) $O)
|
||||
p *$seq
|
||||
set $size = $seq->count
|
||||
set $cnt = 0
|
||||
while ( $cnt < $size )
|
||||
p $cnt
|
||||
p $seq->array[$cnt]
|
||||
pso $seq->array[$cnt] $arg1+1
|
||||
set $cnt++
|
||||
end
|
||||
$OT = 0
|
||||
end
|
||||
if ( $OT == <<scheme_prim_type>> )
|
||||
printf "scheme_prim_type\n"
|
||||
set $pproc = ((Scheme_Primitive_Proc *) $O)
|
||||
p *$pproc
|
||||
end
|
||||
if ( $OT == <<scheme_closure_type>> )
|
||||
printf "scheme_closure_type\n"
|
||||
set $closure = ((Scheme_Closure *) $O)
|
||||
p *$closure
|
||||
set $code = $closure->code
|
||||
printf "scheme_closure_type code1\n"
|
||||
p *$code
|
||||
set $name = $code->name
|
||||
p *$name
|
||||
#pso $name $arg+1
|
||||
printf "scheme_closure_type code2\n"
|
||||
pso $code->code $arg+1
|
||||
$OT = <<scheme_closure_type>>
|
||||
end
|
||||
if ( $OT == <<scheme_structure_type>>)
|
||||
printf "scheme_structure_type\n"
|
||||
end
|
||||
if ( $OT == <<scheme_unix_path_type>>)
|
||||
printf "scheme_unix_path_type"
|
||||
p (char *)((Scheme_Simple_Object *)$O)->u.byte_str_val.string_val
|
||||
end
|
||||
if ( $OT == <<scheme_symbol_type>> )
|
||||
printf "scheme_symbol_type %s %p", (char *)((Scheme_Symbol*) $O)->s, $O
|
||||
end
|
||||
if ( $OT == <<scheme_null_type>> )
|
||||
printf "scheme_null"
|
||||
end
|
||||
if ( $OT == <<scheme_pair_type>> )
|
||||
printf "scheme_pair\n"
|
||||
set $SSO = ((Scheme_Simple_Object*) ($O))
|
||||
set $CAR = $SSO->u.pair_val.car
|
||||
set $CDR = $SSO->u.pair_val.cdr
|
||||
indent $arg1
|
||||
printf "car=\n"
|
||||
pso $CAR $arg1+1
|
||||
indent $arg1
|
||||
printf "cdr=\n"
|
||||
pso $CDR $arg1+1
|
||||
end
|
||||
if ( $OT == <<scheme_vector_type>> )
|
||||
set $vector = ((struct Scheme_Vector *) $O)
|
||||
set $size = $vector->size
|
||||
printf "scheme_vector_type size=%d\n", $size
|
||||
set $cnt = 0
|
||||
while ( $cnt < $size )
|
||||
p $cnt
|
||||
pso $vector->els[$cnt] $arg1+1
|
||||
set $cnt++
|
||||
end
|
||||
end
|
||||
if ( $OT == <<scheme_true_type>> )
|
||||
printf "scheme_true"
|
||||
end
|
||||
if ( $OT == <<scheme_false_type>> )
|
||||
printf "scheme_false"
|
||||
end
|
||||
if ( $OT == <<scheme_void_type>> )
|
||||
printf "scheme_void"
|
||||
end
|
||||
if ( $OT == <<scheme_hash_table_type>> )
|
||||
psht $O $arg1
|
||||
end
|
||||
if ( $OT == <<scheme_module_index_type>> )
|
||||
printf "scheme_module_index_type\n"
|
||||
set $modidx = ((Scheme_Modidx *) $O)
|
||||
indent $arg1
|
||||
printf "path="
|
||||
pso $modidx->path $arg1+1
|
||||
indent $arg1
|
||||
printf "base="
|
||||
pso $modidx->base $arg1+1
|
||||
indent $arg1
|
||||
printf "resolved="
|
||||
pso $modidx->resolved $arg1+1
|
||||
end
|
||||
if ( $OT == <<scheme_namespace_type>>)
|
||||
printf "scheme_namespace_type\n"
|
||||
set $env = ((Scheme_Env*)$O)
|
||||
if ($env->module != 0)
|
||||
pso $env->module $arg1+1
|
||||
else
|
||||
indent $arg1
|
||||
printf "top-level\n"
|
||||
end
|
||||
end
|
||||
if ( $OT == <<scheme_stx_type>> )
|
||||
printf "scheme_stx_type\n"
|
||||
set $stx = ((Scheme_Stx*) $O)
|
||||
p *$stx
|
||||
indent $arg1
|
||||
printf "content="
|
||||
pso $stx->val $arg1+1
|
||||
set $srcloc = $stx->srcloc
|
||||
set $name = ($stx->srcloc->src)
|
||||
set $name = (char *)((Scheme_Simple_Object *)$name)->u.byte_str_val.string_val
|
||||
indent $arg1
|
||||
printf "%s:%i:%i\n", $name, $srcloc->line, $srcloc->col
|
||||
end
|
||||
if ( $OT == <<scheme_compilation_top_type>>)
|
||||
printf "scheme_compilation_top_type\n"
|
||||
set $top = ((Scheme_Compilation_Top*)$O)
|
||||
p *$top
|
||||
pso $top->code $arg1+1
|
||||
end
|
||||
if ( $OT == <<scheme_module_type>>)
|
||||
printf "scheme_module_type\n"
|
||||
set $module = ((Scheme_Module*)$O)
|
||||
pso $module->modname $arg1+1
|
||||
end
|
||||
if ( $OT == <<scheme_resolved_module_path_type>>)
|
||||
set $OO = (((Scheme_Small_Object *)$arg0)->u.ptr_val)
|
||||
printf "scheme_resolved_module_path_type %s %p", (char *)((Scheme_Symbol*) $OO)->s, $OO
|
||||
end
|
||||
end
|
||||
printf "\n"
|
||||
end
|
||||
document psoq
|
||||
print scheme object quiet
|
||||
end
|
||||
|
||||
define psht
|
||||
set $ht= ((struct Scheme_Hash_Table *) $arg0)
|
||||
set $size = $ht->size
|
||||
printf "scheme_hash_table_type size=%d count=%d\n", $size, $ht->count
|
||||
set $cnt = 0
|
||||
while ( $cnt < $size )
|
||||
set $item = $ht->vals[$cnt]
|
||||
if ($item != 0)
|
||||
set $item = $ht->keys[$cnt]
|
||||
indent $arg1
|
||||
printf "key=\n"
|
||||
psoq $item $arg1+1
|
||||
set $item = $ht->vals[$cnt]
|
||||
indent $arg1
|
||||
printf "val=\n"
|
||||
psoq $item $arg1+1
|
||||
end
|
||||
set $cnt++
|
||||
end
|
||||
end
|
||||
document psht
|
||||
print scheme hash table
|
||||
end
|
||||
EOS
|
||||
)
|
||||
|
||||
(define styles (with-input-from-file stypes-path
|
||||
(lambda () (read-string (* 2 (file-size stypes-path))))))
|
||||
|
||||
(call-with-output-file* "mz-gdbinit"
|
||||
#:exists 'truncate
|
||||
(lambda (out)
|
||||
(let ([in (open-input-string template)])
|
||||
(let loop ()
|
||||
(let ([m (regexp-match #rx"<<([^>]*)>>" in 0 #f out)])
|
||||
(when m
|
||||
(let ([m2 (regexp-match (format "~a, */[*] ([0-9]+) [*]/" (cadr m))
|
||||
styles)])
|
||||
(if m2
|
||||
(display (cadr m2) out)
|
||||
(error 'mk-gdbinit "cannot find type in stypes.h: ~e" (cadr m))))
|
||||
(loop)))))
|
||||
(newline out)))
|
||||
|
|
@ -26,7 +26,6 @@ OBJS = salloc.@LTO@ \
|
|||
fun.@LTO@ \
|
||||
gmp.@LTO@ \
|
||||
hash.@LTO@ \
|
||||
image.@LTO@ \
|
||||
jit.@LTO@ \
|
||||
list.@LTO@ \
|
||||
module.@LTO@ \
|
||||
|
|
@ -66,7 +65,6 @@ SRCS = $(srcdir)/salloc.c \
|
|||
$(srcdir)/fun.c \
|
||||
$(srcdir)/gmp/gmp.c \
|
||||
$(srcdir)/hash.c \
|
||||
$(srcdir)/image.c \
|
||||
$(srcdir)/jit.c \
|
||||
$(srcdir)/list.c \
|
||||
$(srcdir)/module.c \
|
||||
|
|
@ -170,8 +168,6 @@ gmp.@LTO@: $(srcdir)/gmp/gmp.c $(srcdir)/gmp/gmplonglong.h
|
|||
$(CC) $(CFLAGS) -c $(srcdir)/gmp/gmp.c -o gmp.@LTO@
|
||||
hash.@LTO@: $(srcdir)/hash.c
|
||||
$(CC) $(CFLAGS) -c $(srcdir)/hash.c -o hash.@LTO@
|
||||
image.@LTO@: $(srcdir)/image.c
|
||||
$(CC) $(CFLAGS) -c $(srcdir)/image.c -o image.@LTO@
|
||||
jit.@LTO@: $(srcdir)/jit.c
|
||||
$(CC) $(CFLAGS) -c $(srcdir)/jit.c -o jit.@LTO@
|
||||
list.@LTO@: $(srcdir)/list.c
|
||||
|
|
|
|||
|
|
@ -168,7 +168,6 @@ static Scheme_Object *top_expander;
|
|||
static Scheme_Object *stop_expander;
|
||||
|
||||
static Scheme_Object *quick_stx;
|
||||
static int taking_shortcut;
|
||||
|
||||
Scheme_Object *scheme_stack_dump_key;
|
||||
|
||||
|
|
@ -4634,6 +4633,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
|
|||
dest[i].certs = src[drec].certs;
|
||||
/* should be always NULL */
|
||||
dest[i].observer = src[drec].observer;
|
||||
dest[i].pre_unwrapped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -4651,6 +4651,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
|
|||
dest[i].value_name = scheme_false;
|
||||
dest[i].certs = src[drec].certs;
|
||||
dest[i].observer = src[drec].observer;
|
||||
dest[i].pre_unwrapped = 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -4672,6 +4673,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
|
|||
lam[dlrec].value_name = scheme_false;
|
||||
lam[dlrec].certs = src[drec].certs;
|
||||
lam[dlrec].observer = src[drec].observer;
|
||||
lam[dlrec].pre_unwrapped = 0;
|
||||
}
|
||||
|
||||
void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
|
||||
|
|
@ -4918,6 +4920,7 @@ static void *compile_k(void)
|
|||
rec.value_name = scheme_false;
|
||||
rec.certs = NULL;
|
||||
rec.observer = NULL;
|
||||
rec.pre_unwrapped = 0;
|
||||
|
||||
cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
|
||||
|
||||
|
|
@ -5556,7 +5559,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
} else if (rec[drec].comp && SAME_OBJ(var, normal) && !rec[drec].observer) {
|
||||
/* Skip creation of intermediate form */
|
||||
Scheme_Syntax *f;
|
||||
taking_shortcut = 1;
|
||||
rec[drec].pre_unwrapped = 1;
|
||||
f = (Scheme_Syntax *)SCHEME_SYNTAX(var);
|
||||
if (can_recycle_stx && !quick_stx)
|
||||
quick_stx = can_recycle_stx;
|
||||
|
|
@ -5678,9 +5681,10 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
|
|||
Scheme_Compile_Expand_Info *rec, int drec)
|
||||
{
|
||||
Scheme_Object *form, *naya;
|
||||
int tsc = taking_shortcut;
|
||||
int tsc;
|
||||
|
||||
taking_shortcut = 0;
|
||||
tsc = rec[drec].pre_unwrapped;
|
||||
rec[drec].pre_unwrapped = 0;
|
||||
|
||||
scheme_rec_add_certs(rec, drec, forms);
|
||||
if (tsc) {
|
||||
|
|
@ -5907,9 +5911,9 @@ datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec
|
|||
{
|
||||
Scheme_Object *c, *v;
|
||||
|
||||
if (taking_shortcut) {
|
||||
if (rec[drec].pre_unwrapped) {
|
||||
c = form;
|
||||
taking_shortcut = 0;
|
||||
rec[drec].pre_unwrapped = 0;
|
||||
} else {
|
||||
c = SCHEME_STX_CDR(form);
|
||||
/* Need datum->syntax, in case c is a list: */
|
||||
|
|
@ -5947,13 +5951,13 @@ datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec
|
|||
0, 2);
|
||||
}
|
||||
|
||||
static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Comp_Env *env)
|
||||
static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
|
||||
{
|
||||
Scheme_Object *c;
|
||||
|
||||
if (taking_shortcut) {
|
||||
if (rec[drec].pre_unwrapped) {
|
||||
c = form;
|
||||
taking_shortcut = 0;
|
||||
rec[drec].pre_unwrapped = 0;
|
||||
} else
|
||||
c = SCHEME_STX_CDR(form);
|
||||
|
||||
|
|
@ -6009,7 +6013,7 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
|
|||
{
|
||||
Scheme_Object *c;
|
||||
|
||||
c = check_top(scheme_compile_stx_string, form, env);
|
||||
c = check_top(scheme_compile_stx_string, form, env, rec, drec);
|
||||
|
||||
c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL);
|
||||
|
||||
|
|
@ -6031,7 +6035,7 @@ static Scheme_Object *
|
|||
top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
|
||||
{
|
||||
SCHEME_EXPAND_OBSERVE_PRIM_TOP(erec[drec].observer);
|
||||
check_top(scheme_expand_stx_string, form, env);
|
||||
check_top(scheme_expand_stx_string, form, env, erec, drec);
|
||||
return form;
|
||||
}
|
||||
|
||||
|
|
@ -8757,6 +8761,7 @@ static void *expand_k(void)
|
|||
erec1.value_name = scheme_false;
|
||||
erec1.certs = certs;
|
||||
erec1.observer = observer;
|
||||
erec1.pre_unwrapped = 0;
|
||||
|
||||
if (catch_lifts_key)
|
||||
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
|
||||
|
|
@ -9576,13 +9581,13 @@ local_eval(int argc, Scheme_Object **argv)
|
|||
|
||||
stx_env->in_modidx = scheme_current_thread->current_local_modidx;
|
||||
if (!SCHEME_FALSEP(expr)) {
|
||||
|
||||
Scheme_Compile_Expand_Info rec;
|
||||
rec.comp = 0;
|
||||
rec.depth = -1;
|
||||
rec.value_name = scheme_false;
|
||||
rec.certs = certs;
|
||||
rec.observer = observer;
|
||||
rec.pre_unwrapped = 0;
|
||||
|
||||
/* Evaluate and bind syntaxes */
|
||||
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);
|
||||
|
|
|
|||
|
|
@ -1,45 +0,0 @@
|
|||
/*
|
||||
MzScheme
|
||||
Copyright (c) 2004-2008 PLT Scheme Inc.
|
||||
Copyright (c) 1995-2001 Matthew Flatt
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Library General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Library General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Library General Public
|
||||
License along with this library; if not, write to the Free
|
||||
Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
Boston, MA 02110-1301 USA.
|
||||
|
||||
libscheme
|
||||
Copyright (c) 1994 Brent Benson
|
||||
All rights reserved.
|
||||
*/
|
||||
|
||||
/* Images are long since unsupported, so all that's left is this
|
||||
little trampoline. */
|
||||
|
||||
#include "schpriv.h"
|
||||
|
||||
MZ_DLLSPEC int (*scheme_actual_main)(int argc, char **argv);
|
||||
|
||||
void scheme_set_actual_main(int (*m)(int argc, char **argv))
|
||||
{
|
||||
scheme_actual_main = m;
|
||||
}
|
||||
|
||||
int scheme_image_main(int argc, char **argv)
|
||||
{
|
||||
return scheme_actual_main(argc, argv);
|
||||
}
|
||||
|
||||
void scheme_no_dumps(char *why)
|
||||
{
|
||||
}
|
||||
|
|
@ -5782,6 +5782,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
erec1.value_name = scheme_false;
|
||||
erec1.certs = rec[drec].certs;
|
||||
erec1.observer = rec[drec].observer;
|
||||
erec1.pre_unwrapped = 0;
|
||||
e = scheme_expand_expr(e, xenv, &erec1, 0);
|
||||
}
|
||||
|
||||
|
|
@ -5983,6 +5984,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
mrec.value_name = NULL;
|
||||
mrec.certs = rec[drec].certs;
|
||||
mrec.observer = NULL;
|
||||
mrec.pre_unwrapped = 0;
|
||||
|
||||
if (!rec[drec].comp) {
|
||||
Scheme_Expand_Info erec1;
|
||||
|
|
@ -5991,6 +5993,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
erec1.value_name = boundname;
|
||||
erec1.certs = rec[drec].certs;
|
||||
erec1.observer = rec[drec].observer;
|
||||
erec1.pre_unwrapped = 0;
|
||||
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
|
||||
code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -634,6 +634,10 @@ Scheme_Object * scheme_make_eof (void)
|
|||
return scheme_eof;
|
||||
}
|
||||
|
||||
void scheme_no_dumps(char *why)
|
||||
{
|
||||
}
|
||||
|
||||
/*========================================================================*/
|
||||
/* fd arrays */
|
||||
/*========================================================================*/
|
||||
|
|
|
|||
|
|
@ -1364,6 +1364,7 @@ user_get_or_peek_bytes(Scheme_Input_Port *port,
|
|||
} else {
|
||||
char *vb;
|
||||
vb = scheme_malloc_atomic(size + 1);
|
||||
memset(vb, size + 1, 0); /* must initialize for security */
|
||||
bstr = scheme_make_sized_byte_string(vb, size, 0);
|
||||
}
|
||||
a[0] = bstr;
|
||||
|
|
|
|||
|
|
@ -1775,6 +1775,7 @@ typedef struct Scheme_Compile_Expand_Info
|
|||
Scheme_Object *observer;
|
||||
char dont_mark_local_use;
|
||||
char resolve_module_ids;
|
||||
char pre_unwrapped;
|
||||
int depth;
|
||||
} Scheme_Compile_Expand_Info;
|
||||
|
||||
|
|
|
|||
|
|
@ -5371,6 +5371,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
rec1.value_name = NULL;
|
||||
rec1.certs = rec[drec].certs;
|
||||
rec1.observer = NULL;
|
||||
rec1.pre_unwrapped = 0;
|
||||
|
||||
if (for_stx) {
|
||||
names = defn_targets_syntax(names, exp_env, &rec1, 0);
|
||||
|
|
@ -5561,6 +5562,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
|
|||
mrec.value_name = NULL;
|
||||
mrec.certs = certs;
|
||||
mrec.observer = NULL;
|
||||
mrec.pre_unwrapped = 0;
|
||||
|
||||
a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,6 @@
|
|||
"file"
|
||||
"fun"
|
||||
"hash"
|
||||
"image"
|
||||
"jit"
|
||||
"list"
|
||||
"module"
|
||||
|
|
|
|||
|
|
@ -254,10 +254,6 @@
|
|||
RelativePath="..\..\Mzscheme\Src\Hash.c"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\Mzscheme\Src\image.c"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\Mzscheme\Src\jit.c"
|
||||
>
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user