mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 06:39:17 +02:00
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.
This commit is contained in:
Alex Shinn
parent
0581b41b1e
commit
3ecea4d666
12 changed files with 87 additions and 86 deletions
8
Makefile
8
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)
|
||||
|
|
|
|||
10
README
10
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.
|
||||
|
||||
|
|
|
|||
2
TODO
2
TODO
|
|
@ -27,7 +27,7 @@
|
|||
**- scheme-complete.el support
|
||||
*= ffi
|
||||
**+ libdl interface
|
||||
**= opcode generation interface
|
||||
**+ opcode generation interface
|
||||
**- stub generator
|
||||
*= cleanup
|
||||
*- user documentation
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
11
debug.c
11
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) {
|
||||
|
|
|
|||
47
eval.c
47
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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
2
init.scm
2
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)))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
#include <chibi/eval.h>
|
||||
|
||||
#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);
|
||||
|
||||
|
|
|
|||
33
opcodes.c
33
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),
|
||||
|
|
|
|||
18
sexp.c
18
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, "#<invalid immediate>", 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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue