initial module system

Makefile

@@ -68,10 +68,10 @@ include/chibi/install.h: Makefile
 sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
 
-eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile
+eval.o: eval.c debug.c opcodes.c $(INCLUDES) include/chibi/eval.h Makefile
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
 
-main.o: main.c $(INCLUDES) Makefile
+main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
 
 libchibi-scheme$(SO): eval.o sexp.o
@@ -84,7 +84,7 @@ chibi-scheme-static$(EXE): main.o eval.o sexp.o
 	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
 
 clean:
-	rm -f *.o *.i *.s
+	rm -f *.o *.i *.s *.8
 
 cleaner: clean
 	rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a

debug.c

@@ -63,7 +63,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
 }
 
 #ifdef DEBUG_VM
-static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) {
+static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
   int i;
   for (i=0; i<top; i++) {
     sexp_printf(ctx, out, "%s %02d: ", ((i==fp) ? "*" : " "), i);

eval.c

@@ -26,10 +26,8 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
 
 static sexp analyze (sexp ctx, sexp x);
 static void generate (sexp ctx, sexp x);
-static sexp sexp_make_env (sexp ctx);
 static sexp sexp_make_null_env (sexp ctx, sexp version);
 static sexp sexp_make_standard_env (sexp ctx, sexp version);
-static sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls);
 
 static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) {
   sexp exn;
@@ -83,7 +81,7 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) {
   return (cell ? sexp_cdr(cell) : dflt);
 }
 
-static void env_define(sexp ctx, sexp e, sexp key, sexp value) {
+void env_define(sexp ctx, sexp e, sexp key, sexp value) {
   sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e));
   if (sexp_immutablep(e)) {
     fprintf(stderr, "ERROR: immutable environment\n");
@@ -610,7 +608,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
            && sexp_nullp(sexp_cddar(ls)))) {
       res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls));
     } else {
-      proc = sexp_eval(eval_ctx, sexp_cadar(ls));
+      proc = sexp_eval(eval_ctx, sexp_cadar(ls), NULL);
       if (sexp_procedurep(proc)) {
         name = sexp_caar(ls);
         if (sexp_synclop(name) && sexp_env_global_p(sexp_context_env(bind_ctx)))
@@ -1456,7 +1454,8 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     break;
   case OP_EVAL:
     sexp_context_top(ctx) = top;
-    _ARG1 = sexp_eval(ctx, _ARG1);
+    _ARG2 = sexp_eval(ctx, _ARG1, _ARG2);
+    top--;
     sexp_check_exception();
     break;
   case OP_JUMP_UNLESS:
@@ -2041,12 +2040,16 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
   tmp = sexp_env_bindings(env);
   sexp_context_tailp(ctx2) = 0;
   if (sexp_exceptionp(in)) {
+    if (! sexp_oportp(out))
+      out = env_global_ref(sexp_context_env(ctx),
+                           the_cur_err_symbol,
+                           SEXP_FALSE);
     sexp_print_exception(ctx, in, out);
     res = in;
   } else {
     sexp_port_sourcep(in) = 1;
     while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) {
-      res = sexp_eval(ctx2, x);
+      res = sexp_eval(ctx2, x, env);
       if (sexp_exceptionp(res))
         break;
     }
@@ -2199,7 +2202,7 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) {
   return res;
 }
 
-static sexp sexp_make_env (sexp ctx) {
+sexp sexp_make_env (sexp ctx) {
   sexp e = sexp_alloc_type(ctx, env, SEXP_ENV);
   sexp_env_lambda(e) = NULL;
   sexp_env_parent(e) = NULL;
@@ -2273,15 +2276,24 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
   return e;
 }
 
-static sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) {
+sexp sexp_env_copy (sexp ctx, sexp to, sexp from, sexp ls) {
+  sexp oldname, newname;
   if (! sexp_envp(to)) to = sexp_context_env(ctx);
   if (! sexp_envp(from)) from = sexp_context_env(ctx);
-  for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
+  if (sexp_not(ls)) {
-    if (sexp_pairp(sexp_car(ls)))
+    for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls))
-      env_define(ctx, to, sexp_caar(ls), env_global_ref(from, sexp_cdar(ls), SEXP_FALSE));
+      env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls));
-    else
+  } else {
-      env_define(ctx, to, sexp_car(ls), env_global_ref(from, sexp_car(ls), SEXP_FALSE));
+    for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
-  return SEXP_UNDEF;
+      if (sexp_pairp(sexp_car(ls))) {
+        newname = sexp_caar(ls); oldname = sexp_cdar(ls);
+      } else {
+        newname = oldname = sexp_car(ls);
+      }
+      env_define(ctx, to, newname, env_global_ref(from, oldname, SEXP_FALSE));
+    }
+  }
+  return SEXP_VOID;
 }
 
 /************************** eval interface ****************************/
