string-ports

debug.c

@@ -18,8 +18,11 @@ static const char* reverse_opcode_names[] =
    "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE",
   };
 
-void disasm (sexp bc, sexp out) {
-  unsigned char *ip=sexp_bytecode_data(bc), opcode;
+static sexp sexp_disasm (sexp bc, sexp out) {
+  unsigned char *ip, opcode;
+  if (sexp_procedurep(bc))
+    bc = sexp_procedure_code(bc);
+  ip = sexp_bytecode_data(bc);
  loop:
   opcode = *ip++;
   if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
@@ -52,9 +55,10 @@ void disasm (sexp bc, sexp out) {
   sexp_write_char('\n', out);
   if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
     goto loop;
+  return SEXP_UNDEF;
 }
 
-void print_bytecode (sexp bc) {
+static void print_bytecode (sexp bc) {
   int i;
   unsigned char *data = sexp_bytecode_data(bc);
   fprintf(stderr, "bytecode @ %p, data @ %p, length = %lu\n",
@@ -79,7 +83,7 @@ void print_bytecode (sexp bc) {
   }
 }
 
-void print_stack (sexp *stack, int top, int fp, sexp out) {
+static void 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);

eval.c

@@ -18,12 +18,10 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
 #else
 #define print_stack(...)
 #define print_bytecode(...)
-#define disasm(...)
+#define sexp_disasm(...)
 #endif
 
 static sexp analyze (sexp x, sexp context);
-static sexp_sint_t sexp_context_make_label (sexp context);
-static void sexp_context_patch_label (sexp context, sexp_sint_t label);
 static void generate (sexp x, sexp context);
 static sexp sexp_make_null_env (sexp version);
 static sexp sexp_make_standard_env (sexp version);
@@ -529,7 +527,7 @@ static void sexp_context_patch_label (sexp context, sexp_sint_t label) {
 static sexp finalize_bytecode (sexp context) {
   emit(OP_RET, context);
   shrink_bcode(context, sexp_context_pos(context));
-/*   disasm(sexp_context_bc(context), */
+/*   sexp_disasm(sexp_context_bc(context), */
 /*               env_global_ref(sexp_context_env(context), */
 /*                              the_cur_err_symbol, */
 /*                              SEXP_FALSE)); */
@@ -1488,19 +1486,6 @@ sexp sexp_load (sexp source, sexp env) {
   return res;
 }
 
-static sexp sexp_type_exception (char *message, sexp obj) {
-  return sexp_make_exception(sexp_intern("type-error"),
-                             sexp_c_string(message),
-                             sexp_list1(obj), SEXP_FALSE, SEXP_FALSE);
-}
-
-static sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
-  return sexp_make_exception(sexp_intern("range-error"),
-                             sexp_c_string("bad index range"),
-                             sexp_list3(obj, start, end),
-                             SEXP_FALSE, SEXP_FALSE);
-}
-
 #if USE_MATH
 
 #define define_math_op(name, cname)       \
@@ -1557,30 +1542,6 @@ static sexp sexp_expt (sexp x, sexp e) {
   return sexp_make_integer((sexp_sint_t)round(res));
 }
 
-static sexp sexp_substring (sexp str, sexp start, sexp end) {
-  sexp res;
-  if (! sexp_stringp(str))
-    return sexp_type_exception("not a string", str);
-  if (! sexp_integerp(start))
-    return sexp_type_exception("not a number", start);
-  if (end == SEXP_FALSE)
-    end = sexp_make_integer(sexp_string_length(str));
-  if (! sexp_integerp(end))
-    return sexp_type_exception("not a number", end);
-  if ((sexp_unbox_integer(start) < 0)
-      || (sexp_unbox_integer(start) > sexp_string_length(str))
-      || (sexp_unbox_integer(end) < 0)
-      || (sexp_unbox_integer(end) > sexp_string_length(str))
-      || (end < start))
-    return sexp_range_exception(str, start, end);
-  res = sexp_make_string(sexp_fx_sub(end, start),
-                         SEXP_UNDEF);
-  memcpy(sexp_string_data(res),
-         sexp_string_data(str)+sexp_unbox_integer(start),
-         sexp_string_length(res));
-  return res;
-}
-
 static sexp sexp_string_concatenate (sexp str_ls) {
   sexp res, ls;
   sexp_uint_t len=0;

init.scm

@@ -2,7 +2,6 @@
 ;; let-syntax letrec-syntax syntax-rules
 ;; number->string string->number
 ;; symbol->string string->symbol
-;; call-with-input-file call-with-output-file
 ;; with-input-from-file with-output-to-file
 
 ;; provide c[ad]{2,4}r
@@ -420,13 +419,33 @@
 
 (define (vector . args) (list->vector args))
 
-;; I/O utilities
+;; I/O utils
 
 (define (char-ready? . o)
   (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
 
 (define (load file) (%load file (interaction-environment)))
 
+(define (call-with-input-string str proc)
+  (proc (open-input-string str)))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+(define (call-with-input-file file proc)
+  (let* ((in (open-input-file file))
+         (res (proc in)))
+    (close-input-port in)
+    res))
+
+(define (call-with-output-file file proc)
+  (let* ((out (open-output-file file))
+         (res (proc in)))
+    (close-output-port in)
+    res))
+
 ;; values
 
 (define *values-tag* (list 'values))

opcodes.c

@@ -83,6 +83,14 @@ _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", sexp_string_cmp),
 _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", sexp_string_cmp_ci),
 _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", sexp_substring),
 _FN1(SEXP_PAIR, "string-concatenate", sexp_string_concatenate),
+_FN2(0, SEXP_PAIR, "memq", sexp_memq),
+_FN2(0, SEXP_PAIR, "assq", sexp_assq),
+_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo),
+_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT),
+_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
+_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
+_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE),
+_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
 #if USE_MATH
 _FN1(0, "exp", sexp_exp),
 _FN1(0, "log", sexp_log),
@@ -99,13 +107,13 @@ _FN1(0, "floor", sexp_floor),
 _FN1(0, "ceiling", sexp_ceiling),
 _FN2(0, 0, "expt", sexp_expt),
 #endif
-_FN2(0, SEXP_PAIR, "memq", sexp_memq),
-_FN2(0, SEXP_PAIR, "assq", sexp_assq),
-_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo),
-_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT),
-_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
-_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
-_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE),
-_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
+#if USE_STRING_STREAMS
+_FN0("open-output-string", sexp_make_output_string_port),
+_FN1(SEXP_STRING, "open-input-string", sexp_make_input_string_port),
+_FN1(SEXP_OPORT, "get-output-string", sexp_get_output_string),
+#endif
+#if USE_DEBUG
+_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", sexp_disasm),
+#endif
 };
 

sexp.c

@@ -102,6 +102,19 @@ sexp sexp_make_exception (sexp kind, sexp message, sexp irritants,
   return exn;
 }
 
+sexp sexp_type_exception (char *message, sexp obj) {
+  return sexp_make_exception(sexp_intern("type-error"),
+                             sexp_c_string(message),
+                             sexp_list1(obj), SEXP_FALSE, SEXP_FALSE);
+}
+
+sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
+  return sexp_make_exception(sexp_intern("range-error"),
+                             sexp_c_string("bad index range"),
+                             sexp_list3(obj, start, end),
+                             SEXP_FALSE, SEXP_FALSE);
+}
+
 sexp sexp_print_exception (sexp exn, sexp out) {
   sexp ls;
   sexp_write_string("ERROR", out);
@@ -288,6 +301,30 @@ sexp sexp_c_string(char *str) {
   return s;
 }
 
+sexp sexp_substring (sexp str, sexp start, sexp end) {
+  sexp res;
+  if (! sexp_stringp(str))
+    return sexp_type_exception("not a string", str);
+  if (! sexp_integerp(start))
+    return sexp_type_exception("not a number", start);
+  if (end == SEXP_FALSE)
+    end = sexp_make_integer(sexp_string_length(str));
+  if (! sexp_integerp(end))
+    return sexp_type_exception("not a number", end);
+  if ((sexp_unbox_integer(start) < 0)
+      || (sexp_unbox_integer(start) > sexp_string_length(str))
+      || (sexp_unbox_integer(end) < 0)
+      || (sexp_unbox_integer(end) > sexp_string_length(str))
+      || (end < start))
+    return sexp_range_exception(str, start, end);
+  res = sexp_make_string(sexp_fx_sub(end, start),
+                         SEXP_UNDEF);
+  memcpy(sexp_string_data(res),
+         sexp_string_data(str)+sexp_unbox_integer(start),
+         sexp_string_length(res));
+  return res;
+}
+
 #define FNV_PRIME 16777619
 #define FNV_OFFSET_BASIS 2166136261uL
 
@@ -392,50 +429,95 @@ sexp sexp_vector(int count, ...) {
 
 #if USE_STRING_STREAMS
 
+#define SEXP_INIT_STRING_PORT_SIZE 128
+
+#if SEXP_BSD
+
+#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(0))
+#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(1))
+#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(2))
+
 int sstream_read(void *vec, char *dst, int n) {
-  int len = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1));
-  int pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2));
+  sexp_uint_t len = sexp_unbox_integer(sexp_stream_size(vec));
+  sexp_uint_t pos = sexp_unbox_integer(sexp_stream_pos(vec));
   if (pos >= len) return 0;
   if (n > (len - pos)) n = (len - pos);
-  memcpy(dst+pos, sexp_vector_ref((sexp) vec, sexp_make_integer(0)), n);
-  sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)n);
+  memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n);
+  sexp_vector_set((sexp) vec, sexp_make_integer(2), sexp_make_integer(n));
   return n;
 }
 
 int sstream_write(void *vec, const char *src, int n) {
+  sexp_uint_t len, pos, newpos;
+  sexp newbuf;
+  len = sexp_unbox_integer(sexp_stream_size(vec));
+  pos = sexp_unbox_integer(sexp_stream_pos(vec));
+  newpos = pos+n;
+  if (newpos > len) {
+    newbuf = sexp_make_string(sexp_make_integer(len*2), SEXP_UNDEF);
+    memcpy(sexp_string_data(newbuf),
+           sexp_string_data(sexp_stream_buf(vec)),
+           pos);
+    sexp_vector_set((sexp)vec, sexp_make_integer(0), newbuf);
+    sexp_vector_set((sexp)vec, sexp_make_integer(1), sexp_make_integer(len*2));
+  }
+  memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n);
+  sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(newpos));
   return n;
 }
 
 off_t sstream_seek(void *vec, off_t offset, int whence) {
-  int pos;
+  sexp_sint_t pos;
   if (whence == SEEK_SET) {
     pos = offset;
   } else if (whence == SEEK_CUR) {
-    pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2)) + offset;
+    pos = sexp_unbox_integer(sexp_stream_pos(vec)) + offset;
   } else {                      /* SEEK_END */
-    pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1)) + offset;
+    pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset;
   }
