only using our own buffering for string ports

Makefile

@@ -24,7 +24,8 @@ SO  = .dylib
 EXE =
 CLIBFLAGS = -dynamiclib
 STATICFLAGS = -static-libgcc
-else ifeq ($(PLATFORM),mingw)
+else
+ifeq ($(PLATFORM),mingw)
 SO  = .dll
 EXE = .exe
 CLIBFLAGS = -fPIC -shared
@@ -34,6 +35,7 @@ EXE =
 CLIBFLAGS = -fPIC -shared
 STATICFLAGS = -static
 endif
+endif
 
 ifdef USE_BOEHM
 GCLDFLAGS := -lgc
@@ -90,6 +92,7 @@ test: chibi-scheme
 	./chibi-scheme tests/r5rs-tests.scm
 
 install: chibi-scheme
+	mkdir -p $(BINDIR)
 	cp chibi-scheme $(BINDIR)/
 	mkdir -p $(MODDIR)
 	cp init.scm $(MODDIR)/

debug.c

@@ -28,9 +28,9 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
  loop:
   opcode = *ip++;
   if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
-    sexp_printf(out, "  %s ", reverse_opcode_names[opcode]);
+    sexp_printf(ctx, out, "  %s ", reverse_opcode_names[opcode]);
   } else {
-    sexp_printf(out, "  <unknown> %d ", opcode);
+    sexp_printf(ctx, out, "  <unknown> %d ", opcode);
   }
   switch (opcode) {
   case OP_STACK_REF:
@@ -44,7 +44,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
   case OP_FCALL2:
   case OP_FCALL3:
   case OP_TYPEP:
-    sexp_printf(out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
+    sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
     ip += sizeof(sexp);
     break;
   case OP_GLOBAL_REF:
@@ -52,11 +52,11 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
   case OP_TAIL_CALL:
   case OP_CALL:
   case OP_PUSH:
-    sexp_write(((sexp*)ip)[0], out);
+    sexp_write(ctx, ((sexp*)ip)[0], out);
     ip += sizeof(sexp);
     break;
   }
-  sexp_write_char('\n', out);
+  sexp_write_char(ctx, '\n', out);
   if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
     goto loop;
   return SEXP_VOID;
@@ -66,9 +66,9 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
 static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) {
   int i;
   for (i=0; i<top; i++) {
-    sexp_printf(out, "%s %02d: ", ((i==fp) ? "*" : " "), i);
-    sexp_write(stack[i], out);
-    sexp_printf(out, "\n");
+    sexp_printf(ctx, out, "%s %02d: ", ((i==fp) ? "*" : " "), i);
+    sexp_write(ctx, stack[i], out);
+    sexp_printf(ctx, out, "\n");
   }
 }
 #endif

eval.c

@@ -719,12 +719,12 @@ static sexp analyze (sexp ctx, sexp object) {
           x = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
           sexp_context_env(x) = sexp_macro_env(op);
           x = sexp_apply(x, sexp_macro_proc(op), tmp);
-          /* goto loop; */
+          goto loop;
           /* XXXX need to handle free vars, simplify */
-          tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
-          sexp_context_env(tmp)
-            = sexp_chain_env(ctx, sexp_macro_env(op), sexp_context_env(tmp));
-          res = analyze(tmp, x);
+/*           tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); */
+/*           sexp_context_env(tmp) */
+/*             = sexp_chain_env(ctx, sexp_macro_env(op), sexp_context_env(tmp)); */
+/*           res = analyze(tmp, x); */
         } else if (sexp_opcodep(op)) {
           res = sexp_length(ctx, sexp_cdr(x));
           if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) {
@@ -1770,16 +1770,16 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     top--;
     break;
   case OP_WRITE_CHAR:
-    sexp_write_char(sexp_unbox_character(_ARG1), _ARG2);
+    sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
     _ARG2 = SEXP_VOID;
     top--;
     break;
   case OP_NEWLINE:
-    sexp_write_char(ctx, '\n', _ARG1);
+    sexp_newline(ctx, _ARG1);
     _ARG1 = SEXP_VOID;
     break;
   case OP_FLUSH_OUTPUT:
-    sexp_flush(_ARG1);
+    sexp_flush(ctx, _ARG1);
     _ARG1 = SEXP_VOID;
     break;
   case OP_READ:
@@ -1859,10 +1859,11 @@ static sexp sexp_close_port (sexp ctx, sexp port) {
     free(sexp_port_buf(port));
   if (sexp_port_stream(port))
     fclose(sexp_port_stream(port));
+  sexp_port_openp(port) = 0;
   return SEXP_VOID;
 }
 
-void sexp_warn_undefs (sexp from, sexp to, sexp out) {
+void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) {
   sexp x;
   for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x))
     if (sexp_cdar(x) == SEXP_UNDEF) {
@@ -1903,7 +1904,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
     sexp_close_port(ctx, in);
 #if USE_WARN_UNDEFS
     if (sexp_oportp(out))
-      sexp_warn_undefs(sexp_env_bindings(env), tmp, out);
+      sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out);
 #endif
   }
   sexp_gc_release(ctx, ctx2, s_ctx2);
