adding i/o port parameters

config.h

@@ -2,8 +2,19 @@
 /*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt  */
 
+#ifndef USE_BOEHM
 #define USE_BOEHM 1
-#define USE_HUFF_SYMS 1
+#endif
-#define USE_DEBUG 1
+
-#define USE_STRING_STREAMS 1
+#ifndef USE_HUFF_SYMS
+#define USE_HUFF_SYMS 1
+#endif
+
+#ifndef USE_DEBUG
+#define USE_DEBUG 1
+#endif
+
+#ifndef USE_STRING_STREAMS
+#define USE_STRING_STREAMS 1
+#endif
 

debug.c

@@ -5,7 +5,7 @@
 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",
+   "JUMP_UNLESS", "JUMP", "RET", "DONE", "PARAMETER",
    "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF",
    "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE",
    "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP",
@@ -26,6 +26,7 @@ void disasm (bytecode bc) {
   case OP_STACK_REF:
   case OP_STACK_SET:
   case OP_CLOSURE_REF:
+  case OP_PARAMETER:
     fprintf(stderr, "%d", (long) ((sexp*)ip)[0]);
     ip += sizeof(sexp);
     break;

eval.c

@@ -12,7 +12,7 @@ static sexp cur_input_port, cur_output_port, cur_error_port;
 static sexp exception_handler_cell;
 static sexp continuation_resumer;
 
-#ifdef USE_DEBUG
+#if USE_DEBUG
 #include "debug.c"
 #else
 #define print_stack(...)
@@ -228,6 +228,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
             (*d) -= sexp_length(SEXP_CDDR(obj));
           }
           break;
+        case OPC_PARAMETER:
+          emit(bc, i, ((opcode)o1)->op_name);
+          emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data);
+          break;
         case OPC_FOREIGN:
           for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2);
                o2 = SEXP_CDR(o2)) {
@@ -454,35 +458,20 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
   int i;
 
  loop:
-  /* fprintf(stderr, "opcode: %s (%d), ip: %d\n", reverse_opcode_names[*ip], *ip, ip); */
-  /* print_bytecode(bc); */
   switch (*ip++) {
   case OP_NOOP:
     fprintf(stderr, "noop\n");
     break;
   case OP_GLOBAL_REF:
-/*     fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */
-/*     fflush(stderr); */
-/*     sexp_write(stderr, ((sexp*)ip)[0]); */
-/*     fprintf(stderr, "\n"); */
     tmp1 = env_cell(e, ((sexp*)ip)[0]);
     stack[top++]=SEXP_CDR(tmp1);
     ip += sizeof(sexp);
     break;
   case OP_GLOBAL_SET:
-/*     fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */
-/*     fflush(stderr); */
-/*     sexp_write(stderr, ((sexp*)ip)[0]); */
-/*     fprintf(stderr, "\n"); */
     env_define(e, ((sexp*)ip)[0], stack[--top]);
     ip += sizeof(sexp);
     break;
   case OP_STACK_REF:
-/*     fprintf(stderr, "stack ref: ip=%p,  %d - %d => ", */
-/*             ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */
-/*     fflush(stderr); */
-/*     sexp_write(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */
-/*     fprintf(stderr, "\n"); */
     stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]];
     ip += sizeof(sexp);
     top++;
@@ -493,10 +482,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
     ip += sizeof(sexp);
     break;
   case OP_CLOSURE_REF:
-/*     fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */
-/*     fflush(stderr); */
-/*     sexp_write(stderr, vector_ref(cp,((sexp*)ip)[0])); */
-/*     fprintf(stderr, "\n"); */
     stack[top++]=sexp_vector_ref(cp,((sexp*)ip)[0]);
     ip += sizeof(sexp);
     break;
@@ -542,6 +527,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
     stack[top-2]=stack[top-1];
     stack[top-1]=tmp1;
     break;
+  case OP_PARAMETER:
+    stack[top] = *(sexp*)((sexp*)ip)[0];
+    top++;
+    ip += sizeof(sexp);
+    break;
   case OP_PAIRP:
     stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
   case OP_NULLP:
@@ -748,8 +738,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
     sexp_write(stack[top-1], cur_error_port);
     fprintf(stderr, "...\n");
     /* print_stack(stack, top); */
-    /*                      top-1  */
-    /* stack: args ... n ip result */
     cp = stack[top-2];
     ip = (unsigned char*) sexp_unbox_integer(stack[top-3]);
     i = sexp_unbox_integer(stack[top-4]);
@@ -795,6 +783,7 @@ static const struct opcode opcodes[] = {
 #define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f)
 #define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f)
 #define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f)
+#define _PARAM(n,a,t) {SEXP_OPCODE, OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL}
 _OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car"),
 _OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!"),
 _OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr"),
@@ -827,7 +816,7 @@ _OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP,  1, 0, 0, 0, 0, "procedure?"),
 _OP(OPC_TYPE_PREDICATE, OP_IPORTP,  1, 0, 0, 0, 0, "input-port?"),
 _OP(OPC_TYPE_PREDICATE, OP_OPORTP,  1, 0, 0, 0, 0, "output-port?"),
 _OP(OPC_TYPE_PREDICATE, OP_EOFP,  1, 0, 0, 0, 0, "eof-object?"),
