[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