From 7130f38e767e288137a068c038081e52171ed07b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 20:03:46 +0900 Subject: [PATCH] string-ports --- debug.c | 12 +++-- eval.c | 49 ++----------------- init.scm | 23 ++++++++- opcodes.c | 24 ++++++--- sexp.c | 143 +++++++++++++++++++++++++++++++++++++++++++----------- sexp.h | 22 ++------- 6 files changed, 171 insertions(+), 102 deletions(-) diff --git a/debug.c b/debug.c index 89923926..4ff6d2cd 100644 --- a/debug.c +++ b/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 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; diff --git a/init.scm b/init.scm index 530a0ae1..eb78c704 100644 --- a/init.scm +++ b/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)) diff --git a/opcodes.c b/opcodes.c index e9a3ca74..f4f326b4 100644 --- a/opcodes.c +++ b/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 }; diff --git a/sexp.c b/sexp.c index 8cb49a33..936d70e3 100644 --- a/sexp.c +++ b/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 ... */ - 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] == '\\') + 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: + i = sexp_symbol_length(obj); + str = sexp_symbol_data(obj); + for ( ; i>0; str++, i--) { + 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)) { diff --git a/sexp.h b/sexp.h index 7db6b806..ae4835b2 100644 --- a/sexp.h +++ b/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();