@@ -2140,7 +2141,6 @@ sexp sexp_eval (sexp ctx, sexp obj) {
   return res;
 }
 
-#if USE_STRING_STREAMS
 sexp sexp_eval_string (sexp ctx, char *str) {
   sexp res;
   sexp_gc_var(ctx, obj, s_obj);
@@ -2150,7 +2150,6 @@ sexp sexp_eval_string (sexp ctx, char *str) {
   sexp_gc_release(ctx, obj, s_obj);
   return res;
 }
-#endif
 
 void sexp_scheme_init () {
   sexp ctx;

include/chibi/eval.h

@@ -134,7 +134,7 @@ sexp sexp_eval(sexp context, sexp obj);
 sexp sexp_eval_string(sexp context, char *str);
 sexp sexp_load(sexp context, sexp expr, sexp env);
 sexp sexp_make_context(sexp context, sexp stack, sexp env);
-void sexp_warn_undefs (sexp from, sexp to, sexp out);
+void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out);
 
 #endif /* ! SEXP_EVAL_H */
 

include/chibi/sexp.h

@@ -128,8 +128,7 @@ struct sexp_struct {
     struct {
       FILE *stream;
       char *buf;
-      sexp_uint_t offset, line, openp;
-      size_t size;
+      sexp_uint_t offset, line, size, openp;
       sexp name;
       sexp cookie;
     } port;
@@ -329,6 +328,8 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_idp(x) \
   (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x))))
 
+#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x))
+
 /***************************** constructors ****************************/
 
 #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
@@ -527,21 +528,21 @@ sexp sexp_make_flonum(sexp ctx, double f);
 
 #else
 
-#define sexp_read_char(x, p) ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p))
-#define sexp_push_char(x, c, p) (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c)))
-#define sexp_write_char(x, c, p) ((sexp_port_offset(p) < sexp_port_size(p)) ? (((sexp_port_buf(p))[sexp_port_offset(p)++]) = ((char)(c))) : sexp_buffered_write_char(x, c, p))
-#define sexp_write_string(x, s, p) sexp_buffered_write_string(x, s, p)
-#define sexp_flush(x, p) sexp_buffered_flush(x, p)
+#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p)))
+#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p)))
+#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID))
+#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID))
+#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID))
 
 int sexp_buffered_read_char (sexp ctx, sexp p);
 sexp sexp_buffered_write_char (sexp ctx, int c, sexp p);
-sexp sexp_buffered_write_string_n (sexp ctx, char *str, int len, sexp p);
+sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p);
 sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p);
 sexp sexp_buffered_flush (sexp ctx, sexp p);
 
 #endif
 
-#define sexp_newline(p) sexp_write_char('\n', (p))
+#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p))
 
 sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
 sexp sexp_cons(sexp ctx, sexp head, sexp tail);
@@ -562,7 +563,6 @@ sexp sexp_intern(sexp ctx, char *str);
 sexp sexp_string_to_symbol(sexp ctx, sexp str);
 sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
 sexp sexp_list_to_vector(sexp ctx, sexp ls);
-/* sexp sexp_vector(sexp ctx, int count, ...); */
 void sexp_write(sexp ctx, sexp obj, sexp out);
 sexp sexp_read_string(sexp ctx, sexp in);
 sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp);

main.c