-_OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"),
+_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"),
 _FN1(SEXP_PAIR, "reverse", sexp_reverse),
@@ -835,11 +824,15 @@ _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
 _FN2(0, SEXP_PAIR, "memq", sexp_memq),
 _FN2(0, SEXP_PAIR, "assq", sexp_assq),
 _FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff),
+_PARAM("current-input-port", (sexp)&cur_input_port, SEXP_IPORT),
+_PARAM("current-output-port", (sexp)&cur_output_port, SEXP_OPORT),
+_PARAM("current-error-port", (sexp)&cur_error_port, SEXP_OPORT),
 #undef _OP
 #undef _FN
 #undef _FN0
 #undef _FN1
 #undef _FN2
+#undef _PARAM
 };
 
 env make_standard_env() {
@@ -925,6 +918,8 @@ int main (int argc, char **argv) {
   env_define(e, err_handler_sym, err_handler);
   exception_handler_cell = env_cell(e, err_handler_sym);
 
+  fprintf(stderr, "current-input-port: %d => %d\n", &cur_input_port, cur_input_port);
+
   /* parse options */
   for (i=1; i < argc && argv[i][0] == '-'; i++) {
     switch (argv[i][1]) {

eval.h

@@ -76,6 +76,7 @@ enum opcode_classes {
   OPC_ARITHMETIC_CMP,
   OPC_CONSTRUCTOR,
   OPC_ACCESSOR,
+  OPC_PARAMETER,
   OPC_FOREIGN,
 };
 
@@ -99,6 +100,7 @@ enum opcode_names {
   OP_JUMP,
   OP_RET,
   OP_DONE,
+  OP_PARAMETER,
   OP_STACK_REF,
   OP_STACK_SET,
   OP_GLOBAL_REF,

sexp.c

@@ -215,7 +215,7 @@ sexp sexp_intern(char *str) {
   char c, *mystr, *p=str;
   sexp sym, *newtable;
 
-#ifdef USE_HUFF_SYMS
+#if USE_HUFF_SYMS
   res = 0;
   for (p=str; c=*p; p++) {
     he = huff_table[c];
@@ -312,7 +312,7 @@ sexp sexp_vector(int count, ...) {
 
 /************************ reading and writing *************************/
 
-#ifdef USE_STRING_STREAMS
+#if USE_STRING_STREAMS
 
 int sstream_read(void *vec, char *dst, int n) {
   int len = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1));
@@ -455,7 +455,7 @@ void sexp_write (sexp obj, sexp out) {
       }
   } else if (SEXP_SYMBOLP(obj)) {
 
-#ifdef USE_HUFF_SYMS
+#if USE_HUFF_SYMS
     if (((sexp_uint_t)obj&7)==7) {
       c = ((sexp_uint_t)obj)>>3;
       while (c) {
@@ -764,7 +764,7 @@ sexp sexp_read_from_string(char *str) {
 void sexp_init() {
   if (! sexp_initialized_p) {
     sexp_initialized_p = 1;
-#ifdef USE_BOEHM
+#if USE_BOEHM
     GC_init();
 #endif
     symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp));

sexp.h

@@ -13,7 +13,7 @@
 
 #include "config.h"
 
-#ifdef HAVE_ERR_H
+#if HAVE_ERR_H
 #include <err.h>
 #else
 /* requires that msg be a string literal */
@@ -21,10 +21,12 @@
 #endif
 
 #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
-#define SEXP_BSD
+#define SEXP_BSD 1
+#else
+#define SEXP_BSD 0
 #endif
 
-#ifdef USE_BOEHM
+#if USE_BOEHM
 #include "gc/include/gc.h"
 #define SEXP_ALLOC        GC_malloc
 #define SEXP_ALLOC_ATOMIC GC_malloc_atomic
@@ -125,7 +127,7 @@ typedef long sexp_sint_t;
 
 #define SEXP_SYMBOLP(x)  (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x))
 
-#ifdef USE_HUFF_SYMS
+#if USE_HUFF_SYMS
 #define SEXP_DOTP(x)     (((sexp_uint_t)(x))==((0x5D00<<SEXP_IMMEDIATE_BITS)+SEXP_ISYMBOL_TAG))
 #else
 #define SEXP_DOTP(x)     ((x)==sexp_the_dot_symbol)
@@ -155,8 +157,8 @@ typedef long sexp_sint_t;
 
 #define sexp_port_stream(p)  ((FILE*) ((sexp)p)->data1)
 
-#ifdef USE_STRING_STREAMS
+#if USE_STRING_STREAMS
-#ifdef SEXP_BSD
+#if SEXP_BSD
 #define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close)
 int sstream_read(void *vec, char *dst, int n);
 int sstream_write(void *vec, const char *src, int n);