commit ff482c2c28350522b46e491ecaa11ead69112da5
parent 4220b3288dea3f805274c8a7d5f3bc13bfbbb843
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 5 Apr 2011 16:47:17 -0300
Added display to the ground environment. Some light refactoring.
Diffstat:
8 files changed, 65 insertions(+), 27 deletions(-)
diff --git a/src/kgports.c b/src/kgports.c
@@ -154,7 +154,7 @@ void read(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
ktok_reset_source_info(K); /* this should be saved in the port
and restored before the call to
read and saved after it */
- K->read_cons_flag = true; /* read mutable pairs */
+ K->read_mconsp = true; /* read mutable pairs */
TValue obj = kread(K); /* this may throw an error, that's ok */
kapply_cc(K, obj);
}
@@ -181,6 +181,7 @@ void write(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* TEMP: for now set this by hand */
K->curr_out = kport_file(port);
+ K->write_displayp = false;
kwrite(K, obj);
kapply_cc(K, KINERT);
@@ -369,7 +370,7 @@ TValue read_all_expr(klisp_State *K, TValue port)
/* TEMP: for now set this by hand */
K->curr_in = kport_file(port);
ktok_reset_source_info(K);
- K->read_cons_flag = false; /* read immutable pairs */
+ K->read_mconsp = false; /* read immutable pairs */
/* GC: root dummy and obj */
TValue dummy = kimm_cons(K, KNIL, KNIL);
@@ -519,4 +520,29 @@ void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.2.? display */
-/* TODO */
+void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_al1tp(K, "display", ptree, "any", anytype, obj,
+ port);
+
+ if (!get_opt_tpar(K, "display", K_TPORT, &port)) {
+ port = kcdr(K->kd_out_port_key); /* access directly */
+ } else if (!kport_is_output(port)) {
+ klispE_throw(K, "display: the port should be an output port");
+ return;
+ }
+ if (kport_is_closed(port)) {
+ klispE_throw(K, "display: the port is already closed");
+ return;
+ }
+
+ /* TEMP: for now set this by hand */
+ K->curr_out = kport_file(port);
+ K->write_displayp = true;
+
+ kwrite(K, obj);
+ kapply_cc(K, KINERT);
+}
diff --git a/src/kgports.h b/src/kgports.h
@@ -81,6 +81,6 @@ void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 15.2.? display */
-/* TODO */
+void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
#endif
diff --git a/src/kground.c b/src/kground.c
@@ -995,7 +995,7 @@ void kinit_ground_env(klisp_State *K)
add_applicative(K, ground_env, "get-module", get_module, 0);
/* 15.2.? display */
- /* TODO */
+ add_applicative(K, ground_env, "display", display, 0);
/* MAYBE: That's all there is in the report combined with r5rs scheme,
but we will probably need: file-exists?, rename-file and remove-file.
diff --git a/src/kread.c b/src/kread.c
@@ -165,7 +165,7 @@ TValue kread_fsm(klisp_State *K)
return KINERT;
}
/* construct the list with the correct type of pair */
- TValue np = kcons_g(K, K->read_cons_flag, KINERT, KNIL);
+ TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
/*
** NOTE: the source info of the '(' is temporarily saved
** in np (later it will be replace by the source info
@@ -408,7 +408,7 @@ TValue kread_fsm(klisp_State *K)
/* get the state out of the way */
pop_state(K);
/* construct the list with the correct type of pair */
- TValue np = kcons_g(K, K->read_cons_flag, obj, KNIL);
+ TValue np = kcons_g(K, K->read_mconsp, obj, KNIL);
kset_source_info(np, obj_si);
kset_cdr(get_data(K), np);
/* replace last pair of the (still incomplete) read next obj */
diff --git a/src/krepl.c b/src/krepl.c
@@ -42,7 +42,7 @@ void read_fn(klisp_State *K, TValue *xparams, TValue obj)
/* TEMP: for now set this by hand */
K->curr_in = stdin;
ktok_reset_source_info(K);
- K->read_cons_flag = true; /* read mutable pairs */
+ K->read_mconsp = true; /* read mutable pairs */
obj = kread(K);
kapply_cc(K, obj);
@@ -90,7 +90,7 @@ void loop_fn(klisp_State *K, TValue *xparams, TValue obj)
/* TEMP: for now set this by hand */
K->curr_out = stdout;
-
+ K->write_displayp = false;
kwrite(K, obj);
knewline(K);
TValue denv = xparams[0];
diff --git a/src/kstate.c b/src/kstate.c
@@ -122,9 +122,10 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* initialize reader */
K->shared_dict = KNIL;
- K->read_cons_flag = false; /* should be set before calling read */
+ K->read_mconsp = false; /* should be set before calling read */
/* initialize writer */
+ K->write_displayp = false; /* should be set before calling write */
/* initialize temp stack */
K->ssize = KS_ISSIZE;
diff --git a/src/kstate.h b/src/kstate.h
@@ -102,7 +102,10 @@ struct klisp_State {
/* reader */
/* TODO: replace the list with a hashtable */
TValue shared_dict;
- bool read_cons_flag;
+ bool read_mconsp;
+
+ /* writer */
+ bool write_displayp;
/* auxiliary stack */
int32_t ssize; /* total size of array */
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -49,7 +49,8 @@ void kw_print_string(klisp_State *K, TValue str)
char *ptr = buf;
int i = 0;
- kw_printf(K, "\"");
+ if (!K->write_displayp)
+ kw_printf(K, "\"");
while (i < size) {
/* find the longest printf-able substring to avoid calling printf
@@ -76,7 +77,8 @@ void kw_print_string(klisp_State *K, TValue str)
buf = ptr;
}
- kw_printf(K, "\"");
+ if (!K->write_displayp)
+ kw_printf(K, "\"");
}
/*
@@ -168,20 +170,24 @@ void kwrite_simple(klisp_State *K, TValue obj)
kw_printf(K, "()");
break;
case K_TCHAR: {
- char ch_buf[4];
- char ch = chvalue(obj);
- char *ch_ptr;
-
- if (ch == '\n') {
- ch_ptr = "newline";
- } else if (ch == ' ') {
- ch_ptr = "space";
+ if (K->write_displayp) {
+ kw_printf(K, "%c", chvalue(obj));
} else {
- ch_buf[0] = ch;
- ch_buf[1] = '\0';
- ch_ptr = ch_buf;
+ char ch_buf[4];
+ char ch = chvalue(obj);
+ char *ch_ptr;
+
+ if (ch == '\n') {
+ ch_ptr = "newline";
+ } else if (ch == ' ') {
+ ch_ptr = "space";
+ } else {
+ ch_buf[0] = ch;
+ ch_buf[1] = '\0';
+ ch_ptr = ch_buf;
+ }
+ kw_printf(K, "#\\%s", ch_ptr);
}
- kw_printf(K, "#\\%s", ch_ptr);
break;
}
case K_TBOOLEAN:
@@ -285,7 +291,7 @@ void kwrite_fsm(klisp_State *K, TValue obj)
push_data(K, kcdr(obj));
push_data(K, kcar(obj));
middle_list = false;
- } else { /* string with an assigned number */
+ } else { /* pair with an assigned number */
kw_printf(K, "#%" PRId32 "#", ivalue(mark));
middle_list = true;
}
@@ -296,7 +302,9 @@ void kwrite_fsm(klisp_State *K, TValue obj)
kw_printf(K, "\"\"");
} else {
TValue mark = kget_mark(obj);
- if (ttisboolean(mark)) { /* simple string (only once) */
+ if (K->write_displayp || ttisboolean(mark)) {
+ /* simple string (only once) or in display
+ (show all strings) */
kw_print_string(K, obj);
} else if (ivalue(mark) < 0) { /* string with no assigned # */
/* TEMP: for now only fixints in shared refs */