@@ -2325,11 +2337,11 @@ sexp sexp_compile (sexp ctx, sexp x) {
   return res;
 }
 
-sexp sexp_eval (sexp ctx, sexp obj) {
+sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
   sexp res, ctx2;
   sexp_gc_var(ctx, thunk, s_thunk);
   sexp_gc_preserve(ctx, thunk, s_thunk);
-  ctx2 = sexp_make_context(ctx, NULL, sexp_context_env(ctx));
+  ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
   sexp_context_parent(ctx2) = ctx;
   thunk = sexp_compile(ctx2, obj);
   if (sexp_exceptionp(thunk)) {
@@ -2345,12 +2357,12 @@ sexp sexp_eval (sexp ctx, sexp obj) {
   return res;
 }
 
-sexp sexp_eval_string (sexp ctx, char *str) {
+sexp sexp_eval_string (sexp ctx, char *str, sexp env) {
   sexp res;
   sexp_gc_var(ctx, obj, s_obj);
   sexp_gc_preserve(ctx, obj, s_obj);
   obj = sexp_read_from_string(ctx, str);
-  res = sexp_eval(ctx, obj);
+  res = sexp_eval(ctx, obj, env);
   sexp_gc_release(ctx, obj, s_obj);
   return res;
 }

include/chibi/bignum.h

@@ -14,6 +14,7 @@ sexp sexp_make_bignum (sexp ctx, sexp_uint_t len);
 sexp sexp_copy_bignum (sexp ctx, sexp dst, sexp a, sexp_uint_t len);
 sexp sexp_fixnum_to_bignum (sexp ctx, sexp a);
 double sexp_bignum_to_double (sexp a);
+sexp sexp_double_to_bignum (sexp ctx, double f);
 sexp sexp_bignum_fxadd (sexp ctx, sexp a, sexp_uint_t b);
 sexp sexp_bignum_fxmul (sexp ctx, sexp d, sexp a, sexp_uint_t b, int offset);
 sexp_uint_t sexp_bignum_fxdiv (sexp ctx, sexp a, sexp_uint_t b, int offset);

include/chibi/config.h

@@ -2,6 +2,9 @@
 /*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt  */
 
+/* uncomment this to disable the module system */
+/* #define USE_MODULES 0 */
+
 /* uncomment this to use the Boehm conservative GC */
 /* #define USE_BOEHM 1 */
 
@@ -52,6 +55,10 @@
 #define _GNU_SOURCE
 #endif
 
+#ifndef USE_MODULES
+#define USE_MODULES 1
+#endif
+
 #ifndef USE_BOEHM
 #define USE_BOEHM 0
 #endif

include/chibi/eval.h

@@ -13,6 +13,7 @@
 #define INIT_STACK_SIZE 8192
 
 #define sexp_init_file "init.scm"
+#define sexp_config_file "config.scm"
 
 enum core_form_names {
   CORE_DEFINE = 1,
@@ -113,16 +114,20 @@ enum opcode_names {
   OP_READ_CHAR,
   OP_PEEK_CHAR,
   OP_RET,
-  OP_DONE
+  OP_DONE,
+  OP_NUM_OPCODES
 };
 
 /**************************** prototypes ******************************/
 
 SEXP_API void sexp_scheme_init(void);
 SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args);
-SEXP_API sexp sexp_eval(sexp context, sexp obj);
+SEXP_API sexp sexp_eval(sexp context, sexp obj, sexp env);
-SEXP_API sexp sexp_eval_string(sexp context, char *str);
+SEXP_API sexp sexp_eval_string(sexp context, char *str, sexp env);
 SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env);
+SEXP_API sexp sexp_make_env(sexp context);
+SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls);
+SEXP_API void 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);
 

include/chibi/sexp.h

@@ -24,6 +24,7 @@ typedef unsigned long size_t;
 #include <string.h>
 #include <stdarg.h>
 #include <sys/types.h>
