initial variadic i/o routines

debug.c

@@ -5,13 +5,16 @@
 static const char* reverse_opcode_names[] =
   {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1",
    "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN",
-   "JUMP_UNLESS", "JUMP", "RET", "DONE", "PARAMETER",
+   "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER",
-   "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF",
+   "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF",
-   "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE",
+   "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE",
-   "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP",
+   "MAKE-VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP",
    "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP",
-   "OPORTP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL",
+   "OPORTP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL",
-   "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ",};
+   "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ",
+   "DISPLAY", "WRITE", "WRITE-CHAR", "NEWLINE", "FLUSH-OUTPUT", "READ",
+   "READ-CHAR",
+  };
 
 void disasm (bytecode bc) {
   unsigned char *ip=bc->data, opcode;

eval.c

@@ -228,6 +228,19 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
             (*d) -= sexp_length(SEXP_CDDR(obj));
           }
           break;
+        case OPC_IO:
+          tmp1 = sexp_length(SEXP_CDR(obj));
+          if (tmp1 == ((opcode)o1)->num_args && ((opcode)o1)->var_args_p) {
+            emit(bc, i, OP_PARAMETER);
+            emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data);
+            (*d)++;
+          }
+          for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2);
+               o2 = SEXP_CDR(o2))
+            analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d);
+          emit(bc, i, ((opcode)o1)->op_name);
+          (*d) -= (tmp1-1);
+          break;
         case OPC_PARAMETER:
           emit(bc, i, ((opcode)o1)->op_name);
           emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data);
@@ -732,6 +745,35 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
     fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]);
     ip += ((signed char*)ip)[0];
     break;
+  case OP_DISPLAY:
+    if (SEXP_STRINGP(stack[top-1])) {
+      sexp_write_string(sexp_string_data(stack[top-1]), stack[top-2]);
+      break;
+    }
+  case OP_WRITE:
+    sexp_write(stack[top-1], stack[top-2]);
+    stack[top-2] = SEXP_UNDEF;
+    top--;
+    break;
+  case OP_WRITE_CHAR:
+    sexp_write_char(sexp_unbox_character(stack[top-1]), stack[top-2]);
+    break;
+  case OP_NEWLINE:
+    sexp_write_char('\n', stack[top-1]);
+    stack[top-1] = SEXP_UNDEF;
+    break;
+  case OP_FLUSH_OUTPUT:
+    sexp_flush(stack[top-1]);
+    stack[top-1] = SEXP_UNDEF;
+    break;
+  case OP_READ:
+    stack[top-1] = sexp_read(stack[top-1]);
+    if (stack[top-1] == SEXP_ERROR) sexp_raise(sexp_intern("read-error"));
+    break;
+  case OP_READ_CHAR:
+    i = sexp_read_char(stack[top-1]);
+    stack[top-1] = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
+    break;
   case OP_RET:
     fprintf(stderr, "returning @ %d: ", top-1);
     fflush(stderr);
@@ -819,6 +861,13 @@ _OP(OPC_TYPE_PREDICATE, OP_EOFP,  1, 0, 0, 0, 0, "eof-object?"),
 _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1"),
 _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"),
 _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"),
+{SEXP_OPCODE, OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL},
+{SEXP_OPCODE, OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL},
+{SEXP_OPCODE, OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL},
+{SEXP_OPCODE, OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL},
+{SEXP_OPCODE, OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL},
+{SEXP_OPCODE, OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL},
+{SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL},
 _FN1(SEXP_PAIR, "reverse", sexp_reverse),
 _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
 _FN2(0, SEXP_PAIR, "memq", sexp_memq),

eval.h

@@ -74,6 +74,7 @@ enum opcode_classes {
   OPC_ARITHMETIC,
   OPC_ARITHMETIC_INV,
   OPC_ARITHMETIC_CMP,
+  OPC_IO,
   OPC_CONSTRUCTOR,
   OPC_ACCESSOR,
   OPC_PARAMETER,
@@ -145,6 +146,13 @@ enum opcode_names {
   OP_GE,
   OP_EQN,
   OP_EQ,
+  OP_DISPLAY,
+  OP_WRITE,
+  OP_WRITE_CHAR,
+  OP_NEWLINE,
+  OP_FLUSH_OUTPUT,
+  OP_READ,
+  OP_READ_CHAR,
 };
 
 /**************************** prototypes ******************************/