commit 842a15801195249d8f1cc3c3f3fbfa0d103ff13a
parent 80ebdc81688bac55c98444ba4ff1ce3e5ba69798
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 18 Nov 2011 13:44:53 -0300
Added port-open? and open-{input/output}-{string/bytevector} to the ground environment.
Diffstat:
11 files changed, 187 insertions(+), 62 deletions(-)
diff --git a/src/kgports.c b/src/kgports.c
@@ -39,6 +39,11 @@
/* 15.1.2 input-port?, output-port? */
/* use ftypep */
+/* 15.1.? port-open? */
+/* uses ftyped_predp */
+
+/* uses ftyped_predp */
+
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* helper for with-i/o-from/to-file & call-with-i/o-file */
void do_close_file_ret(klisp_State *K, TValue *xparams, TValue obj)
@@ -106,11 +111,15 @@ void get_current_port(klisp_State *K, TValue *xparams, TValue ptree,
/* 15.1.5 open-input-file, open-output-file */
+/* 15.1.? open-binary-input-file, open-binary-output-file */
void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
- bool writep = bvalue(xparams[1]);
- bool binaryp = bvalue(xparams[2]);
- UNUSED(denv);
+ /*
+ ** xparams[0]: write?
+ ** xparams[1]: binary?
+ */
+ bool writep = bvalue(xparams[0]);
+ bool binaryp = bvalue(xparams[1]);
bind_1tp(K, ptree, "string", ttisstring, filename);
@@ -118,6 +127,38 @@ void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, new_port);
}
+/* 15.1.? open-input-string, open-output-string */
+/* 15.1.? open-input-bytevector, open-output-bytevector */
+void open_mport(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ /*
+ ** xparams[0]: write?
+ ** xparams[1]: binary?
+ */
+ bool writep = bvalue(xparams[0]);
+ bool binaryp = bvalue(xparams[1]);
+ UNUSED(denv);
+
+ TValue buffer;
+
+ /* This is kinda ugly but... */
+ if (writep) {
+ check_0p(K, ptree);
+ buffer = KINERT;
+ } else if (binaryp) {
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bb);
+ buffer = bb;
+ } else {
+ bind_1tp(K, ptree, "string", ttisstring, str);
+ buffer = str;
+ }
+
+ TValue new_port = kmake_mport(K, buffer, writep, binaryp);
+ kapply_cc(K, new_port);
+}
+
+/* 15.1.? open-output-string, open-output-bytevector */
+
/* 15.1.6 close-input-file, close-output-file */
void close_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
@@ -716,7 +757,7 @@ void flush(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
if (ttisfport(port)) { /* only necessary for file ports */
- FILE *file = kport_file(port);
+ FILE *file = kfport_file(port);
klisp_assert(file);
UNUSED(fflush(file)); /* TEMP for now don't signal errors on flush */
}
@@ -793,17 +834,20 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.1 port? */
add_applicative(K, ground_env, "port?", ftypep, 2, symbol,
- p2tv(kis_port));
+ p2tv(kportp));
/* 15.1.2 input-port?, output-port? */
add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
- p2tv(kis_input_port));
+ p2tv(kinput_portp));
add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol,
- p2tv(kis_output_port));
+ p2tv(koutput_portp));
/* 15.1.? binary-port?, textual-port? */
add_applicative(K, ground_env, "binary-port?", ftypep, 2, symbol,
- p2tv(kis_binary_port));
+ p2tv(kbinary_portp));
add_applicative(K, ground_env, "textual-port?", ftypep, 2, symbol,
- p2tv(kis_textual_port));
+ p2tv(ktextual_portp));
+ /* 15.1.? port-open? */
+ add_applicative(K, ground_env, "port-open?", ftyped_predp, 3, symbol,
+ p2tv(kportp), p2tv(kport_openp));
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* 15.1.? with-error-to-file */
@@ -822,14 +866,24 @@ void kinit_ports_ground_env(klisp_State *K)
add_applicative(K, ground_env, "get-current-error-port", get_current_port,
2, symbol, K->kd_error_port_key);
/* 15.1.5 open-input-file, open-output-file */
- add_applicative(K, ground_env, "open-input-file", open_file, 3, symbol,
+ add_applicative(K, ground_env, "open-input-file", open_file, 2,
b2tv(false), b2tv(false));
- add_applicative(K, ground_env, "open-output-file", open_file, 3, symbol,
+ add_applicative(K, ground_env, "open-output-file", open_file, 2,
b2tv(true), b2tv(false));
/* 15.1.? open-binary-input-file, open-binary-output-file */
- add_applicative(K, ground_env, "open-binary-input-file", open_file, 3, symbol,
+ add_applicative(K, ground_env, "open-binary-input-file", open_file, 2,
+ b2tv(false), b2tv(true));
+ add_applicative(K, ground_env, "open-binary-output-file", open_file, 2,
+ b2tv(true), b2tv(true));
+ /* 15.1.? open-input-string, open-output-string */
+ /* 15.1.? open-input-bytevector, open-output-bytevector */
+ add_applicative(K, ground_env, "open-input-string", open_mport, 2,
+ b2tv(false), b2tv(false));
+ add_applicative(K, ground_env, "open-output-string", open_mport, 2,
+ b2tv(true), b2tv(false));
+ add_applicative(K, ground_env, "open-input-bytevector", open_mport, 2,
b2tv(false), b2tv(true));
- add_applicative(K, ground_env, "open-binary-output-file", open_file, 3, symbol,
+ add_applicative(K, ground_env, "open-output-bytevector", open_mport, 2,
b2tv(true), b2tv(true));
/* 15.1.6 close-input-file, close-output-file */
diff --git a/src/kgports.h b/src/kgports.h
@@ -24,6 +24,9 @@
/* 15.1.2 input-port?, output-port? */
/* use ftypep */
+/* 15.1.? port-open? */
+/* uses ftyped_predp */
+
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* 15.1.? with-error-to-file */
void with_file(klisp_State *K, TValue *xparams, TValue ptree,
@@ -37,6 +40,10 @@ void get_current_port(klisp_State *K, TValue *xparams, TValue ptree,
/* 15.1.5 open-input-file, open-output-file */
void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* 15.1.? open-input-string, open-output-string */
+/* 15.1.? open-input-bytevector, open-output-bytevector */
+void open_mport(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
/* 15.1.6 close-input-file, close-output-file */
void close_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
diff --git a/src/klimits.h b/src/klimits.h
@@ -67,4 +67,14 @@
/* at last count, there were about 200 bindings in ground env */
#define ENVTABSIZE 512
+/* starting size for string port buffers */
+#ifndef MINSTRINGPORTBUFFER
+#define MINSTRINGPORTBUFFER 256
+#endif
+
+/* starting size for bytebuffer port buffers */
+#ifndef MINBYTEVECTORPORTBUFFER
+#define MINBYTEVECTORPORTBUFFER 256
+#endif
+
#endif
diff --git a/src/kobject.c b/src/kobject.c
@@ -74,31 +74,6 @@ char *ktv_names[] = {
[K_TMPORT] = "mem port"
};
-bool kis_port(TValue o)
-{
- return ttisport(o);
-}
-
-bool kis_input_port(TValue o)
-{
- return ttisport(o) && kport_is_input(o);
-}
-
-bool kis_output_port(TValue o)
-{
- return ttisport(o) && kport_is_output(o);
-}
-
-bool kis_binary_port(TValue o)
-{
- return ttisport(o) && kport_is_binary(o);
-}
-
-bool kis_textual_port(TValue o)
-{
- return ttisport(o) && kport_is_textual(o);
-}
-
int32_t klispO_log2 (uint32_t x) {
static const uint8_t log_2[256] = {
0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
diff --git a/src/kobject.h b/src/kobject.h
@@ -829,6 +829,7 @@ int32_t kmark_count;
#define kport_is_input(o_) ((tv_get_kflags(o_) & K_FLAG_INPUT_PORT) != 0)
#define kport_is_output(o_) ((tv_get_kflags(o_) & K_FLAG_OUTPUT_PORT) != 0)
+#define kport_is_open(o_) ((tv_get_kflags(o_) & K_FLAG_CLOSED_PORT) == 0)
#define kport_is_closed(o_) ((tv_get_kflags(o_) & K_FLAG_CLOSED_PORT) != 0)
#define kport_is_binary(o_) ((tv_get_kflags(o_) & K_FLAG_BINARY_PORT) != 0)
#define kport_is_textual(o_) ((tv_get_kflags(o_) & K_FLAG_BINARY_PORT) == 0)
@@ -842,15 +843,6 @@ int32_t kmark_count;
#define ktable_has_weak_values(o_) \
((tv_get_kflags(o_) & K_FLAG_WEAK_VALUES) != 0)
-/* can't be inline because we also use pointers to them,
- (at least gcc doesn't bother to create them and the linker fails) */
-/* REFACTOR shouldn't these be in kport.h?? */
-bool kis_port(TValue o);
-bool kis_input_port(TValue o);
-bool kis_output_port(TValue o);
-bool kis_binary_port(TValue o);
-bool kis_textual_port(TValue o);
-
/* Macro to test the most basic equality on TValues */
#define tv_equal(tv1_, tv2_) ((tv1_).raw == (tv2_).raw)
diff --git a/src/kport.c b/src/kport.c
@@ -13,9 +13,47 @@
#include "kmem.h"
#include "kerror.h"
#include "kstring.h"
+#include "kbytevector.h"
#include "kgc.h"
#include "kpair.h"
+bool kportp(TValue o)
+{
+ return ttisport(o);
+}
+
+bool kinput_portp(TValue o)
+{
+ return ttisport(o) && kport_is_input(o);
+}
+
+bool koutput_portp(TValue o)
+{
+ return ttisport(o) && kport_is_output(o);
+}
+
+bool kbinary_portp(TValue o)
+{
+ return ttisport(o) && kport_is_binary(o);
+}
+
+bool ktextual_portp(TValue o)
+{
+ return ttisport(o) && kport_is_textual(o);
+}
+
+bool kport_openp(TValue o)
+{
+ klisp_assert(ttisport(o));
+ return kport_is_open(o);
+}
+
+bool kport_closedp(TValue o)
+{
+ klisp_assert(ttisport(o));
+ return kport_is_closed(o);
+}
+
/* XXX: per the c spec, this truncates the file if it exists! */
/* Ask John: what would be best? Probably should also include delete,
file-exists? and a mechanism to truncate or append to a file, or
@@ -68,6 +106,39 @@ TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
return tv_port;
}
+TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp)
+{
+ klisp_assert(!writep || ttisinert(buffer));
+ klisp_assert(writep || (ttisbytevector(buffer) && binaryp) ||
+ (ttisstring(buffer) && !binaryp));
+
+ if (writep) {
+ buffer = binaryp? kbytevector_new_s(K, MINBYTEVECTORPORTBUFFER) :
+ kstring_new_s(K, MINSTRINGPORTBUFFER);
+ }
+
+ krooted_tvs_push(K, buffer);
+
+ MPort *new_port = klispM_new(K, MPort);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_port, K_TMPORT,
+ K_FLAG_CAN_HAVE_NAME |
+ (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
+ (binaryp? K_FLAG_BINARY_PORT : 0));
+
+ /* port specific fields */
+ TValue tv_port = gc2mport(new_port);
+ kport_filename(tv_port) = K->empty_string; /* XXX for now no filename */
+ /* line is 1-based and col is 0-based */
+ kport_line(tv_port) = 1;
+ kport_col(tv_port) = 0;
+ kmport_buf(tv_port) = buffer;
+ kmport_off(tv_port) = 0; /* no bytes read/written */
+ krooted_tvs_pop(K);
+ return tv_port;
+}
+
/* if the port is already closed do nothing */
/* This is also called from GC, so it shouldn't throw any error */
void kclose_port(klisp_State *K, TValue port)
diff --git a/src/kport.h b/src/kport.h
@@ -12,6 +12,16 @@
#include "kobject.h"
#include "kstate.h"
+/* can't be inline because we also use pointers to them,
+ (at least gcc doesn't bother to create them and the linker fails) */
+bool kportp(TValue o);
+bool kinput_portp(TValue o);
+bool koutput_portp(TValue o);
+bool kbinary_portp(TValue o);
+bool ktextual_portp(TValue o);
+bool kport_openp(TValue o);
+bool kport_closedp(TValue o);
+
/* GC: Assumes filename is rooted */
TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp);
@@ -21,9 +31,12 @@ TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp);
TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
bool binaryp, FILE *file);
-/* This closes the underlying FILE * (unless it is a std port) and also
- set the closed flag to true, this shouldn't throw errors because it
- is also called when deallocating all objs. If errors need to be thrown
+/* GC: buffer doesn't need to be rooted, but should probably do it anyways */
+TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp);
+
+/* This closes the underlying FILE * (unless it is a std port or memory port)
+ and also set the closed flag to true, this shouldn't throw errors because
+ it is also called when deallocating all objs. If errors need to be thrown
fork this function instead of simply modifying */
void kclose_port(klisp_State *K, TValue port);
@@ -31,7 +44,10 @@ void kclose_port(klisp_State *K, TValue port);
#define kport_line(p_) (tv2port(p_)->row)
#define kport_col(p_) (tv2port(p_)->col)
-#define kport_file(p_) (tv2fport(p_)->file)
+#define kfport_file(p_) (tv2fport(p_)->file)
+
+#define kmport_off(p_) (tv2mport(p_)->off)
+#define kmport_buf(p_) (tv2mport(p_)->buf)
void kport_reset_source_info(TValue port);
void kport_update_source_info(TValue port, int32_t line, int32_t col);
diff --git a/src/kread.c b/src/kread.c
@@ -563,7 +563,7 @@ TValue kread(klisp_State *K)
TValue kread_from_port(klisp_State *K, TValue port, bool mut)
{
K->curr_port = port;
- K->curr_in = kport_file(port);
+ K->curr_in = kfport_file(port);
K->read_mconsp = mut;
ktok_set_source_info(K, kport_filename(port),
@@ -583,7 +583,7 @@ TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek)
K->ktok_seen_eof = false;
K->curr_port = port;
- K->curr_in = kport_file(port);
+ K->curr_in = kfport_file(port);
int ch;
if (peek) {
ch = ktok_peekc(K);
@@ -604,7 +604,7 @@ TValue kread_peek_u8_from_port(klisp_State *K, TValue port, bool peek)
K->ktok_seen_eof = false;
K->curr_port = port;
- K->curr_in = kport_file(port);
+ K->curr_in = kfport_file(port);
int32_t u8;
if (peek) {
u8 = ktok_peekc(K);
@@ -626,7 +626,7 @@ void kread_ignore_whitespace_and_comments_from_port(klisp_State *K,
TValue port)
{
K->curr_port = port;
- K->curr_in = kport_file(port);
+ K->curr_in = kfport_file(port);
/* source code info isn't important because it will be reset later */
ktok_ignore_whitespace_and_comments(K);
}
diff --git a/src/krepl.c b/src/krepl.c
@@ -46,7 +46,7 @@ void do_repl_read(klisp_State *K, TValue *xparams, TValue obj)
fprintf(stdout, "klisp> ");
TValue port = kcdr(K->kd_in_port_key);
- klisp_assert(kport_file(port) == stdin);
+ klisp_assert(kfport_file(port) == stdin);
#if 0 /* Let's disable this for now */
/* workaround to the problem of the dangling '\n' in repl
(from previous line) */
@@ -112,7 +112,7 @@ void do_repl_loop(klisp_State *K, TValue *xparams, TValue obj)
*/
TValue port = kcdr(K->kd_out_port_key);
- klisp_assert(kport_file(port) == stdout);
+ klisp_assert(kfport_file(port) == stdout);
/* false: quote strings, escape chars */
kwrite_display_to_port(K, port, obj, false);
@@ -131,7 +131,7 @@ void do_repl_error(klisp_State *K, TValue *xparams, TValue obj)
/* FOR NOW used only for irritant list */
TValue port = kcdr(K->kd_error_port_key);
- klisp_assert(kport_file(port) == stderr);
+ klisp_assert(kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
diff --git a/src/kscript.c b/src/kscript.c
@@ -76,7 +76,7 @@ void do_script_error(klisp_State *K, TValue *xparams, TValue obj)
/* FOR NOW used only for irritant list */
TValue port = kcdr(K->kd_error_port_key);
- klisp_assert(kport_file(port) == stderr);
+ klisp_assert(kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -591,7 +591,7 @@ void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
bool displayp)
{
K->curr_port = port;
- K->curr_out = kport_file(port);
+ K->curr_out = kfport_file(port);
K->write_displayp = displayp;
kwrite(K, obj);
}
@@ -604,7 +604,7 @@ void kwrite_newline_to_port(klisp_State *K, TValue port)
void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
{
K->curr_port = port;
- K->curr_out = kport_file(port);
+ K->curr_out = kfport_file(port);
int res = fputc(chvalue(ch), K->curr_out);
/* implicit flush, MAYBE add flush call */
if (res != EOF)
@@ -619,7 +619,7 @@ void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8)
{
K->curr_port = port;
- K->curr_out = kport_file(port);
+ K->curr_out = kfport_file(port);
int res = fputc(ivalue(u8), K->curr_out);
/* implicit flush, MAYBE add flush call */
if (res != EOF)
