klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/kgbytevectors.c | 6+-----
Msrc/kgc.c | 42+++++++++++++++++++++++++++---------------
Msrc/kgcombiners.c | 2+-
Msrc/kgcontinuations.c | 2+-
Msrc/kgffi.c | 4++--
Msrc/kghelpers.h | 43+++++++++++++++++++------------------------
Msrc/kgports.c | 68++++++++++++++++++++++++++++++++++----------------------------------
Msrc/kgstrings.c | 2+-
Msrc/kobject.c | 10++++++++--
Msrc/kobject.h | 55++++++++++++++++++++++++++++++++++++++++---------------
Msrc/kport.c | 22++++++++++++----------
Msrc/kport.h | 9+++++----
Msrc/kstate.c | 6+++---
Msrc/kwrite.c | 15+++++++++++++--
Msrc/tests/test-all.k | 4++--
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")