mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-10 22:47:33 +02:00
fixing syntax-rules.scm
This commit is contained in:
Alex Shinn
commit
b5f07e6da6
41 changed files with 5725 additions and 0 deletions
19
.hgignore
Normal file
19
.hgignore
Normal 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
71
Makefile
Normal 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
27
README
Normal 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
1
VERSION
Normal file
|
|
@ -0,0 +1 @@
|
|||
0.1
|
||||
31
config.h
Normal file
31
config.h
Normal 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
73
debug.c
Normal 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
73
defaults.h
Normal 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
|
||||
|
||||
137
eval.h
Normal file
137
eval.h
Normal 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
525
init.scm
Normal 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
110
main.c
Normal 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
130
opcodes.c
Normal 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
128
sexp-huff.c
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
{12, 0x0C00}, /* '\x00' */
|
||||
{15, 0x0000}, /* '\x01' */
|
||||
{15, 0x4000}, /* '\x02' */
|
||||
{15, 0x2000}, /* '\x03' */
|
||||
{15, 0x6000}, /* '\x04' */
|
||||
{15, 0x0800}, /* '\x05' */
|
||||
{15, 0x4800}, /* '\x06' */
|
||||
{15, 0x2800}, /* '\x07' */
|
||||
{15, 0x6800}, /* '\x08' */
|
||||
{15, 0x1800}, /* '\x09' */
|
||||
{15, 0x5800}, /* '\x0a' */
|
||||
{15, 0x3800}, /* '\x0b' */
|
||||
{15, 0x7800}, /* '\x0c' */
|
||||
{15, 0x0100}, /* '\x0d' */
|
||||
{15, 0x4100}, /* '\x0e' */
|
||||
{15, 0x2100}, /* '\x0f' */
|
||||
{15, 0x6100}, /* '\x10' */
|
||||
{15, 0x1100}, /* '\x11' */
|
||||
{15, 0x5100}, /* '\x12' */
|
||||
{15, 0x3100}, /* '\x13' */
|
||||
{15, 0x7100}, /* '\x14' */
|
||||
{15, 0x0900}, /* '\x15' */
|
||||
{15, 0x4900}, /* '\x16' */
|
||||
{15, 0x2900}, /* '\x17' */
|
||||
{15, 0x6900}, /* '\x18' */
|
||||
{15, 0x1900}, /* '\x19' */
|
||||
{15, 0x5900}, /* '\x1a' */
|
||||
{15, 0x3900}, /* '\x1b' */
|
||||
{15, 0x7900}, /* '\x1c' */
|
||||
{15, 0x0500}, /* '\x1d' */
|
||||
{15, 0x4500}, /* '\x1e' */
|
||||
{15, 0x2500}, /* '\x1f' */
|
||||
{15, 0x6500}, /* '\x20' */
|
||||
{ 8, 0x0040}, /* '!' */
|
||||
{15, 0x1500}, /* '"' */
|
||||
{15, 0x5500}, /* '#' */
|
||||
{15, 0x3500}, /* '$' */
|
||||
{15, 0x7500}, /* '%' */
|
||||
{15, 0x0D00}, /* '&' */
|
||||
{15, 0x4D00}, /* '\'' */
|
||||
{15, 0x2D00}, /* '(' */
|
||||
{15, 0x6D00}, /* ')' */
|
||||
{11, 0x0300}, /* '*' */
|
||||
{10, 0x0180}, /* '+' */
|
||||
{15, 0x1D00}, /* ',' */
|
||||
{ 4, 0x000D}, /* '-' */
|
||||
{15, 0x5D00}, /* '.' */
|
||||
{10, 0x0380}, /* '/' */
|
||||
{15, 0x3D00}, /* '0' */
|
||||
{15, 0x7D00}, /* '1' */
|
||||
{14, 0x0080}, /* '2' */
|
||||
{14, 0x2080}, /* '3' */
|
||||
{14, 0x1080}, /* '4' */
|
||||
{14, 0x3080}, /* '5' */
|
||||
{14, 0x0880}, /* '6' */
|
||||
{14, 0x2880}, /* '7' */
|
||||
{14, 0x1880}, /* '8' */
|
||||
{14, 0x3880}, /* '9' */
|
||||
{14, 0x0480}, /* ':' */
|
||||
{14, 0x2480}, /* ';' */
|
||||
{ 7, 0x0050}, /* '<' */
|
||||
{ 7, 0x0042}, /* '=' */
|
||||
{ 7, 0x0022}, /* '>' */
|
||||
{ 5, 0x0009}, /* '?' */
|
||||
{14, 0x1480}, /* '@' */
|
||||
{14, 0x3480}, /* 'A' */
|
||||
{14, 0x0C80}, /* 'B' */
|
||||
{14, 0x2C80}, /* 'C' */
|
||||
{14, 0x1C80}, /* 'D' */
|
||||
{14, 0x3C80}, /* 'E' */
|
||||
{14, 0x0280}, /* 'F' */
|
||||
{14, 0x2280}, /* 'G' */
|
||||
{14, 0x1280}, /* 'H' */
|
||||
{14, 0x3280}, /* 'I' */
|
||||
{14, 0x0A80}, /* 'J' */
|
||||
{14, 0x2A80}, /* 'K' */
|
||||
{14, 0x1A80}, /* 'L' */
|
||||
{14, 0x3A80}, /* 'M' */
|
||||
{14, 0x0680}, /* 'N' */
|
||||
{14, 0x2680}, /* 'O' */
|
||||
{14, 0x1680}, /* 'P' */
|
||||
{14, 0x3680}, /* 'Q' */
|
||||
{14, 0x0E80}, /* 'R' */
|
||||
{14, 0x2E80}, /* 'S' */
|
||||
{14, 0x1E80}, /* 'T' */
|
||||
{14, 0x3E80}, /* 'U' */
|
||||
{14, 0x0200}, /* 'V' */
|
||||
{14, 0x2200}, /* 'W' */
|
||||
{14, 0x1200}, /* 'X' */
|
||||
{14, 0x3200}, /* 'Y' */
|
||||
{14, 0x0A00}, /* 'Z' */
|
||||
{14, 0x2A00}, /* '[' */
|
||||
{14, 0x1A00}, /* '\\' */
|
||||
{14, 0x3A00}, /* ']' */
|
||||
{14, 0x0600}, /* '^' */
|
||||
{14, 0x2600}, /* '_' */
|
||||
{14, 0x1600}, /* '`' */
|
||||
{ 3, 0x0007}, /* 'a' */
|
||||
{ 7, 0x0020}, /* 'b' */
|
||||
{ 4, 0x0004}, /* 'c' */
|
||||
{ 5, 0x001A}, /* 'd' */
|
||||
{ 4, 0x0006}, /* 'e' */
|
||||
{ 7, 0x0002}, /* 'f' */
|
||||
{ 5, 0x0011}, /* 'g' */
|
||||
{ 6, 0x0012}, /* 'h' */
|
||||
{ 4, 0x000C}, /* 'i' */
|
||||
{12, 0x0400}, /* 'j' */
|
||||
{ 8, 0x00C0}, /* 'k' */
|
||||
{ 5, 0x0018}, /* 'l' */
|
||||
{ 6, 0x0032}, /* 'm' */
|
||||
{ 4, 0x0005}, /* 'n' */
|
||||
{ 5, 0x000A}, /* 'o' */
|
||||
{ 5, 0x0001}, /* 'p' */
|
||||
{ 7, 0x0070}, /* 'q' */
|
||||
{ 3, 0x0003}, /* 'r' */
|
||||
{ 5, 0x0008}, /* 's' */
|
||||
{ 4, 0x000E}, /* 't' */
|
||||
{ 5, 0x0019}, /* 'u' */
|
||||
{ 7, 0x0062}, /* 'v' */
|
||||
{ 7, 0x0030}, /* 'w' */
|
||||
{ 7, 0x0060}, /* 'x' */
|
||||
{ 7, 0x0010}, /* 'y' */
|
||||
{11, 0x0700}, /* 'z' */
|
||||
{14, 0x3600}, /* '{' */
|
||||
{14, 0x0E00}, /* '|' */
|
||||
{14, 0x2E00}, /* '}' */
|
||||
{14, 0x1E00}, /* '~' */
|
||||
{14, 0x3E00}, /* '\x7f' */
|
||||
92
sexp-hufftabs.c
Normal file
92
sexp-hufftabs.c
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
|
||||
|
||||
char _huff_tab21[] = {
|
||||
'\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00',
|
||||
};
|
||||
|
||||
char _huff_tab19[] = {
|
||||
'\x01', 'j', '\x01', '\x00',
|
||||
};
|
||||
|
||||
char _huff_tab20[] = {
|
||||
'\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c',
|
||||
};
|
||||
|
||||
char _huff_tab18[] = {
|
||||
'2', ':', '6', 'B', '4', '@', '8', 'D',
|
||||
'3', ';', '7', 'C', '5', 'A', '9', 'E',
|
||||
};
|
||||
|
||||
char _huff_tab17[] = {
|
||||
'\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',',
|
||||
'\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0',
|
||||
'\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.',
|
||||
'\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1',
|
||||
};
|
||||
|
||||
char _huff_tab16[] = {
|
||||
'V', '^', 'Z', '|', 'X', '`', '\\', '~',
|
||||
'W', '_', '[', '}', 'Y', '{', ']', '\x7f',
|
||||
};
|
||||
|
||||
char _huff_tab15[] = {
|
||||
'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T',
|
||||
'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U',
|
||||
};
|
||||
|
||||
char _huff_tab13[] = {
|
||||
'\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/',
|
||||
};
|
||||
|
||||
char _huff_tab14[] = {
|
||||
'*', 'z',
|
||||
};
|
||||
|
||||
char _huff_tab11[] = {
|
||||
'\x00', 'b', '\x00', 'x',
|
||||
};
|
||||
|
||||
char _huff_tab12[] = {
|
||||
'!', 'k',
|
||||
};
|
||||
|
||||
char _huff_tab9[] = {
|
||||
'\x00', 's', '\x00', 'l',
|
||||
};
|
||||
|
||||
char _huff_tab10[] = {
|
||||
'y', 'w', '<', 'q',
|
||||
};
|
||||
|
||||
char _huff_tab8[] = {
|
||||
'p', '?', 'g', 'u',
|
||||
};
|
||||
|
||||
char _huff_tab7[] = {
|
||||
'f', '>', '=', 'v',
|
||||
};
|
||||
|
||||
char _huff_tab5[] = {
|
||||
'\x00', 'o', '\x00', 'd',
|
||||
};
|
||||
|
||||
char _huff_tab6[] = {
|
||||
'h', 'm',
|
||||
};
|
||||
|
||||
char _huff_tab4[] = {
|
||||
'c', 'i',
|
||||
};
|
||||
|
||||
char _huff_tab3[] = {
|
||||
'n', '-',
|
||||
};
|
||||
|
||||
char _huff_tab1[] = {
|
||||
'\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a',
|
||||
};
|
||||
|
||||
char _huff_tab2[] = {
|
||||
'e', 't',
|
||||
};
|
||||
|
||||
71
sexp-unhuff.c
Normal file
71
sexp-unhuff.c
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */
|
||||
|
||||
res = c & 7;
|
||||
c = c >> 3;
|
||||
if (res == 0) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = c & 7;
|
||||
c = c >> 3;
|
||||
if (res == 0) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = _huff_tab21[c & 7];
|
||||
c = c >> 3;
|
||||
} else if ((res = _huff_tab19[res]) == '\x01') {
|
||||
res = _huff_tab20[c & 7];
|
||||
c = c >> 3;
|
||||
}
|
||||
} else if (res == 1) {
|
||||
res = _huff_tab18[c & 15];
|
||||
c = c >> 4;
|
||||
} else if (res == 2) {
|
||||
res = _huff_tab17[c & 31];
|
||||
c = c >> 5;
|
||||
} else if (res == 4) {
|
||||
res = _huff_tab16[c & 15];
|
||||
c = c >> 4;
|
||||
} else if (res == 5) {
|
||||
res = _huff_tab15[c & 15];
|
||||
c = c >> 4;
|
||||
} else if ((res = _huff_tab13[res]) == '\x00') {
|
||||
res = _huff_tab14[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
} else if ((res = _huff_tab11[res]) == '\x00') {
|
||||
res = _huff_tab12[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
} else if ((res = _huff_tab9[res]) == '\x00') {
|
||||
res = _huff_tab10[c & 3];
|
||||
c = c >> 2;
|
||||
}
|
||||
} else if (res == 1) {
|
||||
res = _huff_tab8[c & 3];
|
||||
c = c >> 2;
|
||||
} else if (res == 2) {
|
||||
res = c & 3;
|
||||
c = c >> 2;
|
||||
if (res == 0) {
|
||||
res = _huff_tab7[c & 3];
|
||||
c = c >> 2;
|
||||
} else if ((res = _huff_tab5[res]) == '\x00') {
|
||||
res = _huff_tab6[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
} else if (res == 4) {
|
||||
res = _huff_tab4[c & 1];
|
||||
c = c >> 1;
|
||||
} else if (res == 5) {
|
||||
res = _huff_tab3[c & 1];
|
||||
c = c >> 1;
|
||||
} else if ((res = _huff_tab1[res]) == '\x00') {
|
||||
res = _huff_tab2[c & 1];
|
||||
c = c >> 1;
|
||||
}
|
||||
|
||||
441
sexp.h
Normal file
441
sexp.h
Normal 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
182
syntax-rules.scm
Normal 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:
|
||||
|
||||
1
tests/basic/test00-fact-3.res
Normal file
1
tests/basic/test00-fact-3.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
(fact 3) => 6
|
||||
14
tests/basic/test00-fact-3.scm
Normal file
14
tests/basic/test00-fact-3.scm
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
(define (fact-helper x res)
|
||||
(if (= x 0)
|
||||
res
|
||||
(fact-helper (- x 1) (* res x))))
|
||||
|
||||
(define (fact x)
|
||||
(fact-helper x 1))
|
||||
|
||||
(display "(fact 3) => ")
|
||||
(write (fact 3))
|
||||
(newline)
|
||||
|
||||
|
||||
8
tests/basic/test01-apply.res
Normal file
8
tests/basic/test01-apply.res
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
11
|
||||
(11 10 9 8 7 6 5 4 3 2 1)
|
||||
(1 2 3 4)
|
||||
100
|
||||
100
|
||||
100
|
||||
100
|
||||
100
|
||||
18
tests/basic/test01-apply.scm
Normal file
18
tests/basic/test01-apply.scm
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
|
||||
(define foo
|
||||
(lambda (a b c d e f g h)
|
||||
(+ (+ (* a b) (* c d)) (+ (* e f) (* g h)))))
|
||||
|
||||
(define (writeln x)
|
||||
(write x)
|
||||
(newline))
|
||||
|
||||
(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11))))
|
||||
(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))
|
||||
(writeln (append (list 1 2) (list 3 4)))
|
||||
(writeln (foo 1 2 3 4 5 6 7 8))
|
||||
(writeln (apply foo (list 1 2 3 4 5 6 7 8)))
|
||||
(writeln (apply foo 1 (list 2 3 4 5 6 7 8)))
|
||||
(writeln (apply foo 1 2 3 4 (list 5 6 7 8)))
|
||||
(writeln (apply foo 1 2 3 4 5 (list 6 7 8)))
|
||||
|
||||
6
tests/basic/test02-closure.res
Normal file
6
tests/basic/test02-closure.res
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
1
|
||||
2
|
||||
101
|
||||
102
|
||||
3
|
||||
103
|
||||
16
tests/basic/test02-closure.scm
Normal file
16
tests/basic/test02-closure.scm
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
|
||||
(define (make-counter n)
|
||||
(lambda ()
|
||||
(set! n (+ n 1))
|
||||
n))
|
||||
|
||||
(define f (make-counter 0))
|
||||
(define g (make-counter 100))
|
||||
|
||||
(write (f)) (newline)
|
||||
(write (f)) (newline)
|
||||
(write (g)) (newline)
|
||||
(write (g)) (newline)
|
||||
(write (f)) (newline)
|
||||
(write (g)) (newline)
|
||||
|
||||
1
tests/basic/test03-nested-closure.res
Normal file
1
tests/basic/test03-nested-closure.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
11357
|
||||
8
tests/basic/test03-nested-closure.scm
Normal file
8
tests/basic/test03-nested-closure.scm
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
((lambda (a b)
|
||||
((lambda (c d e)
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline))
|
||||
(- a 2) (+ b 2) 10000))
|
||||
3 5)
|
||||
|
||||
1
tests/basic/test04-nested-let.res
Normal file
1
tests/basic/test04-nested-let.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
11357
|
||||
9
tests/basic/test04-nested-let.scm
Normal file
9
tests/basic/test04-nested-let.scm
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(let ((a 3)
|
||||
(b 5))
|
||||
(let ((c (- a 2))
|
||||
(d (+ b 2))
|
||||
(e 10000))
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline)))
|
||||
|
||||
1
tests/basic/test05-internal-define.res
Normal file
1
tests/basic/test05-internal-define.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
1000 1003
|
||||
8
tests/basic/test05-internal-define.scm
Normal file
8
tests/basic/test05-internal-define.scm
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(let ((a 1000))
|
||||
(define b (+ a 3))
|
||||
(write a)
|
||||
(display " ")
|
||||
(write b)
|
||||
(newline))
|
||||
|
||||
4
tests/basic/test06-letrec.res
Normal file
4
tests/basic/test06-letrec.res
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
7
|
||||
#t
|
||||
#f
|
||||
#f
|
||||
15
tests/basic/test06-letrec.scm
Normal file
15
tests/basic/test06-letrec.scm
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
|
||||
(letrec ((add (lambda (a b) (+ a b))))
|
||||
(write (add 3 4))
|
||||
(newline))
|
||||
|
||||
(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
|
||||
(odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))))
|
||||
(write (even? 1000))
|
||||
(newline)
|
||||
(write (even? 1001))
|
||||
(newline)
|
||||
(write (odd? 1000))
|
||||
(newline)
|
||||
)
|
||||
|
||||
1
tests/basic/test07-mutation.res
Normal file
1
tests/basic/test07-mutation.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
11357
|
||||
9
tests/basic/test07-mutation.scm
Normal file
9
tests/basic/test07-mutation.scm
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(let ((a 3)
|
||||
(b 5))
|
||||
(let ((c (- a 2))
|
||||
(d (+ b 2))
|
||||
(e #f))
|
||||
(set! e 10000)
|
||||
(write (+ e (* c 1000) (* a 100) (* b 10) d))
|
||||
(newline)))
|
||||
1
tests/basic/test08-callcc.res
Normal file
1
tests/basic/test08-callcc.res
Normal file
|
|
@ -0,0 +1 @@
|
|||
543
|
||||
34
tests/basic/test08-callcc.scm
Normal file
34
tests/basic/test08-callcc.scm
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
|
||||
(define fail
|
||||
(lambda () 999999))
|
||||
|
||||
(define in-range
|
||||
(lambda (a b)
|
||||
(call-with-current-continuation
|
||||
(lambda (cont)
|
||||
(enumerate a b cont)))))
|
||||
|
||||
(define enumerate
|
||||
(lambda (a b cont)
|
||||
(if (< b a)
|
||||
(fail)
|
||||
(let ((save fail))
|
||||
(begin
|
||||
(set! fail
|
||||
(lambda ()
|
||||
(begin
|
||||
(set! fail save)
|
||||
(enumerate (+ a 1) b cont))))
|
||||
(cont a))))))
|
||||
|
||||
(write
|
||||
(let ((x (in-range 2 9))
|
||||
(y (in-range 2 9))
|
||||
(z (in-range 2 9)))
|
||||
(if (= (* x x)
|
||||
(+ (* y y) (* z z)))
|
||||
(+ (* x 100) (+ (* y 10) z))
|
||||
(fail))))
|
||||
|
||||
(newline)
|
||||
|
||||
5
tests/basic/test09-hygiene.res
Normal file
5
tests/basic/test09-hygiene.res
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
25
tests/basic/test09-hygiene.scm
Normal file
25
tests/basic/test09-hygiene.scm
Normal 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)
|
||||
6
tests/basic/test10-unhygiene.res
Normal file
6
tests/basic/test10-unhygiene.res
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
1
|
||||
1
|
||||
1
|
||||
6
|
||||
7
|
||||
8
|
||||
49
tests/basic/test10-unhygiene.scm
Normal file
49
tests/basic/test10-unhygiene.scm
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
|
||||
(define-syntax aif
|
||||
(sc-macro-transformer
|
||||
(lambda (form environment)
|
||||
(let ((condition
|
||||
(make-syntactic-closure environment '() (cadr form)))
|
||||
(consequent
|
||||
(make-syntactic-closure environment '(it) (caddr form)))
|
||||
(alternative
|
||||
(make-syntactic-closure environment '() (cadddr form))))
|
||||
`(let ((it ,condition))
|
||||
(if it
|
||||
,consequent
|
||||
,alternative))))))
|
||||
|
||||
(write (aif 1 it 3))
|
||||
(newline)
|
||||
|
||||
(write (let ((it 4)) (aif 1 it 3)))
|
||||
(newline)
|
||||
|
||||
(write (let ((it 4)) (aif (let ((it 5)) 1) it 3)))
|
||||
(newline)
|
||||
|
||||
(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3)))
|
||||
(newline)
|
||||
|
||||
(write
|
||||
(letrec-syntax
|
||||
((myor
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#f
|
||||
(list (rename 'let) (list (list (rename 'it) (cadr expr)))
|
||||
(list (rename 'if) (rename 'it)
|
||||
(rename 'it)
|
||||
(cons (rename 'myor) (cddr expr)))))))))
|
||||
(let ((it 7)) (myor #f it))))
|
||||
(newline)
|
||||
|
||||
(define-syntax define-foo
|
||||
(sc-macro-transformer
|
||||
(lambda (form environment)
|
||||
(make-syntactic-closure environment '(foo) `(define foo 8)))))
|
||||
|
||||
(define-foo)
|
||||
(write foo)
|
||||
(newline)
|
||||
373
tests/r5rs-tests.scm
Normal file
373
tests/r5rs-tests.scm
Normal 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)
|
||||
Loading…
Add table
Reference in a new issue