From 3ecea4d66608527a445e511b61d7032343ef9ceb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Nov 2009 04:04:23 +0900 Subject: [PATCH] adding define_foreign_opt to bind C functions with optional parameters moving several opcodes to normal FFI functions, considering doing the same for all I/O opcodes. --- Makefile | 8 ++++---- README | 10 +++++++--- TODO | 2 +- config.scm | 4 ++-- debug.c | 11 ++++------- eval.c | 47 +++++++++----------------------------------- include/chibi/eval.h | 13 +++++------- include/chibi/sexp.h | 4 +++- init.scm | 2 -- lib/srfi/69/hash.c | 21 ++++++++++++++++---- opcodes.c | 33 +++++++++++++++++-------------- sexp.c | 18 ++++++++++++++++- 12 files changed, 87 insertions(+), 86 deletions(-) diff --git a/Makefile b/Makefile index f8627fe7..b6350aa3 100644 --- a/Makefile +++ b/Makefile @@ -92,7 +92,7 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) -lib/srfi/69/hash$(SO): lib/srfi/69/hash.c +lib/srfi/69/hash$(SO): lib/srfi/69/hash.c $(INCLUDES) $(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme clean: @@ -113,10 +113,10 @@ test-basic: chibi-scheme$(EXE) done test-numbers: chibi-scheme$(EXE) - ./chibi-scheme$(EXE) tests/numeric-tests.scm + LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/numeric-tests.scm -test: chibi-scheme$(EXE) - ./chibi-scheme$(EXE) tests/r5rs-tests.scm +test: all + LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH ./chibi-scheme$(EXE) tests/r5rs-tests.scm install: chibi-scheme$(EXE) mkdir -p $(DESTDIR)$(BINDIR) diff --git a/README b/README index e6c01034..9e203db2 100644 --- a/README +++ b/README @@ -72,11 +72,15 @@ function takes (not counting the context argument), and a C function. /* sexp_define_foreign(context, env, name, num_args, f) */ - sexp add1 (sexp context, sexp x) { - return sexp_fx_add(x, sexp_make_fixnum(1)); + sexp add (sexp context, sexp x, sexp y) { + return sexp_fx_add(x, y); } - sexp_define_foreign(context, env, "add1", 1, add1) + sexp_define_foreign(context, env, "add", 2, add); + +You can also define functions with a single optional argument: + + sexp_define_foreign_opt(context, env, "add", 2, add, sexp_make_fixnum(1)); See the SRFI-69 implementation for more detailed examples of this. diff --git a/TODO b/TODO index 98e4e0d6..e9cb620b 100644 --- a/TODO +++ b/TODO @@ -27,7 +27,7 @@ **- scheme-complete.el support *= ffi **+ libdl interface -**= opcode generation interface +**+ opcode generation interface **- stub generator *= cleanup *- user documentation diff --git a/config.scm b/config.scm index ebf744db..1208c201 100644 --- a/config.scm +++ b/config.scm @@ -34,7 +34,7 @@ (define (load-module-definition name) (let* ((file (module-name->file name)) (path (find-module-file name file))) - (if path (%load path *config-env*)))) + (if path (load path *config-env*)))) (define (find-module name) (cond @@ -53,7 +53,7 @@ (let ((mod2 (load-module (cadr x)))) (%env-copy! env (module-env mod2) (module-exports mod2)))) ((include) - (for-each (lambda (f) (%load (find-module-file name f) env)) (cdr x))) + (for-each (lambda (f) (load (find-module-file name f) env)) (cdr x))) ((body) (for-each (lambda (expr) (eval expr env)) (cdr x))))) (module-meta-data mod)) diff --git a/debug.c b/debug.c index 31a351df..051e4123 100644 --- a/debug.c +++ b/debug.c @@ -5,20 +5,17 @@ static const char* reverse_opcode_names[] = {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", - "EVAL", "JUMP-UNLESS", - "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", - "LOCAL-REF", "LOCAL-SET", + "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", + "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", - "LT", "LE", "EQN", "EQ", - "EXACT->INEXACT", "INEXACT->EXACT", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", - "DISPLAY", "WRITE", "WRITE-CHAR", - "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { diff --git a/eval.c b/eval.c index cc553b2f..ac694626 100644 --- a/eval.c +++ b/eval.c @@ -871,7 +871,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { num_args++; } - /* push the arguments onto the stack */ + /* push the arguments onto the stack in reverse order */ ls = ((sexp_opcode_inverse(op) && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); @@ -1401,12 +1401,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp); sexp_check_exception(); break; - case OP_EVAL: - sexp_context_top(ctx) = top; - _ARG2 = sexp_eval(ctx, _ARG1, _ARG2); - top--; - sexp_check_exception(); - break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) ip += _SWORD0; @@ -1886,24 +1880,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1)); _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); break; - case OP_DISPLAY: - if (sexp_stringp(_ARG1)) { - sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2); - _ARG2 = SEXP_VOID; - top--; - break; - } else if (sexp_charp(_ARG1)) { - sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); - _ARG2 = SEXP_VOID; - top--; - break; - } - /* ... FALLTHROUGH ... */ - case OP_WRITE: - sexp_write(ctx, _ARG1, _ARG2); - _ARG2 = SEXP_VOID; - top--; - break; case OP_WRITE_CHAR: if (! sexp_charp(_ARG1)) sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1)); @@ -1915,15 +1891,6 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_newline(ctx, _ARG1); _ARG1 = SEXP_VOID; break; - case OP_FLUSH_OUTPUT: - sexp_flush(ctx, _ARG1); - _ARG1 = SEXP_VOID; - break; - case OP_READ: - sexp_context_top(ctx) = top; - _ARG1 = sexp_read(ctx, _ARG1); - sexp_check_exception(); - break; case OP_READ_CHAR: i = sexp_read_char(ctx, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); @@ -2251,7 +2218,8 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code, return res; } -sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) { +sexp sexp_make_foreign (sexp ctx, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { sexp res; if (num_args > 6) { res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit", @@ -2260,19 +2228,22 @@ sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) { res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); sexp_opcode_class(res) = OPC_FOREIGN; sexp_opcode_code(res) = OP_FCALL1+num_args-1; + if (flags & 1) num_args--; sexp_opcode_num_args(res) = num_args; + sexp_opcode_flags(res) = flags; sexp_opcode_name(res) = name; + sexp_opcode_data(res) = data; sexp_opcode_func(res) = f; } return res; } -sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, - int num_args, sexp_proc1 f) { +sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, + int flags, sexp_proc1 f, sexp data) { sexp_gc_var1(op); sexp_gc_preserve1(ctx, op); sexp res = SEXP_VOID; - op = sexp_make_foreign(ctx, name, num_args, (sexp_proc1)f); + op = sexp_make_foreign(ctx, name, num_args, flags, f, data); if (sexp_exceptionp(op)) res = op; else diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5312893d..5137b235 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -57,7 +57,6 @@ enum opcode_names { OP_FCALL4, OP_FCALL5, OP_FCALL6, - OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, OP_PUSH, @@ -109,12 +108,8 @@ enum opcode_names { OP_INT2CHAR, OP_CHAR_UPCASE, OP_CHAR_DOWNCASE, - OP_DISPLAY, - OP_WRITE, OP_WRITE_CHAR, OP_NEWLINE, - OP_FLUSH_OUTPUT, - OP_READ, OP_READ_CHAR, OP_PEEK_CHAR, OP_RET, @@ -135,9 +130,11 @@ SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); -SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f); -SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f); -#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,(sexp_proc1)f) +SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); +SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, int flags, sexp_proc1 f, sexp data); + +#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) +#define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) #if USE_TYPE_DEFS SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d25dc6a4..7152b806 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -688,7 +688,9 @@ SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str); SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls); SEXP_API sexp sexp_make_cpointer(sexp ctx, void* value); -SEXP_API void sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_write(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_display(sexp ctx, sexp obj, sexp out); +SEXP_API sexp sexp_flush_output(sexp ctx, sexp out); SEXP_API sexp sexp_read_string(sexp ctx, sexp in); SEXP_API sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); SEXP_API sexp sexp_read_number(sexp ctx, sexp in, int base); diff --git a/init.scm b/init.scm index 14173846..b5b372e6 100644 --- a/init.scm +++ b/init.scm @@ -487,8 +487,6 @@ (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) (let* ((in (open-input-string str)) (res (proc in))) diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c index c08a3708..7be9e2d7 100644 --- a/lib/srfi/69/hash.c +++ b/lib/srfi/69/hash.c @@ -2,6 +2,7 @@ #include #define HASH_DEPTH 5 +#define HASH_BOUND sexp_make_fixnum(SEXP_MAX_FIXNUM) #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL @@ -11,6 +12,8 @@ #define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2) #define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3) +#define sexp_hash_resize_check(n, len) (((n)*3) > ((len)>>2)) + static sexp_uint_t string_hash (char *str, sexp_uint_t bound) { sexp_uint_t acc = FNV_OFFSET_BASIS; while (*str) {acc *= FNV_PRIME; acc ^= *str++;} @@ -147,6 +150,9 @@ static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) { return res; } +/* static sexp sexp_regrow_hash_table (sexp ctx, sexp ht) { */ +/* } */ + static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) { sexp_gc_var1(res); sexp_uint_t size; @@ -158,6 +164,11 @@ static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) { } else if (sexp_truep(createp)) { sexp_gc_preserve1(ctx, res); size = sexp_unbox_fixnum(sexp_hash_table_size(ht)); + /* if (sexp_hash_resize_check(size, sexp_vector_length(buckets))) { */ + /* sexp_regrow_hash_table(ctx, ht); */ + /* buckets = sexp_hash_table_buckets(ht); */ + /* i = sexp_get_bucket(ctx, ht, obj); */ + /* } */ res = sexp_cons(ctx, obj, createp); sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i))); sexp_hash_table_size(ht) = sexp_make_fixnum(size+1); @@ -171,6 +182,8 @@ static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) { i=sexp_get_bucket(ctx, ht, obj), p, res; res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn); if (sexp_pairp(res)) { + sexp_hash_table_size(ht) + = sexp_fx_sub(sexp_hash_table_size(ht), sexp_make_fixnum(1)); if (res == sexp_vector_ref(buckets, i)) { sexp_vector_set(buckets, i, sexp_cdr(res)); } else { @@ -184,10 +197,10 @@ static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) { sexp sexp_init_library (sexp ctx, sexp env) { - sexp_define_foreign(ctx, env, "string-hash", 2, sexp_string_hash); - sexp_define_foreign(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash); - sexp_define_foreign(ctx, env, "hash", 2, sexp_hash); - sexp_define_foreign(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity); + sexp_define_foreign_opt(ctx, env, "string-hash", 2, sexp_string_hash, HASH_BOUND); + sexp_define_foreign_opt(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash, HASH_BOUND); + sexp_define_foreign_opt(ctx, env, "hash", 2, sexp_hash, HASH_BOUND); + sexp_define_foreign_opt(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity, HASH_BOUND); sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell); sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete); diff --git a/opcodes.c b/opcodes.c index 4e135bf8..c11154b9 100644 --- a/opcodes.c +++ b/opcodes.c @@ -2,15 +2,18 @@ #define _OP(c,o,n,m,t,u,i,s,d,f) \ {.tag=SEXP_OPCODE, \ .value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}} -#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc1)p) -#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) -#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) -#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d) -#define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d) -#define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d) -#define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d) -#define _FN5(t, u, s, f, d) _FN(OP_FCALL5, 5, 0, t, u, s, f, d) -#define _FN6(t, u, s, f, d) _FN(OP_FCALL6, 6, 0, t, u, s, f, d) +#define _FN(o,n,m,t,u,s,d,f) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, d, (sexp_proc1)f) +#define _FN0(s, d, f) _FN(OP_FCALL0, 0, 0, 0, 0, s, d, f) +#define _FN1(t, s, d, f) _FN(OP_FCALL1, 1, 0, t, 0, s, d, f) +#define _FN1OPT(t, s, d, f) _FN(OP_FCALL1, 0, 1, t, u, s, d, f) +#define _FN1OPTP(t, s, d, f) _FN(OP_FCALL1, 0, 3, t, 0, s, d, f) +#define _FN2(t, u, s, d, f) _FN(OP_FCALL2, 2, 0, t, u, s, d, f) +#define _FN2OPT(t, u, s, d, f) _FN(OP_FCALL2, 1, 1, t, u, s, d, f) +#define _FN2OPTP(t, u, s, d, f) _FN(OP_FCALL2, 1, 3, t, u, s, d, f) +#define _FN3(t, u, s, d, f) _FN(OP_FCALL3, 3, 0, t, u, s, d, f) +#define _FN4(t, u, s, d, f) _FN(OP_FCALL4, 4, 0, t, u, s, d, f) +#define _FN5(t, u, s, d, f) _FN(OP_FCALL5, 5, 0, t, u, s, d, f) +#define _FN6(t, u, s, d, f) _FN(OP_FCALL6, 6, 0, t, u, s, d, f) #define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_struct opcodes[] = { @@ -61,15 +64,14 @@ _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", sexp_make_fixn _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), _OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), -_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), -_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN1OPTP(SEXP_IPORT, "read", (sexp)"*current-input-port*", sexp_read), +_FN2OPTP(0, SEXP_OPORT, "write", (sexp)"*current-output-port*", sexp_write), +_FN2OPTP(0, SEXP_OPORT, "display", (sexp)"*current-output-port*", sexp_display), +_FN1OPTP(SEXP_OPORT, "flush-output", (sexp)"*current-output-port*", sexp_flush_output), _FN2(0, 0, "equal?", 0, sexp_equalp), _FN1(0, "list?", 0, sexp_listp), _FN1(0, "identifier?", 0, sexp_identifierp), @@ -88,7 +90,8 @@ _FN1(SEXP_STRING, "file-exists?", 0, sexp_file_exists_p), _FN0("make-environment", 0, sexp_make_env), _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), -_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2OPTP(0, SEXP_ENV, "eval", (sexp)"*interaction-environment*", sexp_eval), +_FN2OPTP(SEXP_STRING, SEXP_ENV, "load", (sexp)"*interaction-environment*", sexp_load), _FN3(SEXP_ENV, SEXP_ENV, "%env-copy!", 0, sexp_env_copy), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), diff --git a/sexp.c b/sexp.c index dd8dac2b..ea068bf4 100644 --- a/sexp.c +++ b/sexp.c @@ -863,7 +863,7 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { return p; } -void sexp_write (sexp ctx, sexp obj, sexp out) { +sexp sexp_write (sexp ctx, sexp obj, sexp out) { unsigned long len, c, res; long i=0; double f; @@ -1026,6 +1026,22 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { sexp_write_string(ctx, "#", out); } } + return SEXP_VOID; +} + +sexp sexp_display (sexp ctx, sexp obj, sexp out) { + if (sexp_stringp(obj)) + sexp_write_string(ctx, sexp_string_data(obj), out); + else if (sexp_charp(obj)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else + sexp_write(ctx, obj, out); + return SEXP_VOID; +} + +sexp sexp_flush_output (sexp ctx, sexp out) { + sexp_flush(ctx, out); + return SEXP_VOID; } #define INIT_STRING_BUFFER_SIZE 128