klisp

commit e1a2beb5435794502beec95a9e66edb366e1b7ae
parent 51ddb2f98e38a8daa537e754d77011bd342b61bb
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Tue,  5 Apr 2011 16:12:41 -0300

Added read-char and peek-char to the ground environment.

Diffstat:
M
src/kgports.c
 | 
56
++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kgports.h
 | 
8
++++++--
M
src/kground.c
 | 
6
++++--

3 files changed, 66 insertions(+), 4 deletions(-)
diff --git a/src/kgports.c b/src/kgports.c
@@ -245,6 +245,62 @@ void write_char(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     }
 }
 
+/* Helper for read-char and peek-char */
+void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree, 
+		    TValue denv)
+{
+    /* 
+    ** xparams[0]: symbol name
+    ** xparams[1]: ret-char-after-readp
+    */
+    UNUSED(denv);
+    
+    char *name = ksymbol_buf(xparams[0]);
+    bool ret_charp = bvalue(xparams[1]);
+
+    TValue port = ptree;
+    if (!get_opt_tpar(K, name, K_TPORT, &port)) {
+	port = kcdr(K->kd_in_port_key); /* access directly */
+    } else if (!kport_is_input(port)) {
+	klispE_throw_extra(K, name, ": the port should be an input port");
+	return;
+    } 
+    if (kport_is_closed(port)) {
+	klispE_throw_extra(K, name, ": the port is already closed");
+	return;
+    }
+
+    /* TODO update source info on the port */
+    FILE *f = K->curr_in = kport_file(port);
+    int ch = fgetc(f);
+    TValue obj;
+    if (ch == EOF) {
+	if (ferror(f) != 0) {
+	    /* clear error marker to allow retries later */
+	    clearerr(f);
+	    klispE_throw_extra(K, name, ": reading error");
+	    return;
+	} else { /* if (feof(f) != 0) */
+	    /* let the eof marker set */
+	    obj = KEOF;
+	}
+    } else {
+	obj = ch2tv((char) ch);
+	/* check to see if this was a peek-char call */
+	if (ret_charp) {
+	    if (ungetc(ch, f) == EOF)  {
+		/* shouldn't happen, but better be safe than sorry */
+		/* clear error marker to allow retries later */
+		clearerr(f);
+		klispE_throw_extra(K, name, ": error ungetting char");
+		return;
+	    }
+	}
+    }
+    kapply_cc(K, obj);
+}
+
+
 /* 15.1.? read-char */
 /* TODO */
 
diff --git a/src/kgports.h b/src/kgports.h
@@ -53,11 +53,15 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 /* 15.1.? write-char */
 void write_char(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
+/* Helper for read-char and peek-char */
+void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree, 
+		    TValue denv);
+
 /* 15.1.? read-char */
-/* TODO */
+/* uses read_peek_char */
 
 /* 15.1.? peek-char */
-/* TODO */
+/* uses read_peek_char */
 
 /* 15.1.? char-ready? */
 /* TODO */
diff --git a/src/kground.c b/src/kground.c
@@ -964,10 +964,12 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "write-char", write_char, 0);
     
     /* 15.1.? read-char */
-    /* TODO */
+    add_applicative(K, ground_env, "read-char", read_peek_char, 2, symbol, 
+		    b2tv(false));
     
     /* 15.1.? peek-char */
-    /* TODO */
+    add_applicative(K, ground_env, "peek-char", read_peek_char, 2, symbol, 
+		    b2tv(true));
 
     /* 15.1.? char-ready? */
     /* TODO */