preparing for preview release

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
+# install: chibi-scheme
-	cp chibi-scheme $(BINDIR)/
+# 	cp chibi-scheme $(BINDIR)/
-	mkdir -p $(MODDIR)
+# 	mkdir -p $(MODDIR)
-	cp init.scm $(MODDIR)/
+# 	cp init.scm $(MODDIR)/
-	mkdir -p $(INCDIR)
+# 	mkdir -p $(INCDIR)
-	cp *.h $(INCDIR)/
+# 	cp *.h $(INCDIR)/
-	cp *.$(SO) $(LIBDIR)/
+# 	cp *.$(SO) $(LIBDIR)/
 
-uninstall:
+# uninstall:
-	rm -f $(BINDIR)/chibi-scheme
+# 	rm -f $(BINDIR)/chibi-scheme
-	rm -f $(LIBDIR)/libchibischeme.$(SO)
+# 	rm -f $(LIBDIR)/libchibischeme.$(SO)
-	rm -f $(LIBDIR)/libchibisexp.$(SO)
+# 	rm -f $(LIBDIR)/libchibisexp.$(SO)
-	rm -f $(INCDIR)/*.h
+# 	rm -f $(INCDIR)/*.h
-	rm -f $(MODDIR)/*.scm
+# 	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`

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.

VERSION

@@ -0,0 +1 @@
+0.1

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",
+  {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
-   "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS",
+   "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",

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

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_compile_error_symbol = sexp_intern("compile");
-    the_err_handler_symbol = sexp_intern("*current-error-handler*");
+    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*");

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,

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))

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),

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;