-  sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)pos);
+  sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(pos));
   return pos;
 }
 
-int sstream_close(void *vec) {
-  sexp_deep_free((sexp)vec);
-  return 0;
+sexp sexp_make_input_string_port(sexp str) {
+  FILE *in;
+  sexp res, cookie;
+  cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)),
+                       sexp_make_integer(0));
+  in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
+  res = sexp_make_input_port(in);
+  sexp_port_cookie(res) = cookie;
+  return res;
 }
 
+sexp sexp_make_output_string_port() {
+  FILE *out;
+  sexp res, size, cookie;
+  size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE);
+  cookie = sexp_vector(3, sexp_make_string(size, SEXP_UNDEF),
+                       size, sexp_make_integer(0));
+  out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
+  res = sexp_make_output_port(out);
+  sexp_port_cookie(res) = cookie;
+  return res;
+}
+
+sexp sexp_get_output_string(sexp port) {
+  sexp cookie = sexp_port_cookie(port);
+  fflush(sexp_port_stream(port));
+  return sexp_substring(sexp_stream_buf(cookie),
+                        sexp_make_integer(0),
+                        sexp_stream_pos(cookie));
+}
+
+#else
+
 sexp sexp_make_input_string_port(sexp str) {
   FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
   return sexp_make_input_port(in);
 }
 
