[uim-commit] r1234 - branches/r5rs/sigscheme
kzk at freedesktop.org
kzk at freedesktop.org
Fri Aug 19 02:54:34 PDT 2005
Author: kzk
Date: 2005-08-19 02:53:30 -0700 (Fri, 19 Aug 2005)
New Revision: 1234
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/error.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/io.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* Implement SIOD like backtrace function
* Change car and cdr behavior
* sigscheme/sigscheme.h
- (struct trace_frame): new struct
- (trace_root): new variable
- (SigScm_ShowBacktrace): new func
* sigscheme/eval.c
- (trace_root): new variable
- (ScmOp_eval): introduce eval_done label and change to handle
trace_frame
* sigscheme/error.c
- (SigScm_Die, SigScm_Error, SigScm_ErrorObj): show backtrace
- (SigScm_ShowBacktrace): new func
* sigscheme/operations.c
- (ScmOp_car, ScmOp_cdr): now (car '()) and (cdr '()) aren't an error
- (ScmOp_list_ref): more functional error message
* sigscheme/io.c
- (ScmOp_require): protect stack
* sigscheme/datas.c
- (Scm_eval_c_string): protect str_port
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-08-19 08:22:49 UTC (rev 1233)
+++ branches/r5rs/sigscheme/datas.c 2005-08-19 09:53:30 UTC (rev 1234)
@@ -908,12 +908,14 @@
ScmObj Scm_eval_c_string(const char *exp)
{
ScmObj stack_start;
- ScmObj str_port = Scm_NewStringPort(exp);
+ ScmObj str_port = SCM_NIL;
ScmObj ret = SCM_NIL;
/* start protecting stack */
SigScm_gc_protect_stack(&stack_start);
+ str_port = Scm_NewStringPort(exp);
+
ret = SigScm_Read(str_port);
ret = ScmOp_eval(ret, SCM_NIL);
Modified: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c 2005-08-19 08:22:49 UTC (rev 1233)
+++ branches/r5rs/sigscheme/error.c 2005-08-19 09:53:30 UTC (rev 1234)
@@ -63,7 +63,13 @@
Function Implementations
=======================================*/
int SigScm_Die(const char *msg, const char *filename, int line) {
+ /* show message */
printf("SigScheme Died : %s (file : %s, line : %d)\n", msg, filename, line);
+
+ /* show backtrace */
+ SigScm_ShowBacktrace();
+
+ /* TODO: doesn't exit here */
exit(-1);
return -1;
@@ -72,10 +78,16 @@
void SigScm_Error(const char *msg, ...)
{
va_list va;
+
+ /* show message */
va_start(va, msg);
vfprintf(SCM_PORTINFO_FILE(current_error_port), msg, va);
va_end(va);
+ /* show backtrace */
+ SigScm_ShowBacktrace();
+
+ /* TODO: doesn't exit here */
exit(-1);
}
@@ -85,8 +97,27 @@
fprintf(SCM_PORTINFO_FILE(current_error_port), "%s", msg);
/* print obj */
- SigScm_DisplayToPort(current_error_port, obj);
- SigScm_DisplayToPort(current_error_port, Scm_NewStringCopying("\n"));
-
+ SigScm_WriteToPort(current_error_port, obj);
+ fprintf(SCM_PORTINFO_FILE(current_error_port), "\n");
+
+ /* show backtrace */
+ SigScm_ShowBacktrace();
+
+ /* TODO: doesn't exit here*/
exit(-1);
}
+
+void SigScm_ShowBacktrace(void)
+{
+ struct trace_frame *f;
+
+ /* show title */
+ fprintf(SCM_PORTINFO_FILE(current_error_port), "**** BACKTRACE ****\n");
+
+ /* show each frame's obj */
+ for (f = trace_root; f; f = f->prev) {
+ SigScm_WriteToPort(current_error_port, f->obj);
+
+ fprintf(SCM_PORTINFO_FILE(current_error_port), "\n");
+ }
+}
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-19 08:22:49 UTC (rev 1233)
+++ branches/r5rs/sigscheme/eval.c 2005-08-19 09:53:30 UTC (rev 1234)
@@ -70,9 +70,11 @@
/*=======================================
Variable Declarations
=======================================*/
-ScmObj continuation_thrown_obj = NULL;
-ScmObj letrec_env = NULL;
+ScmObj continuation_thrown_obj = NULL; /* for storing continuation return object */
+ScmObj letrec_env = NULL; /* for storing environment obj of letrec */
+struct trace_frame *trace_root = NULL;
+
/*=======================================
File Local Function Declarations
=======================================*/
@@ -204,14 +206,24 @@
===========================================================================*/
ScmObj ScmOp_eval(ScmObj obj, ScmObj env)
{
- ScmObj tmp = SCM_NIL;
- ScmObj arg = SCM_NIL;
+ ScmObj tmp = SCM_NIL;
+ ScmObj arg = SCM_NIL;
+ ScmObj ret = SCM_NIL;
int tail_flag = 0;
+ /* for debugging */
+ struct trace_frame frame;
+ frame.prev = trace_root;
+ frame.obj = obj;
+ trace_root = &frame;
+
eval_loop:
switch (SCM_GETTYPE(obj)) {
case ScmSymbol:
- return symbol_value(obj, env);
+ {
+ ret = symbol_value(obj, env);
+ goto eval_done;
+ }
/*====================================================================
Evaluating Expression
@@ -268,9 +280,10 @@
switch (SCM_FUNC_NUMARG(tmp)) {
case FUNCTYPE_L:
{
- return SCM_FUNC_EXEC_SUBRL(tmp,
- map_eval(SCM_CDR(obj), env),
- env);
+ ret = SCM_FUNC_EXEC_SUBRL(tmp,
+ map_eval(SCM_CDR(obj), env),
+ env);
+ goto eval_done;
}
case FUNCTYPE_R:
{
@@ -288,77 +301,91 @@
*/
if (tail_flag == 1)
goto eval_loop;
- else
- return obj;
+
+ ret = obj;
+ goto eval_done;
}
case FUNCTYPE_2N:
{
obj = SCM_CDR(obj);
/* check 1st arg */
- if (SCM_NULLP(obj))
- return SCM_FUNC_EXEC_SUBR2N(tmp, SCM_NIL, SCM_NIL);
+ if (SCM_NULLP(obj)) {
+ ret = SCM_FUNC_EXEC_SUBR2N(tmp, SCM_NIL, SCM_NIL);
+ goto eval_done;
+ }
/* eval 1st arg */
- arg = ScmOp_eval(SCM_CAR(obj), env);
+ ret = ScmOp_eval(SCM_CAR(obj), env);
/* check 2nd arg */
- if (SCM_NULLP(SCM_CDR(obj)))
- return SCM_FUNC_EXEC_SUBR2N(tmp, arg, SCM_NIL);
+ if (SCM_NULLP(SCM_CDR(obj))) {
+ ret = SCM_FUNC_EXEC_SUBR2N(tmp, ret, SCM_NIL);
+ goto eval_done;
+ }
/* call proc with each 2 objs */
for (obj = SCM_CDR(obj); !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
- arg = SCM_FUNC_EXEC_SUBR2N(tmp,
- arg,
+ ret = SCM_FUNC_EXEC_SUBR2N(tmp,
+ ret,
ScmOp_eval(SCM_CAR(obj), env));
}
- return arg;
+ goto eval_done;
}
case FUNCTYPE_0:
- return SCM_FUNC_EXEC_SUBR0(tmp);
+ {
+ ret = SCM_FUNC_EXEC_SUBR0(tmp);
+ goto eval_done;
+ }
case FUNCTYPE_1:
- return SCM_FUNC_EXEC_SUBR1(tmp, ScmOp_eval(SCM_CAR(SCM_CDR(obj)),env));
+ {
+ ret = SCM_FUNC_EXEC_SUBR1(tmp, ScmOp_eval(SCM_CAR(SCM_CDR(obj)),env));
+ goto eval_done;
+ }
case FUNCTYPE_2:
{
obj = SCM_CDR(obj);
arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
- return SCM_FUNC_EXEC_SUBR2(tmp,
- arg,
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 2nd arg */
+ ret = SCM_FUNC_EXEC_SUBR2(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 2nd arg */
+ goto eval_done;
}
case FUNCTYPE_3:
{
obj = SCM_CDR(obj);
arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
obj = SCM_CDR(obj);
- return SCM_FUNC_EXEC_SUBR3(tmp,
- arg,
- ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 3rd arg */
+ ret = SCM_FUNC_EXEC_SUBR3(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 3rd arg */
+ goto eval_done;
}
case FUNCTYPE_4:
{
obj = SCM_CDR(obj);
arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
obj = SCM_CDR(obj);
- return SCM_FUNC_EXEC_SUBR4(tmp,
- arg,
- ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env)); /* 4th arg */
+ ret = SCM_FUNC_EXEC_SUBR4(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env)); /* 4th arg */
+ goto eval_done;
}
case FUNCTYPE_5:
{
obj = SCM_CDR(obj);
arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
obj = SCM_CDR(obj);
- return SCM_FUNC_EXEC_SUBR5(tmp,
- arg,
- ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env), /* 4th arg */
- ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))), env)); /* 5th arg */
-
+ ret = SCM_FUNC_EXEC_SUBR5(tmp,
+ arg,
+ ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env), /* 4th arg */
+ ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))), env)); /* 5th arg */
+ goto eval_done;
}
}
break;
@@ -441,10 +468,13 @@
}
default:
- return obj;
+ ret = obj;
+ goto eval_done;
}
- return SCM_NIL;
+eval_done:
+ trace_root = frame.prev;
+ return ret;
}
ScmObj ScmOp_apply(ScmObj args, ScmObj env)
Modified: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c 2005-08-19 08:22:49 UTC (rev 1233)
+++ branches/r5rs/sigscheme/io.c 2005-08-19 09:53:30 UTC (rev 1234)
@@ -495,11 +495,15 @@
ScmObj ScmOp_require(ScmObj filename)
{
+ ScmObj stack_start;
ScmObj loaded_str = SCM_NIL;
if (!SCM_STRINGP(filename))
SigScm_ErrorObj("require : string required but got ", filename);
+ /* start protecting stack */
+ SigScm_gc_protect_stack(&stack_start);
+
/* construct loaded_str */
loaded_str = create_loaded_str(filename);
@@ -511,6 +515,9 @@
SCM_SYMBOL_VCELL(SigScm_features) = Scm_NewCons(loaded_str, SCM_SYMBOL_VCELL(SigScm_features));
}
+ /* now no need to protect stack */
+ SigScm_gc_unprotect_stack(&stack_start);
+
return SCM_TRUE;
}
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-08-19 08:22:49 UTC (rev 1233)
+++ branches/r5rs/sigscheme/operations.c 2005-08-19 09:53:30 UTC (rev 1234)
@@ -750,8 +750,20 @@
==============================================================================*/
ScmObj ScmOp_car(ScmObj obj)
{
+ /*
+ * TODO: fixme! : Kazuki Ohta <mover at hct.zaq.ne.jp>
+ *
+ * In R5RS (car '()) becomes an error, but current uim assumes (car '()) == ()
+ * in many places. So, I decided to change ScmOp_car to SIOD like behavior.
+ *
+ */
+ /*
if (SCM_NULLP(obj))
SigScm_Error("car : empty list\n");
+ */
+ if (SCM_NULLP(obj))
+ return SCM_NIL;
+
if (!SCM_CONSP(obj))
SigScm_ErrorObj("car : list required but got ", obj);
@@ -760,8 +772,20 @@
ScmObj ScmOp_cdr(ScmObj obj)
{
+ /*
+ * TODO: fixme! : Kazuki Ohta <mover at hct.zaq.ne.jp>
+ *
+ * In R5RS (car '()) becomes an error, but current uim assumes (car '()) == ()
+ * in many places. So, I decided to change ScmOp_car to SIOD like behavior.
+ *
+ */
+ /*
if (SCM_NULLP(obj))
SigScm_Error("cdr : empty list\n");
+ */
+ if (SCM_NULLP(obj))
+ return SCM_NIL;
+
if (!SCM_CONSP(obj))
SigScm_ErrorObj("cdr : list required but got ", obj);
@@ -1078,9 +1102,8 @@
SigScm_ErrorObj("list-ref : int required but got ", scm_k);
list_tail = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
- if (SCM_NULLP(list_tail)) {
- SigScm_Error("list-ref : out of range\n");
- }
+ if (SCM_NULLP(list_tail))
+ SigScm_ErrorObj("list-ref : out of range ", scm_k);
return SCM_CAR(list_tail);
}
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-19 08:22:49 UTC (rev 1233)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-19 09:53:30 UTC (rev 1234)
@@ -55,17 +55,30 @@
=======================================*/
typedef void (*C_FUNC) (void);
+/* type declaration */
#include "sigschemetype.h"
+/* for debugging */
+struct trace_frame {
+ struct trace_frame *prev;
+ ScmObj obj;
+};
+
/*=======================================
Variable Declarations
=======================================*/
+/* datas.c */
extern ScmObj *stack_start_pointer;
+/* error.c*/
+extern ScmObj current_error_port;
+
+/* eval.c */
+extern struct trace_frame *trace_root;
+
+/* io.c */
extern ScmObj current_input_port;
extern ScmObj current_output_port;
-extern ScmObj current_error_port;
-
extern ScmObj SigScm_features;
/*=======================================
@@ -341,6 +354,7 @@
/* error.c */
void SigScm_Error(const char *msg, ...);
void SigScm_ErrorObj(const char *msg, ScmObj obj);
+void SigScm_ShowBacktrace(void);
/* debug.c */
void SigScm_Display(ScmObj obj);
More information about the uim-commit
mailing list