├── zen ├── test │ ├── if.res │ ├── let.res │ ├── plus.res │ ├── closure.res │ ├── fact5.res │ ├── identity.res │ ├── multi-arg.res │ ├── order1.res │ ├── order2.res │ ├── partial.res │ ├── plus.in │ ├── plus1.res │ ├── sum100.res │ ├── multi-arg1.res │ ├── order3.res │ ├── order4.res │ ├── if.in │ ├── let.in │ ├── identity.in │ ├── multi-arg.in │ ├── multi-arg1.in │ ├── partial.in │ ├── plus1.in │ ├── closure.in │ ├── order1.in │ ├── order2.in │ ├── order3.in │ ├── order4.in │ ├── fact5.in │ ├── sum100.in │ └── hello.c ├── Makefile ├── doc │ ├── RELEASE │ └── bytecode.md ├── driver.ss ├── core.ss ├── main.go ├── parser.ss ├── compiler.ss ├── match.scm ├── emit.ss └── macro.ss ├── 0.10 └── README ├── 0.01 ├── README └── main.c ├── nanopass ├── t.out ├── t.out.tmp ├── fmts.pretty ├── main.ss ├── testcase.ss └── t.s ├── re ├── go.mod ├── cmd │ └── cora │ │ └── main.go ├── reader.go └── eval_test.go ├── value-of-k ├── Makefile └── README ├── 0.20 └── README ├── reborn ├── TODO ├── Makefile └── opt │ ├── sexp-hufftabdefs.h │ ├── opcode_names.h │ ├── plan9-opcodes.c │ ├── sexp-unhuff.c │ ├── sexp-hufftabs.c │ ├── fcall.c │ └── sexp-huff.c ├── Makefile ├── n6blisp ├── .svn │ ├── prop-base │ │ ├── gc.c.svn-base │ │ ├── mem.c.svn-base │ │ ├── mem.h.svn-base │ │ ├── type.c.svn-base │ │ └── interpret.scm.svn-base │ ├── text-base │ │ ├── mem.h.svn-base │ │ ├── type.c.svn-base │ │ ├── gc.c.svn-base │ │ ├── mem.c.svn-base │ │ └── interpret.scm.svn-base │ ├── all-wcprops │ └── entries ├── eval.h ├── compile.h ├── gc.h ├── lex.h ├── README ├── env.h ├── mem.h ├── vm.h ├── Makefile ├── main.c ├── doc │ ├── 实现.txt │ └── 如此优雅地定义一门语言 ├── scheme.c ├── mem.c ├── gc.c ├── interpret1.scm └── interpret.scm ├── test.scm ├── sandbox ├── sandbox.meta ├── sandbox.setup ├── sandbox.scm ├── desugar.scm └── eval.scm ├── README.md ├── 0.25 └── README ├── lambda-calculus.rkt ├── scheme2c ├── scheme2c.scm ├── desugar.scm ├── scheme.h ├── fact.c ├── cps-convert.scm ├── closure-convert.scm └── generator.scm ├── continuation_monad.cora ├── delimcc.cora ├── spiffy └── spiffy.scm ├── test.scm.c ├── pmatch.scm ├── roadmap ├── srfi-18 ├── main.scm └── schedule.scm ├── scheme.h ├── eff.cora ├── free_monad.cora ├── interpret.scm ├── inspect.cora ├── dt.cora ├── lisp2c.shen ├── pi.cora ├── lisp2c.scm ├── minilang.rkt ├── ukanren.cora ├── scheme2c.rkt ├── infer.cora └── test.c /zen/test/if.res: -------------------------------------------------------------------------------- 1 | 5 -------------------------------------------------------------------------------- /zen/test/let.res: -------------------------------------------------------------------------------- 1 | 3 -------------------------------------------------------------------------------- /zen/test/plus.res: -------------------------------------------------------------------------------- 1 | 3 -------------------------------------------------------------------------------- /0.10/README: -------------------------------------------------------------------------------- 1 | eval的基本实现 -------------------------------------------------------------------------------- /zen/test/closure.res: -------------------------------------------------------------------------------- 1 | 3 -------------------------------------------------------------------------------- /zen/test/fact5.res: -------------------------------------------------------------------------------- 1 | 120 -------------------------------------------------------------------------------- /zen/test/identity.res: -------------------------------------------------------------------------------- 1 | 5 -------------------------------------------------------------------------------- /zen/test/multi-arg.res: -------------------------------------------------------------------------------- 1 | 2 -------------------------------------------------------------------------------- /zen/test/order1.res: -------------------------------------------------------------------------------- 1 | 3 -------------------------------------------------------------------------------- /zen/test/order2.res: -------------------------------------------------------------------------------- 1 | 4 -------------------------------------------------------------------------------- /zen/test/partial.res: -------------------------------------------------------------------------------- 1 | 42 -------------------------------------------------------------------------------- /zen/test/plus.in: -------------------------------------------------------------------------------- 1 | (+ 1 2) -------------------------------------------------------------------------------- /zen/test/plus1.res: -------------------------------------------------------------------------------- 1 | 8 -------------------------------------------------------------------------------- /zen/test/sum100.res: -------------------------------------------------------------------------------- 1 | 5050 -------------------------------------------------------------------------------- /zen/test/multi-arg1.res: -------------------------------------------------------------------------------- 1 | 42 -------------------------------------------------------------------------------- /zen/test/order3.res: -------------------------------------------------------------------------------- 1 | 2 | 1 -------------------------------------------------------------------------------- /zen/test/order4.res: -------------------------------------------------------------------------------- 1 | 2 | 2 -------------------------------------------------------------------------------- /0.01/README: -------------------------------------------------------------------------------- 1 | 基本的数据结构，实现scheme的类型系统 -------------------------------------------------------------------------------- /nanopass/t.out: -------------------------------------------------------------------------------- 1 | (5 4 3 2 1 0) 2 | -------------------------------------------------------------------------------- /zen/test/if.in: -------------------------------------------------------------------------------- 1 | (if (= 1 1) 5 2) -------------------------------------------------------------------------------- /zen/test/let.in: -------------------------------------------------------------------------------- 1 | (let ((a 3)) a) -------------------------------------------------------------------------------- /nanopass/t.out.tmp: -------------------------------------------------------------------------------- 1 | (5 4 3 2 1 0) 2 | -------------------------------------------------------------------------------- /zen/test/identity.in: -------------------------------------------------------------------------------- 1 | ((lambda (x) x) 5) 2 | -------------------------------------------------------------------------------- /re/go.mod: -------------------------------------------------------------------------------- 1 | module yasfs/re 2 | 3 | go 1.19 4 | -------------------------------------------------------------------------------- /zen/test/multi-arg.in: -------------------------------------------------------------------------------- 1 | ((lambda (x y) x) 2 42) -------------------------------------------------------------------------------- /zen/test/multi-arg1.in: -------------------------------------------------------------------------------- 1 | ((lambda (x y) y) 2 42) -------------------------------------------------------------------------------- /zen/test/partial.in: -------------------------------------------------------------------------------- 1 | (((lambda (x y) y) 1) 42) -------------------------------------------------------------------------------- /zen/test/plus1.in: -------------------------------------------------------------------------------- 1 | ((lambda (x y) (+ x y)) 3 5) -------------------------------------------------------------------------------- /value-of-k/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gcc -g main.c mpc.c 3 | -------------------------------------------------------------------------------- /0.20/README: -------------------------------------------------------------------------------- 1 | 添加也读写的方法，得到了一个基本的repl环境 2 | read-eval-print loop -------------------------------------------------------------------------------- /reborn/TODO: -------------------------------------------------------------------------------- 1 | 用scheme写一个编译器生成字节码 2 | 用c写一个虚拟机执行字节码 3 | 编译它自己，获得编译器，实现自编译 -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | a.out:vm.c vm.h 2 | gcc -g $< -o $@ 3 | 4 | clean: 5 | rm -rf a.out -------------------------------------------------------------------------------- /zen/test/closure.in: -------------------------------------------------------------------------------- 1 | ((lambda (x) 2 | (lambda (y) 3 | (+ x y))) 4 | 1 2) -------------------------------------------------------------------------------- /n6blisp/.svn/prop-base/gc.c.svn-base: -------------------------------------------------------------------------------- 1 | K 14 2 | svn:executable 3 | V 1 4 | * 5 | END 6 | -------------------------------------------------------------------------------- /n6blisp/.svn/prop-base/mem.c.svn-base: -------------------------------------------------------------------------------- 1 | K 14 2 | svn:executable 3 | V 1 4 | * 5 | END 6 | -------------------------------------------------------------------------------- /n6blisp/.svn/prop-base/mem.h.svn-base: -------------------------------------------------------------------------------- 1 | K 14 2 | svn:executable 3 | V 1 4 | * 5 | END 6 | -------------------------------------------------------------------------------- /n6blisp/.svn/prop-base/type.c.svn-base: -------------------------------------------------------------------------------- 1 | K 14 2 | svn:executable 3 | V 1 4 | * 5 | END 6 | -------------------------------------------------------------------------------- /zen/test/order1.in: -------------------------------------------------------------------------------- 1 | ((lambda (a b) 2 | (let ((x 3) 3 | (y 4)) 4 | x)) 1 2) -------------------------------------------------------------------------------- /zen/test/order2.in: -------------------------------------------------------------------------------- 1 | ((lambda (a b) 2 | (let ((x 3) 3 | (y 4)) 4 | y)) 1 2) -------------------------------------------------------------------------------- /n6blisp/.svn/prop-base/interpret.scm.svn-base: -------------------------------------------------------------------------------- 1 | K 14 2 | svn:executable 3 | V 1 4 | * 5 | END 6 | -------------------------------------------------------------------------------- /n6blisp/eval.h: -------------------------------------------------------------------------------- 1 | #ifndef EVAL_H 2 | #include "type.h" 3 | OBJ eval(OBJ exp,OBJ env); 4 | #endif 5 | -------------------------------------------------------------------------------- /test.scm: -------------------------------------------------------------------------------- 1 | (define func 2 | (lambda (a) 3 | (define b 6) 4 | (cons a b))) 5 | (func 3) -------------------------------------------------------------------------------- /zen/test/order3.in: -------------------------------------------------------------------------------- 1 | 2 | ((lambda (a b) 3 | (let ((x 3) 4 | (y 4)) 5 | a)) 1 2) -------------------------------------------------------------------------------- /zen/test/order4.in: -------------------------------------------------------------------------------- 1 | 2 | ((lambda (a b) 3 | (let ((x 3) 4 | (y 4)) 5 | b)) 1 2) -------------------------------------------------------------------------------- /n6blisp/.svn/text-base/mem.h.svn-base: -------------------------------------------------------------------------------- 1 | #ifndef MEM_H 2 | 3 | extern struct chunk *mem; 4 | 5 | #endif 6 | -------------------------------------------------------------------------------- /reborn/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gcc -g -Wall sexp.c vm.c -DSEXP_USE_NO_FEATURES -DSEXP_USE_GLOBAL_HEAP -DSEXP_USE_MALLOC -------------------------------------------------------------------------------- /n6blisp/compile.h: -------------------------------------------------------------------------------- 1 | #ifndef COMPILE_H 2 | 3 | #include "type.h" 4 | char* compile(OBJ sexp,OBJ env); 5 | #endif 6 | -------------------------------------------------------------------------------- /n6blisp/gc.h: -------------------------------------------------------------------------------- 1 | #ifndef GC_H 2 | #include "type.h" 3 | 4 | void gc_needgc(); 5 | void gc(OBJ env); 6 | 7 | #endif 8 | -------------------------------------------------------------------------------- /zen/test/fact5.in: -------------------------------------------------------------------------------- 1 | ((lambda1 (fact n) 2 | (if (= n 0) 3 | 1 4 | (* n (fact (- n 1))))) 5 | 5) -------------------------------------------------------------------------------- /zen/test/sum100.in: -------------------------------------------------------------------------------- 1 | ((lambda1 (loop i sum) 2 | (if (= i 101) 3 | sum 4 | (loop (+ i 1) (+ sum i)))) 5 | 1 0) -------------------------------------------------------------------------------- /n6blisp/lex.h: -------------------------------------------------------------------------------- 1 | #ifndef LEX_H 2 | #include "type.h" 3 | #include 4 | 5 | OBJ lex_read(FILE *in); 6 | void obj_write(FILE *out,OBJ obj); 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /sandbox/sandbox.meta: -------------------------------------------------------------------------------- 1 | ((files "sandbox.setup" 2 | "sandbox.scm" 3 | "desugar.scm" 4 | "eval.scm") 5 | (license "BSD") 6 | (author "Arthur Mao") 7 | (synopsis "a sandbox environment")) 8 | 9 | 10 | -------------------------------------------------------------------------------- /sandbox/sandbox.setup: -------------------------------------------------------------------------------- 1 | (compile -s -O3 -d1 "sandbox.scm" -j sandbox) 2 | (compile -s -O3 -d0 "sandbox.import.scm") 3 | 4 | (install-extension 5 | 'sandbox 6 | '("sandbox.so" "sandbox.import.so") 7 | '((version 1.0))) -------------------------------------------------------------------------------- /value-of-k/README: -------------------------------------------------------------------------------- 1 | scheme解释器，宿主语言为C 2 | 3 | (eval exp env cont) 4 | 5 | 支持基本if begin set lambda define let几个syntax 6 | 7 | builtin函数: + - * eq? 8 | 9 | gcc main.c mpc.c -o a.out 10 | ./a.out 11 | -------------------------------------------------------------------------------- /zen/test/hello.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "value.h" 3 | 4 | value 5 | print(value a, value b) { 6 | value ret = value_add(a, b); 7 | printf("hello world %ld\n", ret); 8 | return ret; 9 | } 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Some old pieces of code of Scheme Compiler I've ever wrote 2 | Part of this is placed in my googlecode previously. 3 | NO Licence claimed. Because it's even not a usable code... 4 | -------------------------------------------------------------------------------- /sandbox/sandbox.scm: -------------------------------------------------------------------------------- 1 | (module sandbox 2 | (make-sandbox 3 | sandbox-ref 4 | sandbox-set! 5 | sandbox-remove! 6 | sandbox-eval) 7 | 8 | (import scheme chicken) 9 | 10 | (include "desugar.scm") 11 | (include "eval.scm") 12 | ) 13 | -------------------------------------------------------------------------------- /zen/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all vm clean test 2 | 3 | all: vm 4 | 5 | vm: 6 | gcc -g -I runtime -o vm main.c runtime/dylib.c runtime/util.c runtime/value.c runtime/vm.c 7 | 8 | test : vm 9 | go run main.go 10 | 11 | clean: 12 | rm -rf vm vm.dSYM test/*.out test/*.bc 13 | -------------------------------------------------------------------------------- /0.25/README: -------------------------------------------------------------------------------- 1 | 引入了continuation，实现了call/cc函数 2 | 3 | (if (call-with-current-continuation (lambda (cont) (set! cc cont) #t)) "one-way" "other-way") 4 | (cc #f) 可以看到正确的结果 "other-way" 5 | 6 | (define cc 1) 7 | (call-with-current-continuation (lambda (cont) (set! cc cont))) 8 | (begin 1 2 (cc 33) 4) 9 | 10 | -------------------------------------------------------------------------------- /n6blisp/README: -------------------------------------------------------------------------------- 1 | 自己写的一个scheme语言的编译器，基本功能实现着不多了 2 | 主要包括： 3 | 1.类型系统 4 | 2.垃圾回收 5 | 3.文法分析 6 | 4.语法分析 7 | 5.代码生成 8 | 6.虚拟机 9 | scheme语言的特色包括： 10 | 垃圾回收 已实现 11 | 高阶函数 已实现 12 | 严格尾递归 已实现 13 | 卫生宏 部分实现，没时间做了 14 | 连续 还未研究 15 | 今天我怀着愤怒的心情(不解释)，放下写编译器的工作。项目又开始紧了，必须有所取舍。 16 | 有时候，有些东西，想着放一放，等有时间了再做，可能一放永远不会再有时间做了。 17 | 谨以此代码纪念过去的大半个月的自由时光！我宣布正式开始工作！ -------------------------------------------------------------------------------- /n6blisp/env.h: -------------------------------------------------------------------------------- 1 | #ifndef ENV_H 2 | 3 | OBJ env_null(); 4 | OBJ env_init(); 5 | OBJ extend_environment(OBJ names,OBJ values,OBJ env); 6 | OBJ lookup_variable_value(OBJ name,OBJ env); 7 | OBJ lookup_variable_cell(OBJ name,OBJ env); 8 | void set_variable_value(OBJ name,OBJ value,OBJ env); 9 | OBJ define(OBJ name,OBJ value,OBJ env); 10 | OBJ make_env(OBJ base,OBJ frame); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /reborn/opt/sexp-hufftabdefs.h: -------------------------------------------------------------------------------- 1 | 2 | char _huff_tab1[8], _huff_tab2[8], _huff_tab3[2], _huff_tab4[2], 3 | _huff_tab5[4], _huff_tab6[2], _huff_tab7[4], _huff_tab8[4], 4 | _huff_tab9[4], _huff_tab10[4], _huff_tab11[4], _huff_tab12[2], 5 | _huff_tab13[8], _huff_tab14[2], _huff_tab15[8], _huff_tab16[8], 6 | _huff_tab17[8], _huff_tab18[8], _huff_tab19[4], _huff_tab20[8], 7 | _huff_tab21[8]; 8 | -------------------------------------------------------------------------------- /n6blisp/mem.h: -------------------------------------------------------------------------------- 1 | #ifndef MEM_H 2 | 3 | struct freenode 4 | { 5 | struct freenode *next; 6 | unsigned int size; 7 | }; 8 | 9 | struct chunk 10 | { 11 | struct chunk *next; 12 | struct freenode *freelist; 13 | char data[]; 14 | }; 15 | 16 | void* mem_alloc(unsigned int size); 17 | unsigned long align(unsigned long p); 18 | void mem_exit_hook(); 19 | struct chunk* mem_get_chunk(); 20 | #endif 21 | -------------------------------------------------------------------------------- /n6blisp/.svn/text-base/type.c.svn-base: -------------------------------------------------------------------------------- 1 | typedef struct object_t 2 | { 3 | unsigned int flag; 4 | }*object; 5 | 6 | struct object_pair 7 | { 8 | unsigned int flag; 9 | object car; 10 | object cdr; 11 | }; 12 | 13 | struct object_fixnum 14 | { 15 | unsigned int flag; 16 | int num; 17 | }; 18 | 19 | typedef enum object_type_t 20 | { 21 | PAIR = 0, 22 | FIXNUM, 23 | 24 | }object_type; 25 | 26 | -------------------------------------------------------------------------------- /lambda-calculus.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (racket racket/match) 3 | 4 | (define (eval exp env) 5 | (match exp 6 | [`(,f ,e) (apply (eval f env) (eval e ent))] 7 | [`(λ ,v . ,e) `(closure ,exp ,env)] 8 | [(? symbol?) (cadr (assq exp env))])) 9 | 10 | (define (apply f x) 11 | (match f 12 | [`(closure (λ ,v . ,body) ,env) 13 | (eval body (cons `(,v ,x) env))])) 14 | 15 | (display (eval (read) '())) (newline) -------------------------------------------------------------------------------- /n6blisp/vm.h: -------------------------------------------------------------------------------- 1 | #ifndef VM_H 2 | 3 | #include "type.h" 4 | 5 | enum opcode 6 | { 7 | CONS, 8 | CAR, 9 | CDR, 10 | SET_CAR, 11 | SET_CDR, 12 | ADD, 13 | SUB, 14 | MUL, 15 | DIV, 16 | PUSH, 17 | POP, 18 | JUMP_UNLESS, 19 | JUMP, 20 | EQ, 21 | REF, 22 | UNINIT_REF, 23 | BIND, 24 | CALL, 25 | TAIL_CALL, 26 | RET, 27 | TYPE, 28 | GT, 29 | FC1, 30 | FC2, 31 | DONE, 32 | }; 33 | 34 | OBJ vm(char *bytecode); 35 | void print_bytecode(char *bytecode); 36 | #endif 37 | -------------------------------------------------------------------------------- /scheme2c/scheme2c.scm: -------------------------------------------------------------------------------- 1 | (define scheme2c 2 | (lambda (exp) 3 | (set! global-funcs '()) 4 | (set! global-vars '()) 5 | (let ((content (generate 6 | (explicit-allocation 7 | (closure-convert 8 | (T-c 9 | (lift-inner exp) 'cont)))))) 10 | (map print global-vars) 11 | (map print global-funcs) 12 | (print (string-append "void TopLevel(Value cont) {\n" 13 | "CheckMinorGC(cont);\n" 14 | content 15 | "}\n"))))) 16 | -------------------------------------------------------------------------------- /n6blisp/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean 2 | 3 | CC = gcc 4 | CFLAGS = -Wall -g 5 | 6 | SRCS = main.c mem.c type.c gc.c env.c lex.c eval.c vm.c compile.c 7 | OBJS = $(SRCS:.c=.o) 8 | 9 | %.o:%.c 10 | $(CC) -c $(CFLAGS) $< -o $@ 11 | 12 | .depend:$(SRCS) 13 | $(CC) -MM $(CFLAGS) $(SRCS) > .depend 14 | 15 | all:.depend $(OBJS) 16 | $(CC) $(OBJS) -o a.out 17 | 18 | clean: 19 | rm -f a.out $(OBJS) .depend 20 | -include .depend 21 | test: 22 | $(CC) -DENV_TEST -g mem.c gc.c type.c env.c lex.c -o test -------------------------------------------------------------------------------- /n6blisp/main.c: -------------------------------------------------------------------------------- 1 | #include "type.h" 2 | #include "gc.h" 3 | #include "env.h" 4 | #include "lex.h" 5 | #include "eval.h" 6 | #include 7 | 8 | int main(void) 9 | { 10 | OBJ env; 11 | OBJ data; 12 | OBJ result; 13 | 14 | printf("welcome to n6blisp~\n>"); 15 | env = env_init(); 16 | while(1) 17 | { 18 | data = lex_read(stdin); 19 | if(data == OBJ_EOF) 20 | break; 21 | result = eval(data,env); 22 | obj_write(stdout,result); 23 | printf("\n>"); 24 | } 25 | 26 | printf("Goodbye\n"); 27 | 28 | return 0; 29 | } 30 | -------------------------------------------------------------------------------- /re/cmd/cora/main.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "fmt" 5 | "io" 6 | "os" 7 | 8 | "yasfs/re" 9 | ) 10 | 11 | func main() { 12 | vm := re.New() 13 | r := re.NewSexpReader(os.Stdin, "") 14 | for i := 0; ; i++ { 15 | fmt.Printf("%d #> ", i) 16 | 17 | sexp, err := r.Read() 18 | if err != nil && err != io.EOF { 19 | panic(err) 20 | } 21 | // fmt.Println("read=", sexp) 22 | 23 | sexp = vm.MacroExpand(sexp) 24 | // fmt.Println("after macroexpand=", sexp) 25 | 26 | res := vm.Eval(sexp) 27 | 28 | fmt.Printf(res.String()) 29 | fmt.Println() 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /n6blisp/.svn/all-wcprops: -------------------------------------------------------------------------------- 1 | K 25 2 | svn:wc:ra_dav:version-url 3 | V 30 4 | /svn/!svn/ver/19/trunk/n6blisp 5 | END 6 | mem.c 7 | K 25 8 | svn:wc:ra_dav:version-url 9 | V 36 10 | /svn/!svn/ver/19/trunk/n6blisp/mem.c 11 | END 12 | type.c 13 | K 25 14 | svn:wc:ra_dav:version-url 15 | V 37 16 | /svn/!svn/ver/19/trunk/n6blisp/type.c 17 | END 18 | mem.h 19 | K 25 20 | svn:wc:ra_dav:version-url 21 | V 36 22 | /svn/!svn/ver/19/trunk/n6blisp/mem.h 23 | END 24 | gc.c 25 | K 25 26 | svn:wc:ra_dav:version-url 27 | V 35 28 | /svn/!svn/ver/19/trunk/n6blisp/gc.c 29 | END 30 | interpret.scm 31 | K 25 32 | svn:wc:ra_dav:version-url 33 | V 44 34 | /svn/!svn/ver/19/trunk/n6blisp/interpret.scm 35 | END 36 | -------------------------------------------------------------------------------- /continuation_monad.cora: -------------------------------------------------------------------------------- 1 | ;; blog link https://www.zenlife.tk/continuation-monad.md 2 | 3 | (defun return (x) (lambda (k) (k x))) 4 | 5 | (defun bind (m f) 6 | (lambda (k) 7 | (m (lambda (res) 8 | (f res k))))) 9 | 10 | (func rewrite-monad-do-h 11 | [val m . body] => ['bind m ['lambda [val] (rewrite-monad-do-h body)]] 12 | [body] => body) 13 | 14 | (defmacro monad-do (exp) 15 | (rewrite-monad-do-h (cdr exp))) 16 | 17 | ;; (defun fib (n) 18 | ;; (cond 19 | ;; ((= n 0) (return 0)) 20 | ;; ((= n 1) (return 1)) 21 | ;; (true (monad-do 22 | ;; x1 (fib (- n 1)) 23 | ;; x2 (fib (- n 2)) 24 | ;; (return (+ x1 x2)))))) 25 | 26 | ;; (fib 10 (lambda (x) x)) 27 | -------------------------------------------------------------------------------- /delimcc.cora: -------------------------------------------------------------------------------- 1 | (defun return (v) 2 | (lambda (k) 3 | (k v))) 4 | 5 | (defun id (x) x) 6 | 7 | (defun run-cc (c k) 8 | (c k)) 9 | 10 | (defun bind (c f) 11 | (lambda (k) 12 | (run-cc c (lambda (v) 13 | (run-cc (f v) k))))) 14 | 15 | (defun reset (cc) 16 | (run-cc cc id)) 17 | 18 | 19 | (defmacro shift (exp) 20 | (let k (cadr exp) 21 | body (cddr exp) 22 | ['lambda [k] . body])) 23 | 24 | (func rewrite-monad-do-h 25 | [val m . body] => ['bind m ['lambda [val] (rewrite-monad-do-h body)]] 26 | [body] => body) 27 | 28 | (defmacro do (exp) 29 | (rewrite-monad-do-h (cdr exp))) 30 | 31 | (reset 32 | (do 33 | v (shift k (k 666)) 34 | (return (+ v 42)))) 35 | -------------------------------------------------------------------------------- /scheme2c/desugar.scm: -------------------------------------------------------------------------------- 1 | (define desugar 2 | (lambda (exp) 3 | exp)) 4 | 5 | ;; 处理内部define 6 | (define lift-inner 7 | (lambda (exp) 8 | (match exp 9 | [(? symbol?) exp] 10 | [(? integer?) exp] 11 | [`(if ,test ,then ,else) 12 | `(if ,(lift-inner test) 13 | ,(lift-inner then) 14 | ,(lift-inner else))] 15 | [`(set! ,var ,val) 16 | `(set! ,var ,(lift-inner val))] 17 | [('lambda (bind ...) body ...) 18 | (let* ((bind$ '()) 19 | (body$ (map (lambda (e) 20 | (if (and (pair? e) (eq? (car e) 'define)) 21 | (begin 22 | (set! bind$ (cons (cadr e) bind$)) 23 | `(set! ,(cadr e) ,(lift-inner (caddr e)))) 24 | (lift-inner e))) 25 | body))) 26 | `(lambda (,@bind$ ,@bind) ,@body$))] 27 | [(f args ...) 28 | (map lift-inner exp)]))) 29 | 30 | -------------------------------------------------------------------------------- /zen/doc/RELEASE: -------------------------------------------------------------------------------- 1 | # Release Notes 2 | 3 | ## v0.0.1 4 | 5 | 一句话描述：实现了最基础的lambda演算，支持partial apply 6 | 7 | 语法支持int常量，变量，匿名函数，调用函数 8 | 9 | 基础的ZINC虚拟机，支持Access Grab Pushmark Closure Return Tailapply Apply几条指令 10 | 11 | ## v0.0.2 12 | 13 | 一句话描述：可以跑过阶乘函数和1-100求和了 14 | 15 | 添加了递归函数支持，fn => 语法 16 | 添加了+ - * 几个基本运算 17 | 添加了if then else语句 18 | 添加了BOOL类型 19 | 20 | ## v0.0.3 21 | 22 | 一句话描述：添加了类型推导这个feature 23 | 24 | 这个pass是外挂上去的，也就是类型推导的结果暂时丢弃了，但是不能过类型推导会编译不过 25 | 26 | ## v0.0.4 27 | 28 | 一句话描述：Tuple类型系统 29 | 30 | 添加了tuple类型 31 | field操作符，用于取tuple里面的值 32 | switch case表达式，用于tuple的tag匹配 33 | 34 | ## v0.0.5 35 | 36 | 一句话描述：用C重写了bytecode解释器 37 | 38 | 确定了指令集,调用协议 39 | 基本按照ppt里面最高级别的优化实现 40 | 41 | ## v0.0.6 42 | 43 | 简单的实现了FFI接口 44 | 45 | 添加了CCALL指令 46 | 47 | ## v0.0.7 48 | 49 | 一句话描述：采用S表达式语法 50 | 51 | port之前的代码，基于scheme重新实现 52 | 虚拟机添加了let的实现 53 | 添加了一些类似宏展开的预处理 54 | 提供eval-file函数读文件将生成bytecode输出到文件 -------------------------------------------------------------------------------- /nanopass/fmts.pretty: -------------------------------------------------------------------------------- 1 | (pretty-format 'define-who '(_ x #f ...)) 2 | (pretty-format 'trace-define-who '(_ x #f ...)) 3 | (pretty-format 'match '(_ x #f [bracket e 0 ...] ...)) 4 | (pretty-format 'code '(_ #f e ...)) 5 | (pretty-format 'locals '(_ (var ...) #f e)) 6 | (pretty-format 'ulocals '(_ (var ...) #f e)) 7 | (pretty-format 'spills '(_ (var ...) #f e)) 8 | (pretty-format 'locate '(_ ([bracket var loc] 0 ...) #f e)) 9 | (pretty-format 'register-conflict '(_ ([bracket fill 0 x ...] 0 ...) #f e)) 10 | (pretty-format 'frame-conflict '(_ ([bracket fill 0 x ...] 0 ...) #f e)) 11 | (pretty-format 'new-frames '(_ ((var ...) 0 ...) #f e)) 12 | (pretty-format 'return-point '(_ rplab #f e)) 13 | (pretty-format 'call-live '(_ (var ...) #f e)) 14 | (pretty-format 'free '(_ x #f e)) 15 | (pretty-format 'closures '(_ ([bracket x ...] 0 ...) #f e ...)) 16 | (pretty-format 'bind-free '(_ x #f e)) 17 | (pretty-format 'well-known '(_ x #f e)) 18 | (pretty-format 'assigned '(_ x #f e)) 19 | -------------------------------------------------------------------------------- /spiffy/spiffy.scm: -------------------------------------------------------------------------------- 1 | (use intarweb) 2 | (use tcp) 3 | (use srfi-18) 4 | 5 | (define (handler req resp) 6 | (display "hello world" (response-port resp)) 7 | (finish-response-body resp)) 8 | 9 | 10 | (define (handle-incoming-request in out) 11 | (let ((req (read-request in)) 12 | (resp (make-response 13 | port: out 14 | headers: (headers 15 | `((content-type text/html)))))) 16 | (handler req resp) 17 | (unless (port-closed? out) (flush-output out)))) 18 | 19 | (define (accept-loop listener) 20 | (let accept-next-connection () 21 | (let-values (((in out) (tcp-accept listener))) 22 | (thread-start! 23 | (lambda () 24 | (let handle-next-request () 25 | (when (and (handle-incoming-request in out) 26 | (not (port-closed? in)) 27 | (not (port-closed? out))) 28 | (handle-next-request))) 29 | (close-input-port in) 30 | (close-output-port out)))) 31 | (accept-next-connection))) 32 | 33 | (define (start-server port) 34 | (let ((listener (tcp-listen port))) 35 | (accept-loop listener))) 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /zen/driver.ss: -------------------------------------------------------------------------------- 1 | (load "core.ss") 2 | (load "parser.ss") 3 | (load "compiler.ss") 4 | (load "emit.ss") 5 | 6 | (define (read-file file) 7 | (define (loop p l) 8 | (let ((s (read p))) 9 | (if (eof-object? s) 10 | l 11 | (loop p (cons s l))))) 12 | (call-with-input-file file 13 | (lambda (port) 14 | (let ((input `(lambda () 15 | ,@(reverse 16 | (loop port '()))))) 17 | (caddr 18 | (macro2 19 | (macro1 20 | (macro0 input)))))))) 21 | 22 | (define (step-parse exp) 23 | (parse exp '())) 24 | 25 | (define (step-compile ir) 26 | (compile ir (cons (tuple IStop) '()))) 27 | 28 | (define (step-emit bc) 29 | (lambda (p) 30 | (for-each 31 | (lambda (x) (emit-inst p x)) 32 | bc))) 33 | 34 | (define (step-emit-file bc filename) 35 | (let ((p 36 | (open-file-output-port filename 37 | (file-options no-fail) 38 | (buffer-mode block)))) 39 | ((step-emit bc) p) 40 | (flush-output-port p) 41 | (close-output-port p))) 42 | -------------------------------------------------------------------------------- /zen/core.ss: -------------------------------------------------------------------------------- 1 | (define-syntax tuple 2 | (syntax-rules () 3 | ((_ tag v ...) 4 | (vector 'tag v ...)))) 5 | 6 | (define (field n t) (vector-ref t (+ n 1))) 7 | 8 | (define-syntax case 9 | (syntax-rules () 10 | [(_ exp (tag e) ...) 11 | (cond 12 | ((eq? 'tag (vector-ref exp 0)) e) 13 | ... 14 | (else 15 | ;; if none matched, throw a exception 16 | (+ 23 "type infer failed")))])) 17 | 18 | (define-syntax match-tuple-one 19 | (syntax-rules () 20 | ((_ x (tag) body) 21 | body) 22 | ((_ x (tag v) body) 23 | (let ((v (vector-ref x 1))) 24 | body)) 25 | ((_ x (tag v1 v2) body) 26 | (let ((v1 (vector-ref x 1)) 27 | (v2 (vector-ref x 2))) 28 | body)) 29 | ((_ x (tag v1 v2 v3) body) 30 | (let ((v1 (vector-ref x 1)) 31 | (v2 (vector-ref x 2)) 32 | (v3 (vector-ref x 3))) 33 | body)))) 34 | 35 | (define-syntax match-tuple 36 | (syntax-rules () 37 | ((_ x ((tag v ...) body) ...) 38 | (let ((tmp x)) 39 | (cond 40 | ((eq? (quote tag) (vector-ref x 0)) 41 | (match-tuple-one tmp (tag v ...) body)) 42 | ...))))) 43 | -------------------------------------------------------------------------------- /n6blisp/.svn/text-base/gc.c.svn-base: -------------------------------------------------------------------------------- 1 | #include "mem.h" 2 | 3 | #define gc_mark(object) (((object)->flag) |= 0x1) 4 | #define gc_ismarked(object) ((((object) & 0x1) > 0)? 1:0) 5 | #define gc_unmark(object) (((object)->flag) &= ~0x1) 6 | 7 | void mark(object obj) 8 | { 9 | gc_mark(obj); 10 | switch(obj->flag << 1) 11 | { 12 | case PAIR: 13 | gc_mark(obj->car); 14 | gc_mark(obj->cdr); 15 | break; 16 | default: 17 | break; 18 | } 19 | } 20 | 21 | void sweep() 22 | { 23 | struct chunk *ck; 24 | object base; 25 | object_type type; 26 | struct freenode *p; 27 | 28 | for(ck=mem; ck!=NULL; ck=ck->next) 29 | { 30 | base = ck->data; 31 | while(base < ck+4096) 32 | { 33 | if(gc_ismarked(base)) 34 | { 35 | gc_unmark(base); 36 | type = base->flag >> 1; 37 | switch(type) 38 | { 39 | case PAIR: 40 | base = (char*)base+sizeof(struct object_pair); 41 | continue; 42 | case FIXNUM: 43 | base = (char*)base + sizeof(struct object_fixnum); 44 | continue; 45 | default: 46 | fprintf(stderr,"unknown type"); 47 | exit(-1); 48 | } 49 | } 50 | else 51 | { 52 | base += sizeof(object); 53 | } 54 | } 55 | } 56 | } 57 | 58 | gc() 59 | -------------------------------------------------------------------------------- /reborn/opt/opcode_names.h: -------------------------------------------------------------------------------- 1 | 2 | static const char* sexp_opcode_names_[] = 3 | {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", 4 | "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", 5 | "JUMP-UNLESS", "JUMP", "PUSH", "RESERVE", "DROP", 6 | "GLOBAL-REF", "GLOBAL-KNOWN-REF", "PARAMETER-REF", "STACK-REF", 7 | "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "CLOSURE-VARS", 8 | "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", 9 | "BYTES-REF", "BYTES-SET", "BYTES-LENGTH", 10 | "STRING-REF", "STRING-SET", "STRING-LENGTH", 11 | "STRING-CURSOR-NEXT", "STRING-CURSOR-PREV", "STRING-SIZE", 12 | "MAKE-PROCEDURE", "MAKE-VECTOR", 13 | "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", 14 | "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", 15 | "ISA?", "SLOTN-REF", "SLOTN-SET", 16 | "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", 17 | "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", 18 | "LT", "LE", "EQN", "EQ", 19 | "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", 20 | "WRITE-CHAR", "WRITE-STRING", "READ-CHAR", "PEEK-CHAR", 21 | "YIELD", "FORCE", "RET", "DONE", 22 | }; 23 | 24 | const char** sexp_opcode_names = sexp_opcode_names_; 25 | -------------------------------------------------------------------------------- /n6blisp/doc/实现.txt: -------------------------------------------------------------------------------- 1 | 1.对象类型系统 2 | scheme中类型是与值相关联的。变量是无类型的，但变量绑定的值是有类型的。 3 | 2.环境 4 | 在程序的某一点有效的所有可见绑定的集合，被称为对该点有效的环境。 5 | 3.内存管理 6 | 4.垃圾回收 7 | 5.文法分析 8 | 6.编译 9 | 6.1计算栈而非通用栈 10 | 6.2严格尾递归 11 | 如果scheme实现上支持无限数量的活动尾调用，它就是严格尾递归的。 12 | 尾调用是发生在尾上下文中的过程调用。 13 | 尾上下文定义具体见r5rs第8页 14 | 7.虚拟机 15 | 16 | 17 | 写个专题，每天记录遇到了哪些问题，怎么样解决这些问题的。 18 | 2011.9.5以前 19 | 垃圾回收的问题 20 | 参数绑定的问题 21 | 22 | 2011.9.5 23 | 1.尾调用的实现 24 | 理解尾上下文，尾调用。 25 | 2.发现递归定义的bug 26 | 问题描述：(define f (lambda () (f))) 27 | 在语法分析阶段analyze函数中， 28 | 先生成f的环境结点，指定一个未初始化的值 29 | 然后analyze f的具体定义生成ast,初始化f 30 | 但是...在递归的lambda内分析f时，f是还未初始化的，因此不知道如何处理这种情况。 31 | 32 | 2011.9.6 33 | 修复递归定义的bug 34 | 解决方法： 35 | 在analyze中加入对末初始化值的处理。不再是直接生成procedure的调用的代码，而是生成 （获得procedure的代码，然后调用） 的代码 36 | 在(lambda () (f))中，如果f是末初始化的， 37 | 不再取其值，而是取环境结点。虚拟机中加入了一条UNINIT_REF指令。 38 | 在代码生成中，先PUSH环境结点，再UNINIT_REF，如此，在运行时期就可以得到已初始化的f 39 | 子问题：对于生成末初始化值的procedure，由于语法分析阶段得不到procedure，所以上面的解决方案是推迟到了运行期 40 | 但是语法分析阶段procedure没初始化，就无法生成形参实参绑定的代码。 41 | 于是加了一条指令BIND,运行期动态绑定参数 42 | 43 | 2011.9.8-2011.7.11 44 | 实现scheme语言的"卫生宏" 45 | 实现方法是一言以蔽之：在当前环境“展开”宏，在宏定义的环境进行计算 46 | 宏定义阶段： 47 | syntax-rules生成一个syntax，这个syntax包括三个成员，模式，模板，宏定义环境 48 | 模板这个时候都是不编码的，是外部表示的形式 49 | 宏使用阶段： 50 | 如果是宏，匹配到了某个模式，则编译模板。编译过程特殊处理，若变量是宏的参数，则在 51 | 当前环境中查找变量，否则，在宏定义环境中查找变量。这就是所谓的在当前环境“展开”宏， 52 | 在宏定义的环境进行计算。 53 | -------------------------------------------------------------------------------- /test.scm.c: -------------------------------------------------------------------------------- 1 | void funcXXX(struct vm *vm){ 2 | ENTER_CLOSURE(1,"funcXXX"); 3 | vm->value = make_number(3); 4 | PUSH(vm->value); 5 | value = SHALLOW_ARGUMENT_REF(0); 6 | vm->func = vm->value; 7 | vm->value = make_vector(1); 8 | CLOSURE_CALL() 9 | vector_set(vm->value,0,POP()) 10 | PUSH(vm->value); 11 | vm->value = make_closure(funcXXX,vm->env); 12 | value = SHALLOW_ARGUMENT_SET(0); 13 | vm->func = vm->value; 14 | vm->value = make_vector(1); 15 | CLOSURE_CALL() 16 | vector_set(vm->value,0,POP()) 17 | EXIT_CLOSURE(); 18 | } 19 | void funcXXX(struct vm *vm){ 20 | ENTER_CLOSURE(1,"funcXXX"); 21 | vm->value = make_number(6); 22 | value = SHALLOW_ARGUMENT_SET(1); 23 | value = SHALLOW_ARGUMENT_REF(0); 24 | PUSH(vm->value); 25 | value = SHALLOW_ARGUMENT_REF(1); 26 | PUSH(vm->value); 27 | vm->value = cons(POP(),POP()) 28 | EXIT_CLOSURE(); 29 | } 30 | void funcXXX(struct vm *vm){ 31 | ENTER_CLOSURE(1,"funcXXX"); 32 | vm->value = make_number(6); 33 | value = SHALLOW_ARGUMENT_SET(1); 34 | value = SHALLOW_ARGUMENT_REF(0); 35 | PUSH(vm->value); 36 | value = SHALLOW_ARGUMENT_REF(1); 37 | PUSH(vm->value); 38 | vm->value = cons(POP(),POP()) 39 | EXIT_CLOSURE(); 40 | } 41 | 42 | 43 | //code 44 | vm->value = make_closure(funcXXX,vm->env); 45 | vm->func = vm->value; 46 | vm->value = make_vector(0); 47 | CLOSURE_CALL() 48 | -------------------------------------------------------------------------------- /reborn/opt/plan9-opcodes.c: -------------------------------------------------------------------------------- 1 | _FN0(_I(SEXP_FIXNUM), "random-integer", 0, sexp_rand), 2 | _FN1(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "random-seed", 0, sexp_srand), 3 | _FN0(_I(SEXP_STRING), "current-directory", 0, sexp_getwd), 4 | _FN0(_I(SEXP_STRING), "current-user", 0, sexp_getuser), 5 | _FN0(_I(SEXP_STRING), "system-name", 0, sexp_sysname), 6 | _FN1(_I(SEXP_FIXNUM), _I(SEXP_IPORT), "port-fileno", 0, sexp_fileno), 7 | _FN2(_I(SEXP_IPORT), _I(SEXP_FIXNUM), _I(SEXP_STRING), "fileno->port", 0, sexp_fdopen), 8 | _FN0(_I(SEXP_FIXNUM), "fork", 0, sexp_fork), 9 | _FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_PAIR), "exec", 0, sexp_exec), 10 | _FN1(SEXP_VOID, _I(SEXP_STRING), "exits", 0, sexp_exits), 11 | _FN2(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "dup", 0, sexp_dup), 12 | _FN0(_I(SEXP_PAIR), "pipe", 0, sexp_pipe), 13 | _FN1(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "sleep", 0, sexp_sleep), 14 | _FN1(_I(SEXP_STRING), _I(SEXP_STRING), "getenv", 0, sexp_getenv), 15 | _FN1(_I(SEXP_FIXNUM), _I(SEXP_STRING), "change-directory", 0, sexp_chdir), 16 | _FN0(_I(SEXP_FIXNUM), "wait", 0, sexp_wait), 17 | _FN2(_I(SEXP_FIXNUM), _I(SEXP_FIXNUM), _I(SEXP_STRING), "post-note", 0, sexp_postnote), 18 | _FN4(_I(SEXP_FIXNUM), _I(SEXP_PAIR), _I(SEXP_STRING), _I(SEXP_STRING), "%postmountsrv", 0, sexp_postmountsrv), 19 | _FN1(_I(SEXP_FIXNUM), _I(SEXP_STRING), "file-exists?", 0, sexp_file_exists_p), 20 | -------------------------------------------------------------------------------- /n6blisp/scheme.c: -------------------------------------------------------------------------------- 1 | 2 | OBJ analyze_define(OBJ sexp,OBJ env) 3 | { 4 | 建一个环境cell加到env中; 5 | 产生一个define结构的ast; 6 | struct ast 7 | { 8 | OBJ value; 9 | OBJ cell; 10 | }; 11 | 12 | } 13 | OBJ analyze_if(){} 14 | OBJ analyze_set(){} 15 | OBJ analyze_lambda(OBJ sexp,OBJ env) 16 | { 17 | 新建env，其父env是传入的env; 18 | 将参数全binding到env，value为undefined; 19 | 生成lambda结构的ast; 20 | struct ast 21 | { 22 | OBJ env = 新的env; 23 | OBJ para = 取出para构成一个list; 24 | OBJ body = body部分; 25 | }; 26 | } 27 | OBJ analyze_if(OBJ sexp,OBJ env) 28 | { 29 | 生成if结构的ast; 30 | struct ast 31 | { 32 | test_part; 33 | then_part; 34 | else_part; 35 | }; 36 | } 37 | OBJ analyze(OBJ sexp,OBJ env) 38 | { 39 | } 40 | 41 | OBJ generate_define() 42 | { 43 | generate（value）; 44 | emit(PUSH); 45 | emit(cell); 46 | emit(set-cdr); 47 | } 48 | OBJ generate_if(OBJ ast,OBJ env) 49 | { 50 | generate(sexp->test_part); 51 | emit(JUMP_UNLESS); 52 | emit(label1); 53 | generate(sexp->then_part); 54 | emit(JUMP); 55 | emit(label2); 56 | make_label(label1); 57 | generate(sexp->else_part); 58 | make_label(label2); 59 | } 60 | generate_if() 61 | generate_set() 62 | generate_lambda() 63 | OBJ generate_lambda(OBJ ast,OBJ env) 64 | { 65 | generate(ast->body,ast->env); 66 | 生成RET; 67 | } 68 | OBJ generate(OBJ ast,OBJ env) 69 | { 70 | } 71 | 72 | int compile(OBJ sexp,OBJ env) 73 | { 74 | } 75 | -------------------------------------------------------------------------------- /pmatch.scm: -------------------------------------------------------------------------------- 1 | (use matchable) 2 | 3 | (define-syntax pmatch 4 | (er-macro-transformer 5 | (lambda (input rename compare) 6 | ;; input (pat1 -> act1 pat2 -> act2 ...) 7 | ;; output ((pat1 act1) (pat2 act2) ...) 8 | (define (extract-rules input) 9 | (if (null? input) 10 | input 11 | (cons (list (car input) (caddr input)) 12 | (extract-rules (cdddr input))))) 13 | 14 | (let* ((raw (cddr input)) 15 | (rules (extract-rules raw))) 16 | `(match ,(cadr input) ,@rules))))) 17 | 18 | (define (rewrite-fun input) 19 | (rewrite-fun1 input '() '())) 20 | 21 | (define (rewrite-fun1 input cache result) 22 | (pmatch input 23 | () -> (reverse result) 24 | ('-> act . remain) -> (let ((tmp (list (reverse cache) act))) 25 | (rewrite-fun1 remain '() (cons tmp result))) 26 | (a . b) -> (rewrite-fun1 b (cons a cache) result))) 27 | 28 | (define-syntax fun 29 | (er-macro-transformer 30 | (lambda (input rename compare) 31 | (let* ((raw (cddr input)) 32 | (rules (rewrite-fun raw))) 33 | `(define ,(cadr input) 34 | (match-lambda* 35 | ,@rules))) 36 | ))) 37 | 38 | ;; (fun map 39 | ;; f () -> '() 40 | ;; f (a . b) -> (cons (f a) (map f b))) 41 | 42 | 43 | -------------------------------------------------------------------------------- /zen/main.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "fmt" 5 | "strings" 6 | "os/exec" 7 | "os" 8 | ) 9 | 10 | func main() { 11 | dir, err := os.Open("test/") 12 | checkErr(err) 13 | defer dir.Close() 14 | 15 | files, err := dir.Readdirnames(0) 16 | checkErr(err) 17 | for _, f := range files { 18 | if strings.HasSuffix(f, ".in") { 19 | fmt.Println("testing file:", f) 20 | handleFile("test/" + f[:len(f)-3]) 21 | } 22 | } 23 | } 24 | 25 | func checkErr(err error) { 26 | if err != nil { 27 | panic(err) 28 | } 29 | } 30 | 31 | func handleFile(file string) { 32 | err := compile(file) 33 | checkErr(err) 34 | 35 | err = run(file) 36 | checkErr(err) 37 | 38 | err = check(file) 39 | checkErr(err) 40 | } 41 | 42 | func compile(file string) error { 43 | cmd := exec.Command("./cc") 44 | input, err := os.Open(file + ".in") 45 | if err != nil { 46 | return err 47 | } 48 | 49 | output, err := os.Create(file + ".bc") 50 | if err != nil { 51 | return err 52 | } 53 | 54 | cmd.Stdin = input 55 | cmd.Stdout = output 56 | return cmd.Run() 57 | } 58 | 59 | func run(file string) error { 60 | cmd := exec.Command("./vm", file + ".bc") 61 | 62 | output, err := os.Create(file + ".out") 63 | if err != nil { 64 | return err 65 | } 66 | cmd.Stdout = output 67 | return cmd.Run() 68 | } 69 | 70 | func check(file string) error { 71 | return nil 72 | } 73 | -------------------------------------------------------------------------------- /n6blisp/.svn/text-base/mem.c.svn-base: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | struct freenode 5 | { 6 | struct freenode *next; 7 | unsigned int size; 8 | }; 9 | struct chunk 10 | { 11 | struct chunk *next; 12 | struct freenode *freelist; 13 | char *data; 14 | }; 15 | 16 | struct chunk *mem = NULL; 17 | 18 | static int mem_alloc_chunk() 19 | { 20 | struct chunk *ck; 21 | ck = malloc(4096); 22 | if(ck == NULL) 23 | return -1; 24 | ck->next = mem; 25 | mem = ck; 26 | ck->freelist = chunk->data; 27 | ck->freelist->next = NULL; 28 | ck->>freelist->size = 4096 - sizeof(struct chunk*)-sizeof(struct freenode); 29 | return 0; 30 | } 31 | 32 | void* mem_alloc(unsigned int size) 33 | { 34 | struct chunk *ck; 35 | struct freenode *p,*prev,*tmp; 36 | 37 | if(size >= 4096 - sizeof(struct chunk*)-sizeof(struct freenode)) 38 | return NULL; 39 | for(ck = mem; ck!=NULL; ck=ck->next) 40 | { 41 | prev = ck->freelist; 42 | p = prev->next; 43 | while(p) 44 | { 45 | if(p->size >= size) 46 | { 47 | if(p->size - size < OBJECT_SMALL_SIZE) 48 | { 49 | prev->next = p->next; 50 | return p; 51 | } 52 | else 53 | { 54 | tmp = (char*)p + size; 55 | tmp->next = p->next; 56 | prev->next = tmp; 57 | return p; 58 | } 59 | } 60 | prev = p; 61 | p = p->next; 62 | } 63 | } 64 | if(gc()) /* 如果gc后空间仍不足 */ 65 | { 66 | if(mem_alloc_chunk() != 0) 67 | { 68 | fprintf(stderr,"out of memory"); 69 | return NULL; 70 | } 71 | return mem_alloc(size); 72 | } 73 | } 74 | 75 | -------------------------------------------------------------------------------- /roadmap: -------------------------------------------------------------------------------- 1 | yasfs is the short hand for "yet another scheme from scratch." 2 | By saying "from scratch" I mean: 3 | 1.a interpreter written in C, 4 | 2.a bytecode compiler in written in scheme,and a vm written in C 5 | 3.a scheme to C compiler. 6 | 7 | Firstly,I want to implement a basic scheme interpreter in C. 8 | This interpreter need not be powerful,maybe there is no gc,no continuation, 9 | on macro. It's enough for it to intepret simple scheme. 10 | I want it to be a bootstrap, no gc,no continuation,no macro as soon as it 11 | can interpret the bytecode compiler,which will be written in scheme. 12 | I'll call this version v0.3. 13 | 14 | Secondly,I want to implement a bytecode compiler in scheme. 15 | It should be able to be interpreted by the previous interpret. 16 | And a vm will be need to run the compiled bytecodes,which should be written in C for efficiency reasons. 17 | continuation should be be implemented,and gc should be also guaranteed.Tail-call in not difficult,of course. 18 | This compiler should be able to compile itself.So I get a faster compiler. 19 | It's need not be started until the v0.3 done,because I can use much better tools like racket as bootstrap.And the work can be parellel. 20 | With this completed,The version should goes to v0.6. 21 | 22 | Lastly,the scheme to C compiler. Using the technology of continuatus style convert and lambda lifting.I think the 90-minutes-scheme is a good start point. 23 | After all things done,the version will be v0.9. 24 | Never the v1.0 because all of this is just my toy code and a process of learning scheme.I won't goes further,I think. -------------------------------------------------------------------------------- /srfi-18/main.scm: -------------------------------------------------------------------------------- 1 | (define thread-queue '()) 2 | 3 | (define halt #f) 4 | 5 | (define (void) (begin)) 6 | 7 | (define (current/cc) 8 | (call/cc (lambda (cc) cc))) 9 | 10 | (define (spawn thunk) 11 | (let ((cc (current/cc))) 12 | (if (procedure? cc) 13 | (set! thread-queue (append thread-queue (list cc))) 14 | (begin (thunk) (quit))))) 15 | 16 | (define (yield) 17 | (let ((cc (current/cc))) 18 | (if (and (procedure? cc) (pair? thread-queue)) 19 | (let ((next-thread (car thread-queue))) 20 | (set! thread-queue (append (cdr thread-queue) (list cc))) 21 | (next-thread 'resume)) 22 | (void)))) 23 | 24 | (define (quit) 25 | (if (pair? thread-queue) 26 | (let ((next-thread (car thread-queue))) 27 | (set! thread-queue (cdr thread-queue)) 28 | (next-thread 'resume)) 29 | (halt))) 30 | 31 | (define (start-threads) 32 | (let ((cc (current/cc))) 33 | (if cc 34 | (begin 35 | (set! halt (lambda () (cc #f))) 36 | (if (null? thread-queue) 37 | (void) 38 | (begin 39 | (let ((next-thread (car thread-queue))) 40 | (set! thread-queue (cdr thread-queue)) 41 | (next-thread 'resume))))) 42 | (void)))) 43 | 44 | (define counter 10) 45 | 46 | (define (make-thread-thunk name) 47 | (letrec ((loop (lambda () 48 | (if (< counter 0) 49 | (quit)) 50 | (display "in thread ") 51 | (display name) 52 | (display "; counter = ") 53 | (display counter) 54 | (newline) 55 | (set! counter (- counter 1)) 56 | (yield) 57 | (loop)))) 58 | loop)) 59 | 60 | (spawn (make-thread-thunk 'a)) 61 | (spawn (make-thread-thunk 'b)) 62 | (spawn (make-thread-thunk 'c)) 63 | 64 | (start-threads) 65 | -------------------------------------------------------------------------------- /zen/doc/bytecode.md: -------------------------------------------------------------------------------- 1 | int是32位或者64位，由机器字长决定 2 | 3 | ## 寄存器 4 | 5 | pc 6 | bp 7 | sp 8 | acc 9 | env 10 | global 11 | 12 | ## 指令集 13 | 14 | CLOSURE ofst 创建闭包，pc为下一个，环境为空 15 | APPLY 将pc和env设置为acc(闭包)里面的值 16 | ENV n 将参数数量进栈，更新bp，保存bp 17 | UNENV 跟ENV相反的操作 18 | RETURN n 出栈n个元素，将pc和env设置为acc里面的值 19 | MARK 标记设置为sp 20 | ACC n 栈顶往下第n个到acc 21 | 22 | ACC0 栈顶到acc 23 | PUSH0 acc到栈顶 24 | PUSHACC n stack[top-n]->acc 25 | POP n 出栈n个 26 | ASSIGN n 栈第n个设置为acc，acc设置为unit 27 | ENVACC n acc设置为env第n个 28 | 29 | OFFSETCLOSURE n 将acc设置为环境中第n个闭包值 30 | GETGLOBAL n 将accu设置为global数据的第n个 31 | GETGLOBALFIELD n p global的第n个的第p个field 32 | SETGLOBAL n 将global的第n个设置为accu，然后accu设置为unit 33 | MAKEBLOCK n t 用accu和栈上n-1个元素，创建block，tag为t，将block设置到accu 34 | GETFIELD0 将accu设置为accu的field0元素 35 | GETFIELD n 将accu设置为accu的field n元素 36 | SETFIELD n 将accu对就block里面的第n个field设置为栈顶值，出栈，accu设置为unit 37 | BRANCH ofst 将pc加ofst 38 | BRANCHIF ofst 如果accu不为0，则将pc加ofst 39 | SWITCH n tab 40 | BOOLNOT 对accu执行not操作 41 | CCALL p 保存环境，调用p，accu设置为返回值，恢复p 42 | CONST n 将accu设置为常量n 43 | NEGINT 对accu执行取负 44 | ADDINT 45 | SUBINT 46 | MULINT 47 | DIVINT 48 | MODINT 49 | ANDINT 50 | ORINT 51 | XORINT 52 | LSLINT 53 | LSRINT 54 | EQ 55 | NEQ 56 | LTINT 57 | LEINT 58 | GTINT 59 | GEINT 60 | OFFSETINT ofst 在accu加上ofst 61 | STOP 62 | 63 | 其实"环境"由静态跟动态两个部分组成，动态的那部分保存在栈上面，静态的部分保存在env寄存器里面 64 | bp跟stack[bp]区间，是动态环境 65 | 66 | 闭包 = 环境 + pc 67 | 环境 = 动态环境 + 静态环境 68 | 动态环境 = bp跟stack[bp]区间 69 | 70 | 闭包跟上下文其实等价 71 | 72 | 函数调用就是保存上下文，切换到新的上下文 73 | 保存上下文跟切换其实是两个动作，保存上下文涉及保存旧的pc,env,bp；切换上下文涉及覆盖当前的pc,env,bp； 74 | 对于尾递归，可以不用保存上下文，直接切换新的上下文 75 | 所以呢，相关的指令是三条： 76 | PUSHADDR 保存上下文 -- 将bp env pc进栈 77 | APPLY 切换上下文 -- bp更新为sp、pc和env更新为acc里面的值 78 | RETURN 返回之前的上下文 79 | 80 | 闭包的形成有以下几种情况： 81 | CLOSURE指令：非尾调用的时候lambda会生成闭包 82 | GRAB指令：当判断参数不够时，会生成闭包 83 | PUSHADDR指令：返回信息实际上就是闭包 84 | 85 | 仅有一个bp是不够的，需要加一个mark 86 | mark不需要保存在栈内(不需要恢复)，但是需要有 87 | bp还是原始的作用 88 | -------------------------------------------------------------------------------- /scheme.h: -------------------------------------------------------------------------------- 1 | struct Int ; 2 | struct Boolean ; 3 | struct Closure ; 4 | union Value ; 5 | 6 | enum Tag { VOID, INT, BOOLEAN, CLOSURE, CELL, ENV } ; 7 | 8 | typedef union Value (*Lambda)() ; 9 | 10 | struct Int { 11 | enum Tag t ; 12 | int value ; 13 | } ; 14 | 15 | struct Boolean { 16 | enum Tag t ; 17 | unsigned int value ; 18 | } ; 19 | 20 | struct Closure { 21 | enum Tag t ; 22 | Lambda lam ; 23 | void* env ; 24 | } ; 25 | 26 | struct Env { 27 | enum Tag t ; 28 | void* env ; 29 | } ; 30 | 31 | struct Cell { 32 | enum Tag t ; 33 | union Value* addr ; 34 | } ; 35 | 36 | union Value { 37 | enum Tag t ; 38 | struct Int z ; 39 | struct Boolean b ; 40 | struct Closure clo ; 41 | struct Env env ; 42 | struct Cell cell ; 43 | } ; 44 | 45 | typedef union Value Value ; 46 | 47 | static Value MakeClosure(Lambda lam, Value env) { 48 | Value v ; 49 | v.clo.t = CLOSURE ; 50 | v.clo.lam = lam ; 51 | v.clo.env = env.env.env ; 52 | return v ; 53 | } 54 | 55 | static Value MakeInt(int n) { 56 | Value v ; 57 | v.z.t = INT ; 58 | v.z.value = n ; 59 | return v ; 60 | } 61 | 62 | static Value MakeBoolean(unsigned int b) { 63 | Value v ; 64 | v.b.t = BOOLEAN ; 65 | v.b.value = b ; 66 | return v ; 67 | } 68 | 69 | static Value MakePrimitive(Lambda prim) { 70 | Value v ; 71 | v.clo.t = CLOSURE ; 72 | v.clo.lam = prim ; 73 | v.clo.env = NULL ; 74 | return v ; 75 | } 76 | 77 | static Value MakeEnv(void* env) { 78 | Value v ; 79 | v.env.t = ENV ; 80 | v.env.env = env ; 81 | return v ; 82 | } 83 | 84 | 85 | static Value NewCell(Value initialValue) { 86 | Value v ; 87 | v.cell.t = CELL ; 88 | v.cell.addr = malloc(sizeof(Value)) ; 89 | *v.cell.addr = initialValue ; 90 | return v ; 91 | } 92 | 93 | 94 | extern Value __sum ; 95 | extern Value __difference ; 96 | extern Value __product ; 97 | extern Value __display ; 98 | extern Value __numEqual ; -------------------------------------------------------------------------------- /reborn/opt/sexp-unhuff.c: -------------------------------------------------------------------------------- 1 | /* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ 2 | 3 | res = c & 7; 4 | c = c >> 3; 5 | if (res == 0) { 6 | res = c & 3; 7 | c = c >> 2; 8 | if (res == 0) { 9 | res = c & 3; 10 | c = c >> 2; 11 | if (res == 0) { 12 | res = c & 7; 13 | c = c >> 3; 14 | if (res == 0) { 15 | res = c & 3; 16 | c = c >> 2; 17 | if (res == 0) { 18 | res = _huff_tab21[c & 7]; 19 | c = c >> 3; 20 | } else if ((res = _huff_tab19[res]) == '\x01') { 21 | res = _huff_tab20[c & 7]; 22 | c = c >> 3; 23 | } 24 | } else if (res == 1) { 25 | res = _huff_tab18[c & 15]; 26 | c = c >> 4; 27 | } else if (res == 2) { 28 | res = _huff_tab17[c & 31]; 29 | c = c >> 5; 30 | } else if (res == 4) { 31 | res = _huff_tab16[c & 15]; 32 | c = c >> 4; 33 | } else if (res == 5) { 34 | res = _huff_tab15[c & 15]; 35 | c = c >> 4; 36 | } else if ((res = _huff_tab13[res]) == '\x00') { 37 | res = _huff_tab14[c & 1]; 38 | c = c >> 1; 39 | } 40 | } else if ((res = _huff_tab11[res]) == '\x00') { 41 | res = _huff_tab12[c & 1]; 42 | c = c >> 1; 43 | } 44 | } else if ((res = _huff_tab9[res]) == '\x00') { 45 | res = _huff_tab10[c & 3]; 46 | c = c >> 2; 47 | } 48 | } else if (res == 1) { 49 | res = _huff_tab8[c & 3]; 50 | c = c >> 2; 51 | } else if (res == 2) { 52 | res = c & 3; 53 | c = c >> 2; 54 | if (res == 0) { 55 | res = _huff_tab7[c & 3]; 56 | c = c >> 2; 57 | } else if ((res = _huff_tab5[res]) == '\x00') { 58 | res = _huff_tab6[c & 1]; 59 | c = c >> 1; 60 | } 61 | } else if (res == 4) { 62 | res = _huff_tab4[c & 1]; 63 | c = c >> 1; 64 | } else if (res == 5) { 65 | res = _huff_tab3[c & 1]; 66 | c = c >> 1; 67 | } else if ((res = _huff_tab1[res]) == '\x00') { 68 | res = _huff_tab2[c & 1]; 69 | c = c >> 1; 70 | } 71 | 72 | -------------------------------------------------------------------------------- /scheme2c/scheme.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for intptr_t 4 | 5 | // 001 fixnum 6 | // 000 pointer 7 | // 010 bool 8 | // 100 char 9 | // 110 other 10 | 11 | // 1110 void 12 | // 1010 true 13 | // 0010 false 14 | 15 | typedef union Value_t* Value; 16 | 17 | #define INTERMEDIA_TYPE_MASK 0x00f00007L 18 | #define CLOSURE 0x00100000L 19 | #define CONS 0x00200000L 20 | #define VECTOR 0x00300000L 21 | #define ENV 0x00400000L 22 | #define SYMBOL 0x00500000L 23 | 24 | #define FORWARD_BIT 0x10000000L 25 | 26 | typedef intptr_t Tag; 27 | typedef void (*Lambda)() ; 28 | 29 | struct Closure { 30 | Tag t ; 31 | Lambda lam ; 32 | Value env ; 33 | }; 34 | 35 | struct Cons { 36 | Tag t; 37 | Value car; 38 | Value cdr; 39 | }; 40 | 41 | // 其实跟Vector一样的，但是Tag不一样 42 | struct Env { 43 | Tag t ; 44 | int size; 45 | Value *value; 46 | }; 47 | 48 | struct Vector { 49 | Tag t; 50 | int size; 51 | Value *value; 52 | }; 53 | 54 | struct Cell { 55 | Tag t ; 56 | Value addr ; 57 | }; 58 | 59 | union Value_t { 60 | Tag t ; 61 | struct Closure clo ; 62 | struct Vector vec; 63 | struct Env env ; 64 | struct Cons cons; 65 | }; 66 | 67 | extern Value ValueTrue; 68 | extern Value ValueFalse; 69 | 70 | Value InitClosure(struct Closure *addr, Lambda lam, Value env); 71 | Value MakeInt(int n); 72 | Value MakeBoolean(unsigned int b); 73 | Value InitVector(struct Vector *addr, int n, ...); 74 | Value InitEnv(struct Env *addr, int n, ...); 75 | Value VectorGet(Value v, int n); 76 | Value VectorRef(Value n, Value e); 77 | Value EnvRef(Value n, Value e); 78 | 79 | Value __sub(Value v1, Value v2); 80 | Value __product(Value v1, Value v2); 81 | Value ValueEqual(Value v1, Value v2); 82 | 83 | // EntryPoint是整个库的入口点。它的参数是整个计算结果的返回点 84 | void EntryPoint(Value); 85 | int CheckMinorGC(); 86 | void MinorGC(); 87 | void SaveCall(Lambda lam, int n, ...); 88 | 89 | // TopLevel是生成的代码入口点 90 | extern void TopLevel(Value); 91 | 92 | extern char *stackTop; 93 | extern char *stackBottom; -------------------------------------------------------------------------------- /0.01/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | enum object_type 5 | { 6 | OBJ_PAIR = 0, 7 | OBJ_NUMBER, 8 | OBJ_STRING, 9 | OBJ_ENV, 10 | OBJ_TYPE_MAX 11 | }; 12 | 13 | struct object_head 14 | { 15 | enum object_type type; 16 | char marked; 17 | }; 18 | 19 | typedef struct object_head* object_t; 20 | 21 | struct pair 22 | { 23 | struct object_head head; 24 | object_t car; 25 | object_t cdr; 26 | }; 27 | struct string 28 | { 29 | struct object_head head; 30 | unsigned int size; 31 | char data[1]; 32 | }; 33 | struct env 34 | { 35 | struct object_head head; 36 | struct env *parent; 37 | struct pair *binding; 38 | }; 39 | 40 | struct object_head scheme_null_object; 41 | struct object_head scheme_false_object; 42 | 43 | object_t scheme_null = &scheme_null_object; 44 | object_t scheme_false = &scheme_false_object; 45 | 46 | struct typeinfo 47 | { 48 | char *name; 49 | unsigned int size; 50 | object_t (*generator)(); 51 | }; 52 | 53 | struct typeinfo typeinfo_table[OBJ_TYPE_MAX]; 54 | 55 | #define type_name(o) (typeinfo_table[o->type].name) 56 | #define type_size(o) (typeinfo_table[o->type].size) 57 | 58 | struct env* make_env(struct env *p,struct pair *binding) 59 | { 60 | struct env* ret = malloc(sizeof(struct env)); 61 | ret->head.type = OBJ_ENV; 62 | ret->parent = p; 63 | ret->binding = binding; 64 | return ret; 65 | } 66 | 67 | struct pair* make_pair(object_t car,object_t cdr) 68 | { 69 | struct pair* ret = malloc(sizeof(struct env)); 70 | ret->head.type = OBJ_PAIR; 71 | ret->car = car; 72 | ret->cdr = cdr; 73 | return ret; 74 | } 75 | 76 | void init() 77 | { 78 | typeinfo_table[OBJ_PAIR].name = "pair"; 79 | typeinfo_table[OBJ_PAIR].size = sizeof(struct pair); 80 | typeinfo_table[OBJ_PAIR].generator = NULL; 81 | 82 | typeinfo_table[OBJ_ENV].name = "environment"; 83 | typeinfo_table[OBJ_ENV].size = sizeof(struct env); 84 | typeinfo_table[OBJ_ENV].generator = NULL; 85 | 86 | } 87 | 88 | int main() 89 | { 90 | object_t o; 91 | 92 | init(); 93 | o = make_env(scheme_null,scheme_null); 94 | printf("object->type: %s\n",type_name(o)); 95 | printf("object->type: %d\n",type_size(o)); 96 | return 0; 97 | } 98 | -------------------------------------------------------------------------------- /n6blisp/.svn/entries: -------------------------------------------------------------------------------- 1 | 10 2 | 3 | dir 4 | 19 5 | https://n6b.googlecode.com/svn/trunk/n6blisp 6 | https://n6b.googlecode.com/svn 7 | 8 | 9 | 10 | 2011-07-18T14:08:15.666202Z 11 | 19 12 | tiancaiamao@gmail.com 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 2ded9f86-9df0-11de-9cec-99053a980508 28 | 29 | mem.c 30 | file 31 | 32 | 33 | 34 | 35 | 2011-07-16T13:17:00.000000Z 36 | a87c6061bd7a313a9238eb9599a78ac3 37 | 2011-07-18T14:08:15.666202Z 38 | 19 39 | tiancaiamao@gmail.com 40 | has-props 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 1216 62 | 63 | type.c 64 | file 65 | 66 | 67 | 68 | 69 | 2011-07-16T14:22:58.000000Z 70 | e8d2a354368cd4c83b2839873ebc6d09 71 | 2011-07-18T14:08:15.666202Z 72 | 19 73 | tiancaiamao@gmail.com 74 | has-props 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 250 96 | 97 | mem.h 98 | file 99 | 100 | 101 | 102 | 103 | 2011-07-16T13:51:44.000000Z 104 | 3f3bf13f8e8480f7e786d2f1822fca2d 105 | 2011-07-18T14:08:15.666202Z 106 | 19 107 | tiancaiamao@gmail.com 108 | has-props 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 49 130 | 131 | gc.c 132 | file 133 | 134 | 135 | 136 | 137 | 2011-07-16T14:22:54.000000Z 138 | fdaf340bcb23849ea502be1b79a13ad4 139 | 2011-07-18T14:08:15.666202Z 140 | 19 141 | tiancaiamao@gmail.com 142 | has-props 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 918 164 | 165 | interpret.scm 166 | file 167 | 168 | 169 | 170 | 171 | 2011-07-11T06:58:04.000000Z 172 | 4aa16373ca307ee3066d555da2db3942 173 | 2011-07-18T14:08:15.666202Z 174 | 19 175 | tiancaiamao@gmail.com 176 | has-props 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 4082 198 | 199 | -------------------------------------------------------------------------------- /zen/parser.ss: -------------------------------------------------------------------------------- 1 | (define (find-env env v) 2 | (define (find e v i) 3 | (if (null? e) (+ 3 "find-env fail and panic") 4 | (if (eq? (car e) v) 5 | i 6 | (find (cdr e) v (+ i 1))))) 7 | (find env v 0)) 8 | 9 | (define (extend-env env v) 10 | (if (null? v) 11 | env 12 | (extend-env (cons (car v) env) (cdr v)))) 13 | 14 | (define (parse exp env) 15 | (if (pair? exp) 16 | (parse-sexp exp env) 17 | (parse-atom exp env))) 18 | 19 | (define (parse-atom v env) 20 | (cond 21 | ((boolean? v) (tuple Bool v)) 22 | ((integer? v) (tuple Int v)) 23 | ((string? v) (tuple String v)) 24 | ((symbol? v) 25 | (let ((find (find-env env v))) 26 | (if find (tuple Var find) (+ 3 "find env fail")))))) 27 | 28 | (define (parse-sexp exp env) 29 | (let ((hd (car exp)) 30 | (tl (cdr exp))) 31 | (cond 32 | ((eq? hd 'if) 33 | (tuple If (parse (car tl) env) 34 | (parse (cadr tl) env) 35 | (parse (caddr tl) env))) 36 | ((memq hd '(+ - * / =)) 37 | (tuple Prim hd (parse (car tl) env) (parse (cadr tl) env))) 38 | ((eq? hd 'load) 39 | (tuple Load (parse (car tl) env))) 40 | ((eq? hd 'lambda) 41 | (tuple Fun (length (car tl)) 42 | (let ((nenv (extend-env env (cadr exp)))) 43 | (map 44 | (lambda (x) (parse x nenv)) 45 | (cdr tl))))) 46 | ((eq? hd 'lambda1) 47 | (tuple Fun1 (length (car tl)) 48 | (let ((nenv (extend-env env (cadr exp)))) 49 | (map 50 | (lambda (x) (parse x nenv)) 51 | (cdr tl))))) 52 | ((eq? hd 'let) 53 | (let* ((args (map car (car tl))) 54 | (nenv (extend-env env args)) 55 | (header (map 56 | (lambda (x) 57 | (tuple Set (find-env nenv (car x)) 58 | (parse (cadr x) env))) 59 | (car tl))) 60 | (body (map (lambda (x) (parse x nenv)) (cdr tl)))) 61 | (tuple Let (length args) (append header body)))) 62 | ((eq? hd 'ccall) 63 | (tuple CCall (car tl) (map 64 | (lambda (x) (parse x env)) 65 | (cdr tl)))) 66 | (#t (tuple App (parse hd env) (map (lambda (x) (parse x env)) tl)))))) 67 | -------------------------------------------------------------------------------- /n6blisp/mem.c: -------------------------------------------------------------------------------- 1 | #include "mem.h" 2 | #include "gc.h" 3 | #include 4 | #include 5 | 6 | static struct chunk *mem = NULL; 7 | 8 | unsigned long align(unsigned long p) 9 | { 10 | unsigned align = sizeof(void*); 11 | if((p | (align -1)) != 0) 12 | { 13 | p = (p & ~(align-1)) + align; 14 | } 15 | return p; 16 | } 17 | 18 | void mem_exit_hook() 19 | { 20 | struct chunk *ck; 21 | while(mem != NULL) 22 | { 23 | ck = mem->next; 24 | free(mem); 25 | mem = ck; 26 | } 27 | } 28 | 29 | struct chunk* mem_get_chunk() 30 | { 31 | return mem; 32 | } 33 | 34 | static int mem_alloc_chunk() 35 | { 36 | struct chunk *ck; 37 | ck = malloc(4096); 38 | if(ck == NULL) 39 | return -1; 40 | ck->next = mem; 41 | mem = ck; 42 | ck->freelist = (struct freenode*)align((unsigned long)&ck->data); 43 | ck->freelist->next = NULL; 44 | ck->freelist->size = (char*)ck + 4096 - (char*)ck->freelist; 45 | return 0; 46 | } 47 | 48 | static void* mem_try_alloc(unsigned int size) 49 | { 50 | struct chunk *ck; 51 | struct freenode *p,*prev,*tmp; 52 | 53 | size = align(size); 54 | for(ck = mem; ck!=NULL; ck=ck->next) 55 | { 56 | 57 | p = ck->freelist; 58 | if(p == NULL) 59 | continue; 60 | if(p->next == NULL) 61 | { 62 | if(p->size >= size) 63 | { 64 | tmp = (struct freenode*)((char*)p + size); 65 | tmp->next = NULL; 66 | tmp->size = p->size - size; 67 | ck->freelist = tmp; 68 | return p; 69 | } 70 | else 71 | continue; 72 | } 73 | prev = p; 74 | p = p->next; 75 | while(p) 76 | { 77 | if(p->size >= size) 78 | { 79 | tmp = (struct freenode*)((char*)p + size); 80 | tmp->next = p->next; 81 | tmp->size = p->size - size; 82 | prev->next = tmp; 83 | return p; 84 | } 85 | prev = p; 86 | p = p->next; 87 | } 88 | } 89 | return NULL; 90 | } 91 | 92 | void* mem_alloc(unsigned int size) 93 | { 94 | void *ret; 95 | ret = mem_try_alloc(size); 96 | if(mem_alloc_chunk() != 0) 97 | { 98 | fprintf(stderr,"out of memory"); 99 | return NULL; 100 | } 101 | gc_needgc(); 102 | return mem_try_alloc(size); 103 | } 104 | 105 | #ifdef MEM_TEST 106 | 107 | int main() 108 | { 109 | atexit(mem_exit_hook); 110 | printf("test align: 13-> %d",align(13)); 111 | mem_alloc(13); 112 | return 0; 113 | } 114 | #endif 115 | -------------------------------------------------------------------------------- /reborn/opt/sexp-hufftabs.c: -------------------------------------------------------------------------------- 1 | /* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ 2 | 3 | char _huff_tab21[] = { 4 | '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', 5 | }; 6 | 7 | char _huff_tab19[] = { 8 | '\x01', 'j', '\x01', '\x00', 9 | }; 10 | 11 | char _huff_tab20[] = { 12 | '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', 13 | }; 14 | 15 | char _huff_tab18[] = { 16 | '2', ':', '6', 'B', '4', '@', '8', 'D', 17 | '3', ';', '7', 'C', '5', 'A', '9', 'E', 18 | }; 19 | 20 | char _huff_tab17[] = { 21 | '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', 22 | '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', 23 | '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', 24 | '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', 25 | }; 26 | 27 | char _huff_tab16[] = { 28 | 'V', '^', 'Z', '|', 'X', '`', '\\', '~', 29 | 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', 30 | }; 31 | 32 | char _huff_tab15[] = { 33 | 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', 34 | 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', 35 | }; 36 | 37 | char _huff_tab13[] = { 38 | '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', 39 | }; 40 | 41 | char _huff_tab14[] = { 42 | '*', 'z', 43 | }; 44 | 45 | char _huff_tab11[] = { 46 | '\x00', 'b', '\x00', 'x', 47 | }; 48 | 49 | char _huff_tab12[] = { 50 | '!', 'k', 51 | }; 52 | 53 | char _huff_tab9[] = { 54 | '\x00', 's', '\x00', 'l', 55 | }; 56 | 57 | char _huff_tab10[] = { 58 | 'y', 'w', '<', 'q', 59 | }; 60 | 61 | char _huff_tab8[] = { 62 | 'p', '?', 'g', 'u', 63 | }; 64 | 65 | char _huff_tab7[] = { 66 | 'f', '>', '=', 'v', 67 | }; 68 | 69 | char _huff_tab5[] = { 70 | '\x00', 'o', '\x00', 'd', 71 | }; 72 | 73 | char _huff_tab6[] = { 74 | 'h', 'm', 75 | }; 76 | 77 | char _huff_tab4[] = { 78 | 'c', 'i', 79 | }; 80 | 81 | char _huff_tab3[] = { 82 | 'n', '-', 83 | }; 84 | 85 | char _huff_tab1[] = { 86 | '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', 87 | }; 88 | 89 | char _huff_tab2[] = { 90 | 'e', 't', 91 | }; 92 | 93 | -------------------------------------------------------------------------------- /n6blisp/doc/如此优雅地定义一门语言: -------------------------------------------------------------------------------- 1 | 类型 2 | 这里说的类型不是指"语言的基本数据类型"，而是从语言实现角度讲的类型 3 | 最基本的类型包括：原子，S表达式，函数，特殊表 4 | 5 | 原子 6 | 一个原子就是一个符号，它可以是任何东西。 7 | 把一个值绑定到一个符号，绑定了值的符号就是变量。 8 | lisp语言中变量是没有类型的，变量的值是有类型的。 9 | 符号是可以动态绑定的，所以说原子可以是任何东西：可能是个数字，可能是个函数... 10 | 11 | pair和list 12 | 13 | 几个基本操作 14 | atom---判断给定的变量是否是个原子 15 | quote---返回变量的符号，而不是变量的值 16 | cons--构造一个(car . cdr)对 17 | car---返回一个pair的car 18 | cdr---返回一个pair的cdr 19 | eq---判断二个符号绑定的值是否是同一个 20 | cond---条件表达式 21 | 22 | S表达式 23 | S表达式要么是一个原子，要么是一个pair，要么是一个list 24 | 具体点，比如说 25 | A 这是一个原子，是S表达式 26 | (A . B)这是一个pair，是S表达式 27 | (A B C)这是一个list,是S表达式 28 | S表达式的存储形式: 29 | 如果是原子，就是存的原子的值。否则存的是链表形式 30 | S表达式的计算规则： 31 | 如果S表达式是原子,则直接返回这个原子的值. 32 | 否则S表达式是pair或list，将第一个当作函数名，其它都当作参数，执行这个函数 33 | 34 | lambda表达式 35 | lambda表达式是的形式是这样的: 36 | (lambda arg body) 37 | 其中arg部分是一个链表 body是一个S表达式 38 | 比如 39 | (lambda (x) x) 40 | (lambda (x y) (cons x y)) 41 | lambda表达式的语义是： 42 | 表达一个未命名的函数，即arg部分是形参,body是函数体 43 | 比如以下是函数调用((lambda (x y) (cons x y)) 3 4) 44 | 用3替换x 用4替换y 然后执行函数体部分并返回结果，也就是(cons 3 4) 45 | lambda特殊表的计算规则(函数定义的实现)： 46 | 将body部分，arg部分，加下定义时的环境env，组合成一个链表，返回链表指针 47 | 函数调用的实现： 48 | 将S表达式中的形参的符号，全用实参符号替换，将自由变量用env中的符号替换，然后计算 49 | 这个S表达式 50 | 51 | 函数--命名lambda表达式 52 | 如果给lambda表达式绑定到一个符号，这就是定义一个函数了 53 | (define func (lambda (x y) (cons x y))) 54 | define将func这个符号，绑定到了(lambda (x y) (cons x y))这个lambda表达式，func就成为了 55 | 一个函数。 56 | 调用(func 3 4)就等价于调用((lambda (x y) (cons x y)) 3 4) 57 | lisp是如此的优雅，仅用几个最基本的操作，组合这些操作和参数就成了S表达式 58 | 在S表达式的基础上定义了lambda表达式，由lambda表达式定义了函数，进而创建了一门语言！ 59 | 60 | eval解释器 61 | 定义一个eval函数，用于计算S表达式，这就成了lisp语言的解释器了 62 | 伪代码如下： 63 | eval(S表达式p) 64 | { 65 | 如果p是原子 66 | 如果p的类型是函数/特殊表 打印消息说这是一个函数 67 | 如果p的类型是数字 打印这个数字 68 | 如果p的类型是变量 打印这个变量对应的值 69 | 否则 70 | 如果car(p)是函数 71 | 分别eval(后面每个链表结点)作为参数 72 | 调用(car(p) 参数) 73 | 如果car(p)是特殊表 74 | 按特殊表的规则计算 75 | } 76 | 77 | 闭包 78 | 79 | 特殊表和宏 80 | 81 | 82 | 83 | 目标： 84 | 性能不是最优先考虑 85 | 简单性必须保证 86 | 能与C语言相互调用 87 | 垃圾回收 88 | 不仅实现解释器，还要实现编译器 89 | 编译成机器码？ 90 | 基于虚拟机？ 91 | 92 | 93 | 94 | 高级对象表示 95 | 垃圾回收 96 | 尾递归消除 97 | 编译技术 98 | 虚拟机 99 | 100 | Gary Knott's Interpreting lisp 单个c 943行 stdio string stdlib math setjmp 101 | Jim Mayfield's lisp lisp.c+lisp.h 173+578行 102 | Xlisp 103 | lisp500 104 | guile 105 | 106 | lisp语言实现的性能的主要影响因素： 107 | 类型表示系统 108 | 虚拟机模型 109 | 存储系统 110 | 111 | 内存回收算法: 112 | 1.引用记数法 113 | 2.标记清扫法 114 | 3.复制算法 115 | 116 | 标记整理算法 117 | 118 | 119 | 子系统： 120 | 分析器--词法分析 121 | 内存管理系统---要实现一个提供垃圾回收的内存分配器 122 | eval--解释器 123 | 编译系统 124 | -------------------------------------------------------------------------------- /eff.cora: -------------------------------------------------------------------------------- 1 | ;; blog link https://www.zenlife.tk/use-algebraic-effect.md 2 | 3 | (defun make-yield-next (v k) 4 | ['Next v k]) 5 | 6 | ;; input: (yield v e1 e2) 7 | ;; output: ['Next e1 (lambda (v) e2)] 8 | (defmacro yield (exp) 9 | (let v (cadr exp) 10 | e1 (caddr exp) 11 | e2 (cdddr exp) 12 | ['make-yield-next e1 ['lambda [v] . e2]])) 13 | 14 | (defun eff (label val) 15 | ['Eff label val]) 16 | 17 | (defun handler (vh effhs th) 18 | (handle-yield-result vh effhs (th ()))) 19 | 20 | (func handle-yield-result 21 | vh handlers ['Next resend remain] => (handle vh handlers resend remain) 22 | vh handlers res => (vh res)) 23 | 24 | (func handle 25 | vh handlers ['Eff e v] remain => (let effh (find-effect-handler e handlers) 26 | k (lambda (arg) 27 | (handle-yield-result vh handlers (remain arg))) 28 | (if (null? effh) 29 | (yield res ['Resend ['Eff e v] k] 30 | res) 31 | (effh v k))) 32 | vh handlers ['Resend ['Eff e v] k1] k => (let effh (find-effect-handler e handlers) 33 | (if (null? effh) 34 | (yield res ['Resend ['Eff e v] (rehandle k handlers k1)] 35 | res) 36 | (effh v (rehandle k handlers k1))))) 37 | 38 | (defun rehandle (vh handlers k arg) 39 | (handler vh handlers (lambda (_) 40 | (k arg)))) 41 | 42 | (func find-effect-handler 43 | e [] => () 44 | e [e1 handle . more] => handle where (= e e1) 45 | e [_ _ . more] => (find-effect-handler e more)) 46 | 47 | 48 | ;; input: (with-handler [eff handler] thunk) 49 | ;; output: (handler (lambda (x) x) [eff handler] (lambda (_) thunk)) 50 | (defmacro with-handler (exp) 51 | (let effhs (cadr exp) 52 | thunk (cddr exp) 53 | ['handler '(lambda (x) x) effhs ['lambda ['_] . thunk]])) 54 | 55 | ;; (defun effh1 (v k) 56 | ;; (k v)) 57 | 58 | ;; (defun effh2 (v k) 59 | ;; (k v)) 60 | 61 | ;; (defun effh3 (v k) 62 | ;; (k v)) 63 | 64 | ;; (handler (lambda (x) x) 65 | ;; ['C3 effh3] 66 | ;; (lambda (_) 67 | ;; (handler (lambda (x) x) 68 | ;; ['C2 effh2] 69 | ;; (lambda (_) 70 | ;; (handler (lambda (x) x) 71 | ;; ['C1 effh1] 72 | ;; (lambda (_) 73 | ;; (yield a (eff 'C3 10) 74 | ;; (yield b (eff 'C3 13) 75 | ;; (yield c (eff 'C3 17) 76 | ;; (+ (+ a b) c)))))))))) 77 | 78 | ;; (with-handler ['C3 effh3] 79 | ;; (with-handler ['C2 effh2 'C1 effh1] 80 | ;; (yield a (eff 'C3 10) 81 | ;; (yield b (eff 'C3 13) 82 | ;; (yield c (eff 'C3 17) 83 | ;; (+ (+ a b) c)))))) 84 | -------------------------------------------------------------------------------- /nanopass/main.ss: -------------------------------------------------------------------------------- 1 | 2 | (eval-when (compile load eval) 3 | (optimize-level 2) 4 | (case-sensitive #t) 5 | ) 6 | 7 | (load "match.ss") 8 | (load "helpers.ss") 9 | (load "fmts.pretty") ; inform pretty-print about new forms 10 | (load "driver.ss") 11 | 12 | (load "a15.ss") 13 | (load "a15-wrapper.ss") ; defines syntactic forms and procedures 14 | ; needed to output of each pass 15 | 16 | 17 | #!eof 18 | 19 | (compiler-passes '( 20 | parse-scheme 21 | convert-complex-datum 22 | uncover-assigned 23 | #| 24 | purify-letrec 25 | convert-assignments 26 | ;optimize-direct-call ;;; optimization 27 | remove-anonymous-lambda 28 | sanitize-binding-forms 29 | uncover-free 30 | convert-closures 31 | ;optimize-known-call ;;; optimization 32 | ;optimize-self-reference ;;; optimization 33 | introduce-procedure-primitives 34 | lift-letrec 35 | normalize-context 36 | specify-representation 37 | uncover-locals 38 | remove-let 39 | verify-uil 40 | remove-complex-opera* 41 | flatten-set! 42 | impose-calling-conventions 43 | uncover-frame-conflict 44 | pre-assign-frame 45 | assign-new-frame 46 | (iterate 47 | finalize-frame-locations 48 | select-instructions 49 | uncover-register-conflict 50 | assign-registers 51 | (break when everybody-home?) 52 | assign-frame) 53 | discard-call-live 54 | finalize-locations 55 | expose-frame-var 56 | expose-basic-blocks 57 | flatten-program 58 | generate-x86-64 59 | |# 60 | )) 61 | 62 | ;; (load "tests15.ss") 63 | 64 | ;; (tracer '(parse-scheme)) 65 | 66 | #| 67 | (test-one '(let ([f (lambda (y) 68 | (lambda (p) 69 | (cons y (p y))))]) 70 | (letrec ([g (lambda (n) 71 | (if (= n 0) 72 | '() 73 | ((f (- n 1)) g)))]) 74 | (g 6)))) 75 | |# 76 | -------------------------------------------------------------------------------- /free_monad.cora: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; (defun return (val) 4 | ;; (lambda (state) 5 | ;; [state . value])) 6 | 7 | 8 | ;; (defun bind (m f) 9 | ;; (lambda (state) 10 | ;; (let ret (m state) 11 | ;; (let state1 (car ret) 12 | ;; val (cdr ret) 13 | ;; ((f val) state1))))) 14 | 15 | ;; (defun get () 16 | ;; (lambda (state) 17 | ;; [state . state])) 18 | 19 | ;; (defun put (state) 20 | ;; (lambda (_) 21 | ;; [state . ()])) 22 | 23 | ;; (defun run-state (state m) 24 | ;; (m state)) 25 | 26 | 27 | 28 | 29 | 30 | ;; (defun pure (x) 31 | ;; ['pure x]) 32 | 33 | ;; (defun impure (f) 34 | ;; ['impure v]) 35 | 36 | ;; (defun result (v) 37 | ;; (pure v)) 38 | 39 | ;; (func fmap 40 | ;; f ['pure x] => ['pure (f x)] 41 | ;; f ['impure m] => ['impure (fmap (fmap f) m)]) 42 | 43 | ;; (func bind 44 | ;; ['pure x] k => ['pure x] 45 | ;; ['impure fa] k => (impure (fmap (lambda (m) (bind m k)) 46 | ;; fa))) 47 | 48 | ;; (defun eta (toy) 49 | ;; (impure ((fmap (lambda (c) (pure c))) toy))) 50 | 51 | 52 | ;; (defun output (c n) 53 | ;; [['output c] n]) 54 | 55 | ;; (defun bell (n) 56 | ;; [['bell] n]) 57 | 58 | ;; (defun done () 59 | ;; [['done] ()]) 60 | k 61 | 62 | 63 | 64 | 65 | (func catch 66 | ['Fix x] f => ['Fix (fmap (flip catch f) x)] 67 | ['Throw e] f => (f e)) 68 | 69 | 70 | 71 | (func fmap 72 | f ['Output x next] => ['Output x (f next)] 73 | f ['Bell next] => ['Bell (f next)] 74 | f ['Done] => ['Done]) 75 | 76 | 77 | 78 | 79 | 80 | (try ['Fix ['Output 'A ['Throw 'IncompleteException]]]) 81 | (catch ['Fix ['Bell ['Fix Done]]]) 82 | 83 | 84 | data Free f r = Free (f (Free f r)) | Pure r 85 | 86 | data FixE f e = Fix (f (FixE f e)) | Throw e 87 | 88 | 89 | (defun bind 90 | ['Free x] f => ['Free (fmap (lambda (m) (bind m f)) x)] 91 | ['Pure r] f => (f r)) 92 | 93 | (defun output (x) 94 | ['Free ['Output x ['Pure ()]]]) 95 | 96 | (defun bell () 97 | ['Free ['Bell ['Pure ()]]]) 98 | 99 | (defun done () 100 | ['Free ['Done]]) 101 | 102 | ;; (defun liftF (cmd) 103 | ;; ['Free (fmap (lambda (x) ['Pure x]) cmd])]) 104 | 105 | 106 | (func interp 107 | ['Free ['Output b next]] => ?? (interp next) 108 | ['Free ['Bell next]] => ?? (interp next) 109 | ['Free ['Done] => ...jjj 110 | ['Pure r] => (error "xxx")) 111 | 112 | 113 | do 114 | (output 'A) 115 | (bell) 116 | (done) 117 | 118 | 119 | (func handle 120 | ['Free ['Output x next]] => (print x) (show next) 121 | ['Free ['Bell next]] => (print) (show next) 122 | ['Free ['Done]] => (print) 123 | ['Pure x] => 124 | 125 | 126 | -------------------------------------------------------------------------------- /scheme2c/fact.c: -------------------------------------------------------------------------------- 1 | #include "stdio.h" 2 | #include "stdlib.h" 3 | #include "scheme.h" 4 | #include "assert.h" 5 | 6 | void lambda__tmp8586(Value env8585, Value fact, Value k8578); 7 | void lambda__tmp8589(Value env8584, Value rv$8579); 8 | void lambda__tmp8587(Value env8583, Value n, Value k8580); 9 | void lambda__tmp8588(Value env8582, Value rv$8581); 10 | 11 | void lambda__tmp8586(Value env8585, Value fact, Value k8578) { 12 | if (CheckMinorGC()) { 13 | SaveCall(lambda__tmp8586, 3, env8585, fact, k8578); 14 | MinorGC(); 15 | } 16 | __set(&fact, ((struct Closure *)closure)->lam(((struct Closure *)closure)->env, lambda__tmp8587, env - make(MakeInt(1), fact)), 17 | ((struct Closure *)closure)->lam(((struct Closure *)closure)->env, lambda__tmp8589, env - make(MakeInt(2), fact, k8578))); 18 | } 19 | 20 | void lambda__tmp8589(Value env8584, Value rv$8579) { 21 | if (CheckMinorGC()) { 22 | SaveCall(lambda__tmp8589, 2, env8584, rv$8579); 23 | MinorGC(); 24 | } 25 | ((struct Closure *)EnvRef(MakeInt(0), env8584))->lam(((struct Closure *)EnvRef(MakeInt(0), env8584))->env, MakeInt(5), EnvRef(MakeInt(1), env8584)); 26 | } 27 | 28 | void lambda__tmp8587(Value env8583, Value n, Value k8580) { 29 | if (CheckMinorGC()) { 30 | SaveCall(lambda__tmp8587, 3, env8583, n, k8580); 31 | MinorGC(); 32 | } 33 | if (ValueEqual(n, MakeInt(0)) == ValueTrue) { 34 | ((struct Closure *)k8580)->lam(((struct Closure *)k8580)->env, MakeInt(1)); 35 | } else { 36 | ((struct Closure *)EnvRef(MakeInt(0), env8583)) 37 | ->lam(((struct Closure *)EnvRef(MakeInt(0), env8583))->env, __sub(n, MakeInt(1)), 38 | ((struct Closure *)closure)->lam(((struct Closure *)closure)->env, lambda__tmp8588, env - make(MakeInt(2), k8580, n))); 39 | } 40 | } 41 | 42 | void lambda__tmp8588(Value env8582, Value rv$8581) { 43 | if (CheckMinorGC()) { 44 | SaveCall(lambda__tmp8588, 2, env8582, rv$8581); 45 | MinorGC(); 46 | } 47 | ((struct Closure *)EnvRef(MakeInt(0), env8582))->lam(((struct Closure *)EnvRef(MakeInt(0), env8582))->env, __product(EnvRef(MakeInt(1), env8582), rv$8581)); 48 | } 49 | 50 | void TopLevel(Value cont) { 51 | ((struct Closure *)((struct Closure *)closure)->lam(((struct Closure *)closure)->env, lambda__tmp8586, env - make(MakeInt(0)))) 52 | ->lam(((struct Closure *)((struct Closure *)closure)->lam(((struct Closure *)closure)->env, lambda__tmp8586, env - make(MakeInt(0))))->env, cont); 53 | } 54 | 55 | void lambda__c0(Value e, Value v) { printf("return = %ld\n", (long)v >> 1); } 56 | 57 | int main() { 58 | // c0的初始化要在EntryPoint前面 59 | struct Closure tmp2; 60 | InitClosure(&tmp2, lambda__c0, NULL); 61 | 62 | EntryPoint((Value)&tmp2); 63 | 64 | return 0; 65 | } -------------------------------------------------------------------------------- /n6blisp/gc.c: -------------------------------------------------------------------------------- 1 | #include "mem.h" 2 | #include "type.h" 3 | #include "env.h" 4 | #include 5 | #include 6 | 7 | static int needgc = 0; 8 | void gc_needgc() 9 | { 10 | needgc = 1; 11 | } 12 | static void mark(OBJ obj) 13 | { 14 | unsigned i; 15 | if(obj_markedp(obj)) 16 | return; 17 | if(obj_pointerp(obj)) 18 | obj_mark(obj); 19 | if(obj_pairp(obj)) 20 | { 21 | mark(car(obj)); 22 | mark(cdr(obj)); 23 | } 24 | else if(obj_vectorp(obj)) 25 | { 26 | for(i=0; inext) 46 | { 47 | ck->freelist = NULL; 48 | base = (OBJ)align((unsigned long)&ck->data); 49 | while((char*)base < (char*)ck+4096) 50 | { 51 | if(obj_markedp(base)) 52 | { 53 | if(begin == 1) 54 | { 55 | begin = 0; 56 | tmp->size = (char*)base - (char*)tmp; 57 | tmp->next = ck->freelist; 58 | ck->freelist = tmp; 59 | } 60 | obj_unmark(base); 61 | switch(base->tag) 62 | { 63 | case OBJ_FLONUM: 64 | base = (OBJ)align((unsigned long)((char*)base+sizeof(double))); 65 | break; 66 | case OBJ_PAIR: 67 | base = (OBJ)align((unsigned long)((char*)base+obj_sizeof(pair))); 68 | case OBJ_CORE: 69 | base = (OBJ)align((unsigned long)((char*)base+obj_sizeof(core))); 70 | break; 71 | case OBJ_AST_DEFINE: 72 | base = (OBJ)align((unsigned long)((char*)base+obj_sizeof(define))); 73 | break; 74 | case OBJ_VECTOR: 75 | base = (OBJ)align((unsigned long)((char*)base + offsetof(struct object,value) + sizeof(unsigned long) + obj_vector_length(base)*sizeof(OBJ))); 76 | break; 77 | case OBJ_STRING: 78 | base = (OBJ)align((unsigned long)((char*)base+offsetof(struct object,value) + sizeof(unsigned) + obj_string_length(base) + 1)); 79 | break; 80 | case OBJ_SYMBOL: 81 | base = (OBJ)align((unsigned long)((char*)base+offsetof(struct object,value) + sizeof(unsigned) + obj_symbol_length(base) + 1)); 82 | break; 83 | default: 84 | printf("gc sweep error unknown type!\n"); 85 | } 86 | } 87 | else 88 | { 89 | if(begin == 0) 90 | { 91 | begin = 1; 92 | tmp = (struct freenode*)base; 93 | } 94 | base++; 95 | } 96 | } 97 | } 98 | } 99 | 100 | void gc(OBJ env) 101 | { 102 | if(needgc) 103 | { 104 | needgc = 0; 105 | mark(env); 106 | sweep(); 107 | } 108 | } 109 | 110 | 111 | #ifdef GC_TEST 112 | 113 | int main() 114 | { 115 | OBJ a,b,c; 116 | 117 | a = obj_make_flonum(10.34); 118 | 119 | b = obj_make_integer(33); 120 | c = cons(a,b); 121 | 122 | return 0; 123 | } 124 | #endif 125 | -------------------------------------------------------------------------------- /scheme2c/cps-convert.scm: -------------------------------------------------------------------------------- 1 | (define (prim? x) (memq x '(+ - * / = or and void set!))) 2 | (define (trivial? x) (or (number? x) (symbol? x) (string? x) (boolean? x))) 3 | (define (lambda? x) (and (pair? x) (eq? (car x) 'lambda))) 4 | (define (void) (begin)) 5 | 6 | ;; M变换，处理trivial和lambda表达式 7 | (define M 8 | (lambda (exp) 9 | (match exp 10 | [(? trivial?) exp] 11 | [('lambda (x ...) e ...) 12 | (let ((k$ (gensym 'k))) 13 | `(lambda (,@x ,k$) 14 | ,(T-c (if (cdr e) 15 | (cons 'begin e) 16 | e) 17 | k$)))]))) 18 | 19 | ;; sexp x label => sexp 20 | ;; set!不能实现为prim?，因为prim?在begin表达式中会被丢弃。而set!是有副作用的，不能丢弃。 21 | (define T-c 22 | (lambda (exp c) 23 | (match exp 24 | [(? trivial?) `(,c ,(M exp))] 25 | [('lambda _ ...) `(,c ,(M exp))] 26 | [`(begin ,e) (T-c e c)] 27 | [('begin e es ...) 28 | (T-k e (lambda (_) 29 | (T-c `(begin ,@es) c)))] 30 | [`(set! ,var ,val) 31 | (T-k val 32 | (lambda (v) 33 | `(set!/k ,var ,v ,c)))] 34 | [`(define ,var ,val) 35 | (T-k exp (lambda (x) x))] 36 | [`(if ,test ,then ,else) 37 | (T-k exp 38 | (lambda (v) 39 | `(,c ,v)))] 40 | [(f es ...) 41 | (if (prim? f) 42 | (T*-k es 43 | (lambda (es$) 44 | `(,c (,f ,@es$)))) 45 | (T-k f 46 | (lambda (f$) 47 | (T*-k es 48 | (lambda (es$) 49 | `(,f$ ,@es$ ,c))))))]))) 50 | 51 | ;; sexps x (list => sexp) => sexp 52 | ;; 参数k是接受一个list，返回一个sexp 53 | (define T*-k 54 | (lambda (exps k) 55 | (if (null? exps) 56 | (k '()) 57 | (T-k (car exps) 58 | (lambda (first) 59 | (T*-k (cdr exps) 60 | (lambda (remain) 61 | (k (cons first remain))))))))) 62 | 63 | ;; sexp x (sexp => sexp) => sexp 64 | (define T-k 65 | (lambda (exp k) 66 | (match exp 67 | [(? trivial?) (k (M exp))] 68 | [('lambda _ ...) (k (M exp))] 69 | [`(begin ,e) 70 | (T-k e k)] 71 | [('begin e es ...) 72 | (T-k e (lambda (_) 73 | (T-k `(begin ,@es) k)))] 74 | [`(set! ,var ,val) 75 | (let* ((rv (gensym 'rv$)) 76 | (cont `(lambda (,rv) ,(k rv)))) 77 | (T-c exp cont))] 78 | [`(if ,test ,then ,else) 79 | (T-k test 80 | (lambda (test$) 81 | `(if ,test$ 82 | ,(T-k then k) 83 | ,(T-k else k))))] 84 | [`(define ,var ,val) 85 | `(define ,var ,(T-k val k))] 86 | [(f es ...) 87 | (if (prim? f) 88 | (T*-k es 89 | (lambda (es$) 90 | (k `(,f ,@es$)))) 91 | (let* ((rv (gensym 'rv$)) 92 | (cont `(lambda (,rv) ,(k rv)))) 93 | (T-c exp cont)))]))) 94 | 95 | 96 | ;;;;;;;;;;;;;test;;;;;;; 97 | (define halt (lambda (x) x)) 98 | (define fact 99 | (lambda (n k5140) 100 | (if (= n 0) 101 | (k5140 1) 102 | (fact (- n 1) 103 | (lambda (rv$5141) 104 | (k5140 (* n rv$5141))))))) 105 | ; (fact 5 halt) => 125 106 | 107 | (define-syntax set!/k 108 | (syntax-rules () 109 | ((_ var val cont) 110 | (cont (set! var val))))) 111 | -------------------------------------------------------------------------------- /sandbox/desugar.scm: -------------------------------------------------------------------------------- 1 | (define my-macros '()) 2 | 3 | (define (desugar exp) 4 | (cond 5 | ((number? exp) exp) 6 | ((symbol? exp) exp) 7 | ((string? exp) exp) 8 | ((boolean? exp) exp) 9 | (else 10 | (if (symbol? (car exp)) 11 | (case (car exp) 12 | [(if) `(if ,(desugar (cadr exp)) 13 | ,(desugar (caddr exp)) 14 | ,(desugar (cadddr exp)))] 15 | [(set!) `(set! ,(cadr exp) ,(desugar (caddr exp)))] 16 | [(begin) `(begin ,@(map desugar (cdr exp)))] 17 | [(lambda) `(lambda ,(cadr exp) ,@(map desugar (cddr exp)))] 18 | (else 19 | (let ([a (assq (car exp) my-macros)]) 20 | (if a 21 | ((cdr a) exp desugar) 22 | exp)))) 23 | (map desugar exp))))) 24 | 25 | (define (desugar-letrec exp desugar) 26 | (let ([vars (map car (cadr exp))] 27 | [vals (map desugar (map cadr (cadr exp)))] 28 | [body (map desugar (cddr exp))]) 29 | (let ([sets (map (lambda (k v) `(set! ,k ,v)) vars vals)]) 30 | `(let ,(map (lambda (x) (cons x '((##sandbox#void)))) vars) 31 | ,@(append sets body))))) 32 | 33 | (define (desugar-cond exp desugar) 34 | (let ([tests (cdr exp)]) 35 | (if (null? tests) 36 | '(##sandbox#void) 37 | (let ([first (car tests)] 38 | [rem (cdr tests)]) 39 | (if (eq? (car first) 'else) 40 | (desugar (cadr first)) 41 | (let ([rem (cons 'cond rem)] 42 | [test (desugar (car first))] 43 | [succ (desugar (cadr first))]) 44 | `(if ,test 45 | ,succ 46 | ,(desugar-cond rem desugar)))))))) 47 | 48 | (define (desugar-define exp desugar) 49 | (let ([head (cadr exp)] 50 | [body (cddr exp)]) 51 | (if (pair? head) 52 | (let* ([body1 `(lambda ,(cdr head) ,@body)]) 53 | `(define ,(car head) ,(desugar body1)) ) 54 | `(define ,head ,(desugar (car body)))))) 55 | 56 | (define (desugar-and exp desugar) 57 | (if (null? (cdr exp)) 58 | #t 59 | (let ([rbody (cddr exp)] 60 | [hbody (cadr exp)]) 61 | (if (eq? rbody '()) 62 | (desugar hbody) 63 | `(if ,(desugar hbody) 64 | ,(desugar-and `(and ,@rbody) desugar) 65 | #f))))) 66 | 67 | (define (desugar-or exp desugar) 68 | (if (null? (cdr exp)) 69 | #f 70 | (let ([hbody (cadr exp)] 71 | [rbody (cddr exp)]) 72 | (if (eq? rbody '()) 73 | (desugar hbody) 74 | (let ((tmp (gensym))) 75 | `(let ([,tmp ,(desugar hbody)]) 76 | (if ,tmp 77 | ,tmp 78 | ,(desugar-or `(or ,@rbody) desugar)))))))) 79 | 80 | (define (desugar-let* exp desugar) 81 | (let ([bindings (cadr exp)] 82 | [body (cddr exp)]) 83 | (let expand ((bs bindings)) 84 | (if (eq? bs '()) 85 | (cons 'begin (map desugar body)) 86 | `(let (,(car bs)) 87 | ,(expand (cdr bs))))))) 88 | 89 | (set! my-macros (cons (cons 'let* desugar-let*) my-macros)) 90 | (set! my-macros (cons (cons 'letrec desugar-letrec) my-macros)) 91 | (set! my-macros (cons (cons 'cond desugar-cond) my-macros)) 92 | (set! my-macros (cons (cons 'define desugar-define) my-macros)) 93 | (set! my-macros (cons (cons 'and desugar-and) my-macros)) 94 | (set! my-macros (cons (cons 'or desugar-or) my-macros)) 95 | -------------------------------------------------------------------------------- /interpret.scm: -------------------------------------------------------------------------------- 1 | (define (atom? o) 2 | (not (pair? o))) 3 | (define (evaluate e env cont) 4 | (if (atom? e) 5 | (if (symbol? e) 6 | (evaluate-variable e env cont) 7 | (cont e)) 8 | (case (car e) 9 | ((define) (evaluate-define (cadr e) (caddr e) env cont)) 10 | ((quote) (evaluate-quote (cadr e) env cont)) 11 | ((if) (evaluate-if (cadr e) (caddr e) (cadddr e) env cont)) 12 | ((begin) (evaluate-begin (cdr e) env cont)) 13 | ((set!) (evaluate-set! (cadr e) (caddr e) env cont)) 14 | ((lambda) (evaluate-lambda (cadr e) (cddr e) env cont)) 15 | (else (evaluate-application (car e) (cdr e) env cont))))) 16 | (define (evaluate-variable name env cont) 17 | (cont (let ((find (lookup-env-cell env name))) 18 | (if find 19 | (cdr find) 20 | (error "unbound variable in environment"))))) 21 | (define (evaluate-quote e env cont) 22 | (cont e)) 23 | (define (lookup-env-cell env name) 24 | (if (pair? env) 25 | (let ((parent (car env)) 26 | (binding (cdr env))) 27 | (or (assv name binding) (lookup-env-cell parent name))) 28 | #f)) 29 | (define (evaluate-if test et ef env cont) 30 | (evaluate test env 31 | (lambda (v) 32 | (evaluate (if v et ef) env cont)))) 33 | (define (evaluate-begin e* env cont) 34 | (if (pair? (cdr e*)) 35 | (evaluate (car e*) env 36 | (lambda (ignore) 37 | (evaluate-begin (cdr e*) env cont))) 38 | (evaluate (car e*) env cont))) 39 | (define (evaluate-set! name value env cont) 40 | (evaluate value env 41 | (lambda (v) 42 | (let ((env-cell (lookup-env-cell env name))) 43 | (if env-cell 44 | (cont (set-cdr! env-cell v)) 45 | (error "can't set unbound variable")))))) 46 | (define (evaluate-define name value env cont) 47 | (evaluate value env 48 | (lambda (v) 49 | (if (pair? env) 50 | (let* ((binding (cdr env)) 51 | (find (assv name binding))) 52 | (if find 53 | (cont (set-cdr! find value)) 54 | (cont (set-cdr! env (cons (cons name value) binding))))) 55 | (error "can't in null-env"))))) 56 | 57 | (define (extend-env n* v* env) 58 | (let ((binding (map cons n* v*))) 59 | (cons env binding))) 60 | (define (evaluate-lambda n* e* env cont) 61 | (cont 62 | (lambda (v* runtime-cont) 63 | (let ((new-env (extend-env n* v* env))) 64 | (runtime-cont (evaluate-begin e* new-env runtime-cont)))))) 65 | (define (evaluate-application f e* env cont) 66 | (define (evaluate-argument e* env cont) 67 | (if (pair? e*) 68 | (evaluate (car e*) env 69 | (lambda (v) 70 | (evaluate-argument (cdr e*) env 71 | (lambda (v*) 72 | (cont (cons v v*)) ) ) ) ) 73 | (cont '()) ) ) 74 | (evaluate-argument e* env 75 | (lambda (v*) 76 | (f v* cont)))) 77 | 78 | 79 | (define global-env (cons '() '())) 80 | (define toplevel-cont (lambda (v) v)) 81 | 82 | (define-syntax define-primitive 83 | (syntax-rules () 84 | ((_ name primitive arity) 85 | (evaluate-define 'name 86 | (lambda (v* cont) 87 | (if (= arity (length v*)) 88 | (cont (apply primitive v*)) 89 | (error "incorrect arity"))) 90 | global-env toplevel-cont)))) 91 | 92 | (define-primitive cons cons 2) 93 | (define-primitive + + 2) 94 | 95 | (define (interpret) 96 | (write (evaluate (read) global-env toplevel-cont)) 97 | (interpret)) -------------------------------------------------------------------------------- /re/reader.go: -------------------------------------------------------------------------------- 1 | package re 2 | 3 | import ( 4 | "bufio" 5 | "io" 6 | "strconv" 7 | "unicode" 8 | ) 9 | 10 | type SexpReader struct { 11 | reader *bufio.Reader 12 | buf []rune 13 | // 'extended' reader is used by cora, which handles reader macro ' and [, 14 | // and expect ; as comment 15 | extended bool 16 | } 17 | 18 | func NewSexpReader(r io.Reader) *SexpReader { 19 | return &SexpReader{ 20 | reader: bufio.NewReader(r), 21 | } 22 | } 23 | 24 | func (r *SexpReader) Read() (Obj, error) { 25 | b, err := peekFirstRune(r.reader) 26 | if err != nil { 27 | return Nil, err 28 | } 29 | 30 | switch b { 31 | case rune(';'): 32 | b, _, err = r.reader.ReadRune() 33 | if err != nil { 34 | return Nil, err 35 | } 36 | for b != '\n' { 37 | b, _, err = r.reader.ReadRune() 38 | if err != nil { 39 | return Nil, err 40 | } 41 | } 42 | return r.Read() 43 | case rune('\''): 44 | return r.readQuoteMacro() 45 | case rune('['): 46 | return r.readListMacro() 47 | case rune('('): 48 | return r.readSexp() 49 | case rune('"'): 50 | return r.readString() 51 | } 52 | 53 | r.resetBuf() 54 | r.appendBuf(b) 55 | b, _, err = r.reader.ReadRune() 56 | for err == nil { 57 | if r.notSymbolChar(b) { 58 | r.reader.UnreadRune() 59 | break 60 | } 61 | r.appendBuf(b) 62 | b, _, err = r.reader.ReadRune() 63 | } 64 | 65 | return tokenToObj(string(r.buf)), err 66 | } 67 | 68 | func (r *SexpReader) readString() (Obj, error) { 69 | r.resetBuf() 70 | b, _, err := r.reader.ReadRune() 71 | for err == nil && b != rune('"') { 72 | r.appendBuf(b) 73 | b, _, err = r.reader.ReadRune() 74 | } 75 | return String(r.buf), err 76 | } 77 | 78 | func (r *SexpReader) readSexp() (Obj, error) { 79 | ret := Nil 80 | b, err := peekFirstRune(r.reader) 81 | for err == nil && b != ')' { 82 | var obj Obj 83 | r.reader.UnreadRune() 84 | obj, err = r.Read() 85 | if err == nil { 86 | ret = cons(obj, ret) 87 | b, err = peekFirstRune(r.reader) 88 | } 89 | } 90 | return reverse(ret), err 91 | } 92 | 93 | func (r *SexpReader) readQuoteMacro() (Obj, error) { 94 | obj, err := r.Read() 95 | if err != nil { 96 | return obj, err 97 | } 98 | return cons(symQuote, cons(obj, Nil)), nil 99 | } 100 | 101 | func (r *SexpReader) readListMacro() (Obj, error) { 102 | hd := MakeSymbol("list") 103 | tmp := Nil 104 | b, err := peekFirstRune(r.reader) 105 | for err == nil && b != ']' { 106 | if b == '.' { 107 | hd = MakeSymbol("list-rest") 108 | } else { 109 | r.reader.UnreadRune() 110 | } 111 | var obj Obj 112 | obj, err = r.Read() 113 | if err == nil { 114 | tmp = cons(obj, tmp) 115 | b, err = peekFirstRune(r.reader) 116 | } 117 | } 118 | return cons(hd, reverse(tmp)), nil 119 | } 120 | 121 | func (r *SexpReader) resetBuf() { 122 | r.buf = r.buf[:0] 123 | } 124 | 125 | func (r *SexpReader) appendBuf(b rune) { 126 | r.buf = append(r.buf, b) 127 | } 128 | 129 | func peekFirstRune(r *bufio.Reader) (rune, error) { 130 | b, _, err := r.ReadRune() 131 | for err == nil && unicode.IsSpace(b) { 132 | b, _, err = r.ReadRune() 133 | } 134 | return b, err 135 | } 136 | 137 | func (r *SexpReader) notSymbolChar(c rune) bool { 138 | if unicode.IsSpace(c) { 139 | return true 140 | } 141 | switch c { 142 | case '(', '"', ')': 143 | return true 144 | case '[', ']': 145 | return true 146 | } 147 | return false 148 | } 149 | 150 | func tokenToObj(str string) Obj { 151 | switch str { 152 | case "true": 153 | return True 154 | case "false": 155 | return False 156 | } 157 | if v, err := strconv.ParseFloat(str, 64); err == nil { 158 | return MakeNumber(v) 159 | } 160 | return MakeSymbol(str) 161 | } 162 | -------------------------------------------------------------------------------- /zen/compiler.ss: -------------------------------------------------------------------------------- 1 | (define (op->inst op) 2 | (cdr (assq op `((+ . ,(tuple IPlus)) 3 | (- . ,(tuple ISub)) 4 | (* . ,(tuple IMul)) 5 | (/ . ,(tuple IDiv)) 6 | (= . ,(tuple IEqual)))))) 7 | 8 | (define (compile exp code) 9 | (match-tuple exp 10 | ((Int v) (cons (tuple IConst v) code)) 11 | ((Bool v) (cons (tuple IBool v) code)) 12 | ((String s) (cons (tuple IString s) code)) 13 | ((Load s) (compile s (cons (tuple ILoad) code))) 14 | ((Var n) (cons (tuple IAccess n) code)) 15 | ((Fun n ts) 16 | (cons (tuple IClosure (compile-tail exp )) code)) 17 | ;; ((Fun1 n ts) 18 | ;; (cons (tuple IClosure (compile-tail exp n)) code)) 19 | ;; ((Let n ts) 20 | ;; (cons (tuple ILet n) 21 | ;; (fold-left 22 | ;; (lambda (o x) 23 | ;; (compile x o (+ threshold n))) 24 | ;; (cons (tuple IEndLet n) code) 25 | ;; (reverse ts)))) 26 | ((Set n v) 27 | (compile v (cons (tuple ISet n) code))) 28 | ((CCall fn ts) 29 | (let ((init (cons (tuple IString fn) 30 | (cons (tuple ICCall (length ts)) 31 | code))) 32 | (f (lambda (a b) 33 | (compile b (cons (tpule IPush) a))))) 34 | (fold-left f init ts))) 35 | ((App) 36 | (cons (tuple IPushMark) 37 | (append (compile-tail exp ) code))) 38 | ((Prim op a b) 39 | (compile a 40 | (cons (tuple IPush) 41 | (compile b 42 | (cons (op->inst op) code) 43 | )) 44 | )) 45 | ((If a b c) 46 | (compile a 47 | (cons (tuple IBranch (compile b code ) 48 | (compile c code )) '()) 49 | )) 50 | )) 51 | 52 | (define (compile-tail exp ) 53 | (case exp 54 | (Int (compile exp (cons (tuple IReturn) '()) )) 55 | (Bool (compile exp (cons (tuple IReturn) '()) )) 56 | (String (compile exp (cons (tuple IReturn) '()) )) 57 | (CCall (compile exp (cons (tuple IReturn) '()) )) 58 | (Load (compile exp (cons (tuple IReturn) '()) )) 59 | (Var (compile exp (cons (tuple IReturn) '()) )) 60 | (Prim (compile exp (cons (tuple IReturn) '()) )) 61 | ;; (Let (compile exp (cons (tuple IReturn) '()) )) 62 | (Set (compile exp (cons (tuple IReturn) '()) )) 63 | (Fun (let ((n (field 0 exp)) 64 | (ts (field 1 exp))) 65 | (cons (tuple IGrab n) (compile-body ts)))) 66 | ;; (Fun1 (let ((n (field 0 exp)) 67 | ;; (ts (field 1 exp))) 68 | ;; (append 69 | ;; (cons (tuple IGrab (- n 1)) 70 | ;; (cons (tuple IPush) (compile-body ts n))) 71 | ;; (cons (tuple IReturn) '())))) 72 | (App (let ((t (field 0 exp)) 73 | (ts (field 1 exp))) 74 | (let ((init (compile t (cons (tuple IApply) '()) )) 75 | (f (lambda (a b) 76 | (compile b a )))) 77 | (fold-left f init ts)))) 78 | )) 79 | 80 | (define (compile-body ts ) 81 | (if (null? ts) '() 82 | (if (null? (cdr ts)) 83 | (compile (car ts) (cons (tuple IReturn) '()) ) 84 | (compile (car ts) 85 | (compile-body (cdr ts) ) )))) 86 | -------------------------------------------------------------------------------- /inspect.cora: -------------------------------------------------------------------------------- 1 | ;; (@import "cora/lib/let-loop") 2 | ;; (@import "cora/lib/sys") 3 | 4 | (set 'set (set)) 5 | (set 'car (car)) 6 | (set 'cdr (cdr)) 7 | (set 'cons (cons)) 8 | (set 'cons (cons)) 9 | (set '+ (+)) 10 | (set '- (-)) 11 | (set '* (*)) 12 | (set '/ (/)) 13 | (set '= (=)) 14 | (set '> (>)) 15 | (set '< (<)) 16 | (set 'gensym (gensym)) 17 | (set 'symbol? (symbol?)) 18 | (set 'not (not)) 19 | (set 'integer? (integer?)) 20 | (set 'string? (string?)) 21 | 22 | (defun inspect (env k stacks) 23 | (let-loop recur (ignore 1) 24 | (begin 25 | (display "debug>\n") 26 | (let exp (read-sexp) 27 | (cond 28 | ((and (cons? exp) (= (car exp) 'continue)) 29 | (eval (cadr exp) env k stacks)) 30 | ((and (cons? exp) (= (car exp) 'stack)) 31 | (do (display stacks) 32 | (recur ()))) 33 | (true (let res (eval exp env .id stacks) 34 | (begin 35 | (display res) 36 | (recur ()))))))))) 37 | 38 | (func .env-extend 39 | [] [] env => env 40 | [p . ps] [a . as] env => (.env-extend ps as [[p . a] . env])) 41 | 42 | (func .env-extend-k 43 | [p . ps] [a . as] env k => (.env-extend-k ps as [[p . a] . env] k) 44 | params args env k => (k params args env)) 45 | 46 | (set '*return-addr* ()) 47 | 48 | (defun .pop-k () 49 | (let ret (car *return-addr*) 50 | (begin 51 | (set '*return-addr* (cdr *return-addr*)) 52 | ret))) 53 | 54 | (defun .save-k (k) 55 | (set '*return-addr* (cons k *return-addr*))) 56 | 57 | (func eval 58 | exp env k _ => (k exp) where (or (number? exp) (string? exp) (boolean? exp) (null? exp)) 59 | exp env k _ => (let find (assq exp env) 60 | (if (null? find) 61 | (k (value exp)) 62 | (k (cdr find)))) 63 | where (symbol? exp) 64 | ['quote x] env k _ => (k x) 65 | ['do x y] env k stacks => (eval x env (lambda (_) 66 | (eval y env k stacks)) stacks) 67 | ['if x y z] env k stacks => (eval x env (lambda (x1) 68 | (if x1 69 | (eval y env k stacks) 70 | (eval z env k stacks))) stacks) 71 | ['lambda args body . more] env k _ => (k ['lambda args body . (append more env)]) 72 | ['let var val body] env k stacks => (eval val env (lambda (val1) 73 | (eval body (cons [var . val1] env) k stacks)) stacks) 74 | ['try exp ['lambda params body]] env k stacks => (begin 75 | (.save-k (lambda (v resume) 76 | (let nenv (.env-extend params [v resume] env) 77 | (eval body nenv k stacks)))) 78 | (eval (cons exp ()) env k stacks)) 79 | ['throw x] env k stacks => (let k1 (.pop-k) 80 | (eval x env (lambda (vx) 81 | (k1 vx k)) stacks)) 82 | ['inspect] env k stacks => (inspect env k stacks) 83 | [f . args] env k stacks => (eval f env (lambda (f1) 84 | (eval-list [] args env 85 | (lambda (vargs) 86 | (match f1 87 | ['lambda params body . cenv] 88 | ;; (eval body (.env-extend params vargs cenv) k (cons f stacks)) 89 | (.env-extend-k params vargs cenv 90 | (lambda (params1 vargs1 nenv) 91 | (cond 92 | ((and (null? params1) (null? vargs1)) 93 | (eval body nenv k (cons f stacks))) 94 | ((null? vargs1) 95 | (k ['lambda params1 body . nenv])) 96 | ((null? params1) 97 | (eval body nenv 98 | (lambda (v) 99 | (eval (cons v vargs1) () k stacks)) 100 | stacks))))) 101 | host-fn (k (apply host-fn vargs)))) 102 | stacks) 103 | ) stacks)) 104 | 105 | (func eval-list 106 | res [] env k stacks => (k (reverse res)) 107 | res [x . xs] env k stacks => (eval x env (lambda (x1) 108 | (eval-list [x1 . res] xs env k stacks)) stacks)) 109 | 110 | (defun .id (x) x) 111 | 112 | (defun eval0 (exp) 113 | (eval exp () .id ())) 114 | -------------------------------------------------------------------------------- /reborn/opt/fcall.c: -------------------------------------------------------------------------------- 1 | 2 | typedef sexp (*sexp_proc8) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 3 | typedef sexp (*sexp_proc9) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 4 | typedef sexp (*sexp_proc10) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 5 | typedef sexp (*sexp_proc11) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 6 | typedef sexp (*sexp_proc12) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 7 | typedef sexp (*sexp_proc13) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 8 | typedef sexp (*sexp_proc14) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 9 | typedef sexp (*sexp_proc15) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 10 | typedef sexp (*sexp_proc16) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 11 | typedef sexp (*sexp_proc17) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 12 | typedef sexp (*sexp_proc18) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 13 | typedef sexp (*sexp_proc19) (sexp, sexp, sexp_sint_t, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); 14 | 15 | #define _A(i) stack[top-i] 16 | 17 | sexp sexp_fcall (sexp ctx, sexp self, sexp_sint_t n, sexp f) { 18 | sexp *stack = sexp_stack_data(sexp_context_stack(ctx)); 19 | sexp_sint_t top = sexp_context_top(ctx); 20 | switch (n) { 21 | case 5: return ((sexp_proc6)sexp_opcode_func(f))(ctx, f, 5, _A(1), _A(2), _A(3), _A(4), _A(5)); 22 | case 6: return ((sexp_proc7)sexp_opcode_func(f))(ctx, f, 6, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6)); 23 | case 7: return ((sexp_proc8)sexp_opcode_func(f))(ctx, f, 7, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7)); 24 | case 8: return ((sexp_proc9)sexp_opcode_func(f))(ctx, f, 8, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8)); 25 | case 9: return ((sexp_proc10)sexp_opcode_func(f))(ctx, f, 9, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9)); 26 | case 10: return ((sexp_proc11)sexp_opcode_func(f))(ctx, f, 10, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10)); 27 | case 11: return ((sexp_proc12)sexp_opcode_func(f))(ctx, f, 11, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11)); 28 | case 12: return ((sexp_proc13)sexp_opcode_func(f))(ctx, f, 12, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12)); 29 | case 13: return ((sexp_proc14)sexp_opcode_func(f))(ctx, f, 13, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13)); 30 | case 14: return ((sexp_proc15)sexp_opcode_func(f))(ctx, f, 14, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14)); 31 | case 15: return ((sexp_proc16)sexp_opcode_func(f))(ctx, f, 15, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15)); 32 | case 16: return ((sexp_proc17)sexp_opcode_func(f))(ctx, f, 16, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16)); 33 | case 17: return ((sexp_proc18)sexp_opcode_func(f))(ctx, f, 17, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16), _A(17)); 34 | case 18: return ((sexp_proc19)sexp_opcode_func(f))(ctx, f, 18, _A(1), _A(2), _A(3), _A(4), _A(5), _A(6), _A(7), _A(8), _A(9), _A(10), _A(11), _A(12), _A(13), _A(14), _A(15), _A(16), _A(17), _A(18)); 35 | default: return sexp_user_exception(ctx, self, "too many FFI arguments", f); 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /srfi-18/schedule.scm: -------------------------------------------------------------------------------- 1 | (define-record-type :thread 2 | (make-:thread name state specific cont) 3 | thread? 4 | (name thread-name :thread-name-set!) 5 | (state :thread-state :thread-state-set!) 6 | (specific thread-specific thread-specific-set!) 7 | (cont :thread-cont :thread-cont-set!)) 8 | 9 | (define ready-head '()) 10 | (define ready-tail '()) 11 | 12 | (define (ready-empty?) 13 | (and (eq? ready-head '()) 14 | (eq? ready-tail '()))) 15 | 16 | (define (ready-enqueue v) 17 | (if (null? ready-tail) 18 | (begin 19 | (set! ready-head (cons v '())) 20 | (set! ready-tail ready-head)) 21 | (let ((node (cons v '()))) 22 | (set-cdr! ready-tail node) 23 | (set! ready-tail node)))) 24 | 25 | (define (ready-dequeue) 26 | (let ((ret (car ready-head))) 27 | (set! ready-head (cdr ready-head)) 28 | (if (null? ready-head) (set! ready-tail '())) 29 | ret)) 30 | 31 | (define (ready-delete v) 32 | ;; prev not null 33 | (define (delete-help prev cur v) 34 | (cond 35 | ((null? cur) void) 36 | ((eq? (car cur) v) 37 | (begin 38 | (set-cdr! prev (cdr cur)) 39 | (if (eq? cur ready-tail) 40 | (set! ready-tail prev)))) 41 | (else 42 | (delete-help cur (cdr cur) v)))) 43 | 44 | (cond 45 | ((null? ready-head) void) 46 | ((eq? (car ready-head) v) 47 | (if (eq? ready-head ready-tail) 48 | (begin (set! ready-head '()) 49 | (set! ready-tail '())) 50 | (set! ready-head (cdr ready-head)))) 51 | (else 52 | (delete-help ready-head (cdr ready-head) v)))) 53 | 54 | (define this #f) 55 | (define void (begin)) 56 | (define (current-thread) 57 | this) 58 | 59 | ;; switch to another thread 60 | (define (switch-to to) 61 | (:thread-state-set! to 'running) 62 | (set! this to) 63 | ((:thread-cont this) void)) 64 | 65 | (define (thread-exit-hook) 66 | (:thread-state-set! this 'dead) 67 | (or (ready-empty?) 68 | (let ((next (ready-dequeue))) 69 | (switch-to next)))) 70 | 71 | (define (make-thread thunk . name) 72 | (set! name (or (symbol? name) (gensym 'thread))) 73 | (make-:thread name 'new void 74 | (lambda (_) 75 | (thunk) 76 | (thread-exit-hook)))) 77 | 78 | ;; save current thread and switch to another thread 79 | (define (switch to) 80 | (call/cc 81 | (lambda (save) 82 | (:thread-cont-set! this save) 83 | (:thread-state-set! this 'ready) 84 | (ready-enqueue this) 85 | (switch-to to)))) 86 | 87 | ;; take a appropriate thread and switch to it 88 | (define (schedule) 89 | (let ((next (ready-dequeue))) 90 | (switch next))) 91 | 92 | (define (thread-yield!) 93 | (if (not (ready-empty?)) (schedule))) 94 | 95 | ;; put thread to ready queue, also trigger a schedule 96 | (define (thread-start! thread) 97 | (or (and (thread? thread) 98 | (eq? (:thread-state thread) 'new)) 99 | (error "not a valid thread!")) 100 | (:thread-state-set! thread 'ready) 101 | (ready-enqueue thread) 102 | (schedule)) 103 | 104 | (define (thread-terminate! thread) 105 | (:thread-state-set! thread 'dead) 106 | (cond 107 | ((eq? thread this) ;;suicide 108 | (if (ready-empty?) (exit) (thread-exit-hook))) 109 | (else 110 | (ready-delete thread)))) 111 | 112 | 113 | (set! this (make-thread '())) 114 | (:thread-state-set! this 'running) 115 | (:thread-name-set! this 'primordial) 116 | (call/cc (lambda (cc) 117 | (:thread-cont-set! this cc))) 118 | 119 | 120 | (define t (make-thread 121 | (lambda () 122 | (printf "print a line ~A~%") 123 | (thread-yield!) 124 | (printf "after yield~%") 125 | (thread-yield!) 126 | (printf "after after yield ~%") 127 | (printf "finish")))) 128 | 129 | 130 | (:thread-name-set! t 'create-thread) 131 | (:thread-state t) 132 | (eq? t this) 133 | ((:thread-cont this) 'resume) 134 | 135 | (thread-start! t) 136 | (thread-name (car ready-head)) 137 | (thread-name t) 138 | (thread-yield!) 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /n6blisp/interpret1.scm: -------------------------------------------------------------------------------- 1 | (define (my-write obj) 2 | (cond ((and (pair? obj) (equal? (car obj) ')) 3 | (display "")) 4 | ((and (pair? obj) (equal? (car obj) ')) 5 | (display "")) 6 | ((pair? obj) 7 | (display "unsafe to display pair")) 8 | (else 9 | (write obj)))) 10 | (define (repl evaluator env) 11 | (display "repl>") 12 | (let ((expr (read))) 13 | (cond ((eof-object? expr) 14 | (display "byebye") 15 | (newline)) 16 | (else 17 | (my-write (evaluator expr env)) 18 | (newline) 19 | (repl evaluator env))))) 20 | 21 | (define (my-eval expr envt) 22 | (cond ((symbol? expr) 23 | (eval-symbol expr envt)) 24 | ((pair? expr) 25 | (eval-list expr envt)) 26 | ((self-evaluating? expr) 27 | expr) 28 | (else 29 | (error "Illegal expression form" expr)))) 30 | 31 | (define (eval-symbol name env) 32 | (lookup-variable name env)) 33 | 34 | (define (lookup-variable name env) 35 | (if (null? env) 36 | (error "unbound value in env") 37 | (let ((find (assoc name (cdr env)))) 38 | (if find 39 | (cdr find) 40 | (lookup-variable name (car env)))))) 41 | 42 | (define (eval-list ls env) 43 | (let ((op (lookup-variable (car ls) env))) 44 | (cond 45 | ((core-form? op) 46 | ((cdr op) ls env)) 47 | ((macro? op) 48 | (eval-macro-call (cdr op) ls env)) 49 | ((use-procedure? op) 50 | (my-apply op 51 | (map (lambda (o) (my-eval o env)) (cdr ls)))) 52 | ((procedure? op) ;;primitive 53 | (apply op (map (lambda (o) (my-eval o env)) (cdr ls)))) 54 | (else 55 | (error "must be core-form/procedure/macro: " (car ls)))))) 56 | 57 | (define (macro? op) 58 | (and (pair? op) (equal? (car op) '))) 59 | 60 | (define (core-form? pair) 61 | (and (pair? pair) (equal? (car pair) '))) 62 | 63 | (define (use-procedure? pair) 64 | (and (pair? pair) (equal? (car pair) '))) 65 | 66 | (define (eval-macro-call transformer expr envt) 67 | (my-eval (my-apply transformer expr) envt)) 68 | 69 | (define (self-evaluating? expr) 70 | (or (number? expr) (boolean? expr) (string? expr))) 71 | 72 | (define (define-variable name value env) 73 | (let ((find (assoc name (cdr env)))) 74 | (if find 75 | (set-cdr! find value) 76 | (set-cdr! env (cons (cons name value) (cdr env)))))) 77 | 78 | (define (eval-define exp env) 79 | (let ((value (my-eval (caddr exp) env))) 80 | (define-variable (cadr exp) value env))) 81 | 82 | (define (eval-define-rewriter exp env) 83 | (let ((value (my-eval (caddr exp) env))) 84 | (define-variable (cadr exp) (cons ' value) env))) 85 | 86 | (define (eval-set! exp env) 87 | (let ((find (assoc (cadr exp) (cdr env)))) 88 | (if find 89 | (set-cdr! find (my-eval (caddr exp) env)) 90 | (error "can't set! a unbound value")))) 91 | (define (eval-quote exp env) 92 | (cadr exp)) 93 | 94 | (define (eval-lambda exp env) 95 | (let ((args (cadr exp)) 96 | (body (cons 'begin (cddr exp)))) 97 | (make-closure env args body))) 98 | 99 | (define (eval-begin exp env) 100 | (cond ((null? (cdr exp)) '()) 101 | ((null? (cddr exp)) (my-eval (cadr exp) env)) 102 | (else 103 | (eval-begin (cdr exp) env)))) 104 | 105 | (define (make-closure env args body) 106 | (list ' env args body)) 107 | 108 | (define (my-apply proc arg) 109 | (let* ((parent (cadr proc)) 110 | (args (caddr proc)) 111 | (body (cadddr proc)) 112 | (env (cons parent (map cons args arg)))) 113 | (my-eval body env))) 114 | 115 | (define (init-env) 116 | (let ((ret (cons '() '()))) 117 | (define-variable 'define (cons ' eval-define) ret) 118 | (define-variable 'define-rewriter (cons ' eval-define-rewriter) ret) 119 | (define-variable 'set! (cons ' eval-set!) ret) 120 | (define-variable 'quote (cons ' eval-quote) ret) 121 | (define-variable 'lambda (cons ' eval-lambda) ret) 122 | (define-variable 'begin (cons ' eval-begin) ret) 123 | (define-variable '+ + ret) 124 | (define-variable 'cons cons ret) 125 | ret)) -------------------------------------------------------------------------------- /zen/match.scm: -------------------------------------------------------------------------------- 1 | (use matchable) 2 | 3 | '(match x 4 | 3 -> 3 5 | 'a -> 'a 6 | a -> a 7 | (p1 . p2) -> p1) 8 | 9 | '(match x 10 | (3 3) 11 | ('a 'a) 12 | (a a) 13 | ((p1 . p2) p1)) 14 | 15 | (define (extract-rules input) 16 | (extract-rules1 (cddr input) (car input) '() '())) 17 | 18 | (define (extract-rules1 input pattern cache result) 19 | (match input 20 | ['() (reverse (cons (cons pattern (reverse cache)) result))] 21 | [`(,x -> . ,remain) (let ((v (cons pattern (reverse cache)))) 22 | (extract-rules1 remain x '() (cons v result)))] 23 | [`(,x . ,y) (extract-rules1 y pattern (cons x cache) result)])) 24 | 25 | ;; (extract-rules '(3 -> 3 'a -> a (p1 . p2) -> p2)) 26 | ;; ((3 3) ('a a) ((p1 . p2) p2)) 27 | 28 | (define (rewrite input) 29 | (let ((val (cadr input)) 30 | (raw (cddr input))) 31 | (rewrite-match val (extract-rules raw)))) 32 | 33 | (define (rewrite-match val rules) 34 | (match rules 35 | ['() '(error "no match")] 36 | [`((,pat ,action) . ,remain) 37 | (ppat val pat action (rewrite-match val remain))])) 38 | 39 | (define (ppat val pat kt kf) 40 | (match pat 41 | [(? number? x) `(if (equal? ,val ,x) ,kt ,kf)] 42 | [`(quote ,x) `(if (eq? ,val ,pat) ,kt ,kf)] 43 | ['() `(if (null? ,val) ,kt ,kf)] 44 | [(? symbol?) `(let ((,pat ,val)) 45 | ,kt)] 46 | [`(,p1 . ,p2) 47 | `(if (pair? ,val) 48 | (let ((v1 (car ,val)) 49 | (v2 (cdr ,val))) 50 | ,(ppat 'v1 51 | p1 52 | (ppat 'v2 p2 kt kf) 53 | kf)) 54 | ,kf)])) 55 | 56 | (rewrite-match 'x '((3 3))) 57 | (rewrite-match 'x '(('a 3))) 58 | 59 | ;; (rewrite '(match x 60 | ;; (1 . 2) -> 42 61 | ;; 3 -> 3 62 | ;; 'a -> 'a 63 | ;; $v -> $v 64 | ;; )) 65 | 66 | ;; (let ((x (cons 1 2))) 67 | ;; (if (pair? x) (let ((v1 (car x)) (v2 (cdr x))) (if (equal? v1 1) (if (equal? v2 2) 42 (if (equal? x 3) 3 (if (eq? x 'a) 'a (let (($v x)) $v)))) (if (equal? x 3) 3 (if (eq? x 'a) 'a (let (($v x)) $v))))) (if (equal? x 3) 3 (if (eq? x 'a) 'a (let (($v x)) $v)))) 68 | ;; ) 69 | 70 | (rewrite '(match x(1 2 3) -> 42)) 71 | 72 | (rewrite-match 'x '(((1 2 3) 42))) 73 | (let ((x '(2 3))) 74 | (if (pair? x) 75 | (let ((v1 (car x)) (v2 (cdr x))) 76 | (if (equal? v1 1) 77 | (if (pair? v2) 78 | (let ((v1 (car v2)) (v2 (cdr v2))) 79 | (if (equal? v1 2) 80 | (if (pair? v2) 81 | (let ((v1 (car v2)) (v2 (cdr v2))) 82 | (if (equal? v1 3) 83 | (if (null? v2) 84 | 42 85 | (error "no match")) 86 | (error "no match"))) 87 | (error "no match")) 88 | (error "no match"))) 89 | (error "no match")) 90 | (error "no match"))) 91 | (error "no match"))) 92 | 93 | (define-syntax pmatch 94 | (er-macro-transformer 95 | (lambda (input rename compare) 96 | (rewrite input)))) 97 | 98 | 99 | 100 | (macroexpand 101 | '(pmatch 1 102 | 1 -> 42)) 103 | 104 | (define input '(pmatch 34 105 | a -> (+ a 1))) 106 | 107 | (extract-rules (cddr input)) 108 | `(match ,(cadr input) ,@(extract-rules (cddr input))) 109 | 110 | (match 34 111 | ((a (+ a 1)))) 112 | 113 | (pmatch '() 114 | 1 -> 24 115 | ('a 'b 'c) -> 444 116 | () -> #t 117 | (a . b) -> (+ a 1)) 118 | 119 | (func map 120 | / f () -> 123 121 | / f (a . b) -> (cons (f a) (map f b))) 122 | 123 | (define (rewrite input) 124 | (let ((val (cadr input)) 125 | (raw (cddr input))) 126 | (rewrite-match val (extract-rules raw)))) 127 | 128 | ;; (define-syntax pmatch 129 | ;; (er-macro-transformer 130 | ;; (lambda (input rename compare) 131 | ;; `(match ,(cadr input) ,@(extract-rules (cddr input)))))) 132 | -------------------------------------------------------------------------------- /reborn/opt/sexp-huff.c: -------------------------------------------------------------------------------- 1 | {12, 0x0C00}, /* '\x00' */ 2 | {15, 0x0000}, /* '\x01' */ 3 | {15, 0x4000}, /* '\x02' */ 4 | {15, 0x2000}, /* '\x03' */ 5 | {15, 0x6000}, /* '\x04' */ 6 | {15, 0x0800}, /* '\x05' */ 7 | {15, 0x4800}, /* '\x06' */ 8 | {15, 0x2800}, /* '\x07' */ 9 | {15, 0x6800}, /* '\x08' */ 10 | {15, 0x1800}, /* '\x09' */ 11 | {15, 0x5800}, /* '\x0a' */ 12 | {15, 0x3800}, /* '\x0b' */ 13 | {15, 0x7800}, /* '\x0c' */ 14 | {15, 0x0100}, /* '\x0d' */ 15 | {15, 0x4100}, /* '\x0e' */ 16 | {15, 0x2100}, /* '\x0f' */ 17 | {15, 0x6100}, /* '\x10' */ 18 | {15, 0x1100}, /* '\x11' */ 19 | {15, 0x5100}, /* '\x12' */ 20 | {15, 0x3100}, /* '\x13' */ 21 | {15, 0x7100}, /* '\x14' */ 22 | {15, 0x0900}, /* '\x15' */ 23 | {15, 0x4900}, /* '\x16' */ 24 | {15, 0x2900}, /* '\x17' */ 25 | {15, 0x6900}, /* '\x18' */ 26 | {15, 0x1900}, /* '\x19' */ 27 | {15, 0x5900}, /* '\x1a' */ 28 | {15, 0x3900}, /* '\x1b' */ 29 | {15, 0x7900}, /* '\x1c' */ 30 | {15, 0x0500}, /* '\x1d' */ 31 | {15, 0x4500}, /* '\x1e' */ 32 | {15, 0x2500}, /* '\x1f' */ 33 | {15, 0x6500}, /* '\x20' */ 34 | { 8, 0x0040}, /* '!' */ 35 | {15, 0x1500}, /* '"' */ 36 | {15, 0x5500}, /* '#' */ 37 | {15, 0x3500}, /* '$' */ 38 | {15, 0x7500}, /* '%' */ 39 | {15, 0x0D00}, /* '&' */ 40 | {15, 0x4D00}, /* '\'' */ 41 | {15, 0x2D00}, /* '(' */ 42 | {15, 0x6D00}, /* ')' */ 43 | {11, 0x0300}, /* '*' */ 44 | {10, 0x0180}, /* '+' */ 45 | {15, 0x1D00}, /* ',' */ 46 | { 4, 0x000D}, /* '-' */ 47 | {15, 0x5D00}, /* '.' */ 48 | {10, 0x0380}, /* '/' */ 49 | {15, 0x3D00}, /* '0' */ 50 | {15, 0x7D00}, /* '1' */ 51 | {14, 0x0080}, /* '2' */ 52 | {14, 0x2080}, /* '3' */ 53 | {14, 0x1080}, /* '4' */ 54 | {14, 0x3080}, /* '5' */ 55 | {14, 0x0880}, /* '6' */ 56 | {14, 0x2880}, /* '7' */ 57 | {14, 0x1880}, /* '8' */ 58 | {14, 0x3880}, /* '9' */ 59 | {14, 0x0480}, /* ':' */ 60 | {14, 0x2480}, /* ';' */ 61 | { 7, 0x0050}, /* '<' */ 62 | { 7, 0x0042}, /* '=' */ 63 | { 7, 0x0022}, /* '>' */ 64 | { 5, 0x0009}, /* '?' */ 65 | {14, 0x1480}, /* '@' */ 66 | {14, 0x3480}, /* 'A' */ 67 | {14, 0x0C80}, /* 'B' */ 68 | {14, 0x2C80}, /* 'C' */ 69 | {14, 0x1C80}, /* 'D' */ 70 | {14, 0x3C80}, /* 'E' */ 71 | {14, 0x0280}, /* 'F' */ 72 | {14, 0x2280}, /* 'G' */ 73 | {14, 0x1280}, /* 'H' */ 74 | {14, 0x3280}, /* 'I' */ 75 | {14, 0x0A80}, /* 'J' */ 76 | {14, 0x2A80}, /* 'K' */ 77 | {14, 0x1A80}, /* 'L' */ 78 | {14, 0x3A80}, /* 'M' */ 79 | {14, 0x0680}, /* 'N' */ 80 | {14, 0x2680}, /* 'O' */ 81 | {14, 0x1680}, /* 'P' */ 82 | {14, 0x3680}, /* 'Q' */ 83 | {14, 0x0E80}, /* 'R' */ 84 | {14, 0x2E80}, /* 'S' */ 85 | {14, 0x1E80}, /* 'T' */ 86 | {14, 0x3E80}, /* 'U' */ 87 | {14, 0x0200}, /* 'V' */ 88 | {14, 0x2200}, /* 'W' */ 89 | {14, 0x1200}, /* 'X' */ 90 | {14, 0x3200}, /* 'Y' */ 91 | {14, 0x0A00}, /* 'Z' */ 92 | {14, 0x2A00}, /* '[' */ 93 | {14, 0x1A00}, /* '\\' */ 94 | {14, 0x3A00}, /* ']' */ 95 | {14, 0x0600}, /* '^' */ 96 | {14, 0x2600}, /* '_' */ 97 | {14, 0x1600}, /* '`' */ 98 | { 3, 0x0007}, /* 'a' */ 99 | { 7, 0x0020}, /* 'b' */ 100 | { 4, 0x0004}, /* 'c' */ 101 | { 5, 0x001A}, /* 'd' */ 102 | { 4, 0x0006}, /* 'e' */ 103 | { 7, 0x0002}, /* 'f' */ 104 | { 5, 0x0011}, /* 'g' */ 105 | { 6, 0x0012}, /* 'h' */ 106 | { 4, 0x000C}, /* 'i' */ 107 | {12, 0x0400}, /* 'j' */ 108 | { 8, 0x00C0}, /* 'k' */ 109 | { 5, 0x0018}, /* 'l' */ 110 | { 6, 0x0032}, /* 'm' */ 111 | { 4, 0x0005}, /* 'n' */ 112 | { 5, 0x000A}, /* 'o' */ 113 | { 5, 0x0001}, /* 'p' */ 114 | { 7, 0x0070}, /* 'q' */ 115 | { 3, 0x0003}, /* 'r' */ 116 | { 5, 0x0008}, /* 's' */ 117 | { 4, 0x000E}, /* 't' */ 118 | { 5, 0x0019}, /* 'u' */ 119 | { 7, 0x0062}, /* 'v' */ 120 | { 7, 0x0030}, /* 'w' */ 121 | { 7, 0x0060}, /* 'x' */ 122 | { 7, 0x0010}, /* 'y' */ 123 | {11, 0x0700}, /* 'z' */ 124 | {14, 0x3600}, /* '{' */ 125 | {14, 0x0E00}, /* '|' */ 126 | {14, 0x2E00}, /* '}' */ 127 | {14, 0x1E00}, /* '~' */ 128 | {14, 0x3E00}, /* '\x7f' */ 129 | -------------------------------------------------------------------------------- /nanopass/testcase.ss: -------------------------------------------------------------------------------- 1 | (letrec ([merge$4 (lambda (fp.22 ls.16 ls2.15) 2 | (if (null? ls.16) 3 | ls2.15 4 | (if (null? ls2.15) 5 | ls.16 6 | (if (< (car ls.16) (car ls2.15)) 7 | (cons 8 | (car ls.16) 9 | ((procedure-code 10 | (procedure-ref fp.22 '0)) 11 | (procedure-ref fp.22 '0) 12 | (cdr ls.16) 13 | ls2.15)) 14 | (cons 15 | (car ls2.15) 16 | ((procedure-code 17 | (procedure-ref fp.22 '0)) 18 | (procedure-ref fp.22 '0) 19 | ls.16 20 | (cdr ls2.15)))))))] 21 | [sort$3 (lambda (fp.21 ls.11) 22 | (if (null? ls.11) 23 | ls.11 24 | (if (null? (cdr ls.11)) 25 | ls.11 26 | (let ([halves.12 ((procedure-code 27 | (procedure-ref fp.21 '0)) 28 | (procedure-ref fp.21 '0) 29 | ls.11 '() '() '#t)]) 30 | (let ([first.14 (car halves.12)] 31 | [second.13 (car (cdr halves.12))]) 32 | ((procedure-code (procedure-ref fp.21 '1)) 33 | (procedure-ref fp.21 '1) 34 | ((procedure-code (procedure-ref fp.21 '2)) 35 | (procedure-ref fp.21 '2) 36 | first.14) 37 | ((procedure-code (procedure-ref fp.21 '2)) 38 | (procedure-ref fp.21 '2) 39 | second.13)))))))] 40 | [halves$2 (lambda (fp.20 ls.10 first.9 second.8 first?.7) 41 | (if (null? ls.10) 42 | (cons first.9 (cons second.8 '())) 43 | (if (if (eq? first?.7 '#f) (false) (true)) 44 | ((procedure-code (procedure-ref fp.20 '0)) 45 | (procedure-ref fp.20 '0) (cdr ls.10) 46 | (cons (car ls.10) first.9) second.8 '#f) 47 | ((procedure-code (procedure-ref fp.20 '0)) 48 | (procedure-ref fp.20 '0) (cdr ls.10) first.9 49 | (cons (car ls.10) second.8) '#t))))] 50 | [pend$1 (lambda (fp.19 ls.6 ls2.5) 51 | (if (null? ls.6) 52 | ls2.5 53 | (cons 54 | (car ls.6) 55 | ((procedure-code (procedure-ref fp.19 '0)) 56 | (procedure-ref fp.19 '0) 57 | (cdr ls.6) 58 | ls2.5))))]) 59 | (let ([u.18 (cons 60 | '1 61 | (cons 62 | '5 63 | (cons '5 (cons '8 (cons '2 (cons '3 (cons '9 '())))))))] 64 | [u.17 (cons 65 | '5 66 | (cons 67 | '9 68 | (cons '5 (cons '7 (cons '7 (cons '8 (cons '7 '())))))))]) 69 | (let ([merge.4 (make-procedure merge$4 '1)] 70 | [sort.3 (make-procedure sort$3 '3)] 71 | [halves.2 (make-procedure halves$2 '1)] 72 | [pend.1 (make-procedure pend$1 '1)]) 73 | (begin 74 | (procedure-set! merge.4 '0 merge.4) 75 | (procedure-set! sort.3 '0 halves.2) 76 | (procedure-set! sort.3 '1 merge.4) 77 | (procedure-set! sort.3 '2 sort.3) 78 | (procedure-set! halves.2 '0 halves.2) 79 | (procedure-set! pend.1 '0 pend.1) 80 | ((procedure-code pend.1) 81 | pend.1 82 | ((procedure-code sort.3) sort.3 u.18) 83 | ((procedure-code sort.3) sort.3 u.17)))))) 84 | 85 | (let ([t (cons 1 2)] [v (make-vector 2)]) 86 | (begin 87 | (vector-set! v 1 t) 88 | (vector-set! v 2 10) 89 | v)) -------------------------------------------------------------------------------- /dt.cora: -------------------------------------------------------------------------------- 1 | (func assv 2 | s [] => [] 3 | s [[x . y] . z] => [x . y] where (= s x) 4 | s [_ . z] => (assv s z)) 5 | 6 | (defun extend (env var val) 7 | (cons (cons var val) env)) 8 | 9 | (func subst 10 | env var => (let find (assv var env) 11 | (if (null? find) 12 | var 13 | (cdr find))) 14 | where (symbol? var) 15 | env uni => uni where (number? uni) 16 | env ['pi [x A] B] => ['pi . (subst-abstruction env x A B)] 17 | env ['lambda [x A] B] => ['lambda . (subst-abstruction env x A B)] 18 | env [f x] => [(subst env f) (subst env x)]) 19 | 20 | (func subst-abstruction 21 | env x t e => (let x1 (gensym x) 22 | [[x1 (subst env t)] (subst (extend env x x1) e)])) 23 | 24 | (func get-type 25 | ['#def t v] => t 26 | ['#bind t] => t) 27 | 28 | (func infer-type 29 | ctx x => (let find (assv x ctx) 30 | (if (null? find) 31 | (error "unknown identifer %s" x) 32 | (get-type (cdr find)))) 33 | where (symbol? x) 34 | ctx uni => (+ uni 1) where (number? uni) 35 | ctx ['pi [x t1] t2] => (let k1 (infer-universe ctx t1) 36 | (let k2 (infer-universe (extend ctx x ['#bind t1]) t2) 37 | (if (> k1 k2) k1 k2))) 38 | ctx ['lambda [x t] e] => (let _ (infer-universe ctx t) 39 | (let te (infer-type (extend ctx x ['#bind t]) e) 40 | ['pi [x t] te])) 41 | ctx [e1 e2] => (match (infer-pi ctx e1) 42 | ['pi [x s] t] 43 | (let te (infer-type ctx e2) 44 | (let _ (check-equal ctx s te) 45 | (subst (extend () x e2) t))))) 46 | 47 | (defun check-equal (ctx e1 e2) 48 | (if (not (alpha-eq? ctx e1 e2)) 49 | (error "expression %t and %t are not equal") 50 | 'ok)) 51 | 52 | (defun infer-universe (ctx t) 53 | (let u (infer-type ctx t) 54 | (let u1 (normalize ctx u) 55 | (if (number? u1) 56 | u1 57 | (error "type expected"))))) 58 | 59 | 60 | (defun infer-pi (ctx e) 61 | (let t (infer-type ctx e) 62 | (match (normalize ctx t) 63 | ['pi . a] ['pi . a] 64 | _ (error "function expected")))) 65 | 66 | (func normalize 67 | env var => (let find (assv var env) 68 | (if (null? find) 69 | (error "unknown identifier %t") 70 | (match (cdr find) 71 | ['#def t val] (normalize env val) 72 | ['#bind t] var))) 73 | where (symbol? var) 74 | env [e1 e2] => (let ne2 (normalize env e2) 75 | (match (normalize env e1) 76 | ['lambda [x _] e] (normalize env (subst (extend () x ne2) e)) 77 | f [f e2])) 78 | env uni => uni where (number? uni) 79 | env ['pi [x A] B] => ['pi . (normalize-abstraction env x A B)] 80 | env ['lambda [x t] e] => ['lambda . (normalize-abstraction env x t e)]) 81 | 82 | (defun normalize-abstraction (env x t e) 83 | (let t1 (normalize env t) 84 | [[x t1] (normalize (extend env x ['#bind t1]) e)])) 85 | 86 | (defun alpha-eq? (ctx e1 e2) 87 | (alpha-eq-h (normalize ctx e1) (normalize ctx e2))) 88 | 89 | (func alpha-eq-h 90 | x1 x2 => (= x1 x2) where (and (symbol? x1) (symbol? x2)) 91 | k1 k2 => (= k1 k2) where (and (number? k1) (number? k2)) 92 | [f1 x1] [f2 x2] => (and (alpha-eq-h f1 f2) 93 | (alpha-eq-h x1 x2)) 94 | ['pi [x1 A1] B1] ['pi [x2 A2] B2] => (and (alpha-eq-h A1 A2) 95 | (let z (gensym 'bbc) 96 | (alpha-eq-h (subst (extend () x1 z) B1) 97 | (subst (extend () x2 z) B2)))) 98 | ['lambda [x1 A1] B1] ['lambda [x2 A2] B2] => (and (alpha-eq-h A1 A2) 99 | (lambda z (gensym 'cca) 100 | (alpha-eq-h (subst (extend () x1 z) B1) 101 | (subst (extend () x2 z) B2)))) 102 | _ _ => false) 103 | 104 | 105 | 106 | 107 | ;; (let ctx [['N . ['#bind 0]] 108 | ;; ['id . ['#def 109 | ;; '(pi (A 0) (pi (_ A) A)) 110 | ;; '(lambda (a 0) (lambda (x a) x))]]] 111 | ;; (infer-type ctx '(id (pi (x N) (pi (y x) x) )))) 112 | ;; (normalize ctx '((id (pi (x 0) (pi (y x) x) )) id))) 113 | 114 | ;; (let ctx [['N . ['#bind 0]] 115 | ;; ['z . ['#bind 'N]] 116 | ;; ['s . ['#bind '(pi (_ N) N)]] 117 | ;; ['three . ['#def 118 | ;; '(pi (_ (pi (_ N) N)) 119 | ;; (pi (_ N) N)) 120 | ;; '(lambda (f (pi (_ N) N)) 121 | ;; (lambda (x N) 122 | ;; (f (f (f x)))))]]] 123 | 124 | ;; (normalize ctx '((three (three s)) z))) 125 | ;; (infer-type ctx '((three (three s)) z))) 126 | -------------------------------------------------------------------------------- /lisp2c.shen: -------------------------------------------------------------------------------- 1 | (define cps 2 | AST CC -> [%apply CC [%lit AST]] where (or (number? AST) (string? AST) (boolean? AST)) 3 | AST CC -> [%apply CC AST] where (symbol? AST) 4 | [if A B C] CC -> (cps a (let R1 (gensym r) 5 | [%lambda [R1] 6 | [%if R1 (cps B CC) 7 | (cps C CC)]])) 8 | [begin E1 E2] CC -> (cps E1 [%lambda [(gensym _)] 9 | (cps E2 CC)]) 10 | [set! V E] CC -> (cps E (let R1 (gensym r) 11 | [%lambda [R1] 12 | [%apply CC [%apply [%prim set!] V R1]]])) 13 | [lambda ARGS E] CC -> (let K (gensym k) 14 | [%apply CC [%lambda (cons K ARGS) 15 | (cps E K)]]) 16 | [E] CC -> (cps E (let R0 (gensym r) 17 | [%lambda [R0] [%apply R0 CC]])) 18 | [OP X Y] CC -> (let R1 (gensym r) 19 | R2 (gensym r) 20 | (cps X 21 | [%lambda [R1] 22 | (cps Y 23 | [%lambda [R2] 24 | [%apply CC [%apply [%prim OP] R1 R2]]])])) 25 | where (element? OP [= * + - / >]) 26 | [E0 E1] CC -> (cps E0 (let R0 (gensym r) 27 | R1 (gensym r) 28 | [%lambda [R0] 29 | (cps E1 30 | [%lambda [R1] 31 | [%apply R0 CC R1]])]))) 32 | 33 | (defun cps-convert (AST) 34 | (cps AST [%lambda [X] X])) 35 | 36 | (define gen-let 37 | Res [] [] -> (reverse Res) 38 | Res [X | Y] [A | B] -> (gen-let [[X A] | Res] Y B)) 39 | 40 | (define pp-ast 41 | [%apply Var | L] -> [[%closure-ref Var 0] Var | (map (pp-ast) L)] where (symbol? Var) 42 | [%apply [%lambda Params Body] | Args] -> (let NArgs (map (pp-ast) Args) 43 | Bind (gen-let [] Params NArgs) 44 | [let Bind (pp-ast Body)]) 45 | [%apply | L] -> (map (pp-ast) L) 46 | [%lambda ARGS BODY] -> [lambda ARGS (pp-ast BODY)] 47 | [%closure | L] -> [%closure | (map (pp-ast) L)] 48 | [%prim X] -> X 49 | [%lit X] -> X 50 | [%if | L] -> [if | (map (pp-ast) L)] 51 | X -> X) 52 | 53 | 54 | (defun source (X) 55 | (make-string "~R" (pp-ast X))) 56 | 57 | (define diff 58 | S1 [] -> S1 59 | [] S2 -> [] 60 | [X | Y] S2 -> (diff Y S2) where (element? X S2) 61 | [X | Y] S2 -> [X | (diff Y S2)]) 62 | 63 | (define foldl 64 | F Init [X | Y] -> (foldl F (F X Init) Y) 65 | F Init [] -> Init) 66 | 67 | (define free-vars 68 | AST -> [AST] where (symbol? AST) 69 | [%lit X] -> [] 70 | [%prim OP] -> [] 71 | [%if | More] -> (foldl (union) [] (map (free-vars) More)) 72 | [%lambda ARGS BODY] -> (diff (free-vars BODY) ARGS) 73 | [%apply | More] -> (foldl (union) [] (map (free-vars) More))) 74 | 75 | (define pos-in-list0 76 | X [] _ -> -1 77 | X [X | L] I -> I 78 | X [_ | L] I -> (post-in-list0 X L (+ I 1))) 79 | 80 | (defun pos-in-list (x l) 81 | (pos-in-list0 x l 0)) 82 | 83 | (define convert 84 | SELF FREE [%prim OP] -> [%prim OP] 85 | SELF FREE [%lit AST] -> [%lit AST] 86 | 87 | SELF FREE AST -> (let POS (pos-in-list AST FREE) 88 | (if (= POS -1) 89 | AST 90 | [%closure-ref SELF (+ pos 1)])) where (symbol? AST) 91 | 92 | SELF FREE [%if | More] -> [%if | (map (convert SELF FREE) More)] 93 | 94 | SELF FREE [%lambda ARGS E] -> 95 | (let FV (free-vars [%lambda ARGS E]) 96 | SELF-VAR (gensym self) 97 | [%closure [%lambda [SELF-VAR | ARGS] (convert SELF-VAR FV E)] | 98 | (map (convert SELF FREE) FV)]) 99 | 100 | SELF FREE [%apply [%lambda PARAMS BODY] | ARGS] -> 101 | [%apply [%lambda PARAMS (convert SELF FREE BODY)] | (map (convert SELF FREE) ARGS)] 102 | SELF FREE [%apply | More] -> [%apply | (map (convert SELF FREE) More)]) 103 | 104 | (defun closure-convert (ast) 105 | (convert ignore [] ast )) 106 | 107 | (closure-convert [%apply [%lambda [r1235] 108 | [%if r1235 109 | y 110 | z]] a]) 111 | 112 | -------------------------------------------------------------------------------- /pi.cora: -------------------------------------------------------------------------------- 1 | ;; 0 = type 2 | ;; 1 = kind 3 | ;; 2 = box 4 | 5 | (func assv 6 | s [] => [] 7 | s [[x . y] . z] => [x . y] where (= s x) 8 | s [_ . z] => (assv s z)) 9 | 10 | (defun extend (env var val) 11 | (cons (cons var val) env)) 12 | 13 | (func infer-type 14 | ctx 1 => 2 15 | ctx 2 => (error "type of box is ?") 16 | ctx x => (let find (assv x ctx) 17 | (if (null? find) 18 | (error "var not find") 19 | (cdr find))) where (symbol? x) 20 | ctx ['pi [x A] B] => (let tA (infer-type ctx A) 21 | (let tB (infer-type (extend ctx x A) B) 22 | tB)) 23 | ctx [f x] => (match (infer-type ctx f) 24 | ['pi [a A] B] 25 | (let tx (infer-type ctx x) 26 | (if (alpha-eq? ctx tx A) 27 | (subst (extend () a x) B) 28 | (error "infer (f x) fail"))) 29 | _ (error "infer-type [f x] error"))) 30 | 31 | (defun alpha-eq? (ctx e1 e2) 32 | (alpha-eq-h (normalize ctx e1) (normalize ctx e2))) 33 | 34 | (func alpha-eq-h 35 | x1 x2 => (= x1 x2) where (and (symbol? x1) (symbol? x2)) 36 | k1 k2 => (= k1 k2) where (and (number? k1) (number? k2)) 37 | [f1 x1] [f2 x2] => (and (alpha-eq-h f1 f2) 38 | (alpha-eq-h x1 x2)) 39 | ['pi [x1 A1] B1] ['pi [x2 A2] B2] => (and (alpha-eq-h A1 A2) 40 | (let z (gensym 'bbc) 41 | (alpha-eq-h (subst (extend () x1 z) B1) 42 | (subst (extend () x2 z) B2)))) 43 | ['lambda [x1 A1] B1] ['lambda [x2 A2] B2] => (and (alpha-eq-h A1 A2) 44 | (lambda z (gensym 'cca) 45 | (alpha-eq-h (subst (extend () x1 z) B1) 46 | (subst (extend () x2 z) B2)))) 47 | _ _ => false) 48 | 49 | (func normalize 50 | env var => (let find (assv var env) 51 | (if (null? find) 52 | (error "unknown identifier %t") 53 | (match (cdr find) 54 | ['#def t val] (normalize env val) 55 | ['#bind t] var))) 56 | where (symbol? var) 57 | env [e1 e2] => (let ne2 (normalize env e2) 58 | (match (normalize env e1) 59 | ['lambda [x _] e] (normalize env (subst (extend () x ne2) e)) 60 | f [f e2])) 61 | env uni => uni where (number? uni) 62 | env ['pi [x A] B] => ['pi . (normalize-abstraction env x A B)] 63 | env ['lambda [x t] e] => ['lambda . (normalize-abstraction env x t e)]) 64 | 65 | (defun normalize-abstraction (env x t e) 66 | (let t1 (normalize env t) 67 | [[x t1] (normalize (extend env x ['#bind t1]) e)])) 68 | 69 | (func subst 70 | env var => (let find (assv var env) 71 | (if (null? find) 72 | var 73 | (cdr find))) 74 | where (symbol? var) 75 | env uni => uni where (number? uni) 76 | env ['pi [x A] B] => ['pi . (subst-abstruction env x A B)] 77 | env ['lambda [x A] B] => ['lambda . (subst-abstruction env x A B)] 78 | env [f x] => [(subst env f) (subst env x)]) 79 | 80 | (func subst-abstruction 81 | env x t e => (let x1 (gensym x) 82 | [[x1 (subst env t)] (subst (extend env x x1) e)])) 83 | 84 | (func check-type 85 | ctx x A => 86 | ctx ['lambda x y] ['pi [a A] B] => (check-type (extend ctx x A) y 87 | (subst a x B)) 88 | ctx e t => (alpha-eq? (infer-type ctx e) t)) 89 | 90 | 91 | 92 | (let ctx (extend () 'id '(pi (x 1) (pi (y x) x))) 93 | 94 | (infer-type ctx '(id (pi (x 1) (pi (y x) x))))) 95 | 96 | ===> (pi (#y422 (pi (x 1) (pi (y x) x))) (pi (x 1) (pi (y x) x))) 97 | ===> (pi (#y458 (pi (x 1) (pi (y x) x))) (pi (x 1) (pi (y x) x))) 98 | 99 | ===> (pi (x 1) (pi (y x) x)) 100 | 101 | (infer-type ctx '((id (pi (x 1) (pi (y x) x))) id))) 102 | 103 | 104 | 105 | 106 | (infer-type ctx '(pi (x 1) (pi (y x) x)))) 107 | 108 | (infer-type ctx 1)) 109 | (infer-type ctx 'id)) 110 | 111 | (infer-type 112 | 113 | 114 | id ['pi [x 1] ['pi [y x] x]] 115 | (lambda x (lambda y y)) 116 | 117 | 118 | ((id ['pi [x T] ['pi [y x] x]]) id) 119 | 120 | 121 | infer-type (id ['pi [x T] ['pi [y x] x]]) 122 | 123 | 124 | infer-type id => ['pi [x T1] ['pi [y x] x]] 125 | 126 | 127 | check-type ['pi [x T] ['pi [y x] x]] T1 128 | 129 | 130 | (subst x ['pi [x T] ['pi [y x] x]] ['pi [y x] x]) 131 | 132 | ['pi [_ ['pi [x T] ['pi [y x] x]]] ['pi [x T] ['pi [y x] x]]] 133 | 134 | (subst 'x '(pi (x 1) (pi (y x) x)) '(pi (y x) x)) 135 | 136 | (subst (extend () 'x '(pi (x 1) (pi (y x) x))) '(pi (y x) x)) 137 | 138 | 139 | (pi (#y408 (pi (x 1) (pi (y x) x))) 140 | (pi (x 1) (pi (y x) x))) 141 | -------------------------------------------------------------------------------- /n6blisp/.svn/text-base/interpret.scm.svn-base: -------------------------------------------------------------------------------- 1 | (define (my-eval exp env) 2 | (cond ((immediate-data? exp) exp) 3 | ((variable? exp) (lookup-variable exp env)) 4 | ((quote? exp) (cadr exp)) 5 | ((assignment? exp) (set-variable (set-name exp) (set-value exp) env)) 6 | ((define? exp) (define-variable (define-name exp) (define-value exp env) env)) 7 | ((if? exp) (eval-if exp env)) 8 | ((lambda? exp) (eval-lambda exp env)) 9 | ((application? exp) 10 | (my-apply (my-eval (car exp) env) 11 | (make-args (cdr exp) env))) 12 | (else (display "known error")))) 13 | (define (immediate-data? exp) 14 | (or (number? exp) (string? exp) (boolean? exp))) 15 | (define (variable? exp) 16 | (symbol? exp)) 17 | (define (make-binding name value) 18 | (cons name value)) 19 | (define (lookup-variable-in-frame variable frame) 20 | (if (null? frame) 21 | '() 22 | (if (eq? (caar frame) variable) 23 | (cdar frame) 24 | (lookup-variable-in-frame variable (cdr frame))))) 25 | (define (lookup-variable variable env) 26 | (if (null? env) 27 | '() 28 | (let ((ret (lookup-variable-in-frame variable (car env)))) 29 | (if (null? ret) 30 | (lookup-variable variable (cdr env)) 31 | ret)))) 32 | (define (quote? exp) 33 | (tagged-list? exp 'quote)) 34 | (define (tagged-list? exp tag) 35 | (and (pair? exp) (eq? (car exp) tag))) 36 | (define (define? exp) 37 | (tagged-list? exp 'define)) 38 | (define (define-name exp) 39 | (cadr exp)) 40 | (define (define-value exp env) 41 | (my-eval (caddr exp) env)) 42 | (define (lookup-binding-in-frame frame name) 43 | (if (null? frame) 44 | '() 45 | (if (eq? (caar frame) name) 46 | (car frame) 47 | (lookup-binding-in-frame (cdr frame) name)))) 48 | (define (define-variable name value env) 49 | (let ((binding (lookup-binding-in-frame (car env) name))) 50 | (if (null? binding) 51 | (set-car! env (cons (make-binding name value) (car env))) 52 | (set-cdr! binding value)))) 53 | (define (set-variable name value env) 54 | (if (null? env) 55 | (display "error:variable not exist") 56 | (let ((binding (lookup-binding-in-frame (car env) name))) 57 | (if (null? binding) 58 | (set-variable name value (cdr env)) 59 | (set-cdr! binding value))))) 60 | 61 | (define (tagged-list? exp tag) 62 | (and (pair? exp) (eq? (car exp) tag))) 63 | 64 | (define (assignment? exp) 65 | (tagged-list? exp 'set!)) 66 | (define (set-name exp) 67 | (cadr exp)) 68 | (define (set-value exp) 69 | (caddr exp)) 70 | (define (if? exp) 71 | (tagged-list? exp 'if)) 72 | (define (eval-if exp env) 73 | (let ((if-part (cadr exp)) 74 | (then-part (caddr exp)) 75 | (else-part (cadddr exp))) 76 | (if (my-eval if-part env) 77 | (my-eval then-part env) 78 | (my-eval else-part env)))) 79 | (define (lambda? exp) 80 | (tagged-list? exp 'lambda)) 81 | (define (eval-lambda exp env) 82 | (let ((arg-part (cadr exp)) (body-part (caddr exp))) 83 | (list 'procedure arg-part body-part env))) 84 | (define (application? exp) (pair? exp)) 85 | (define (make-args list env) 86 | (if (null? list) 87 | '() 88 | (cons (my-eval (car list) env) 89 | (make-args (cdr list) env)))) 90 | (define (my-apply procedure argument) 91 | (cond ((tagged-list? procedure 'procedure) (call-procedure (cdr procedure) argument)) 92 | ((tagged-list? procedure 'primitive) (call-primitive (cadr procedure) argument)) 93 | (else (display "error:undefined procedure")))) 94 | (define (call-procedure procedure argument) 95 | (let ((parament (car procedure)) 96 | (body (cadr procedure)) 97 | (env (caddr procedure)) 98 | (newframe '())) 99 | (define (make-frame names values newframe) 100 | (cond ((and (null? names) (null? values)) newframe) 101 | ((or (null? names) (null? values)) (display "wrong number of args")) 102 | (else (cons 103 | (make-binding (car names) (car values)) 104 | (make-frame (cdr names) (cdr values) newframe))))) 105 | (begin (set! env (cons (make-frame parament argument newframe) env)) 106 | (my-eval body env)))) 107 | (define (call-primitive op argument) 108 | (op (car argument) (cadr argument))) 109 | (define env '()) 110 | (define global-frame '()) 111 | (define (init-env) 112 | (begin (set! global-frame (cons (make-binding '+ (list 'primitive +)) global-frame)) 113 | (set! global-frame (cons (make-binding '- (list 'primitive -)) global-frame)) 114 | (set! global-frame (cons (make-binding '/ (list 'primitive /)) global-frame)) 115 | (set! global-frame (cons (make-binding '* (list 'primitive *)) global-frame)) 116 | (set! env (cons global-frame '())))) 117 | 118 | 119 | -------------------------------------------------------------------------------- /n6blisp/interpret.scm: -------------------------------------------------------------------------------- 1 | (define (my-eval exp env) 2 | (cond ((immediate-data? exp) exp) 3 | ((variable? exp) (lookup-variable exp env)) 4 | ((quote? exp) (cadr exp)) 5 | ((assignment? exp) (set-variable (set-name exp) (set-value exp) env)) 6 | ((define? exp) (define-variable (define-name exp) (define-value exp env) env)) 7 | ((if? exp) (eval-if exp env)) 8 | ((lambda? exp) (eval-lambda exp env)) 9 | ((application? exp) 10 | (my-apply (my-eval (car exp) env) 11 | (make-args (cdr exp) env))) 12 | (else (display "known error")))) 13 | 14 | (define (immediate-data? exp) 15 | (or (number? exp) (string? exp) (boolean? exp))) 16 | (define (variable? exp) 17 | (symbol? exp)) 18 | (define (make-binding name value) 19 | (cons name value)) 20 | (define (lookup-variable-in-frame variable frame) 21 | (if (null? frame) 22 | '() 23 | (if (eq? (caar frame) variable) 24 | (cdar frame) 25 | (lookup-variable-in-frame variable (cdr frame))))) 26 | (define (lookup-variable variable env) 27 | (if (null? env) 28 | '() 29 | (let ((ret (lookup-variable-in-frame variable (car env)))) 30 | (if (null? ret) 31 | (lookup-variable variable (cdr env)) 32 | ret)))) 33 | (define (quote? exp) 34 | (tagged-list? exp 'quote)) 35 | (define (tagged-list? exp tag) 36 | (and (pair? exp) (eq? (car exp) tag))) 37 | (define (define? exp) 38 | (tagged-list? exp 'define)) 39 | (define (define-name exp) 40 | (cadr exp)) 41 | (define (define-value exp env) 42 | (my-eval (caddr exp) env)) 43 | (define (lookup-binding-in-frame frame name) 44 | (if (null? frame) 45 | '() 46 | (if (eq? (caar frame) name) 47 | (car frame) 48 | (lookup-binding-in-frame (cdr frame) name)))) 49 | (define (define-variable name value env) 50 | (let ((binding (lookup-binding-in-frame (car env) name))) 51 | (if (null? binding) 52 | (set-car! env (cons (make-binding name value) (car env))) 53 | (set-cdr! binding value)))) 54 | (define (set-variable name value env) 55 | (if (null? env) 56 | (display "error:variable not exist") 57 | (let ((binding (lookup-binding-in-frame (car env) name))) 58 | (if (null? binding) 59 | (set-variable name value (cdr env)) 60 | (set-cdr! binding value))))) 61 | 62 | (define (tagged-list? exp tag) 63 | (and (pair? exp) (eq? (car exp) tag))) 64 | 65 | (define (assignment? exp) 66 | (tagged-list? exp 'set!)) 67 | (define (set-name exp) 68 | (cadr exp)) 69 | (define (set-value exp) 70 | (caddr exp)) 71 | (define (if? exp) 72 | (tagged-list? exp 'if)) 73 | (define (eval-if exp env) 74 | (let ((if-part (cadr exp)) 75 | (then-part (caddr exp)) 76 | (else-part (cadddr exp))) 77 | (if (my-eval if-part env) 78 | (my-eval then-part env) 79 | (my-eval else-part env)))) 80 | (define (lambda? exp) 81 | (tagged-list? exp 'lambda)) 82 | (define (eval-lambda exp env) 83 | (let ((arg-part (cadr exp)) (body-part (caddr exp))) 84 | (list 'procedure arg-part body-part env))) 85 | (define (application? exp) (pair? exp)) 86 | (define (make-args list env) 87 | (if (null? list) 88 | '() 89 | (cons (my-eval (car list) env) 90 | (make-args (cdr list) env)))) 91 | (define (my-apply procedure argument) 92 | (cond ((tagged-list? procedure 'procedure) (call-procedure (cdr procedure) argument)) 93 | ((tagged-list? procedure 'primitive) (call-primitive (cadr procedure) argument)) 94 | (else (display "error:undefined procedure")))) 95 | (define (call-procedure procedure argument) 96 | (let ((parament (car procedure)) 97 | (body (cadr procedure)) 98 | (env (caddr procedure)) 99 | (newframe '())) 100 | (define (make-frame names values newframe) 101 | (cond ((and (null? names) (null? values)) newframe) 102 | ((or (null? names) (null? values)) (display "wrong number of args")) 103 | (else (cons 104 | (make-binding (car names) (car values)) 105 | (make-frame (cdr names) (cdr values) newframe))))) 106 | (begin (set! env (cons (make-frame parament argument newframe) env)) 107 | (my-eval body env)))) 108 | (define (call-primitive op argument) 109 | (op (car argument) (cadr argument))) 110 | (define env '()) 111 | (define global-frame '()) 112 | (define (init-env) 113 | (begin (set! global-frame (cons (make-binding '+ (list 'primitive +)) global-frame)) 114 | (set! global-frame (cons (make-binding '- (list 'primitive -)) global-frame)) 115 | (set! global-frame (cons (make-binding '/ (list 'primitive /)) global-frame)) 116 | (set! global-frame (cons (make-binding '* (list 'primitive *)) global-frame)) 117 | (set! env (cons global-frame '())))) 118 | 119 | 120 | (define (repl evaluator env) 121 | (display "repl>") 122 | (let ((expr (read))) 123 | (cond ((eof-object? expr) 124 | (display "byebye") 125 | (newline)) 126 | (else 127 | (write (evaluator expr env)) 128 | (newline) 129 | (repl evaluator))))) -------------------------------------------------------------------------------- /lisp2c.scm: -------------------------------------------------------------------------------- 1 | (func cps 2 | ast cc => (list cc ast) where (or (symbol? ast) (number? ast) (string? ast) (boolean? ast)) 3 | (list 'if a b c) cc => (cps a (let ((r1 (gensym))) 4 | (list 'lambda (list r1) 5 | (list 'if r1 6 | (cps b cc) 7 | (cps c cc))))) 8 | (list 'begin e1 e2) cc => (cps e1 (list 'lambda (list (gensym)) 9 | (cps e2 cc))) 10 | (list 'set! v e) cc => (cps e (let ((r1 (gensym))) 11 | (list 'lambda (list r1) 12 | (list cc (list 'set! v r1))))) 13 | (list 'lambda args e) cc => (let ((k (gensym))) 14 | (list cc (list 'lambda (cons k args) 15 | (cps e k)))) 16 | (list e) cc => (cps e (let ((r0 (gensym))) 17 | (list 'lambda (list r0) 18 | (list r0 cc)))) 19 | (list op x y) cc => (let ((r1 (gensym)) 20 | (r2 (gensym))) 21 | (cps x 22 | (list 'lambda (list r1) 23 | (cps y 24 | (list 'lambda (list r2) 25 | (list cc (list op r1 r2))))))) where 26 | (memq op '(= * + - / >)) 27 | (list e0 e1) cc => (cps e0 (let ((r0 (gensym)) 28 | (r1 (gensym))) 29 | (list 'lambda (list r0) 30 | (cps e1 31 | (list 'lambda (list r1) 32 | (list r0 cc r1))))))) 33 | 34 | (defun cps-convert (ast) 35 | (cps ast '(lambda (x) x))) 36 | 37 | ;; (define id (lambda (x) x)) 38 | 39 | ;; (cps '(set! fact 40 | ;; (lambda (n) 41 | ;; (if (= n 0) 42 | ;; 1 43 | ;; (* n (fact (- n 1))) 44 | ;; ))) 45 | ;; 'id) 46 | 47 | ;; (fact id 10) 48 | 49 | (func diff 50 | '() s2 => '() 51 | (cons x y) s2 => (if (memq x s2) 52 | (diff y s2) 53 | (cons x (diff y s2)))) 54 | 55 | (func union 56 | '() s2 => s2 57 | (cons x y) s2 => (if (memq x s2) 58 | (union y s2) 59 | (cons x (union y s2)))) 60 | 61 | (func free-vars 62 | ast => (list ast) where (symbol? ast) 63 | (list 'set! x v) => (union (free-vars v) (list x)) 64 | (list-rest 'if more) => (foldl union '() (map free-vars more)) 65 | (list 'lambda args e) => (diff (free-vars e) args) 66 | ast => (foldl union '() (map free-vars ast))) 67 | 68 | (func pos-in-list0 69 | x '() _ => -1 70 | x (cons y l) i => (if (eq? x y) 71 | i 72 | (pos-in-list0 x l (+ i 1)))) 73 | 74 | (defun pos-in-list (x l) (pos-in-list0 x l 0)) 75 | 76 | (defun not-global (x) (not (memq x '(+ - * / > < = eq?)))) 77 | 78 | (func convert 79 | ast self free => ast where (or (number? ast) (string? ast) (boolean? ast)) 80 | ast self free => 81 | (let ((pos (pos-in-list ast free))) 82 | (if (= pos -1) 83 | ast 84 | (list '%closure-ref self (+ pos 1)))) where (symbol? ast) 85 | (list 'set! x v) self free => (list 'set! x (convert v self free)) 86 | (list 'if a b c) self free => (list 'if (convert a self free) 87 | (convert b self free) 88 | (convert c self free)) 89 | (list 'lambda args e) self free => 90 | (let ((fv (filter not-global (free-vars (list 'lambda args e)))) 91 | (self-var (gensym)) 92 | (fn (lambda (x) (convert x self free)))) 93 | (let ((lam (list 'lambda (cons self-var args) 94 | (convert e self-var fv))) 95 | (new-fv (map fn fv))) 96 | (cons '%closure (cons lam new-fv)))) 97 | ;; an optimize, no need to closure-convert 98 | (list-rest (list 'lambda params body) args) self free => 99 | (cons (list 'lambda params (convert body self free)) 100 | (map (lambda (x) (convert x self free)) args)) 101 | (list-rest op args) self free => 102 | (cons op (map (lambda (x) (convert x self free)) args)) where (memq op '(+ - * / > < = eq?)) 103 | funcall self free => (cons '%apply (map (lambda (x) (convert x self free)) funcall))) 104 | 105 | (defun closure-convert (ast) 106 | (convert ast #f '())) 107 | -------------------------------------------------------------------------------- /nanopass/t.s: -------------------------------------------------------------------------------- 1 | /* 2 | (code 3 | (set! rcx r15) 4 | (set! rax rdx) 5 | (set! rdx (+ rdx 8)) 6 | (set! rax (+ rax 2)) 7 | (set! rbx rax) 8 | (set! rax f$1) 9 | (set! # rax) 10 | (set! rsi rbx) 11 | (set! rax rdx) 12 | (set! rdx (+ rdx 24)) 13 | (set! rax (+ rax 2)) 14 | (set! rbx rax) 15 | (set! rax g$4) 16 | (set! # rax) 17 | (set! # rsi) 18 | (set! # rbx) 19 | (set! rax #) 20 | (set! r9 48) 21 | (set! r8 rbx) 22 | (set! r15 rcx) 23 | (jump rax) 24 | g$4 25 | (set! # r15) 26 | (set! # r8) 27 | (set! rsi r9) 28 | (if (= rsi 0) (jump c$49)) 29 | (jump a$50) 30 | anon$6 31 | (set! # r15) 32 | (set! rcx r8) 33 | (set! rsi r9) 34 | (set! rax #) 35 | (set! rax #) 36 | (set! # rax) 37 | (set! rax #) 38 | (set! rbx #) 39 | (set! rbp (+ rbp 16)) 40 | (set! r8 rsi) 41 | (set! r9 rbx) 42 | (set! r15 rp$32) 43 | (jump rax) 44 | f$1 45 | (set! rcx r15) 46 | (set! rax r8) 47 | (set! rbx r9) 48 | (set! rax rdx) 49 | (set! rdx (+ rdx 16)) 50 | (set! rax (+ rax 2)) 51 | (set! rsi rax) 52 | (set! rax anon$6) 53 | (set! # rax) 54 | (set! rax rsi) 55 | (set! # rbx) 56 | (jump rcx) 57 | c$49 58 | (set! rax 22) 59 | (jump #) 60 | a$50 61 | (set! rax #) 62 | (set! rbx #) 63 | (set! rcx #) 64 | (set! rax #) 65 | (set! rbx #) 66 | (set! rax rsi) 67 | (set! rax (- rax 8)) 68 | (set! rbp (+ rbp 16)) 69 | (set! r8 rbx) 70 | (set! r9 rax) 71 | (set! r15 rp$34) 72 | (jump rcx) 73 | rp$34 74 | (set! rbp (- rbp 16)) 75 | (set! rbx rax) 76 | (set! rcx #) 77 | (set! rax #) 78 | (set! rsi #) 79 | (set! r9 rsi) 80 | (set! r8 rbx) 81 | (set! r15 #) 82 | (jump rcx) 83 | rp$32 84 | (set! rbp (- rbp 16)) 85 | (set! rcx rax) 86 | (set! rax rdx) 87 | (set! rdx (+ rdx 16)) 88 | (set! rax (+ rax 1)) 89 | (set! rbx rax) 90 | (set! rax #) 91 | (set! # rax) 92 | (set! # rax) 93 | (set! # rcx) 94 | (set! rax rbx) 95 | (jump #)) 96 | */ 97 | 98 | 99 | .globl _scheme_entry 100 | _scheme_entry: 101 | pushq %rbx 102 | pushq %rbp 103 | pushq %r12 104 | pushq %r13 105 | pushq %r14 106 | pushq %r15 107 | movq %rdi, %rbp 108 | movq %rsi, %rdx 109 | leaq _scheme_exit(%rip), %r15 110 | movq %r15, %rcx 111 | movq %rdx, %rax 112 | addq $8, %rdx 113 | addq $2, %rax 114 | movq %rax, %rbx 115 | leaq L1(%rip), %rax 116 | movq %rax, -2(%rbx) 117 | movq %rbx, %rsi 118 | movq %rdx, %rax 119 | addq $24, %rdx 120 | addq $2, %rax 121 | movq %rax, %rbx 122 | leaq L4(%rip), %rax 123 | movq %rax, -2(%rbx) 124 | movq %rsi, 6(%rbx) 125 | movq %rbx, 14(%rbx) 126 | movq -2(%rbx), %rax 127 | movq $48, %r9 128 | movq %rbx, %r8 129 | movq %rcx, %r15 130 | jmp *%rax 131 | L4: 132 | movq %r15, 8(%rbp) 133 | movq %r8, 0(%rbp) 134 | movq %r9, %rsi 135 | cmpq $0, %rsi 136 | je L49 137 | jmp L50 138 | L6: 139 | movq %r15, 8(%rbp) 140 | movq %r8, %rcx 141 | movq %r9, %rsi 142 | movq 0(%rbp), %rax 143 | movq 6(%rcx), %rax 144 | movq %rax, 0(%rbp) 145 | movq -2(%rsi), %rax 146 | movq 6(%rcx), %rbx 147 | addq $16, %rbp 148 | movq %rsi, %r8 149 | movq %rbx, %r9 150 | leaq L32(%rip), %r15 151 | jmp *%rax 152 | L1: 153 | movq %r15, %rcx 154 | movq %r8, %rax 155 | movq %r9, %rbx 156 | movq %rdx, %rax 157 | addq $16, %rdx 158 | addq $2, %rax 159 | movq %rax, %rsi 160 | leaq L6(%rip), %rax 161 | movq %rax, -2(%rsi) 162 | movq %rsi, %rax 163 | movq %rbx, 6(%rax) 164 | jmp *%rcx 165 | L49: 166 | movq $22, %rax 167 | jmp *8(%rbp) 168 | L50: 169 | movq 0(%rbp), %rax 170 | movq 6(%rax), %rbx 171 | movq -2(%rbx), %rcx 172 | movq 0(%rbp), %rax 173 | movq 6(%rax), %rbx 174 | movq %rsi, %rax 175 | subq $8, %rax 176 | addq $16, %rbp 177 | movq %rbx, %r8 178 | movq %rax, %r9 179 | leaq L34(%rip), %r15 180 | jmp *%rcx 181 | L34: 182 | subq $16, %rbp 183 | movq %rax, %rbx 184 | movq -2(%rbx), %rcx 185 | movq 0(%rbp), %rax 186 | movq 14(%rax), %rsi 187 | movq %rsi, %r9 188 | movq %rbx, %r8 189 | movq 8(%rbp), %r15 190 | jmp *%rcx 191 | L32: 192 | subq $16, %rbp 193 | movq %rax, %rcx 194 | movq %rdx, %rax 195 | addq $16, %rdx 196 | addq $1, %rax 197 | movq %rax, %rbx 198 | movq 0(%rbp), %rax 199 | movq %rax, -1(%rbx) 200 | movq %rax, 0(%rbp) 201 | movq %rcx, 7(%rbx) 202 | movq %rbx, %rax 203 | jmp *8(%rbp) 204 | _scheme_exit: 205 | popq %r15 206 | popq %r14 207 | popq %r13 208 | popq %r12 209 | popq %rbp 210 | popq %rbx 211 | ret 212 | -------------------------------------------------------------------------------- /zen/emit.ss: -------------------------------------------------------------------------------- 1 | (define idSTOP 1) 2 | (define idPUSHMARK 2) 3 | (define idCONST 3) 4 | (define idPUSH 4) 5 | (define idCLOSURE 5) 6 | (define idAPPLY 6) 7 | (define idGRAB 7) 8 | (define idRESTART 8) 9 | (define idACCESS 9) 10 | (define idADDINT 11) 11 | (define idRETURN 12) 12 | (define idBRANCH 13) 13 | (define idBRANCHIF 14) 14 | (define idEQ 15) 15 | (define idSUBINT 16) 16 | (define idMULINT 17) 17 | (define idDIVINT 18) 18 | (define idMAKEBLOCK 19) 19 | (define idGETFIELD 20) 20 | (define idSWITCH 21) 21 | (define idCCALL 22) 22 | (define idSTRING 23) 23 | (define idASSIGN 24) 24 | (define idLET 25) 25 | (define idENDLET 26) 26 | (define idLOAD 27) 27 | 28 | (define (put-u32 p u) 29 | (let ((v0 (bitwise-and u 255)) 30 | (v1 (bitwise-and (bitwise-arithmetic-shift-right u 8) 255)) 31 | (v2 (bitwise-and (bitwise-arithmetic-shift-right u 16) 255)) 32 | (v3 (bitwise-and (bitwise-arithmetic-shift-right u 24) 255))) 33 | (put-u8 p v0) 34 | (put-u8 p v1) 35 | (put-u8 p v2) 36 | (put-u8 p v3))) 37 | 38 | (define (put-u64 p u) 39 | (let ((v0 (bitwise-and u 4294967295)) 40 | (v1 (bitwise-and (bitwise-arithmetic-shift-right u 32) 4294967295))) 41 | (put-u32 p v0) 42 | (put-u32 p v1))) 43 | 44 | (define (ByteBuffer op g) (tuple ByteBuffer op g)) 45 | (define (ByteBuffer.op x) 46 | (case x (ByteBuffer (field 0 x)))) 47 | (define (ByteBuffer.g x) 48 | (case x (ByteBuffer (field 1 x)))) 49 | (define (ByteBuffer->bytevector x) ((ByteBuffer.g x))) 50 | 51 | ;; 接受一个inst的列表，将它们全部emit后放到一块buffer，并不关闭 52 | (define (emit-inst-list ls) 53 | (let-values (((op g) (open-bytevector-output-port))) 54 | (for-each 55 | (lambda (x) 56 | (emit-inst op x)) 57 | ls) 58 | (ByteBuffer op g))) 59 | 60 | ;; 将ByteBuffer列表转化成bytevector列表，并且在里面插入该跳转的偏移 61 | (define (fnbuf l) 62 | (define (loop ls) 63 | (if (null? ls) 0 64 | (if (null? (cdr ls)) 65 | (port-output-size (ByteBuffer.op (car ls))) 66 | (let ((ofst (loop (cdr ls))) 67 | (p (ByteBuffer.op (car ls)))) 68 | (put-u8 p idBRANCH) 69 | (put-u32 p ofst) 70 | (+ ofst (port-output-size p)))))) 71 | (loop l) 72 | (map ByteBuffer->bytevector l)) 73 | 74 | (define (str->bv s) 75 | (let ([tx (make-transcoder (utf-8-codec) (eol-style none) 76 | (error-handling-mode raise))]) 77 | (string->bytevector s tx))) 78 | 79 | (define (emit-inst p x) 80 | (case x 81 | (IConst 82 | (begin (put-u8 p idCONST) 83 | (put-u64 p (field 0 x)))) 84 | (IBool 85 | (begin (put-u8 p idCONST) 86 | (put-u64 p (if (field 0 x) 18 34)))) 87 | (IString 88 | (let ((n (string-length (field 0 x)))) 89 | (put-u8 p idSTRING) 90 | (put-u32 p n) 91 | (put-bytevector p (str->bv (field 0 x))) 92 | (put-u8 p 0))) 93 | (ICCall 94 | (begin (put-u8 p idCCALL) 95 | (put-u32 p (field 0 x)))) 96 | (ILoad (put-u8 p idLOAD)) 97 | (IStop (put-u8 p idSTOP)) 98 | (IApply (put-u8 p idAPPLY)) 99 | (IPlus (put-u8 p idADDINT)) 100 | (ISub (put-u8 p idSUBINT)) 101 | (IMul (put-u8 p idMULINT)) 102 | (IDiv (put-u8 p idDIVINT)) 103 | (IEqual (put-u8 p idEQ)) 104 | (IReturn (put-u8 p idRETURN)) 105 | (IClosure 106 | (let-values (((op g) (open-bytevector-output-port))) 107 | (for-each (lambda (x) (emit-inst op x)) (field 0 x)) 108 | (put-u8 p idCLOSURE) 109 | (let ((bv (g))) 110 | (put-u32 p (bytevector-length bv)) 111 | (put-bytevector p bv)))) 112 | (IGrab 113 | (let loop ((i 0) 114 | (n (field 0 x))) 115 | (if (< i n) 116 | (begin 117 | (put-u8 p idGRAB) 118 | (loop (+ i 1) n))))) 119 | (IPushMark (put-u8 p idPUSHMARK)) 120 | (IAccess 121 | (begin (put-u8 p idACCESS) 122 | (put-u8 p (field 0 x)))) 123 | (IBranch 124 | (let-values (((op1 g1) (open-bytevector-output-port)) 125 | ((op2 g2) (open-bytevector-output-port))) 126 | (for-each (lambda (x) (emit-inst op1 x)) (field 0 x)) 127 | (for-each (lambda (x) (emit-inst op2 x)) (field 1 x)) 128 | (let ((bv1 (g1)) 129 | (bv2 (g2))) 130 | (put-u8 p idBRANCHIF) 131 | (put-u32 p (+ 5 (bytevector-length bv2))) 132 | (put-bytevector p bv2) 133 | (put-u8 p idBRANCH) 134 | (put-u32 p (bytevector-length bv1)) 135 | (put-bytevector p bv1)))) 136 | (IEqual (put-u8 p idEQ)) 137 | (IMakeTuple 138 | (begin (put-u8 p idMAKEBLOCK) 139 | (put-u32 p (field 0 x)) 140 | (put-u32 p (field 1 x)))) 141 | (ILet 142 | (begin (put-u8 p idLET) 143 | (put-u8 p (field 0 x)))) 144 | (IEndLet 145 | (begin (put-u8 p idENDLET) 146 | (put-u8 p (field 0 x)))) 147 | (ISet 148 | (begin (put-u8 p idASSIGN) 149 | (put-u8 p (field 0 x)))) 150 | )) 151 | -------------------------------------------------------------------------------- /minilang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/match) 4 | 5 | ;; Evaluation toggles between eval and apply. 6 | 7 | ; eval dispatches on the type of expression: 8 | (define (eval exp env) 9 | (match exp 10 | [(? symbol?) (env-lookup env exp)] 11 | [(? number?) exp] 12 | [(? boolean?) exp] 13 | [`(if ,ec ,et ,ef) (if (eval ec env) 14 | (eval et env) 15 | (eval ef env))] 16 | [`(letrec ,binds ,eb) (eval-letrec binds eb env)] 17 | [`(let ,binds ,eb) (eval-let binds eb env)] 18 | [`(lambda ,vs ,e) `(closure ,exp ,env)] 19 | [`(set! ,v ,e) (env-set! env v e)] 20 | [`(begin ,e1 ,e2) (begin (eval e1 env) 21 | (eval e2 env))] 22 | [`(,f . ,args) (apply-proc 23 | (eval f env) 24 | (map (eval-with env) args))])) 25 | 26 | ; a handy wrapper for Currying eval: 27 | (define (eval-with env) 28 | (lambda (exp) (eval exp env))) 29 | 30 | ; eval for letrec: 31 | (define (eval-letrec bindings body env) 32 | (let* ((vars (map car bindings)) 33 | (exps (map cadr bindings)) 34 | (fs (map (lambda _ #f) bindings)) 35 | (env* (env-extend* env vars fs)) 36 | (vals (map (eval-with env*) exps))) 37 | (env-set!* env* vars vals) 38 | (eval body env*))) 39 | 40 | ; eval for let: 41 | (define (eval-let bindings body env) 42 | (let* ((vars (map car bindings)) 43 | (exps (map cadr bindings)) 44 | (vals (map (eval-with env) exps)) 45 | (env* (env-extend* env vars vals))) 46 | (eval body env*))) 47 | 48 | ; applies a procedure to arguments: 49 | (define (apply-proc f values) 50 | (match f 51 | [`(closure (lambda ,vs ,body) ,env) 52 | ; => 53 | (eval body (env-extend* env vs values))] 54 | 55 | [`(primitive ,p) 56 | ; => 57 | (apply p values)])) 58 | 59 | ;; Environments map variables to mutable cells 60 | ;; containing values. 61 | 62 | (define-struct cell ([value #:mutable])) 63 | 64 | ; empty environment: 65 | (define (env-empty) (hash)) 66 | 67 | ; initial environment, with bindings for primitives: 68 | (define (env-initial) 69 | (env-extend* 70 | (env-empty) 71 | '(+ - / * <= void display newline) 72 | (map (lambda (s) (list 'primitive s)) 73 | `(,+ ,- ,/ ,* ,<= ,void ,display ,newline)))) 74 | 75 | ; looks up a value: 76 | (define (env-lookup env var) 77 | (cell-value (hash-ref env var))) 78 | 79 | ; sets a value in an environment: 80 | (define (env-set! env var value) 81 | (set-cell-value! (hash-ref env var) value)) 82 | 83 | ; extends an environment with several bindings: 84 | (define (env-extend* env vars values) 85 | (match `(,vars ,values) 86 | [`((,v . ,vars) (,val . ,values)) 87 | ; => 88 | (env-extend* (hash-set env v (make-cell val)) vars values)] 89 | 90 | [`(() ()) 91 | ; => 92 | env])) 93 | 94 | ; mutates an environment with several assignments: 95 | (define (env-set!* env vars values) 96 | (match `(,vars ,values) 97 | [`((,v . ,vars) (,val . ,values)) 98 | ; => 99 | (begin 100 | (env-set! env v val) 101 | (env-set!* env vars values))] 102 | 103 | [`(() ()) 104 | ; => 105 | (void)])) 106 | 107 | ;; Evaluation tests. 108 | 109 | ; define new syntax to make tests look prettier: 110 | (define-syntax 111 | test-eval 112 | (syntax-rules (====) 113 | [(_ program ==== value) 114 | (let ((result (eval (quote program) (env-initial)))) 115 | (when (not (equal? program value)) 116 | (error "test failed!")))])) 117 | 118 | (test-eval 119 | ((lambda (x) (+ 3 4)) 20) 120 | ==== 121 | 7) 122 | 123 | (test-eval 124 | (letrec ((f (lambda (n) 125 | (if (<= n 1) 126 | 1 127 | (* n (f (- n 1))))))) 128 | (f 5)) 129 | ==== 130 | 120) 131 | 132 | (test-eval 133 | (let ((x 100)) 134 | (begin 135 | (set! x 20) 136 | x)) 137 | ==== 138 | 20) 139 | 140 | (test-eval 141 | (let ((x 1000)) 142 | (begin (let ((x 10)) 143 | 20) 144 | x)) 145 | ==== 146 | 1000) 147 | 148 | ;; Programs are translated into a single letrec expression. 149 | 150 | (define (define->binding define) 151 | (match define 152 | [`(define (,f . ,formals) ,body) 153 | ; => 154 | `(,f (lambda ,formals ,body))] 155 | 156 | [`(define ,v ,value) 157 | ; => 158 | `(,v ,value)] 159 | 160 | [else 161 | ; => 162 | `(,(gensym) ,define)])) 163 | 164 | (define (transform-top-level defines) 165 | `(letrec ,(map define->binding defines) 166 | (void))) 167 | 168 | (define (eval-program program) 169 | (eval (transform-top-level program) (env-initial))) 170 | 171 | (define (read-all) 172 | (let ((next (read))) 173 | (if (eof-object? next) 174 | '() 175 | (cons next (read-all))))) 176 | 177 | ; read in a program, and evaluate: 178 | (eval-program (read-all)) 179 | -------------------------------------------------------------------------------- /ukanren.cora: -------------------------------------------------------------------------------- 1 | ;; blog link: https://www.zenlife.tk/micro-kanren.md 2 | 3 | (@import "cora/lib/string" string) 4 | 5 | (defun procedure? (x) 6 | (and (cons? x) 7 | (= (car x) 'lambda))) 8 | 9 | (defun var (c) 10 | (let v (vector 1) 11 | (vector-set! v 0 c))) 12 | 13 | (set 'var? vector?) 14 | 15 | (defun var=? (x y) 16 | (= (vector-ref x 0) (vector-ref y 0))) 17 | 18 | (func assp 19 | pred [] => [] 20 | pred [x . y] => (if (pred x) 21 | x 22 | (assp pred y))) 23 | 24 | (defun walk (u s) 25 | (if (var? u) 26 | (let pr (assp (lambda (v) (var=? u (car v))) s) 27 | (if (null? pr) 28 | u 29 | (walk (cdr pr) s))) 30 | u)) 31 | 32 | ;; (set 'tmp [[(var 'z) . (var 'a)] [(var 'x) . (var 'w)] [(var 'y) . (var 'z)]]) 33 | ;; (walk (var 'y) tmp) 34 | ;; (set 'tmp [[(var 'x) . (var 'y)] [(var 'y) . (var 'z)] [(var 'z) . (var 'x)]]) 35 | ;; (walk (var 'x)) ;; deadlock 36 | 37 | (defun ext-s (x v s) 38 | (cons (cons x v) s)) 39 | 40 | (defun unify (u v s) 41 | (unify1 (walk u s) (walk v s) s)) 42 | 43 | (func unify1 44 | u v s => s where (and (var? u) (var? v) (var=? u v)) 45 | u v s => (ext-s u v s) where (var? u) 46 | u v s => (ext-s v u s) where (var? v) 47 | [u1 . u2] [v1 . v2] s => 48 | (let s1 (unify u1 v1 s) 49 | (if (null? s1) 50 | () 51 | (unify u2 v2 s1))) 52 | u v s => (if (= u v) s ())) 53 | 54 | (defun == (u v) 55 | (lambda (state) 56 | (let subst (car state) 57 | free-var-idx (cdr state) 58 | (let s1 (unify u v subst) 59 | (if (null? s1) 60 | () 61 | (cons [s1 . free-var-idx] ())))))) 62 | 63 | (defun call/fresh (f) 64 | (lambda (state) 65 | (let subst (car state) 66 | c (cdr state) 67 | (let new-goal (f (var c)) 68 | new-state [subst . (+ c 1)] 69 | (new-goal new-state))))) 70 | 71 | (defun disj (g1 g2) 72 | (lambda (state) 73 | (mplus (g1 state) (g2 state)))) 74 | 75 | (defun conj (g1 g2) 76 | (lambda (state) 77 | (bind (g1 state) g2))) 78 | 79 | ;; (conde (g0 g) ...) 80 | (defmacro conde (input) 81 | ['disj+ . (map (lambda (x) (cons 'conj+ x)) (cdr input))]) 82 | 83 | (func mplus 84 | [] x => x 85 | x y => (lambda () (mplus y (x))) where (procedure? x) 86 | [h . t] z => (cons h (mplus t z))) 87 | 88 | (func bind 89 | [] _ => () 90 | x y => (lambda () (bind (x) y)) where (procedure? x) 91 | [h . t] y => (mplus (y h) (bind t y))) 92 | 93 | (defmacro Zzz (input) 94 | (let g (cadr input) 95 | state (gensym) 96 | ['lambda [state] 97 | ['lambda [] 98 | [g state]]])) 99 | 100 | (func conj+-macro 101 | [g] => ['Zzz g] 102 | [g . g1] => ['conj ['Zzz g] (conj+-macro g1)]) 103 | 104 | (defmacro conj+ (input) 105 | (conj+-macro (cdr input))) 106 | 107 | (func disj+-macro 108 | [g] => ['Zzz g] 109 | [g . g1] => ['disj ['Zzz g] (disj+-macro g1)]) 110 | 111 | (defmacro disj+ (input) 112 | (disj+-macro (cdr input))) 113 | 114 | (func fresh-macro 115 | [] body => (cons 'conj+ body) 116 | [x . l] body => ['call/fresh 117 | ['lambda [x] 118 | (fresh-macro l body)]]) 119 | 120 | ;; (fresh (x y z) g) 121 | ;; (call/freesh (lambda (x) 122 | ;; (call/fresh (lambda (y) 123 | ;; (call/fresh (lambda (z) g)))))) 124 | 125 | (defmacro fresh (input) 126 | (fresh-macro (cadr input) (cddr input))) 127 | 128 | ((fresh (x y z) 129 | (disj+ (== x 0) (== y 1) (== z x))) (cons () 0)) 130 | 131 | ;; reify related 132 | 133 | (defun pull (stream) 134 | (if (procedure? stream) 135 | (pull (stream)) 136 | stream)) 137 | 138 | (defun take-all (stream) 139 | (take-all-h (pull stream))) 140 | 141 | (func take-all-h 142 | [] => [] 143 | [h . t] => [h . (take-all t)]) 144 | 145 | (func take 146 | 0 s => [] 147 | n s => (take-h n (pull s))) 148 | 149 | (func take-h 150 | 0 s => [] 151 | n [] => [] 152 | n [h . t] => [h . (take (- n 1) t)]) 153 | 154 | (func walk*-h 155 | v s => v where (var? v) 156 | [h . t] s => [(walk* h s) . (walk* t s)] 157 | v s => v) 158 | 159 | (defun walk* (v s) 160 | (walk*-h (walk v s) s)) 161 | 162 | (defun reify (s) 163 | (map reify-state s)) 164 | 165 | (defun reify-state (state) 166 | (let v (walk* (var 0) (car state)) 167 | (walk* v (reify-s v ())))) 168 | 169 | (func reify-s-h 170 | v s => (cons [v . (reify-name (length s))] s) where (var? v) 171 | [h . t] s => (reify-s t (reify-s h s)) 172 | _ s => s) 173 | 174 | (defun reify-s (v subst) 175 | (reify-s-h (walk v subst) subst)) 176 | 177 | (defun reify-name (n) 178 | (intern 179 | (string.append "_." (number->string n)))) 180 | 181 | (set 'empty-state (cons () 0)) 182 | (defun call/empty-state (g) 183 | (g empty-state)) 184 | 185 | 186 | ;; (run * (x ...) g0 g ...) 187 | ;; (run n (x ...) g0 g ...) 188 | (defmacro run (input) 189 | (let n (cadr input) 190 | xs (caddr input) 191 | g (cdddr input) 192 | (if (= n '*) 193 | ['reify ['take-all ['call/empty-state 194 | ['fresh xs . g]]]] 195 | ['reify ['take n ['call/empty-state 196 | ['fresh xs . g]]]]))) 197 | -------------------------------------------------------------------------------- /scheme2c.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (define (atom? exp) (not (pair? exp))) 3 | (define (make-cont num) 4 | (string->symbol (string-append "k" (number->string num)))) 5 | (define (cps-convert exp level) 6 | (if (atom? exp) 7 | `(,(make-cont level) ,exp) 8 | (case (car exp) 9 | ((set!) (cps-convert-set (cdr exp) level)) 10 | ((if) (cps-convert-if (cdr exp) level)) 11 | ((begin) (cps-convert-begin (cdr exp) level)) 12 | ((lambda) (cps-convert-lambda (cdr exp) level)) 13 | ((define) (cps-convert-define (cdr exp) level)) 14 | (else 15 | (cps-convert-application exp level))))) 16 | 17 | (define (cps-convert-set exp level) 18 | (let ((name (car exp)) 19 | (value (cadr exp)) 20 | (cc (make-cont (+ level 1)))) 21 | `(let ((,cc (lambda (v) (,(make-cont level) (set! ,name v))))) 22 | ,(cps-convert value (+ level 1))))) 23 | (define (cps-convert-define exp level) 24 | (let ((name (car exp)) 25 | (value (cadr exp)) 26 | (cc (make-cont (+ level 1)))) 27 | `(let ((,cc (lambda (v) (,(make-cont level) (define ,name v))))) 28 | ,(cps-convert value (+ level 1))))) 29 | 30 | (define (cps-convert-if exp level) 31 | (let ((test (car exp)) 32 | (etrue (cadr exp)) 33 | (efalse (caddr exp))) 34 | `(let ((,(make-cont (+ level 1)) 35 | (lambda (v) 36 | (if v 37 | ,(cps-convert etrue level) 38 | ,(cps-convert efalse level))))) 39 | ,(cps-convert test (+ level 1))))) 40 | 41 | (define (cps-convert-begin exp level) 42 | (if (pair? exp) 43 | (if (null? (cdr exp)) 44 | (cps-convert (car exp) level) 45 | `(let ((,(make-cont (+ level 1)) 46 | (lambda (v) 47 | ,(cps-convert-begin (cdr exp) level)))) 48 | ,(cps-convert (car exp) (+ level 1)))) 49 | (if (not (null? exp)) 50 | (error "wrong form of begin") 51 | `(,(make-cont level) scheme-null-object)))) 52 | 53 | (define (cps-convert-lambda exp level) 54 | (let ((args (car exp)) 55 | (body (cdr exp))) 56 | `(,(make-cont level) (lambda ,(cons (make-cont (+ level 1)) args) ,(cps-convert-begin body (+ level 1)))))) 57 | 58 | (define (cps-convert-application exp level) 59 | (if (primitive? (car exp)) 60 | (cps-convert-argument (car exp) (cdr exp) 0 level #t) 61 | (cps-convert-argument (car exp) (cdr exp) 0 level #f))) 62 | 63 | (define (make-args number) 64 | (let loop ((i 0) 65 | (lst '())) 66 | (let ((v (string->symbol (string-append "v" (number->string i))))) 67 | (if (= i number) 68 | (reverse lst) 69 | (loop (+ i 1) (cons v lst)))))) 70 | 71 | (define (cps-convert-argument func args number level primitive?) 72 | (if (null? args) 73 | (if primitive? 74 | `(,(make-cont level) (,func ,@(make-args number))) 75 | (cond ((atom? func) 76 | `(,func ,(make-cont level) ,@(make-args number))) 77 | ;; ((eqv? (car func) 'lambda) 78 | ;; (error "not implement yet")) 79 | (else 80 | `(let ((,(make-cont (+ level 1)) 81 | (lambda (v) 82 | (v ,(make-cont level) ,@(make-args number))))) 83 | ,(cps-convert func (+ level 1)))))) 84 | `(let ((,(make-cont (+ level 1)) 85 | (lambda ,(list (string->symbol (string-append "v" (number->string number)))) 86 | ,(cps-convert-argument func (cdr args) (+ number 1) level primitive?)))) 87 | ,(cps-convert (car args) (+ level 1))))) 88 | 89 | (define (primitive? exp) 90 | (memv exp '(+ - * /))) 91 | 92 | (define c-function-count 0) 93 | (define c-function-list '()) 94 | 95 | (define *value* "value_register") 96 | (define *env* "env_register") 97 | (define *func* "func_register") 98 | 99 | (define (c-store target value) (c target " = " value ";")) 100 | (define (c-repr exp) 101 | (define symbol-map ;; map to create legal C names. 102 | '((#\- . #\_) (#\/ . #\S) (#\? . #\P) (#\> . #\G) (#\< . #\L) (#\= . #\E) 103 | (#\! . #\1) (#\+ . #\A) (#\* . #\C) (#\/ . #\D) (#\% . #\F))) 104 | (define (symbol-fix str pos) 105 | (if (= pos (string-length str)) '() 106 | (let ((a (assoc (string-ref str pos) symbol-map))) 107 | (cons (if a (cdr a) (string-ref str pos)) 108 | (symbol-fix str (+ 1 pos)))))) 109 | (cond ((number? exp) (number->string (* 4 exp))) 110 | ((symbol? exp) (list->string (symbol-fix (symbol->string exp) 0))) 111 | ((char? exp) (number->string (* 4 (char->integer exp)))) 112 | (else exp))) 113 | (define (c . strs) ;; generalized string-append 114 | (define (str-app str1 rest) 115 | (if (null? rest) (if (string? str1) str1 (c-repr str1)) 116 | (string-append (if (string? str1) str1 (c-repr str1)) 117 | (str-app (car rest) (cdr rest))))) 118 | (str-app (car strs) (cdr strs))) 119 | 120 | (define (compile exp env) 121 | (if (atom? exp) 122 | (cond ((symbol? exp) (compile-symbol exp)) 123 | ((number? exp) (c *value* "=" number ";")) 124 | 125 | 126 | 127 | (c *value* "=env_ref(" *env* "," i "," j ");")) 128 | -------------------------------------------------------------------------------- /infer.cora: -------------------------------------------------------------------------------- 1 | (@import "cora/lib/sys") 2 | 3 | (func apply-subst 4 | 'int s => 'int 5 | 'bool s => 'bool 6 | [a '-> b] s => [(apply-subst a s) '-> (apply-subst b s)] 7 | ['list a] s => ['list (apply-subst a s)] 8 | v s => (let find (assq v s) 9 | (if (null? find) 10 | v 11 | (cdr find)))) 12 | 13 | ;; (apply-subst '(4 -> int) '[[1 . int] [2 . bool] [3 . [int -> int]]]) 14 | ;; (apply-subst '6 '()) 15 | ;; (apply-subst '1 '()) 16 | 17 | (func occur? 18 | 'int _ => false 19 | 'bool _ => false 20 | [a '-> b] t => (or (occur? a t) (occur? b t)) 21 | ['list a] t => (occure? a t) 22 | v t => (= v t)) 23 | 24 | (defun unify (x y s) 25 | (unify1 (apply-subst x s) (apply-subst y s) s)) 26 | 27 | (func unify1 28 | x y s => s where (= x y) 29 | x y s => [[x . y] . s] where (and (number? x) (not (occur? x y))) 30 | x y s => [[y . x] . s] where (and (number? y) (not (occur? y x))) 31 | [a '-> b] [c '-> d] s => (let s1 (unify a c s) 32 | (unify b d s1)) 33 | ['list a] ['list b] s => (unify a b s)) 34 | 35 | (set '*tvar* 1000) 36 | (defun tvar () 37 | (let ret *tvar* 38 | (do (set '*tvar* (+ ret 1)) 39 | ret))) 40 | 41 | (defun extend (env v x) 42 | (cons (cons v x) env)) 43 | 44 | (func infer 45 | x env s => ['int s] where (number? x) 46 | x env s => ['bool s] where (boolean? x) 47 | x env s => (let find (assq x env) 48 | (if (null? find) 49 | (error "variable not bound") 50 | [(cdr find) s])) where (symbol? x) 51 | ['if e1 e2 e3] env s => (match (infer e1 env s) 52 | [t1 s1] 53 | (let s2 (unify 'bool t1 s1) 54 | (match (infer e2 env s2) 55 | [t2 s3] 56 | (match (infer e3 env s3) 57 | [t3 s4] 58 | [t2 (unify t2 t3 s4)])))) 59 | ['/. x e] env s => (let tx (tvar) 60 | (match (infer e (extend env x tx) s) 61 | [te s1] [[tx '-> te] s1])) 62 | [f g] env s => (match (infer f env s) 63 | [tf s1] 64 | (match (infer g env s1) 65 | [tg s2] 66 | (let tr (tvar) 67 | [tr (unify tf [tg '-> tr] s2)])))) 68 | 69 | (defun init-tenv () 70 | [['* . '(int -> (int -> int))] 71 | ['+ . '(int -> (int -> int))] 72 | ['- . '(int -> (int -> int))] 73 | ['= . '(int -> (int -> bool))] 74 | ['> . '(int -> (int -> bool))]]) 75 | 76 | ;; (infer '(if true 1 false) () ()) => fail 77 | ;; (infer 1 () ()) => (int ()) 78 | ;; (infer '(/. x x) () ()) 79 | ;; (infer '(/. t (if true (/. x x) t)) '() '()) => ((1000 -> (1001 -> 1001)) ((1000 1001 -> 1001))) 80 | ;; (infer '((/. x (/. y x)) 1) () ()) => (1005 ((1005 1004 -> int) (1003 . int))) 81 | ;; (infer '((/. x (/. y y)) 1) () ()) 82 | ;; (infer '(/. x (/. y (if x 1 2))) (init-tenv) '()) 83 | ;; (infer '((+ 1) 2) (init-tenv) '()) 84 | ;; (infer '(/. f (/. g (f (g 1)))) () ()) 85 | ;; (infer '(/. f (/. x (f (x 1)))) () ()) => ((1000 -> (1001 -> 1003)) ((1000 1002 -> 1003) (1001 int -> 1002))) 86 | 87 | 88 | (func check-type 89 | x t env s => (unify 'int t s) where (number? x) 90 | x t env s => (unify 'bool t s) where (boolean? x) 91 | x t env s => (let find (assq x env) 92 | (if (null? find) 93 | (error "variable not bound") 94 | (unify (cdr find) t s))) where (symbol? x) 95 | () t env s => (let a (tvar) 96 | (unify t ['list a] s)) 97 | ['cons x y] t env s => (let a (tvar) 98 | (let s1 (check-type x a env s) 99 | (let s2 (unify t ['list a] s1) 100 | (check-type y ['list a] env s2)))) 101 | ['if e1 e2 e3] t env s => (let s1 (check-type e1 'bool env s) 102 | (let _ (check-type e2 t env s1) 103 | (check-type e3 t env s1))) 104 | ['/. x e] [a '-> b] env s => (check-type e b (extend env x a) s) 105 | [f g] b env s => (let a (tvar) 106 | (let s1 (check-type g a env s) 107 | (check-type f [a '-> b] env s1)))) 108 | 109 | 110 | 111 | ;; (check-type '((* 1) 0) 'int (init-tenv) ()) 112 | ;; (check-type '(/. x ((* 3) x)) '(int -> int) (init-tenv) ()) 113 | ;; (check-type '(/. x x) '(1 -> 1) () ()) 114 | ;; (check-type '(/. x (if true 0 1)) '(int -> int) () ()) 115 | ;; (check-type '((/. x (if ((= x) 5) 0 1)) 6) 'int (init-tenv) ()) 116 | ;; (check-type '(/. x (if ((= x) 0) 117 | ;; 1 118 | ;; ((* x) (f ((- x) 1))))) 119 | ;; '(int -> int) 120 | ;; (extend (init-tenv) 'f '(int -> int)) 121 | ;; ()) 122 | ;; (check-type '(cons 1 (cons 2 ())) '(list int) () ()) 123 | ;; (check-type '((remove 42) ()) '(list int) 124 | ;; (extend (init-tenv) 125 | ;; 'remove '(1 -> ((list 1) -> (list 1)))) 126 | ;; ()) 127 | ;; (check-type '((remove 42) (cons 3 (cons 7 ()))) '(list int) 128 | ;; (extend (init-tenv) 129 | ;; 'remove '(1 -> ((list 1) -> (list 1)))) 130 | ;; ()) 131 | 132 | ;; type check reverse function 133 | ;; (check-type '(/. x (/. y 134 | ;; (if (null? x) 135 | ;; y 136 | ;; (if (cons? x) 137 | ;; ((reverse-h (cdr x)) (cons (car x) y)) 138 | ;; ())))) 139 | ;; '((list 1) -> ((list 1) -> (list 1))) 140 | ;; (extend 141 | ;; (extend 142 | ;; (extend 143 | ;; (extend 144 | ;; (extend 145 | ;; (init-tenv) 146 | ;; 'null? '(2 -> bool)) 147 | ;; 'cons? '(3 -> bool)) 148 | ;; 'car '((list 4) -> 4)) 149 | ;; 'cdr '((list 5) -> (list 5))) 150 | ;; 'reverse-h '((list 1) -> ((list 1) -> (list 1)))) 151 | ;; ()) 152 | 153 | ;; (check-type '(/. f (/. g (f (g 1)))) 154 | ;; '((0 -> 1) -> ((int -> 0) -> 1)) 155 | ;; () ()) 156 | 157 | 158 | ;; (infer '(/. x (if true (x 1) (x true))) () ()) => fail 159 | ;; (check-type '(/. x (if true (x 1) (x true))) 160 | ;; '((1 -> 2) -> 2) 161 | ;; () ()) => ok 162 | ;; 163 | ;; This case is invalid for HM to infer 164 | ;; (infer '(/. f (/. x ((f (x 1)) (x true)))) () ()) 165 | ;; 166 | ;; (infer '(/. f (/. x ((f (x (/. z z))) 167 | ;; (x (/. u (/. v u)))))) () ()) 168 | -------------------------------------------------------------------------------- /zen/macro.ss: -------------------------------------------------------------------------------- 1 | ;; macro0把(define (f x) ...)变成(define f (lambda (x) ...)) 2 | (define (macro0 exp) 3 | (if (not (pair? exp)) exp 4 | (let ((hd (car exp)) 5 | (tl (cdr exp))) 6 | (cond 7 | ((eq? hd 'define) 8 | (if (pair? (car tl)) 9 | (let ((body `(lambda ,(cdar tl) ,@(cdr tl)))) 10 | `(define ,(caar tl) ,(macro0 body))) 11 | `(define ,(car tl) ,@(map macro0 (cdr tl))))) 12 | ((eq? hd 'if) 13 | `(if ,(macro0 (car tl)) ,(macro0 (cadr tl)) ,(macro0 (caddr tl)))) 14 | ((eq? hd 'field) 15 | `(field ,(car tl) ,(macro0 (cadr tl)))) 16 | ((eq? hd 'tuple) 17 | `(tuple ,(car tl) ,@(map macro0 (cdr tl)))) 18 | ((eq? hd 'lambda) 19 | `(lambda ,(car tl) ,@(map macro0 (cdr tl)))) 20 | ((eq? hd 'case) 21 | `(case ,(macro0 (car tl)) 22 | ,@(map (lambda (x) 23 | (cons (car x) (macro0 (cdr x)))) 24 | (cdr tl)))) 25 | ((eq? hd 'let) 26 | `(let ,(car tl) ,@(map macro0 (cdr tl)))) 27 | ((or (eq? hd '+) (eq? hd '-) (eq? hd '*) (eq? hd '/) (eq? hd '=)) 28 | `(,hd ,(macro0 (car tl)) ,(macro0 (cadr tl)))) 29 | (#t `(,(macro0 hd) ,@(map macro0 tl))))))) 30 | 31 | 32 | (define remove 33 | (lambda (x ls) 34 | (cond 35 | ((null? ls) '()) 36 | ((eq? x (car ls)) 37 | (remove x (cdr ls))) 38 | (else 39 | (cons (car ls) (remove x (cdr ls))))))) 40 | 41 | (define difference 42 | (lambda (lst1 lst2) 43 | (if (not (pair? lst2)) 44 | lst1 45 | (difference (remove (car lst2) lst1) (cdr lst2))))) 46 | 47 | (define insert 48 | (lambda (x ls) 49 | (cond 50 | ((null? ls) (cons x '())) 51 | ((eq? (car ls) x) ls) 52 | (else (cons (car ls) 53 | (insert x (cdr ls))))))) 54 | 55 | (define union 56 | (lambda (lst1 lst2) 57 | (if (null? lst1) 58 | lst2 59 | (insert (car lst1) 60 | (union (cdr lst1) lst2))))) 61 | 62 | (define reduce 63 | (lambda (f ls rv) 64 | (if (null? ls) 65 | rv 66 | (reduce f (cdr ls) (f (car ls) rv))))) 67 | 68 | (define free-vars 69 | (lambda (exp) 70 | (cond 71 | ((or (integer? exp) (string? exp)) '()) 72 | ((symbol? exp) 73 | (if (member exp '(tuple switch case = + - * /)) 74 | '() 75 | (list exp))) 76 | ((eq? 'if (car exp)) 77 | (union (free-vars (cadr exp)) 78 | (union (free-vars (caddr exp)) 79 | (free-vars (cadddr exp))))) 80 | ((eq? 'lambda (car exp)) 81 | (difference (free-vars (cddr exp)) 82 | (cadr exp))) 83 | ((eq? 'define (car exp)) 84 | (difference (free-vars (caddr exp)) 85 | (list (cadr exp)))) 86 | (else (reduce union (map free-vars exp) '()))))) 87 | 88 | ;; 把(define f (lambda (x) ...))变成(define f (lambda1 (this x) ...)) 89 | (define (macro1 exp) 90 | (if (not (pair? exp)) exp 91 | (let ((hd (car exp)) 92 | (tl (cdr exp))) 93 | (cond 94 | ((eq? hd 'define) 95 | (let ((body (macro1 (cadr tl))) 96 | (fv (free-vars (cadr tl)))) 97 | (if (member (car tl) fv) 98 | `(define ,(car tl) 99 | (lambda1 ,(cons (car tl) (cadr body)) 100 | ,@(cddr body))) 101 | `(define ,(car tl) ,body)))) 102 | ((eq? hd 'if) 103 | `(if ,(macro1 (car tl)) ,(macro1 (cadr tl)) ,(macro1 (caddr tl)))) 104 | ((eq? hd 'field) 105 | `(field ,(car tl) ,(macro1 (cadr tl)))) 106 | ((eq? hd 'tuple) 107 | `(tuple ,(car tl) ,@(map macro1 (cdr tl)))) 108 | ((eq? hd 'lambda) 109 | `(lambda ,(car tl) ,@(map macro1 (cdr tl)))) 110 | ((eq? hd 'case) 111 | `(case ,(macro1 (car tl)) 112 | ,@(map (lambda (x) 113 | (cons (car x) (macro1 (cdr x)))) 114 | (cdr tl)))) 115 | ((eq? hd 'let) 116 | `(let ,(car tl) ,@(map macro0 (cdr tl)))) 117 | ((or (eq? hd '+) (eq? hd '-) (eq? hd '*) (eq? hd '/) (eq? hd '=)) 118 | `(,hd ,(macro1 (car tl)) ,(macro1 (cadr tl)))) 119 | (#t `(,(macro1 hd) ,@(map macro1 tl))))))) 120 | 121 | ;; 把(lambda () (define f ...) (define g ...) (define h ...) ...)变成 122 | ;; (let ((f ...) (g ...) (h ...)) ...) 123 | (define (macro2 exp) 124 | (if (not (pair? exp)) exp 125 | (let ((hd (car exp)) 126 | (tl (cdr exp))) 127 | (cond 128 | ((eq? hd 'define) 129 | `(define ,(car tl) ,@(map macro2 (cdr tl)))) 130 | ((eq? hd 'if) 131 | `(if ,(macro2 (car tl)) ,(macro2 (cadr tl)) ,(macro2 (caddr tl)))) 132 | ((eq? hd 'field) 133 | `(field ,(car tl) ,(macro2 (cadr tl)))) 134 | ((eq? hd 'tuple) 135 | `(tuple ,(car tl) ,@(map macro2 (cdr tl)))) 136 | ((eq? hd 'lambda) 137 | (let ((fn (lambda (x) 138 | (and (pair? x) (eq? (car x) 'define)))) 139 | (body (map macro2 (cdr tl)))) 140 | (let ((defs (filter fn body)) 141 | (rem (filter (lambda (x) (not (fn x))) body))) 142 | (if (null? defs) 143 | `(lambda ,(car tl) ,@body) 144 | `(lambda ,(car tl) 145 | (let ,(map cdr defs) 146 | ,@rem)))))) 147 | ((eq? hd 'case) 148 | `(case ,(macro2 (car tl)) 149 | ,@(map (lambda (x) 150 | (cons (car x) (macro2 (cdr x)))) 151 | (cdr tl)))) 152 | ((eq? hd 'let) 153 | `(let ,(car tl) ,@(map macro0 (cdr tl)))) 154 | ((or (eq? hd '+) (eq? hd '-) (eq? hd '*) (eq? hd '/) (eq? hd '=)) 155 | `(,hd ,(macro2 (car tl)) ,(macro2 (cadr tl)))) 156 | (else `(,(macro2 hd) ,@(map macro2 tl))))))) 157 | -------------------------------------------------------------------------------- /scheme2c/closure-convert.scm: -------------------------------------------------------------------------------- 1 | (define (prim? exp) (memq exp '(+ - * / = set!/k))) 2 | (define (const? x) (or (integer? x) (string? x) (boolean? x))) 3 | (define (tagged-list? e tag) 4 | (and (pair? e) (eq? (car e) tag))) 5 | 6 | (define (lambda? e) (tagged-list? e 'lambda)) 7 | (define (lambda->bind e) (cadr e)) 8 | (define (lambda->body e) (caddr e)) 9 | 10 | (define (if? e) (tagged-list? e 'if)) 11 | (define (if->test e) (cadr e)) 12 | (define (if->then e) (caddr e)) 13 | (define (if->else e) (caddr (cdr e))) 14 | 15 | (define (set!? e) (tagged-list? e 'set!)) 16 | (define (set!->var e) (cadr e)) 17 | (define (set!->val e) (caddr e)) 18 | 19 | (define (define? e) (tagged-list? e 'define)) 20 | (define (define->var e) (cadr e)) 21 | (define (define->val e) (caddr e)) 22 | 23 | (define (begin? e) (tagged-list? e 'begin)) 24 | (define (begin->exp e) (cdr e)) 25 | 26 | (define (app? e) (pair? e)) 27 | 28 | (define (closure? e) (tagged-list? e 'closure)) 29 | 30 | (define remove 31 | (lambda (x ls) 32 | (cond 33 | ((null? ls) '()) 34 | ((eq? x (car ls)) 35 | (remove x (cdr ls))) 36 | (else 37 | (cons (car ls) (remove x (cdr ls))))))) 38 | 39 | (define difference 40 | (lambda (lst1 lst2) 41 | (if (not (pair? lst2)) 42 | lst1 43 | (difference (remove (car lst2) lst1) (cdr lst2))))) 44 | 45 | (define insert 46 | (lambda (x ls) 47 | (cond 48 | ((null? ls) (cons x '())) 49 | ((eq? (car ls) x) ls) 50 | (else (cons (car ls) 51 | (insert x (cdr ls))))))) 52 | 53 | (define union 54 | (lambda (lst1 lst2) 55 | (if (null? lst1) 56 | lst2 57 | (insert (car lst1) 58 | (union (cdr lst1) lst2))))) 59 | 60 | (define reduce 61 | (lambda (f ls rv) 62 | (if (null? ls) 63 | rv 64 | (reduce f (cdr ls) (f (car ls) rv))))) 65 | 66 | (define environments '()) 67 | (define num-envs 0) 68 | (define allocate-environment 69 | (lambda (lst) 70 | (set! num-envs (+ num-envs 1)) 71 | (set! environments (cons (cons num-envs lst) environments)) 72 | num-envs)) 73 | 74 | (define free-vars 75 | (lambda (exp) 76 | (cond 77 | ((const? exp) '()) 78 | ((prim? exp) '()) 79 | ((symbol? exp) (list exp)) 80 | ((lambda? exp) (difference (free-vars (lambda->body exp)) 81 | (lambda->bind exp))) 82 | ((if? exp) (union (free-vars (if->test exp)) 83 | (union (free-vars (if->then exp)) 84 | (free-vars (if->else exp))))) 85 | ((set!? exp) (union (list (set!->var exp)) 86 | (free-vars (set!->val exp)))) 87 | ((begin? exp) (reduce union (map free-vars (begin->exp exp)) '())) 88 | ((app? exp) (reduce union (map free-vars exp) '())) 89 | (else (error "unknown expression:" exp))))) 90 | 91 | (define substitute-var 92 | (lambda (env x) 93 | (let ((sub (assq x env))) 94 | (if sub 95 | (cdr sub) 96 | x)))) 97 | 98 | (define assq-remove-key 99 | (lambda (x env) 100 | (cond 101 | ((null? env) '()) 102 | ((eq? (caar env) x) 103 | (assq-remove-key x (cdr env))) 104 | (else (cons (car env) 105 | (assq-remove-key x (cdr env))))))) 106 | 107 | (define assq-remove-keys 108 | (lambda (lst env) 109 | (if (null? lst) 110 | env 111 | (assq-remove-keys (cdr lst) 112 | (assq-remove-key (car lst) env))))) 113 | 114 | (define substitute 115 | (lambda (env exp) 116 | (define substitute-with (lambda (e) (substitute env e))) 117 | (cond 118 | ((const? exp) exp) 119 | ((symbol? exp) 120 | (substitute-var env exp)) 121 | ((if? exp) 122 | `(if ,(substitute env (if->test exp)) 123 | ,(substitute env (if->then exp)) 124 | ,(substitute env (if->else exp)))) 125 | ((begin? exp) 126 | (cons 'begin (map substitute-with (begin->exp exp)))) 127 | ((closure? exp) exp) 128 | ; ((set!? exp) 129 | ; `(set! ,(substitute-var env (set!->var exp)) 130 | ; ,(substitute-var env (set!->val exp)))) 131 | ((lambda? exp) 132 | `(lambda ,(lambda->bind exp) 133 | ,(substitute (assq-remove-keys (lambda->bind exp) env) 134 | (lambda->body exp)))) 135 | ((app? exp) (map substitute-with exp))))) 136 | 137 | (define (azip list1 list2) 138 | (if (and (pair? list1) (pair? list2)) 139 | (cons (list (car list1) (car list2)) 140 | (azip (cdr list1) (cdr list2))) 141 | '())) 142 | 143 | ;; (fv1 fv2 ...) => ((fv1 (env-get 1 env)) (fv2 (env-get 2 env)) ...) 144 | (define fv->sub 145 | (lambda (fv idx env) 146 | (if (null? fv) 147 | '() 148 | (cons (cons (car fv) `(env-get ,idx ,env)) 149 | (fv->sub (cdr fv) (+ idx 1) env))))) 150 | 151 | (define closure-convert 152 | (lambda (exp) 153 | (cond 154 | ((or (symbol? exp) (boolean? exp) (number? exp)) 155 | exp) 156 | ((lambda? exp) 157 | (let* ((body (closure-convert (lambda->body exp))) 158 | (fv (difference (free-vars (lambda->body exp)) (lambda->bind exp))) 159 | (id (allocate-environment fv)) 160 | ($env (gensym 'env)) 161 | (sub (fv->sub fv 0 $env))) 162 | `(closure (lambda (,$env ,@(lambda->bind exp)) 163 | ,(substitute sub body)) 164 | (env-make ,(length fv) ,@fv)))) 165 | ((if? exp) 166 | `(if ,(closure-convert (if->test exp)) 167 | ,(closure-convert (if->then exp)) 168 | ,(closure-convert (if->else exp)))) 169 | ; ((set!? exp) 170 | ; `(set! ,(set!->var exp) 171 | ; ,(closure-convert (set!->val exp)))) 172 | ; ((define? exp) 173 | ; `(define ,(define->var exp) 174 | ; ,(closure-convert (define->val exp)))) 175 | ((app? exp) 176 | (map closure-convert exp)) 177 | (else (error "unhandled exp: " exp))))) 178 | 179 | 180 | (define closure 181 | (lambda (f e) 182 | (lambda x 183 | (apply f (cons e x))))) 184 | 185 | (define env-make 186 | (lambda (n . ls) 187 | (list->vector ls))) 188 | 189 | (define env-get 190 | (lambda (n e) 191 | (vector-ref e n))) 192 | 193 | 194 | ;;;;;;;;test;;;;;;;;;;;;;; 195 | (define halt (lambda (x) x)) 196 | (define fact 197 | (closure 198 | (lambda (env58306 n k58145) 199 | (if (= n 0) 200 | (k58145 1) 201 | (fact (- n 1) 202 | (closure 203 | (lambda (env58305 rv$58146) 204 | ((env-get 0 env58305) (* (env-get 1 env58305) rv$58146))) 205 | (env-make 2 k58145 n))))) 206 | (env-make 1 fact))) 207 | ;; (fact 5 halt) => 120 208 | -------------------------------------------------------------------------------- /sandbox/eval.scm: -------------------------------------------------------------------------------- 1 | (define (filter pred lst) 2 | (define (filter1 f l ret) 3 | (if (null? l) 4 | ret 5 | (if (f (car l)) 6 | (filter1 f (cdr l) ret) 7 | (filter1 f (cdr l) (cons (car l) ret))))) 8 | (filter1 pred lst '())) 9 | 10 | (define (posq x lst) 11 | (let loop ((lst lst) (i 0)) 12 | (cond ((null? lst) #f) 13 | ((eq? x (car lst)) i) 14 | (else (loop (cdr lst) (+ i 1))) ) ) ) 15 | 16 | (define (lookup var e) 17 | (let loop ((envs e) (ei 0)) 18 | (cond ((null? envs) (values #f var)) 19 | ((posq var (car envs)) => (lambda (p) (values ei p))) 20 | (else (loop (cdr envs) (+ ei 1))) ) ) ) 21 | 22 | (define (defined? var e) 23 | (receive (i j) (lookup var e) i) ) 24 | 25 | (define (undefine vars e) 26 | (let loop ([envs e]) 27 | (if (null? envs) 28 | '() 29 | (let ([envi (car envs)]) 30 | (cons 31 | (let delq ([ee envi]) 32 | (if (null? ee) 33 | '() 34 | (let ([h (car ee)] 35 | [r (cdr ee)] ) 36 | (if (memq h vars) 37 | r 38 | (cons h (delq r)) ) ) ) ) 39 | (loop (cdr envs)) ) ) ) ) ) 40 | 41 | (define (s-error loc msg . args) 42 | (signal 43 | (make-composite-condition 44 | (make-property-condition 'sandbox) 45 | (make-property-condition 46 | 'exn 47 | 'location loc 48 | 'message msg 49 | 'arguments args) ) ) ) 50 | 51 | (define (make-sandbox) 52 | (let ([env '()]) 53 | (lambda (method) 54 | (case method 55 | ((set!) 56 | (lambda (id val) 57 | (set! env (cons (cons id val) env)))) 58 | ((ref) 59 | (lambda (id) 60 | (assq id env))) 61 | ((remove!) 62 | (lambda (id) 63 | (set! env 64 | (filter (lambda (x) (eq? (car x) id)) env)))) 65 | ((debug) 66 | (lambda () 67 | env)))))) 68 | 69 | (define (environment-set! e id val) 70 | ((e 'set!) id val)) 71 | (define (environment-ref e id) 72 | ((e 'ref) id)) 73 | (define (environment-remove! e id) 74 | ((e 'remove!) id)) 75 | (define (environment-debug e) 76 | ((e 'debug))) 77 | 78 | ;; for export 79 | (define sandbox-set! environment-set!) 80 | (define sandbox-ref 81 | (lambda (sandbox var) 82 | (let ([a (environment-ref sandbox var)]) 83 | (if a (cdr a))))) 84 | (define sandbox-remove! environment-remove!) 85 | 86 | (define not-bound (cons 'not 'bound)) 87 | 88 | (define (compile-call x e sandbox) 89 | (let* ([fn (compile (car x) e sandbox)] 90 | [args (cdr x)]) 91 | (let ([as (map (lambda (a) (compile a e sandbox)) args)]) 92 | (lambda (v) 93 | (apply (fn v) (map (lambda (a) (a v)) as))) ))) 94 | 95 | (define (compile x e sandbox) 96 | (cond 97 | [(symbol? x) 98 | (let-values ([(i j) (lookup x e)]) 99 | (cond 100 | [(not i) 101 | (let ([a (environment-ref sandbox x)]) 102 | (if (not a) 103 | (s-error #f "compile error: unbound variable" x) 104 | (lambda v 105 | (if (eq? (cdr a) not-bound) 106 | (s-error #f "runtime error: unbound variable" x) 107 | (cdr a)))))] 108 | [(zero? i) (lambda (v) (vector-ref (car v) j))] 109 | [else (lambda (v) (vector-ref (list-ref v i) j))] ) ) ] 110 | [(number? x) (lambda v x)] 111 | [(boolean? x) 112 | (if x (lambda v #t) (lambda v #f) ) ] 113 | [(or (char? x) (eof-object? x) (string? x) ) 114 | (lambda v x) ] 115 | [(symbol? (car x)) 116 | (let ([head (car x)]) 117 | (if (defined? head e) 118 | (compile-call x e sandbox) 119 | (case head 120 | [(quote) 121 | (lambda v (cadr x)) ] 122 | [(if) 123 | (let* ([test (compile (cadr x) e sandbox)] 124 | [cns (compile (caddr x) e sandbox)] 125 | [alt (compile (cadddr x) e sandbox)] ) 126 | (lambda (v) (if (test v) 127 | (cns v) 128 | (alt v))) ) ] 129 | [(begin) 130 | (let ([body (cdr x)]) 131 | (if (pair? body) 132 | (if (null? (cdr body)) 133 | (compile (car body) e sandbox) 134 | (let* ([x1 (compile (car body) e sandbox)] 135 | [x2 (compile `(begin ,@(cdr body)) e sandbox)]) 136 | (lambda (v) 137 | (x1 v) 138 | (x2 v)) )))) ] 139 | [(set!) 140 | (let ([var (cadr x)]) 141 | (let-values ([(i j) (lookup var e)]) 142 | (let ([val (compile (caddr x) e sandbox)]) 143 | (cond 144 | [(not i) 145 | (let ([a (environment-ref sandbox var)]) 146 | (if (not a) 147 | (s-error #f "compile error: set! unbound variable" var) 148 | (let ([val (compile (caddr x) e sandbox)]) 149 | (lambda (v) (set-cdr! a (val v))))))] 150 | [(zero? i) 151 | (lambda (v) (vector-set! (car v) j (val v)))] 152 | [else 153 | (lambda (v) 154 | (vector-set! (list-ref v i) j (val v)) ) ] ) ) ) ) ] 155 | [(define) 156 | (let ([var (cadr x)]) 157 | (let-values ([(i j) (lookup var e)]) 158 | (cond 159 | [(not i) 160 | (let ([a (environment-ref sandbox var)]) 161 | (if (not a) 162 | (begin 163 | (environment-set! sandbox var not-bound) 164 | (set! a (environment-ref sandbox var)))) 165 | (let ([val (compile (caddr x) e sandbox)]) 166 | (lambda (v) (set-cdr! a (val v)))))] 167 | [(zero? i) 168 | (let ([val (compile (caddr x) e sandbox)]) 169 | (lambda (v) (vector-set! (car v) j (val v))))] 170 | [else 171 | (let ([val (compile (caddr x) e sandbox)]) 172 | (lambda (v) 173 | (vector-set! (list-ref v i) j (val v))))])))] 174 | [(let) 175 | (let* ([bindings (cadr x)] 176 | [n (length bindings)] 177 | [vars (map (lambda (x) (car x)) bindings)] 178 | [body (compile 179 | (cons 'begin (cddr x)) 180 | (cons vars e) 181 | sandbox) ] ) 182 | (let ([vals (map 183 | (lambda (x) 184 | (compile (cadr x) e sandbox)) 185 | bindings)]) 186 | (lambda (v) 187 | (let ([v2 (make-vector n)]) 188 | (do ([i 0 (+ i 1)] 189 | [vlist vals (cdr vlist)] ) 190 | ((>= i n)) 191 | (vector-set! v2 i ((car vlist) v)) ) 192 | (body (cons v2 v)) ) ) ) ) ] 193 | [(lambda) 194 | (let* ((vars (cadr x)) 195 | (body (cddr x)) 196 | (argc (length vars))) 197 | (let ([body (compile 198 | (cons 'begin body) 199 | (cons vars e) 200 | sandbox) ] ) 201 | (lambda (v) 202 | (lambda as 203 | (body (cons (apply vector as) v)) ))))] 204 | [(##sandbox#void) 205 | (lambda (v) (begin))] 206 | [else (compile-call x e sandbox)] ) ) ) ] 207 | [else (compile-call x e sandbox)] ) ) 208 | 209 | (define (sandbox-eval exp sandbox) 210 | (set! exp (desugar exp)) 211 | ((compile exp '() sandbox) '())) 212 | -------------------------------------------------------------------------------- /scheme2c/generator.scm: -------------------------------------------------------------------------------- 1 | (define (prim? x) (memq x '(+ - * / = env-get env-make set!/k))) 2 | 3 | (define split 4 | (lambda (lst c) 5 | (cond 6 | ((null? lst) "") 7 | ((null? (cdr lst)) (car lst)) 8 | (else 9 | (string-append (car lst) c (split (cdr lst) c)))))) 10 | 11 | (define gc-guard-string 12 | (lambda (func-name bind) 13 | (string-append "if (CheckMinorGC()) {\nSaveCall(" 14 | func-name ", " 15 | (number->string (length bind)) 16 | ", " 17 | (split (map symbol->string bind) ", ") 18 | ");\nMinorGC();\n}\n"))) 19 | 20 | (define generate-lambda 21 | (lambda (bind body collect) 22 | (let* ((func-name (symbol->string (gensym 'lambda__tmp))) 23 | (declear (string-append "void " func-name "(" 24 | (split (map (lambda (x) (string-append "Value " (symbol->string x))) bind) ", ") ")")) 25 | (def (string-append declear " {\n" (gc-guard-string func-name bind) (generate body) "\n}\n"))) 26 | (collect func-name declear def)))) 27 | 28 | (define global-funcs '()) 29 | (define global-vars '()) 30 | 31 | (define gensym 32 | (let ((v 0)) 33 | (lambda (x) 34 | (set! v (+ v 1)) 35 | (string->symbol 36 | (string-append (symbol->string x) (number->string v)))))) 37 | 38 | (define generate 39 | (lambda (exp) 40 | (match exp 41 | [(? boolean?) (if (eq? exp #t) "ValueTrue" "ValueFalse")] 42 | [(? integer?) 43 | (string-append "MakeInt(" (number->string exp) ")")] 44 | [(? symbol?) 45 | (if (prim? exp) 46 | (case exp 47 | ['+ "__add"] 48 | ['- "__sub"] 49 | ['* "__product"] 50 | ['env-get "EnvRef"] 51 | ['set!/k "__set"] 52 | [else (symbol->string exp)]) 53 | (symbol->string exp))] 54 | [`(if ,test ,then ,else) 55 | (string-append "if (" (generate test) " == ValueTrue) {\n" 56 | (generate then) "\n" 57 | "} else {\n" 58 | (generate else) "\n}")] 59 | [('begin exps ...) 60 | (split (map generate exps) "\n")] 61 | [`(set! ,var ,val) 62 | (string-append (generate var) " = " (generate val) "\n")] 63 | [`(define ,var ,val) 64 | (set! global-vars 65 | (cons (string-append "Value " (symbol->string var) ";") global-vars)) 66 | (string-append (generate var) " = " (generate val) "\n")] 67 | [`(= ,rator ,rand) 68 | (string-append "ValueEqual(" (generate rator) ", " (generate rand) ")")] 69 | [('locate bind body) 70 | (string-append 71 | (split (map (lambda (x) 72 | (case (cadr x) 73 | ['CLOSURE (string-append "struct Closure " (symbol->string (car x)) ";")] 74 | ['ENV (let ((var (symbol->string (car x))) 75 | (size (number->string (caddr x)))) 76 | (string-append "struct Env " var ";\n" 77 | var ".value = alloca(sizeof(Value)*" size ");"))] 78 | ['VECTOR (let ((var (symbol->string (car x))) 79 | (size (number->string (caddr x)))) 80 | (string-append "struct Vector " var ";\n" 81 | var ".value = alloca(sizeof(Value)*" size ");"))] 82 | ['CONS (string-append "struct Cons " (symbol->string (car x)) ";")])) 83 | bind) "\n") 84 | "\n" (generate body))] 85 | [('lambda bind body) 86 | (generate-lambda bind body 87 | (lambda (func-name declear def) 88 | (set! global-funcs (cons def global-funcs)) 89 | (set! global-vars (cons declear global-vars)) 90 | func-name))] 91 | [('InitClosure addr lam env) 92 | (string-append "InitClosure(&" (symbol->string addr) ", " (generate lam) ", " (generate env) ")")] 93 | [('InitVector addr n v ...) 94 | (string-append "InitVector(&" (symbol->string addr) ", " (number->string n) ", " (split (map generate v) ", ") ")")] 95 | [('InitEnv addr n v ...) 96 | (string-append "InitEnv(&" (symbol->string addr) ", " (number->string n) ", " (split (map generate v) ", ") ")")] 97 | [(rator rand ...) 98 | (if (prim? rator) 99 | (string-append (generate rator) "(" (split (map generate rand) ", ") ")") 100 | (let ((tmp (string-append "((struct Closure*)" (generate rator) ")"))) 101 | (string-append tmp "->lam(" tmp "->env, " (split (map generate rand) ", ") ")")))]))) 102 | 103 | ;; 接受一个lambda表达式，对里面的所有涉及到分配的操作拆分成分配空间和使用数据 104 | ;; (lambda (x) 105 | ;; (cons x a) 106 | ;; (vector 6)) => 107 | ;; (lambda (x) 108 | ;; (locate ((tmp1 CONS 2) 109 | ;; (tmp2 VECTOR 6)) 110 | ;; (InitCons tmp1 x a) 111 | ;; (InitVector tmp2 6)) 112 | (define explicit-allocation 113 | (lambda (exp) 114 | (explicit-alloc exp 115 | (lambda (e b) 116 | (if (null? b) 117 | e 118 | `(locate ,b ,e)))))) 119 | 120 | ;; 接受一个exp和一个连续，返回exp和提取出来的分配 121 | (define explicit-alloc 122 | (lambda (exp cont) 123 | (match exp 124 | [(? symbol?) (cont exp '())] 125 | [(? integer?) (cont exp '())] 126 | [`(if ,test ,then ,else) 127 | (explicit-alloc 128 | test 129 | (lambda (test$ b1) 130 | (explicit-alloc 131 | then 132 | (lambda (then$ b2) 133 | (explicit-alloc 134 | else 135 | (lambda (else$ b3) 136 | (cont `(if ,test$ ,then$ ,else$) (append b1 b2 b3))))))))] 137 | [('begin es ...) 138 | (explicit-alloc-list es 139 | (lambda (es$ b) 140 | (cont `(begin ,@es$) b)))] 141 | [`(set! ,var ,val) 142 | (explicit-alloc val 143 | (lambda (val$ b) 144 | (cont `(set! ,var ,val$) b)))] 145 | [`(define ,var ,val) 146 | (explicit-alloc val 147 | (lambda (val$ b) 148 | (cont `(define ,var ,val$) b)))] 149 | [('lambda bind body) 150 | (explicit-alloc body 151 | (lambda (body$ b) 152 | (if (null? b) 153 | (cont exp '()) 154 | (cont 155 | `(lambda ,bind 156 | (locate ,b ,body$)) '()))))] 157 | [`(cons ,x ,y) 158 | (let ((tmp (gensym 'tmp))) 159 | (explicit-alloc x 160 | (lambda (x$ b1) 161 | (explicit-alloc y 162 | (lambda (y$ b2) 163 | (cont `(InitCons ,tmp ,x$ ,y$) 164 | (append (cons (list tmp 'CONS 2) b1) b2)))))))] 165 | [('env-make num fvs ...) 166 | (let ((tmp (gensym 'tmp))) 167 | (cont `(InitEnv ,tmp ,num ,@fvs) (list (list tmp 'ENV num))))] 168 | [('closure lam env) 169 | (let ((tmp (gensym 'tmp))) 170 | (explicit-alloc lam 171 | (lambda (lam$ b) 172 | (explicit-alloc env 173 | (lambda (env$ b1) 174 | (cont `(InitClosure ,tmp ,lam$ ,env$) 175 | (append (cons (list tmp 'CLOSURE 2) b1) b)))))))] 176 | [(rator rand ...) 177 | (explicit-alloc rator 178 | (lambda (rator$ b1) 179 | (explicit-alloc-list rand 180 | (lambda (rand$ b2) 181 | (cont `(,rator$ ,@rand$) (append b1 b2))))))]))) 182 | 183 | (define explicit-alloc-list 184 | (lambda (lst+ cont) 185 | (explicit-alloc 186 | (car lst+) 187 | (lambda (e b) 188 | (if (null? (cdr lst+)) 189 | (cont (cons e '()) b) 190 | (explicit-alloc-list (cdr lst+) 191 | (lambda (remain b1) 192 | (cont (cons e remain) (append b b1))))))))) 193 | -------------------------------------------------------------------------------- /test.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | /*--------------------------data struct---------------------*/ 4 | enum object_type 5 | { 6 | OBJ_PAIR = 0, 7 | OBJ_NUMBER, 8 | OBJ_STRING, 9 | OBJ_CHARACTER, 10 | OBJ_VECTOR, 11 | OBJ_NULL, 12 | OBJ_FALSE, 13 | OBJ_TRUE, 14 | OBJ_ENV, 15 | OBJ_SYMBOL, 16 | OBJ_SYNTAX, 17 | OBJ_PRIMITIVE, 18 | OBJ_PROCEDURE, 19 | OBJ_MACRO, 20 | OBJ_ERROR, 21 | OBJ_UNSPECIFIED, 22 | OBJ_UNINITED, 23 | OBJ_CONT, 24 | OBJ_CLOSURE, 25 | OBJ_TYPE_MAX 26 | }; 27 | 28 | enum syntax_type 29 | { 30 | SYNTAX_IF = 0, 31 | SYNTAX_BEGIN, 32 | SYNTAX_LAMBDA, 33 | SYNTAX_SET, 34 | SYNTAX_DEFINE, 35 | SYNTAX_QUOTE 36 | }; 37 | 38 | struct object_head 39 | { 40 | enum object_type type; 41 | char marked; 42 | }; 43 | 44 | typedef struct object_head* object_t; 45 | 46 | struct vm 47 | { 48 | object_t env; 49 | object_t value; 50 | object_t func; 51 | object_t *ebp; 52 | // object_t *esp; 53 | }; 54 | struct pair 55 | { 56 | struct object_head head; 57 | object_t car; 58 | object_t cdr; 59 | }; 60 | struct string 61 | { 62 | struct object_head head; 63 | unsigned int size; 64 | char data[1]; 65 | }; 66 | struct symbol 67 | { 68 | struct object_head head; 69 | unsigned int size; 70 | char data[1]; 71 | }; 72 | struct syntax 73 | { 74 | struct object_head head; 75 | enum syntax_type tag; 76 | char *name; 77 | }; 78 | struct env 79 | { 80 | struct object_head head; 81 | struct env *parent; 82 | struct pair *binding; 83 | }; 84 | struct number 85 | { 86 | struct object_head head; 87 | union 88 | { 89 | int fixnum; 90 | double flonum; 91 | }data; 92 | }; 93 | struct character 94 | { 95 | struct object_head head; 96 | char data; 97 | }; 98 | struct procedure 99 | { 100 | struct object_head head; 101 | object_t variables; 102 | object_t body; 103 | struct env *env; 104 | struct cont *cont; 105 | }; 106 | struct primitive 107 | { 108 | struct object_head head; 109 | char *name; 110 | unsigned int arg_num; 111 | union 112 | { 113 | object_t (*op0)(); 114 | object_t (*op1)(object_t); 115 | object_t (*op2)(object_t,object_t); 116 | object_t (*op3)(object_t,object_t,object_t); 117 | object_t (*op4)(object_t,object_t,object_t,object_t); 118 | object_t (*op5)(object_t,object_t,object_t,object_t,object_t); 119 | object_t (*op6)(object_t,object_t,object_t,object_t,object_t,object_t); 120 | }callback; 121 | }; 122 | typedef void (*func_t)(struct vm*); 123 | struct closure 124 | { 125 | struct object_head head; 126 | func_t func; 127 | object_t env; 128 | }; 129 | struct vector 130 | { 131 | struct object_head head; 132 | unsigned int size; 133 | object_t data[0]; 134 | }; 135 | object_t make_vector(unsigned int size) 136 | { 137 | struct vector *ret = malloc(sizeof(struct vector)+size*sizeof(object_t)); 138 | ret->head.type = OBJ_VECTOR; 139 | ret->size = size; 140 | return ret; 141 | } 142 | void vector_set(object_t v,unsigned int idx,object_t o) 143 | { 144 | ((struct vector*)v)->data[idx] = o; 145 | } 146 | object_t vector_ref(object_t v,unsigned int idx) 147 | { 148 | return ((struct vector*)v)->data[idx]; 149 | } 150 | object_t closure_env(struct closure *c) 151 | { 152 | return c->env; 153 | } 154 | func_t closure_func(struct closure *c) 155 | { 156 | return c->func; 157 | } 158 | struct number* make_number(int n) 159 | { 160 | struct number *ret=malloc(sizeof(struct number)); 161 | ret->head.type = OBJ_NUMBER; 162 | ret->data.fixnum = n; 163 | return ret; 164 | } 165 | struct error 166 | { 167 | struct object_head head; 168 | char *info; 169 | }; 170 | struct closure* make_closure(func_t func,object_t env) 171 | { 172 | struct closure *ret = malloc(sizeof(struct closure)); 173 | ret->head.type = OBJ_CLOSURE; 174 | ret->func = func; 175 | ret->env = env; 176 | return ret; 177 | } 178 | struct pair* make_pair(object_t car,object_t cdr) 179 | { 180 | struct pair* ret = malloc(sizeof(struct env)); 181 | ret->head.type = OBJ_PAIR; 182 | ret->car = car; 183 | ret->cdr = cdr; 184 | return ret; 185 | } 186 | 187 | object_t cons(object_t car,object_t cdr) 188 | { 189 | return make_pair(car,cdr); 190 | } 191 | object_t car(object_t o) 192 | { 193 | return ((struct pair*)o)->car; 194 | } 195 | 196 | //struct vm *make_vm(); 197 | //struct vm *load_standard_environment(struct vm *); 198 | 199 | #define PUSH(v) *(--vm->esp) = (v) 200 | #define POP() *vm->esp++ 201 | #define SHALLOW_ARGUMENT_REF(n) vector_ref(car(vm->env),n) 202 | #define CLOSURE_CALL() (closure_func(vm->func))(vm) 203 | 204 | //#define PUSH(v) do{*vm->esp = v; ++vm->esp;}while(0) 205 | 206 | struct pair scheme_null_obj; 207 | object_t scheme_standard_environment = &scheme_null_obj; 208 | 209 | //(lambda (a b) (cons a b)) 210 | /* static void funcXXX(struct vm *vm) */ 211 | /* { */ 212 | /* object_t save_esp; */ 213 | /* save_esp = vm->esp;//保存esp */ 214 | /* vm->esp = &save_esp;//新的esp */ 215 | /* PUSH(vm->ebp);//保存ebp */ 216 | /* vm->ebp = &save_esp;//新的ebp */ 217 | /* PUSH(vm->env);//保存环境 */ 218 | /* vm->env = cons(vm->value,closure_env(vm->func));//改变环境 */ 219 | /* //... */ 220 | /* vm->value = SHALLOW_ARGUMENT_REF(0); */ 221 | /* *(--vm->esp) = vm->value; */ 222 | /* // PUSH(vm->value); */ 223 | /* vm->value = SHALLOW_ARGUMENT_REF(1); */ 224 | /* PUSH(vm->value); */ 225 | /* vm->value = cons(POP(),POP()); */ 226 | 227 | /* //... */ 228 | /* vm->env = POP();//恢复环境 */ 229 | /* vm->esp = vm->ebp[0];//恢复esp */ 230 | /* vm->ebp = vm->ebp[-1];//恢复ebp */ 231 | /* } */ 232 | 233 | #define ENTER_CLOSURE(size,name) \ 234 | object_t stack[size];\ 235 | unsigned int index = 4;\ 236 | stack[0] = vm->ebp;\ 237 | vm->ebp = stack;\ 238 | stack[1] = size;\ 239 | stack[2] = "name";\ 240 | stack[3] = vm->env;\ 241 | vm->env = cons(vm->value,closure_env(vm->func)) 242 | #define EXIT_CLOSURE()\ 243 | vm->ebp = stack[0];\ 244 | vm->env = stack[3] 245 | 246 | #define PUSH(v) stack[index++] = (v) 247 | #define POP() stack[--index] 248 | static void funcXXX(struct vm *vm) 249 | { 250 | ENTER_CLOSURE(6,name); 251 | //... 252 | vm->value = SHALLOW_ARGUMENT_REF(0); 253 | PUSH(vm->value); 254 | vm->value = SHALLOW_ARGUMENT_REF(1); 255 | PUSH(vm->value); 256 | vm->value = cons(POP(),POP()); 257 | //... 258 | EXIT_CLOSURE(); 259 | vm->ebp = stack[0];//恢复ebp 260 | vm->env = stack[3]; 261 | } 262 | 263 | int main() 264 | { 265 | struct vm *vm = malloc(sizeof(struct vm)); 266 | func_t fun_ptr; 267 | 268 | //(f 1 2) 269 | /* ... */ 270 | /* reg_value = 1; */ 271 | /* PUSH(reg_value); */ 272 | /* reg_value = 2; */ 273 | /* PUSH(reg_value); */ 274 | /* reg_value = deep_argument_ref(3,0);//取到闭包f */ 275 | /* reg_func = reg_value; */ 276 | /* reg_value = make_vector(2);//构造环境的frame */ 277 | /* vector_set(reg_value,0,POP()); */ 278 | /* vector_set(reg_value,1,POP()); */ 279 | /* CLOSURE_CALL();//闭包调用 */ 280 | /* reg_env = POP();//恢复环境 */ 281 | /* reg_stack_base = POP();//恢复栈寄存器 */ 282 | /* reg_stack -= 2; //消除C栈造成的影响 */ 283 | 284 | vm->ebp = NULL; 285 | vm->value = make_vector(2); 286 | vector_set(vm->value,0,make_number(1)); 287 | vector_set(vm->value,1,make_number(2)); 288 | vm->env = scheme_standard_environment; 289 | vm->func = make_closure(funcXXX,scheme_standard_environment); 290 | CLOSURE_CALL(); 291 | return 0; 292 | } 293 | -------------------------------------------------------------------------------- /re/eval_test.go: -------------------------------------------------------------------------------- 1 | package re 2 | 3 | import ( 4 | "fmt" 5 | "io" 6 | "strings" 7 | "testing" 8 | ) 9 | 10 | type testCase struct { 11 | name string 12 | input string 13 | output string 14 | } 15 | 16 | var basicCases = []testCase{ 17 | testCase{ 18 | name: "curry as arg", 19 | input: `((lambda (f) (f 42)) (+ 1))`, 20 | output: "43", 21 | }, 22 | 23 | // testCase{ 24 | // name: "let-variable-shadow", 25 | // input: `(do (set (quote f) (lambda (a b) 26 | // (let a 3 a)) (f 4 5)))`, 27 | // output: "3", 28 | // }, 29 | 30 | // testCase{ 31 | // name: "let variable shadow", 32 | // input: `(let Result 123 33 | // (let Result 456 34 | // (if (= Result 456) 35 | // true 36 | // Result)))`, 37 | // output: "true", 38 | // }, 39 | 40 | testCase{ 41 | name: "curry", 42 | input: `(do (set (quote f) (lambda (x y z) y)) ((f 1 2) 3))`, 43 | output: "2", 44 | }, 45 | 46 | testCase{ 47 | name: "curry-partial", 48 | input: `((lambda (x) (lambda (y) (lambda (z) (+ x z)))) 1 2 3)`, 49 | output: "4", 50 | }, 51 | 52 | // testCase{ 53 | // name: "trap-let", 54 | // input: "(trap-error (let X 666 42) (lambda E (cons --> (cons A ()))))", 55 | // output: "42", 56 | // }, 57 | 58 | testCase{ 59 | name: "curry1", 60 | input: `(do (set (quote f) (lambda (x) 61 | (do (set (quote ignore) (lambda (z w) 62 | (lambda (y) 63 | z))) (ignore)))) 64 | (((f 1) 2 3) 4))`, 65 | output: "2", 66 | }, 67 | 68 | testCase{ 69 | name: "fib10", 70 | input: `(do (set (quote fib) (lambda (i) 71 | (if (= i 0) 72 | 1 73 | (if (= i 1) 74 | 1 75 | (+ (fib (- i 1)) (fib (- i 2))))))) 76 | (fib 10))`, 77 | output: "89", 78 | }, 79 | 80 | testCase{ 81 | name: "proper tail call", 82 | input: `(do (set (quote sum) (lambda (r i) 83 | (if (= i 0) 84 | r 85 | (sum (+ r 1) (- i 1))))) 86 | (sum 0 5000000))`, 87 | output: "5000000", 88 | }, 89 | 90 | testCase{ 91 | name: "do in args", 92 | input: `(+ (do 1 (do 2 3)) 4)`, 93 | output: "7", 94 | }, 95 | 96 | testCase{ 97 | name: "partial primitive", 98 | input: `(+ (+ (+ 1 2) 3) 4)`, 99 | output: "10", 100 | }, 101 | 102 | testCase{ 103 | name: "do in tail call", 104 | input: `(do (set (quote f) (lambda (x y z) (do 1 (do 2 z)))) (f 1 2 3))`, 105 | output: "3", 106 | }, 107 | 108 | testCase{ 109 | name: "closure value", 110 | input: "((((lambda (x) (lambda (y) (lambda (z) (+ x z)))) 1) 2) 3)", 111 | output: "4", 112 | }, 113 | 114 | testCase{ 115 | name: "basic func call", 116 | input: `(do (set (quote id) (lambda (x) x)) (id (do 1 (do 2 42))))`, 117 | output: "42", 118 | }, 119 | 120 | testCase{ 121 | name: "identify function", 122 | input: `(do (set (quote id) (lambda (x) x)) (id 42))`, 123 | output: "42", 124 | }, 125 | 126 | testCase{ 127 | name: "basic set", 128 | input: `(do (set (quote x) 42) x)`, 129 | output: "42", 130 | }, 131 | 132 | testCase{ 133 | name: "basic if", 134 | input: `(if true 1 2)`, 135 | output: "1", 136 | }, 137 | 138 | testCase{ 139 | name: "curry lambda", 140 | input: `((lambda (x) (lambda (y) (lambda (z) z))) 1 2 3)`, 141 | output: "3", 142 | }, 143 | 144 | testCase{ 145 | name: "basic lambda", 146 | input: `(((lambda (x y) (lambda (z) y)) 1 2) 3)`, 147 | output: "2", 148 | }, 149 | 150 | testCase{ 151 | name: "basic do", 152 | input: `(do 1 2)`, 153 | output: "2", 154 | }, 155 | 156 | testCase{ 157 | name: "basic primitive", 158 | input: `(+ 3 7)`, 159 | output: "10", 160 | }, 161 | 162 | testCase{ 163 | name: "constant", 164 | input: "42", 165 | output: "42", 166 | }, 167 | 168 | testCase{ 169 | name: "partial primitive1", 170 | input: `((+ 1) 2)`, 171 | output: "3", 172 | }, 173 | 174 | testCase{ 175 | name: "partial primitive2", 176 | input: `(((+) 1) 2)`, 177 | output: "3", 178 | }, 179 | } 180 | 181 | func TestBasic(t *testing.T) { 182 | ctx := New() 183 | for _, c := range basicCases { 184 | t.Run(c.name, func(t *testing.T) { 185 | res := evalString(ctx, c.input) 186 | if res.String() != c.output { 187 | fmt.Println("input is:", c.input) 188 | fmt.Println("output is:", res.String()) 189 | t.Fail() 190 | } 191 | if len(ctx.stack) != 0 { 192 | fmt.Println("unexpected sp after evaluation:", len(ctx.stack)) 193 | t.Fail() 194 | } 195 | if ctx.base != 0 { 196 | fmt.Println("unexpected stack after evaluation:", ctx.base) 197 | t.Fail() 198 | } 199 | }) 200 | } 201 | } 202 | 203 | func TestIssue25(t *testing.T) { 204 | ctx := New() 205 | evalString(ctx, "(set (quote return) (lambda (x) (lambda (k) (k x))))") 206 | evalString(ctx, "(set (quote add1) (lambda (n) (return (+ n 1))))") 207 | res := evalString(ctx, "(add1 4 (lambda (x) x))") 208 | if res != Integer(5) { 209 | t.Fail() 210 | } 211 | } 212 | 213 | func evalString(ctx *VM, exp string) Obj { 214 | r := NewSexpReader(strings.NewReader(exp)) 215 | sexp, err := r.Read() 216 | if err != nil && err != io.EOF { 217 | panic(err) 218 | } 219 | 220 | sexp = macroExpand(ctx, sexp) 221 | 222 | return ctx.Eval(sexp) 223 | } 224 | 225 | // func TestTryThrow(t *testing.T) { 226 | // ctx := New() 227 | // res := evalString(ctx, `(try (lambda (cc handler) 228 | // (+ 4 (throw 42 cc handler))) 229 | // (lambda (x k) 230 | // (k 66)))`) 231 | // if res != Integer(70) { 232 | // t.Fail() 233 | // } 234 | // } 235 | 236 | // func TestLoadData(t *testing.T) { 237 | // r := NewSexpReader(strings.NewReader("(load \"./init.cora\")")) 238 | // sexp, err := r.Read() 239 | // if err != nil && err != io.EOF { 240 | // panic(err) 241 | // } 242 | 243 | // vm := New() 244 | // res := vm.Eval(sexp) 245 | // fmt.Println(res.String()) 246 | // } 247 | 248 | func TestClosureConvert(t *testing.T) { 249 | // r := NewSexpReader(strings.NewReader(`(lambda (x) x)`)) 250 | // r := NewSexpReader(strings.NewReader(`(lambda (z) (+ x z))`)) 251 | r := NewSexpReader(strings.NewReader(`((((lambda (x) (lambda (y) (lambda (z) (+ x y)))) 1) 2) 3)`)) 252 | sexp, err := r.Read() 253 | if err != nil && err != io.EOF { 254 | panic(err) 255 | } 256 | exp1, frees := closureConvert(sexp, Nil, Nil, nil) 257 | fmt.Println("result:", exp1, frees) 258 | } 259 | 260 | func TestXXX(t *testing.T) { 261 | r := NewSexpReader(strings.NewReader(`((+ 1) 2)`)) 262 | // r := NewSexpReader(strings.NewReader(`(((lambda (x y) x) 4) 5)`)) 263 | // r := NewSexpReader(strings.NewReader(`((((lambda (x) (lambda (y) (lambda (z) (+ x z)))) 1) 2) 3)`)) 264 | // r := NewSexpReader(strings.NewReader(`(((lambda (x) (lambda () (+ x 1))) 5))`)) 265 | // r := NewSexpReader(strings.NewReader(`(do (set 'f (lambda (x) x)) (f 44))`)) 266 | // r := NewSexpReader(strings.NewReader(`(do 267 | // (set 'f (lambda (a b c) a)) 268 | // (do 269 | // (set 'g (lambda (n) (+ n 1))) 270 | // (f 1 (g 5) 4)))`)) 271 | // r := NewSexpReader(strings.NewReader("(load \"../cmd/cora/init.cora\")")) 272 | // r := NewSexpReader(strings.NewReader(`(do (set (quote sum) (lambda (r i) 273 | // (if (= i 0) 274 | // r 275 | // (sum (+ r 1) (- i 1))))) 276 | // (sum 0 5000000))`)) 277 | sexp, err := r.Read() 278 | if err != nil && err != io.EOF { 279 | panic(err) 280 | } 281 | 282 | // vm := New() 283 | // res := vm.Eval(sexp) 284 | // fmt.Println(res.String()) 285 | 286 | // loadFile(vm, "../cmd/cora/init.cora") 287 | 288 | var vm VM 289 | res := vm.Eval(sexp) 290 | fmt.Printf("%#v\n", res) 291 | 292 | // var cg CodeGen 293 | // cg.GenC(code) 294 | } 295 | --------------------------------------------------------------------------------