mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-12 23:47:34 +02:00
store difference between ip and bytecode start instead of the
raw ip, which may overflow the integer range.
This commit is contained in:
Alex Shinn
parent
b9f4668027
commit
450548e3e2
8 changed files with 247 additions and 215 deletions
|
|
@ -4,6 +4,7 @@ syntax: glob
|
|||
*.s
|
||||
*.o
|
||||
*.so
|
||||
*.dylib
|
||||
*.dSYM
|
||||
*.orig
|
||||
.hg
|
||||
|
|
|
|||
24
Makefile
24
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)
|
||||
|
|
|
|||
41
README
41
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.
|
||||
|
|
|
|||
23
eval.c
23
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<i; k++)
|
||||
stack[fp-j+k] = stack[top-1-i+k];
|
||||
|
|
@ -1355,7 +1356,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
i++;
|
||||
}
|
||||
_ARG1 = sexp_make_integer(i);
|
||||
stack[top] = sexp_make_integer(ip+sizeof(sexp));
|
||||
stack[top] = sexp_make_integer(ip+sizeof(sexp)-sexp_bytecode_data(bc));
|
||||
stack[top+1] = self;
|
||||
stack[top+2] = sexp_make_integer(fp);
|
||||
top += 3;
|
||||
|
|
@ -1775,9 +1776,9 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
i = sexp_unbox_integer(stack[fp]);
|
||||
stack[fp-i] = _ARG1;
|
||||
top = fp-i+1;
|
||||
ip = (unsigned char*) sexp_unbox_integer(stack[fp+1]);
|
||||
self = stack[fp+2];
|
||||
bc = sexp_procedure_code(self);
|
||||
ip = sexp_bytecode_data(bc) + sexp_unbox_integer(stack[fp+1]);
|
||||
cp = sexp_procedure_vars(self);
|
||||
fp = sexp_unbox_integer(stack[fp+3]);
|
||||
break;
|
||||
|
|
@ -2077,8 +2078,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
stack[top] = sexp_make_integer(top);
|
||||
top++;
|
||||
sexp_context_top(ctx) = top + 3;
|
||||
stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
|
||||
stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID);
|
||||
stack[top++] = sexp_make_integer(0);
|
||||
stack[top++] = final_resumer;
|
||||
stack[top++] = sexp_make_integer(0);
|
||||
return sexp_vm(ctx, proc);
|
||||
}
|
||||
|
|
@ -2160,6 +2161,10 @@ void sexp_scheme_init () {
|
|||
continuation_resumer = finalize_bytecode(ctx);
|
||||
ctx = sexp_make_child_context(ctx, NULL);
|
||||
emit(ctx, OP_DONE);
|
||||
final_resumer = finalize_bytecode(ctx);
|
||||
final_resumer = sexp_make_procedure(ctx,
|
||||
sexp_make_integer(0),
|
||||
sexp_make_integer(0),
|
||||
finalize_bytecode(ctx),
|
||||
sexp_make_vector(ctx, 0, SEXP_VOID));
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -326,11 +326,11 @@ sexp sexp_make_flonum(sexp ctx, double f);
|
|||
#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
|
||||
#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1)
|
||||
|
||||
#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)n)<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
|
||||
#define sexp_unbox_integer(n) (((sexp_sint_t)n)>>SEXP_FIXNUM_BITS)
|
||||
#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)(n))<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
|
||||
#define sexp_unbox_integer(n) (((sexp_sint_t)(n))>>SEXP_FIXNUM_BITS)
|
||||
|
||||
#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
|
||||
#define sexp_unbox_character(n) ((int) (((sexp_sint_t)n)>>SEXP_EXTENDED_BITS))
|
||||
#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
|
||||
#define sexp_unbox_character(n) ((int) (((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)))
|
||||
|
|
|
|||
177
init.scm
177
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"))))))))))
|
||||
|
|
|
|||
6
sexp.c
6
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 *****************************/
|
||||
|
||||
|
|
|
|||
182
syntax-rules.scm
182
syntax-rules.scm
|
|
@ -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:
|
||||
|
||||
Loading…
Add table
Reference in a new issue