From 62c390d68e1aaac5b55ddb035c59157c9081f06d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 13 Oct 2009 18:29:18 +0900 Subject: [PATCH] initial module system --- Makefile | 6 +- debug.c | 2 +- eval.c | 48 ++++++++++------ include/chibi/bignum.h | 1 + include/chibi/config.h | 7 +++ include/chibi/eval.h | 11 +++- include/chibi/sexp.h | 1 + init.scm | 29 +++++++--- lib/srfi/1.module | 31 ++++++++++ lib/srfi/1/alists.scm | 10 ++++ lib/srfi/1/constructors.scm | 33 +++++++++++ lib/srfi/1/deletion.scm | 22 +++++++ lib/srfi/1/fold.scm | 112 ++++++++++++++++++++++++++++++++++++ lib/srfi/1/lset.scm | 48 ++++++++++++++++ lib/srfi/1/misc.scm | 58 +++++++++++++++++++ lib/srfi/1/predicates.scm | 31 ++++++++++ lib/srfi/1/search.scm | 50 ++++++++++++++++ lib/srfi/1/selectors.scm | 56 ++++++++++++++++++ main.c | 40 +++++++++---- opcodes.c | 3 + opt/bignum.c | 13 ++--- sexp.c | 17 ++++-- 22 files changed, 572 insertions(+), 57 deletions(-) create mode 100644 lib/srfi/1.module create mode 100644 lib/srfi/1/alists.scm create mode 100644 lib/srfi/1/constructors.scm create mode 100644 lib/srfi/1/deletion.scm create mode 100644 lib/srfi/1/fold.scm create mode 100644 lib/srfi/1/lset.scm create mode 100644 lib/srfi/1/misc.scm create mode 100644 lib/srfi/1/predicates.scm create mode 100644 lib/srfi/1/search.scm create mode 100644 lib/srfi/1/selectors.scm diff --git a/Makefile b/Makefile index a98fd165..001e90c5 100644 --- a/Makefile +++ b/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 diff --git a/debug.c b/debug.c index d8a51689..74c4774e 100644 --- a/debug.c +++ b/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 #include #include +#include #include #endif diff --git a/init.scm b/init.scm index 61413eda..a3b0030e 100644 --- a/init.scm +++ b/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) - (if (null? ls) - #f - (if (equal? obj (car ls)) - ls - (member obj (cdr ls))))) +(define (member obj ls . o) + (let ((eq (if (pair? o) (car o) equal?))) + (let lp ((ls ls)) + (and (pair? ls) (if (eq obj (car ls)) ls (lp (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))))))) diff --git a/lib/srfi/1.module b/lib/srfi/1.module new file mode 100644 index 00000000..1d76a116 --- /dev/null +++ b/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")) + diff --git a/lib/srfi/1/alists.scm b/lib/srfi/1/alists.scm new file mode 100644 index 00000000..ffea4bd8 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/lib/srfi/1/constructors.scm b/lib/srfi/1/constructors.scm new file mode 100644 index 00000000..836f48b5 --- /dev/null +++ b/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)))))) + diff --git a/lib/srfi/1/deletion.scm b/lib/srfi/1/deletion.scm new file mode 100644 index 00000000..721ae8c3 --- /dev/null +++ b/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) + diff --git a/lib/srfi/1/fold.scm b/lib/srfi/1/fold.scm new file mode 100644 index 00000000..8bb25b4a --- /dev/null +++ b/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) + diff --git a/lib/srfi/1/lset.scm b/lib/srfi/1/lset.scm new file mode 100644 index 00000000..dd1a0964 --- /dev/null +++ b/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) diff --git a/lib/srfi/1/misc.scm b/lib/srfi/1/misc.scm new file mode 100644 index 00000000..20011c44 --- /dev/null +++ b/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)))) + diff --git a/lib/srfi/1/predicates.scm b/lib/srfi/1/predicates.scm new file mode 100644 index 00000000..fe1dc77b --- /dev/null +++ b/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)))))))) + diff --git a/lib/srfi/1/search.scm b/lib/srfi/1/search.scm new file mode 100644 index 00000000..335faf4c --- /dev/null +++ b/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))) + )))) diff --git a/lib/srfi/1/selectors.scm b/lib/srfi/1/selectors.scm new file mode 100644 index 00000000..c6608d50 --- /dev/null +++ b/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)))) + diff --git a/main.c b/main.c index 9197f996..7f05c55e 100644 --- a/main.c +++ b/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)"); - out = sexp_eval_string(ctx, "(current-output-port)"); - err = sexp_eval_string(ctx, "(current-error-port)"); + in = sexp_eval_string(ctx, "(current-input-port)", env); + out = sexp_eval_string(ctx, "(current-output-port)", env); + 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); diff --git a/opcodes.c b/opcodes.c index e765c22b..fc2277b4 100644 --- a/opcodes.c +++ b/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), diff --git a/opt/bignum.c b/opt/bignum.c index 1a7112bd..aacdcf19 100644 --- a/opt/bignum.c +++ b/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) { - if (sexp_integerp(a)) { - return 1; - } else if (! sexp_pointerp(a)) { - return 0; - } else { - return sexp_number_type_lookup[sexp_pointer_tag(a)]; - } +static int sexp_number_type (sexp a) { + return sexp_pointerp(a) ? sexp_number_types[sexp_pointer_tag(a)] + : sexp_integerp(a); } sexp sexp_add (sexp ctx, sexp a, sexp b) { diff --git a/sexp.c b/sexp.c index ca8db254..3b057044 100644 --- a/sexp.c +++ b/sexp.c @@ -1133,20 +1133,24 @@ sexp sexp_read_raw (sexp ctx, sexp in) { goto scan_loop; case '\'': res = sexp_read(ctx, in); - res = sexp_list2(ctx, the_quote_symbol, res); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, the_quote_symbol, res); break; case '`': res = sexp_read(ctx, in); - res = sexp_list2(ctx, the_quasiquote_symbol, res); + 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); - res = sexp_list2(ctx, the_unquote_splicing_symbol, res); + 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); - res = sexp_list2(ctx, the_unquote_symbol, res); + if (! sexp_exceptionp(res)) + res = sexp_list2(ctx, the_unquote_symbol, res); } break; case '"': @@ -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);