-sexp sexp_make_output_string_port() {
-  return SEXP_ERROR;
-}
-
-sexp sexp_get_output_string(sexp port) {
-  return SEXP_ERROR;
-}
+#endif
 
 #endif
 
@@ -560,19 +642,26 @@ void sexp_write (sexp obj, sexp out) {
       sexp_write_char('"', out);
       i = sexp_string_length(obj);
       str = sexp_string_data(obj);
-      /* ... FALLTHROUGH ... */
+      for ( ; i>0; str++, i--) {
+        switch (str[0]) {
+        case '\\': sexp_write_string("\\\\", out); break;
+        case '"': sexp_write_string("\\\"", out); break;
+        case '\n': sexp_write_string("\\n", out); break;
+        case '\r': sexp_write_string("\\r", out); break;
+        case '\t': sexp_write_string("\\t", out); break;
+        default: sexp_write_char(str[0], out);
+        }
+      }
+      sexp_write_char('"', out);
+      break;
     case SEXP_SYMBOL:
-      if (! sexp_stringp(obj)) {
       i = sexp_symbol_length(obj);
       str = sexp_symbol_data(obj);
-      }
       for ( ; i>0; str++, i--) {
-        if (str[0] == '\\')
+        if ((str[0] == '\\') || is_separator(str[0]))
           sexp_write_char('\\', out);
         sexp_write_char(str[0], out);
       }
-      if (sexp_stringp(obj))
-        sexp_write_char('"', out);
       break;
     }
   } else if (sexp_integerp(obj)) {

sexp.h

@@ -102,6 +102,7 @@ struct sexp_struct {
       FILE *stream;
       char *name;
       sexp_uint_t line;
+      sexp cookie;
     } port;
     struct {
       sexp kind, message, irritants, file, line;
@@ -263,6 +264,7 @@ struct sexp_struct {
 #define sexp_port_stream(p)    ((p)->value.port.stream)
 #define sexp_port_name(p)      ((p)->value.port.name)
 #define sexp_port_line(p)      ((p)->value.port.line)
+#define sexp_port_cookie(p)    ((p)->value.port.cookie)
 
 #define sexp_exception_kind(p)      ((p)->value.exception.kind)
 #define sexp_exception_message(p)   ((p)->value.exception.message)
@@ -382,29 +384,12 @@ struct sexp_struct {
 
 /***************************** general API ****************************/
 
-#if USE_STRING_STREAMS
-#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);
-off_t sstream_seek(void *vec, off_t offset, int whence);
-int sstream_close(void *vec);
-#endif
 #define sexp_read_char(p) (getc(sexp_port_stream(p)))
 #define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p)))
 #define sexp_write_char(c, p) (putc(c, sexp_port_stream(p)))
 #define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p)))
 #define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
 #define sexp_flush(p) (fflush(sexp_port_stream(p)))
-#else
-sexp sexp_read_char(sexp port);
-void sexp_push_char(sexp ch, sexp port);
-void sexp_write_char(sexp ch, sexp port);
-void sexp_write_string(sexp str, sexp port);
-void sexp_printf(sexp port, sexp fmt, ...);
-#endif
-
-/***************************** general API ****************************/
 
 sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag);
 sexp sexp_cons(sexp head, sexp tail);
@@ -418,6 +403,7 @@ sexp sexp_assq(sexp x, sexp ls);
 sexp sexp_length(sexp ls);
 sexp sexp_c_string(char *str);
 sexp sexp_make_string(sexp len, sexp ch);
+sexp sexp_substring (sexp str, sexp start, sexp end);
 sexp sexp_make_flonum(double f);
 int sexp_string_hash(char *str, int acc);
 sexp sexp_intern(char *str);
@@ -437,6 +423,8 @@ sexp sexp_make_input_string_port(sexp str);
 sexp sexp_make_output_string_port();
 sexp sexp_get_output_string(sexp port);
 sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line);
+sexp sexp_type_exception (char *message, sexp obj);
+sexp sexp_range_exception (sexp obj, sexp start, sexp end);
 sexp sexp_print_exception(sexp exn, sexp out);
 void sexp_init();