+#include <sys/stat.h>
 #include <math.h>
 #endif
 

init.scm

@@ -79,7 +79,9 @@
       (map1 proc ls '())
       (mapn proc (cons ls lol) '())))
 
-(define for-each map)
+(define (for-each f ls . lol)
+  (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls)))))
+  (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f))))
 
 (define (any pred ls)
   (if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f))
@@ -355,12 +357,10 @@
 
 (define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b))))
 
-(define (member obj ls)
+(define (member obj ls . o)
-  (if (null? ls)
+  (let ((eq (if (pair? o) (car o) equal?)))
-      #f
+    (let lp ((ls ls))
-      (if (equal? obj (car ls))
+      (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls)))))))
-          ls
-          (member obj (cdr ls)))))
 
 (define memv member)
 
@@ -542,6 +542,7 @@
         (apply consumer (cdr res))
         (consumer res))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax-rules
 
 (define-syntax syntax-rules
@@ -718,3 +719,17 @@
                  (lambda (clause) (expand-pattern (car clause) (cadr clause)))
                  forms)
                 (list (list 'error "no expansion"))))))))))
+
+(define *config-env* #f)
+
+(define-syntax import
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((mod (eval `(load-module ',(cadr expr)) *config-env*)))
+       (if (vector? mod)
+           `(%env-copy! #f
+                        (vector-ref
+                         (eval '(load-module ',(cadr expr)) *config-env*)
+                         1)
+                        ',(vector-ref mod 0))
+           `(error "couldn't find module" ',(cadr expr)))))))

lib/srfi/1.module

@@ -0,0 +1,31 @@
+
+(define-module (srfi 1)
+  (export
+   xcons cons* make-list list-tabulate list-copy circular-list iota
+   proper-list? circular-list? dotted-list? not-pair? null-list? list=
+   first second third fourth fifth sixth seventh eighth ninth tenth
+   car+cdr take drop take-right drop-right take! drop-right! split-at split-at!
+   last last-pair length+ concatenate append! concatenate! reverse!
+   append-reverse append-reverse!
+   zip unzip1 unzip2 unzip3 unzip4 unzip5 count
+   fold unfold pair-fold reduce fold-right unfold-right
+   pair-fold-right reduce-right
+   append-map append-map! map! pair-for-each filter-map map-in-order
+   filter partition remove filter! partition! remove! find find-tail any every
+   list-index take-while drop-while take-while! span break span! break!
+   delete delete-duplicates delete! delete-duplicates!
+   alist-cons alist-copy alist-delete alist-delete!
+   lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
+   lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
+   lset-diff+intersection lset-diff+intersection!)
+  (import (scheme))
+  (include "srfi/1/constructors.scm"
+           "srfi/1/predicates.scm"
+           "srfi/1/selectors.scm"
+           "srfi/1/misc.scm"
+           "srfi/1/search.scm"
+           "srfi/1/fold.scm"
+           "srfi/1/deletion.scm"
+           "srfi/1/alists.scm"
+           "srfi/1/lset.scm"))
+

lib/srfi/1/alists.scm

@@ -0,0 +1,10 @@
+
+(define (alist-cons key value ls) (cons (cons key value) ls))
+
+(define (alist-copy ls) (map (lambda (x) (cons (car x) (cdr x))) ls))
+
+(define (alist-delete key ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (remove (lambda (x) (eq (car x) key)) ls)))
+
+(define alist-delete! alist-delete)

lib/srfi/1/constructors.scm

@@ -0,0 +1,33 @@
+
+(define (xcons a b) (cons b a))
+
+(define (cons* x . args)
+  (let lp ((rev '()) (x x) (ls args))
+    (if (null? ls)
+        (append-reverse rev x)
+        (lp (cons x rev) (car ls) (cdr ls)))))
+
+(define (make-list n . o)
+  (let ((default (if (pair? o) (car o))))
+    (let lp ((n n) (res '()))
+      (if (<= n 0) res (lp (- n 1) (cons default res))))))
+
+(define (list-tabulate n proc)
+  (let lp ((n n) (res '()))
+    (if (< n 0) res (lp (- n 1) (cons (proc n) res)))))
+
+(define (list-copy ls) (reverse! (reverse ls)))
+
+(define (circular-list x . args)
+  (let ((res (cons x args)))
+    (set-cdr! (last-pair res) res)
+    res))
+
+(define (iota count . o)
+  (let ((start (if (pair? o) (car o) count))
+        (step (if (and (pair? o) (pair? (cdr o))) (cadr o) 1)))
+    (let lp ((i count) (n (- start step)) (res '()))
+      (if (<= i 0)
+          res
+          (lp (- i 1) (- n step) (cons n res))))))
+

lib/srfi/1/deletion.scm

@@ -0,0 +1,22 @@
+
+(define (delete x ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (if (eq? eq eq?)
+        (let lp ((ls ls) (rev '())) ;; fast path for delq
+          (let ((tail (memq x ls)))
+            (if tail
+                (lp (cdr tail) (take-up-to-reverse ls tail rev))
+                (if (pair? rev) (append-reverse! rev ls) ls))))
+        (filter (lambda (y) (eq x y)) ls))))
+
+(define delete! delete)
+
+(define (delete-duplicates ls . o)
+  (let ((eq (if (pair? o) (car o) equal?)))
+    (let lp ((ls ls) (res '()))
+      (if (pair? ls)
+          (lp (cdr ls) (if (member (car ls) res) res (cons (car ls) res)))
+          (reverse! res)))))
+
+(define delete-duplicates! delete-duplicates)
+

lib/srfi/1/fold.scm

@@ -0,0 +1,112 @@
+
+(define (fold kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (acc knil))
+        (if (pair? ls) (lp (cdr ls) (kons (car ls) acc)) acc))
+      (let lp ((lists (cons ls lists)) (acc knil))
+        (if (every pair? lists)
+            (lp (map cdr lists) (apply kons (map-onto car lists (list acc))))
+            acc))))
+
+(define (fold-right kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls))
+        (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
+      (let lp ((lists (cons ls lists)))
+        (if (every pair? lists)
+            (apply kons (map-onto car lists (lp (map cdr lists))))
+            knil))))
+
+(define (pair-fold kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (acc knil))
+        (if (pair? ls) (lp (cdr ls) (kons ls acc)) acc))
+      (let lp ((lists (cons ls lists)) (acc knil))
+        (if (every pair? lists)
+            (lp (map cdr lists) (apply kons (append lists (list acc))))
+            acc))))
+
+(define (pair-fold-right kons knil ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls))
+        (if (pair? ls) (kons (car ls) (lp (cdr ls))) knil))
+      (let lp ((lists (cons ls lists)))
+        (if (every pair? lists)
+            (apply kons (append lists (lp (map cdr lists))))
+            knil))))
+
+(define (reduce f identity ls)
+  (if (null? ls) identity (fold f (car ls) (cdr ls))))
+
+(define (reduce-right f identity ls)
+  (if (null? ls) identity (fold-right f (car ls) (cdr ls))))
+
+(define (unfold p f g seed . o)
+  (let lp ((seed seed))
+    (if (p seed)
+        (if (pair? o) ((car o) seed) '())
+        (cons (f seed) (lp (g seed))))))
+
+(define (unfold-right p f g seed . o)
+  (let lp ((seed seed) (res (if (pair? o) (car o) '())))
+    (if (p seed) res (lp (g seed) (cons (f seed) res)))))
+
+(define (append-map-helper append f ls lists)
+  (if (null? lists)
+      (if (null? ls)
+          '()
+          (let ((rev-ls (reverse ls)))
+            (let lp ((ls (cdr rev-ls)) (res (car rev-ls)))
+              (if (null? ls) res (lp (cdr ls) (append (f (car ls) res))))
+              )))
+      (if (and (pair? ls) (every pair lists))
+          (let lp ((lists (cons ls lists)))
+            (let ((vals (apply f (map car lists)))
+                  (cdrs (map cdr lists)))
+              (if (every pair? cdrs) (append vals (lp cdrs)) vals)))
+          '())))
+
+(define (append-map f ls . lists)
+  (append-map-helper append f ls lists))
+
+(define (append-map! f ls . lists)
+  (append-map-helper append! f ls lists))
+
+(define map! map)
+(define map-in-order map)
+
+(define (pair-for-each f ls . lists)
+  (apply pair-fold (lambda (x _) (f x)) ls lists))
+
+(define (filter-map f ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (res '()))
+        (if (pair? ls)
+            (let ((x (f (car ls)))) (lp (cdr ls) (if f (cons f res) res)))
+            (reverse! res)))
+      (filter (lambda (x) x) (apply map f ls lists))))
+
+(define (take-up-to-reverse from to init)
+  (if (eq? from to)
+      init
+      (take-up-to-reverse (cdr from) to (cons (car from) init))))
+
+(define (filter pred ls)
+  (let lp ((ls ls) (rev '()))
+    (let ((tail (find-tail pred ls)))
+      (if tail
+          (lp (cdr tail) (take-up-to-reverse ls tail rev))
+          (if (pair? rev) (append-reverse! rev ls) ls)))))
+
+(define (remove pred ls) (filter (lambda (x) (not (pred x))) ls))
+
+(define (partition pred ls)
+  (let lp ((ls ls) (good '()) (bad '()))
+    (cond ((null? ls) (values (reverse! good) (reverse! bad)))
+          ((pred (car ls)) (lp (cdr ls) (cons (car ls) good) bad))
+          (else (lp (cdr ls) good (cons (car ls) bad))))))
+
+(define filter! filter)
+(define remove! remove)
+(define partition! partition)
+

lib/srfi/1/lset.scm

@@ -0,0 +1,48 @@
+
+(define (lset<= eq . sets)
+  (if (null? sets)
+      #t
+      (let lp1 ((set1 (car sets)) (sets (cdr sets)))
+        (if (null? sets)
+            #t
+            (let ((set2 (car sets)))
+              (let lp2 ((ls set1))
+                (if (pair? ls)
+                    (and (member (car set1) set2 eq) (lp2 (cdr ls)))
+                    (lp1 set2 (cdr sets)))))))))
+
+(define (lset= eq . sets)
+  (and (apply lset<= eq sets) (apply lset<= eq (reverse sets))))
+
+(define (lset-adjoin eq set . elts)
+  (lset-union2 eq elts set))
+
+(define (lset-union2 eq a b)
+  (if (null? b)
+      a
+      (lset-union2 (cdr b) (if (member (car b) a eq) a (cons (car b) a)))))
+
+(define (lset-union eq . sets)
+  (reduce (lambda (a b) (lset-union2 eq a b)) '() sets))
+
+(define (lset-intersection eq . sets)
+  (reduce (lambda (a b) (filter (lambda (x) (member x b eq)) a)) '() sets))
+
+(define (lset-difference eq . sets)
+  (reduce (lambda (a b) (remove (lambda (x) (member x b eq)) a)) '() sets))
+
+(define (lset-xor eq . sets)
+  (reduce (lambda (a b)
+            (append (filter (lambda (x) (member x b eq)) a)
+                    (filter (lambda (x) (member x a eq)) b)))
+          '()
+          sets))
+
+(define (lset-diff+intersection eq . sets)
+  (values (apply lset-difference eq sets) (apply lset-intersection eq sets)))
+
+(define lset-diff+intersection! lset-diff+intersection)
+(define lset-xor! lset-xor)
+(define lset-difference! lset-difference)
+(define lset-intersection! lset-intersection)
+(define lset-union! lset-union)

lib/srfi/1/misc.scm

@@ -0,0 +1,58 @@
+
+(define (map-onto proc ls init)
+  (let lp ((ls ls) (res init))
+    (if (null? ls) res (lp (cdr ls) (cons (proc (car ls)) res)))))
+
+(define (length+ x)
+  (if (not (pair? x))
+      0
+      (let lp ((hare (cdr x)) (tortoise x) (res 0))
+        (and (not (eq? hare tortoise))
+             (if (pair? hare)
+                 (lp (cddr hare) (cdr tortoise) (+ res 1))
+                 res)))))
+
+(define (append! . lists) (concatenate! lists))
+
+(define (concatenate lists) (reduce-right append '() lists))
+
+(define (concatenate! lists)
+  (if (null? lists)
+      '()
+      (let lp ((ls lists))
+        (cond ((not (pair? (cdr ls)))
+               lists)
+              (else
+               (set-cdr! (last-pair (car ls)) (cadr ls))
+               (lp (cdr ls)))))))
+
+(define (append-reverse rev tail)
+  (if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
+
+(define (append-reverse! rev tail)
+  (if (null? rev)
+      tail
+      (let ((head (reverse! rev)))
+        (set-cdr! rev tail)
+        head)))
+
+(define (zip . lists) (apply map list lists))
+
+(define (unzip1 ls) (map car ls))
+(define (unzip2 ls) (values (map car ls) (map cadr ls)))
+(define (unzip3 ls) (values (map car ls) (map cadr ls) (map caddr ls)))
+(define (unzip4 ls)
+  (values (map car ls) (map cadr ls) (map caddr ls) (map cadddr ls)))
+(define (unzip5 ls)
+  (values (map car ls) (map cadr ls) (map caddr ls)
+          (map cadddr ls) (map fifth ls)))
+
+(define (count pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (res 0))
+        (if (pair? ls) (lp (cdr ls) (if (pred (car ls)) (+ res 1) res)) res))
+      (let lp ((lists (cons ls lists)) (res 0))
+        (if (every pair? lists)
+            (lp (map cdr lists) (if (apply pred (map car lists)) (+ res 1) res))
+            res))))
+

lib/srfi/1/predicates.scm

@@ -0,0 +1,31 @@
+
+(define (proper-list? x)
+  (cond ((null? x) #t)
+        ((pair? x) (proper-list? (cdr x)))
+        (else #f)))
+
+(define (circular-list? x)
+  (and (pair? x) (pair? (cdr x))
+       (let race ((hare (cdr x)) (tortoise x))
+         (or (eq? hare tortoise)
+             (and (pair? hare) (pair? (cdr hare))
+                  (race (cddr hare) (cdr tortoise)))))))
+
+(define (dotted-list? x)
+  (not (proper-list? x)))
+
+(define (not-pair? x) (not (pair? x)))
+
+(define (null-list? x) (null? x)) ; no error
+
+(define (list= eq . lists)
+  (let lp1 ((lists lists))
+    (or (null? lists)
+        (null? (cdr lists))
+        (let lp2 ((ls1 (car lists)) (ls2 (cadr lists)))
+          (if (null? ls1)
+              (and (null? ls2)
+                   (lp1 (cdr lists)))
+              (and (eq (car ls1) (car ls2))
+                   (lp2 (cdr ls1) (cdr ls2))))))))
+

lib/srfi/1/search.scm

@@ -0,0 +1,50 @@
+
+(define (find pred ls)
+  (cond ((find-tail pred ls) => car) (else #f)))
+
+(define (find-tail pred ls)
+  (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
+
+(define (take-while pred ls)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pred (car ls)))
+        (lp (cdr ls) (cons (car ls) res))
+        (reverse! res))))
+
+(define take-while! take-while)
+
+(define (drop-while pred ls)
+  (or (find-tail (lambda (x) (not (pred x))) ls) '()))
+
+(define (span pred ls)
+  (let lp ((ls ls) (res '()))
+    (if (and (pair? ls) (pred (car ls)))
+        (lp (cdr ls) (cons (car ls) res))
+        (values (reverse! res) ls))))
+
+(define span! span)
+
+(define (break pred ls) (span (lambda (x) (not (pred x))) ls))
+
+(define break! break)
+
+(define (any pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) #t (lp (cdr ls)))))
+      (let lp ((lists (cons ls lists)))
+        (and (every pair? lists)
+             (if (apply pred (map car lists)) #t (lp (map cdr lists)))))))
+
+(define (every pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls)) (if (pair? ls) (and (pred (car ls)) (lp (cdr ls))) #t))
+      (not (apply any (lambda (x) (not (pred x))) ls lists))))
+
+(define (list-index pred ls . lists)
+  (if (null? lists)
+      (let lp ((ls ls) (n 0))
+        (and (pair? ls) (if (pred (car ls)) n (lp (cdr ls) (+ n 1)))))
+      (let lp ((lists (cons ls lists)) (n 0))
+        (and (every pair? lists)
+             (if (apply pred (map car lists)) n (lp (map cdr lists) (+ n 1)))
+             ))))

lib/srfi/1/selectors.scm

@@ -0,0 +1,56 @@
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth ls)   (car (cdr (cdr (cdr (cdr ls))))))
+(define (sixth ls)   (car (cdr (cdr (cdr (cdr (cdr ls)))))))
+(define (seventh ls) (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
+(define (eighth ls)  (car (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))
+(define (ninth ls)   (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls)))))))))
+(define (tenth ls)   (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr ls))))))))))
+
+(define (car+cdr x) (values (car x) (cdr x)))
+
+(define (take ls i)
+  (let lp ((i i) (ls ls) (res '()))
+    (if (<= i 0)
+        (reverse! res)
+        (lp (- i 1) (cdr ls) (cons (car ls) res)))))
+
+(define (take! ls i)
+  (if (<= i 0)
+      '()
+      (let ((tail (list-tail ls (- i 1))))
+        (set-cdr! tail '())
+        ls)))
+
+(define (drop ls i)
+  (if (<= i 0) ls (drop (cdr ls) (- i 1))))
+
+(define (take-right ls i)
+  (drop ls (- (length+ ls) i)))
+
+(define (drop-right ls i)
+  (take ls (- (length+ ls) i)))
+
+(define (drop-right! ls i)
+  (take! ls (- (length+ ls) i)))
+
+(define (split-at ls i)
+  (let lp ((i i) (ls ls) (res '()))
+    (if (<= i 0)
+        (values (reverse! res) ls)
+        (lp (- i 1) (cdr ls) (cons (car ls) res)))))
+
+(define (split-at! ls i)
+  (if (<= i 0)
+      (values '() ls)
+      (let* ((tail (list-tail ls (- i 1)))
+             (right (cdr tail)))
+        (set-cdr! tail '())
+        (values ls right))))
+
+(define (last ls) (if (null? (cdr ls)) (car ls) (last (cdr ls))))
+(define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls))))
+

main.c

@@ -71,15 +71,33 @@ sexp sexp_load_module_file (sexp ctx, char *file, sexp env) {
   return res;
 }
 
+sexp sexp_init_environments (sexp ctx) {
+  sexp res, env;
+  sexp_gc_var(ctx, confenv, s_confenv);
+  env = sexp_context_env(ctx);
+  res = sexp_load_module_file(ctx, sexp_init_file, env);
+  if (! sexp_exceptionp(res)) {
+    res = SEXP_UNDEF;
+    sexp_gc_preserve(ctx, confenv, s_confenv);
+    confenv = sexp_make_env(ctx);
+    sexp_env_copy(ctx, confenv, env, SEXP_FALSE);
+    sexp_load_module_file(ctx, sexp_config_file, confenv);
+    env_define(ctx, env, sexp_intern(ctx, "*config-env*"), confenv);
+    env_define(ctx, confenv, sexp_intern(ctx, "*config-env*"), confenv);
+    sexp_gc_release(ctx, confenv, s_confenv);
+  }
+  return res;
+}
+
 void repl (sexp ctx) {
   sexp tmp, res, env, in, out, err;
   sexp_gc_var(ctx, obj, s_obj);
   sexp_gc_preserve(ctx, obj, s_obj);
   env = sexp_context_env(ctx);
   sexp_context_tracep(ctx) = 1;
-  in = sexp_eval_string(ctx, "(current-input-port)");
+  in = sexp_eval_string(ctx, "(current-input-port)", env);
-  out = sexp_eval_string(ctx, "(current-output-port)");
+  out = sexp_eval_string(ctx, "(current-output-port)", env);
-  err = sexp_eval_string(ctx, "(current-error-port)");
+  err = sexp_eval_string(ctx, "(current-error-port)", env);
   sexp_port_sourcep(in) = 1;
   while (1) {
     sexp_write_string(ctx, "> ", out);
@@ -92,7 +110,7 @@ void repl (sexp ctx) {
     } else {
       tmp = sexp_env_bindings(env);
       sexp_context_top(ctx) = 0;
-      res = sexp_eval(ctx, obj);
+      res = sexp_eval(ctx, obj, env);
 #if USE_WARN_UNDEFS
       sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err);
 #endif
@@ -109,11 +127,13 @@ void run_main (int argc, char **argv) {
   sexp env, out=NULL, res=SEXP_VOID, ctx;
   sexp_uint_t i, quit=0, init_loaded=0;
   sexp_gc_var(ctx, str, s_str);
+  sexp_gc_var(ctx, confenv, s_confenv);
 
   ctx = sexp_make_context(NULL, NULL, NULL);
   sexp_gc_preserve(ctx, str, s_str);
+  sexp_gc_preserve(ctx, confenv, s_confenv);
   env = sexp_context_env(ctx);
-  out = sexp_eval_string(ctx, "(current-output-port)");
+  out = sexp_eval_string(ctx, "(current-output-port)", env);
 
   /* parse options */
   for (i=1; i < argc && argv[i][0] == '-'; i++) {
@@ -121,10 +141,10 @@ void run_main (int argc, char **argv) {
     case 'e':
     case 'p':
       if (! init_loaded++)
-        sexp_load_module_file(ctx, sexp_init_file, env);
+        sexp_init_environments(ctx);
       res = sexp_read_from_string(ctx, argv[i+1]);
       if (! sexp_exceptionp(res))
-        res = sexp_eval(ctx, res);
+        res = sexp_eval(ctx, res, env);
       if (sexp_exceptionp(res)) {
         sexp_print_exception(ctx, res, out);
         quit = 1;
@@ -138,7 +158,7 @@ void run_main (int argc, char **argv) {
       break;
     case 'l':
       if (! init_loaded++)
-        sexp_load_module_file(ctx, sexp_init_file, env);
+        sexp_init_environments(ctx);
       sexp_load_module_file(ctx, argv[++i], env);
       break;
     case 'q':
@@ -154,10 +174,10 @@ void run_main (int argc, char **argv) {
 
   if (! quit) {
     if (! init_loaded)
-      res = sexp_load_module_file(ctx, sexp_init_file, env);
+      res = sexp_init_environments(ctx);
     if (res && sexp_exceptionp(res))
       sexp_print_exception(ctx, res,
-                           sexp_eval_string(ctx, "(current-error-port)"));
+                           sexp_eval_string(ctx, "(current-error-port)", env));
     if (i < argc)
       for ( ; i < argc; i++)
         res = sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env);

opcodes.c

@@ -84,9 +84,12 @@ _FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file),
 _FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file),
 _FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port),
 _FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port),
+_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),
+_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),
 _FN5(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception),

opt/bignum.c

@@ -478,18 +478,13 @@ enum sexp_number_combs {
   SEXP_NUM_BIG_BIG
 };
 
-int sexp_number_type_lookup[SEXP_NUM_TYPES] =
+static int sexp_number_types[SEXP_NUM_TYPES] =
   {0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 3, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, };
 
-int sexp_number_type (sexp a) {
+static int sexp_number_type (sexp a) {
-  if (sexp_integerp(a)) {
+  return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)]
-    return 1;
+    : sexp_integerp(a);
-  } else if (! sexp_pointerp(a)) {
-    return 0;
-  } else {
-    return sexp_number_type_lookup[sexp_pointer_tag(a)];
-  }
 }
 
 sexp sexp_add (sexp ctx, sexp a, sexp b) {

sexp.c

@@ -1133,19 +1133,23 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
     goto scan_loop;
   case '\'':
     res = sexp_read(ctx, in);
+    if (! sexp_exceptionp(res))
       res = sexp_list2(ctx, the_quote_symbol, res);
     break;
   case '`':
     res = sexp_read(ctx, in);
+    if (! sexp_exceptionp(res))
       res = sexp_list2(ctx, the_quasiquote_symbol, res);
     break;
   case ',':
     if ((c1 = sexp_read_char(ctx, in)) == '@') {
       res = sexp_read(ctx, in);
+      if (! sexp_exceptionp(res))
         res = sexp_list2(ctx, the_unquote_splicing_symbol, res);
     } else {
       sexp_push_char(ctx, c1, in);
       res = sexp_read(ctx, in);
+      if (! sexp_exceptionp(res))
         res = sexp_list2(ctx, the_unquote_symbol, res);
     }
     break;
@@ -1157,12 +1161,12 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
     res = SEXP_NULL;
     tmp = sexp_read_raw(ctx, in);
     while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) {
-      res = sexp_cons(ctx, tmp, res);
-      tmp = sexp_read_raw(ctx, in);
       if (sexp_exceptionp(tmp)) {
         res = tmp;
         break;
       }
+      res = sexp_cons(ctx, tmp, res);
+      tmp = sexp_read_raw(ctx, in);
     }
     if (! sexp_exceptionp(res)) {
       if (tmp == SEXP_RAWDOT) { /* dotted list */
@@ -1238,6 +1242,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) {
         res = tmp;
       else
         goto scan_loop;
+      break;
     case '\\':
       c1 = sexp_read_char(ctx, in);
       res = sexp_read_symbol(ctx, in, c1, 0);