[uim-commit] r1238 - branches/r5rs/sigscheme
kzk at freedesktop.org
kzk at freedesktop.org
Sat Aug 20 04:04:35 EST 2005
Author: kzk
Date: 2005-08-19 11:04:31 -0700 (Fri, 19 Aug 2005)
New Revision: 1238
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/io.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* implement valid file-path guessing for "load", "require"
* implement "bit-and", "bit-or", "but-xor" and "bit-not"
* reimplement "set-symbol-value!" to be compatible with SIOD properly
* sigscheme/io.c
- (create_valid_path): new func
- (file_existsp): new func
- (SigScm_load): use create_valid_path to guess valid path
* sigscheme/sigscheme.h
* sigscheme/sigscheme.c
* sigscheme/eval.c
- (ScmOp_bit_and, ScmOp_bit_or, ScmOp_bit_xor, ScmOp_bit_not)
: new func
- (ScmOp_set_symbol_value): change args
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-19 16:04:16 UTC (rev 1237)
+++ branches/r5rs/sigscheme/eval.c 2005-08-19 18:04:31 UTC (rev 1238)
@@ -1677,11 +1677,49 @@
return symbol_value(var, env);
}
-ScmObj ScmOp_set_symbol_value(ScmObj arg, ScmObj env)
+ScmObj ScmOp_set_symbol_value(ScmObj var, ScmObj val)
{
- int flag = 0;
+ /* sanity check */
+ if (!SCM_SYMBOLP(var))
+ SigScm_ErrorObj("set-symbol-value! : require symbol but got ", var);
- return ScmExp_set(arg,
- &env,
- &flag);
+ return SCM_SYMBOL_VCELL(var);
}
+
+ScmObj ScmOp_bit_and(ScmObj obj1, ScmObj obj2)
+{
+ if (!SCM_INTP(obj1))
+ SigScm_ErrorObj("bit-and : number required but got ", obj1);
+ if (!SCM_INTP(obj2))
+ SigScm_ErrorObj("bit-and : number required but got ", obj2);
+
+ return Scm_NewInt(SCM_INT_VALUE(obj1) & SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_bit_or(ScmObj obj1, ScmObj obj2)
+{
+ if (!SCM_INTP(obj1))
+ SigScm_ErrorObj("bit-or : number required but got ", obj1);
+ if (!SCM_INTP(obj2))
+ SigScm_ErrorObj("bit-or : number required but got ", obj2);
+
+ return Scm_NewInt(SCM_INT_VALUE(obj1) | SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_bit_xor(ScmObj obj1, ScmObj obj2)
+{
+ if (!SCM_INTP(obj1))
+ SigScm_ErrorObj("bit-xor : number required but got ", obj1);
+ if (!SCM_INTP(obj2))
+ SigScm_ErrorObj("bit-xor : number required but got ", obj2);
+
+ return Scm_NewInt(SCM_INT_VALUE(obj1) ^ SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_bit_not(ScmObj obj)
+{
+ if (!SCM_INTP(obj))
+ SigScm_ErrorObj("bit-not : number required but got ", obj);
+
+ return Scm_NewInt(~SCM_INT_VALUE(obj));
+}
Modified: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c 2005-08-19 16:04:16 UTC (rev 1237)
+++ branches/r5rs/sigscheme/io.c 2005-08-19 18:04:31 UTC (rev 1238)
@@ -62,7 +62,9 @@
/*=======================================
File Local Function Declarations
=======================================*/
+static char* create_valid_path(const char *c_filename);
static ScmObj create_loaded_str(ScmObj filename);
+static int file_existsp(const char *filepath);
/*=======================================
Function Implementations
@@ -443,22 +445,14 @@
ScmObj stack_start;
ScmObj port = SCM_NIL;
ScmObj s_expression = SCM_NIL;
- char *c_filename = strdup(filename);
- char *filepath = NULL;
+ char *filepath = create_valid_path(filename);
/* start protecting stack */
SigScm_gc_protect_stack(&stack_start);
- /* construct filepath */
- if (lib_path) {
- filepath = alloca(strlen(lib_path) + strlen(c_filename) + 2);
- strcpy(filepath, lib_path);
- strcat(filepath, "/");
- strcat(filepath, c_filename);
- } else {
- filepath = alloca(strlen(c_filename) + 1);
- strcpy(filepath, c_filename);
- }
+ /* sanity check */
+ if (!filepath)
+ SigScm_Error("SigScm_load : no such file = %s\n", filepath);
/* open port */
port = ScmOp_open_input_file(Scm_NewStringCopying(filepath));
@@ -479,11 +473,50 @@
SigScm_gc_unprotect_stack(&stack_start);
/* free str */
- free(c_filename);
+ free(filepath);
return SCM_UNSPECIFIED;
}
+static char* create_valid_path(const char *filename)
+{
+ char *c_filename = strdup(filename);
+ char *filepath = NULL;
+
+ /* construct filepath */
+ if (lib_path) {
+ /* try absolute path */
+ if (file_existsp(c_filename))
+ return c_filename;
+
+ /* use lib_path */
+ filepath = (char*)malloc(strlen(lib_path) + strlen(c_filename) + 2);
+ strcpy(filepath, lib_path);
+ strcat(filepath, "/");
+ strcat(filepath, c_filename);
+ if (file_existsp(filepath)) {
+ free(c_filename);
+ return filepath;
+ }
+ }
+
+ /* clear */
+ if (filepath)
+ free(filepath);
+
+ /* fallback */
+ filepath = (char*)malloc(strlen(c_filename) + 1);
+ strcpy(filepath, c_filename);
+ if (file_existsp(filepath)) {
+ free(c_filename);
+ return filepath;
+ }
+
+ free(c_filename);
+ free(filepath);
+ return NULL;
+}
+
ScmObj ScmOp_load(ScmObj filename)
{
char *c_filename = SCM_STRING_STR(filename);
@@ -558,18 +591,13 @@
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;
+ if (file_existsp(SCM_STRING_STR(filepath)))
+ return SCM_TRUE;
- fclose(f);
-
- return SCM_TRUE;
+ return SCM_FALSE;
}
ScmObj ScmOp_delete_file(ScmObj filepath)
@@ -582,3 +610,13 @@
return SCM_TRUE;
}
+
+static int file_existsp(const char *c_filepath)
+{
+ FILE *f = fopen(c_filepath, "r");
+ if (!f)
+ return 0;
+
+ fclose(f);
+ return 1;
+}
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-08-19 16:04:16 UTC (rev 1237)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-08-19 18:04:31 UTC (rev 1238)
@@ -134,9 +134,14 @@
Scm_RegisterFuncR("define" , ScmExp_define);
Scm_RegisterFunc1("scheme-report-environment", ScmOp_scheme_report_environment);
Scm_RegisterFunc1("null-environment" , ScmOp_null_environment);
+ /* SIOD compatible functions */
Scm_RegisterFunc1("symbol-bound?" , ScmOp_symbol_boundp);
Scm_RegisterFuncL("symbol-value" , ScmOp_symbol_value);
- Scm_RegisterFuncL("set-symbol-value!" , ScmOp_set_symbol_value);
+ Scm_RegisterFunc2("set-symbol-value!" , ScmOp_set_symbol_value);
+ Scm_RegisterFunc2("bit-and" , ScmOp_bit_and);
+ Scm_RegisterFunc2("bit-or" , ScmOp_bit_or);
+ Scm_RegisterFunc2("bit-xor" , ScmOp_bit_xor);
+ Scm_RegisterFunc1("bit-not" , ScmOp_bit_not);
/* operations.c */
Scm_RegisterFunc2("eqv?" , ScmOp_eqvp);
Scm_RegisterFunc2("eq?" , ScmOp_eqp);
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-19 16:04:16 UTC (rev 1237)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-19 18:04:31 UTC (rev 1238)
@@ -179,9 +179,14 @@
ScmObj ScmExp_define(ScmObj arg, ScmObj *envp, int *tail_flag);
ScmObj ScmOp_scheme_report_environment(ScmObj version);
ScmObj ScmOp_null_environment(ScmObj version);
+/* SIOD compatible functions */
ScmObj ScmOp_symbol_boundp(ScmObj obj);
ScmObj ScmOp_symbol_value(ScmObj var, ScmObj env);
-ScmObj ScmOp_set_symbol_value(ScmObj var, ScmObj env);
+ScmObj ScmOp_set_symbol_value(ScmObj var, ScmObj val);
+ScmObj ScmOp_bit_and(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_bit_or(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_bit_xor(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_bit_not(ScmObj obj);
/* operations.c */
ScmObj ScmOp_eqvp(ScmObj obj1, ScmObj obj2);
More information about the uim-commit
mailing list