mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
DESTDIR patch from sladegen
This commit is contained in:
Alex Shinn
commit
55a8a38e62
41 changed files with 6886 additions and 0 deletions
20
.hgignore
Normal file
20
.hgignore
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
syntax: glob
|
||||
*~
|
||||
*.i
|
||||
*.s
|
||||
*.o
|
||||
*.so
|
||||
*.dylib
|
||||
*.dSYM
|
||||
*.orig
|
||||
.hg
|
||||
junk*
|
||||
*.tar.gz
|
||||
*.tar.bz2
|
||||
*.log
|
||||
*.err
|
||||
*.out
|
||||
gc
|
||||
gc6.8
|
||||
chibi-scheme
|
||||
include/chibi/install.h
|
||||
118
Makefile
Normal file
118
Makefile
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
# -*- makefile-gmake -*-
|
||||
|
||||
.PHONY: all doc dist clean cleaner test install uninstall
|
||||
|
||||
all: chibi-scheme
|
||||
|
||||
CC ?= cc
|
||||
PREFIX ?= /usr/local
|
||||
BINDIR ?= $(PREFIX)/bin
|
||||
LIBDIR ?= $(PREFIX)/lib
|
||||
INCDIR ?= $(PREFIX)/include/chibi
|
||||
MODDIR ?= $(PREFIX)/share/chibi
|
||||
|
||||
DESTDIR ?=
|
||||
|
||||
ifndef PLATFORM
|
||||
ifeq ($(shell uname),Darwin)
|
||||
PLATFORM=macosx
|
||||
else
|
||||
PLATFORM=unix
|
||||
endif
|
||||
endif
|
||||
|
||||
ifeq ($(PLATFORM),macosx)
|
||||
SO = .dylib
|
||||
EXE =
|
||||
CLIBFLAGS = -dynamiclib
|
||||
STATICFLAGS = -static-libgcc
|
||||
else
|
||||
ifeq ($(PLATFORM),mingw)
|
||||
SO = .dll
|
||||
EXE = .exe
|
||||
CLIBFLAGS = -fPIC -shared
|
||||
else
|
||||
SO = .so
|
||||
EXE =
|
||||
CLIBFLAGS = -fPIC -shared
|
||||
STATICFLAGS = -static
|
||||
endif
|
||||
endif
|
||||
|
||||
ifdef USE_BOEHM
|
||||
GCLDFLAGS := -lgc
|
||||
XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1
|
||||
else
|
||||
GCLDFLAGS :=
|
||||
XCPPFLAGS := $(CPPFLAGS) -Iinclude
|
||||
endif
|
||||
|
||||
XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm
|
||||
XCFLAGS := -Wall -g $(CFLAGS)
|
||||
|
||||
INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h
|
||||
|
||||
include/chibi/install.h: Makefile
|
||||
echo '#define sexp_module_dir "'$(MODDIR)'"' > $@
|
||||
|
||||
sexp.o: sexp.c gc.c $(INCLUDES) Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||
|
||||
main.o: main.c $(INCLUDES) Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
|
||||
|
||||
libchibi-scheme$(SO): eval.o sexp.o
|
||||
$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
|
||||
|
||||
chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
|
||||
$(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
|
||||
|
||||
chibi-scheme-static$(EXE): main.o eval.o sexp.o
|
||||
$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
|
||||
|
||||
clean:
|
||||
rm -f *.o *.i *.s
|
||||
|
||||
cleaner: clean
|
||||
rm -f chibi-scheme chibi-scheme-static *$(SO)
|
||||
rm -rf *.dSYM
|
||||
|
||||
test-basic: chibi-scheme
|
||||
@for f in tests/basic/*.scm; do \
|
||||
./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
|
||||
if diff -q $${f%.scm}.out $${f%.scm}.res; then \
|
||||
echo "[PASS] $${f%.scm}"; \
|
||||
else \
|
||||
echo "[FAIL] $${f%.scm}"; \
|
||||
fi; \
|
||||
done
|
||||
|
||||
test: chibi-scheme
|
||||
./chibi-scheme tests/r5rs-tests.scm
|
||||
|
||||
install: chibi-scheme
|
||||
mkdir -p $(DESTDIR)$(BINDIR)
|
||||
cp chibi-scheme $(DESTDIR)$(BINDIR)/
|
||||
mkdir -p $(DESTDIR)$(MODDIR)
|
||||
cp init.scm $(DESTDIR)$(MODDIR)/
|
||||
mkdir -p $(DESTDIR)$(INCDIR)
|
||||
cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/
|
||||
mkdir -p $(DESTDIR)$(LIBDIR)
|
||||
cp libchibi-scheme$(SO) $(DESTDIR)$(LIBDIR)/
|
||||
if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi
|
||||
|
||||
uninstall:
|
||||
rm -f $(BINDIR)/chibi-scheme*
|
||||
rm -f $(LIBDIR)/libchibi-scheme$(SO)
|
||||
cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h
|
||||
rm -f $(MODDIR)/*.scm
|
||||
|
||||
dist: cleaner
|
||||
rm -f chibi-scheme-`cat VERSION`.tgz
|
||||
mkdir chibi-scheme-`cat VERSION`
|
||||
for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done
|
||||
tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
|
||||
rm -rf chibi-scheme-`cat VERSION`
|
||||
52
README
Normal file
52
README
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
|
||||
Chibi-Scheme
|
||||
--------------
|
||||
|
||||
Minimal Scheme Implementation for use as an Extension Language
|
||||
|
||||
http://synthcode.com/wiki/chibi-scheme/
|
||||
|
||||
|
||||
Chibi-Scheme is a very small but mostly complete R5RS Scheme
|
||||
implementation using a reasonably fast custom VM. Chibi-Scheme tries
|
||||
as much as possible not to trade its small size by cutting corners,
|
||||
and provides full continuations, both low and high-level hygienic
|
||||
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". 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
|
||||
|
||||
1
VERSION
Normal file
1
VERSION
Normal file
|
|
@ -0,0 +1 @@
|
|||
0.2
|
||||
75
debug.c
Normal file
75
debug.c
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
/* debug.c -- optional debugging utilities */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
static const char* reverse_opcode_names[] =
|
||||
{"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
|
||||
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6",
|
||||
"EVAL", "JUMP-UNLESS",
|
||||
"JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF",
|
||||
"LOCAL-REF", "LOCAL-SET",
|
||||
"CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
|
||||
"STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND",
|
||||
"NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
|
||||
"EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
|
||||
"MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE",
|
||||
"LT", "LE", "EQN", "EQ",
|
||||
"EXACT->INEXACT", "INEXACT->EXACT",
|
||||
"CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
|
||||
"DISPLAY", "WRITE", "WRITE-CHAR",
|
||||
"NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE",
|
||||
};
|
||||
|
||||
static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) {
|
||||
unsigned char *ip, opcode;
|
||||
if (sexp_procedurep(bc))
|
||||
bc = sexp_procedure_code(bc);
|
||||
ip = sexp_bytecode_data(bc);
|
||||
loop:
|
||||
opcode = *ip++;
|
||||
if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) {
|
||||
sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]);
|
||||
} else {
|
||||
sexp_printf(ctx, out, " <unknown> %d ", opcode);
|
||||
}
|
||||
switch (opcode) {
|
||||
case OP_STACK_REF:
|
||||
case OP_LOCAL_REF:
|
||||
case OP_LOCAL_SET:
|
||||
case OP_CLOSURE_REF:
|
||||
case OP_JUMP:
|
||||
case OP_JUMP_UNLESS:
|
||||
case OP_FCALL0:
|
||||
case OP_FCALL1:
|
||||
case OP_FCALL2:
|
||||
case OP_FCALL3:
|
||||
case OP_TYPEP:
|
||||
sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]);
|
||||
ip += sizeof(sexp);
|
||||
break;
|
||||
case OP_GLOBAL_REF:
|
||||
case OP_GLOBAL_KNOWN_REF:
|
||||
case OP_TAIL_CALL:
|
||||
case OP_CALL:
|
||||
case OP_PUSH:
|
||||
sexp_write(ctx, ((sexp*)ip)[0], out);
|
||||
ip += sizeof(sexp);
|
||||
break;
|
||||
}
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
|
||||
goto loop;
|
||||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
#ifdef DEBUG_VM
|
||||
static void sexp_print_stack (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);
|
||||
sexp_write(ctx, stack[i], out);
|
||||
sexp_printf(ctx, out, "\n");
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
237
gc.c
Normal file
237
gc.c
Normal file
|
|
@ -0,0 +1,237 @@
|
|||
/* gc.c -- simple mark&sweep garbage collector */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#include "chibi/sexp.h"
|
||||
|
||||
#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024)
|
||||
#define SEXP_MAXIMUM_HEAP_SIZE 0
|
||||
#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair))
|
||||
#define SEXP_GROW_HEAP_RATIO 0.7
|
||||
|
||||
#define sexp_heap_align(n) sexp_align(n, 4)
|
||||
|
||||
typedef struct sexp_free_list *sexp_free_list;
|
||||
struct sexp_free_list {
|
||||
sexp_uint_t size;
|
||||
sexp_free_list next;
|
||||
};
|
||||
|
||||
typedef struct sexp_heap *sexp_heap;
|
||||
struct sexp_heap {
|
||||
sexp_uint_t size;
|
||||
sexp_free_list free_list;
|
||||
sexp_heap next;
|
||||
char *data;
|
||||
};
|
||||
|
||||
static sexp_heap heap;
|
||||
|
||||
#if USE_DEBUG_GC
|
||||
static sexp* stack_base;
|
||||
#endif
|
||||
|
||||
extern sexp continuation_resumer, final_resumer;
|
||||
|
||||
static sexp_heap sexp_heap_last (sexp_heap h) {
|
||||
while (h->next) h = h->next;
|
||||
return h;
|
||||
}
|
||||
|
||||
sexp_uint_t sexp_allocated_bytes (sexp x) {
|
||||
sexp_uint_t res, *len_ptr;
|
||||
sexp t;
|
||||
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT))
|
||||
return sexp_heap_align(1);
|
||||
t = &(sexp_type_specs[sexp_pointer_tag(x)]);
|
||||
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t));
|
||||
res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t);
|
||||
return res;
|
||||
}
|
||||
|
||||
void sexp_mark (sexp x) {
|
||||
sexp_uint_t *len_ptr;
|
||||
sexp_sint_t i, len;
|
||||
sexp t, *p;
|
||||
struct sexp_gc_var_t *saves;
|
||||
loop:
|
||||
if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x))
|
||||
return;
|
||||
sexp_gc_mark(x) = 1;
|
||||
if (sexp_contextp(x))
|
||||
for (saves=sexp_context_saves(x); saves; saves=saves->next)
|
||||
if (saves->var) sexp_mark(*(saves->var));
|
||||
t = &(sexp_type_specs[sexp_pointer_tag(x)]);
|
||||
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
|
||||
len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t));
|
||||
len = sexp_type_field_len_base(t)
|
||||
+ len_ptr[0]*sexp_type_field_len_scale(t) - 1;
|
||||
if (len >= 0) {
|
||||
for (i=0; i<len; i++)
|
||||
sexp_mark(p[i]);
|
||||
x = p[len];
|
||||
goto loop;
|
||||
}
|
||||
}
|
||||
|
||||
#if USE_DEBUG_GC
|
||||
int stack_references_pointer_p (sexp ctx, sexp x) {
|
||||
sexp *p;
|
||||
for (p=(&x)+1; p<stack_base; p++)
|
||||
if (*p == x)
|
||||
return 1;
|
||||
return 0;
|
||||
}
|
||||
#else
|
||||
#define stack_references_pointer_p(ctx, x) 0
|
||||
#endif
|
||||
|
||||
sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
|
||||
size_t freed, max_freed=0, sum_freed=0, size;
|
||||
sexp_heap h = heap;
|
||||
sexp p;
|
||||
sexp_free_list q, r, s;
|
||||
char *end;
|
||||
/* scan over the whole heap */
|
||||
for ( ; h; h=h->next) {
|
||||
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
|
||||
q = h->free_list;
|
||||
end = (char*)h->data + h->size;
|
||||
while (((char*)p) < end) {
|
||||
/* find the preceding and succeeding free list pointers */
|
||||
for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
|
||||
;
|
||||
if ((char*)r == (char*)p) {
|
||||
p = (sexp) (((char*)p) + r->size);
|
||||
continue;
|
||||
}
|
||||
size = sexp_heap_align(sexp_allocated_bytes(p));
|
||||
if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) {
|
||||
sum_freed += size;
|
||||
if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
|
||||
/* merge q with p */
|
||||
if (r && ((((char*)p)+size) == (char*)r)) {
|
||||
/* ... and with r */
|
||||
q->next = r->next;
|
||||
freed = q->size + size + r->size;
|
||||
p = (sexp) (((char*)p) + size + r->size);
|
||||
} else {
|
||||
freed = q->size + size;
|
||||
p = (sexp) (((char*)p)+size);
|
||||
}
|
||||
q->size = freed;
|
||||
} else {
|
||||
s = (sexp_free_list)p;
|
||||
if (r && ((((char*)p)+size) == (char*)r)) {
|
||||
/* merge p with r */
|
||||
s->size = size + r->size;
|
||||
s->next = r->next;
|
||||
q->next = s;
|
||||
freed = size + r->size;
|
||||
} else {
|
||||
s->size = size;
|
||||
s->next = r;
|
||||
q->next = s;
|
||||
freed = size;
|
||||
}
|
||||
p = (sexp) (((char*)p)+freed);
|
||||
}
|
||||
if (freed > max_freed)
|
||||
max_freed = freed;
|
||||
} else {
|
||||
sexp_gc_mark(p) = 0;
|
||||
p = (sexp) (((char*)p)+size);
|
||||
}
|
||||
}
|
||||
}
|
||||
sum_freed_ptr[0] = sum_freed;
|
||||
return sexp_make_integer(max_freed);
|
||||
}
|
||||
|
||||
sexp sexp_gc (sexp ctx, size_t *sum_freed) {
|
||||
sexp res;
|
||||
int i;
|
||||
sexp_mark(continuation_resumer);
|
||||
sexp_mark(final_resumer);
|
||||
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
|
||||
sexp_mark(sexp_symbol_table[i]);
|
||||
sexp_mark(ctx);
|
||||
res = sexp_sweep(ctx, sum_freed);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp_heap sexp_make_heap (size_t size) {
|
||||
sexp_free_list free, next;
|
||||
sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size);
|
||||
if (! h)
|
||||
errx(70, "out of memory allocating %zu byte heap, aborting\n", size);
|
||||
h->size = size;
|
||||
h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data));
|
||||
free = h->free_list = (sexp_free_list) h->data;
|
||||
h->next = NULL;
|
||||
next = (sexp_free_list) ((char*)free + sexp_heap_align(sexp_sizeof(pair)));
|
||||
free->size = 0; /* actually sexp_sizeof(pair) */
|
||||
free->next = next;
|
||||
next->size = size - sexp_heap_align(sexp_sizeof(pair));
|
||||
next->next = NULL;
|
||||
return h;
|
||||
}
|
||||
|
||||
int sexp_grow_heap (sexp ctx, size_t size) {
|
||||
size_t cur_size, new_size;
|
||||
sexp_heap h = sexp_heap_last(heap);
|
||||
cur_size = h->size;
|
||||
new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2);
|
||||
h->next = sexp_make_heap(new_size);
|
||||
return (h->next != NULL);
|
||||
}
|
||||
|
||||
void* sexp_try_alloc (sexp ctx, size_t size) {
|
||||
sexp_free_list ls1, ls2, ls3;
|
||||
sexp_heap h;
|
||||
for (h=heap; h; h=h->next)
|
||||
for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next)
|
||||
if (ls2->size >= size) {
|
||||
if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) {
|
||||
ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */
|
||||
ls3->size = ls2->size - size;
|
||||
ls3->next = ls2->next;
|
||||
ls1->next = ls3;
|
||||
} else { /* take the whole chunk */
|
||||
ls1->next = ls2->next;
|
||||
}
|
||||
memset((void*)ls2, 0, size);
|
||||
return ls2;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
void* sexp_alloc (sexp ctx, size_t size) {
|
||||
void *res;
|
||||
size_t max_freed, sum_freed;
|
||||
sexp_heap h;
|
||||
size = sexp_heap_align(size);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res) {
|
||||
max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed));
|
||||
h = sexp_heap_last(heap);
|
||||
if (((max_freed < size)
|
||||
|| ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO))))
|
||||
&& ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE)))
|
||||
sexp_grow_heap(ctx, size);
|
||||
res = sexp_try_alloc(ctx, size);
|
||||
if (! res)
|
||||
errx(80, "out of memory allocating %zu bytes, aborting\n", size);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
void sexp_gc_init () {
|
||||
sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE);
|
||||
heap = sexp_make_heap(size);
|
||||
#if USE_DEBUG_GC
|
||||
/* the +32 is a hack, but this is just for debugging anyway */
|
||||
stack_base = ((sexp*)&size) + 32;
|
||||
#endif
|
||||
}
|
||||
|
||||
120
include/chibi/config.h
Normal file
120
include/chibi/config.h
Normal file
|
|
@ -0,0 +1,120 @@
|
|||
/* config.h -- general configuration */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
/* uncomment this to use the Boehm conservative GC */
|
||||
/* #define USE_BOEHM 1 */
|
||||
|
||||
/* uncomment this to just malloc manually instead of any GC */
|
||||
/* #define USE_MALLOC 1 */
|
||||
|
||||
/* uncomment this to add conservative checks to the native GC */
|
||||
/* #define USE_DEBUG_GC 1 */
|
||||
|
||||
/* uncomment this if you only want fixnum support */
|
||||
/* #define USE_FLONUMS 0 */
|
||||
|
||||
/* uncomment this if you want immediate flonums */
|
||||
/* #define USE_IMMEDIATE_FLONUMS 1 */
|
||||
|
||||
/* uncomment this if you don't need extended math operations */
|
||||
/* #define USE_MATH 0 */
|
||||
|
||||
/* uncomment this to disable warning about references to undefined variables */
|
||||
/* #define USE_WARN_UNDEFS 0 */
|
||||
|
||||
/* uncomment this to disable huffman-coded immediate symbols */
|
||||
/* #define USE_HUFF_SYMS 0 */
|
||||
|
||||
/* uncomment this to just use a single list for hash tables */
|
||||
/* #define USE_HASH_SYMS 0 */
|
||||
|
||||
/* uncomment this to disable string ports */
|
||||
/* #define USE_STRING_STREAMS 0 */
|
||||
|
||||
/* uncomment this to enable stack overflow checks */
|
||||
/* #define USE_CHECK_STACK 1 */
|
||||
|
||||
/* uncomment this to disable debugging utilities */
|
||||
/* #define USE_DEBUG 0 */
|
||||
|
||||
/************************************************************************/
|
||||
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
|
||||
/************************************************************************/
|
||||
|
||||
#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
|
||||
#define SEXP_BSD 1
|
||||
#else
|
||||
#define SEXP_BSD 0
|
||||
#define _GNU_SOURCE
|
||||
#endif
|
||||
|
||||
#ifndef USE_BOEHM
|
||||
#define USE_BOEHM 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MALLOC
|
||||
#define USE_MALLOC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG_GC
|
||||
#define USE_DEBUG_GC 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_FLONUMS
|
||||
#define USE_FLONUMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_IMMEDIATE_FLONUMS
|
||||
#define USE_IMMEDIATE_FLONUMS 0
|
||||
#endif
|
||||
|
||||
#ifndef USE_MATH
|
||||
#define USE_MATH 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_WARN_UNDEFS
|
||||
#define USE_WARN_UNDEFS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_HUFF_SYMS
|
||||
#define USE_HUFF_SYMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_HASH_SYMS
|
||||
#define USE_HASH_SYMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_DEBUG
|
||||
#define USE_DEBUG 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_STRING_STREAMS
|
||||
#define USE_STRING_STREAMS 1
|
||||
#endif
|
||||
|
||||
#ifndef USE_CHECK_STACK
|
||||
#define USE_CHECK_STACK 0
|
||||
#endif
|
||||
|
||||
#ifdef PLAN9
|
||||
|
||||
#define errx(code, msg, ...) exits(msg)
|
||||
#define exit_normally() exits(NULL)
|
||||
#define strcasecmp cistrcmp
|
||||
#define strncasecmp cistrncmp
|
||||
/* XXXX these are wrong */
|
||||
#define trunc floor
|
||||
#define round(x) floor(x+0.5)
|
||||
|
||||
#else
|
||||
|
||||
#define exit_normally() exit(0)
|
||||
#if HAVE_ERR_H
|
||||
#include <err.h>
|
||||
#else
|
||||
/* requires msg be a string literal, and at least one argument */
|
||||
#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code))
|
||||
#endif
|
||||
|
||||
#endif
|
||||
140
include/chibi/eval.h
Normal file
140
include/chibi/eval.h
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
/* eval.h -- headers for eval library */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#ifndef SEXP_EVAL_H
|
||||
#define SEXP_EVAL_H
|
||||
|
||||
#include "chibi/sexp.h"
|
||||
|
||||
/************************* additional types ***************************/
|
||||
|
||||
#define INIT_BCODE_SIZE 128
|
||||
#define INIT_STACK_SIZE 1024
|
||||
|
||||
#define sexp_init_file "init.scm"
|
||||
|
||||
/* procedure types */
|
||||
typedef sexp (*sexp_proc0) ();
|
||||
typedef sexp (*sexp_proc1) (sexp);
|
||||
typedef sexp (*sexp_proc2) (sexp, sexp);
|
||||
typedef sexp (*sexp_proc3) (sexp, sexp, sexp);
|
||||
typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp);
|
||||
typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp);
|
||||
typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp);
|
||||
|
||||
enum core_form_names {
|
||||
CORE_DEFINE = 1,
|
||||
CORE_SET,
|
||||
CORE_LAMBDA,
|
||||
CORE_IF,
|
||||
CORE_BEGIN,
|
||||
CORE_QUOTE,
|
||||
CORE_DEFINE_SYNTAX,
|
||||
CORE_LET_SYNTAX,
|
||||
CORE_LETREC_SYNTAX,
|
||||
};
|
||||
|
||||
enum opcode_classes {
|
||||
OPC_GENERIC = 1,
|
||||
OPC_TYPE_PREDICATE,
|
||||
OPC_PREDICATE,
|
||||
OPC_ARITHMETIC,
|
||||
OPC_ARITHMETIC_INV,
|
||||
OPC_ARITHMETIC_CMP,
|
||||
OPC_IO,
|
||||
OPC_CONSTRUCTOR,
|
||||
OPC_ACCESSOR,
|
||||
OPC_PARAMETER,
|
||||
OPC_FOREIGN,
|
||||
};
|
||||
|
||||
enum opcode_names {
|
||||
OP_NOOP,
|
||||
OP_RAISE,
|
||||
OP_RESUMECC,
|
||||
OP_CALLCC,
|
||||
OP_APPLY1,
|
||||
OP_TAIL_CALL,
|
||||
OP_CALL,
|
||||
OP_FCALL0,
|
||||
OP_FCALL1,
|
||||
OP_FCALL2,
|
||||
OP_FCALL3,
|
||||
OP_FCALL4,
|
||||
OP_FCALL5,
|
||||
OP_FCALL6,
|
||||
OP_EVAL,
|
||||
OP_JUMP_UNLESS,
|
||||
OP_JUMP,
|
||||
OP_PUSH,
|
||||
OP_DROP,
|
||||
OP_GLOBAL_REF,
|
||||
OP_GLOBAL_KNOWN_REF,
|
||||
OP_STACK_REF,
|
||||
OP_LOCAL_REF,
|
||||
OP_LOCAL_SET,
|
||||
OP_CLOSURE_REF,
|
||||
OP_VECTOR_REF,
|
||||
OP_VECTOR_SET,
|
||||
OP_VECTOR_LENGTH,
|
||||
OP_STRING_REF,
|
||||
OP_STRING_SET,
|
||||
OP_STRING_LENGTH,
|
||||
OP_MAKE_PROCEDURE,
|
||||
OP_MAKE_VECTOR,
|
||||
OP_AND,
|
||||
OP_NULLP,
|
||||
OP_INTEGERP,
|
||||
OP_SYMBOLP,
|
||||
OP_CHARP,
|
||||
OP_EOFP,
|
||||
OP_TYPEP,
|
||||
OP_CAR,
|
||||
OP_CDR,
|
||||
OP_SET_CAR,
|
||||
OP_SET_CDR,
|
||||
OP_CONS,
|
||||
OP_ADD,
|
||||
OP_SUB,
|
||||
OP_MUL,
|
||||
OP_DIV,
|
||||
OP_QUOTIENT,
|
||||
OP_REMAINDER,
|
||||
OP_NEGATIVE,
|
||||
OP_INVERSE,
|
||||
OP_LT,
|
||||
OP_LE,
|
||||
OP_EQN,
|
||||
OP_EQ,
|
||||
OP_FIX2FLO,
|
||||
OP_FLO2FIX,
|
||||
OP_CHAR2INT,
|
||||
OP_INT2CHAR,
|
||||
OP_CHAR_UPCASE,
|
||||
OP_CHAR_DOWNCASE,
|
||||
OP_DISPLAY,
|
||||
OP_WRITE,
|
||||
OP_WRITE_CHAR,
|
||||
OP_NEWLINE,
|
||||
OP_FLUSH_OUTPUT,
|
||||
OP_READ,
|
||||
OP_READ_CHAR,
|
||||
OP_PEEK_CHAR,
|
||||
OP_RET,
|
||||
OP_DONE,
|
||||
};
|
||||
|
||||
/**************************** prototypes ******************************/
|
||||
|
||||
void sexp_scheme_init();
|
||||
sexp sexp_apply(sexp context, sexp proc, sexp args);
|
||||
sexp sexp_eval(sexp context, sexp obj);
|
||||
sexp sexp_eval_string(sexp context, char *str);
|
||||
sexp sexp_load(sexp context, sexp expr, sexp env);
|
||||
sexp sexp_make_context(sexp context, sexp stack, sexp env);
|
||||
void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out);
|
||||
|
||||
#endif /* ! SEXP_EVAL_H */
|
||||
|
||||
595
include/chibi/sexp.h
Normal file
595
include/chibi/sexp.h
Normal file
|
|
@ -0,0 +1,595 @@
|
|||
/* sexp.h -- header for sexp library */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#ifndef SEXP_H
|
||||
#define SEXP_H
|
||||
|
||||
#include "chibi/config.h"
|
||||
#include "chibi/install.h"
|
||||
|
||||
#include <ctype.h>
|
||||
#include <stdio.h>
|
||||
#ifdef PLAN9
|
||||
typedef unsigned long size_t;
|
||||
#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0))
|
||||
#else
|
||||
#include <stddef.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdarg.h>
|
||||
#include <sys/types.h>
|
||||
#include <math.h>
|
||||
#endif
|
||||
|
||||
/* tagging system
|
||||
* bits end in 00: pointer
|
||||
* 01: fixnum
|
||||
* 011: immediate flonum (optional)
|
||||
* 111: immediate symbol (optional)
|
||||
* 0110: char
|
||||
* 1110: other immediate object (NULL, TRUE, FALSE)
|
||||
*/
|
||||
|
||||
#define SEXP_FIXNUM_BITS 2
|
||||
#define SEXP_IMMEDIATE_BITS 3
|
||||
#define SEXP_EXTENDED_BITS 4
|
||||
|
||||
#define SEXP_FIXNUM_MASK 3
|
||||
#define SEXP_IMMEDIATE_MASK 7
|
||||
#define SEXP_EXTENDED_MASK 15
|
||||
|
||||
#define SEXP_POINTER_TAG 0
|
||||
#define SEXP_FIXNUM_TAG 1
|
||||
#define SEXP_ISYMBOL_TAG 7
|
||||
#define SEXP_IFLONUM_TAG 3
|
||||
#define SEXP_CHAR_TAG 6
|
||||
#define SEXP_EXTENDED_TAG 14
|
||||
|
||||
#define SEXP_MAX_INT ((1<<29)-1)
|
||||
#define SEXP_MIN_INT (-(1<<29))
|
||||
|
||||
#if USE_HASH_SYMS
|
||||
#define SEXP_SYMBOL_TABLE_SIZE 389
|
||||
#else
|
||||
#define SEXP_SYMBOL_TABLE_SIZE 1
|
||||
#endif
|
||||
|
||||
enum sexp_types {
|
||||
SEXP_OBJECT,
|
||||
SEXP_TYPE,
|
||||
SEXP_FIXNUM,
|
||||
SEXP_CHAR,
|
||||
SEXP_BOOLEAN,
|
||||
SEXP_PAIR,
|
||||
SEXP_SYMBOL,
|
||||
SEXP_STRING,
|
||||
SEXP_VECTOR,
|
||||
SEXP_FLONUM,
|
||||
SEXP_BIGNUM,
|
||||
SEXP_IPORT,
|
||||
SEXP_OPORT,
|
||||
SEXP_EXCEPTION,
|
||||
SEXP_PROCEDURE,
|
||||
SEXP_MACRO,
|
||||
SEXP_SYNCLO,
|
||||
SEXP_ENV,
|
||||
SEXP_BYTECODE,
|
||||
SEXP_CORE,
|
||||
SEXP_OPCODE,
|
||||
SEXP_LAMBDA,
|
||||
SEXP_CND,
|
||||
SEXP_REF,
|
||||
SEXP_SET,
|
||||
SEXP_SEQ,
|
||||
SEXP_LIT,
|
||||
SEXP_STACK,
|
||||
SEXP_CONTEXT,
|
||||
SEXP_NUM_TYPES,
|
||||
};
|
||||
|
||||
typedef unsigned long sexp_uint_t;
|
||||
typedef long sexp_sint_t;
|
||||
typedef unsigned char sexp_tag_t;
|
||||
typedef struct sexp_struct *sexp;
|
||||
|
||||
struct sexp_gc_var_t {
|
||||
sexp *var;
|
||||
char *name;
|
||||
struct sexp_gc_var_t *next;
|
||||
};
|
||||
|
||||
struct sexp_struct {
|
||||
sexp_tag_t tag;
|
||||
char immutablep;
|
||||
char gc_mark;
|
||||
union {
|
||||
/* basic types */
|
||||
double flonum;
|
||||
struct {
|
||||
sexp_tag_t tag;
|
||||
short field_base, field_len_base, field_len_off, field_len_scale;
|
||||
short size_base, size_off, size_scale;
|
||||
char *name;
|
||||
} type;
|
||||
struct {
|
||||
sexp car, cdr;
|
||||
sexp source;
|
||||
} pair;
|
||||
struct {
|
||||
sexp_uint_t length;
|
||||
sexp data[];
|
||||
} vector;
|
||||
struct {
|
||||
sexp_uint_t length;
|
||||
char data[];
|
||||
} string;
|
||||
struct {
|
||||
sexp string;
|
||||
} symbol;
|
||||
struct {
|
||||
FILE *stream;
|
||||
char *buf;
|
||||
sexp_uint_t offset, line, size, openp, sourcep;
|
||||
sexp name;
|
||||
sexp cookie;
|
||||
} port;
|
||||
struct {
|
||||
sexp kind, message, irritants, procedure, source;
|
||||
} exception;
|
||||
struct {
|
||||
char sign;
|
||||
sexp_uint_t length;
|
||||
sexp_uint_t data[];
|
||||
} bignum;
|
||||
/* runtime types */
|
||||
struct {
|
||||
char flags;
|
||||
sexp parent, lambda, bindings;
|
||||
} env;
|
||||
struct {
|
||||
sexp_uint_t length;
|
||||
sexp name, literals;
|
||||
unsigned char data[];
|
||||
} bytecode;
|
||||
struct {
|
||||
char flags;
|
||||
unsigned short num_args;
|
||||
sexp bc, vars;
|
||||
} procedure;
|
||||
struct {
|
||||
sexp proc, env;
|
||||
} macro;
|
||||
struct {
|
||||
sexp env, free_vars, expr;
|
||||
} synclo;
|
||||
struct {
|
||||
unsigned char op_class, code, num_args, flags,
|
||||
arg1_type, arg2_type, inverse;
|
||||
char *name;
|
||||
sexp data, dflt, proc;
|
||||
} opcode;
|
||||
struct {
|
||||
char code;
|
||||
char *name;
|
||||
} core;
|
||||
/* ast types */
|
||||
struct {
|
||||
sexp name, params, locals, defs, flags, fv, sv, body;
|
||||
} lambda;
|
||||
struct {
|
||||
sexp test, pass, fail;
|
||||
} cnd;
|
||||
struct {
|
||||
sexp var, value;
|
||||
} set;
|
||||
struct {
|
||||
sexp name, cell;
|
||||
} ref;
|
||||
struct {
|
||||
sexp ls;
|
||||
} seq;
|
||||
struct {
|
||||
sexp value;
|
||||
} lit;
|
||||
/* compiler state */
|
||||
struct {
|
||||
sexp_uint_t length, top;
|
||||
sexp data[];
|
||||
} stack;
|
||||
struct {
|
||||
struct sexp_gc_var_t *saves;
|
||||
sexp_uint_t pos, depth, tailp, tracep;
|
||||
sexp bc, lambda, stack, env, fv, parent;
|
||||
} context;
|
||||
} value;
|
||||
};
|
||||
|
||||
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
|
||||
+ SEXP_EXTENDED_TAG))
|
||||
|
||||
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0) /* 14 0x0e */
|
||||
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) /* 30 0x1e */
|
||||
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) /* 46 0x2e */
|
||||
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) /* 62 0x3e */
|
||||
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */
|
||||
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */
|
||||
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */
|
||||
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */
|
||||
|
||||
#if USE_BOEHM
|
||||
|
||||
#define sexp_gc_var(ctx, x, y) sexp x;
|
||||
#define sexp_gc_preserve(ctx, x, y)
|
||||
#define sexp_gc_release(ctx, x, y)
|
||||
|
||||
#include "gc/gc.h"
|
||||
#define sexp_alloc(ctx, size) GC_malloc(size)
|
||||
#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size)
|
||||
#define sexp_realloc(ctx, x, size) GC_realloc(x, size)
|
||||
#define sexp_free(ctx, x)
|
||||
#define sexp_deep_free(ctx, x)
|
||||
|
||||
#else
|
||||
|
||||
#define sexp_gc_var(ctx, x, y) \
|
||||
sexp x = SEXP_VOID; \
|
||||
struct sexp_gc_var_t y = {NULL, NULL};
|
||||
|
||||
#define sexp_gc_preserve(ctx, x, y) \
|
||||
do { \
|
||||
(y).var = &(x); \
|
||||
(y).name = #x; \
|
||||
(y).next = sexp_context_saves(ctx); \
|
||||
sexp_context_saves(ctx) = &(y); \
|
||||
} while (0)
|
||||
|
||||
#define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next)
|
||||
|
||||
#if USE_MALLOC
|
||||
#define sexp_alloc(ctx, size) malloc(size)
|
||||
#define sexp_alloc_atomic(ctx, size) malloc(size)
|
||||
#define sexp_realloc(ctx, x, size) realloc(x, size)
|
||||
#define sexp_free(ctx, x) free(x)
|
||||
void sexp_deep_free(sexp ctx, sexp obj);
|
||||
|
||||
#else /* native gc */
|
||||
void *sexp_alloc(sexp ctx, size_t size);
|
||||
#define sexp_alloc_atomic sexp_alloc
|
||||
void *sexp_realloc(sexp ctx, sexp x, size_t size);
|
||||
#define sexp_free(ctx, x)
|
||||
#define sexp_deep_free(ctx, x)
|
||||
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1)))
|
||||
|
||||
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
|
||||
+ sizeof(((sexp)0)->value.x))
|
||||
|
||||
#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f))
|
||||
|
||||
#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag)
|
||||
|
||||
/***************************** predicates *****************************/
|
||||
|
||||
#define sexp_truep(x) ((x) != SEXP_FALSE)
|
||||
#define sexp_not(x) ((x) == SEXP_FALSE)
|
||||
|
||||
#define sexp_nullp(x) ((x) == SEXP_NULL)
|
||||
#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG)
|
||||
#define sexp_integerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG)
|
||||
#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG)
|
||||
#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG)
|
||||
#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE))
|
||||
|
||||
#define sexp_pointer_tag(x) ((x)->tag)
|
||||
#define sexp_gc_mark(x) ((x)->gc_mark)
|
||||
#define sexp_immutablep(x) ((x)->immutablep)
|
||||
|
||||
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
|
||||
|
||||
#if USE_IMMEDIATE_FLONUMS
|
||||
union sexp_flonum_conv {
|
||||
float flonum;
|
||||
sexp_uint_t bits;
|
||||
};
|
||||
#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG)
|
||||
#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG))
|
||||
#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((sexp_uint_t)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum)
|
||||
#else
|
||||
#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM))
|
||||
#define sexp_flonum_value(f) ((f)->value.flonum)
|
||||
sexp sexp_make_flonum(sexp ctx, double f);
|
||||
#endif
|
||||
|
||||
#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE))
|
||||
#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR))
|
||||
#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING))
|
||||
#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL))
|
||||
#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR))
|
||||
#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT))
|
||||
#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT))
|
||||
#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION))
|
||||
#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE))
|
||||
#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV))
|
||||
#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE))
|
||||
#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE))
|
||||
#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE))
|
||||
#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO))
|
||||
#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO))
|
||||
#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA))
|
||||
#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND))
|
||||
#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF))
|
||||
#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET))
|
||||
#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ))
|
||||
#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT))
|
||||
#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT))
|
||||
#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x))
|
||||
|
||||
#define sexp_idp(x) \
|
||||
(sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x))))
|
||||
|
||||
#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x))
|
||||
|
||||
/***************************** constructors ****************************/
|
||||
|
||||
#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_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)))
|
||||
#else
|
||||
#define sexp_integer_to_flonum(ctx, x) (x)
|
||||
#endif
|
||||
|
||||
/*************************** field accessors **************************/
|
||||
|
||||
#define sexp_vector_length(x) ((x)->value.vector.length)
|
||||
#define sexp_vector_data(x) ((x)->value.vector.data)
|
||||
|
||||
#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_integer(i)])
|
||||
#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_integer(i)]=(v))
|
||||
|
||||
#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args)
|
||||
#define sexp_procedure_flags(x) ((x)->value.procedure.flags)
|
||||
#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(sexp_procedure_flags(x)) & 1)
|
||||
#define sexp_procedure_code(x) ((x)->value.procedure.bc)
|
||||
#define sexp_procedure_vars(x) ((x)->value.procedure.vars)
|
||||
|
||||
#define sexp_string_length(x) ((x)->value.string.length)
|
||||
#define sexp_string_data(x) ((x)->value.string.data)
|
||||
|
||||
#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)]))
|
||||
#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v))
|
||||
|
||||
#define sexp_symbol_string(x) ((x)->value.symbol.string)
|
||||
|
||||
#define sexp_port_stream(p) ((p)->value.port.stream)
|
||||
#define sexp_port_name(p) ((p)->value.port.name)
|
||||
#define sexp_port_line(p) ((p)->value.port.line)
|
||||
#define sexp_port_openp(p) ((p)->value.port.openp)
|
||||
#define sexp_port_sourcep(p) ((p)->value.port.sourcep)
|
||||
#define sexp_port_cookie(p) ((p)->value.port.cookie)
|
||||
#define sexp_port_buf(p) ((p)->value.port.buf)
|
||||
#define sexp_port_size(p) ((p)->value.port.size)
|
||||
#define sexp_port_offset(p) ((p)->value.port.offset)
|
||||
|
||||
#define sexp_exception_kind(p) ((p)->value.exception.kind)
|
||||
#define sexp_exception_message(p) ((p)->value.exception.message)
|
||||
#define sexp_exception_irritants(p) ((p)->value.exception.irritants)
|
||||
#define sexp_exception_procedure(p) ((p)->value.exception.procedure)
|
||||
#define sexp_exception_source(p) ((p)->value.exception.source)
|
||||
|
||||
#define sexp_bytecode_length(x) ((x)->value.bytecode.length)
|
||||
#define sexp_bytecode_name(x) ((x)->value.bytecode.name)
|
||||
#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals)
|
||||
#define sexp_bytecode_data(x) ((x)->value.bytecode.data)
|
||||
|
||||
#define sexp_env_flags(x) ((x)->value.env.flags)
|
||||
#define sexp_env_parent(x) ((x)->value.env.parent)
|
||||
#define sexp_env_bindings(x) ((x)->value.env.bindings)
|
||||
#define sexp_env_local_p(x) (sexp_env_parent(x))
|
||||
#define sexp_env_global_p(x) (! sexp_env_local_p(x))
|
||||
#define sexp_env_lambda(x) ((x)->value.env.lambda)
|
||||
|
||||
#define sexp_macro_proc(x) ((x)->value.macro.proc)
|
||||
#define sexp_macro_env(x) ((x)->value.macro.env)
|
||||
|
||||
#define sexp_synclo_env(x) ((x)->value.synclo.env)
|
||||
#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars)
|
||||
#define sexp_synclo_expr(x) ((x)->value.synclo.expr)
|
||||
|
||||
#define sexp_core_code(x) ((x)->value.core.code)
|
||||
#define sexp_core_name(x) ((x)->value.core.name)
|
||||
|
||||
#define sexp_opcode_class(x) ((x)->value.opcode.op_class)
|
||||
#define sexp_opcode_code(x) ((x)->value.opcode.code)
|
||||
#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args)
|
||||
#define sexp_opcode_flags(x) ((x)->value.opcode.flags)
|
||||
#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type)
|
||||
#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type)
|
||||
#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse)
|
||||
#define sexp_opcode_name(x) ((x)->value.opcode.name)
|
||||
#define sexp_opcode_default(x) ((x)->value.opcode.dflt)
|
||||
#define sexp_opcode_data(x) ((x)->value.opcode.data)
|
||||
#define sexp_opcode_proc(x) ((x)->value.opcode.proc)
|
||||
|
||||
#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1)
|
||||
#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2)
|
||||
|
||||
#define sexp_lambda_name(x) ((x)->value.lambda.name)
|
||||
#define sexp_lambda_params(x) ((x)->value.lambda.params)
|
||||
#define sexp_lambda_locals(x) ((x)->value.lambda.locals)
|
||||
#define sexp_lambda_defs(x) ((x)->value.lambda.defs)
|
||||
#define sexp_lambda_flags(x) ((x)->value.lambda.flags)
|
||||
#define sexp_lambda_body(x) ((x)->value.lambda.body)
|
||||
#define sexp_lambda_fv(x) ((x)->value.lambda.fv)
|
||||
#define sexp_lambda_sv(x) ((x)->value.lambda.sv)
|
||||
|
||||
#define sexp_cnd_test(x) ((x)->value.cnd.test)
|
||||
#define sexp_cnd_pass(x) ((x)->value.cnd.pass)
|
||||
#define sexp_cnd_fail(x) ((x)->value.cnd.fail)
|
||||
|
||||
#define sexp_set_var(x) ((x)->value.set.var)
|
||||
#define sexp_set_value(x) ((x)->value.set.value)
|
||||
|
||||
#define sexp_ref_name(x) ((x)->value.ref.name)
|
||||
#define sexp_ref_cell(x) ((x)->value.ref.cell)
|
||||
#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x)))
|
||||
|
||||
#define sexp_seq_ls(x) ((x)->value.seq.ls)
|
||||
|
||||
#define sexp_lit_value(x) ((x)->value.lit.value)
|
||||
|
||||
#define sexp_stack_length(x) ((x)->value.stack.length)
|
||||
#define sexp_stack_top(x) ((x)->value.stack.top)
|
||||
#define sexp_stack_data(x) ((x)->value.stack.data)
|
||||
|
||||
#define sexp_context_heap(x) ((x)->value.context.heap)
|
||||
#define sexp_context_symbols(x) ((x)->value.context.symbols)
|
||||
#define sexp_context_env(x) ((x)->value.context.env)
|
||||
#define sexp_context_stack(x) ((x)->value.context.stack)
|
||||
#define sexp_context_depth(x) ((x)->value.context.depth)
|
||||
#define sexp_context_bc(x) ((x)->value.context.bc)
|
||||
#define sexp_context_fv(x) ((x)->value.context.fv)
|
||||
#define sexp_context_pos(x) ((x)->value.context.pos)
|
||||
#define sexp_context_lambda(x) ((x)->value.context.lambda)
|
||||
#define sexp_context_parent(x) ((x)->value.context.parent)
|
||||
#define sexp_context_saves(x) ((x)->value.context.saves)
|
||||
#define sexp_context_tailp(x) ((x)->value.context.tailp)
|
||||
#define sexp_context_tracep(x) ((x)->value.context.tailp)
|
||||
|
||||
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
|
||||
|
||||
#define sexp_type_tag(x) ((x)->value.type.tag)
|
||||
#define sexp_type_field_base(x) ((x)->value.type.field_base)
|
||||
#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base)
|
||||
#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off)
|
||||
#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale)
|
||||
#define sexp_type_size_base(x) ((x)->value.type.size_base)
|
||||
#define sexp_type_size_off(x) ((x)->value.type.size_off)
|
||||
#define sexp_type_size_scale(x) ((x)->value.type.size_scale)
|
||||
#define sexp_type_name(x) ((x)->value.type.name)
|
||||
|
||||
#define sexp_bignum_sign(x) ((x)->value.bignum.sign)
|
||||
#define sexp_bignum_length(x) ((x)->value.bignum.length)
|
||||
#define sexp_bignum_data(x) ((x)->value.bignum.data)
|
||||
|
||||
/****************************** arithmetic ****************************/
|
||||
|
||||
#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG))
|
||||
#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG))
|
||||
#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG)))
|
||||
#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b)))
|
||||
#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b)))
|
||||
#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */
|
||||
|
||||
#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b)))
|
||||
#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b)))
|
||||
#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b)))
|
||||
#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b)))
|
||||
|
||||
/****************************** utilities *****************************/
|
||||
|
||||
#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL)
|
||||
|
||||
#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls)))
|
||||
#define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x)))
|
||||
|
||||
#define sexp_pair_source(x) ((x)->value.pair.source)
|
||||
|
||||
#define sexp_car(x) ((x)->value.pair.car)
|
||||
#define sexp_cdr(x) ((x)->value.pair.cdr)
|
||||
|
||||
#define sexp_caar(x) (sexp_car(sexp_car(x)))
|
||||
#define sexp_cadr(x) (sexp_car(sexp_cdr(x)))
|
||||
#define sexp_cdar(x) (sexp_cdr(sexp_car(x)))
|
||||
#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x)))
|
||||
#define sexp_caaar(x) (sexp_car(sexp_caar(x)))
|
||||
#define sexp_caadr(x) (sexp_car(sexp_cadr(x)))
|
||||
#define sexp_cadar(x) (sexp_car(sexp_cdar(x)))
|
||||
#define sexp_caddr(x) (sexp_car(sexp_cddr(x)))
|
||||
#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x)))
|
||||
#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x)))
|
||||
#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x)))
|
||||
#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x)))
|
||||
#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */
|
||||
#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
|
||||
|
||||
/***************************** general API ****************************/
|
||||
|
||||
#if USE_STRING_STREAMS
|
||||
|
||||
#define sexp_read_char(x, p) (getc(sexp_port_stream(p)))
|
||||
#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p)))
|
||||
#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p)))
|
||||
#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p)))
|
||||
#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
|
||||
#define sexp_flush(x, p) (fflush(sexp_port_stream(p)))
|
||||
|
||||
#else
|
||||
|
||||
#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p)))
|
||||
#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p)))
|
||||
#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID))
|
||||
#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID))
|
||||
#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID))
|
||||
|
||||
int sexp_buffered_read_char (sexp ctx, sexp p);
|
||||
sexp sexp_buffered_write_char (sexp ctx, int c, sexp p);
|
||||
sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p);
|
||||
sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p);
|
||||
sexp sexp_buffered_flush (sexp ctx, sexp p);
|
||||
|
||||
#endif
|
||||
|
||||
#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p))
|
||||
|
||||
sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
|
||||
sexp sexp_cons(sexp ctx, sexp head, sexp tail);
|
||||
sexp sexp_list2(sexp ctx, sexp a, sexp b);
|
||||
sexp sexp_equalp (sexp ctx, sexp a, sexp b);
|
||||
sexp sexp_listp(sexp ctx, sexp obj);
|
||||
sexp sexp_reverse(sexp ctx, sexp ls);
|
||||
sexp sexp_nreverse(sexp ctx, sexp ls);
|
||||
sexp sexp_append2(sexp ctx, sexp a, sexp b);
|
||||
sexp sexp_memq(sexp ctx, sexp x, sexp ls);
|
||||
sexp sexp_assq(sexp ctx, sexp x, sexp ls);
|
||||
sexp sexp_length(sexp ctx, sexp ls);
|
||||
sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen);
|
||||
sexp sexp_make_string(sexp ctx, sexp len, sexp ch);
|
||||
sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end);
|
||||
sexp sexp_string_concatenate (sexp ctx, sexp str_ls);
|
||||
sexp sexp_intern(sexp ctx, char *str);
|
||||
sexp sexp_string_to_symbol(sexp ctx, sexp str);
|
||||
sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt);
|
||||
sexp sexp_list_to_vector(sexp ctx, sexp ls);
|
||||
void sexp_write(sexp ctx, sexp obj, sexp out);
|
||||
sexp sexp_read_string(sexp ctx, sexp in);
|
||||
sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp);
|
||||
sexp sexp_read_number(sexp ctx, sexp in, int base);
|
||||
sexp sexp_read_raw(sexp ctx, sexp in);
|
||||
sexp sexp_read(sexp ctx, sexp in);
|
||||
sexp sexp_read_from_string(sexp ctx, char *str);
|
||||
sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name);
|
||||
sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name);
|
||||
sexp sexp_make_input_string_port(sexp ctx, sexp str);
|
||||
sexp sexp_make_output_string_port(sexp ctx);
|
||||
sexp sexp_get_output_string(sexp ctx, sexp port);
|
||||
sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source);
|
||||
sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj);
|
||||
sexp sexp_type_exception (sexp ctx, char *message, sexp obj);
|
||||
sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
|
||||
sexp sexp_print_exception(sexp ctx, sexp exn, sexp out);
|
||||
void sexp_init();
|
||||
|
||||
#endif /* ! SEXP_H */
|
||||
|
||||
713
init.scm
Normal file
713
init.scm
Normal file
|
|
@ -0,0 +1,713 @@
|
|||
|
||||
;; provide c[ad]{2,4}r
|
||||
|
||||
(define (caar x) (car (car x)))
|
||||
(define (cadr x) (car (cdr x)))
|
||||
(define (cdar x) (cdr (car x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
(define (caaar x) (car (car (car x))))
|
||||
(define (caadr x) (car (car (cdr x))))
|
||||
(define (cadar x) (car (cdr (car x))))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
(define (cdaar x) (cdr (car (car x))))
|
||||
(define (cdadr x) (cdr (car (cdr x))))
|
||||
(define (cddar x) (cdr (cdr (car x))))
|
||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
(define (caaaar x) (car (car (car (car x)))))
|
||||
(define (caaadr x) (car (car (car (cdr x)))))
|
||||
(define (caadar x) (car (car (cdr (car x)))))
|
||||
(define (caaddr x) (car (car (cdr (cdr x)))))
|
||||
(define (cadaar x) (car (cdr (car (car x)))))
|
||||
(define (cadadr x) (car (cdr (car (cdr x)))))
|
||||
(define (caddar x) (car (cdr (cdr (car x)))))
|
||||
(define (cadddr x) (car (cdr (cdr (cdr x)))))
|
||||
(define (cdaaar x) (cdr (car (car (car x)))))
|
||||
(define (cdaadr x) (cdr (car (car (cdr x)))))
|
||||
(define (cdadar x) (cdr (car (cdr (car x)))))
|
||||
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
|
||||
(define (cddaar x) (cdr (cdr (car (car x)))))
|
||||
(define (cddadr x) (cdr (cdr (car (cdr x)))))
|
||||
(define (cdddar x) (cdr (cdr (cdr (car x)))))
|
||||
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
|
||||
|
||||
;; basic utils
|
||||
|
||||
(define (procedure? x) (if (closure? x) #t (opcode? x)))
|
||||
|
||||
(define (list . args) args)
|
||||
|
||||
(define (list-tail ls k)
|
||||
(if (eq? k 0)
|
||||
ls
|
||||
(list-tail (cdr ls) (- k 1))))
|
||||
|
||||
(define (list-ref ls k) (car (list-tail ls k)))
|
||||
|
||||
(define (append-helper ls res)
|
||||
(if (null? ls)
|
||||
res
|
||||
(append-helper (cdr ls) (append2 (car ls) res))))
|
||||
|
||||
(define (append . o)
|
||||
(if (null? o)
|
||||
'()
|
||||
((lambda (lol)
|
||||
(append-helper (cdr lol) (car lol)))
|
||||
(reverse o))))
|
||||
|
||||
(define (apply proc . args)
|
||||
(if (null? args)
|
||||
(proc)
|
||||
((lambda (lol)
|
||||
(apply1 proc (append2 (reverse (cdr lol)) (car lol))))
|
||||
(reverse args))))
|
||||
|
||||
;; map with a fast-path for single lists
|
||||
|
||||
(define (map proc ls . lol)
|
||||
(define (map1 proc ls res)
|
||||
(if (pair? ls)
|
||||
(map1 proc (cdr ls) (cons (proc (car ls)) res))
|
||||
(reverse res)))
|
||||
(define (mapn proc lol res)
|
||||
(if (null? (car lol))
|
||||
(reverse res)
|
||||
(mapn proc
|
||||
(map1 cdr lol '())
|
||||
(cons (apply1 proc (map1 car lol '())) res))))
|
||||
(if (null? lol)
|
||||
(map1 proc ls '())
|
||||
(mapn proc (cons ls lol) '())))
|
||||
|
||||
(define for-each map)
|
||||
|
||||
(define (any pred ls)
|
||||
(if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f))
|
||||
|
||||
;; syntax
|
||||
|
||||
(define sc-macro-transformer
|
||||
(lambda (f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure mac-env '() (f expr use-env)))))
|
||||
|
||||
(define rsc-macro-transformer
|
||||
(lambda (f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure use-env '() (f expr mac-env)))))
|
||||
|
||||
(define er-macro-transformer
|
||||
(lambda (f)
|
||||
(lambda (expr use-env mac-env)
|
||||
((lambda (rename compare) (f expr rename compare))
|
||||
((lambda (renames)
|
||||
(lambda (identifier)
|
||||
((lambda (cell)
|
||||
(if cell
|
||||
(cdr cell)
|
||||
((lambda (name)
|
||||
(set! renames (cons (cons identifier name) renames))
|
||||
name)
|
||||
(make-syntactic-closure mac-env '() identifier))))
|
||||
(assq identifier renames))))
|
||||
'())
|
||||
(lambda (x y) (identifier=? use-env x use-env y))))))
|
||||
|
||||
(define-syntax cond
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#f
|
||||
((lambda (cl)
|
||||
(if (compare 'else (car cl))
|
||||
(cons (rename 'begin) (cdr cl))
|
||||
(if (if (null? (cdr cl)) #t (compare '=> (cadr cl)))
|
||||
(list (list (rename 'lambda) (list (rename 'tmp))
|
||||
(list (rename 'if) (rename 'tmp)
|
||||
(if (null? (cdr cl))
|
||||
(rename 'tmp)
|
||||
(list (caddr cl) (rename 'tmp)))
|
||||
(cons (rename 'cond) (cddr expr))))
|
||||
(car cl))
|
||||
(list (rename 'if)
|
||||
(car cl)
|
||||
(cons (rename 'begin) (cdr cl))
|
||||
(cons (rename 'cond) (cddr expr))))))
|
||||
(cadr expr))))))
|
||||
|
||||
(define-syntax or
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(cond ((null? (cdr expr)) #f)
|
||||
((null? (cddr expr)) (cadr expr))
|
||||
(else
|
||||
(list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
|
||||
(list (rename 'if) (rename 'tmp)
|
||||
(rename 'tmp)
|
||||
(cons (rename 'or) (cddr expr)))))))))
|
||||
|
||||
(define-syntax and
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(cond ((null? (cdr expr)))
|
||||
((null? (cddr expr)) (cadr expr))
|
||||
(else (list (rename 'if) (cadr expr)
|
||||
(cons (rename 'and) (cddr expr))
|
||||
#f))))))
|
||||
|
||||
(define-syntax quasiquote
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(define (qq x d)
|
||||
(cond
|
||||
((pair? x)
|
||||
(cond
|
||||
((eq? 'unquote (car x))
|
||||
(if (<= d 0)
|
||||
(cadr x)
|
||||
(list (rename 'list) (list (rename 'quote) 'unquote)
|
||||
(qq (cadr x) (- d 1)))))
|
||||
((eq? 'unquote-splicing (car x))
|
||||
(if (<= d 0)
|
||||
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
|
||||
(list (rename 'list) (list (rename 'quote) 'unquote-splicing)
|
||||
(qq (cadr x) (- d 1)))))
|
||||
((eq? 'quasiquote (car x))
|
||||
(list (rename 'list) (list (rename 'quote) 'quasiquote)
|
||||
(qq (cadr x) (+ d 1))))
|
||||
((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x)))
|
||||
(if (null? (cdr x))
|
||||
(cadar x)
|
||||
(list (rename 'append) (cadar x) (qq (cdr x) d))))
|
||||
(else
|
||||
(list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
|
||||
((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
|
||||
((symbol? x) (list (rename 'quote) x))
|
||||
(else x)))
|
||||
(qq (cadr expr) 0))))
|
||||
|
||||
(define-syntax letrec
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
((lambda (defs)
|
||||
`((,(rename 'lambda) () ,@defs ,@(cddr expr))))
|
||||
(map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
|
||||
|
||||
(define-syntax let
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (identifier? (cadr expr))
|
||||
`(,(rename 'letrec) ((,(cadr expr)
|
||||
(,(rename 'lambda) ,(map car (caddr expr))
|
||||
,@(cdddr expr))))
|
||||
,(cons (cadr expr) (map cadr (caddr expr))))
|
||||
`((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr))
|
||||
,@(map cadr (cadr expr)))))))
|
||||
|
||||
(define-syntax let*
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cadr expr))
|
||||
`(,(rename 'begin) ,@(cddr expr))
|
||||
`(,(rename 'let) (,(caadr expr))
|
||||
(,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))))))
|
||||
|
||||
(define-syntax case
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(define (clause ls)
|
||||
(cond
|
||||
((null? ls) #f)
|
||||
((compare 'else (caar ls))
|
||||
`(,(rename 'begin) ,@(cdar ls)))
|
||||
(else
|
||||
(if (and (pair? (caar ls)) (null? (cdaar ls)))
|
||||
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls))
|
||||
(,(rename 'begin) ,@(cdar ls))
|
||||
,(clause (cdr ls)))
|
||||
`(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls))
|
||||
(,(rename 'begin) ,@(cdar ls))
|
||||
,(clause (cdr ls)))))))
|
||||
`(let ((,(rename 'tmp) ,(cadr expr)))
|
||||
,(clause (cddr expr))))))
|
||||
|
||||
(define-syntax do
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let* ((body
|
||||
`(,(rename 'begin)
|
||||
,@(cdddr expr)
|
||||
(,(rename 'lp)
|
||||
,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x)))
|
||||
(cadr expr)))))
|
||||
(check (caddr expr))
|
||||
(wrap
|
||||
(if (null? (cdr check))
|
||||
`(,(rename 'let) ((,(rename 'tmp) ,(car check)))
|
||||
(,(rename 'if) ,(rename 'tmp)
|
||||
,(rename 'tmp)
|
||||
,body))
|
||||
`(,(rename 'if) ,(car check)
|
||||
(,(rename 'begin) ,@(cdr check))
|
||||
,body))))
|
||||
`(,(rename 'let) ,(rename 'lp)
|
||||
,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
|
||||
,wrap)))))
|
||||
|
||||
(define-syntax delay
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
`(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
|
||||
|
||||
(define (make-promise thunk)
|
||||
(lambda ()
|
||||
(let ((computed? #f) (result #f))
|
||||
(if (not computed?)
|
||||
(begin
|
||||
(set! result (thunk))
|
||||
(set! computed? #t)))
|
||||
result)))
|
||||
|
||||
(define (force x) (if (procedure? x) (x) x))
|
||||
|
||||
(define (error msg . args)
|
||||
(raise (make-exception 'user msg args #f #f #f)))
|
||||
|
||||
(define (with-exception-handler handler thunk)
|
||||
(let ((orig-handler (current-exception-handler)))
|
||||
(current-exception-handler handler)
|
||||
(let ((res (thunk)))
|
||||
(current-exception-handler orig-handler)
|
||||
res)))
|
||||
|
||||
;; booleans
|
||||
|
||||
(define (not x) (if x #f #t))
|
||||
(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
|
||||
|
||||
;; char utils
|
||||
|
||||
(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90))
|
||||
(define (char-numeric? ch) (<= 48 (char->integer ch) 57))
|
||||
(define (char-whitespace? ch)
|
||||
(if (eq? ch #\space)
|
||||
#t
|
||||
(if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return)))))
|
||||
(define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
|
||||
(define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
|
||||
|
||||
(define (char=? a b) (= (char->integer a) (char->integer b)))
|
||||
(define (char<? a b) (< (char->integer a) (char->integer b)))
|
||||
(define (char>? a b) (> (char->integer a) (char->integer b)))
|
||||
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
|
||||
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
|
||||
|
||||
(define (char-ci=? a b)
|
||||
(= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
|
||||
(define (char-ci<? a b)
|
||||
(< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
|
||||
(define (char-ci>? a b)
|
||||
(> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
|
||||
(define (char-ci<=? a b)
|
||||
(<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
|
||||
(define (char-ci>=? a b)
|
||||
(>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
|
||||
|
||||
;; string utils
|
||||
|
||||
(define (symbol->string sym)
|
||||
(call-with-output-string (lambda (out) (write sym out))))
|
||||
|
||||
(define (list->string ls)
|
||||
(let ((str (make-string (length ls) #\space)))
|
||||
(let lp ((ls ls) (i 0))
|
||||
(if (pair? ls)
|
||||
(begin
|
||||
(string-set! str i (car ls))
|
||||
(lp (cdr ls) (+ i 1)))))
|
||||
str))
|
||||
|
||||
(define (string->list str)
|
||||
(let lp ((i (- (string-length str) 1)) (res '()))
|
||||
(if (< i 0) res (lp (- i 1) (cons (string-ref str i) res)))))
|
||||
|
||||
(define (string-fill! str ch)
|
||||
(let lp ((i (- (string-length str) 1)))
|
||||
(if (>= i 0) (begin (string-set! str i ch) (lp (- i 1))))))
|
||||
|
||||
(define (string . args) (list->string args))
|
||||
(define (string-append . args) (string-concatenate args))
|
||||
(define (string-copy s) (substring s 0 (string-length s)))
|
||||
|
||||
(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0))
|
||||
(define (string<? s1 s2) (< (string-cmp s1 s2 #f) 0))
|
||||
(define (string<=? s1 s2) (<= (string-cmp s1 s2 #f) 0))
|
||||
(define (string>? s1 s2) (> (string-cmp s1 s2 #f) 0))
|
||||
(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0))
|
||||
|
||||
(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0))
|
||||
(define (string-ci<? s1 s2) (< (string-cmp s1 s2 #t) 0))
|
||||
(define (string-ci<=? s1 s2) (<= (string-cmp s1 s2 #t) 0))
|
||||
(define (string-ci>? s1 s2) (> (string-cmp s1 s2 #t) 0))
|
||||
(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0))
|
||||
|
||||
;; list utils
|
||||
|
||||
(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 memv member)
|
||||
|
||||
(define (assoc obj ls)
|
||||
(if (null? ls)
|
||||
#f
|
||||
(if (equal? obj (caar ls))
|
||||
(car ls)
|
||||
(assoc obj (cdr ls)))))
|
||||
|
||||
(define assv assoc)
|
||||
|
||||
;; math utils
|
||||
|
||||
(define (number? x) (if (fixnum? x) #t (flonum? x)))
|
||||
(define complex? number?)
|
||||
(define rational? number?)
|
||||
(define real? number?)
|
||||
(define exact? fixnum?)
|
||||
(define inexact? flonum?)
|
||||
(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x)))))
|
||||
|
||||
(define (zero? x) (= x 0))
|
||||
(define (positive? x) (> x 0))
|
||||
(define (negative? x) (< x 0))
|
||||
(define (even? n) (= (remainder n 2) 0))
|
||||
(define (odd? n) (= (remainder n 2) 1))
|
||||
|
||||
(define (abs x) (if (< x 0) (- x) x))
|
||||
|
||||
(define (modulo a b)
|
||||
(let ((res (remainder a b)))
|
||||
(if (< b 0)
|
||||
(if (<= res 0) res (+ res b))
|
||||
(if (>= res 0) res (+ res b)))))
|
||||
|
||||
(define (gcd a b)
|
||||
(if (= b 0)
|
||||
(abs a)
|
||||
(gcd b (remainder a b))))
|
||||
|
||||
(define (lcm a b)
|
||||
(abs (quotient (* a b) (gcd a b))))
|
||||
|
||||
(define (max x . rest)
|
||||
(let lp ((hi x) (ls rest))
|
||||
(if (null? ls)
|
||||
hi
|
||||
(lp (if (> (car ls) hi) (car ls) hi) (cdr ls)))))
|
||||
|
||||
(define (min x . rest)
|
||||
(let lp ((lo x) (ls rest))
|
||||
(if (null? ls)
|
||||
lo
|
||||
(lp (if (< (car ls) lo) (car ls) lo) (cdr ls)))))
|
||||
|
||||
(define (real-part z) z)
|
||||
(define (imag-part z) 0.0)
|
||||
(define magnitude abs)
|
||||
(define (angle z) (if (< z 0) 3.141592653589793 0))
|
||||
|
||||
(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o)))))
|
||||
|
||||
(define (digit-char n) (integer->char (+ n (char->integer #\0))))
|
||||
(define (digit-value ch)
|
||||
(if (char-numeric? ch)
|
||||
(- (char->integer ch) (char->integer #\0))
|
||||
(and (<= 65 (char->integer (char-upcase ch)) 70)
|
||||
(- (char->integer (char-upcase ch)) 65))))
|
||||
|
||||
(define (number->string n . o)
|
||||
(if (if (null? o) #t (eq? 10 (car o)))
|
||||
(call-with-output-string (lambda (out) (write n out)))
|
||||
(let lp ((n n) (d (car o)) (res '()))
|
||||
(if (> n 0)
|
||||
(lp (quotient n d) d (cons (digit-char (remainder n d)) res))
|
||||
(list->string res)))))
|
||||
|
||||
(define (string->number str . o)
|
||||
(let ((res
|
||||
(if (if (null? o) #t (eq? 10 (car o)))
|
||||
(call-with-input-string str (lambda (in) (read in)))
|
||||
(let ((len (string-length str)))
|
||||
(let lp ((i 0) (d (car o)) (acc 0))
|
||||
(if (>= i len)
|
||||
acc
|
||||
(let ((v (digit-value (string-ref str i))))
|
||||
(and v (lp (+ i 1) d (+ (* acc d) v))))))))))
|
||||
(and (number? res) res)))
|
||||
|
||||
;; vector utils
|
||||
|
||||
(define (list->vector ls)
|
||||
(let ((vec (make-vector (length ls) #f)))
|
||||
(let lp ((ls ls) (i 0))
|
||||
(if (pair? ls)
|
||||
(begin
|
||||
(vector-set! vec i (car ls))
|
||||
(lp (cdr ls) (+ i 1)))))
|
||||
vec))
|
||||
|
||||
(define (vector->list vec)
|
||||
(let lp ((i (- (vector-length vec) 1)) (res '()))
|
||||
(if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res)))))
|
||||
|
||||
(define (vector-fill! str ch)
|
||||
(let lp ((i (- (vector-length str) 1)))
|
||||
(if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1))))))
|
||||
|
||||
(define (vector . args) (list->vector args))
|
||||
|
||||
;; I/O utils
|
||||
|
||||
(define (char-ready? . o)
|
||||
(not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
|
||||
|
||||
(define (load file) (%load file (interaction-environment)))
|
||||
|
||||
(define (call-with-input-string str proc)
|
||||
(let* ((in (open-input-string str))
|
||||
(res (proc in)))
|
||||
(close-input-port in)
|
||||
res))
|
||||
|
||||
(define (call-with-output-string proc)
|
||||
(let ((out (open-output-string)))
|
||||
(proc out)
|
||||
(let ((res (get-output-string out)))
|
||||
(close-output-port out)
|
||||
res)))
|
||||
|
||||
(define (call-with-input-file file proc)
|
||||
(let* ((in (open-input-file file))
|
||||
(res (proc in)))
|
||||
(close-input-port in)
|
||||
res))
|
||||
|
||||
(define (call-with-output-file file proc)
|
||||
(let* ((out (open-output-file file))
|
||||
(res (proc out)))
|
||||
(close-output-port out)
|
||||
res))
|
||||
|
||||
(define (with-input-from-file file thunk)
|
||||
(let ((old-in (current-input-port))
|
||||
(tmp-in (open-input-file file)))
|
||||
(current-input-port tmp-in)
|
||||
(let ((res (thunk)))
|
||||
(current-input-port old-in)
|
||||
res)))
|
||||
|
||||
(define (with-output-to-file file thunk)
|
||||
(let ((old-out (current-input-port))
|
||||
(tmp-out (open-output-file file)))
|
||||
(current-input-port tmp-out)
|
||||
(let ((res (thunk)))
|
||||
(current-output-port old-out)
|
||||
res)))
|
||||
|
||||
;; values
|
||||
|
||||
(define *values-tag* (list 'values))
|
||||
|
||||
(define (values . ls)
|
||||
(if (and (pair? ls) (null? (cdr ls)))
|
||||
(car ls)
|
||||
(cons *values-tag* ls)))
|
||||
|
||||
(define (call-with-values producer consumer)
|
||||
(let ((res (producer)))
|
||||
(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"))))))))))
|
||||
147
main.c
Normal file
147
main.c
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
/* main.c -- chibi-scheme command-line app */
|
||||
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#ifndef PLAN9
|
||||
#include <sys/stat.h>
|
||||
#endif
|
||||
#include "chibi/eval.h"
|
||||
|
||||
char *chibi_module_dir = NULL;
|
||||
|
||||
sexp find_module_file (sexp ctx, char *file) {
|
||||
sexp res;
|
||||
int mlen, flen;
|
||||
char *path;
|
||||
#ifndef PLAN9
|
||||
struct stat buf;
|
||||
|
||||
if (! stat(file, &buf))
|
||||
#endif
|
||||
return sexp_c_string(ctx, file, -1);
|
||||
#ifndef PLAN9
|
||||
if (! chibi_module_dir) {
|
||||
#ifndef PLAN9
|
||||
chibi_module_dir = getenv("CHIBI_MODULE_DIR");
|
||||
if (! chibi_module_dir)
|
||||
#endif
|
||||
chibi_module_dir = sexp_module_dir;
|
||||
}
|
||||
mlen = strlen(chibi_module_dir);
|
||||
flen = strlen(file);
|
||||
path = (char*) malloc(mlen+flen+2);
|
||||
memcpy(path, chibi_module_dir, mlen);
|
||||
path[mlen] = '/';
|
||||
memcpy(path+mlen+1, file, flen);
|
||||
path[mlen+flen+1] = '\0';
|
||||
if (! stat(path, &buf))
|
||||
res = sexp_c_string(ctx, path, mlen+flen+2);
|
||||
else
|
||||
res = SEXP_FALSE;
|
||||
free(path);
|
||||
return res;
|
||||
#endif
|
||||
}
|
||||
|
||||
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)");
|
||||
sexp_port_sourcep(in) = 1;
|
||||
while (1) {
|
||||
sexp_write_string(ctx, "> ", out);
|
||||
sexp_flush(ctx, out);
|
||||
obj = sexp_read(ctx, in);
|
||||
if (obj == SEXP_EOF)
|
||||
break;
|
||||
if (sexp_exceptionp(obj)) {
|
||||
sexp_print_exception(ctx, obj, err);
|
||||
} else {
|
||||
tmp = sexp_env_bindings(env);
|
||||
sexp_context_top(ctx) = 0;
|
||||
res = sexp_eval(ctx, obj);
|
||||
#if USE_WARN_UNDEFS
|
||||
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err);
|
||||
#endif
|
||||
if (res != SEXP_VOID) {
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
}
|
||||
}
|
||||
sexp_gc_release(ctx, obj, s_obj);
|
||||
}
|
||||
|
||||
void run_main (int argc, char **argv) {
|
||||
sexp env, out=NULL, res, ctx;
|
||||
sexp_uint_t i, quit=0, init_loaded=0;
|
||||
sexp_gc_var(ctx, str, s_str);
|
||||
|
||||
ctx = sexp_make_context(NULL, NULL, NULL);
|
||||
sexp_gc_preserve(ctx, str, s_str);
|
||||
env = sexp_context_env(ctx);
|
||||
out = sexp_eval_string(ctx, "(current-output-port)");
|
||||
|
||||
/* parse options */
|
||||
for (i=1; i < argc && argv[i][0] == '-'; i++) {
|
||||
switch (argv[i][1]) {
|
||||
case 'e':
|
||||
case 'p':
|
||||
if (! init_loaded++)
|
||||
sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env);
|
||||
res = sexp_read_from_string(ctx, argv[i+1]);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_eval(ctx, res);
|
||||
if (sexp_exceptionp(res)) {
|
||||
sexp_print_exception(ctx, res, out);
|
||||
quit = 1;
|
||||
break;
|
||||
} else if (argv[i][1] == 'p') {
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
quit=1;
|
||||
i++;
|
||||
break;
|
||||
case 'l':
|
||||
if (! init_loaded++)
|
||||
sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env);
|
||||
sexp_load(ctx, str=find_module_file(ctx, argv[++i]), env);
|
||||
break;
|
||||
case 'q':
|
||||
init_loaded = 1;
|
||||
break;
|
||||
case 'm':
|
||||
chibi_module_dir = argv[++i];
|
||||
break;
|
||||
default:
|
||||
errx(1, "unknown option: %s", argv[i]);
|
||||
}
|
||||
}
|
||||
|
||||
if (! quit) {
|
||||
if (! init_loaded)
|
||||
res = sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env);
|
||||
if (! sexp_exceptionp(res)) {
|
||||
if (i < argc)
|
||||
for ( ; i < argc; i++)
|
||||
sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env);
|
||||
else
|
||||
repl(ctx);
|
||||
}
|
||||
}
|
||||
|
||||
sexp_gc_release(ctx, str, s_str);
|
||||
}
|
||||
|
||||
int main (int argc, char **argv) {
|
||||
sexp_scheme_init();
|
||||
run_main(argc, argv);
|
||||
return 0;
|
||||
}
|
||||
|
||||
36
mkfile
Normal file
36
mkfile
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
</$objtype/mkfile
|
||||
|
||||
BIN=/$objtype/bin
|
||||
TARG=chibi-scheme
|
||||
MODDIR=/sys/lib/chibi-scheme
|
||||
|
||||
CPPFLAGS= -Iinclude -DPLAN9 -DUSE_STRING_STREAMS=0 -DUSE_DEBUG=0
|
||||
CFLAGS= -c -B $CPPFLAGS
|
||||
|
||||
OFILES=sexp.$O eval.$O main.$O
|
||||
|
||||
HFILES=include/chibi/sexp.h include/chibi/eval.h include/chibi/config.h
|
||||
|
||||
include/chibi/install.h: mkfile
|
||||
echo '#define sexp_module_dir "'$MODDIR'"' > include/chibi/install.h
|
||||
|
||||
%.i: %.c include/chibi/install.h $HFILES
|
||||
cpp $CPPFLAGS $stem.c > $target
|
||||
|
||||
sexp.$O: sexp.i
|
||||
$CC $CFLAGS -c -o $target sexp.i
|
||||
|
||||
eval.$O: eval.i
|
||||
$CC $CFLAGS -c -o $target eval.i
|
||||
|
||||
main.$O: main.i
|
||||
$CC $CFLAGS -c -o $target main.i
|
||||
|
||||
chibi-scheme: sexp.$O eval.$O main.$O
|
||||
$LD -o $target $prereq
|
||||
|
||||
#</sys/src/cmd/mkone
|
||||
|
||||
install:
|
||||
mkdir $MODDIR
|
||||
cp init.scm $MODDIR
|
||||
129
opcodes.c
Normal file
129
opcodes.c
Normal file
|
|
@ -0,0 +1,129 @@
|
|||
|
||||
#define _OP(c,o,n,m,t,u,i,s,f,d) \
|
||||
{.tag=SEXP_OPCODE, \
|
||||
.value={.opcode={c, o, n, m, t, u, i, s, d, f, NULL}}}
|
||||
#define _FN(o,n,m,t,u,s,f,d) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp)d)
|
||||
#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d)
|
||||
#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d)
|
||||
#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d)
|
||||
#define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d)
|
||||
#define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d)
|
||||
#define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d)
|
||||
#define _FN5(t, u, s, f, d) _FN(OP_FCALL5, 5, 0, t, u, s, f, d)
|
||||
#define _FN6(t, u, s, f, d) _FN(OP_FCALL6, 6, 0, t, u, s, f, d)
|
||||
#define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0)
|
||||
|
||||
static struct sexp_struct opcodes[] = {
|
||||
_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_integer(0), NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_integer(1), NULL),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL),
|
||||
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", 0, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", 0, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", 0, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT),
|
||||
_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL),
|
||||
_OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL),
|
||||
_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL),
|
||||
_FN2(0, 0, "equal?", 0, sexp_equalp),
|
||||
_FN1(0, "list?", 0, sexp_listp),
|
||||
_FN1(0, "identifier?", 0, sexp_identifierp),
|
||||
_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr),
|
||||
_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq),
|
||||
_FN1(SEXP_PAIR, "length", 0, sexp_length),
|
||||
_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse),
|
||||
_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse),
|
||||
_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2),
|
||||
_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector),
|
||||
_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_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),
|
||||
_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception),
|
||||
_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func),
|
||||
_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception),
|
||||
_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string),
|
||||
_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp),
|
||||
_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring),
|
||||
_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol),
|
||||
_FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate),
|
||||
_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq),
|
||||
_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq),
|
||||
_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo),
|
||||
_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT),
|
||||
_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
|
||||
_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
|
||||
_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE),
|
||||
_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
|
||||
#if USE_MATH
|
||||
_FN1(0, "exp", 0, sexp_exp),
|
||||
_FN1(0, "log", 0, sexp_log),
|
||||
_FN1(0, "sin", 0, sexp_sin),
|
||||
_FN1(0, "cos", 0, sexp_cos),
|
||||
_FN1(0, "tan", 0, sexp_tan),
|
||||
_FN1(0, "asin", 0, sexp_asin),
|
||||
_FN1(0, "acos", 0, sexp_acos),
|
||||
_FN1(0, "atan1", 0, sexp_atan),
|
||||
_FN1(0, "sqrt", 0, sexp_sqrt),
|
||||
_FN1(0, "round", 0, sexp_round),
|
||||
_FN1(0, "truncate", 0, sexp_trunc),
|
||||
_FN1(0, "floor", 0, sexp_floor),
|
||||
_FN1(0, "ceiling", 0, sexp_ceiling),
|
||||
_FN2(0, 0, "expt", 0, sexp_expt),
|
||||
#endif
|
||||
_FN0("open-output-string", 0, sexp_make_output_string_port),
|
||||
_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port),
|
||||
_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string),
|
||||
#if USE_DEBUG
|
||||
_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm),
|
||||
#endif
|
||||
};
|
||||
|
||||
128
opt/sexp-huff.c
Normal file
128
opt/sexp-huff.c
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
{12, 0x0C00}, /* '\x00' */
|
||||
{15, 0x0000}, /* '\x01' */
|
||||
{15, 0x4000}, /* '\x02' */
|
||||
{15, 0x2000}, /* '\x03' */
|
||||
{15, 0x6000}, /* '\x04' */
|
||||
{15, 0x0800}, /* '\x05' */
|
||||
{15, 0x4800}, /* '\x06' */
|
||||
{15, 0x2800}, /* '\x07' */
|
||||
{15, 0x6800}, /* '\x08' */
|
||||
{15, 0x1800}, /* '\x09' */
|
||||
{15, 0x5800}, /* '\x0a' */
|
||||
{15, 0x3800}, /* '\x0b' */
|
||||
{15, 0x7800}, /* '\x0c' */
|
||||
{15, 0x0100}, /* '\x0d' */
|
||||
{15, 0x4100}, /* '\x0e' */
|
||||
{15, 0x2100}, /* '\x0f' */
|
||||
{15, 0x6100}, /* '\x10' */
|
||||
{15, 0x1100}, /* '\x11' */
|
||||
{15, 0x5100}, /* '\x12' */
|
||||
{15, 0x3100}, /* '\x13' */
|
||||
{15, 0x7100}, /* '\x14' */
|
||||
{15, 0x0900}, /* '\x15' */
|
||||
{15, 0x4900}, /* '\x16' */
|
||||
{15, 0x2900}, /* '\x17' */
|
||||
{15, 0x6900}, /* '\x18' */
|
||||
{15, 0x1900}, /* '\x19' */
|
||||
{15, 0x5900}, /* '\x1a' */
|
||||
{15, 0x3900}, /* '\x1b' */
|
||||
{15, 0x7900}, /* '\x1c' */
|
||||
{15, 0x0500}, /* '\x1d' */
|
||||
{15, 0x4500}, /* '\x1e' */
|
||||
{15, 0x2500}, /* '\x1f' */
|
||||
{15, 0x6500}, /* '\x20' */
|
||||
{ 8, 0x0040}, /* '!' */
|
||||
{15, 0x1500}, /* '"' */
|
||||
{15, 0x5500}, /* '#' */
|
||||
{15, 0x3500}, /* '$' */
|
||||
{15, 0x7500}, /* '%' */
|
||||
{15, 0x0D00}, /* '&' */
|
||||
{15, 0x4D00}, /* '\'' */
|
||||
{15, 0x2D00}, /* '(' */
|
||||
{15, 0x6D00}, /* ')' */
|
||||
{11, 0x0300}, /* '*' */
|
||||
{10, 0x0180}, /* '+' */
|
||||
{15, 0x1D00}, /* ',' */
|
||||
{ 4, 0x000D}, /* '-' */
|
||||
{15, 0x5D00}, /* '.' */
|
||||
{10, 0x0380}, /* '/' */
|
||||
{15, 0x3D00}, /* '0' */
|
||||
{15, 0x7D00}, /* '1' */
|
||||
{14, 0x0080}, /* '2' */
|
||||
{14, 0x2080}, /* '3' */
|
||||
{14, 0x1080}, /* '4' */
|
||||
{14, 0x3080}, /* '5' */
|
||||
{14, 0x0880}, /* '6' */
|
||||
{14, 0x2880}, /* '7' */
|
||||
{14, 0x1880}, /* '8' */
|
||||
{14, 0x3880}, /* '9' */
|
||||
{14, 0x0480}, /* ':' */
|
||||
{14, 0x2480}, /* ';' */
|
||||
{ 7, 0x0050}, /* '<' */
|
||||
{ 7, 0x0042}, /* '=' */
|
||||
{ 7, 0x0022}, /* '>' */
|
||||
{ 5, 0x0009}, /* '?' */
|
||||
{14, 0x1480}, /* '@' */
|
||||
{14, 0x3480}, /* 'A' */
|
||||
{14, 0x0C80}, /* 'B' */
|
||||
{14, 0x2C80}, /* 'C' */
|
||||
{14, 0x1C80}, /* 'D' */
|
||||
{14, 0x3C80}, /* 'E' */
|
||||
{14, 0x0280}, /* 'F' */
|
||||
{14, 0x2280}, /* 'G' */
|
||||
{14, 0x1280}, /* 'H' */
|
||||
{14, 0x3280}, /* 'I' */
|
||||
{14, 0x0A80}, /* 'J' */
|
||||
{14, 0x2A80}, /* 'K' */
|
||||
{14, 0x1A80}, /* 'L' */
|
||||
{14, 0x3A80}, /* 'M' */
|
||||
{14, 0x0680}, /* 'N' */
|
||||
{14, 0x2680}, /* 'O' */
|
||||
{14, 0x1680}, /* 'P' */
|
||||
{14, 0x3680}, /* 'Q' */
|
||||
{14, 0x0E80}, /* 'R' */
|
||||
{14, 0x2E80}, /* 'S' */
|
||||
{14, 0x1E80}, /* 'T' */
|
||||
{14, 0x3E80}, /* 'U' */
|
||||
{14, 0x0200}, /* 'V' */
|
||||
{14, 0x2200}, /* 'W' */
|
||||
{14, 0x1200}, /* 'X' */
|
||||
{14, 0x3200}, /* 'Y' */
|
||||
{14, 0x0A00}, /* 'Z' */
|
||||
{14, 0x2A00}, /* '[' */
|
||||
{14, 0x1A00}, /* '\\' */
|
||||
{14, 0x3A00}, /* ']' */
|
||||
{14, 0x0600}, /* '^' */
|
||||
{14, 0x2600}, /* '_' */
|
||||
{14, 0x1600}, /* '`' */
|
||||
{ 3, 0x0007}, /* 'a' */
|
||||
{ 7, 0x0020}, /* 'b' */
|
||||
{ 4, 0x0004}, /* 'c' */
|
||||
{ 5, 0x001A}, /* 'd' */
|
||||
{ 4, 0x0006}, /* 'e' */
|
||||
{ 7, 0x0002}, /* 'f' */
|
||||
{ 5, 0x0011}, /* 'g' */
|
||||
{ 6, 0x0012}, /* 'h' */
|
||||
{ 4, 0x000C}, /* 'i' */
|
||||
{12, 0x0400}, /* 'j' */
|
||||
{ 8, 0x00C0}, /* 'k' */
|
||||
{ 5, 0x0018}, /* 'l' */
|
||||
{ 6, 0x0032}, /* 'm' */
|
||||
{ 4, 0x0005}, /* 'n' */
|
||||
{ 5, 0x000A}, /* 'o' */
|
||||
{ 5, 0x0001}, /* 'p' */
|
||||
{ 7, 0x0070}, /* 'q' */
|
||||
{ 3, 0x0003}, /* 'r' */
|
||||
{ 5, 0x0008}, /* 's' */
|
||||
{ 4, 0x000E}, /* 't' */
|
||||
{ 5, 0x0019}, /* 'u' */
|
||||
{ 7, 0x0062}, /* 'v' */
|
||||
{ 7, 0x0030}, /* 'w' */
|
||||
{ 7, 0x0060}, /* 'x' */
|
||||
{ 7, 0x0010}, /* 'y' */
|
||||
{11, 0x0700}, /* 'z' */
|
||||
{14, 0x3600}, /* '{' */
|
||||
{14, 0x0E00}, /* '|' */
|
||||
{14, 0x2E00}, /* '}' */
|
||||
{14, 0x1E00}, /* '~' */
|
||||
{14, 0x3E00}, /* '\x7f' */
|
||||
92
opt/sexp-hufftabs.c
Normal file
92
opt/sexp-hufftabs.c
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
|
||||
|
||||
char _huff_tab21[] = {
|
||||
'\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00',
|
||||
};
|
||||
|
||||
char _huff_tab19[] = {
|
||||
'\x01', 'j', '\x01', '\x00',
|
||||
};
|
||||
|
||||
char _huff_tab20[] = {
|
||||
'\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c',
|
||||
};
|
||||
|
||||
char _huff_tab18[] = {
|
||||
'2', ':', '6', 'B', '4', '@', '8', 'D',
|
||||
'3', ';', '7', 'C', '5', 'A', '9', 'E',
|
||||
};
|
||||
|
||||
char _huff_tab17[] = {
|
||||
'\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',',
|
||||
'\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0',
|
||||
'\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.',
|
||||
'\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1',
|
||||
};
|
||||
|
||||
char _huff_tab16[] = {
|
||||
'V', '^', 'Z', '|', 'X', '`', '\\', '~',
|
||||
'W', '_', '[', '}', 'Y', '{', ']', '\x7f',
|
||||
};
|
||||
|
||||
char _huff_tab15[] = {
|
||||
'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T',
|
||||
'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U',
|
||||
};
|
||||
|
||||
char _huff_tab13[] = {
|
||||
'\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/',
|
||||
};
|
||||
|
||||
char _huff_tab14[] = {
|
||||
'*', 'z',
|
||||
};
|
||||
|
||||
char _huff_tab11[] = {
|
||||
'\x00', 'b', '\x00', 'x',
|
||||
};
|
||||
|
||||
char _huff_tab12[] = {
|
||||
'!', 'k',
|
||||
};
|
||||
|
||||
char _huff_tab9[] = {
|
||||
'\x00', 's', '\x00', 'l',
|
||||
};
|
||||
|
||||
char _huff_tab10[] = {
|
||||
'y', 'w', '<', 'q',
|
||||
};
|
||||
|
||||
char _huff_tab8[] = {
|
||||
'p', '?', 'g', 'u',
|
||||
};
|
||||
|
||||
char _huff_tab7[] = {
|
||||
'f', '>', '=', 'v',
|
||||
};
|
||||
|
||||
char _huff_tab5[] = {
|
||||
'\x00', 'o', '\x00', 'd',
|
||||
};
|
||||
|
||||
char _huff_tab6[] = {
|
||||
'h', 'm',
|
||||
};
|
||||
|
||||
char _huff_tab4[] = {
|
||||
'c', 'i',
|
||||
};
|
||||
|
||||
char _huff_tab3[] = {
|
||||
'n', '-',
|
||||
};
|
||||
|
||||
char _huff_tab1[] = {
|
||||
'\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a',
|
||||
};
|
||||
|
||||
char _huff_tab2[] = {
|
||||
'e', 't',
|
||||
};
|
||||
|
||||
71
opt/sexp-unhuff.c
Normal file
71
opt/sexp-unhuff.c
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
|
||||
|
||||
res = c & 7;
|
||||
c = c >> 3;
|
||||
if (res == 0) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = c & 7;
|
||||
c = c >> 3;
|
||||
if (res == 0) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = _huff_tab21[c & 7];
|
||||
c = c >> 3;
|
||||
} else if ((res = _huff_tab19[res]) == '\x01') {
|
||||
res = _huff_tab20[c & 7];
|
||||
c = c >> 3;
|
||||
}
|
||||
} else if (res == 1) {
|
||||
res = _huff_tab18[c & 15];
|
||||
c = c >> 4;
|
||||
} else if (res == 2) {
|
||||
res = _huff_tab17[c & 31];
|
||||
c = c >> 5;
|
||||
} else if (res == 4) {
|
||||
res = _huff_tab16[c & 15];
|
||||
c = c >> 4;
|
||||
} else if (res == 5) {
|
||||
res = _huff_tab15[c & 15];
|
||||
c = c >> 4;
|
||||
} else if ((res = _huff_tab13[res]) == '\x00') {
|
||||
res = _huff_tab14[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
} else if ((res = _huff_tab11[res]) == '\x00') {
|
||||
res = _huff_tab12[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
} else if ((res = _huff_tab9[res]) == '\x00') {
|
||||
res = _huff_tab10[c & 3];
|
||||
c = c >> 2;
|
||||
}
|
||||
} else if (res == 1) {
|
||||
res = _huff_tab8[c & 3];
|
||||
c = c >> 2;
|
||||
} else if (res == 2) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = _huff_tab7[c & 3];
|
||||
c = c >> 2;
|
||||
} else if ((res = _huff_tab5[res]) == '\x00') {
|
||||
res = _huff_tab6[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
} else if (res == 4) {
|
||||
res = _huff_tab4[c & 1];
|
||||
c = c >> 1;
|
||||
} else if (res == 5) {
|
||||
res = _huff_tab3[c & 1];
|
||||
c = c >> 1;
|
||||
} else if ((res = _huff_tab1[res]) == '\x00') {
|
||||
res = _huff_tab2[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
|
||||
1
tests/basic/test00-fact-3.res
Normal file
1
tests/basic/test00-fact-3.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
(fact 3) => 6
|
||||
14
tests/basic/test00-fact-3.scm
Normal file
14
tests/basic/test00-fact-3.scm
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
(define (fact-helper x res)
|
||||
(if (= x 0)
|
||||
res
|
||||
(fact-helper (- x 1) (* res x))))
|
||||
|
||||
(define (fact x)
|
||||
(fact-helper x 1))
|
||||
|
||||
(display "(fact 3) => ")
|
||||
(write (fact 3))
|
||||
(newline)
|
||||
|
||||
|
||||
8
tests/basic/test01-apply.res
Normal file
8
tests/basic/test01-apply.res
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
11
|
||||
(11 10 9 8 7 6 5 4 3 2 1)
|
||||
(1 2 3 4)
|
||||
100
|
||||
100
|
||||
100
|
||||
100
|
||||
100
|
||||
18
tests/basic/test01-apply.scm
Normal file
18
tests/basic/test01-apply.scm
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
|
||||
(define foo
|
||||
(lambda (a b c d e f g h)
|
||||
(+ (+ (* a b) (* c d)) (+ (* e f) (* g h)))))
|
||||
|
||||
(define (writeln x)
|
||||
(write x)
|
||||
(newline))
|
||||
|
||||
(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11))))
|
||||
(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))
|
||||
(writeln (append (list 1 2) (list 3 4)))
|
||||
(writeln (foo 1 2 3 4 5 6 7 8))
|
||||
(writeln (apply foo (list 1 2 3 4 5 6 7 8)))
|
||||
(writeln (apply foo 1 (list 2 3 4 5 6 7 8)))
|
||||
(writeln (apply foo 1 2 3 4 (list 5 6 7 8)))
|
||||
(writeln (apply foo 1 2 3 4 5 (list 6 7 8)))
|
||||
|
||||
6
tests/basic/test02-closure.res
Normal file
6
tests/basic/test02-closure.res
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
1
|
||||
2
|
||||
101
|
||||
102
|
||||
3
|
||||
103
|
||||
16
tests/basic/test02-closure.scm
Normal file
16
tests/basic/test02-closure.scm
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
|
||||
(define (make-counter n)
|
||||
(lambda ()
|
||||
(set! n (+ n 1))
|
||||
n))
|
||||
|
||||
(define f (make-counter 0))
|
||||
(define g (make-counter 100))
|
||||
|
||||
(write (f)) (newline)
|
||||
(write (f)) (newline)
|
||||
(write (g)) (newline)
|
||||
(write (g)) (newline)
|
||||
(write (f)) (newline)
|
||||
(write (g)) (newline)
|
||||
|
||||
1
tests/basic/test03-nested-closure.res
Normal file
1
tests/basic/test03-nested-closure.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
11357
|
||||
8
tests/basic/test03-nested-closure.scm
Normal file
8
tests/basic/test03-nested-closure.scm
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
((lambda (a b)
|
||||
((lambda (c d e)
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline))
|
||||
(- a 2) (+ b 2) 10000))
|
||||
3 5)
|
||||
|
||||
1
tests/basic/test04-nested-let.res
Normal file
1
tests/basic/test04-nested-let.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
11357
|
||||
9
tests/basic/test04-nested-let.scm
Normal file
9
tests/basic/test04-nested-let.scm
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(let ((a 3)
|
||||
(b 5))
|
||||
(let ((c (- a 2))
|
||||
(d (+ b 2))
|
||||
(e 10000))
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline)))
|
||||
|
||||
1
tests/basic/test05-internal-define.res
Normal file
1
tests/basic/test05-internal-define.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
1000 1003
|
||||
8
tests/basic/test05-internal-define.scm
Normal file
8
tests/basic/test05-internal-define.scm
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(let ((a 1000))
|
||||
(define b (+ a 3))
|
||||
(write a)
|
||||
(display " ")
|
||||
(write b)
|
||||
(newline))
|
||||
|
||||
4
tests/basic/test06-letrec.res
Normal file
4
tests/basic/test06-letrec.res
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
7
|
||||
#t
|
||||
#f
|
||||
#f
|
||||
15
tests/basic/test06-letrec.scm
Normal file
15
tests/basic/test06-letrec.scm
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
|
||||
(letrec ((add (lambda (a b) (+ a b))))
|
||||
(write (add 3 4))
|
||||
(newline))
|
||||
|
||||
(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
|
||||
(odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))))
|
||||
(write (even? 1000))
|
||||
(newline)
|
||||
(write (even? 1001))
|
||||
(newline)
|
||||
(write (odd? 1000))
|
||||
(newline)
|
||||
)
|
||||
|
||||
1
tests/basic/test07-mutation.res
Normal file
1
tests/basic/test07-mutation.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
11357
|
||||
9
tests/basic/test07-mutation.scm
Normal file
9
tests/basic/test07-mutation.scm
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(let ((a 3)
|
||||
(b 5))
|
||||
(let ((c (- a 2))
|
||||
(d (+ b 2))
|
||||
(e #f))
|
||||
(set! e 10000)
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline)))
|
||||
1
tests/basic/test08-callcc.res
Normal file
1
tests/basic/test08-callcc.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
543
|
||||
34
tests/basic/test08-callcc.scm
Normal file
34
tests/basic/test08-callcc.scm
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
|
||||
(define fail
|
||||
(lambda () 999999))
|
||||
|
||||
(define in-range
|
||||
(lambda (a b)
|
||||
(call-with-current-continuation
|
||||
(lambda (cont)
|
||||
(enumerate a b cont)))))
|
||||
|
||||
(define enumerate
|
||||
(lambda (a b cont)
|
||||
(if (< b a)
|
||||
(fail)
|
||||
(let ((save fail))
|
||||
(begin
|
||||
(set! fail
|
||||
(lambda ()
|
||||
(begin
|
||||
(set! fail save)
|
||||
(enumerate (+ a 1) b cont))))
|
||||
(cont a))))))
|
||||
|
||||
(write
|
||||
(let ((x (in-range 2 9))
|
||||
(y (in-range 2 9))
|
||||
(z (in-range 2 9)))
|
||||
(if (= (* x x)
|
||||
(+ (* y y) (* z z)))
|
||||
(+ (* x 100) (+ (* y 10) z))
|
||||
(fail))))
|
||||
|
||||
(newline)
|
||||
|
||||
7
tests/basic/test09-hygiene.res
Normal file
7
tests/basic/test09-hygiene.res
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
6
|
||||
outer
|
||||
62
tests/basic/test09-hygiene.scm
Normal file
62
tests/basic/test09-hygiene.scm
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
|
||||
(write (or 1))
|
||||
(newline)
|
||||
(write (or #f 2))
|
||||
(newline)
|
||||
(write (or 3 #t))
|
||||
(newline)
|
||||
|
||||
(let ((tmp 4))
|
||||
(write (or #f tmp))
|
||||
(newline))
|
||||
|
||||
(write
|
||||
(letrec-syntax
|
||||
((myor
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#f
|
||||
(list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
|
||||
(list (rename 'if) (rename 'tmp)
|
||||
(rename 'tmp)
|
||||
(cons (rename 'myor) (cddr expr)))))))))
|
||||
(let ((tmp 5)) (myor #f tmp))))
|
||||
(newline)
|
||||
|
||||
(define-syntax myor
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#f
|
||||
(list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
|
||||
(list (rename 'if) (rename 'tmp)
|
||||
(rename 'tmp)
|
||||
(cons (rename 'myor) (cddr expr))))))))
|
||||
|
||||
(write (let ((tmp 6)) (myor #f tmp)))
|
||||
(newline)
|
||||
|
||||
;; (let ((x 'outer))
|
||||
;; (let-syntax ((with-x
|
||||
;; (syntax-rules ()
|
||||
;; ((_ y expr)
|
||||
;; (let-syntax ((y (syntax-rules () ((_) x))))
|
||||
;; expr)))))
|
||||
;; (let ((x 'inner))
|
||||
;; (write (with-x z (z)))
|
||||
;; (newline))))
|
||||
|
||||
(let ((x 'outer))
|
||||
(let-syntax ((with-x
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
`(let-syntax ((,(cadr form)
|
||||
(er-macro-transformer
|
||||
(lambda (form rename2 compare)
|
||||
(rename2 'x)))))
|
||||
,(caddr form))))))
|
||||
(let ((x 'inner))
|
||||
(write (with-x z (z)))
|
||||
(newline))))
|
||||
|
||||
6
tests/basic/test10-unhygiene.res
Normal file
6
tests/basic/test10-unhygiene.res
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
1
|
||||
1
|
||||
1
|
||||
6
|
||||
7
|
||||
8
|
||||
49
tests/basic/test10-unhygiene.scm
Normal file
49
tests/basic/test10-unhygiene.scm
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
|
||||
(define-syntax aif
|
||||
(sc-macro-transformer
|
||||
(lambda (form environment)
|
||||
(let ((condition
|
||||
(make-syntactic-closure environment '() (cadr form)))
|
||||
(consequent
|
||||
(make-syntactic-closure environment '(it) (caddr form)))
|
||||
(alternative
|
||||
(make-syntactic-closure environment '() (cadddr form))))
|
||||
`(let ((it ,condition))
|
||||
(if it
|
||||
,consequent
|
||||
,alternative))))))
|
||||
|
||||
(write (aif 1 it 3))
|
||||
(newline)
|
||||
|
||||
(write (let ((it 4)) (aif 1 it 3)))
|
||||
(newline)
|
||||
|
||||
(write (let ((it 4)) (aif (let ((it 5)) 1) it 3)))
|
||||
(newline)
|
||||
|
||||
(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3)))
|
||||
(newline)
|
||||
|
||||
(write
|
||||
(letrec-syntax
|
||||
((myor
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#f
|
||||
(list (rename 'let) (list (list (rename 'it) (cadr expr)))
|
||||
(list (rename 'if) (rename 'it)
|
||||
(rename 'it)
|
||||
(cons (rename 'myor) (cddr expr)))))))))
|
||||
(let ((it 7)) (myor #f it))))
|
||||
(newline)
|
||||
|
||||
(define-syntax define-foo
|
||||
(sc-macro-transformer
|
||||
(lambda (form environment)
|
||||
(make-syntactic-closure environment '(foo) `(define foo 8)))))
|
||||
|
||||
(define-foo)
|
||||
(write foo)
|
||||
(newline)
|
||||
377
tests/r5rs-tests.scm
Normal file
377
tests/r5rs-tests.scm
Normal file
|
|
@ -0,0 +1,377 @@
|
|||
|
||||
(define *tests-run* 0)
|
||||
(define *tests-passed* 0)
|
||||
|
||||
(define-syntax test
|
||||
(syntax-rules ()
|
||||
((test expect expr)
|
||||
(begin
|
||||
(set! *tests-run* (+ *tests-run* 1))
|
||||
(let ((str (call-with-output-string (lambda (out) (display 'expr out))))
|
||||
(res expr))
|
||||
(display str)
|
||||
(write-char #\space)
|
||||
(display (make-string (max 0 (- 72 (string-length str))) #\.))
|
||||
(flush-output)
|
||||
(cond
|
||||
((equal? res expect)
|
||||
(set! *tests-passed* (+ *tests-passed* 1))
|
||||
(display " [PASS]\n"))
|
||||
(else
|
||||
(display " [FAIL]\n")
|
||||
(display " expected ") (write expect)
|
||||
(display " but got ") (write res) (newline))))))))
|
||||
|
||||
(define (test-report)
|
||||
(write *tests-passed*)
|
||||
(display " out of ")
|
||||
(write *tests-run*)
|
||||
(display " passed (")
|
||||
(write (* (/ *tests-passed* *tests-run*) 100))
|
||||
(display "%)")
|
||||
(newline))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(test 8 ((lambda (x) (+ x x)) 4))
|
||||
|
||||
(test '(3 4 5 6) ((lambda x x) 3 4 5 6))
|
||||
|
||||
(test '(5 6) ((lambda (x y . z) z) 3 4 5 6))
|
||||
|
||||
(test 'yes (if (> 3 2) 'yes 'no))
|
||||
|
||||
(test 'no (if (> 2 3) 'yes 'no))
|
||||
|
||||
(test 1 (if (> 3 2) (- 3 2) (+ 3 2)))
|
||||
|
||||
(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less)))
|
||||
|
||||
(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)))
|
||||
|
||||
(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)))
|
||||
|
||||
(test 'consonant
|
||||
(case (car '(c d))
|
||||
((a e i o u) 'vowel)
|
||||
((w y) 'semivowel)
|
||||
(else 'consonant)))
|
||||
|
||||
(test #t (and (= 2 2) (> 2 1)))
|
||||
|
||||
(test #f (and (= 2 2) (< 2 1)))
|
||||
|
||||
(test '(f g) (and 1 2 'c '(f g)))
|
||||
|
||||
(test #t (and))
|
||||
|
||||
(test #t (or (= 2 2) (> 2 1)))
|
||||
|
||||
(test #t (or (= 2 2) (< 2 1)))
|
||||
|
||||
(test '(b c) (or (memq 'b '(a b c)) (/ 3 0)))
|
||||
|
||||
(test 6 (let ((x 2) (y 3)) (* x y)))
|
||||
|
||||
(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
|
||||
|
||||
(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
|
||||
|
||||
(test '#(0 1 2 3 4)
|
||||
(do ((vec (make-vector 5))
|
||||
(i 0 (+ i 1)))
|
||||
((= i 5) vec)
|
||||
(vector-set! vec i i)))
|
||||
|
||||
(test 25
|
||||
(let ((x '(1 3 5 7 9)))
|
||||
(do ((x x (cdr x))
|
||||
(sum 0 (+ sum (car x))))
|
||||
((null? x)
|
||||
sum))))
|
||||
|
||||
(test '((6 1 3) (-5 -2))
|
||||
(let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '()))
|
||||
(cond
|
||||
((null? numbers)
|
||||
(list nonneg neg))
|
||||
((>= (car numbers) 0)
|
||||
(loop (cdr numbers) (cons (car numbers) nonneg) neg))
|
||||
((< (car numbers) 0)
|
||||
(loop (cdr numbers) nonneg (cons (car numbers) neg))))))
|
||||
|
||||
(test '(list 3 4) `(list ,(+ 1 2) 4))
|
||||
|
||||
(test '(list a 'a) (let ((name 'a)) `(list ,name ',name)))
|
||||
|
||||
(test '(a 3 4 5 6 b)
|
||||
`(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
|
||||
|
||||
(test '(10 5 2 4 3 8)
|
||||
`(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
|
||||
|
||||
(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
|
||||
`(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
|
||||
|
||||
(test '(a `(b ,x ,'y d) e)
|
||||
(let ((name1 'x)
|
||||
(name2 'y))
|
||||
`(a `(b ,,name1 ,',name2 d) e)))
|
||||
|
||||
(test '(list 3 4)
|
||||
(quasiquote (list (unquote (+ 1 2)) 4)))
|
||||
|
||||
(test #t (eqv? 'a 'a))
|
||||
|
||||
(test #f (eqv? 'a 'b))
|
||||
|
||||
(test #t (eqv? '() '()))
|
||||
|
||||
(test #f (eqv? (cons 1 2) (cons 1 2)))
|
||||
|
||||
(test #f (eqv? (lambda () 1) (lambda () 2)))
|
||||
|
||||
(test #t (let ((p (lambda (x) x))) (eqv? p p)))
|
||||
|
||||
(test #t (eq? 'a 'a))
|
||||
|
||||
(test #f (eq? (list 'a) (list 'a)))
|
||||
|
||||
(test #t (eq? '() '()))
|
||||
|
||||
(test #t (eq? car car))
|
||||
|
||||
(test #t (let ((x '(a))) (eq? x x)))
|
||||
|
||||
(test #t (let ((p (lambda (x) x))) (eq? p p)))
|
||||
|
||||
(test #t (equal? 'a 'a))
|
||||
|
||||
(test #t (equal? '(a) '(a)))
|
||||
|
||||
(test #t (equal? '(a (b) c) '(a (b) c)))
|
||||
|
||||
(test #t (equal? "abc" "abc"))
|
||||
|
||||
(test #t (equal? 2 2))
|
||||
|
||||
(test #t (equal? (make-vector 5 'a) (make-vector 5 'a)))
|
||||
|
||||
(test 4 (max 3 4))
|
||||
|
||||
(test 4 (max 3.9 4))
|
||||
|
||||
(test 7 (+ 3 4))
|
||||
|
||||
(test 3 (+ 3))
|
||||
|
||||
(test 0 (+))
|
||||
|
||||
(test 4 (* 4))
|
||||
|
||||
(test 1 (*))
|
||||
|
||||
(test -1 (- 3 4))
|
||||
|
||||
(test -6 (- 3 4 5))
|
||||
|
||||
(test -3 (- 3))
|
||||
|
||||
(test 7 (abs -7))
|
||||
|
||||
(test 1 (modulo 13 4))
|
||||
|
||||
(test 1 (remainder 13 4))
|
||||
|
||||
(test 3 (modulo -13 4))
|
||||
|
||||
(test -1 (remainder -13 4))
|
||||
|
||||
(test -3 (modulo 13 -4))
|
||||
|
||||
(test 1 (remainder 13 -4))
|
||||
|
||||
(test -1 (modulo -13 -4))
|
||||
|
||||
(test -1 (remainder -13 -4))
|
||||
|
||||
(test 4 (gcd 32 -36))
|
||||
|
||||
(test 288 (lcm 32 -36))
|
||||
|
||||
(test -5 (floor -4.3))
|
||||
|
||||
(test -4 (ceiling -4.3))
|
||||
|
||||
(test -4 (truncate -4.3))
|
||||
|
||||
(test -4 (round -4.3))
|
||||
|
||||
(test 3 (floor 3.5))
|
||||
|
||||
(test 4 (ceiling 3.5))
|
||||
|
||||
(test 3 (truncate 3.5))
|
||||
|
||||
(test 4 (round 3.5))
|
||||
|
||||
(test 100 (string->number "100"))
|
||||
|
||||
(test 256 (string->number "100" 16))
|
||||
|
||||
(test 100 (string->number "1e2"))
|
||||
|
||||
(test #f (not 3))
|
||||
|
||||
(test #f (not (list 3)))
|
||||
|
||||
(test #f (not '()))
|
||||
|
||||
(test #f (not (list)))
|
||||
|
||||
(test #f (not '()))
|
||||
|
||||
(test #f (boolean? 0))
|
||||
|
||||
(test #f (boolean? '()))
|
||||
|
||||
(test #t (pair? '(a . b)))
|
||||
|
||||
(test #t (pair? '(a b c)))
|
||||
|
||||
(test '(a) (cons 'a '()))
|
||||
|
||||
(test '((a) b c d) (cons '(a) '(b c d)))
|
||||
|
||||
(test '("a" b c) (cons "a" '(b c)))
|
||||
|
||||
(test '(a . 3) (cons 'a 3))
|
||||
|
||||
(test '((a b) . c) (cons '(a b) 'c))
|
||||
|
||||
(test 'a (car '(a b c)))
|
||||
|
||||
(test '(a) (car '((a) b c d)))
|
||||
|
||||
(test 1 (car '(1 . 2)))
|
||||
|
||||
(test '(b c d) (cdr '((a) b c d)))
|
||||
|
||||
(test 2 (cdr '(1 . 2)))
|
||||
|
||||
(test #t (list? '(a b c)))
|
||||
|
||||
(test #t (list? '()))
|
||||
|
||||
(test #f (list? '(a . b)))
|
||||
|
||||
(test #f
|
||||
(let ((x (list 'a)))
|
||||
(set-cdr! x x)
|
||||
(list? x)))
|
||||
|
||||
(test '(a 7 c) (list 'a (+ 3 4) 'c))
|
||||
|
||||
(test '() (list))
|
||||
|
||||
(test 3 (length '(a b c)))
|
||||
|
||||
(test 3 (length '(a (b) (c d e))))
|
||||
|
||||
(test 0 (length '()))
|
||||
|
||||
(test '(x y) (append '(x) '(y)))
|
||||
|
||||
(test '(a b c d) (append '(a) '(b c d)))
|
||||
|
||||
(test '(a (b) (c)) (append '(a (b)) '((c))))
|
||||
|
||||
(test '(a b c . d) (append '(a b) '(c . d)))
|
||||
|
||||
(test 'a (append '() 'a))
|
||||
|
||||
(test '(c b a) (reverse '(a b c)))
|
||||
|
||||
(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
|
||||
|
||||
(test 'c (list-ref '(a b c d) 2))
|
||||
|
||||
(test '(a b c) (memq 'a '(a b c)))
|
||||
|
||||
(test '(b c) (memq 'b '(a b c)))
|
||||
|
||||
(test #f (memq 'a '(b c d)))
|
||||
|
||||
(test #f (memq (list 'a) '(b (a) c)))
|
||||
|
||||
(test '((a) c) (member (list 'a) '(b (a) c)))
|
||||
|
||||
(test '(101 102) (memv 101 '(100 101 102)))
|
||||
|
||||
(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
|
||||
|
||||
(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
|
||||
|
||||
(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
|
||||
|
||||
(test #t (symbol? 'foo))
|
||||
|
||||
(test #t (symbol? (car '(a b))))
|
||||
|
||||
(test #f (symbol? "bar"))
|
||||
|
||||
(test #t (symbol? 'nil))
|
||||
|
||||
(test #f (symbol? '()))
|
||||
|
||||
(test "flying-fish" (symbol->string 'flying-fish))
|
||||
|
||||
(test "Martin" (symbol->string 'Martin))
|
||||
|
||||
(test "Malvina" (symbol->string (string->symbol "Malvina")))
|
||||
|
||||
(test '#(0 ("Sue" "Sue") "Anna")
|
||||
(let ((vec (vector 0 '(2 2 2 2) "Anna")))
|
||||
(vector-set! vec 1 '("Sue" "Sue"))
|
||||
vec))
|
||||
|
||||
(test '(dah dah didah) (vector->list '#(dah dah didah)))
|
||||
|
||||
(test '#(dididit dah) (list->vector '(dididit dah)))
|
||||
|
||||
(test #t (procedure? car))
|
||||
|
||||
(test #f (procedure? 'car))
|
||||
|
||||
(test #t (procedure? (lambda (x) (* x x))))
|
||||
|
||||
(test #f (procedure? '(lambda (x) (* x x))))
|
||||
|
||||
(test #t (call-with-current-continuation procedure?))
|
||||
|
||||
(test 7 (apply + (list 3 4)))
|
||||
|
||||
(test '(b e h) (map cadr '((a b) (d e) (g h))))
|
||||
|
||||
(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
|
||||
|
||||
(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
|
||||
|
||||
(test '#(0 1 4 9 16)
|
||||
(let ((v (make-vector 5)))
|
||||
(for-each
|
||||
(lambda (i) (vector-set! v i (* i i)))
|
||||
'(0 1 2 3 4))
|
||||
v))
|
||||
|
||||
(test 3 (force (delay (+ 1 2))))
|
||||
|
||||
(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p))))
|
||||
|
||||
(test 7 (call-with-current-continuation (lambda (k) (+ 2 5))))
|
||||
|
||||
(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(test-report)
|
||||
Loading…
Add table
Reference in a new issue