[uim-commit] r1072 - branches/r5rs/sigscheme
kzk at freedesktop.org
kzk at freedesktop.org
Sat Jul 30 01:12:47 EST 2005
Author: kzk
Date: 2005-07-29 08:12:41 -0700 (Fri, 29 Jul 2005)
New Revision: 1072
Modified:
branches/r5rs/sigscheme/debug.c
branches/r5rs/sigscheme/error.c
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/io.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* fix many, many bugs...
* sigscheme/io.c
- (ScmOp_call_with_input_file): use apply instead of eval,
because eval re-evaluated the argument.
- (ScmOp_call_with_output_file): Ditto.
- (ScmOp_with_input_from_file): Ditto.
- (ScmOp_with_output_to_file): Ditto.
- (ScmOp_read): fixed argument handling.
- (ScmOp_write): use current_output_port. too odd..
- (ScmOp_file_existp): new func for SLIB
- (ScmOp_delete_file): new func for SLIB
* sigscheme/sigscheme.c
- (SigScm_Initialize): export "file-exists?" and "delete-file"
for SLIB. and add current_error_port.
* sigscheme/sigscheme.h
- (current_error_port): new variable
- (ScmOp_file_existp): new func for SLIB
- (ScmOp_delete_file): new func for SLIB
* sigscheme/debug.c
- (print_ScmObj_internal): print "port".
* sigscheme/eval.c
- (lookup_environment): change error message
- (lookup_frame): change error message and handle dot list
correctly.
- (ScmOp_apply): no need to evaluate args in apply
* sigscheme/error.c
- (SigScm_Error): use current_error_port instead of
current_output_port
- (SigScm_ErrorObj): use current_error_port instead of
current_output_port
Modified: branches/r5rs/sigscheme/debug.c
===================================================================
--- branches/r5rs/sigscheme/debug.c 2005-07-29 14:59:15 UTC (rev 1071)
+++ branches/r5rs/sigscheme/debug.c 2005-07-29 15:12:41 UTC (rev 1072)
@@ -103,7 +103,18 @@
} else if (SCM_FREECELLP(obj)) {
fprintf(f, "[ FreeCell ] \n");
} else if (SCM_PORTP(obj)) {
- fprintf(f, "(port)");
+ fprintf(f, "#<");
+ if (SCM_PORT_PORTDIRECTION(obj) == PORT_INPUT)
+ fprintf(f, "i");
+ else
+ fprintf(f, "o");
+ fprintf(f, "port ");
+ if (SCM_PORT_PORTTYPE(obj) == PORT_FILE) {
+ fprintf(f, "file");
+ } else if (SCM_PORT_PORTTYPE(obj) == PORT_STRING) {
+ fprintf(f, "string");
+ }
+ fprintf(f, ">");
} else if (SCM_CONTINUATIONP(obj)) {
fprintf(f, "(continuation)");
} else {
Modified: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c 2005-07-29 14:59:15 UTC (rev 1071)
+++ branches/r5rs/sigscheme/error.c 2005-07-29 15:12:41 UTC (rev 1072)
@@ -51,6 +51,11 @@
=======================================*/
/*=======================================
+ Variable Declarations
+=======================================*/
+ScmObj current_error_port = NULL;
+
+/*=======================================
File Local Function Declarations
=======================================*/
@@ -68,7 +73,7 @@
{
va_list va;
va_start(va, msg);
- vfprintf(SCM_PORTINFO_FILE(current_output_port), msg, va);
+ vfprintf(SCM_PORTINFO_FILE(current_error_port), msg, va);
va_end(va);
exit(-1);
@@ -77,7 +82,7 @@
void SigScm_ErrorObj(const char *msg, ScmObj obj)
{
/* print msg */
- fprintf(SCM_PORTINFO_FILE(current_output_port), "%s", msg);
+ fprintf(SCM_PORTINFO_FILE(current_error_port), "%s", msg);
/* print obj */
SigScm_Display(obj);
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-07-29 14:59:15 UTC (rev 1071)
+++ branches/r5rs/sigscheme/eval.c 2005-07-29 15:12:41 UTC (rev 1072)
@@ -150,7 +150,7 @@
if (SCM_NULLP(env))
return SCM_NIL;
if (!SCM_CONSP(env))
- SigScm_Error("Broken environent.\n");
+ SigScm_ErrorObj("Broken environent : ", env);
/* lookup frames */
for (; !SCM_NULLP(env); env = SCM_CDR(env)) {
@@ -172,7 +172,7 @@
if (SCM_NULLP(frame))
return SCM_NIL;
else if (!SCM_CONSP(frame))
- SigScm_Error("Broken frame.\n");
+ SigScm_ErrorObj("Broken frame : ", frame);
/* lookup in frame */
vars = SCM_CAR(frame);
@@ -186,6 +186,8 @@
} else {
if (SCM_EQ(vars, var))
return Scm_NewCons(vals, SCM_NIL);
+ else
+ return SCM_NIL;
}
}
@@ -468,7 +470,7 @@
case ARGNUM_L:
{
return SCM_FUNC_EXEC_SUBRL(proc,
- map_eval(obj, env),
+ obj,
env);
}
case ARGNUM_2N:
@@ -490,7 +492,7 @@
for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
obj = SCM_FUNC_EXEC_SUBR2N(proc,
obj,
- ScmOp_eval(SCM_CAR(args), env));
+ SCM_CAR(args));
}
return obj;
}
Modified: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c 2005-07-29 14:59:15 UTC (rev 1071)
+++ branches/r5rs/sigscheme/io.c 2005-07-29 15:12:41 UTC (rev 1072)
@@ -81,8 +81,11 @@
/* open port */
port = ScmOp_open_input_file(filepath);
- /* (eval '(proc port) '())*/
- ret = ScmOp_eval(Scm_NewCons(proc, Scm_NewCons(port, SCM_NIL)), SCM_NIL);
+ /* (apply proc (port)) */
+ ret = ScmOp_apply(Scm_NewCons(proc,
+ Scm_NewCons(Scm_NewCons(port, SCM_NIL),
+ SCM_NIL)),
+ SCM_NIL);
/* close port */
ScmOp_close_input_port(port);
@@ -103,8 +106,11 @@
/* open port */
port = ScmOp_open_output_file(filepath);
- /* (eval '(proc port) '())*/
- ret = ScmOp_eval(Scm_NewCons(proc, Scm_NewCons(port, SCM_NIL)), SCM_NIL);
+ /* (apply proc (port)) */
+ ret = ScmOp_apply(Scm_NewCons(proc,
+ Scm_NewCons(Scm_NewCons(port, SCM_NIL),
+ SCM_NIL)),
+ SCM_NIL);
/* close port */
ScmOp_close_output_port(port);
@@ -152,8 +158,11 @@
tmp_port = current_input_port;
current_input_port = ScmOp_open_input_file(filepath);
- /* (eval '(thunk) '())*/
- ret = ScmOp_eval(Scm_NewCons(thunk, SCM_NIL), SCM_NIL);
+ /* (apply thunk ())*/
+ ret = ScmOp_apply(Scm_NewCons(thunk,
+ Scm_NewCons(Scm_NewCons(SCM_NIL, SCM_NIL),
+ SCM_NIL)),
+ SCM_NIL);
/* close port */
ScmOp_close_input_port(current_input_port);
@@ -178,8 +187,11 @@
tmp_port = current_output_port;
current_output_port = ScmOp_open_output_file(filepath);
- /* (eval '(thunk) '())*/
- ret = ScmOp_eval(Scm_NewCons(thunk, SCM_NIL), SCM_NIL);
+ /* (apply thunk ())*/
+ ret = ScmOp_apply(Scm_NewCons(thunk,
+ Scm_NewCons(Scm_NewCons(SCM_NIL, SCM_NIL),
+ SCM_NIL)),
+ SCM_NIL);
/* close port */
ScmOp_close_output_port(current_output_port);
@@ -253,9 +265,9 @@
if (SCM_NULLP(arg)) {
/* (read) */
port = current_input_port;
- } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+ } else if (SCM_PORTP(SCM_CAR(arg))) {
/* (read port) */
- port = SCM_CAR(SCM_CDR(arg));
+ port = SCM_CAR(arg);
} else {
SigScm_ErrorObj("read : invalid parameter", arg);
}
@@ -317,7 +329,7 @@
arg = SCM_CDR(arg);
/* get port */
- port = current_input_port;
+ port = current_output_port;
if (!SCM_NULLP(arg) && !SCM_NULLP(SCM_CAR(arg)) && SCM_PORTP(SCM_CAR(arg)))
port = SCM_CAR(arg);
@@ -348,6 +360,7 @@
port = SCM_CAR(arg);
SigScm_DisplayToPort(port, obj);
+
return SCM_UNDEF;
}
@@ -361,7 +374,7 @@
port = SCM_CAR(arg);
}
- SigScm_DisplayToPort(port, Scm_NewString("\n"));
+ SigScm_DisplayToPort(port, Scm_NewStringCopying("\n"));
return SCM_UNDEF;
}
@@ -429,6 +442,31 @@
SigScm_load(c_filename);
/* TODO : investigate */
- return SCM_NIL;
+ return SCM_TRUE;
}
+
+ScmObj ScmOp_file_existsp(ScmObj filepath)
+{
+ FILE *f = NULL;
+
+ if (!SCM_STRINGP(filepath))
+ SigScm_ErrorObj("file-exists? : string requred but got ", filepath);
+
+ f = fopen(SCM_STRING_STR(filepath), "r");
+ if (!f)
+ return SCM_FALSE;
+
+ return SCM_TRUE;
+}
+
+ScmObj ScmOp_delete_file(ScmObj filepath)
+{
+ if (!SCM_STRINGP(filepath))
+ SigScm_ErrorObj("delete-file : string requred but got ", filepath);
+
+ if (remove(SCM_STRING_STR(filepath)) == -1)
+ SigScm_ErrorObj("delete-file : delete failed. file = ", filepath);
+
+ return SCM_TRUE;
+}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-07-29 14:59:15 UTC (rev 1071)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-07-29 15:12:41 UTC (rev 1072)
@@ -257,6 +257,9 @@
Scm_InitSubrL("newline" , ScmOp_newline);
Scm_InitSubrL("write-char" , ScmOp_write_char);
Scm_InitSubr1("load" , ScmOp_load);
+ Scm_InitSubr1("file-exists?" , ScmOp_file_existsp);
+ Scm_InitSubr1("delete-file" , ScmOp_delete_file);
+
/*=======================================================================
Current Input & Output Initialization
=======================================================================*/
@@ -264,6 +267,8 @@
SigScm_gc_protect(current_input_port);
current_output_port = Scm_NewFilePort(stdout, PORT_OUTPUT);
SigScm_gc_protect(current_output_port);
+ current_error_port = Scm_NewFilePort(stderr, PORT_OUTPUT);
+ SigScm_gc_protect(current_error_port);
#if USE_SRFI1
/*=======================================================================
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-07-29 14:59:15 UTC (rev 1071)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-07-29 15:12:41 UTC (rev 1072)
@@ -64,6 +64,7 @@
extern ScmObj current_input_port;
extern ScmObj current_output_port;
+extern ScmObj current_error_port;
/*=======================================
Macro Declarations
@@ -311,6 +312,9 @@
ScmObj SigScm_load(const char *c_filename);
ScmObj ScmOp_load(ScmObj filename);
+ScmObj ScmOp_file_existsp(ScmObj filepath);
+ScmObj ScmOp_delete_file(ScmObj filepath);
+
/* encoding.c */
int SigScm_default_encoding_strlen(const char *str);
const char* SigScm_default_encoding_str_startpos(const char *str, int k);
More information about the uim-commit
mailing list