From 450548e3e2cfb26842349b3afef58c5b3e34e733 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 16:37:58 +0900 Subject: [PATCH] store difference between ip and bytecode start instead of the raw ip, which may overflow the integer range. --- .hgignore | 1 + Makefile | 24 +++--- README | 41 ++++++++-- eval.c | 23 +++--- include/chibi/sexp.h | 8 +- init.scm | 177 +++++++++++++++++++++++++++++++++++++++++ sexp.c | 6 +- syntax-rules.scm | 182 ------------------------------------------- 8 files changed, 247 insertions(+), 215 deletions(-) delete mode 100644 syntax-rules.scm diff --git a/.hgignore b/.hgignore index 05828695..9d217d26 100644 --- a/.hgignore +++ b/.hgignore @@ -4,6 +4,7 @@ syntax: glob *.s *.o *.so +*.dylib *.dSYM *.orig .hg diff --git a/Makefile b/Makefile index 7606ca9f..8566af34 100644 --- a/Makefile +++ b/Makefile @@ -37,14 +37,14 @@ endif ifdef USE_BOEHM GCLDFLAGS := -lgc -CPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 else GCLDFLAGS := -CPPFLAGS := $(CPPFLAGS) -Iinclude +XCPPFLAGS := $(CPPFLAGS) -Iinclude endif -LDFLAGS := $(LDFLAGS) -lm -CFLAGS := $(CFLAGS) -Wall -O2 -g +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := $(CFLAGS) -Wall -O2 -g INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h @@ -52,22 +52,22 @@ include/chibi/install.h: Makefile echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ sexp.o: sexp.c gc.c $(INCLUDES) Makefile - $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile - $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< main.o: main.c $(INCLUDES) Makefile - $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< libchibi-scheme$(SO): eval.o sexp.o - $(CC) $(CLIBFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) chibi-scheme$(EXE): main.o libchibi-scheme$(SO) - $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< -L. -lchibi-scheme + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme chibi-scheme-static$(EXE): main.o eval.o sexp.o - $(CC) $(CFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) clean: rm -f *.o *.i *.s @@ -87,12 +87,12 @@ test-basic: chibi-scheme done test: chibi-scheme - ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm + ./chibi-scheme tests/r5rs-tests.scm install: chibi-scheme cp chibi-scheme $(BINDIR)/ mkdir -p $(MODDIR) - cp init.scm syntax-rules.scm $(MODDIR)/ + cp init.scm $(MODDIR)/ mkdir -p $(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/ mkdir -p $(LIBDIR) diff --git a/README b/README index d5f2b369..bfd07571 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ Chibi-Scheme -------------- - Simple and Minimal Scheme Implementation + Minimal Scheme Implementation for use as an Extension Language http://synthcode.com/wiki/chibi-scheme/ @@ -15,9 +15,38 @@ macros based on syntactic-closures, 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. +To build, just run "make". This will provide a shared library +"libchibi-scheme", as well as a sample "chibi-scheme" command-line +repl. The "chibi-scheme-static" make target builds an equivalent +static executable. + +You can edit the file config.h for a number of settings, mostly +disabling features to make the executable smaller. You can specify +standard options directly as arguments to make, for example + + make CFLAGS=-Os + +to optimize for size, or + + make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include + +to compile against a library installed in /usr/local. + +By default Chibi uses a custom, precise, non-moving GC. You can link +against the Boehm conservative GC by editing the config file, or +directly from make with: + + make USE_BOEHM=1 + +See the file main.c for an example of using chibi-scheme as a library. +The essential functions to remember are: + + sexp_make_context(NULL, NULL, NULL) + returns a new context + + sexp_eval(context, expr) + evaluates an s-expression + + sexp_eval_string(context, str) + reads an s-expression from str and evaluates it -syntax-rules must be loaded manually from the file syntax-rules.scm. diff --git a/eval.c b/eval.c index 50e9efb5..f920fae6 100644 --- a/eval.c +++ b/eval.c @@ -1245,7 +1245,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_RAISE: call_error_handler: stack[top] = (sexp) 1; - stack[top+1] = sexp_make_integer(ip); + stack[top+1] = sexp_make_integer(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_integer(fp); top += 4; @@ -1269,7 +1269,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_CALLCC: stack[top] = sexp_make_integer(1); - stack[top+1] = sexp_make_integer(ip); + stack[top+1] = sexp_make_integer(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_integer(fp); tmp1 = _ARG1; @@ -1298,10 +1298,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { /* save frame info */ tmp2 = stack[fp+3]; j = sexp_unbox_integer(stack[fp]); - ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); self = stack[fp+2]; - cp = sexp_procedure_vars(self); bc = sexp_procedure_vars(self); + cp = sexp_procedure_vars(self); + ip = (sexp_bytecode_data(bc) + + sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); /* copy new args into place */ for (k=0; k>SEXP_FIXNUM_BITS) +#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) -#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) #if USE_FLONUMS #define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) diff --git a/init.scm b/init.scm index f6cf0b94..72ecb2b1 100644 --- a/init.scm +++ b/init.scm @@ -529,3 +529,180 @@ (if (and (pair? res) (eq? *values-tag* (car res))) (apply consumer (cdr res)) (consumer res)))) + +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse")) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) (if (memq x (list _quote lits)) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list 'error "no expansion")))))))))) diff --git a/sexp.c b/sexp.c index bd1a851b..5835c5b6 100644 --- a/sexp.c +++ b/sexp.c @@ -53,6 +53,8 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } +#if ! USE_BOEHM + #define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \ {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}} @@ -90,11 +92,11 @@ static struct sexp_struct sexp_types[] = { #undef _DEF_TYPE -#if ! USE_BOEHM #if ! USE_MALLOC #include "gc.c" #endif -#endif + +#endif /* ! USE_BOEHM */ /***************************** exceptions *****************************/ diff --git a/syntax-rules.scm b/syntax-rules.scm deleted file mode 100644 index 468c4bdf..00000000 --- a/syntax-rules.scm +++ /dev/null @@ -1,182 +0,0 @@ - -(define-syntax syntax-rules - (er-macro-transformer - (lambda (expr rename compare) - (let ((lits (cadr expr)) - (forms (cddr expr)) - (count 0) - (_er-macro-transformer (rename 'er-macro-transformer)) - (_lambda (rename 'lambda)) (_let (rename 'let)) - (_begin (rename 'begin)) (_if (rename 'if)) - (_and (rename 'and)) (_or (rename 'or)) - (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) - (_car (rename 'car)) (_cdr (rename 'cdr)) - (_cons (rename 'cons)) (_pair? (rename 'pair?)) - (_null? (rename 'null?)) (_expr (rename 'expr)) - (_rename (rename 'rename)) (_compare (rename 'compare)) - (_quote (rename 'quote)) (_apply (rename 'apply)) - (_append (rename 'append)) (_map (rename 'map)) - (_vector? (rename 'vector?)) (_list? (rename 'list?)) - (_lp (rename 'lp)) (_reverse (rename 'reverse)) - (_vector->list (rename 'vector->list)) - (_list->vector (rename 'list->vector))) - (define (next-v) - (set! count (+ count 1)) - (rename (string->symbol (string-append "v." (number->string count))))) - (define (expand-pattern pat tmpl) - (let lp ((p (cdr pat)) - (x (list _cdr _expr)) - (dim 0) - (vars '()) - (k (lambda (vars) - (or (expand-template tmpl vars) - (list _begin #f))))) - (let ((v (next-v))) - (list - _let (list (list v x)) - (cond - ((identifier? p) - (if (any (lambda (l) (compare p l)) lits) - (list _and (list _compare v (list _quote p)) (k vars)) - (list _let (list (list p v)) (k (cons (cons p dim) vars))))) - ((ellipse? p) - (cond - ((not (null? (cddr p))) - (error "non-trailing ellipse")) - ((identifier? (car p)) - (list _and (list _list? v) - (list _let (list (list (car p) v)) - (k (cons (cons (car p) (+ 1 dim)) vars))))) - (else - (let* ((w (next-v)) - (new-vars (all-vars (car p) (+ dim 1))) - (ls-vars (map (lambda (x) - (rename - (string->symbol - (string-append - (symbol->string - (identifier->symbol (car x))) - "-ls")))) - new-vars)) - (once - (lp (car p) (list _car w) (+ dim 1) '() - (lambda (_) - (cons - _lp - (cons - (list _cdr w) - (map (lambda (x l) - (list _cons (car x) l)) - new-vars - ls-vars))))))) - (list - _let - _lp (cons (list w v) - (map (lambda (x) (list x '())) ls-vars)) - (list _if (list _null? w) - (list _let (map (lambda (x l) - (list (car x) (list _reverse l))) - new-vars - ls-vars) - (k (append new-vars vars))) - (list _and (list _pair? w) once))))))) - ((pair? p) - (list _and (list _pair? v) - (lp (car p) - (list _car v) - dim - vars - (lambda (vars) - (lp (cdr p) (list _cdr v) dim vars k))))) - ((vector? p) - (list _and - (list _vector? v) - (lp (vector->list p) (list _vector->list v) dim vars k))) - ((null? p) (list _and (list _null? v) (k vars))) - (else (list _and (list _equal? v p) (k vars)))))))) - (define (ellipse? x) - (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) - (define (ellipse-depth x) - (if (ellipse? x) - (+ 1 (ellipse-depth (cdr x))) - 0)) - (define (ellipse-tail x) - (if (ellipse? x) - (ellipse-tail (cdr x)) - (cdr x))) - (define (all-vars x dim) - (let lp ((x x) (dim dim) (vars '())) - (cond ((identifier? x) (if (memq x (list _quote lits)) - vars - (cons (cons x dim) vars))) - ((ellipse? x) (lp (car x) (+ dim 1) vars)) - ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) - ((vector? x) (lp (vector->list x) dim vars)) - (else vars)))) - (define (free-vars x vars dim) - (let lp ((x x) (free '())) - (cond - ((identifier? x) - (if (and (not (memq x free)) - (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) - (else #f))) - (cons x free) - free)) - ((pair? x) (lp (car x) (lp (cdr x) free))) - ((vector? x) (lp (vector->list x) free)) - (else free)))) - (define (expand-template tmpl vars) - (let lp ((t tmpl) (dim 0)) - (cond - ((identifier? t) - (cond - ((assq t vars) - => (lambda (cell) - (if (<= (cdr cell) dim) - t - (error "too few ...'s")))) - (else - (list _rename (list _quote t))))) - ((pair? t) - (if (ellipse? t) - (let* ((depth (ellipse-depth t)) - (ell-dim (+ dim depth)) - (ell-vars (free-vars (car t) vars ell-dim))) - (if (null? ell-vars) - (error "too many ...'s") - (let* ((once (lp (car t) ell-dim)) - (nest (if (and (null? (cdr ell-vars)) - (identifier? once) - (eq? once (car vars))) - once ;; shortcut - (cons _map - (cons (list _lambda ell-vars once) - ell-vars)))) - (many (do ((d depth (- d 1)) - (many nest - (list _apply _append many))) - ((= d 1) many)))) - (if (null? (ellipse-tail t)) - many ;; shortcut - (list _append many (lp (ellipse-tail t) dim)))))) - (list _cons (lp (car t) dim) (lp (cdr t) dim)))) - ((vector? t) (list _list->vector (lp (vector->list t) dim))) - ((null? t) (list _quote '())) - (else t)))) - (list - _er-macro-transformer - (list _lambda (list _expr _rename _compare) - (cons - _or - (append - (map - (lambda (clause) (expand-pattern (car clause) (cadr clause))) - forms) - (list (list 'error "no expansion")))))))))) - -;; Local Variables: -;; eval: (put '_lambda 'scheme-indent-function 1) -;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent) -;; eval: (put '_if 'scheme-indent-function 3) -;; End: -