commit f3d9c6fd442e9272e6d35b26c26cebcd48cd6ecf
parent 35bca54319ff0ab909426fa9f27b754f54ab78ca
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 29 Nov 2011 02:09:49 -0300
Added write-simple to the ground environment.
Diffstat:
6 files changed, 65 insertions(+), 13 deletions(-)
diff --git a/TODO b/TODO
@@ -1,19 +1,17 @@
* refactor:
** double check combiner names to be verbs
(e.g. add get- where appropriate)
-** remove function prototypes from kg*.h, move the
- ones that are used in more than one place to kghelpers.h
-** create knumber.h knumber.c and move there kfinitep, kintegerp, etc
- from kgnumbers.
+** split kghelpers in appropriate parts
+ (e.g. create knumber.h knumber.c and move there kfinitep, kintegerp, etc
+ from kgnumbers)
** use some convention for ground operative underlaying function names
maybe add "kgop_"
** use a better convention for continuation underlaying function names
** try to use krooted_vars_push more to save some lines and avoid
clutter (e.g. when creating continuations)
** Study differrent c interfaces (maybe a stack like in lua would be
- better than dealing with gc push/pop
-** eliminate char * arguments where not needed (like list check/copy
- functions in kghelpers
+ better than dealing with gc push/pop)
+** eliminate all remaining char * arguments where not needed
** check if all inline functions need to be inline
** standarize either int32_t (now used in lists) or uint32_t (now used
in strings, vectors and bytevectors) for sizes (and maybe use a
@@ -37,7 +35,6 @@
** number->string (r7rs)
** string->number (r7rs)
** read-line (r7rs)
-** write-simple (r7rs)
* reader
** symbol escapes (r7rs)
** string escapes (r7rs)
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -46,7 +46,7 @@ TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
TValue res = gc2cont(new_cont);
/* Add the current source info as source info (may be changed later) */
/* TODO: find all the places where this should be changed (like $and?,
- $sequence, and change it */
+ $sequence), and change it */
kset_source_info(K, res, kget_csi(K));
return res;
}
diff --git a/src/kgports.c b/src/kgports.c
@@ -336,6 +336,38 @@ void gwrite(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* 15.1.? write-simple */
+void gwrite_simple(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_al1tp(K, ptree, "any", anytype, obj,
+ port);
+
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
+ port = kcdr(K->kd_out_port_key); /* access directly */
+ }
+
+ if (!kport_is_output(port)) {
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
+ klispE_throw_simple(K, "the port is already closed");
+ return;
+ }
+
+ kwrite_simple_to_port(K, port, obj);
+ kapply_cc(K, KINERT);
+}
+
/* 15.1.? eof-object? */
/* uses typep */
@@ -963,6 +995,8 @@ void kinit_ports_ground_env(klisp_State *K)
add_applicative(K, ground_env, "read", gread, 0);
/* 15.1.8 write */
add_applicative(K, ground_env, "write", gwrite, 0);
+ /* 15.1.? write-simple */
+ add_applicative(K, ground_env, "write-simple", gwrite_simple, 0);
/* 15.1.? eof-object? */
add_applicative(K, ground_env, "eof-object?", typep, 2, symbol,
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -327,13 +327,12 @@ void kw_print_cont_type(klisp_State *K, TValue obj)
/*
** Writes all values except strings and pairs
*/
-
-void kwrite_simple(klisp_State *K, TValue obj)
+void kwrite_scalar(klisp_State *K, TValue obj)
{
switch(ttype(obj)) {
case K_TSTRING:
/* shouldn't happen */
- kwrite_error(K, "string type found in kwrite-simple");
+ klisp_assert(0);
/* avoid warning */
return;
case K_TFIXINT:
@@ -607,7 +606,7 @@ void kwrite_fsm(klisp_State *K, TValue obj)
break;
}
default:
- kwrite_simple(K, obj);
+ kwrite_scalar(K, obj);
middle_list = true;
}
}
@@ -633,6 +632,19 @@ void kwrite(klisp_State *K, TValue obj)
}
/*
+** This is the same as above but will not display
+** shared tags (and will hang if there are cycles)
+*/
+void kwrite_simple(klisp_State *K, TValue obj)
+{
+ /* GC: root obj */
+ krooted_tvs_push(K, obj);
+ kwrite_fsm(K, obj);
+ kw_flush(K);
+ krooted_tvs_pop(K);
+}
+
+/*
** Interface
*/
void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
@@ -643,6 +655,13 @@ void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
kwrite(K, obj);
}
+void kwrite_simple_to_port(klisp_State *K, TValue port, TValue obj)
+{
+ K->curr_port = port;
+ K->write_displayp = false;
+ kwrite_simple(K, obj);
+}
+
void kwrite_newline_to_port(klisp_State *K, TValue port)
{
K->curr_port = port; /* this isn't needed but all other
diff --git a/src/kwrite.h b/src/kwrite.h
@@ -15,6 +15,7 @@
*/
void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
bool displayp);
+void kwrite_simple_to_port(klisp_State *K, TValue port, TValue obj);
void kwrite_newline_to_port(klisp_State *K, TValue port);
void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch);
void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8);
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -206,6 +206,7 @@
($check-error (write 0 (get-current-input-port)))
($check-error (call-with-closed-output-port ($lambda (p) (write 0 p))))
+;; write-simple
;; 15.2.1 call-with-input-file call-with-output-file
;; 15.2.2 load
;; 15.2.3 get-module
