From 609ca8df2e46c90f08b85bd47cac4f865fca6416 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 9 Apr 2009 00:46:21 +0900 Subject: [PATCH] preparing for preview release --- Makefile | 42 +++++++++++++++++++++--------------------- README | 26 ++++++++++++++++++++++++++ VERSION | 1 + debug.c | 5 +++-- defaults.h | 4 ++++ eval.c | 28 +++++++++++++++++++++++++--- eval.h | 5 +++-- init.scm | 10 ++++++++++ opcodes.c | 8 ++++++-- sexp.c | 8 ++++---- 10 files changed, 103 insertions(+), 34 deletions(-) create mode 100644 README create mode 100644 VERSION diff --git a/Makefile b/Makefile index 10333b68..1217f916 100644 --- a/Makefile +++ b/Makefile @@ -9,9 +9,8 @@ LIBDIR=$(PREFIX)/lib INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme -SO=.dylib LDFLAGS=-lm -CFLAGS=-Wall -g -save-temps -Os +CFLAGS=-Wall -g -Os GC_OBJ=./gc/gc.a @@ -27,12 +26,6 @@ eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -libchibisexp.$(SO): sexp.o $(GC_OBJ) - gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ - -libchibischeme.$(SO): eval.o $(GC_OBJ) - gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ -lchibisexp - chibi-scheme: main.o sexp.o $(GC_OBJ) gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ @@ -52,18 +45,25 @@ test: chibi-scheme echo "[FAIL] $${f%.scm}"; \ fi; \ done + ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm -install: chibi-scheme - cp chibi-scheme $(BINDIR)/ - mkdir -p $(MODDIR) - cp init.scm $(MODDIR)/ - mkdir -p $(INCDIR) - cp *.h $(INCDIR)/ - cp *.$(SO) $(LIBDIR)/ +# install: chibi-scheme +# cp chibi-scheme $(BINDIR)/ +# mkdir -p $(MODDIR) +# cp init.scm $(MODDIR)/ +# mkdir -p $(INCDIR) +# cp *.h $(INCDIR)/ +# cp *.$(SO) $(LIBDIR)/ -uninstall: - rm -f $(BINDIR)/chibi-scheme - rm -f $(LIBDIR)/libchibischeme.$(SO) - rm -f $(LIBDIR)/libchibisexp.$(SO) - rm -f $(INCDIR)/*.h - rm -f $(MODDIR)/*.scm +# uninstall: +# rm -f $(BINDIR)/chibi-scheme +# rm -f $(LIBDIR)/libchibischeme.$(SO) +# rm -f $(LIBDIR)/libchibisexp.$(SO) +# rm -f $(INCDIR)/*.h +# rm -f $(MODDIR)/*.scm + +dist: cleaner + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s $$f chibi-scheme-`cat VERSION`/$$f; done + tar cphzvf chibi-scheme-`cat VERSION`.tar.gz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README new file mode 100644 index 00000000..0372dfa2 --- /dev/null +++ b/README @@ -0,0 +1,26 @@ + + Chibi-Scheme + -------------- + + Simple and Minimal Scheme Implementation + + http://synthcode.com/scheme/chibi-scheme/ + + version 0.1 + April 8, 2009 + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, and string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. + +To build, just run "make". You can edit the file config.h for a +number of settings, mostly disabling features to make the executable +smaller. Documents and examples for using Chibi-Scheme as a library +for extension scripting will be provided in an upcoming release. + +syntax-rules must be loaded manually from the file syntax-rules.scm. diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..49d59571 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.1 diff --git a/debug.c b/debug.c index 299b20cc..f39ba635 100644 --- a/debug.c +++ b/debug.c @@ -3,8 +3,9 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", + {"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", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", diff --git a/defaults.h b/defaults.h index 949c117e..add20406 100644 --- a/defaults.h +++ b/defaults.h @@ -52,6 +52,10 @@ #define USE_FAST_LET 1 #endif +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 0 +#endif + #if USE_BOEHM #include "gc/include/gc.h" #define sexp_alloc GC_malloc diff --git a/eval.c b/eval.c index 8d3faadb..a5c57ca8 100644 --- a/eval.c +++ b/eval.c @@ -989,6 +989,7 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _ARG3 stack[top-3] #define _ARG4 stack[top-4] #define _ARG5 stack[top-5] +#define _ARG6 stack[top-6] #define _PUSH(x) (stack[top++]=(x)) #define _WORD0 ((sexp*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0] @@ -1020,7 +1021,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { switch (*ip++) { case OP_NOOP: break; - case OP_ERROR: + case OP_RAISE: call_error_handler: stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip); @@ -1087,8 +1088,10 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { fp = sexp_unbox_integer(tmp2); goto make_call; case OP_CALL: +#if USE_CHECK_STACK if (top >= INIT_STACK_SIZE) sexp_raise("out of stack space", SEXP_NULL); +#endif i = sexp_unbox_integer(_WORD0); tmp1 = _ARG1; make_call: @@ -1164,6 +1167,18 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { ip += sizeof(sexp); sexp_check_exception(); break; + case OP_FCALL5: + _ARG5 =((sexp_proc5)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL6: + _ARG6 =((sexp_proc6)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; case OP_EVAL: sexp_context_top(context) = top; _ARG1 = eval_in_context(_ARG1, context); @@ -1534,6 +1549,13 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { /************************ library procedures **************************/ +static sexp sexp_exception_type_func (sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception("not an exception", exn); +} + static sexp sexp_open_input_file (sexp path) { FILE *in; if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); @@ -1800,8 +1822,8 @@ void scheme_init () { if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); - the_compile_error_symbol = sexp_intern("compile-error"); - the_err_handler_symbol = sexp_intern("*current-error-handler*"); + the_compile_error_symbol = sexp_intern("compile"); + the_err_handler_symbol = sexp_intern("*current-exception-handler*"); the_cur_in_symbol = sexp_intern("*current-input-port*"); the_cur_out_symbol = sexp_intern("*current-output-port*"); the_cur_err_symbol = sexp_intern("*current-error-port*"); diff --git a/eval.h b/eval.h index 8e42e3bf..2e16def8 100644 --- a/eval.h +++ b/eval.h @@ -24,7 +24,6 @@ typedef sexp (*sexp_proc3) (sexp, sexp, sexp); typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); -typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); enum core_form_names { CORE_DEFINE = 1, @@ -54,7 +53,7 @@ enum opcode_classes { enum opcode_names { OP_NOOP, - OP_ERROR, + OP_RAISE, OP_RESUMECC, OP_CALLCC, OP_APPLY1, @@ -65,6 +64,8 @@ enum opcode_names { OP_FCALL2, OP_FCALL3, OP_FCALL4, + OP_FCALL5, + OP_FCALL6, OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, diff --git a/init.scm b/init.scm index 17f3ad5d..24d73783 100644 --- a/init.scm +++ b/init.scm @@ -264,6 +264,16 @@ (define (force x) (if (procedure? x) (x) x)) +(define (error msg . args) + (raise (make-exception 'user msg args #f #f #f))) + +(define (with-exception-handler handler thunk) + (let ((orig-handler (current-exception-handler))) + (current-exception-handler handler) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + ;; booleans (define (not x) (if x #f #t)) diff --git a/opcodes.c b/opcodes.c index aaa990ae..c0a9c93b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -9,6 +9,8 @@ #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 _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_struct opcodes[] = { @@ -58,7 +60,7 @@ _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_I _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), _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_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", 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), @@ -83,6 +85,8 @@ _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), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), @@ -95,7 +99,7 @@ _FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), _PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), _PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), _PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), -_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), #if USE_MATH _FN1(0, "exp", 0, sexp_exp), diff --git a/sexp.c b/sexp.c index 4b8e0ce5..3647261c 100644 --- a/sexp.c +++ b/sexp.c @@ -104,7 +104,7 @@ sexp sexp_make_exception (sexp kind, sexp message, sexp irritants, } sexp sexp_user_exception (sexp self, char *message, sexp irritants) { - return sexp_make_exception(sexp_intern("user-error"), + return sexp_make_exception(sexp_intern("user"), sexp_c_string(message), ((sexp_pairp(irritants) || sexp_nullp(irritants)) ? irritants : sexp_list1(irritants)), @@ -112,13 +112,13 @@ sexp sexp_user_exception (sexp self, char *message, sexp irritants) { } sexp sexp_type_exception (char *message, sexp obj) { - return sexp_make_exception(sexp_intern("type-error"), + return sexp_make_exception(sexp_intern("type"), sexp_c_string(message), sexp_list1(obj), SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); } sexp sexp_range_exception (sexp obj, sexp start, sexp end) { - return sexp_make_exception(sexp_intern("range-error"), + return sexp_make_exception(sexp_intern("range"), sexp_c_string("bad index range"), sexp_list3(obj, start, end), SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); @@ -1135,7 +1135,7 @@ void sexp_init() { the_quasiquote_symbol = sexp_intern("quasiquote"); the_unquote_symbol = sexp_intern("unquote"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); - the_read_error_symbol = sexp_intern("read-error"); + the_read_error_symbol = sexp_intern("read"); the_empty_vector = sexp_alloc_type(vector, SEXP_VECTOR); sexp_vector_length(the_empty_vector) = 0; sexp_vector_data(the_empty_vector) = NULL;