@@ -54,7 +54,7 @@ void repl (sexp ctx) {
   err = sexp_eval_string(ctx, "(current-error-port)");
   while (1) {
     sexp_write_string(ctx, "> ", out);
-    sexp_flush(out);
+    sexp_flush(ctx, out);
     obj = sexp_read(ctx, in);
     if (obj == SEXP_EOF)
       break;
@@ -65,7 +65,7 @@ void repl (sexp ctx) {
       sexp_context_top(ctx) = 0;
       res = sexp_eval(ctx, obj);
 #if USE_WARN_UNDEFS
-      sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
+      sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err);
 #endif
       if (res != SEXP_VOID) {
         sexp_write(ctx, res, out);
@@ -89,7 +89,6 @@ void run_main (int argc, char **argv) {
   /* parse options */
   for (i=1; i < argc && argv[i][0] == '-'; i++) {
     switch (argv[i][1]) {
-#if USE_STRING_STREAMS
     case 'e':
     case 'p':
       if (! init_loaded++)
@@ -106,7 +105,6 @@ void run_main (int argc, char **argv) {
       quit=1;
       i++;
       break;
-#endif
     case 'l':
       if (! init_loaded++)
         sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env);

opcodes.c

@@ -119,11 +119,9 @@ _FN1(0, "floor", 0, sexp_floor),
 _FN1(0, "ceiling", 0, sexp_ceiling),
 _FN2(0, 0, "expt", 0, sexp_expt),
 #endif
-#if USE_STRING_STREAMS
 _FN0("open-output-string", 0, sexp_make_output_string_port),
 _FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port),
 _FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string),
-#endif
 #if USE_DEBUG
 _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm),
 #endif

sexp.c

@@ -594,9 +594,11 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) {
   sexp res;
   sexp_gc_var(ctx, cookie, s_cookie);
   sexp_gc_preserve(ctx, cookie, s_cookie);
-  cookie = sexp_vector(ctx, 4, ctx, str,
-                       sexp_make_integer(sexp_string_length(str)),
-                       sexp_make_integer(0));
+  cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID);
+  sexp_stream_ctx(cookie) = ctx;
+  sexp_stream_buf(cookie) = str;
+  sexp_stream_size(cookie) = sexp_make_integer(sexp_string_length(str));
+  sexp_stream_pos(cookie) = sexp_make_integer(0);
   in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
   res = sexp_make_input_port(ctx, in, SEXP_FALSE);
   sexp_port_cookie(res) = cookie;
@@ -610,8 +612,11 @@ sexp sexp_make_output_string_port (sexp ctx) {
   sexp_gc_var(ctx, cookie, s_cookie);
   sexp_gc_preserve(ctx, cookie, s_cookie);
   size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE);
-  cookie = sexp_vector(ctx, 4, ctx, sexp_make_string(ctx, size, SEXP_VOID),
-                       size, sexp_make_integer(0));
+  cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID);
+  sexp_stream_ctx(cookie) = ctx;
+  sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID);
+  sexp_stream_size(cookie) = size;
+  sexp_stream_pos(cookie) = sexp_make_integer(0);
   out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
   res = sexp_make_output_port(ctx, out, SEXP_FALSE);
   sexp_port_cookie(res) = cookie;
@@ -672,7 +677,7 @@ int sexp_buffered_read_char (sexp ctx, sexp p) {
 sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) {
   if (sexp_port_offset(p) >= sexp_port_size(p))
     sexp_buffered_flush(ctx, p);
-  sexp_port_buf(p)[sexp_port_offset(p)++] = (c);
+  sexp_port_buf(p)[sexp_port_offset(p)++] = c;
   return SEXP_VOID;
 }
 
@@ -685,29 +690,29 @@ sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p)
 }
 
 sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) {
-  return sexp_buffered_write_string_n(str, strlen(str), p);
+  return sexp_buffered_write_string_n(ctx, str, strlen(str), p);
 }
 
 sexp sexp_buffered_flush (sexp ctx, sexp p) {
   sexp_gc_var(ctx, tmp, s_tmp);
-  sexp_gc_preserve(ctx, tmp, s_tmp);
-/*   if (! sexp_oportp(p)) */
-/*     return sexp_type_exception(); */
-/*   else if (! sexp_port_openp(p)) */
-/*     return sexp_make_exception(); */
-/*   else { */
+  if (! sexp_oportp(p))
+    return sexp_type_exception(ctx, "not an output-port", p);
+  else if (! sexp_port_openp(p))
+    return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p);
+  else {
     if (sexp_port_stream(p)) {
       fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p));
       sexp_port_offset(p) = 0;
       fflush(sexp_port_stream(p));
     } else if (sexp_port_offset(p) > 0) {
+      sexp_gc_preserve(ctx, tmp, s_tmp);
       tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p));
       sexp_push(ctx, sexp_port_cookie(p), tmp);
       sexp_port_offset(p) = 0;
-  }
       sexp_gc_release(ctx, tmp, s_tmp);
+    }
     return SEXP_VOID;
-/*   } */
+  }
 }
 
 sexp sexp_make_input_string_port (sexp ctx, sexp str) {
@@ -751,17 +756,15 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
   sexp_port_stream(p) = in;
   sexp_port_name(p) = name;
   sexp_port_line(p) = 0;
+  sexp_port_buf(p) = NULL;
   sexp_port_openp(p) = 1;
+  sexp_port_cookie(p) = SEXP_VOID;
   return p;
 }
 
 sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
-  sexp p = sexp_alloc_type(ctx, port, SEXP_OPORT);
-  sexp_port_stream(p) = out;
-  sexp_port_name(p) = name;
-  sexp_port_line(p) = 0;
-  sexp_port_buf(p) = NULL;
-  sexp_port_openp(p) = 1;
+  sexp p = sexp_make_input_port(ctx, out, name);
+  sexp_pointer_tag(p) = SEXP_OPORT;
   return p;
 }