fixing syntax-rules.scm

This commit is contained in:
Alex Shinn 2009-04-14 21:28:21 +09:00
commit b5f07e6da6
41 changed files with 5725 additions and 0 deletions

19
.hgignore Normal file
View file

@ -0,0 +1,19 @@
syntax: glob
*~
*.i
*.s
*.o
*.so
*.dSYM
*.orig
.hg
junk*
*.tar.gz
*.tar.bz2
*.log
*.err
*.out
gc
gc6.8
chibi-scheme

71
Makefile Normal file
View file

@ -0,0 +1,71 @@
.PHONY: all doc dist clean cleaner test install uninstall
all: chibi-scheme
PREFIX=/usr/local
BINDIR=$(PREFIX)/bin
LIBDIR=$(PREFIX)/lib
INCDIR=$(PREFIX)/include/chibi-scheme
MODDIR=$(PREFIX)/share/chibi-scheme
LDFLAGS=-lm
CFLAGS=-Wall -g -Os
GC_OBJ=./gc/gc.a
./gc/gc.a: ./gc/alloc.c
cd gc && make
sexp.o: sexp.c sexp.h config.h defaults.h Makefile
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
chibi-scheme: main.o sexp.o $(GC_OBJ)
gcc $(CFLAGS) $(LDFLAGS) -o $@ $^
clean:
rm -f *.o *.i *.s
cleaner: clean
rm -f chibi-scheme
rm -rf *.dSYM
test: 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
./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm
# install: chibi-scheme
# cp chibi-scheme $(BINDIR)/
# mkdir -p $(MODDIR)
# cp init.scm $(MODDIR)/
# mkdir -p $(INCDIR)
# cp *.h $(INCDIR)/
# cp *.$(SO) $(LIBDIR)/
# uninstall:
# rm -f $(BINDIR)/chibi-scheme
# rm -f $(LIBDIR)/libchibischeme.$(SO)
# rm -f $(LIBDIR)/libchibisexp.$(SO)
# rm -f $(INCDIR)/*.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
cd chibi-scheme-`cat VERSION`; tar xzvf ../gc.tar.gz; mv gc[0-9].[0-9] gc
tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION`
rm -rf chibi-scheme-`cat VERSION`

27
README Normal file
View file

@ -0,0 +1,27 @@
Chibi-Scheme
--------------
Simple and Minimal Scheme Implementation
http://synthcode.com/scheme/chibi-scheme-0.1.tgz
version 0.1
April 8, 2009
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. Currently Chibi-Scheme uses the
Boehm conservative garbage collector to try to play well with C code.
To build, just run "make". You can edit the file config.h for a
number of settings, mostly disabling features to make the executable
smaller. Documents and examples for using Chibi-Scheme as a library
for extension scripting will be provided in an upcoming release.
syntax-rules must be loaded manually from the file syntax-rules.scm.

1
VERSION Normal file
View file

@ -0,0 +1 @@
0.1

31
config.h Normal file
View file

@ -0,0 +1,31 @@
/* config.h -- general configuration */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
/* uncomment this to use manual memory management */
/* #define USE_BOEHM 0 */
/* uncomment this if you only want fixnum support */
/* #define USE_FLONUMS 0 */
/* 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 disable a small optimization for let */
/* #define USE_FAST_LET 0 */
/* uncomment this to enable debugging utilities */
/* #define USE_DEBUG 1 */

73
debug.c Normal file
View file

@ -0,0 +1,73 @@
/* 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 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(out, " %s ", reverse_opcode_names[opcode]);
} else {
sexp_printf(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(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(((sexp*)ip)[0], out);
ip += sizeof(sexp);
break;
}
sexp_write_char('\n', out);
if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))
goto loop;
return SEXP_VOID;
}
static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) {
int i;
for (i=0; i<top; i++) {
sexp_printf(out, "%s %02d: ", ((i==fp) ? "*" : " "), i);
sexp_write(stack[i], out);
sexp_printf(out, "\n");
}
}

73
defaults.h Normal file
View file

@ -0,0 +1,73 @@
/* defaults.h -- defaults for unspecified configs */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#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
#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 1
#endif
#ifndef USE_FLONUMS
#define USE_FLONUMS 1
#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_FAST_LET
#define USE_FAST_LET 1
#endif
#ifndef USE_CHECK_STACK
#define USE_CHECK_STACK 0
#endif
#if USE_BOEHM
#include "gc/include/gc.h"
#define sexp_alloc GC_malloc
#define sexp_alloc_atomic GC_malloc_atomic
#define sexp_realloc GC_realloc
#define sexp_free(x)
#define sexp_deep_free(x)
#else
#define sexp_alloc malloc
#define sexp_alloc_atomic sexp_alloc
#define sexp_realloc realloc
#define sexp_free free
void sexp_deep_free(sexp obj);
#endif

1854
eval.c Normal file

File diff suppressed because it is too large Load diff

137
eval.h Normal file
View file

@ -0,0 +1,137 @@
/* 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 "sexp.h"
/************************* additional types ***************************/
#define INIT_BCODE_SIZE 128
#define INIT_STACK_SIZE 1024
#define sexp_init_file "init.scm"
#define sexp_debug(msg, obj, ctx) (sexp_write_string(msg,env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write(obj, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write_char('\n',env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)))
/* 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);
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 ******************************/
sexp apply(sexp proc, sexp args, sexp context);
sexp eval_in_context(sexp expr, sexp context);
sexp eval(sexp expr, sexp env);
#endif /* ! SEXP_EVAL_H */

525
init.scm Normal file
View file

@ -0,0 +1,525 @@
;; 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-reverse a b)
(if (pair? a)
(append-reverse (cdr a) (cons (car a) b))
b))
(define (append a b)
(append-reverse (reverse a) b))
(define (apply proc . args)
(if (null? args)
(proc)
((lambda (lol)
(apply1 proc (append (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) 0))
(define (string<? s1 s2) (< (string-cmp s1 s2) 0))
(define (string<=? s1 s2) (<= (string-cmp s1 s2) 0))
(define (string>? s1 s2) (> (string-cmp s1 s2) 0))
(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0))
(define (string-ci=? s1 s2) (eq? (string-cmp-ci s1 s2) 0))
(define (string-ci<? s1 s2) (< (string-cmp-ci s1 s2) 0))
(define (string-ci<=? s1 s2) (<= (string-cmp-ci s1 s2) 0))
(define (string-ci>? s1 s2) (> (string-cmp-ci s1 s2) 0))
(define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 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 (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)
(proc (open-input-string str)))
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(get-output-string out)))
(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))))

110
main.c Normal file
View file

@ -0,0 +1,110 @@
#include "eval.c"
void repl (sexp context) {
sexp obj, tmp, res, env, in, out, err;
env = sexp_context_env(context);
sexp_context_tracep(context) = 1;
in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE);
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
while (1) {
sexp_write_string("> ", out);
sexp_flush(out);
obj = sexp_read(in);
if (obj == SEXP_EOF)
break;
if (sexp_exceptionp(obj)) {
sexp_print_exception(obj, err);
} else {
tmp = sexp_env_bindings(env);
res = eval_in_context(obj, context);
#ifdef USE_WARN_UNDEFS
sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
#endif
if (res != SEXP_VOID) {
sexp_write(res, out);
sexp_write_char('\n', out);
}
}
}
}
void run_main (int argc, char **argv) {
sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler;
sexp_uint_t i, quit=0, init_loaded=0;
env = sexp_make_standard_env(sexp_make_integer(5));
env_define(env, the_interaction_env_symbol, env);
out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE);
err_cell = env_cell(env, the_cur_err_symbol);
perr_cell = env_cell(env, sexp_intern("print-exception"));
context = sexp_make_context(NULL, env);
sexp_context_tailp(context) = 0;
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
emit(OP_GLOBAL_KNOWN_REF, context);
emit_word((sexp_uint_t)err_cell, context);
emit(OP_LOCAL_REF, context);
emit_word(0, context);
emit(OP_FCALL2, context);
emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context);
}
emit_push(SEXP_VOID, context);
emit(OP_DONE, context);
err_handler = sexp_make_procedure(sexp_make_integer(0),
sexp_make_integer(0),
finalize_bytecode(context),
sexp_make_vector(0, SEXP_VOID));
env_define(env, the_err_handler_symbol, err_handler);
/* parse options */
for (i=1; i < argc && argv[i][0] == '-'; i++) {
switch (argv[i][1]) {
#if USE_STRING_STREAMS
case 'e':
case 'p':
if (! init_loaded++)
sexp_load(sexp_c_string(sexp_init_file), env);
res = sexp_read_from_string(argv[i+1]);
if (! sexp_exceptionp(res))
res = eval_in_context(res, context);
if (sexp_exceptionp(res)) {
sexp_print_exception(res, out);
} else if (argv[i][1] == 'p') {
sexp_write(res, out);
sexp_write_char('\n', out);
}
quit=1;
i++;
break;
#endif
case 'l':
if (! init_loaded++)
sexp_load(sexp_c_string(sexp_init_file), env);
sexp_load(sexp_c_string(argv[++i]), env);
break;
case 'q':
init_loaded = 1;
break;
default:
errx(1, "unknown option: %s", argv[i]);
}
}
if (! quit) {
if (! init_loaded)
sexp_load(sexp_c_string(sexp_init_file), env);
if (i < argc)
for ( ; i < argc; i++)
sexp_load(sexp_c_string(argv[i]), env);
else
repl(context);
}
}
int main (int argc, char **argv) {
scheme_init();
run_main(argc, argv);
return 0;
}

130
opcodes.c Normal file
View file

@ -0,0 +1,130 @@
#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, f, d, 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, "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),
_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp),
_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci),
_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, "atan", 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
#if USE_STRING_STREAMS
_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),
#endif
#if USE_DEBUG
_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm),
#endif
};

128
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
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
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;
}

1147
sexp.c Normal file

File diff suppressed because it is too large Load diff

441
sexp.h Normal file
View file

@ -0,0 +1,441 @@
/* 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 "config.h"
#include "defaults.h"
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <sysexits.h>
#include <sys/types.h>
#include <math.h>
/* tagging system
* bits end in 00: pointer
* 01: fixnum
* 011: <unused>
* 111: immediate symbol
* 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_CHAR_TAG 6
#define SEXP_EXTENDED_TAG 14
#define SEXP_MAX_INT ((1<<29)-1)
#define SEXP_MIN_INT (-(1<<29))
enum sexp_types {
SEXP_OBJECT,
SEXP_FIXNUM,
SEXP_CHAR,
SEXP_BOOLEAN,
SEXP_PAIR,
SEXP_SYMBOL,
SEXP_STRING,
SEXP_VECTOR,
SEXP_FLONUM,
SEXP_BIGNUM,
SEXP_IPORT,
SEXP_OPORT,
SEXP_EXCEPTION,
/* the following are used only by the evaluator */
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_CONTEXT,
};
typedef unsigned long sexp_uint_t;
typedef long sexp_sint_t;
typedef char sexp_tag_t;
typedef struct sexp_struct *sexp;
struct sexp_struct {
sexp_tag_t tag;
union {
/* basic types */
double flonum;
struct {
sexp car, cdr;
} pair;
struct {
sexp_uint_t length;
sexp *data;
} vector;
struct {
sexp_uint_t length;
char *data;
} string;
struct {
sexp_uint_t length;
char *data;
} symbol;
struct {
FILE *stream;
char *name;
sexp_uint_t line;
sexp cookie;
} port;
struct {
sexp kind, message, irritants, procedure, file, line;
} exception;
/* 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 dflt, data, proc;
} opcode;
struct {
char code;
char *name;
} core;
/* ast types */
struct {
sexp name, params, locals, defs, flags, body, fv, sv;
} 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 bc, lambda, *stack, env, fv;
sexp_uint_t pos, top, depth, tailp, tracep;
} context;
} value;
};
#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \
+ sizeof(((sexp)0)->value.x))
#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag)
#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<<SEXP_EXTENDED_BITS) \
+ SEXP_EXTENDED_TAG))
#define SEXP_NULL SEXP_MAKE_IMMEDIATE(0)
#define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1)
#define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2)
#define SEXP_EOF SEXP_MAKE_IMMEDIATE(3)
#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4)
#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* internal use */
#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(6) /* internal use */
#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(7) /* internal use */
#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(8) /* internal use */
/***************************** predicates *****************************/
#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_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
#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_flonump(x) (sexp_check_tag(x, SEXP_FLONUM))
#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_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(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))
#define sexp_flonum_value(f) ((f)->value.flonum)
#if USE_FLONUMS
#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x)))
#else
#define sexp_integer_to_flonum(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_length(x) ((x)->value.symbol.length)
#define sexp_symbol_data(x) ((x)->value.symbol.data)
#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_cookie(p) ((p)->value.port.cookie)
#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_file(p) ((p)->value.exception.file)
#define sexp_exception_line(p) ((p)->value.exception.line)
#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_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_top(x) ((x)->value.context.top)
#define sexp_context_lambda(x) ((x)->value.context.lambda)
#define sexp_context_tailp(x) ((x)->value.context.tailp)
#define sexp_context_tracep(x) ((x)->value.context.tailp)
/****************************** 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(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b)))
#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b)))
#define sexp_fp_mul(a, b) (sexp_make_flonum(sexp_flonum_value(a) * sexp_flonum_value(b)))
#define sexp_fp_div(a, b) (sexp_make_flonum(sexp_flonum_value(a) / sexp_flonum_value(b)))
/****************************** utilities *****************************/
#define sexp_list1(a) sexp_cons(a, SEXP_NULL)
#define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL))
#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL)))
#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL))))
#define sexp_push(ls, x) ((ls) = sexp_cons((x), (ls)))
#define sexp_insert(ls, x) ((sexp_memq((x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ls), (x)))
#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)))
#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
/***************************** general API ****************************/
#define sexp_read_char(p) (getc(sexp_port_stream(p)))
#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p)))
#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p)))
#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p)))
#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__))
#define sexp_flush(p) (fflush(sexp_port_stream(p)))
sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag);
sexp sexp_cons(sexp head, sexp tail);
sexp sexp_equalp (sexp a, sexp b);
sexp sexp_listp(sexp obj);
sexp sexp_reverse(sexp ls);
sexp sexp_nreverse(sexp ls);
sexp sexp_append(sexp a, sexp b);
sexp sexp_memq(sexp x, sexp ls);
sexp sexp_assq(sexp x, sexp ls);
sexp sexp_length(sexp ls);
sexp sexp_c_string(char *str);
sexp sexp_make_string(sexp len, sexp ch);
sexp sexp_substring (sexp str, sexp start, sexp end);
sexp sexp_make_flonum(double f);
sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc);
sexp sexp_intern(char *str);
sexp sexp_string_to_symbol(sexp str);
sexp sexp_make_vector(sexp len, sexp dflt);
sexp sexp_list_to_vector(sexp ls);
sexp sexp_vector(int count, ...);
void sexp_write(sexp obj, sexp out);
char* sexp_read_string(sexp in);
char* sexp_read_symbol(sexp in, int init);
sexp sexp_read_number(sexp in, int base);
sexp sexp_read_raw(sexp in);
sexp sexp_read(sexp in);
sexp sexp_read_from_string(char *str);
sexp sexp_make_input_port(FILE* in, char *path);
sexp sexp_make_output_port(FILE* out, char *path);
sexp sexp_make_input_string_port(sexp str);
sexp sexp_make_output_string_port();
sexp sexp_get_output_string(sexp port);
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line);
sexp sexp_user_exception (sexp self, char *message, sexp obj);
sexp sexp_type_exception (char *message, sexp obj);
sexp sexp_range_exception (sexp obj, sexp start, sexp end);
sexp sexp_print_exception(sexp exn, sexp out);
void sexp_init();
#endif /* ! SEXP_H */

182
syntax-rules.scm Normal file
View file

@ -0,0 +1,182 @@
(define-syntax syntax-rules
(er-macro-transformer
(lambda (expr rename compare)
(let ((lits (cadr expr))
(forms (cddr expr))
(count 0)
(_er-macro-transformer (rename 'er-macro-transformer))
(_lambda (rename 'lambda)) (_let (rename 'let))
(_begin (rename 'begin)) (_if (rename 'if))
(_and (rename 'and)) (_or (rename 'or))
(_eq? (rename 'eq?)) (_equal? (rename 'equal?))
(_car (rename 'car)) (_cdr (rename 'cdr))
(_cons (rename 'cons)) (_pair? (rename 'pair?))
(_null? (rename 'null?)) (_expr (rename 'expr))
(_rename (rename 'rename)) (_compare (rename 'compare))
(_quote (rename 'quote)) (_apply (rename 'apply))
(_append (rename 'append)) (_map (rename 'map))
(_vector? (rename 'vector?)) (_list? (rename 'list?))
(_lp (rename 'lp)) (_reverse (rename 'reverse))
(_vector->list (rename 'vector->list))
(_list->vector (rename 'list->vector)))
(define (next-v)
(set! count (+ count 1))
(rename (string->symbol (string-append "v." (number->string count)))))
(define (expand-pattern pat tmpl)
(let lp ((p (cdr pat))
(x (list _cdr _expr))
(dim 0)
(vars '())
(k (lambda (vars)
(or (expand-template tmpl vars)
(list _begin #f)))))
(let ((v (next-v)))
(list
_let (list (list v x))
(cond
((identifier? p)
(if (any (lambda (l) (compare p l)) lits)
(list _and (list _compare v (list _quote p)) (k vars))
(list _let (list (list p v)) (k (cons (cons p dim) vars)))))
((ellipse? p)
(cond
((not (null? (cddr p)))
(error "non-trailing ellipse"))
((identifier? (car p))
(list _and (list _list? v)
(list _let (list (list (car p) v))
(k (cons (cons (car p) (+ 1 dim)) vars)))))
(else
(let* ((w (next-v))
(new-vars (all-vars (car p) (+ dim 1)))
(ls-vars (map (lambda (x)
(rename
(string->symbol
(string-append
(symbol->string
(identifier->symbol (car x)))
"-ls"))))
new-vars))
(once
(lp (car p) (list _car w) (+ dim 1) '()
(lambda (_)
(cons
_lp
(cons
(list _cdr w)
(map (lambda (x l)
(list _cons (car x) l))
new-vars
ls-vars)))))))
(list
_let
_lp (cons (list w v)
(map (lambda (x) (list x '())) ls-vars))
(list _if (list _null? w)
(list _let (map (lambda (x l)
(list (car x) (list _reverse l)))
new-vars
ls-vars)
(k (append new-vars vars)))
(list _and (list _pair? w) once)))))))
((pair? p)
(list _and (list _pair? v)
(lp (car p)
(list _car v)
dim
vars
(lambda (vars)
(lp (cdr p) (list _cdr v) dim vars k)))))
((vector? p)
(list _and
(list _vector? v)
(lp (vector->list p) (list _vector->list v) dim vars k)))
((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars))))))))
(define (ellipse? x)
(and (pair? x) (pair? (cdr x)) (compare '... (cadr x))))
(define (ellipse-depth x)
(if (ellipse? x)
(+ 1 (ellipse-depth (cdr x)))
0))
(define (ellipse-tail x)
(if (ellipse? x)
(ellipse-tail (cdr x))
(cdr x)))
(define (all-vars x dim)
(let lp ((x x) (dim dim) (vars '()))
(cond ((identifier? x) (if (memq x (list _quote lits))
vars
(cons (cons x dim) vars)))
((ellipse? x) (lp (car x) (+ dim 1) vars))
((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
((vector? x) (lp (vector->list x) dim vars))
(else vars))))
(define (free-vars x vars dim)
(let lp ((x x) (free '()))
(cond
((identifier? x)
(if (and (not (memq x free))
(cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
(else #f)))
(cons x free)
free))
((pair? x) (lp (car x) (lp (cdr x) free)))
((vector? x) (lp (vector->list x) free))
(else free))))
(define (expand-template tmpl vars)
(let lp ((t tmpl) (dim 0))
(cond
((identifier? t)
(cond
((assq t vars)
=> (lambda (cell)
(if (<= (cdr cell) dim)
t
(error "too few ...'s"))))
(else
(list _rename (list _quote t)))))
((pair? t)
(if (ellipse? t)
(let* ((depth (ellipse-depth t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
(if (null? ell-vars)
(error "too many ...'s")
(let* ((once (lp (car t) ell-dim))
(nest (if (and (null? (cdr ell-vars))
(identifier? once)
(eq? once (car vars)))
once ;; shortcut
(cons _map
(cons (list _lambda ell-vars once)
ell-vars))))
(many (do ((d depth (- d 1))
(many nest
(list _apply _append many)))
((= d 1) many))))
(if (null? (ellipse-tail t))
many ;; shortcut
(list _append many (lp (ellipse-tail t) dim))))))
(list _cons (lp (car t) dim) (lp (cdr t) dim))))
((vector? t) (list _list->vector (lp (vector->list t) dim)))
((null? t) (list _quote '()))
(else t))))
(list
_er-macro-transformer
(list _lambda (list _expr _rename _compare)
(cons
_or
(append
(map
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
forms)
(list (list 'error "no expansion"))))))))))
;; Local Variables:
;; eval: (put '_lambda 'scheme-indent-function 1)
;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent)
;; eval: (put '_if 'scheme-indent-function 3)
;; End:

View file

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

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)

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

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

View file

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

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)

View file

@ -0,0 +1 @@
11357

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)

View file

@ -0,0 +1 @@
11357

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

View file

@ -0,0 +1 @@
1000 1003

View file

@ -0,0 +1,8 @@
(let ((a 1000))
(define b (+ a 3))
(write a)
(display " ")
(write b)
(newline))

View file

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

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

View file

@ -0,0 +1 @@
11357

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

View file

@ -0,0 +1 @@
543

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)

View file

@ -0,0 +1,5 @@
1
2
3
4
5

View file

@ -0,0 +1,25 @@
(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)

View file

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

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)

373
tests/r5rs-tests.scm Normal file
View file

@ -0,0 +1,373 @@
(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-report)