commit 80ebdc81688bac55c98444ba4ff1ce3e5ba69798
parent 50e2b7c6c91186fab58cb75a9c85426aa59d983f
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 18 Nov 2011 11:52:44 -0300
Refactor: get_opt_tpar is now a macro. Port type divided in File Port and Memory Port (for string & bytevector ports)
Diffstat:
15 files changed, 169 insertions(+), 121 deletions(-)
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -39,11 +39,7 @@ void make_bytevector(klisp_State *K, TValue *xparams, TValue ptree,
maybe_byte);
uint8_t fill = 0;
- if (get_opt_tpar(K, "make-bytevector", K_TFIXINT, &maybe_byte)) {
- if (ivalue(maybe_byte) < 0 || ivalue(maybe_byte) > 255) {
- klispE_throw_simple(K, "bad fill byte");
- return;
- }
+ if (get_opt_tpar(K, maybe_byte, "u8", ttisu8)) {
fill = ivalue(maybe_byte);
}
diff --git a/src/kgc.c b/src/kgc.c
@@ -106,10 +106,11 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TAPPLICATIVE:
case K_TENCAPSULATION:
case K_TPROMISE:
- case K_TPORT:
case K_TTABLE:
case K_TERROR:
case K_TBYTEVECTOR:
+ case K_TFPORT:
+ case K_TMPORT:
o->gch.gclist = K->gray;
K->gray = o;
break;
@@ -301,11 +302,6 @@ static int32_t propagatemark (klisp_State *K) {
markvalue(K, p->node);
return sizeof(Promise);
}
- case K_TPORT: {
- Port *p = cast(Port *, o);
- markvalue(K, p->filename);
- return sizeof(Port);
- }
case K_TTABLE: {
Table *h = cast(Table *, o);
if (traversetable(K, h)) /* table is weak? */
@@ -326,6 +322,17 @@ static int32_t propagatemark (klisp_State *K) {
markvalue(K, b->mark);
return sizeof(Bytevector) + b->size * sizeof(uint8_t);
}
+ case K_TFPORT: {
+ FPort *p = cast(FPort *, o);
+ markvalue(K, p->filename);
+ return sizeof(FPort);
+ }
+ case K_TMPORT: {
+ MPort *p = cast(MPort *, o);
+ markvalue(K, p->filename);
+ markvalue(K, p->buf);
+ return sizeof(MPort);
+ }
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
type);
@@ -443,15 +450,6 @@ static void freeobj (klisp_State *K, GCObject *o) {
case K_TPROMISE:
klispM_free(K, (Promise *)o);
break;
- case K_TPORT:
- /* first close the port to free the FILE structure.
- This works even if the port was already closed,
- it is important that this don't throw errors, because
- the mechanism used in error handling would crash at this
- point */
- kclose_port(K, gc2port(o));
- klispM_free(K, (Port *)o);
- break;
case K_TTABLE:
klispH_free(K, (Table *)o);
break;
@@ -464,6 +462,20 @@ static void freeobj (klisp_State *K, GCObject *o) {
K->strt.nuse--;
klispM_freemem(K, o, sizeof(Bytevector)+o->bytevector.size);
break;
+ case K_TFPORT:
+ /* first close the port to free the FILE structure.
+ This works even if the port was already closed,
+ it is important that this don't throw errors, because
+ the mechanism used in error handling would crash at this
+ point */
+ kclose_port(K, gc2fport(o));
+ klispM_free(K, (FPort *)o);
+ break;
+ case K_TMPORT:
+ /* memory ports (string & bytevector) don't need to be closed
+ explicitly */
+ klispM_free(K, (MPort *)o);
+ break;
default:
/* shouldn't happen */
fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -199,7 +199,7 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
"any", anytype, obj,
maybe_env);
- TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
+ TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))?
maybe_env : kmake_empty_environment(K);
krooted_tvs_push(K, env);
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -64,7 +64,7 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
"applicative", ttisapplicative, app,
maybe_env);
- TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
+ TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))?
maybe_env : kmake_empty_environment(K);
krooted_tvs_push(K, env);
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -386,8 +386,8 @@ void ffi_load_library(klisp_State *K, TValue *xparams,
TValue filename = ptree;
const char *filename_c =
- get_opt_tpar(K, "ffi-load-library", K_TSTRING, &filename)
- ? kstring_buf(filename) : NULL;
+ get_opt_tpar(K, filename, "string", ttisstring)
+ ? kstring_buf(filename) : NULL;
#if KGFFI_DLFCN
void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL);
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -199,31 +199,26 @@
/* returns true if the obj pointed by par is a list of one element of
type type, and puts that element in par
- returns false if *par is nil
+ returns false if par is nil
In any other case it throws an error */
-inline bool get_opt_tpar(klisp_State *K, char *name, int32_t type, TValue *par)
-{
- if (ttisnil(*par)) {
- return false;
- } else if (ttispair(*par) && ttisnil(kcdr(*par))) {
- *par = kcar(*par);
- if (ttype(*par) != type) {
- /* TODO show expected type */
- klispE_throw_simple(K, "Bad type on optional argument "
- "(expected ?)");
- /* avoid warning */
- return false;
- } else {
- return true;
- }
- } else {
- klispE_throw_simple(K, "Bad ptree structure (in optional "
- "argument)");
- /* avoid warning */
- return false;
- }
-}
-
+#define get_opt_tpar(K_, par_, tstr_, t_) ({ \
+ bool res_; \
+ if (ttisnil(par_)) { \
+ res_ = false; \
+ } else if (!ttispair(par_) || !ttisnil(kcdr(par_))) { \
+ klispE_throw_simple((K_), \
+ "Bad ptree structure " \
+ "(in optional argument)"); \
+ return; \
+ } else if (!t_(kcar(par_))) { \
+ klispE_throw_simple(K_, "Bad type on optional argument " \
+ "(expected " tstr_ ")"); \
+ return; \
+ } else { \
+ par_ = kcar(par_); \
+ res_ = true; \
+ } \
+ res_; })
/*
** This states are useful for traversing trees, saving the state in the
diff --git a/src/kgports.c b/src/kgports.c
@@ -66,7 +66,7 @@ void with_file(klisp_State *K, TValue *xparams, TValue ptree,
bind_2tp(K, ptree, "string", ttisstring, filename,
"combiner", ttiscombiner, comb);
- TValue new_port = kmake_port(K, filename, writep, false);
+ TValue new_port = kmake_fport(K, filename, writep, false);
krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
TValue new_cont = kmake_continuation(K, kget_cc(K),
@@ -114,7 +114,7 @@ void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_1tp(K, ptree, "string", ttisstring, filename);
- TValue new_port = kmake_port(K, filename, writep, binaryp);
+ TValue new_port = kmake_fport(K, filename, writep, binaryp);
kapply_cc(K, new_port);
}
@@ -165,7 +165,7 @@ void read(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "read", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
}
@@ -194,7 +194,7 @@ void write(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1tp(K, ptree, "any", anytype, obj,
port);
- if (!get_opt_tpar(K, "write", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
}
@@ -224,7 +224,7 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "newline", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
}
@@ -252,7 +252,7 @@ void write_char(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1tp(K, ptree, "char", ttischar, ch,
port);
- if (!get_opt_tpar(K, "write-char", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
}
@@ -276,16 +276,14 @@ void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
/*
- ** xparams[0]: symbol name
- ** xparams[1]: ret-char-after-readp
+ ** xparams[0]: ret-char-after-readp
*/
UNUSED(denv);
- char *name = ksymbol_buf(xparams[0]);
- bool ret_charp = bvalue(xparams[1]);
+ bool ret_charp = bvalue(xparams[0]);
TValue port = ptree;
- if (!get_opt_tpar(K, name, K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
}
@@ -322,7 +320,7 @@ void char_readyp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "char-ready?", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
}
@@ -349,7 +347,7 @@ void write_u8(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1tp(K, ptree, "u8", ttisu8, u8, port);
- if (!get_opt_tpar(K, "write-u8", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
}
@@ -373,16 +371,14 @@ void read_peek_u8(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
/*
- ** xparams[0]: symbol name
- ** xparams[1]: ret-u8-after-readp
+ ** xparams[0]: ret-u8-after-readp
*/
UNUSED(denv);
- char *name = ksymbol_buf(xparams[0]);
- bool ret_u8p = bvalue(xparams[1]);
+ bool ret_u8p = bvalue(xparams[0]);
TValue port = ptree;
- if (!get_opt_tpar(K, name, K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
}
@@ -419,7 +415,7 @@ void u8_readyp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "u8-ready?", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
}
@@ -452,7 +448,7 @@ void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
bind_2tp(K, ptree, "string", ttisstring, filename,
"combiner", ttiscombiner, comb);
- TValue new_port = kmake_port(K, filename, writep, false);
+ TValue new_port = kmake_fport(K, filename, writep, false);
krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
TValue new_cont = kmake_continuation(K, kget_cc(K),
@@ -570,7 +566,7 @@ void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* the reads must be guarded to close the file if there is some error
this continuation also will return inert after the evaluation of the
last expression is done */
- TValue port = kmake_port(K, filename, false, false);
+ TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
TValue inert_cont = make_return_value_cont(K, kget_cc(K), KINERT);
@@ -619,13 +615,13 @@ void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1tp(K, ptree, "string", ttisstring, filename,
maybe_env);
- TValue port = kmake_port(K, filename, false, false);
+ TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
TValue env = kmake_environment(K, K->ground_env);
krooted_tvs_push(K, env);
- if (get_opt_tpar(K, "", K_TENVIRONMENT, &maybe_env)) {
+ if (get_opt_tpar(K, maybe_env, "environment", ttisenvironment)) {
kadd_binding(K, env, K->module_params_sym, maybe_env);
}
@@ -677,7 +673,7 @@ void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1tp(K, ptree, "any", anytype, obj,
port);
- if (!get_opt_tpar(K, "display", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
}
@@ -705,19 +701,23 @@ void flush(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue port = ptree;
- if (!get_opt_tpar(K, "flush-output-port", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
- } else if (!kport_is_output(port)) {
+ }
+
+ if (!kport_is_output(port)) {
klispE_throw_simple(K, "the port should be an output port");
return;
}
+
if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
- FILE *file = kport_file(port);
- if (file) { /* only do for file ports */
+ if (ttisfport(port)) { /* only necessary for file ports */
+ FILE *file = kport_file(port);
+ klisp_assert(file);
UNUSED(fflush(file)); /* TEMP for now don't signal errors on flush */
}
kapply_cc(K, KINERT);
@@ -792,8 +792,8 @@ void kinit_ports_ground_env(klisp_State *K)
TValue symbol, value;
/* 15.1.1 port? */
- add_applicative(K, ground_env, "port?", typep, 2, symbol,
- i2tv(K_TPORT));
+ add_applicative(K, ground_env, "port?", ftypep, 2, symbol,
+ p2tv(kis_port));
/* 15.1.2 input-port?, output-port? */
add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
p2tv(kis_input_port));
@@ -864,10 +864,10 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.? write-char */
add_applicative(K, ground_env, "write-char", write_char, 0);
/* 15.1.? read-char */
- add_applicative(K, ground_env, "read-char", read_peek_char, 2, symbol,
+ add_applicative(K, ground_env, "read-char", read_peek_char, 1,
b2tv(false));
/* 15.1.? peek-char */
- add_applicative(K, ground_env, "peek-char", read_peek_char, 2, symbol,
+ add_applicative(K, ground_env, "peek-char", read_peek_char, 1,
b2tv(true));
/* 15.1.? char-ready? */
/* XXX: this always return #t, proper behaviour requires platform
@@ -878,10 +878,10 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.? write-u8 */
add_applicative(K, ground_env, "write-u8", write_u8, 0);
/* 15.1.? read-u8 */
- add_applicative(K, ground_env, "read-u8", read_peek_u8, 2, symbol,
+ add_applicative(K, ground_env, "read-u8", read_peek_u8, 1,
b2tv(false));
/* 15.1.? peek-u8 */
- add_applicative(K, ground_env, "peek-u8", read_peek_u8, 2, symbol,
+ add_applicative(K, ground_env, "peek-u8", read_peek_u8, 1,
b2tv(true));
/* 15.1.? u8-ready? */
/* XXX: this always return #t, proper behaviour requires platform
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -41,7 +41,7 @@ void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
maybe_char);
char fill = ' ';
- if (get_opt_tpar(K, "make-string", K_TCHAR, &maybe_char))
+ if (get_opt_tpar(K, maybe_char, "char", ttischar))
fill = chvalue(maybe_char);
if (knegativep(tv_s)) {
diff --git a/src/kobject.c b/src/kobject.c
@@ -67,12 +67,18 @@ char *ktv_names[] = {
[K_TAPPLICATIVE] = "applicative",
[K_TENCAPSULATION] = "encapsulation",
[K_TPROMISE] = "promise",
- [K_TPORT] = "port",
[K_TTABLE] = "table",
[K_TERROR] = "error",
- [K_TBYTEVECTOR] = "bytevector"
+ [K_TBYTEVECTOR] = "bytevector",
+ [K_TFPORT] = "file port",
+ [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);
diff --git a/src/kobject.h b/src/kobject.h
@@ -46,7 +46,7 @@ typedef union GCObject GCObject;
** included in other objects)
*/
#define CommonHeader GCObject *next; uint8_t tt; uint8_t kflags; \
- uint16_t gct; GCObject *si; GCObject *gclist;
+ uint16_t gct; GCObject *si; GCObject *gclist
/* NOTE: the gc flags are called marked in lua, but we reserve that them
for marks used in cycle traversal. The field kflags is also missing
@@ -162,10 +162,11 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAPPLICATIVE 36
#define K_TENCAPSULATION 37
#define K_TPROMISE 38
-#define K_TPORT 39
-#define K_TTABLE 40
-#define K_TERROR 41
-#define K_TBYTEVECTOR 42
+#define K_TTABLE 39
+#define K_TERROR 40
+#define K_TBYTEVECTOR 41
+#define K_TFPORT 42
+#define K_TMPORT 43
/* for tables */
#define K_TDEADKEY 60
@@ -215,10 +216,11 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_APPLICATIVE K_MAKE_VTAG(K_TAPPLICATIVE)
#define K_TAG_ENCAPSULATION K_MAKE_VTAG(K_TENCAPSULATION)
#define K_TAG_PROMISE K_MAKE_VTAG(K_TPROMISE)
-#define K_TAG_PORT K_MAKE_VTAG(K_TPORT)
#define K_TAG_TABLE K_MAKE_VTAG(K_TTABLE)
#define K_TAG_ERROR K_MAKE_VTAG(K_TERROR)
#define K_TAG_BYTEVECTOR K_MAKE_VTAG(K_TBYTEVECTOR)
+#define K_TAG_FPORT K_MAKE_VTAG(K_TFPORT)
+#define K_TAG_MPORT K_MAKE_VTAG(K_TMPORT)
/*
@@ -300,10 +302,13 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttiscontinuation(o) (tbasetype_(o) == K_TAG_CONTINUATION)
#define ttisencapsulation(o) (tbasetype_(o) == K_TAG_ENCAPSULATION)
#define ttispromise(o) (tbasetype_(o) == K_TAG_PROMISE)
-#define ttisport(o) (tbasetype_(o) == K_TAG_PORT)
#define ttistable(o) (tbasetype_(o) == K_TAG_TABLE)
#define ttiserror(o) (tbasetype_(o) == K_TAG_ERROR)
#define ttisbytevector(o) (tbasetype_(o) == K_TAG_BYTEVECTOR)
+#define ttisfport(o) (tbasetype_(o) == K_TAG_FPORT)
+#define ttismport(o) (tbasetype_(o) == K_TAG_MPORT)
+#define ttisport(o_) ({ int32_t t_ = tbasetype_(o_); \
+ t_ == K_TAG_FPORT || t_ == K_TAG_MPORT;})
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -437,17 +442,30 @@ typedef struct __attribute__ ((__packed__)) {
sharing the pair */
} Promise;
+/* common fields for all types of ports */
+/* TEMP: for now source code info is in fixints */
+#define PortCommonFields TValue filename; int32_t row; int32_t col
+
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ PortCommonFields;
+} Port;
+
/* input/output direction and open/close status are in kflags */
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue filename;
- /* TEMP: for now source code info is in fixints */
- int32_t row;
- int32_t col;
+ PortCommonFields;
FILE *file;
-} Port;
+} FPort;
/* input/output direction and open/close status are in kflags */
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ PortCommonFields;
+ TValue buf;
+ int32_t off;
+} MPort;
+
/*
** Hashtables
@@ -553,9 +571,11 @@ union GCObject {
Applicative app;
Encapsulation enc;
Promise prom;
- Port port;
Table table;
Bytevector bytevector;
+ Port port; /* common fields for all types of ports */
+ FPort fport;
+ MPort mport;
};
@@ -654,7 +674,8 @@ const TValue kfree;
#define gc2app(o_) (gc2tv(K_TAG_APPLICATIVE, o_))
#define gc2enc(o_) (gc2tv(K_TAG_ENCAPSULATION, o_))
#define gc2prom(o_) (gc2tv(K_TAG_PROMISE, o_))
-#define gc2port(o_) (gc2tv(K_TAG_PORT, o_))
+#define gc2fport(o_) (gc2tv(K_TAG_FPORT, o_))
+#define gc2mport(o_) (gc2tv(K_TAG_MPORT, o_))
#define gc2table(o_) (gc2tv(K_TAG_TABLE, o_))
#define gc2error(o_) (gc2tv(K_TAG_ERROR, o_))
#define gc2bytevector(o_) (gc2tv(K_TAG_BYTEVECTOR, o_))
@@ -672,10 +693,12 @@ const TValue kfree;
#define tv2app(v_) ((Applicative *) gcvalue(v_))
#define tv2enc(v_) ((Encapsulation *) gcvalue(v_))
#define tv2prom(v_) ((Promise *) gcvalue(v_))
-#define tv2port(v_) ((Port *) gcvalue(v_))
#define tv2table(v_) ((Table *) gcvalue(v_))
#define tv2error(v_) ((Error *) gcvalue(v_))
#define tv2bytevector(v_) ((Bytevector *) gcvalue(v_))
+#define tv2fport(v_) ((FPort *) gcvalue(v_))
+#define tv2mport(v_) ((MPort *) gcvalue(v_))
+#define tv2port(v_) ((Port *) gcvalue(v_))
#define tv2gch(v_) ((GCheader *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
@@ -821,6 +844,8 @@ int32_t kmark_count;
/* 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);
diff --git a/src/kport.c b/src/kport.c
@@ -23,7 +23,7 @@
Should use open, but it is non standard (fcntl.h, POSIX only) */
/* GC: Assumes filename is rooted */
-TValue kmake_port(klisp_State *K, TValue filename, bool writep, bool binaryp)
+TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp)
{
/* for now always use text mode */
char *mode;
@@ -38,7 +38,7 @@ TValue kmake_port(klisp_State *K, TValue filename, bool writep, bool binaryp)
kstring_new_b_imm(K, mode));
return KINERT;
} else {
- return kmake_std_port(K, filename, writep, binaryp, f);
+ return kmake_std_fport(K, filename, writep, binaryp, f);
}
}
@@ -46,13 +46,13 @@ TValue kmake_port(klisp_State *K, TValue filename, bool writep, bool binaryp)
also a helper for the above */
/* GC: Assumes filename, name & si are rooted */
-TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
+TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
bool binaryp, FILE *file)
{
- Port *new_port = klispM_new(K, Port);
+ FPort *new_port = klispM_new(K, FPort);
/* header + gc_fields */
- klispC_link(K, (GCObject *) new_port, K_TPORT,
+ klispC_link(K, (GCObject *) new_port, K_TFPORT,
K_FLAG_CAN_HAVE_NAME |
(writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
(binaryp? K_FLAG_BINARY_PORT : 0));
@@ -60,7 +60,7 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
/* port specific fields */
new_port->filename = filename;
new_port->file = file;
- TValue tv_port = gc2port(new_port);
+ TValue tv_port = gc2fport(new_port);
/* line is 1-based and col is 0-based */
kport_line(tv_port) = 1;
kport_col(tv_port) = 0;
@@ -69,15 +69,17 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
}
/* 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)
{
assert(ttisport(port));
if (!kport_is_closed(port)) {
- FILE *f = tv2port(port)->file;
- if (f != stdin && f != stderr && f != stdout)
- fclose(f); /* it isn't necessary to check the close ret val */
-
+ if (ttisfport(port)) {
+ FILE *f = tv2fport(port)->file;
+ if (f != stdin && f != stderr && f != stdout)
+ fclose(f); /* it isn't necessary to check the close ret val */
+ }
kport_set_closed(port);
}
diff --git a/src/kport.h b/src/kport.h
@@ -13,13 +13,13 @@
#include "kstate.h"
/* GC: Assumes filename is rooted */
-TValue kmake_port(klisp_State *K, TValue filename, bool writep, bool binaryp);
+TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp);
/* this is for creating ports for stdin/stdout/stderr &
helper for the one above */
/* GC: Assumes filename, name & si are rooted */
-TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
- bool binaryp, FILE *file);
+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
@@ -27,11 +27,12 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
fork this function instead of simply modifying */
void kclose_port(klisp_State *K, TValue port);
-#define kport_file(p_) (tv2port(p_)->file)
#define kport_filename(p_) (tv2port(p_)->filename)
#define kport_line(p_) (tv2port(p_)->row)
#define kport_col(p_) (tv2port(p_)->col)
+#define kport_file(p_) (tv2fport(p_)->file)
+
void kport_reset_source_info(TValue port);
void kport_update_source_info(TValue port, int32_t line, int32_t col);
diff --git a/src/kstate.c b/src/kstate.c
@@ -201,11 +201,11 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->sbuf = (TValue *)s;
/* the dynamic ports and the keys for the dynamic ports */
- TValue in_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDIN*"),
+ TValue in_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDIN*"),
false, false, stdin);
- TValue out_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDOUT*"),
+ TValue out_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDOUT*"),
true, false, stdout);
- TValue error_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDERR*"),
+ TValue error_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDERR*"),
true, false, stderr);
K->kd_in_port_key = kcons(K, KTRUE, in_port);
K->kd_out_port_key = kcons(K, KTRUE, out_port);
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -421,9 +421,9 @@ void kwrite_simple(klisp_State *K, TValue obj)
/* TODO try to get the name */
kw_printf(K, "#[promise]");
break;
- case K_TPORT:
+ case K_TFPORT:
/* TODO try to get the filename */
- kw_printf(K, "#[%s %s port",
+ kw_printf(K, "#[%s %s file port",
kport_is_binary(obj)? "binary" : "textual",
kport_is_input(obj)? "input" : "output");
#if KTRACK_NAMES
@@ -433,6 +433,17 @@ void kwrite_simple(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
+ case K_TMPORT:
+ kw_printf(K, "#[%s %s port",
+ kport_is_binary(obj)? "bytevector" : "string",
+ kport_is_input(obj)? "input" : "output");
+ #if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+ #endif
+ kw_printf(K, "]");
+ break;
case K_TERROR: {
kw_printf(K, "#[error: ");
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -1,9 +1,9 @@
(load "tests/check.k")
(load "tests/test-helpers.k")
-;(check-set-mode! check-mode-report)
+;; (check-set-mode! check-mode-report)
-;; TODO add applicative?/operative? check in pairs and lists and pair-mutation
+;; TODO add applicative?/operative? for all cominers in all test files
(load "tests/booleans.k")
(load "tests/eq-equal.k")
