Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 21:47:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

switching to linking as a library

Browse source
This commit is contained in:
Alex Shinn 2009-06-20 21:57:28 +09:00
parent 56dcf497de
commit 24d9bfc950
8 changed files with 170 additions and 115 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

62
Makefile
View file

@ -1,29 +1,65 @@
# -*- makefile-gmake -*-
.PHONY: all doc dist clean cleaner test install uninstall .PHONY: all doc dist clean cleaner test install uninstall
all: chibi-scheme all: chibi-scheme
PREFIX=/usr/local CC ?= cc
PREFIX ?= /usr/local
BINDIR=$(PREFIX)/bin BINDIR=$(PREFIX)/bin
LIBDIR=$(PREFIX)/lib LIBDIR=$(PREFIX)/lib
INCDIR=$(PREFIX)/include/chibi-scheme INCDIR=$(PREFIX)/include/chibi
MODDIR=$(PREFIX)/share/chibi-scheme MODDIR=$(PREFIX)/share/chibi
LDFLAGS=-lm #-lgc -L/opt/local/lib ifndef PLATFORM
ifeq ($(shell uname),Darwin)
PLATFORM=macosx
else
PLATFORM=unix
endif
endif
CFLAGS=-Wall -O2 -g #-I/opt/local/include #-save-temps ifeq ($(PLATFORM),macosx)
SO = .dylib
EXE =
CLIBFLAGS = -dynamiclib
else ifeq ($(PLATFORM),mingw)
SO = .dll
EXE = .exe
CLIBFLAGS = -fPIC shared
else
SO = .so
EXE =
CLIBFLAGS = -fPIC -shared
endif
sexp.o: sexp.c gc.c sexp.h config.h Makefile ifdef USE_BOEHM
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< GCLDFLAGS := -lgc
else
GCLDFLAGS :=
endif
eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile LDFLAGS := $(LDFLAGS) -lm
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< CPPFLAGS := $(CPPFLAGS) -Iinclude
CFLAGS := $(CFLAGS) -Wall -O2 -g
main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile sexp.o: sexp.c gc.c include/chibi/sexp.h include/chibi/config.h Makefile
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
chibi-scheme: main.o sexp.o eval.o: eval.c debug.c opcodes.c include/chibi/eval.h include/chibi/sexp.h include/chibi/config.h Makefile
gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
main.o: main.c eval.c debug.c opcodes.c include/chibi/eval.h include/chibi/sexp.h include/chibi/config.h Makefile
$(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
libchibi-scheme$(SO): eval.o sexp.o
$(CC) -dynamiclib -o $@ $^
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
$(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< $(LDFLAGS) $(GCLDFLAGS) -L. -lchibi-scheme
chibi-scheme-static$(EXE): main.o eval.o sexp.o
$(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS)
clean: clean:
rm -f *.o *.i *.s rm -f *.o *.i *.s

75
eval.c
View file

@ -2,7 +2,7 @@
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include "eval.h" #include "chibi/eval.h"
/************************************************************************/ /************************************************************************/
@ -248,7 +248,7 @@ static sexp sexp_make_lit(sexp ctx, sexp value) {
#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE)
static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
sexp_gc_var(ctx, res, save_res); sexp_gc_var(ctx, res, save_res);
if (ctx) sexp_gc_preserve(ctx, res, save_res); if (ctx) sexp_gc_preserve(ctx, res, save_res);
res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT);
@ -279,7 +279,7 @@ static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) {
return res; return res;
} }
static sexp sexp_make_child_context(sexp context, sexp lambda) { sexp sexp_make_child_context(sexp context, sexp lambda) {
sexp ctx = sexp_make_context(context, sexp ctx = sexp_make_context(context,
sexp_context_stack(context), sexp_context_stack(context),
sexp_context_env(context)); sexp_context_env(context));
@ -582,7 +582,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
&& sexp_nullp(sexp_cddar(ls)))) { && sexp_nullp(sexp_cddar(ls)))) {
res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls));
} else { } else {
proc = eval_in_context(eval_ctx, sexp_cadar(ls)); proc = sexp_eval(eval_ctx, sexp_cadar(ls));
if (sexp_exceptionp(proc)) { if (sexp_exceptionp(proc)) {
res = proc; res = proc;
break; break;
@ -697,7 +697,7 @@ static sexp analyze (sexp ctx, sexp object) {
tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL);
tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp);
tmp = sexp_cons(ctx, x, tmp); tmp = sexp_cons(ctx, x, tmp);
x = apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), x = sexp_apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)),
sexp_macro_proc(op), sexp_macro_proc(op),
tmp); tmp);
/* if (in_repl_p) sexp_debug(" => ", x, ctx); */ /* if (in_repl_p) sexp_debug(" => ", x, ctx); */
@ -1216,7 +1216,7 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) {
goto call_error_handler;} \ goto call_error_handler;} \
while (0) while (0)
sexp vm (sexp ctx, sexp proc) { sexp sexp_vm (sexp ctx, sexp proc) {
sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc);
sexp env = sexp_context_env(ctx), sexp env = sexp_context_env(ctx),
*stack = sexp_stack_data(sexp_context_stack(ctx)); *stack = sexp_stack_data(sexp_context_stack(ctx));
@ -1414,7 +1414,7 @@ sexp vm (sexp ctx, sexp proc) {
break; break;
case OP_EVAL: case OP_EVAL:
sexp_context_top(ctx) = top; sexp_context_top(ctx) = top;
_ARG1 = eval_in_context(ctx, _ARG1); _ARG1 = sexp_eval(ctx, _ARG1);
sexp_check_exception(); sexp_check_exception();
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
@ -1830,7 +1830,7 @@ static sexp sexp_close_port (sexp ctx, sexp port) {
return SEXP_VOID; return SEXP_VOID;
} }
static void sexp_warn_undefs (sexp from, sexp to, sexp out) { void sexp_warn_undefs (sexp from, sexp to, sexp out) {
sexp x; sexp x;
for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x))
if (sexp_cdar(x) == SEXP_UNDEF) { if (sexp_cdar(x) == SEXP_UNDEF) {
@ -1862,7 +1862,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
res = in; res = in;
} else { } else {
while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) {
res = eval_in_context(ctx2, x); res = sexp_eval(ctx2, x);
if (sexp_exceptionp(res)) if (sexp_exceptionp(res))
break; break;
} }
@ -2013,23 +2013,26 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) {
static sexp sexp_make_standard_env (sexp ctx, sexp version) { static sexp sexp_make_standard_env (sexp ctx, sexp version) {
sexp_uint_t i; sexp_uint_t i;
sexp cell, sym; sexp ctx2, cell, sym, perr_cell, err_cell;
sexp_gc_var(ctx, e, s_e); sexp_gc_var(ctx, e, s_e);
sexp_gc_var(ctx, op, s_op); sexp_gc_var(ctx, op, s_op);
sexp_gc_var(ctx, tmp, s_tmp);
sexp_gc_var(ctx, err_handler, s_err);
sexp_gc_preserve(ctx, e, s_e); sexp_gc_preserve(ctx, e, s_e);
sexp_gc_preserve(ctx, op, s_op); sexp_gc_preserve(ctx, op, s_op);
sexp_gc_preserve(ctx, tmp, s_tmp);
sexp_gc_preserve(ctx, err_handler, s_err);
e = sexp_make_null_env(ctx, version); e = sexp_make_null_env(ctx, version);
for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) {
/* op = &opcodes[i]; */
op = sexp_copy_opcode(ctx, &opcodes[i]); op = sexp_copy_opcode(ctx, &opcodes[i]);
if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) {
/* op = sexp_copy_opcode(ctx, op); */
sym = sexp_intern(ctx, (char*)sexp_opcode_default(op)); sym = sexp_intern(ctx, (char*)sexp_opcode_default(op));
cell = env_cell_create(ctx, e, sym, SEXP_VOID); cell = env_cell_create(ctx, e, sym, SEXP_VOID);
sexp_opcode_default(op) = cell; sexp_opcode_default(op) = cell;
} }
env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op);
} }
/* add io port and interaction env parameters */
env_define(ctx, e, the_cur_in_symbol, env_define(ctx, e, the_cur_in_symbol,
sexp_make_input_port(ctx, stdin, SEXP_FALSE)); sexp_make_input_port(ctx, stdin, SEXP_FALSE));
env_define(ctx, e, the_cur_out_symbol, env_define(ctx, e, the_cur_out_symbol,
@ -2037,13 +2040,35 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
env_define(ctx, e, the_cur_err_symbol, env_define(ctx, e, the_cur_err_symbol,
sexp_make_output_port(ctx, stderr, SEXP_FALSE)); sexp_make_output_port(ctx, stderr, SEXP_FALSE));
env_define(ctx, e, the_interaction_env_symbol, e); env_define(ctx, e, the_interaction_env_symbol, e);
/* add default exception handler */
err_cell = env_cell(e, the_cur_err_symbol);
perr_cell = env_cell(e, sexp_intern(ctx, "print-exception"));
ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), e);
sexp_context_tailp(ctx2) = 0;
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
emit(ctx2, OP_GLOBAL_KNOWN_REF);
emit_word(ctx2, (sexp_uint_t)err_cell);
emit(ctx2, OP_LOCAL_REF);
emit_word(ctx2, 0);
emit(ctx2, OP_FCALL2);
emit_word(ctx2, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)));
}
emit_push(ctx2, SEXP_VOID);
emit(ctx2, OP_DONE);
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
err_handler = sexp_make_procedure(ctx2,
sexp_make_integer(0),
sexp_make_integer(0),
finalize_bytecode(ctx2),
tmp);
env_define(ctx2, e, the_err_handler_symbol, err_handler);
sexp_gc_release(ctx, e, s_e); sexp_gc_release(ctx, e, s_e);
return e; return e;
} }
/************************** eval interface ****************************/ /************************** eval interface ****************************/
sexp apply (sexp ctx, sexp proc, sexp args) { sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
sexp ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp ls, *stack = sexp_stack_data(sexp_context_stack(ctx));
sexp_sint_t top = sexp_context_top(ctx), offset; sexp_sint_t top = sexp_context_top(ctx), offset;
offset = top + sexp_unbox_integer(sexp_length(ctx, args)); offset = top + sexp_unbox_integer(sexp_length(ctx, args));
@ -2055,10 +2080,10 @@ sexp apply (sexp ctx, sexp proc, sexp args) {
stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID);
stack[top++] = sexp_make_integer(0); stack[top++] = sexp_make_integer(0);
return vm(ctx, proc); return sexp_vm(ctx, proc);
} }
sexp compile (sexp ctx, sexp x) { sexp sexp_compile (sexp ctx, sexp x) {
sexp_gc_var(ctx, ast, s_ast); sexp_gc_var(ctx, ast, s_ast);
sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_var(ctx, ctx2, s_ctx2);
sexp_gc_var(ctx, vec, s_vec); sexp_gc_var(ctx, vec, s_vec);
@ -2084,11 +2109,11 @@ sexp compile (sexp ctx, sexp x) {
return res; return res;
} }
sexp eval_in_context (sexp ctx, sexp obj) { sexp sexp_eval (sexp ctx, sexp obj) {
sexp res; sexp res;
sexp_gc_var(ctx, thunk, s_thunk); sexp_gc_var(ctx, thunk, s_thunk);
sexp_gc_preserve(ctx, thunk, s_thunk); sexp_gc_preserve(ctx, thunk, s_thunk);
thunk = compile(ctx, obj); thunk = sexp_compile(ctx, obj);
if (sexp_exceptionp(thunk)) { if (sexp_exceptionp(thunk)) {
sexp_print_exception(ctx, thunk, sexp_print_exception(ctx, thunk,
env_global_ref(sexp_context_env(ctx), env_global_ref(sexp_context_env(ctx),
@ -2096,19 +2121,23 @@ sexp eval_in_context (sexp ctx, sexp obj) {
SEXP_FALSE)); SEXP_FALSE));
res = thunk; res = thunk;
} else { } else {
res = apply(ctx, thunk, SEXP_NULL); res = sexp_apply(ctx, thunk, SEXP_NULL);
} }
sexp_gc_release(ctx, thunk, s_thunk); sexp_gc_release(ctx, thunk, s_thunk);
return res; return res;
} }
sexp eval (sexp obj, sexp env) { sexp sexp_eval_string (sexp ctx, char *str) {
sexp ctx = sexp_make_context(NULL, NULL, NULL); sexp res;
sexp_context_env(ctx) = env; sexp_gc_var(ctx, obj, s_obj);
return eval_in_context(ctx, obj); sexp_gc_preserve(ctx, obj, s_obj);
obj = sexp_read_from_string(ctx, str);
res = sexp_eval(ctx, obj);
sexp_gc_release(ctx, obj, s_obj);
return res;
} }
void scheme_init () { void sexp_scheme_init () {
sexp ctx; sexp ctx;
if (! scheme_initialized_p) { if (! scheme_initialized_p) {
scheme_initialized_p = 1; scheme_initialized_p = 1;

2
gc.c
View file

@ -2,7 +2,7 @@
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include "sexp.h" #include "chibi/sexp.h"
#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
#define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MAXIMUM_HEAP_SIZE 0

8
config.h → include/chibi/config.h
View file

@ -14,7 +14,7 @@
/* uncomment this if you only want fixnum support */ /* uncomment this if you only want fixnum support */
/* #define USE_FLONUMS 0 */ /* #define USE_FLONUMS 0 */
/* uncomment this if you want immediate flonums (experimental) */ /* uncomment this if you want immediate flonums */
/* #define USE_IMMEDIATE_FLONUMS 1 */ /* #define USE_IMMEDIATE_FLONUMS 1 */
/* uncomment this if you don't need extended math operations */ /* uncomment this if you don't need extended math operations */
@ -32,8 +32,8 @@
/* uncomment this to disable string ports */ /* uncomment this to disable string ports */
/* #define USE_STRING_STREAMS 0 */ /* #define USE_STRING_STREAMS 0 */
/* uncomment this to disable stack checks */ /* uncomment this to enable stack overflow checks */
/* #define USE_CHECK_STACK 0 */ /* #define USE_CHECK_STACK 1 */
/* uncomment this to enable debugging utilities */ /* uncomment this to enable debugging utilities */
/* #define USE_DEBUG 1 */ /* #define USE_DEBUG 1 */
@ -101,6 +101,6 @@
#endif #endif
#ifndef USE_CHECK_STACK #ifndef USE_CHECK_STACK
#define USE_CHECK_STACK 1 #define USE_CHECK_STACK 0
#endif #endif

12
eval.h → include/chibi/eval.h
View file

@ -14,8 +14,6 @@
#define sexp_init_file "init.scm" #define sexp_init_file "init.scm"
#define sexp_debug(msg, obj, ctx) (sexp_write_string(msg,env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write(obj, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write_char('\n',env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)))
/* procedure types */ /* procedure types */
typedef sexp (*sexp_proc0) (); typedef sexp (*sexp_proc0) ();
typedef sexp (*sexp_proc1) (sexp); typedef sexp (*sexp_proc1) (sexp);
@ -130,9 +128,13 @@ enum opcode_names {
/**************************** prototypes ******************************/ /**************************** prototypes ******************************/
sexp apply(sexp proc, sexp args, sexp context); SEXP_API void sexp_scheme_init();
sexp eval_in_context(sexp expr, sexp context); SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args);
sexp eval(sexp expr, sexp env); SEXP_API sexp sexp_eval(sexp context, sexp obj);
SEXP_API sexp sexp_eval_string(sexp context, char *str);
SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env);
SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env);
SEXP_API void sexp_warn_undefs (sexp from, sexp to, sexp out);
#endif /* ! SEXP_EVAL_H */ #endif /* ! SEXP_EVAL_H */

78
sexp.h → include/chibi/sexp.h
View file

@ -16,6 +16,10 @@
#include <sys/types.h> #include <sys/types.h>
#include <math.h> #include <math.h>
#ifndef SEXP_API
#define SEXP_API extern
#endif
/* tagging system /* tagging system
* bits end in 00: pointer * bits end in 00: pointer
* 01: fixnum * 01: fixnum
@ -511,43 +515,43 @@ sexp sexp_make_flonum(sexp ctx, double f);
#define sexp_scanf(p, ...) (fscanf(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))) #define sexp_flush(p) (fflush(sexp_port_stream(p)))
sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
sexp sexp_cons(sexp ctx, sexp head, sexp tail); SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail);
sexp sexp_list2(sexp ctx, sexp a, sexp b); SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b);
sexp sexp_equalp (sexp ctx, sexp a, sexp b); SEXP_API sexp sexp_equalp (sexp ctx, sexp a, sexp b);
sexp sexp_listp(sexp ctx, sexp obj); SEXP_API sexp sexp_listp(sexp ctx, sexp obj);
sexp sexp_reverse(sexp ctx, sexp ls); SEXP_API sexp sexp_reverse(sexp ctx, sexp ls);
sexp sexp_nreverse(sexp ctx, sexp ls); SEXP_API sexp sexp_nreverse(sexp ctx, sexp ls);
sexp sexp_append2(sexp ctx, sexp a, sexp b); SEXP_API sexp sexp_append2(sexp ctx, sexp a, sexp b);
sexp sexp_memq(sexp ctx, sexp x, sexp ls); SEXP_API sexp sexp_memq(sexp ctx, sexp x, sexp ls);
sexp sexp_assq(sexp ctx, sexp x, sexp ls); SEXP_API sexp sexp_assq(sexp ctx, sexp x, sexp ls);
sexp sexp_length(sexp ctx, sexp ls); SEXP_API sexp sexp_length(sexp ctx, sexp ls);
sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); SEXP_API sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen);
sexp sexp_make_string(sexp ctx, sexp len, sexp ch); SEXP_API sexp sexp_make_string(sexp ctx, sexp len, sexp ch);
sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); SEXP_API sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end);
sexp sexp_intern(sexp ctx, char *str); SEXP_API sexp sexp_intern(sexp ctx, char *str);
sexp sexp_string_to_symbol(sexp ctx, sexp str); SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str);
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
sexp sexp_list_to_vector(sexp ctx, sexp ls); SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls);
sexp sexp_vector(sexp ctx, int count, ...); SEXP_API sexp sexp_vector(sexp ctx, int count, ...);
void sexp_write(sexp obj, sexp out); SEXP_API void sexp_write(sexp obj, sexp out);
sexp sexp_read_string(sexp ctx, sexp in); SEXP_API sexp sexp_read_string(sexp ctx, sexp in);
sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); SEXP_API sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp);
sexp sexp_read_number(sexp ctx, sexp in, int base); SEXP_API sexp sexp_read_number(sexp ctx, sexp in, int base);
sexp sexp_read_raw(sexp ctx, sexp in); SEXP_API sexp sexp_read_raw(sexp ctx, sexp in);
sexp sexp_read(sexp ctx, sexp in); SEXP_API sexp sexp_read(sexp ctx, sexp in);
sexp sexp_read_from_string(sexp ctx, char *str); SEXP_API sexp sexp_read_from_string(sexp ctx, char *str);
sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name);
sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); SEXP_API sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name);
sexp sexp_make_input_string_port(sexp ctx, sexp str); SEXP_API sexp sexp_make_input_string_port(sexp ctx, sexp str);
sexp sexp_make_output_string_port(sexp ctx); SEXP_API sexp sexp_make_output_string_port(sexp ctx);
sexp sexp_get_output_string(sexp ctx, sexp port); SEXP_API sexp sexp_get_output_string(sexp ctx, sexp port);
sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); SEXP_API sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line);
sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj);
sexp sexp_type_exception (sexp ctx, char *message, sexp obj); SEXP_API sexp sexp_type_exception (sexp ctx, char *message, sexp obj);
sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
void sexp_init(); SEXP_API void sexp_init();
#endif /* ! SEXP_H */ #endif /* ! SEXP_H */

41
main.c
View file

@ -1,5 +1,8 @@
/* main.c -- chibi-scheme command-line app using */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "eval.c" #include "chibi/eval.h"
void repl (sexp ctx) { void repl (sexp ctx) {
sexp tmp, res, env, in, out, err; sexp tmp, res, env, in, out, err;
@ -7,9 +10,9 @@ void repl (sexp ctx) {
sexp_gc_preserve(ctx, obj, s_obj); sexp_gc_preserve(ctx, obj, s_obj);
env = sexp_context_env(ctx); env = sexp_context_env(ctx);
sexp_context_tracep(ctx) = 1; sexp_context_tracep(ctx) = 1;
in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); in = sexp_eval_string(ctx, "(current-input-port)");
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); out = sexp_eval_string(ctx, "(current-output-port)");
err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); err = sexp_eval_string(ctx, "(current-error-port)");
while (1) { while (1) {
sexp_write_string("> ", out); sexp_write_string("> ", out);
sexp_flush(out); sexp_flush(out);
@ -21,7 +24,7 @@ void repl (sexp ctx) {
} else { } else {
tmp = sexp_env_bindings(env); tmp = sexp_env_bindings(env);
sexp_context_top(ctx) = 0; sexp_context_top(ctx) = 0;
res = eval_in_context(ctx, obj); res = sexp_eval(ctx, obj);
#if USE_WARN_UNDEFS #if USE_WARN_UNDEFS
sexp_warn_undefs(sexp_env_bindings(env), tmp, err); sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
#endif #endif
@ -35,34 +38,14 @@ void repl (sexp ctx) {
} }
void run_main (int argc, char **argv) { void run_main (int argc, char **argv) {
sexp env, out=NULL, res, ctx, perr_cell, err_cell, err_handler; sexp env, out=NULL, res, ctx;
sexp_uint_t i, quit=0, init_loaded=0; sexp_uint_t i, quit=0, init_loaded=0;
sexp_gc_var(ctx, str, s_str); sexp_gc_var(ctx, str, s_str);
ctx = sexp_make_context(NULL, NULL, NULL); ctx = sexp_make_context(NULL, NULL, NULL);
sexp_gc_preserve(ctx, str, s_str); sexp_gc_preserve(ctx, str, s_str);
env = sexp_context_env(ctx); env = sexp_context_env(ctx);
env_define(ctx, env, the_interaction_env_symbol, env); out = sexp_eval_string(ctx, "(current-output-port)");
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
err_cell = env_cell(env, the_cur_err_symbol);
perr_cell = env_cell(env, sexp_intern(ctx, "print-exception"));
sexp_context_tailp(ctx) = 0;
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
emit(ctx, OP_GLOBAL_KNOWN_REF);
emit_word(ctx, (sexp_uint_t)err_cell);
emit(ctx, OP_LOCAL_REF);
emit_word(ctx, 0);
emit(ctx, OP_FCALL2);
emit_word(ctx, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)));
}
emit_push(ctx, SEXP_VOID);
emit(ctx, OP_DONE);
err_handler = sexp_make_procedure(ctx,
sexp_make_integer(0),
sexp_make_integer(0),
finalize_bytecode(ctx),
sexp_make_vector(ctx, 0, SEXP_VOID));
env_define(ctx, env, the_err_handler_symbol, err_handler);
/* parse options */ /* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) { for (i=1; i < argc && argv[i][0] == '-'; i++) {
@ -74,7 +57,7 @@ void run_main (int argc, char **argv) {
sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env);
res = sexp_read_from_string(ctx, argv[i+1]); res = sexp_read_from_string(ctx, argv[i+1]);
if (! sexp_exceptionp(res)) if (! sexp_exceptionp(res))
res = eval_in_context(ctx, res); res = sexp_eval(ctx, res);
if (sexp_exceptionp(res)) { if (sexp_exceptionp(res)) {
sexp_print_exception(ctx, res, out); sexp_print_exception(ctx, res, out);
} else if (argv[i][1] == 'p') { } else if (argv[i][1] == 'p') {
@ -112,7 +95,7 @@ void run_main (int argc, char **argv) {
} }
int main (int argc, char **argv) { int main (int argc, char **argv) {
scheme_init(); sexp_scheme_init();
run_main(argc, argv); run_main(argc, argv);
return 0; return 0;
} }

3
sexp.c
View file

@ -2,7 +2,8 @@
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */ /* BSD-style license: http://synthcode.com/license.txt */
#include "sexp.h" #define SEXP_API
#include "chibi/sexp.h"
/* optional huffman-compressed immediate symbols */ /* optional huffman-compressed immediate symbols */
#if USE_HUFF_SYMS #if USE_HUFF_SYMS