From d4f97c40d59404fc4243b836b68e5a2206631434 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 27 Jun 2009 20:28:04 +0900 Subject: [PATCH] initial plan9 work --- eval.c | 61 +++--- gc.c | 14 +- include/chibi/config.h | 28 ++- include/chibi/eval.h | 2 +- include/chibi/sexp.h | 51 +++-- main.c | 18 +- mkfile | 37 ++++ sexp.c | 461 ++++++++++++++++++++++++++--------------- 8 files changed, 431 insertions(+), 241 deletions(-) create mode 100644 mkfile diff --git a/eval.c b/eval.c index 33a6d84e..9a965345 100644 --- a/eval.c +++ b/eval.c @@ -14,7 +14,7 @@ static sexp the_err_handler_symbol, the_compile_error_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; #define sexp_current_error_port(ctx) env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) -#define sexp_debug(ctx, msg, obj) (sexp_write_string(msg, sexp_current_error_port(ctx)), sexp_write(obj, sexp_current_error_port(ctx)), sexp_write_char('\n', sexp_current_error_port(ctx))) +#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) #if USE_DEBUG #include "debug.c" @@ -1298,7 +1298,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { tmp1 = _ARG1; i = 1; sexp_context_top(ctx) = top; - tmp2 = sexp_vector(ctx, 1, sexp_save_stack(ctx, stack, top+4)); + tmp2 = sexp_make_vector(ctx, sexp_make_integer(1), SEXP_UNDEF); + sexp_vector_set(tmp2, + sexp_make_integer(0), + sexp_save_stack(ctx, stack, top+4)); _ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, tmp2); @@ -1334,10 +1337,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto make_call; case OP_CALL: #if USE_CHECK_STACK - if (top+16 >= INIT_STACK_SIZE) { - fprintf(stderr, "out of stack space\n"); - exit(70); - } + if (top+16 >= INIT_STACK_SIZE) + errx(70, "out of stack space\n"); #endif i = sexp_unbox_integer(_WORD0); tmp1 = _ARG1; @@ -1752,19 +1753,19 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { - sexp_write_string(sexp_string_data(_ARG1), _ARG2); + sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; break; } else if (sexp_charp(_ARG1)) { - sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; break; } /* ... FALLTHROUGH ... */ case OP_WRITE: - sexp_write(_ARG1, _ARG2); + sexp_write(ctx, _ARG1, _ARG2); _ARG2 = SEXP_VOID; top--; break; @@ -1774,7 +1775,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_NEWLINE: - sexp_write_char('\n', _ARG1); + sexp_write_char(ctx, '\n', _ARG1); _ARG1 = SEXP_VOID; break; case OP_FLUSH_OUTPUT: @@ -1787,12 +1788,12 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case OP_READ_CHAR: - i = sexp_read_char(_ARG1); + i = sexp_read_char(ctx, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_PEEK_CHAR: - i = sexp_read_char(_ARG1); - sexp_push_char(i, _ARG1); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: @@ -1850,9 +1851,14 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { } static sexp sexp_close_port (sexp ctx, sexp port) { - fclose(sexp_port_stream(port)); + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "not a port", port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); if (sexp_port_buf(port)) free(sexp_port_buf(port)); + if (sexp_port_stream(port)) + fclose(sexp_port_stream(port)); return SEXP_VOID; } @@ -1860,9 +1866,9 @@ void sexp_warn_undefs (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) { - sexp_write_string("WARNING: reference to undefined variable: ", out); - sexp_write(sexp_caar(x), out); - sexp_write_char('\n', out); + sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out); + sexp_write(ctx, sexp_caar(x), out); + sexp_write_char(ctx, '\n', out); } } @@ -1960,25 +1966,6 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { return sexp_make_integer((sexp_sint_t)round(res)); } -static sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { - sexp res, ls; - sexp_uint_t len=0; - char *p; - for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! sexp_stringp(sexp_car(ls))) - return sexp_type_exception(ctx, "not a string", sexp_car(ls)); - else - len += sexp_string_length(sexp_car(ls)); - res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); - p = sexp_string_data(res); - for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { - len = sexp_string_length(sexp_car(ls)); - memcpy(p, sexp_string_data(sexp_car(ls)), len); - p += len; - } - return res; -} - static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { sexp_sint_t len1, len2, len, diff; if (! sexp_stringp(str1)) @@ -2153,6 +2140,7 @@ 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); @@ -2162,6 +2150,7 @@ sexp sexp_eval_string (sexp ctx, char *str) { sexp_gc_release(ctx, obj, s_obj); return res; } +#endif void sexp_scheme_init () { sexp ctx; diff --git a/gc.c b/gc.c index c8a980f3..caee6213 100644 --- a/gc.c +++ b/gc.c @@ -157,10 +157,8 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_heap sexp_make_heap (size_t size) { sexp free, next; sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); - if (! h) { - fprintf(stderr, "out of memory allocating %zu byte heap, aborting\n", size); - exit(70); - } + if (! h) + errx(70, "out of memory allocating %zu byte heap, aborting\n", size); h->size = size; h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); free = h->free_list = (sexp) h->data; @@ -201,7 +199,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) { } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } - bzero((void*)ls2, size); + memset((void*)ls2, 0, size); return ls2; } ls1 = ls2; @@ -225,10 +223,8 @@ void* sexp_alloc (sexp ctx, size_t size) { && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); - if (! res) { - fprintf(stderr, "out of memory allocating %zu bytes, aborting\n", size); - exit(70); - } + if (! res) + errx(80, "out of memory allocating %zu bytes, aborting\n", size); } return res; } diff --git a/include/chibi/config.h b/include/chibi/config.h index 49661145..e3fdf9b6 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -42,13 +42,6 @@ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ -#if HAVE_ERR_H -#include -#else -/* requires msg be a string literal, and at least one argument */ -#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) -#endif - #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) #define SEXP_BSD 1 #else @@ -104,3 +97,24 @@ #define USE_CHECK_STACK 0 #endif +#ifdef PLAN9 + +#define errx(code, msg, ...) exits(msg) +#define exit_normally() exits(NULL) +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +/* XXXX these are wrong */ +#define trunc floor +#define round(x) floor(x+0.5) + +#else + +#define exit_normally() exit(0) +#if HAVE_ERR_H +#include +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index dcee8420..9f0b26ea 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -5,7 +5,7 @@ #ifndef SEXP_EVAL_H #define SEXP_EVAL_H -#include "sexp.h" +#include "chibi/sexp.h" /************************* additional types ***************************/ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 788d4a12..f3b8068d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -5,17 +5,22 @@ #ifndef SEXP_H #define SEXP_H -#include "config.h" -#include "install.h" +#include "chibi/config.h" +#include "chibi/install.h" #include #include +#ifdef PLAN9 +typedef unsigned long size_t; +#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) +#else #include #include #include #include #include #include +#endif /* tagging system * bits end in 00: pointer @@ -123,7 +128,7 @@ struct sexp_struct { struct { FILE *stream; char *buf; - sexp_uint_t line; + sexp_uint_t offset, line, openp; size_t size; sexp name; sexp cookie; @@ -366,9 +371,11 @@ sexp sexp_make_flonum(sexp ctx, double f); #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_openp(p) ((p)->value.port.openp) #define sexp_port_cookie(p) ((p)->value.port.cookie) #define sexp_port_buf(p) ((p)->value.port.buf) #define sexp_port_size(p) ((p)->value.port.size) +#define sexp_port_offset(p) ((p)->value.port.offset) #define sexp_exception_kind(p) ((p)->value.exception.kind) #define sexp_exception_message(p) ((p)->value.exception.message) @@ -509,13 +516,32 @@ sexp sexp_make_flonum(sexp ctx, double f); /***************************** general API ****************************/ -#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_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) -#define sexp_flush(p) (fflush(sexp_port_stream(p))) +#if USE_STRING_STREAMS + +#define sexp_read_char(x, p) (getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) + +#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) + +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 (sexp ctx, char *str, sexp p); +sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(p) sexp_write_char('\n', (p)) sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); sexp sexp_cons(sexp ctx, sexp head, sexp tail); @@ -531,12 +557,13 @@ sexp sexp_length(sexp ctx, sexp ls); sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); sexp sexp_make_string(sexp ctx, sexp len, sexp ch); sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_string_concatenate (sexp ctx, sexp str_ls); 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 obj, sexp out); +/* 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); sexp sexp_read_number(sexp ctx, sexp in, int base); diff --git a/main.c b/main.c index 42f2d858..5e844ade 100644 --- a/main.c +++ b/main.c @@ -2,7 +2,9 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +#ifndef PLAN9 #include +#endif #include "chibi/eval.h" char *chibi_module_dir = NULL; @@ -11,13 +13,18 @@ sexp find_module_file (sexp ctx, char *file) { sexp res; int mlen, flen; char *path; +#ifndef PLAN9 struct stat buf; if (! stat(file, &buf)) +#endif return sexp_c_string(ctx, file, -1); +#ifndef PLAN9 if (! chibi_module_dir) { +#ifndef PLAN9 chibi_module_dir = getenv("CHIBI_MODULE_DIR"); if (! chibi_module_dir) +#endif chibi_module_dir = sexp_module_dir; } mlen = strlen(chibi_module_dir); @@ -33,6 +40,7 @@ sexp find_module_file (sexp ctx, char *file) { res = SEXP_FALSE; free(path); return res; +#endif } void repl (sexp ctx) { @@ -45,7 +53,7 @@ void repl (sexp ctx) { out = sexp_eval_string(ctx, "(current-output-port)"); err = sexp_eval_string(ctx, "(current-error-port)"); while (1) { - sexp_write_string("> ", out); + sexp_write_string(ctx, "> ", out); sexp_flush(out); obj = sexp_read(ctx, in); if (obj == SEXP_EOF) @@ -60,8 +68,8 @@ void repl (sexp ctx) { sexp_warn_undefs(sexp_env_bindings(env), tmp, err); #endif if (res != SEXP_VOID) { - sexp_write(res, out); - sexp_write_char('\n', out); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); } } } @@ -92,8 +100,8 @@ void run_main (int argc, char **argv) { if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, out); } else if (argv[i][1] == 'p') { - sexp_write(res, out); - sexp_write_char('\n', out); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); } quit=1; i++; diff --git a/mkfile b/mkfile new file mode 100644 index 00000000..a7785b39 --- /dev/null +++ b/mkfile @@ -0,0 +1,37 @@ + include/chibi/install.h + +%.i: %.c include/chibi/install.h $HFILES + cpp $CPPFLAGS $stem.c > $target + +sexp.$O: sexp.i + $CC $CFLAGS -c -o $target sexp.i + +eval.$O: eval.i + $CC $CFLAGS -c -o $target eval.i + +main.$O: main.i + $CC $CFLAGS -c -o $target main.i + +chibi-scheme: sexp.$O eval.$O main.$O + $LD -o $target -l $prereq + +# sexp_make_integer(0))) { - sexp_write_string(" on line ", out); - sexp_write(sexp_exception_line(exn), out); + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_exception_line(exn), out); } if (sexp_stringp(sexp_exception_file(exn))) { - sexp_write_string(" of file ", out); - sexp_write_string(sexp_string_data(sexp_exception_file(exn)), out); + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_exception_file(exn)), out); } - sexp_write_string(": ", out); - sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out); + sexp_write_string(ctx, ": ", out); + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); if (sexp_exception_irritants(exn) && sexp_pairp(sexp_exception_irritants(exn))) { if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { - sexp_write_string(": ", out); - sexp_write(sexp_car(sexp_exception_irritants(exn)), out); - sexp_write_string("\n", out); + sexp_write_string(ctx, ": ", out); + sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string(ctx, "\n", out); } else { - sexp_write_string("\n", out); + sexp_write_string(ctx, "\n", out); for (ls=sexp_exception_irritants(exn); sexp_pairp(ls); ls=sexp_cdr(ls)) { - sexp_write_string(" ", out); - sexp_write(sexp_car(ls), out); - sexp_write_char('\n', out); + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_car(ls), out); + sexp_write_char(ctx, '\n', out); } } } else { - sexp_write_char('\n', out); + sexp_write_char(ctx, '\n', out); } } else { - sexp_write_string(": ", out); + sexp_write_string(ctx, ": ", out); if (sexp_stringp(exn)) - sexp_write_string(sexp_string_data(exn), out); + sexp_write_string(ctx, sexp_string_data(exn), out); else - sexp_write(exn, out); - sexp_write_char('\n', out); + sexp_write(ctx, exn, out); + sexp_write_char(ctx, '\n', out); } return SEXP_VOID; } @@ -434,6 +434,25 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { return res; } +sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, "not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + } + return res; +} + #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL @@ -513,19 +532,6 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } -sexp sexp_vector(sexp ctx, int count, ...) { - sexp vec = sexp_make_vector(ctx, sexp_make_integer(count), SEXP_VOID); - sexp *elts = sexp_vector_data(vec); - va_list ap; - int i; - - va_start(ap, count); - for (i=0; i= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + sexp_port_buf(p)[sexp_port_offset(p)++] = (c); + return SEXP_VOID; +} + +sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); + sexp_port_offset(p) += len; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { + return sexp_buffered_write_string_n(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_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) { + 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) { + sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + sexp_port_cookie(res) = str; + sexp_port_buf(res) = sexp_string_data(str); + sexp_port_offset(res) = 0; + sexp_port_size(res) = sexp_string_length(str); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); + sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_offset(res) = 0; + sexp_port_cookie(res) = SEXP_NULL; + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp out) { + sexp res; + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = ((sexp_port_offset(out) > 0) + ? sexp_cons(ctx, + tmp=sexp_c_string(ctx, + sexp_port_buf(out), + sexp_port_offset(out)), + sexp_port_cookie(out)) + : sexp_port_cookie(out)); + res = sexp_string_concatenate(ctx, tmp); + sexp_gc_release(ctx, tmp, s_tmp); + return res; +} + #endif sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { @@ -652,6 +751,7 @@ 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_openp(p) = 1; return p; } @@ -661,187 +761,205 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { sexp_port_name(p) = name; sexp_port_line(p) = 0; sexp_port_buf(p) = NULL; + sexp_port_openp(p) = 1; return p; } -void sexp_write (sexp obj, sexp out) { +void sexp_write (sexp ctx, sexp obj, sexp out) { unsigned long len, c, res; long i=0; double f; sexp x, *elts; - char *str=NULL; + char *str=NULL, numbuf[20]; if (! obj) { - sexp_write_string("#", out); /* shouldn't happen */ + sexp_write_string(ctx, "#", out); /* shouldn't happen */ } else if (sexp_pointerp(obj)) { switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: - sexp_write_char('(', out); - sexp_write(sexp_car(obj), out); + sexp_write_char(ctx, '(', out); + sexp_write(ctx, sexp_car(obj), out); for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { - sexp_write_char(' ', out); - sexp_write(sexp_car(x), out); + sexp_write_char(ctx, ' ', out); + sexp_write(ctx, sexp_car(x), out); } if (! sexp_nullp(x)) { - sexp_write_string(" . ", out); - sexp_write(x, out); + sexp_write_string(ctx, " . ", out); + sexp_write(ctx, x, out); } - sexp_write_char(')', out); + sexp_write_char(ctx, ')', out); break; case SEXP_VECTOR: len = sexp_vector_length(obj); elts = sexp_vector_data(obj); if (len == 0) { - sexp_write_string("#()", out); + sexp_write_string(ctx, "#()", out); } else { - sexp_write_string("#(", out); - sexp_write(elts[0], out); + sexp_write_string(ctx, "#(", out); + sexp_write(ctx, elts[0], out); for (i=1; i", out); + sexp_write_string(ctx, "#", out); break; case SEXP_IPORT: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_OPORT: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_CORE: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_OPCODE: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_BYTECODE: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_ENV: - sexp_printf(out, "# 5) { - sexp_write_char(' ', out); - sexp_write(sexp_caar(x), out); - sexp_write_string(": ", out); - if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) - sexp_printf(out, "%p", sexp_cdar(x)); - else - sexp_write(sexp_cdar(x), out); - sexp_write_string(" ...", out); - } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { - sexp_write_char(' ', out); - sexp_write(sexp_caar(x), out); - sexp_write_string(": ", out); - if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) - sexp_printf(out, "%p", sexp_cdar(x)); - else - sexp_write(sexp_cdar(x), out); - } - sexp_write_char('>', out); + sexp_write_string(ctx, "#", out); break; +/* sexp_printf(out, "# 5) { */ +/* sexp_write_char(' ', out); */ +/* sexp_write(sexp_caar(x), out); */ +/* sexp_write_string(": ", out); */ +/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */ +/* sexp_printf(out, "%p", sexp_cdar(x)); */ +/* else */ +/* sexp_write(sexp_cdar(x), out); */ +/* sexp_write_string(" ...", out); */ +/* } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { */ +/* sexp_write_char(' ', out); */ +/* sexp_write(sexp_caar(x), out); */ +/* sexp_write_string(": ", out); */ +/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */ +/* sexp_printf(out, "%p", sexp_cdar(x)); */ +/* else */ +/* sexp_write(sexp_cdar(x), out); */ +/* } */ +/* sexp_write_char('>', out); */ break; case SEXP_EXCEPTION: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_MACRO: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; #if USE_DEBUG case SEXP_LAMBDA: - /* sexp_write_string("#', out); + sexp_write_string(ctx, "#', out); */ break; case SEXP_SEQ: - sexp_write_string("#', out); + sexp_write_string(ctx, "#', out); break; case SEXP_CND: - sexp_write_string("#', out); + sexp_write_string(ctx, "#', out); break; case SEXP_REF: - sexp_write_string("#", sexp_ref_loc(obj)); + sexp_write_string(ctx, "#", out); +/* sexp_write_string("#", sexp_ref_loc(obj)); */ break; case SEXP_SET: - sexp_write_string("#", out); + sexp_write_string(ctx, "#", out); break; case SEXP_SYNCLO: - sexp_write_string("#", out); + sexp_write_string(ctx, "#", out); break; #endif case SEXP_TYPE: - sexp_write_string("#", out); + sexp_write_string(ctx, "#", out); break; case SEXP_STRING: - sexp_write_char('"', out); + sexp_write_char(ctx, '"', out); i = sexp_string_length(obj); str = sexp_string_data(obj); 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); + case '\\': sexp_write_string(ctx, "\\\\", out); break; + case '"': sexp_write_string(ctx, "\\\"", out); break; + case '\n': sexp_write_string(ctx, "\\n", out); break; + case '\r': sexp_write_string(ctx, "\\r", out); break; + case '\t': sexp_write_string(ctx, "\\t", out); break; + default: sexp_write_char(ctx, str[0], out); } } - sexp_write_char('"', out); + sexp_write_char(ctx, '"', out); break; case SEXP_SYMBOL: i = sexp_string_length(sexp_symbol_string(obj)); str = sexp_string_data(sexp_symbol_string(obj)); for ( ; i>0; str++, i--) { if ((str[0] == '\\') || is_separator(str[0])) - sexp_write_char('\\', out); - sexp_write_char(str[0], out); + sexp_write_char(ctx, '\\', out); + sexp_write_char(ctx, str[0], out); } break; } } else if (sexp_integerp(obj)) { - sexp_printf(out, "%ld", sexp_unbox_integer(obj)); + sprintf(numbuf, "%ld", sexp_unbox_integer(obj)); + sexp_write_string(ctx, numbuf, out); #if USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { f = sexp_flonum_value(obj); - sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f)) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } + sexp_write_string(ctx, numbuf, out); #endif } else if (sexp_charp(obj)) { if (obj == sexp_make_character(' ')) - sexp_write_string("#\\space", out); + sexp_write_string(ctx, "#\\space", out); else if (obj == sexp_make_character('\n')) - sexp_write_string("#\\newline", out); + sexp_write_string(ctx, "#\\newline", out); else if (obj == sexp_make_character('\r')) - sexp_write_string("#\\return", out); + sexp_write_string(ctx, "#\\return", out); else if (obj == sexp_make_character('\t')) - sexp_write_string("#\\tab", out); + sexp_write_string(ctx, "#\\tab", out); else if ((33 <= sexp_unbox_character(obj)) && (sexp_unbox_character(obj) < 127)) - sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); - else - sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj)); + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else { + sexp_write_string(ctx, "#\\x", out); + if (sexp_unbox_character(obj) < 16) + sexp_write_char(ctx, '0', out); + sexp_write(ctx, sexp_make_integer(sexp_unbox_character(obj)), out); + } } else if (sexp_symbolp(obj)) { #if USE_HUFF_SYMS @@ -849,7 +967,7 @@ void sexp_write (sexp obj, sexp out) { c = ((sexp_uint_t)obj)>>3; while (c) { #include "opt/sexp-unhuff.c" - sexp_write_char(res, out); + sexp_write_char(ctx, res, out); } } #endif @@ -857,18 +975,18 @@ void sexp_write (sexp obj, sexp out) { } else { switch ((sexp_uint_t) obj) { case (sexp_uint_t) SEXP_NULL: - sexp_write_string("()", out); break; + sexp_write_string(ctx, "()", out); break; case (sexp_uint_t) SEXP_TRUE: - sexp_write_string("#t", out); break; + sexp_write_string(ctx, "#t", out); break; case (sexp_uint_t) SEXP_FALSE: - sexp_write_string("#f", out); break; + sexp_write_string(ctx, "#f", out); break; case (sexp_uint_t) SEXP_EOF: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case (sexp_uint_t) SEXP_UNDEF: case (sexp_uint_t) SEXP_VOID: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; default: - sexp_printf(out, "#", obj); + sexp_write_string(ctx, "#", out); } } } @@ -881,9 +999,9 @@ sexp sexp_read_string(sexp ctx, sexp in) { char *buf=initbuf, *tmp; sexp res; - for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { if (c == '\\') { - c = sexp_read_char(in); + c = sexp_read_char(ctx, in); switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;} } if (c == EOF) { @@ -892,7 +1010,7 @@ sexp sexp_read_string(sexp ctx, sexp in) { } buf[i++] = c; if (i >= size) { /* expand buffer w/ malloc(), later free() it */ - tmp = malloc(size*2); + tmp = (char*) malloc(size*2); memcpy(tmp, buf, i); if (size != INIT_STRING_BUFFER_SIZE) free(buf); buf = tmp; @@ -915,15 +1033,15 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { if (init != EOF) buf[i++] = init; - for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { - if (c == '\\') c = sexp_read_char(in); + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') c = sexp_read_char(ctx, in); if (c == EOF || is_separator(c)) { - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); break; } buf[i++] = c; if (i >= size) { /* expand buffer w/ malloc(), later free() it */ - tmp = malloc(size*2); + tmp = (char*) malloc(size*2); memcpy(tmp, buf, i); if (size != INIT_STRING_BUFFER_SIZE) free(buf); buf = tmp; @@ -941,9 +1059,11 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { sexp exponent; double res=0.0, scale=0.1, e=0.0; int c; - for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1) + for (c=sexp_read_char(ctx, in); + isdigit(c); + c=sexp_read_char(ctx, in), scale*=0.1) res += digit_value(c)*scale; - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); if (c=='e' || c=='E') { exponent = sexp_read_number(ctx, in, 10); if (sexp_exceptionp(exponent)) return exponent; @@ -959,23 +1079,24 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { sexp f; sexp_sint_t res = 0, negativep = 0, c; - c = sexp_read_char(in); + c = sexp_read_char(ctx, in); if (c == '-') negativep = 1; else if (isdigit(c)) res = digit_value(c); if (base == 16) - for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) res = res * base + digit_value(c); - for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in)) + for (c=sexp_read_char(ctx, in); isdigit(c); c=sexp_read_char(ctx, in)) res = res * base + digit_value(c); if (c=='.' || c=='e' || c=='E') { if (base != 10) - return sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); + return + sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); if (c!='.') - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); f = sexp_read_float_tail(ctx, in, res); if (! sexp_flonump(f)) return f; if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { @@ -990,7 +1111,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { return f; } } else { - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); if ((c!=EOF) && ! is_separator(c)) return sexp_read_error(ctx, "invalid numeric syntax", sexp_list1(ctx, sexp_make_character(c)), in); @@ -1009,13 +1130,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_gc_preserve(ctx, tmp, s_tmp); scan_loop: - switch (c1 = sexp_read_char(in)) { + switch (c1 = sexp_read_char(ctx, in)) { case EOF: res = SEXP_EOF; break; case ';': sexp_port_line(in)++; - while ((c1 = sexp_read_char(in)) != EOF) + while ((c1 = sexp_read_char(ctx, in)) != EOF) if (c1 == '\n') break; /* ... FALLTHROUGH ... */ @@ -1035,11 +1156,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_list2(ctx, the_quasiquote_symbol, res); break; case ',': - if ((c1 = sexp_read_char(in)) == '@') { + if ((c1 = sexp_read_char(ctx, in)) == '@') { res = sexp_read(ctx, in); res = sexp_list2(ctx, the_unquote_splicing_symbol, res); } else { - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read(ctx, in); res = sexp_list2(ctx, the_unquote_symbol, res); } @@ -1087,7 +1208,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '#': - switch (c1=sexp_read_char(in)) { + switch (c1=sexp_read_char(ctx, in)) { case 'b': res = sexp_read_number(ctx, in, 2); break; case 'o': @@ -1108,10 +1229,10 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; case 'f': case 't': - c2 = sexp_read_char(in); + c2 = sexp_read_char(ctx, in); if (c2 == EOF || is_separator(c2)) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); - sexp_push_char(c2, in); + sexp_push_char(ctx, c2, in); } else { res = sexp_read_error(ctx, "invalid syntax #%c%c", sexp_list2(ctx, @@ -1129,7 +1250,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { else goto scan_loop; case '\\': - c1 = sexp_read_char(in); + c1 = sexp_read_char(ctx, in); res = sexp_read_symbol(ctx, in, c1, 0); if (sexp_stringp(res)) { str = sexp_string_data(res); @@ -1160,7 +1281,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '(': - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read(ctx, in); if (sexp_not(sexp_listp(ctx, res))) { if (! sexp_exceptionp(res)) { @@ -1178,14 +1299,14 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '.': - c1 = sexp_read_char(in); + c1 = sexp_read_char(ctx, in); if (c1 == EOF || is_separator(c1)) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { - sexp_push_char(c1,in ); + sexp_push_char(ctx, c1, in); res = sexp_read_float_tail(ctx, in, 0); } else { - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read_symbol(ctx, in, '.', 1); } break; @@ -1194,9 +1315,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; case '+': case '-': - c2 = sexp_read_char(in); + c2 = sexp_read_char(ctx, in); if (c2 == '.' || isdigit(c2)) { - sexp_push_char(c2, in); + sexp_push_char(ctx, c2, in); res = sexp_read_number(ctx, in, 10); if ((c1 == '-') && ! sexp_exceptionp(res)) { #if USE_FLONUMS @@ -1211,13 +1332,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_fx_mul(res, -1); } } else { - sexp_push_char(c2, in); + sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); } break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read_number(ctx, in, 10); break; default: @@ -1238,7 +1359,6 @@ sexp sexp_read (sexp ctx, sexp in) { return res; } -#if USE_STRING_STREAMS sexp sexp_read_from_string(sexp ctx, char *str) { sexp res; sexp_gc_var(ctx, s, s_s); @@ -1251,7 +1371,6 @@ sexp sexp_read_from_string(sexp ctx, char *str) { sexp_gc_release(ctx, s, s_s); return res; } -#endif void sexp_init() { int i;