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

initial module system

Browse source
This commit is contained in:
Alex Shinn 2009-10-13 18:29:18 +09:00
parent 6376198e92
commit 62c390d68e
22 changed files with 572 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Makefile
View file

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

2
debug.c
View file

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

48
eval.c
View file

@ -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_pairp(sexp_car(ls)))
env_define(ctx, to, sexp_caar(ls), env_global_ref(from, sexp_cdar(ls), SEXP_FALSE));
else
env_define(ctx, to, sexp_car(ls), env_global_ref(from, sexp_car(ls), SEXP_FALSE));
return SEXP_UNDEF;
if (sexp_not(ls)) {
for (ls=sexp_env_bindings(from); sexp_pairp(ls); ls=sexp_cdr(ls))
env_define(ctx, to, sexp_caar(ls), sexp_cdar(ls));
} else {
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
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;
}

1
include/chibi/bignum.h
View file

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

7
include/chibi/config.h
View file

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

11
include/chibi/eval.h
View file

@ -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_string(sexp context, char *str);
SEXP_API sexp sexp_eval(sexp context, sexp obj, sexp env);
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);

1
include/chibi/sexp.h
View file

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

29
init.scm
View file

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

31
lib/srfi/1.module Normal file
View file

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

10
lib/srfi/1/alists.scm Normal file
View file

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

33
lib/srfi/1/constructors.scm Normal file
View file

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

22
lib/srfi/1/deletion.scm Normal file
View file

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

112
lib/srfi/1/fold.scm Normal file
View file

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

48
lib/srfi/1/lset.scm Normal file
View file

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

58
lib/srfi/1/misc.scm Normal file
View file

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

31
lib/srfi/1/predicates.scm Normal file
View file

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

50
lib/srfi/1/search.scm Normal file
View file

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

56
lib/srfi/1/selectors.scm Normal file
View file

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

40
main.c
View file

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

3
opcodes.c
View file

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

13
opt/bignum.c
View file

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

17
sexp.c
View file

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