Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

DESTDIR patch from sladegen

Browse source
This commit is contained in:
Alex Shinn 2009-06-30 11:38:05 +09:00
commit 55a8a38e62
41 changed files with 6886 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
.hgignore Normal file
View 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
View 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
View 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
View file

@ -0,0 +1 @@
0.2

75
debug.c Normal file
View 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

2199
eval.c Normal file
View file

File diff suppressed because it is too large Load diff

237
gc.c Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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;
}

1357
sexp.c Normal file
View file

File diff suppressed because it is too large Load diff

1
tests/basic/test00-fact-3.res Normal file
View file

@ -0,0 +1 @@
(fact 3) => 6

14
tests/basic/test00-fact-3.scm Normal file
View 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
View 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
View 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
View file

@ -0,0 +1,6 @@
1
2
101
102
3
103

16
tests/basic/test02-closure.scm Normal file
View 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
View file

@ -0,0 +1 @@
11357

8
tests/basic/test03-nested-closure.scm Normal file
View 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
View file

@ -0,0 +1 @@
11357

9
tests/basic/test04-nested-let.scm Normal file
View 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
View file

@ -0,0 +1 @@
1000 1003

8
tests/basic/test05-internal-define.scm Normal file
View 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
View file

@ -0,0 +1,4 @@
7
#t
#f
#f

15
tests/basic/test06-letrec.scm Normal file
View 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
View file

@ -0,0 +1 @@
11357

9
tests/basic/test07-mutation.scm Normal file
View 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
View file

@ -0,0 +1 @@
543

34
tests/basic/test08-callcc.scm Normal file
View 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
View file

@ -0,0 +1,7 @@
1
2
3
4
5
6
outer

62
tests/basic/test09-hygiene.scm Normal file
View 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
View file

@ -0,0 +1,6 @@
1
1
1
6
7
8

49
tests/basic/test10-unhygiene.scm Normal file
View 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
View 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)