├── tests ├── test0 │ ├── test-print │ ├── test3.c │ ├── test2.c │ ├── test-string-replace.ss │ ├── test4.c │ ├── test.c │ ├── test-let.s │ ├── duck.c │ ├── test3.s │ ├── test1.s │ ├── test2.s │ ├── make-rand.ss │ ├── test.s │ ├── test4.s │ ├── rand.ss │ ├── test-print.s │ ├── test-list.ss │ └── test-bm.ss ├── test-set.ss ├── test-exp.ss ├── test-begin.ss ├── test-var.ss ├── test-llvm.ss ├── test-wasm.ss ├── test-cmp.ss ├── test-if.ss ├── test-asm.ss ├── test-lambda.ss ├── test-prim.ss ├── test-let.ss ├── test-all.ss ├── test-basic.ss ├── test-print.ss ├── test-define.ss ├── test-remove-code.ss ├── test-tail-call.ss └── test-fib.ss ├── .gitignore ├── scripts ├── run-tests.sh └── run-test.sh ├── arch ├── arm.ss ├── arm64.ss ├── x86-64.ss ├── arch.ss ├── wasm.ss ├── llvm.ss └── x86.ss ├── Makefile ├── duck ├── libs.ss ├── options.ss ├── type.ss ├── primitive.ss ├── duck.ss └── egg.ss ├── common ├── logger.ss ├── trace.ss ├── common.ss ├── test.ss └── match.ss ├── README.md ├── LICENSE └── docs └── exp.txt /tests/test0/test-print: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/evilbinary/duck-compiler/master/tests/test0/test-print -------------------------------------------------------------------------------- /tests/test0/test3.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main(int argc,char* argv[]) 4 | { 5 | return 0; 6 | } 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.ss~ 2 | *.ss#* 3 | .#*.ss 4 | 5 | *.scm~ 6 | *.scm#* 7 | .#*.scm 8 | 9 | build/* 10 | *.log 11 | -------------------------------------------------------------------------------- /tests/test0/test2.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main(void) 4 | { 5 | void* a=malloc(8); 6 | return 0; 7 | } 8 | -------------------------------------------------------------------------------- /tests/test0/test-string-replace.ss: -------------------------------------------------------------------------------- 1 | (import (common)) 2 | 3 | (printf "string-replace-one=> ~a\n" (string-replace ")" "quote" "adfas)" ) ) -------------------------------------------------------------------------------- /tests/test0/test4.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main(int argc,char* argv[]) 4 | { 5 | printf("hello\n"); 6 | int a=malloc(8); 7 | a=a+1; 8 | return 0; 9 | } 10 | -------------------------------------------------------------------------------- /tests/test-set.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test "test set!" 5 | [(set! v 1000) ""] 6 | [(set! square (lambda (x) (* x x))) ""] 7 | ) 8 | 9 | (test-all) 10 | -------------------------------------------------------------------------------- /tests/test-exp.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test "test exp" 5 | [e0 (lambda (x) x) ] 6 | [(e0 e1) '() ] 7 | [(e0 e1 e2) '() ] 8 | ) 9 | 10 | 11 | (test-all) 12 | -------------------------------------------------------------------------------- /tests/test-begin.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test begin" 5 | [(begin (+ 1 2) (+ 3 4) ) 7] 6 | [(begin (+ 1 2) (begin (+ 2 3) (+ 3 4)) ) 7] 7 | ) 8 | 9 | 10 | (test-all) 11 | -------------------------------------------------------------------------------- /tests/test-var.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-string "test var" 5 | ; [x 'x] 6 | [1000 1000] 7 | ["test" "test"] 8 | [#t #t] 9 | [#t #f] 10 | [#f #f] 11 | ;[(compile '1000) 1000] 12 | ) 13 | 14 | (test-all) 15 | -------------------------------------------------------------------------------- /tests/test0/test.c: -------------------------------------------------------------------------------- 1 | // gcc -O3 -S test.c 2 | // gcc-mp-4.9 -O3 --omit-frame-pointer -S test.c 3 | // gcc -masm=intel -S test.c -o test1.s 4 | // int a=10; 5 | // int b=100; 6 | // int scheme_entry(){ 7 | // return 42; 8 | // } 9 | int main(){ 10 | int c=0; 11 | return 0; 12 | } -------------------------------------------------------------------------------- /scripts/run-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | export CHEZSCHEMELIBDIRS=.:.. 3 | trap 'onCtrlC' INT 4 | function onCtrlC () { 5 | echo 'Ctrl+C is captured' 6 | ps -ef |grep test. | grep -v grep|awk '{print $2'}|xargs kill -9 7 | } 8 | 9 | cd build && scheme --script ../tests/test-all.ss 10 | -------------------------------------------------------------------------------- /tests/test-llvm.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (options)) 3 | (option-set 'arch 'llvm) 4 | (import (test) (duck) ) 5 | 6 | 7 | (add-test-print "test var" 8 | ; [x 'x] 9 | ; [1000 1000] 10 | ["Hello, world!" "Hello, world!"] 11 | ; [#t #t] 12 | ; [#t #f] 13 | ; [#f #f] 14 | ;[(compile '1000) 1000] 15 | ) 16 | 17 | (test-all) 18 | -------------------------------------------------------------------------------- /tests/test-wasm.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (options)) 3 | (option-set 'arch 'wasm) 4 | (import (test) (duck) ) 5 | 6 | 7 | (add-test-print "test var" 8 | ; [x 'x] 9 | ; [1000 1000] 10 | ["Hello, world!" "Hello, world!"] 11 | ; [#t #t] 12 | ; [#t #f] 13 | ; [#f #f] 14 | ;[(compile '1000) 1000] 15 | ) 16 | 17 | (test-all) 18 | -------------------------------------------------------------------------------- /scripts/run-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | export CHEZSCHEMELIBDIRS=.:.. 3 | 4 | trap 'onCtrlC' INT 5 | function onCtrlC () { 6 | echo 'Ctrl+C is captured' 7 | ps -ef |grep test. |grep -v grep| awk '{print $2'}|xargs kill -9 8 | } 9 | 10 | cd build && scheme --script ../$1 #--debug-on-exception 11 | #cd tests && echo '(parameterize ([run-cp0 (lambda (cp0 x) x)]) (load-program "../'$1'"))' | scheme -q -------------------------------------------------------------------------------- /arch/arm.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (arch arm) 7 | (export 8 | asm-gen-file 9 | asm-gen 10 | ) 11 | 12 | (import (scheme) 13 | (common match) 14 | ) 15 | 16 | 17 | ) -------------------------------------------------------------------------------- /arch/arm64.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (arch arm64) 7 | (export 8 | asm-gen-file 9 | asm-gen 10 | ) 11 | 12 | (import (scheme) 13 | (common match) 14 | ) 15 | 16 | 17 | ) -------------------------------------------------------------------------------- /tests/test-cmp.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test cmp" 5 | [(> 2 3) #f] 6 | [(> 3 2) #t] 7 | [(= 3 2) #f] 8 | [(= 2 2) #t] 9 | [(< 2 3) #t] 10 | [(< 3 2) #f] 11 | [(= 0 0) #t] 12 | [(> 0 0) #f] 13 | [ (begin 14 | (<= 1 0) 15 | (= 0 0) 16 | ) #t] 17 | [(= 0 -1) #f] 18 | [(= -1 -1) #t] 19 | ) 20 | 21 | (test-all) 22 | -------------------------------------------------------------------------------- /tests/test0/test-let.s: -------------------------------------------------------------------------------- 1 | ;;/opt/local/bin/nasm test-let.s -f macho && ld -e _start test-let.o -o test-let 2 | 3 | section .data 4 | a dd 10 5 | b dd 0 6 | var.2 dd 0 7 | var.3 dd 0 8 | nil dd 0 9 | 10 | section .text 11 | global _start 12 | 13 | _start: 14 | mov eax,10 15 | mov [a],eax 16 | mov eax,11 17 | mov [b],eax 18 | mov eax,[nil] 19 | mov [var.2],eax 20 | ;jmp var.2 21 | mov [var.3],eax 22 | ;jmp var.3 23 | ret 24 | 25 | 26 | -------------------------------------------------------------------------------- /tests/test0/duck.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void duck_print_array(void* addr){ 4 | float *ptr=addr; 5 | int i=0; 6 | for(i=0;i<8;i++){ 7 | printf("######=%f\n",*ptr); 8 | ptr++; 9 | } 10 | } 11 | 12 | void* duck_malloc(size_t n){ 13 | void* ptr=malloc(n); 14 | return ptr; 15 | } 16 | 17 | void duck_free(void* ptr){ 18 | if(ptr!=NULL){ 19 | free(ptr); 20 | } 21 | } 22 | 23 | void duck_print_value(void* ptr){ 24 | 25 | } 26 | 27 | -------------------------------------------------------------------------------- /arch/x86-64.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (arch x86-64) 8 | (export 9 | asm-gen-file 10 | asm-gen 11 | ) 12 | 13 | (import (scheme) 14 | (common match) 15 | ) 16 | 17 | 18 | ; %rdi：第1个参数 19 | ; %rsi：第2个参数 20 | ; %rdx：第3个参数 21 | ; %rcx：第4个参数 22 | ; %r8：第5个参数 23 | ; %r9：第6个参数 24 | 25 | ) -------------------------------------------------------------------------------- /tests/test0/test3.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .macosx_version_min 10, 12 3 | .intel_syntax noprefix 4 | .globl _main 5 | .p2align 4, 0x90 6 | _main: ## @main 7 | ## BB#0: 8 | push ebp 9 | mov ebp, esp 10 | sub esp, 12 11 | mov eax, dword ptr [ebp + 12] 12 | mov ecx, dword ptr [ebp + 8] 13 | xor edx, edx 14 | mov dword ptr [ebp - 4], 0 15 | mov dword ptr [ebp - 8], ecx 16 | mov dword ptr [ebp - 12], eax 17 | mov eax, edx 18 | add esp, 12 19 | pop ebp 20 | ret 21 | 22 | 23 | .subsections_via_symbols 24 | -------------------------------------------------------------------------------- /tests/test0/test1.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .macosx_version_min 10, 12 3 | .intel_syntax noprefix 4 | .globl _main 5 | .p2align 4, 0x90 6 | _main: ## @main 7 | .cfi_startproc 8 | ## BB#0: 9 | push rbp 10 | Lcfi0: 11 | .cfi_def_cfa_offset 16 12 | Lcfi1: 13 | .cfi_offset rbp, -16 14 | mov rbp, rsp 15 | Lcfi2: 16 | .cfi_def_cfa_register rbp 17 | sub rsp, 16 18 | xor edi, edi 19 | mov dword ptr [rbp - 4], 0 20 | mov dword ptr [rbp - 8], 0 21 | call _exit 22 | .cfi_endproc 23 | 24 | 25 | .subsections_via_symbols 26 | -------------------------------------------------------------------------------- /tests/test0/test2.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .macosx_version_min 10, 12 3 | .intel_syntax noprefix 4 | .globl _main 5 | .p2align 4, 0x90 6 | _main: ## @main 7 | ## BB#0: 8 | push ebp 9 | mov ebp, esp 10 | sub esp, 24 11 | mov eax, 8 12 | mov dword ptr [ebp - 4], 0 13 | mov dword ptr [esp], 8 14 | mov dword ptr [ebp - 12], eax ## 4-byte Spill 15 | call _malloc 16 | xor ecx, ecx 17 | mov dword ptr [ebp - 8], eax 18 | mov eax, ecx 19 | add esp, 24 20 | pop ebp 21 | ret 22 | 23 | 24 | .subsections_via_symbols 25 | -------------------------------------------------------------------------------- /tests/test-if.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test if" 5 | [(if #f 1 2) 2] 6 | [(if #t 1 2) 1] 7 | [(if #f #f) "()"] 8 | 9 | [(if (> 3 2) (- 3 2) (+ 3 2)) 1] 10 | [(if (+ 1 2) 1 2) 1] 11 | [(if (< 3 2) (+ 3 4) (+ 4 5)) 9] 12 | 13 | [(if (= 1 1) 14 | 0 15 | (if (= 2 2) 16 | 1 17 | 2 18 | ) 19 | ) 0] 20 | 21 | ;;no pass 22 | ; [(if (> 2 3) 'yes 'no) no] 23 | ; [(if (> 3 2) 'yes 'no) yes] 24 | 25 | ) 26 | 27 | 28 | (test-all) 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | #;Copyright 2016-2080 evilbinary. 3 | #;作者:evilbinary on 12/24/16. 4 | #;邮箱:rootdebug@163.com 5 | #;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | compiler=scheme 8 | 9 | 10 | .PHONY: build 11 | 12 | build: 13 | @echo "build" 14 | 15 | #make test target=begin 16 | test %: 17 | ./scripts/run-test.sh tests/test-${target}.ss 18 | 19 | test-basic: 20 | ./scripts/run-test.sh tests/test-basic.ss 21 | 22 | test-all: 23 | ./scripts/run-tests.sh tests/test-all.ss 24 | 25 | 26 | cp: 27 | cp *.ss ../duck-compiler-git/ 28 | 29 | clean: 30 | rm -rf build/* -------------------------------------------------------------------------------- /duck/libs.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (duck libs) 8 | (export 9 | print-dot 10 | print-list 11 | print-value 12 | 13 | emit-print-const-value 14 | emit-print-type-value 15 | emit-print-value 16 | emit-printf 17 | emit-alloc 18 | emit-free 19 | emit-prim 20 | prim? 21 | binop? 22 | ) 23 | 24 | (import 25 | (common common) 26 | (common match) 27 | (common trace) 28 | (duck primitive) 29 | ) 30 | ) -------------------------------------------------------------------------------- /tests/test-asm.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) 3 | (test) 4 | ) 5 | 6 | (add-test-string "test asm" 7 | ; [($asm (block all 8 | ; (block main 9 | ; (set reg0 reg1) 10 | ; (set reg0 reg1) 11 | ; ))) ""] 12 | ; [($asm (set reg0 reg1)) ""] 13 | 14 | [(begin 15 | (define (print-ch ch) 16 | ($asm 17 | (call print-char #x4f62)) 18 | ) 19 | (print-ch #x4f62) 20 | 21 | ($asm 22 | (label halt) 23 | (jmp halt) 24 | 25 | ;;打印一个字符 26 | (proc print-char) 27 | (set reg0 (local 0)) 28 | (set reg5 #xb8000) 29 | (mset reg5 r0) 30 | (ret) 31 | )) 32 | 33 | "" 34 | ] 35 | 36 | ) 37 | 38 | (test-all) 39 | -------------------------------------------------------------------------------- /tests/test-lambda.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test lambda" 5 | [((lambda (x) x) 1) 1] 6 | [((lambda (x y z) (+ 2 x) ) 100) 102] 7 | [((lambda (p q r) q ) 1 2 3) 2] 8 | [(lambda (p1 p2 p3) p3) ""] 9 | [(lambda (x) x) ""] 10 | [(begin (define test1 (lambda (x) (+ x 10)) ) 11 | (test1 100)) 12 | 110] 13 | 14 | ; [((lambda (x) x) 'x) x] 15 | ; [(lambda (x) 1 2) ""] 16 | ; [(lambda (x) (lambda (x) 'x) ) ""] 17 | 18 | 19 | ;;no pass 20 | ; [(define fib (lambda (n) (printc "fib(%d)" n) (if (= n 0) 0 (fib (- n 1))))) ""] 21 | 22 | ;;todo support more than 2 args 23 | 24 | ) 25 | 26 | ; (add-test "test alpha conversion" 27 | ; [(lambda (x) x) '()] 28 | ; [(lambda (x y) y) '()] 29 | 30 | ; ) 31 | 32 | (test-all) -------------------------------------------------------------------------------- /tests/test-prim.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test prim" 5 | [(+ 1 (+ 1 2) ) 4] 6 | [(+ 1 2) 3] 7 | [(= 2 2) #t] 8 | [(begin (> 1 2) 9 | (< 1 2) 10 | (>= 1 2) 11 | (<= 1 2) 12 | (= 1 2) 13 | (= 2 2) 14 | ) 15 | #t ] 16 | [(- 1200000 11111) 1188889] 17 | [(+ 1 2 3) 6] 18 | [(+ 1 2 3 4) 10] 19 | [(- 1 1) 0] 20 | [(- 2 3) -1] 21 | [(begin 22 | (+ 1 2 3) 23 | (- 2 3) 24 | (> 1 3) 25 | (- 2 3) 26 | ) 27 | -1 28 | ] 29 | [(- (+ 10 5) (- 2 3) ) 16] 30 | [(print-value 11) 11] 31 | 32 | ;;test erro 33 | ; [(/ 3 4) 0] 34 | ; [(* 3 4) 12] 35 | ; [(/ 12 4) 3] 36 | 37 | [(printc "%d" 11) 11] 38 | ; [(printc "ret=%d" (- (+ 10 5) (- 2 3) )) 16] 39 | 40 | ) 41 | 42 | (test-all) 43 | -------------------------------------------------------------------------------- /tests/test0/make-rand.ss: -------------------------------------------------------------------------------- 1 | (collect-request-handler void) 2 | 3 | (define rand 4 | (lambda () 5 | (random 1.0))) 6 | 7 | 8 | (define (extend! l . xs) 9 | (if (null? (cdr l)) 10 | (set-cdr! l xs) 11 | (apply extend! (cdr l) xs))) 12 | 13 | (define make-matrix-rand 14 | (lambda (name rnum cnum) 15 | ;;(hashtable-set! @@@@mt name (list rnum cnum)) 16 | (let loop ([i 0][end (* rnum cnum)][Res '() ]) 17 | (cond 18 | ((eq? i end) (set-box! name (list->vector Res))) 19 | (else 20 | ;;(rand) 21 | (loop (+ 1 i) 22 | end 23 | (cons (rand) Res ) 24 | )))))) 25 | 26 | 27 | (define n (box 0)) 28 | (time (make-matrix-rand n 5000 5000)) -------------------------------------------------------------------------------- /duck/options.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (duck options) 7 | (export 8 | option-set 9 | option-get 10 | make-options 11 | ) 12 | 13 | (import (scheme)) 14 | 15 | (define (make-options) 16 | (make-hashtable equal-hash equal?) 17 | ) 18 | (define duck-options (make-options)) 19 | 20 | (define (option-set var val) 21 | (hashtable-set! duck-options var val) 22 | ) 23 | 24 | (define option-get 25 | (case-lambda 26 | [(var val) 27 | (hashtable-ref duck-options var val) 28 | ] 29 | [(var) 30 | (option-get var '()) 31 | ])) 32 | 33 | ) -------------------------------------------------------------------------------- /common/logger.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (common logger) 7 | (export 8 | log-level 9 | log-info 10 | log-debug 11 | log-error 12 | log-set-level 13 | ) 14 | (import (scheme)) 15 | (define level 'info) 16 | (define (log-set-level l) 17 | (set! level l) 18 | ) 19 | (define (log-level l s . args) 20 | (if (not (null? level)) 21 | (begin 22 | (apply printf (format "[~a]~a" l s) args) 23 | (newline )))) 24 | 25 | (define (log-info . args) 26 | (apply log-level 'info args) 27 | ) 28 | 29 | (define (log-debug . args) 30 | (apply log-level 'debug args) 31 | ) 32 | 33 | (define (log-error . args) 34 | (apply log-level 'error args) 35 | ) 36 | ) -------------------------------------------------------------------------------- /tests/test0/test.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text_cold,regular,pure_instructions 2 | LCOLDB0: 3 | .text 4 | LHOTB0: 5 | .align 4,0x90 6 | .globl _scheme_entry 7 | _scheme_entry: 8 | LFB0: 9 | movl $42, %eax 10 | ret 11 | LFE0: 12 | .section __TEXT,__text_cold,regular,pure_instructions 13 | LCOLDE0: 14 | .text 15 | LHOTE0: 16 | .section __TEXT,__eh_frame,coalesced,no_toc+strip_static_syms+live_support 17 | EH_frame1: 18 | .set L$set$0,LECIE1-LSCIE1 19 | .long L$set$0 20 | LSCIE1: 21 | .long 0 22 | .byte 0x1 23 | .ascii "zR\0" 24 | .byte 0x1 25 | .byte 0x78 26 | .byte 0x10 27 | .byte 0x1 28 | .byte 0x10 29 | .byte 0xc 30 | .byte 0x7 31 | .byte 0x8 32 | .byte 0x90 33 | .byte 0x1 34 | .align 3 35 | LECIE1: 36 | LSFDE1: 37 | .set L$set$1,LEFDE1-LASFDE1 38 | .long L$set$1 39 | LASFDE1: 40 | .long LASFDE1-EH_frame1 41 | .quad LFB0-. 42 | .set L$set$2,LFE0-LFB0 43 | .quad L$set$2 44 | .byte 0 45 | .align 3 46 | LEFDE1: 47 | .subsections_via_symbols 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 🦆鸭子编译器 2 | 鸭子编译器是一款基于scheme的魔改的鸭语言编译器 3 | 鸭子QQ群号:239401374 4 | 5 | ## 使用 6 | linux依赖: 7 | ``` 8 | sudo apt-get install nasm 9 | sudo dpkg --add-architecture i386 10 | sudo apt-get install gcc-multilib libc6:i386 libncurses5:i386 libstdc++6:i386 11 | ``` 12 | 13 | osx 依赖: `brew install nasm` 14 | 15 | 运行: `make build` 16 | 17 | ## 鸭语言 18 | 19 | 自定义语法，声明变量，有为定义，值为“老王” 20 | ```c 21 | 《鸭语法》 22 | 有一个鸭，它叫“老王”。 23 | 打你鸭，走你鸭。 24 | ``` 25 | 26 | 库定义，固定语法 27 | ```c 28 | 《树木》 29 | -四言一三 30 | 移动树木，到三百米。 31 | 当三百米，锯成两段。 32 | 裁剪树枝，摘掉树叶。 33 | ``` 34 | 35 | 函数定义 36 | ```c 37 | 《鸭子标准库》 38 | -作者：鸭子 39 | 定义：输出，名； 40 | 打印：名。 41 | ``` 42 | 43 | 函数调用 44 | ```c 45 | 《鸭子标准库》 46 | 输出：“嘎嘎”。 47 | ``` 48 | 49 | 调用c 50 | ```c 51 | 《C》 52 | 输出：1234。 53 | ``` 54 | 55 | 56 | ## 计划 57 | 58 | 1. add duck compiler [done] 59 | 2. add lib support vector and so on [doing] 60 | 3. add duck language support [doing] 61 | 4. add x86[done] x86-64 llvm[done] arm arm64 wasm 62 | 5. add duck os [doing] 63 | 6. add duck robot [doing] -------------------------------------------------------------------------------- /tests/test0/test4.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .macosx_version_min 10, 12 3 | .intel_syntax noprefix 4 | .globl _main 5 | .p2align 4, 0x90 6 | _main: ## @main 7 | ## BB#0: 8 | push ebp 9 | mov ebp, esp 10 | sub esp, 40 11 | call L0$pb 12 | L0$pb: 13 | pop eax 14 | mov ecx, dword ptr [ebp + 12] 15 | mov edx, dword ptr [ebp + 8] 16 | lea eax, [eax + L_.str-L0$pb] 17 | mov dword ptr [ebp - 4], 0 18 | mov dword ptr [ebp - 8], edx 19 | mov dword ptr [ebp - 12], ecx 20 | mov dword ptr [esp], eax 21 | call _printf 22 | mov ecx, 8 23 | mov dword ptr [esp], 8 24 | mov dword ptr [ebp - 20], eax ## 4-byte Spill 25 | mov dword ptr [ebp - 24], ecx ## 4-byte Spill 26 | call _malloc 27 | xor ecx, ecx 28 | mov dword ptr [ebp - 16], eax 29 | mov eax, dword ptr [ebp - 16] 30 | add eax, 1 31 | mov dword ptr [ebp - 16], eax 32 | mov eax, ecx 33 | add esp, 40 34 | pop ebp 35 | ret 36 | 37 | .section __TEXT,__cstring,cstring_literals 38 | L_.str: ## @.str 39 | .asciz "hello\n" 40 | 41 | 42 | .subsections_via_symbols 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 evilbinary 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /tests/test-let.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test let" 5 | [(let ((a 10)) ) ()] 6 | [(let ((a 10) (b 11) (c 12) (d 13)) ) ()] 7 | [(let ((a 10) (b 11) (c 12) (d 13)) 1) 1] 8 | [(begin 1 (begin 11 22) ) 22] 9 | [(let ((a 10) (b 11) (c 12) (d 13)) 1 2 3 4 (let () 5 6 )) 6] 10 | 11 | 12 | [(let ([var.18 "=>0 "]) 13 | (let ([var.0 (printc var.18)]) 1)) 14 | "=>0 1" 15 | ] 16 | 17 | [(let ((n 3)) 18 | (if (= n 0) 19 | 1 20 | (if (= n 1) 21 | 2 22 | 3))) 23 | 3] 24 | 25 | ; no pass 26 | [(let ((idx (lambda (x) x)) 27 | (a 10) 28 | (b 11) 29 | (c 12)) 30 | (+ a b) 31 | ) 32 | 21] 33 | [(let loop2 ([x 10] [y 11] ) 34 | (if (> x 0) 35 | (begin 36 | (printc "%d,%d " x y) 37 | (loop2 (- x 1) y))) 38 | ) 39 | "10,11 9,11 8,11 7,11 6,11 5,11 4,11 3,11 2,11 1,11 " 40 | ] 41 | 42 | ; [(let ((id (lambda (x) x))) 43 | ; (let ((apply (lambda (f x) (f x)))) 44 | ; ((id apply) (id 3)))) 45 | ; '()] 46 | 47 | 48 | 49 | 50 | ) 51 | 52 | 53 | (test-all) 54 | -------------------------------------------------------------------------------- /tests/test-all.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (load "../tests/test-basic.ss") 5 | (load "../tests/test-var.ss") 6 | (load "../tests/test-prim.ss") 7 | (load "../tests/test-print.ss") 8 | 9 | (load "../tests/test-cmp.ss") 10 | (load "../tests/test-if.ss") 11 | (load "../tests/test-lambda.ss") 12 | (load "../tests/test-define.ss") 13 | (load "../tests/test-define.ss") 14 | (load "../tests/test-let.ss") 15 | (load "../tests/test-set.ss") 16 | (load "../tests/test-tail-call.ss") 17 | 18 | ;;;;;;duck-compile test 19 | 20 | ;;(pretty-print (ast-conversion '(let ((a 1) (b 2) (c 3)) 4 5) ) ) 21 | 22 | ; (duck-compile '(begin 23 | ; (set! square (lambda (x.1) (* x.1 x.1))) (+ (square 5) 1))) 24 | 25 | ; (duck-compile 'x) 26 | ; (duck-compile '(begin 27 | ; (set! a (foo 7)) 28 | ; (set! b (cons 1 (bar 3 4)))) 29 | ; ) 30 | 31 | ; (duck-compile '1000) 32 | ; (duck-compile '(define a "test")) 33 | 34 | 35 | ; (duck-compile '(define square 36 | ; (lambda (x) 37 | ; (* x x)))) 38 | 39 | ; (cps '(lambda (x) (set! x 10) ) id) 40 | 41 | ; (duck-compile '(lambda (x) (set! x 10) )) 42 | ;;(duck-compile '(lambda (x) (* x x) )) 43 | 44 | ; (duck-compile '(f (if a b c))) 45 | ; (duck-compile '(lambda (x) x) ) 46 | 47 | (test-all) 48 | -------------------------------------------------------------------------------- /arch/arch.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (arch arch) 8 | (export 9 | ;;regs 10 | reg0 reg1 reg2 reg3 reg4 reg5 reg6 reg7 regs regs-map 11 | ;;instruct 12 | asm set mref mset note 13 | add label sar sal mul sub div 14 | shl shr ret 15 | call jmp cmp-jmp cmp 16 | land lor xor save restore 17 | nop local proc pret lproc lret 18 | fcall ccall 19 | stext sexit 20 | data sdata 21 | asm-compile-exp 22 | arch-bits 23 | ) 24 | 25 | (import 26 | (common common) 27 | (common match) 28 | (common trace) 29 | (duck options) 30 | (rename (scheme) (div div2) ) 31 | ; (x86) 32 | ; (wasm) 33 | ) 34 | 35 | (define-syntax import-arch 36 | (lambda (x) 37 | (syntax-case x () 38 | ((_ k) 39 | (datum->syntax #'k `(import 40 | ,(case (option-get 'arch 'x86) 41 | ['x86 '(arch x86)] 42 | ['wasm '(arch wasm)] 43 | ['llvm '(arch llvm)] 44 | [else (error 'platform "not support ")] 45 | )) 46 | )))) 47 | ) 48 | 49 | (import-arch options) 50 | 51 | ) -------------------------------------------------------------------------------- /tests/test-basic.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-print "test basic" 5 | 0 6 | -1 7 | -0 8 | -5 9 | 5 10 | 1000 11 | #t 12 | #f 13 | ['() ()] 14 | [(void) ()] 15 | [(begin (+ 1 2)) 3] 16 | "test" 17 | ; "哈哈" 18 | 19 | ['100 100] 20 | ['#f #f] 21 | 22 | ['(1 2) (1 2)] 23 | ; ['a a] 24 | ; ['(a) (a)] 25 | ; ['(a b c) (a b c)] 26 | ; [(quote haha) haha] 27 | ; [(quote (quote a)) "(quote a)"] 28 | ; [''a "(quote a)"] 29 | ; ['((A) B C) ((A) B C)] 30 | ; ['(3 4) (3 4)] 31 | ; ['(3 . 4) (3 . 4)] 32 | ; ['(((1 . 2) (3 . 4)) (5 . 6)) (((1 . 2) (3 . 4)) (5 . 6))] 33 | ; ['((0 . #t) (1 . #f) (3 . #t)) ((0 . #t) (1 . #f) (3 . #t))] 34 | ; '"abc" 35 | ; ['(+ 1 2) (+ 1 2)] 36 | 37 | ; ; '#(1 2 3) 38 | ; ; '#((2 . 3) #f #t (#t . 4)) 39 | 40 | [(null? '()) #t] 41 | [(null? 1) #f] 42 | [(cdr '(1 . 2)) 2] 43 | [(pair? '(1 . 2)) #t] 44 | [(pair? (cons 1 2)) #t] 45 | [(car (cons 1 2)) 1] 46 | [(cons 1 2) (1 . 2)] 47 | 48 | [(cdr (cons 1 2)) 2] 49 | [(null? (cdr (cons 1 '()))) #t] 50 | 51 | [(car '(1 . 2)) 1] 52 | ['(1 2) (1 2)] 53 | 54 | 55 | ; (vector-ref '#(1 2 3) 1) 56 | ; (vector-length '#(1 2 3)) 57 | ; (vector-length (make-vector 10)) 58 | ) 59 | 60 | 61 | (test-all) 62 | -------------------------------------------------------------------------------- /tests/test0/rand.ss: -------------------------------------------------------------------------------- 1 | ; (define x 123456789) 2 | ; (define y 362436069) 3 | ; (define z 521288629) 4 | 5 | ; (define (rand x y z ) 6 | ; (define t '()) 7 | ; (let* 8 | ; ([x1 (logxor x (logand #xffffffffffffffff (bitwise-arithmetic-shift-left x 16))) ] 9 | ; [x2 (logxor x1 (bitwise-arithmetic-shift-right x1 5))] 10 | ; [x3 (logxor x2 (logand #xffffffffffffffff (bitwise-arithmetic-shift-left x2 1))) ]) 11 | ; (set! t x3) 12 | ; (set! x y) 13 | ; (set! y z) 14 | ; (set! z (logxor t x y)) 15 | ; z)) 16 | 17 | ; (define (rand-init x y z) 18 | ; (define t '()) 19 | ; (lambda () 20 | ; (let* ( 21 | ; (x1 (logxor x (logand #xffffffffffffffff (bitwise-arithmetic-shift-left x 16)))) 22 | ; (x2 (logxor x1 (ash x1 -5))) 23 | ; (x3 (logxor x2 (logand #xffffffffffffffff (bitwise-arithmetic-shift-left x2 1)))) 24 | 25 | ; ) 26 | ; (set! t x3) 27 | ; (set! x y) 28 | ; (set! y z) 29 | ; (set! z (logxor t x y)) 30 | ; z)) 31 | ; ) 32 | 33 | ; (define rand-maker (rand-init 123456789 362436069 521288629)) 34 | 35 | (define gseed 1) 36 | 37 | (define (rand-int) 38 | (set! gseed (+ 2531011 (* gseed 214013 ) )) 39 | (logand #xffffffffffffffff (ash gseed 16)) 40 | ) 41 | 42 | 43 | 44 | (time (let loop ((n 25000000)) 45 | (if (> n 0) 46 | (let ((r (rand-int))) 47 | (printf "rand ~a\n" r ) 48 | (loop (- n 1)) 49 | ) 50 | ) 51 | )) 52 | -------------------------------------------------------------------------------- /tests/test-print.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | 5 | (add-test "test print" 6 | [(printc "haha") "haha"] 7 | [(printc "if=%d" (if (< 3 2) (+ 3 4) (+ 4 5))) "if=9"] 8 | [(printc "if=%d" (if 0 12)) "if=12"] 9 | [(printc "if=%d" (if (> 3 2) (+ 3 4) ) ) "if=7"] 10 | 11 | [(printc "if=%d" 12 | (if (= 1 1) 13 | 0 14 | (if (= 1 1) 15 | 1 16 | 2 17 | ) 18 | )) 19 | "if=0"] 20 | [(printc "ret=%d" (let ((a 10) (b 11) (c 12) (d 13)) 1 2 3 4 (let () 5 6 )) ) "ret=6"] 21 | [(printc "ret=%d %d" 22 | (let ((a 10) (b 11) (c 12) (d 13)) 23 | (printc "call a=%d " a) 24 | (printc "call2 b=%d " b) 25 | (printc "call3 c=%d " c) 26 | (printc "call4 d=%d " d) 27 | 1 2 3 4 28 | (let () 5 6 ) 29 | ) 30 | (let ((a 20) (b 21) (c 22) ) 31 | (printc "mid call a=%d " a) 32 | (printc "mid call2 b=%d " b) 33 | (printc "mid call3 c=%d " c) 34 | (printc "mid call4 d=%d " d) 35 | 1 2 3 4 36 | (let () 5 6 ) 37 | ) 38 | ) "call a=10 call2 b=11 call3 c=12 call4 d=13 mid call a=20 mid call2 b=21 mid call3 c=22 mid call4 d=13 ret=6 6"] 39 | [(printc "%s %d" "(+ 1 100000)=" (+ 1 100000)) "(+ 1 100000)= 100001"] 40 | 41 | [(printc "ret=%d" 42 | (let loop2 ((i 0) ) 43 | (printc "i -> %d" i) 44 | (loop2 (+ i 1)) 45 | )) 46 | '()] 47 | ) 48 | 49 | (test-all) 50 | -------------------------------------------------------------------------------- /tests/test-define.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test "test define" 5 | ; [(define a 100) ""] 6 | ; [(define square 7 | ; (lambda (x) 8 | ; (* x x))) 9 | ; "" 10 | ; ] 11 | ; [(define (square x b) 12 | ; (* x x)) 13 | ; "" 14 | ; ] 15 | 16 | [(begin 17 | (define a 100) 18 | (define (test x) x) 19 | ) 20 | 21 | "" 22 | ] 23 | 24 | ; [(begin 25 | ; (define hello (lambda (n) 26 | ; (printc "hello") 27 | ; )) 28 | ; (hello) 29 | ; ) 30 | ; "hello" 31 | ; ] 32 | 33 | 34 | ; [(begin 35 | ; (define fib (lambda (n) 36 | ; (printc "fib(%d)" n) 37 | ; (fib (- n 1)) 38 | ; )) 39 | ; (fib 10) 40 | ; ) 41 | ; '() 42 | ; ] 43 | 44 | ;;no pass 45 | 46 | ; [(begin 47 | ; (define fib (lambda (n) 48 | ; ;;(printc "fib[%d] \\n" n) 49 | ; (if (= n 0) 50 | ; (begin 51 | ; (printc "1 ") 52 | ; 0 53 | ; ) 54 | ; (if (= n 1) 55 | ; (begin 56 | ; (printc "2 ") 57 | ; 1 58 | ; ) 59 | ; (begin 60 | ; (printc "f2[%d] " n) 61 | ; (+ (fib (- n 1)) (fib (- n 2))) 62 | ; ) 63 | ; ) 64 | ; ) 65 | ; )) 66 | ; (printc "test=%d" (fib 10)) 67 | ; ) '()] 68 | 69 | 70 | 71 | ) 72 | 73 | ; (add-test "test combine" 74 | ; [(set! square (lambda (x) (* x x))) '()] 75 | ; [(define a (lambda () (a))) '()] 76 | ; [(begin 77 | ; (define (factorial n) 78 | ; (define (iter product counter) 79 | ; (if (> counter n) 80 | ; product 81 | ; (iter (* counter product) 82 | ; (+ counter 1)))) 83 | ; (iter 1 1)) 84 | ; (printc "ret=%d" (factorial 30)) ) 85 | 86 | ; '()] 87 | ; ) 88 | 89 | (test-all) 90 | -------------------------------------------------------------------------------- /tests/test0/test-print.s: -------------------------------------------------------------------------------- 1 | ;;/opt/local/bin/nasm test-print.s -f macho && ld -macosx_version_min 10.6 -arch i386 -e _start -no_pie -lc test-print.o test-print 2 | extern _printf 3 | extern _exit 4 | extern _malloc 5 | 6 | section .text 7 | global _start 8 | 9 | %macro clib_prolog 1 10 | mov ebx, esp ; remember current esp 11 | and esp, 0xFFFFFFF0 ; align to next 16 byte boundary (could be zero offset!) 12 | sub esp, 12 ; skip ahead 12 so we can store original esp 13 | push ebx ; store esp (16 bytes aligned again) 14 | sub esp, %1 ; pad for arguments (make conditional?) 15 | %endmacro 16 | 17 | ; arg must match most recent call to clib_prolog 18 | %macro clib_epilog 1 19 | add esp, %1 ; remove arg padding 20 | pop ebx ; get original esp 21 | mov esp, ebx ; restore 22 | %endmacro 23 | 24 | _start: 25 | ; Store 'argc' into EAX 26 | pop eax 27 | ; Store 'argv' into EBX 28 | pop ebx 29 | 30 | ; Align stack on a 16 bytes boundary, 31 | ; as we'll use C library functions 32 | mov ebp, esp 33 | and esp, 0xFFFFFFF0 34 | 35 | ; Stack space for local variables 36 | ; A little more space than needed, but that will 37 | ; ensure the stack is still aligned 38 | 39 | call test_print 40 | 41 | ;sub esp,16 42 | ; Call 'printf': printf( hello, ebx, eax ); 43 | ;mov dword[ esp ], hello 44 | ;mov dword[ esp + 4 ], ebx 45 | ;mov dword[ esp + 8 ], eax 46 | ;call _printf 47 | ;add esp,16 48 | 49 | 50 | ; Call 'exit': exit( 0 ); 51 | mov dword[ esp ], 0 52 | call _exit 53 | ret 54 | 55 | test_print: 56 | 57 | clib_prolog 16 58 | mov dword[ esp ], hello 59 | mov dword[ esp + 4 ], 100 60 | call _printf 61 | clib_epilog 16 62 | 63 | ret 64 | 65 | 66 | section .data 67 | hello db "Program name: %d", 10, 0 -------------------------------------------------------------------------------- /common/trace.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (common trace) 8 | (export 9 | print-stack-trace 10 | stack-trace-exception 11 | stack-trace 12 | print-lambda 13 | ) 14 | (import (scheme)) 15 | 16 | (define (print-stack-trace e) 17 | (define (get-func c) 18 | (let ((cc ((c 'code) 'name))) 19 | (if cc cc "--main--"))) 20 | (display-condition e) (newline) 21 | (let p ((t (inspect/object (condition-continuation e)))) 22 | (call/cc 23 | (lambda (ret) 24 | (if (> (t 'depth) 1) 25 | (begin 26 | (call-with-values 27 | (lambda () (t 'source-path)) 28 | (case-lambda 29 | ((file line column) 30 | (printf "\tat ~a (~a:~a,~a)\n" (get-func t) file line column)) 31 | (else (ret)))) 32 | (p (t 'link))))))) 33 | (exit)) 34 | (define (stack-trace-exception) 35 | (base-exception-handler print-stack-trace)) 36 | 37 | 38 | (define (stack-trace obj) 39 | (call/cc (lambda (k) 40 | (printf "backtrace of [~a] as following:\n" obj) 41 | (let loop ((cur (inspect/object k)) (i 0)) 42 | (if (and (> (cur 'depth) 1) ) 43 | (begin 44 | (call-with-values 45 | (lambda () (cur 'source-path)) 46 | (case-lambda 47 | ((file line char) (printf "\tat ~a (~a:~a)\n" ((cur 'code) 'name) file line)) 48 | ((file line) (printf "\tat ~a (~a:~a)\n" ((cur 'code) 'name) file line)) 49 | (else (k)))) 50 | (loop (cur 'link) (+ i 1)))))))) 51 | 52 | (define (print-lambda fun) 53 | (printf "lambda of [~a] as following:\n" fun) 54 | (pretty-print ((((inspect/object fun ) 'code) 'source) 'value)) ) 55 | ) -------------------------------------------------------------------------------- /tests/test-remove-code.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) (egg) ) 3 | 4 | (define code `(code 5 | (code 6 | (code 7 | (code 8 | (= 8 9 | 8)) 10 | (cmp-jmp 11 | reg0 12 | false-rep 13 | ifb.0 14 | ifa.0) 15 | (label 16 | ifa.0) 17 | (code 18 | (set reg0 0)) 19 | (jmp ifend.0) 20 | (label 21 | ifb.0) 22 | (code 23 | (code 24 | (= 16 25 | 16)) 26 | (cmp-jmp 27 | reg0 28 | false-rep 29 | ifb.1 30 | ifa.1) 31 | (label 32 | ifa.1) 33 | (code 34 | (set reg0 8)) 35 | (jmp ifend.1) 36 | (label 37 | ifb.1) 38 | (code 39 | (set reg0 16)) 40 | (label 41 | ifend.1)) 42 | (label 43 | ifend.0)) 44 | (set var.0 reg0)) 45 | (code 46 | (print-value 47 | var.0))) 48 | ) 49 | 50 | ;;return demo 51 | ; ( (= 8 8)) 52 | ; (cmp-jmp reg0 #fse-rep ifb.0 ifa.0) 53 | ; (label ifa.0) (set reg0 0) (jmp ifend.0) 54 | ; (label ifb.0) 55 | ; (= 16 16)) 56 | ; (cmp-jmp reg0 #fse-rep ifb.1 ifa.1) 57 | ; (label ifa.1) 58 | ; (set reg0 8) 59 | ; (jmp ifend.1) 60 | ; (label ifb.1) 61 | ; (set reg0 16) 62 | ; (label ifend.1) 63 | ; (label ifend.0) 64 | ; (set var.0 reg0) 65 | ; (print-value var.0) 66 | ; ) 67 | 68 | 69 | ; (define (remove-begin e ) 70 | ; (match e 71 | ; [(begin (begin ,e1 ... ) ,e2 ...) 72 | ; (remove-begin `(begin ,@e1 ,@e2)) 73 | ; ] 74 | ; [(begin ,e1 ... (begin ,e2 ... ) ,e3 ... ) 75 | ; (printf "begin ===>\n") 76 | ; `(begin ,@e1 ,@e2 ,@e3) 77 | ; ] 78 | ; [(begin ,apps ...) 79 | ; `(begin ,@(map remove-begin apps)) 80 | ; ] 81 | ; [,v v] 82 | ; ) 83 | ; ) 84 | (pretty-format 'code '(_ 0 name 0 args 0 vars ... )) 85 | (pretty-print code) 86 | 87 | (set! code `(code (set reg0 x))) 88 | 89 | (let ((ret (remove-code code))) 90 | (printf "result=>\n") 91 | (pretty-print ret) 92 | ) 93 | 94 | ;;(pretty-print (remove-code code)) 95 | -------------------------------------------------------------------------------- /tests/test0/test-list.ss: -------------------------------------------------------------------------------- 1 | (define make-matrix 2 | (lambda (name rnum cnum) 3 | ;;(hashtable-set! @@@@mt name (list rnum cnum)) 4 | (set-box! name (make-bytevector (* rnum cnum 8))))) 5 | 6 | (define m (box '())) 7 | 8 | 9 | (define make-matrix2 10 | (lambda (name rnum cnum) 11 | ; (hashtable-set! @@@@mt name (list rnum cnum)) 12 | (set-box! name (make-vector (* rnum cnum))))) 13 | 14 | 15 | (define make-list2 16 | (case-lambda 17 | [(n) (make-list n (if #f #f))] 18 | [(n v) (let loop ([n n] [ls '()]) 19 | (if (zero? n) 20 | ls 21 | (loop (fx- n 1) (weak-cons v ls))))])) 22 | 23 | (define make-matrix3 24 | (lambda (name rnum cnum) 25 | ;;(hashtable-set! @@@@mt name (list rnum cnum)) 26 | (make-list2 (* rnum cnum ) ))) 27 | 28 | (define make-matrix4 29 | (lambda (name rnum cnum) 30 | ;;(hashtable-set! @@@@mt name (list rnum cnum)) 31 | (make-list (* rnum cnum ) ))) 32 | 33 | ; (collect-request-handler (lambda () 34 | ; ;(printf "request\n" ) 35 | ; #f 36 | ; )) 37 | 38 | ; (collect-trip-bytes (* 10000 10000 10000) ) 39 | ; (collect-generation-radix 1) 40 | (heap-reserve-ratio 1600000000) 41 | ; (collect-maximum-generation 254) 42 | 43 | (collect-request-handler void) 44 | ; (collect-request-handler (lambda() (collect))) 45 | 46 | ; (time (make-list2 (* 10000 10000 ))) 47 | 48 | 49 | 50 | (define rand 51 | (lambda () 52 | (* (random 101) 0.01))) 53 | (define make-matrix-rand 54 | (lambda (name rnum cnum) 55 | ;;(hashtable-set! @@@@mt name (list rnum cnum)) 56 | (let loop ([i 0][end (* rnum cnum)][Res '()]) 57 | (cond 58 | ((eq? i end) (set-box! name (list->vector Res))) 59 | (else (loop (+ 1 i) end (cons (rand) Res))))))) 60 | 61 | 62 | (define n (box 0)) 63 | ; (time (make-matrix-rand n 5000 5000) ) 64 | 65 | 66 | ; (compile-profile #t) 67 | 68 | (parameterize ([compile-profile 'source]) 69 | (load "./rand.ss") ) 70 | (profile-dump-html "rand") 71 | 72 | ; (printf "==>~a\n" (profile-dump)) 73 | ; (printf "===>~a\n" (profile-dump-list) ) 74 | 75 | 76 | 77 | ; 78 | ; (profile-dump-html) 79 | ; (profile-dump-list) 80 | ; (let () 81 | ; (compile-profile #t) 82 | ; (time (make-matrix-rand n 5000 5000) ) 83 | ; ; (profile-dump-html) 84 | ; (profile-dump-list) 85 | ; ) 86 | 87 | ; (time 88 | ; (let loop ([i 0]) 89 | ; (when (< i 5) (make-matrix m 10000 10000) (loop (+ 1 i )) ))) 90 | 91 | ; (time (make-matrix m 10000 10000)) 92 | ; (time (make-matrix2 m 10000 10000)) 93 | ; (time (make-matrix3 m 10000 10000)) 94 | ; (time (make-matrix4 m 10000 10000)) -------------------------------------------------------------------------------- /tests/test0/test-bm.ss: -------------------------------------------------------------------------------- 1 | (define (compute-last-occ p) 2 | (let ((last-occ (make-vector 128 -1))) 3 | (let loop ((len (- (string-length p) 1)) 4 | (i 0)) 5 | (if (< i len) 6 | (begin 7 | (vector-set! last-occ (char->integer (string-ref p i)) i) 8 | ; (printf "char=~a int=~a i=~a\n" 9 | ; (string-ref p i) 10 | ; (char->integer (string-ref p i)) 11 | ; i 12 | ; ) 13 | ;(printf "==>~a\n" last-occ ) 14 | (loop len (+ i 1)) 15 | ) 16 | ) 17 | ) 18 | last-occ 19 | )) 20 | 21 | (define (bmh t p) 22 | (let ((last-occ (compute-last-occ p)) 23 | (i0 0) 24 | (n (string-length t)) 25 | (m (string-length p)) 26 | (j -1) 27 | (ret -1) 28 | (is-not-ret #t) 29 | ) 30 | ; (printf "vec=>~a" last-occ) 31 | ; (print-last-occ last-occ) 32 | (let loop () 33 | (if (< i0 (- n m)) 34 | (begin 35 | (set! j (- m 1)) 36 | ; (printf "i0=~a j=~a\n" i0 j) 37 | (let loop2 () 38 | (if (char=? (string-ref p j) (string-ref t (+ i0 j)) ) 39 | (begin 40 | (set! j (- j 1)) 41 | (if (< j 0) 42 | (begin 43 | (set! is-not-ret #f) 44 | ; (printf "ret====>~a\n" i0) 45 | (set! ret i0) ) 46 | (loop2) 47 | )))) 48 | (if is-not-ret 49 | (begin 50 | (set! i0 (+ i0 51 | (- m 1) 52 | (- (vector-ref last-occ 53 | (char->integer (string-ref t (+ i0 m -1))) ) ) )) 54 | ; (printf "i0=~a val=>~a char=>~a\n" 55 | ; i0 56 | ; (vector-ref last-occ 57 | ; (char->integer (string-ref t (+ i0 m -1))) ) 58 | ; (string-ref t (+ i0 m -1)) ) 59 | (loop))) 60 | ))) 61 | ret)) 62 | 63 | (define (print-last-occ last-occ) 64 | (let loop ((i (char->integer #\a)) (j 0) ) 65 | (if (<= i (char->integer #\z)) 66 | (begin 67 | (printf "~a ~a;" (integer->char i) (vector-ref last-occ i)) 68 | (set! j (+ j 1)) 69 | (if (= 0 (/ j 13)) 70 | (newline) 71 | ) 72 | (loop (+ i 1) j) 73 | ) 74 | ) 75 | ) 76 | ) 77 | 78 | (let ((l (compute-last-occ "abacbb" ) )) 79 | (print-last-occ l) 80 | (printf "b=>~a\n" (vector-ref l (char->integer #\b))) 81 | 82 | ;(printf "last-occ =>~a" l) 83 | ) 84 | (bmh "abacaxbaccabacbbaabb" "abacbb") -------------------------------------------------------------------------------- /tests/test-tail-call.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | 5 | ; (add-test "test tail call" 6 | ; [(let g (fix f (lambda (n a) (if (zero? n) a (f (- n 1) (* n a))))) 7 | ; (g 10 1)) '()] 8 | ; ) 9 | 10 | 11 | (add-test "test tail call conversion" 12 | ; [(let ([a (fib 10)]) 13 | ; (+ 1 a)) 14 | ; '(fib (lambda (a) 15 | ; (+ 1 a) 16 | ; ) 10) 17 | 18 | ; ] 19 | 20 | ;;test normal tail call 21 | [(begin 22 | (define aa (lambda (a) a)) 23 | (define f (lambda (n) 24 | (printc "f(%d) " n) 25 | (if (= n 0) 26 | 0 27 | (f (- n 1)) 28 | ) 29 | )) 30 | (printc "%d" (f 100)) 31 | ) 32 | '0 33 | ] 34 | 35 | [(let ((f (lambda (n) 36 | (printc "f(%d) " n) 37 | (if (= n 0) 38 | -1 39 | (f (- n 1)) 40 | ) 41 | ))) 42 | (printc "%d" (f 100)) 43 | ) 44 | '-1 45 | ] 46 | 47 | ;;test fib iter tail call ok 48 | [(let ((fib (lambda (n a b) 49 | (if (<= n 1) 50 | b 51 | (fib (- n 1) b (+ a b) ) 52 | ) 53 | ))) 54 | (printc "%d" (fib 30 0 1)) 55 | ) 56 | '832040 57 | ] 58 | 59 | ; [(begin 60 | ; (define Y 61 | ; (lambda (f) 62 | ; ((lambda (x) (x x)) 63 | ; (lambda (x) (f (lambda (y) ((x x) y))))))) 64 | 65 | ; ; (define fib 66 | ; ; (Y (lambda (f) 67 | ; ; (lambda (x) 68 | ; ; (if (< x 2) 69 | ; ; x 70 | ; ; (+ (f (- x 1)) (f (- x 2)))))))) 71 | 72 | ; (define fib 73 | ; (lambda (x) 74 | ; ((Y (lambda (f) 75 | ; (lambda (n a b) 76 | ; (if (<= n 1) 77 | ; b 78 | ; (f (- n 1) b (+ a b)))))) 79 | ; x 0 1))) 80 | 81 | ; (printc "%d" (fib 35)) 82 | ; ) 83 | ; '9227465] 84 | 85 | [(define fac (lambda (n) 86 | (if (< n 2 ) 87 | 1 88 | (* n (fac (- n 1))) 89 | ) 90 | )) 91 | 92 | '()] 93 | 94 | 95 | [(define fib (lambda (n) 96 | (if (<= n 1) 97 | n 98 | (+ (fib (- n 1)) (fib (- n 2)))))) 99 | 100 | '(letrec ((fib (lambda (n a b) 101 | (if (<= n 1) 102 | b 103 | (fib (- n 1) b (+ a b) ) 104 | ) 105 | ))) 106 | (fib 6 0 1) 107 | ) 108 | ] 109 | 110 | ; [(k.0 (fib var.1)) 111 | ; '() 112 | ; ] 113 | 114 | [(begin 115 | (define fib (lambda (n) 116 | (if (<= n 1) 117 | n 118 | (+ (fib (- n 1)) (+ 1 2) (fib (- n 2)))))) 119 | (fib 10)) 120 | 6765 ] 121 | 122 | ;tail call no if 123 | [(begin 124 | (define fib (lambda (n) 125 | (+ (fib (- n 1)) (+ 1 2) (fib (- n 2))))) 126 | (fib 10)) 127 | 6765 ] 128 | 129 | ) 130 | 131 | (test-all) 132 | -------------------------------------------------------------------------------- /docs/exp.txt: -------------------------------------------------------------------------------- 1 | [1,2,3] (list 1 2 3) 2 | f(10,20) (f 10 20) 3 | 4 | (equal? (list 'a 'b ) '(a b)) => #t 5 | 'a => (quote a) 6 | (list (quote a) (quote b)) => '(a b) 7 | 8 | > (cons 1 2) 9 | (1 . 2) 10 | > (cons 3 (cons 1 2)) 11 | (3 1 . 2) 12 | (cons 3 (cons 1 '()) ) ) 13 | (3 1) 14 | 15 | > '(b . (c . (d . nil))) 16 | (b c d . nil) 17 | (cons b (cons c (cons d nil))) 18 | 19 | (cons 1 '()) 20 | (1) 21 | 22 | 23 | > (define x '(1 . 2)) 24 | # 25 | > (set-cdr! x (cons 2 '())) 26 | # 27 | > x 28 | (1 2) 29 | 30 | > (equal? '(a) '(a) ) 31 | #t 32 | > (eqv? '(a) '(a) ) 33 | #f 34 | 35 | 36 | void f() { 37 | return x*x; 38 | } 39 | 40 | if(a>b){ 41 | 42 | } 43 | 44 | (if (> a b) 45 | (begin xxx)) 46 | 47 | 48 | #include 49 | 50 | int main(int argc, char** argv) { 51 | puts("Hello, world!"); 52 | return 0; 53 | } 54 | 55 | 变量 56 | 函数 57 | 58 | scm 59 | c 60 | asm 61 | 62 | 《鸭语言》 63 | 64 | 菩萨蛮 65 | 问君何事轻离别，一年能几团圆月。 66 | 杨柳乍如丝，故园春尽时。 67 | 春归归不得，两桨松花隔。 68 | 旧事逐寒潮，啼鹃恨未消。 69 | 70 | 函数对应的语文. 71 | 72 | 73 | 74 | 《树木》 75 | 移动树木，到三百米。 76 | 当到三百米，锯成两段。 77 | 裁剪树枝，摘掉树叶。 78 | 79 | move(tree),to(300)。 80 | if=300,cut(2)。 81 | cut(branch),takeoff(leaf)。 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | (let ([fib (lambda (n) 93 | (let ([var.4 (alloc "fib(%d)")]) 94 | (let ([var.0 (printc var.4 n)]) 95 | (let ([var.5 (- n 8)]) (tail fib var.5)))))]) 96 | (let ([var.1 fib]) (fib 80))) 97 | 98 | ==> 99 | 100 | (program 'main 101 | ();; args 102 | ();; vars 103 | 104 | (program 'fib 105 | (n);; args 106 | (var.4 var.0 var.5 var.1) ;; local global vars 107 | (alloc "fib(%d)") 108 | (set var.4 ret) 109 | (printc var.4 n) 110 | (set var.0 ret) 111 | (- n 8) 112 | (set var.5 ret) 113 | (call fib var.5) 114 | ) 115 | 116 | (program 'main 117 | ();; args 118 | (var.1 fib) ;; vars 119 | (set var.1 fib) 120 | (call fib 80) 121 | ) 122 | 123 | ) 124 | 125 | 126 | 127 | (let ([fib (lambda (n) 128 | (let ([var.4 (alloc "fib(%d)")]) 129 | (let ([var.0 (printc var.4 n)]) 130 | (let ([var.5 (- n 8)]) (tail fib var.5)))))]) 131 | 132 | => 133 | (program main () () 134 | (program fib (n) 135 | (var.4 var.0 var.5) 136 | (alloc "fib(%d)") 137 | (set var.4 ret) 138 | (printc var.4 n) 139 | (set var.0 ret) 140 | (- n 8) 141 | (set var.5 ret) 142 | (tail fib var.5)) 143 | (program main 144 | () 145 | (fib var.1) 146 | fib 147 | (set var.1 ret) 148 | (fib 80)) 149 | 150 | => 151 | (program main 152 | (program fib 153 | (set (local 1) ret) 154 | (printc (local 1) (local 0)) 155 | (set (local 2) ret) 156 | (- (local 0) 8) 157 | (set (local 3) ret) 158 | (tail fib (local 3)) 159 | ) 160 | (program main 161 | (fib (local 0)) 162 | (set (local 0) ret) 163 | (fib 80) 164 | ) 165 | ) 166 | 167 | => 168 | 169 | (program main 170 | (program fib 171 | (mov esp+4 eax) 172 | (printc (local 1) (local 0)) 173 | (set (local 2) ret) 174 | (- (local 0) 8) 175 | (set (local 3) ret) 176 | (tail fib (local 3)) 177 | ) 178 | (program main 179 | (fib (local 0)) 180 | (set (local 0) ret) 181 | (fib 80) 182 | ) 183 | ) 184 | 185 | => 186 | 187 | (block all 188 | (block main 189 | (fib (local 0)) 190 | (set (local 0) ret) 191 | (fib 80) 192 | ) 193 | (block fib 194 | (mov esp+4 eax) 195 | (printc (local 1) (local 0)) 196 | (set (local 2) ret) 197 | (- (local 0) 8) 198 | (set (local 3) ret) 199 | (tail fib (local 3)) 200 | ) 201 | (block data 202 | 203 | ) 204 | 205 | ) 206 | 207 | 208 | (let ([loop2 (lambda (x) 209 | (let ([var.0 (if (let ([var.1 (string-ref str x)]) 210 | (> var.1 0)) 211 | (let ([var.2 (+ x 1)]) (loop2 var.2)) 212 | (void))]) 213 | x))]) 214 | (let ([string-length (lambda (str) (loop2 0))]) 215 | (print-value string-length))) -------------------------------------------------------------------------------- /tests/test-fib.ss: -------------------------------------------------------------------------------- 1 | ;; test 2 | (import (scheme) (test) (duck) ) 3 | 4 | (add-test-string "test fib" 5 | ; [(begin 6 | ; (define f (lambda (n) 7 | ; (printc "f(%d)" n) 8 | ; (if (> n 0) 9 | ; (f (- n 1)) 10 | ; n 11 | ; ) 12 | ; ) 13 | ; ) 14 | ; (f 10) 15 | ; ) 16 | ; "f(10)f(9)f(8)f(7)f(6)f(5)f(4)f(3)f(2)f(1)f(0)" 17 | ; ] 18 | ; [(begin 19 | ; (define f (lambda (n) 20 | ; (printc "f(%d)" n) 21 | ; (if (> n 0) 22 | ; (if (= n 1) 23 | ; 1 24 | ; (if (= n 2) 25 | ; 2 26 | ; (f (- n 1)) ) 27 | ; ) 28 | ; 0 29 | ; ) 30 | ; )) 31 | ; (printc "%d" (f 10)) 32 | ; ) 33 | ; "f(10)f(9)f(8)f(7)f(6)f(5)f(4)f(3)f(2)2" 34 | ; ] 35 | ; [(begin 36 | ; (define fib (lambda (n) 37 | ; (if (<= n 1) 38 | ; n 39 | ; (+ ( fib (- n 1)) (fib (- n 2))) ) 40 | ; )) 41 | ; (print-value (fib 10))) 42 | ; 55 ] 43 | 44 | ; [(begin 45 | ; (define fib (lambda (n) 46 | ; (if (= n 0) 47 | ; 0 48 | ; (if (= n 1) 49 | ; 1 50 | ; (+ ( fib (- n 1)) (fib (- n 2))) )) 51 | ; )) 52 | ; (print-value (fib 10))) 53 | ; 55 ] 54 | 55 | [(begin 56 | (define fib (lambda (n) 57 | (printc "f(%d) " n) 58 | (if (<= n 0) 59 | (begin 60 | (printc "=>0 ") 61 | 0 62 | ) 63 | (if (= n 1) 64 | (begin 65 | (printc "=>1 " n) 66 | 1 67 | ) 68 | (let ((r (+ (fib (- n 1)) (fib (- n 2))) )) 69 | (printc "=>%d " r) 70 | r 71 | ) 72 | ) 73 | ) 74 | )) 75 | (printc "ret=%d" (fib 10))) 76 | ; "f(10) f(9) f(8) f(7) f(6) f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 =>8 f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 =>13 f(6) f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 =>8 =>21 f(7) f(6) f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 =>8 f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 =>13 =>34 f(8) f(7) f(6) f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 =>8 f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 =>13 f(6) f(5) f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 =>5 f(4) f(3) f(2) f(1) =>1 f(0) =>0 =>1 f(1) =>1 =>2 f(2) f(1) =>1 f(0) =>0 =>1 =>3 =>8 =>21 =>55 ret=55" 77 | 55 78 | ] 79 | 80 | ; [(begin 81 | ; (define fact 82 | ; (lambda (n) 83 | ; (if (= n 1) 84 | ; 1 85 | ; (* n (fact (- n 1)))))) 86 | ; (fact 8)) 87 | ; 40320] 88 | 89 | ; (define fact-iter 90 | ; (lambda (n acc) 91 | ; (if (= n 1) 92 | ; acc 93 | ; (fact-iter (- n 1) (* n acc))))) 94 | 95 | ; [(begin 96 | ; (define Y 97 | ; (lambda (f) 98 | ; ((lambda (x) (x x)) 99 | ; (lambda (x) (f (lambda (y) ((x x) y))))))) 100 | 101 | 102 | ; (define F-fibonacci 103 | ; (lambda (f) 104 | ; (lambda (n) 105 | ; (if (= n 0) 106 | ; 0 107 | ; (if 108 | ; (= n 1) 109 | ; 1 110 | ; (+ (f (- n 1)) (f (- n 2))) 111 | ; )) 112 | ; ))) 113 | 114 | 115 | ; (define fibonacci-4 (Y F-fibonacci)) 116 | ; (printc "fib=%d" (fibonacci-4 30)) 117 | ; ) 118 | ; 832040 119 | ; ] 120 | 121 | ) 122 | 123 | 124 | (test-all) 125 | -------------------------------------------------------------------------------- /duck/type.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (duck type) 8 | (export 9 | type-shift 10 | type-mask 11 | fixnum-tag 12 | pair-tag 13 | box-tag 14 | vector-tag 15 | closure-tag 16 | string-tag 17 | symbol-tag 18 | const-tag 19 | const-mask 20 | boolean-tag 21 | boolean-mask 22 | 23 | true-tag 24 | false-tag 25 | null-tag 26 | true-rep 27 | false-rep 28 | null-rep 29 | void-rep 30 | void-tag 31 | type-rep 32 | 33 | type? 34 | type-value 35 | ) 36 | 37 | (import (scheme) 38 | (common match) 39 | (common trace) 40 | (common common) 41 | ) 42 | 43 | ;;;types 44 | (define type-shift 3) 45 | (define type-mask #b111) 46 | ;;types tag 47 | (define fixnum-tag #b000) 48 | (define pair-tag #b001) 49 | (define box-tag #b010) 50 | (define vector-tag #b011) 51 | (define closure-tag #b100) 52 | (define string-tag #b110) 53 | (define symbol-tag #b111) 54 | 55 | ;;const 56 | (define const-tag #b101) 57 | (define const-mask #b111111) 58 | 59 | (define boolean-tag #b1101) 60 | (define boolean-mask #b1111) 61 | 62 | (define true-tag #b111) 63 | (define false-tag #b101) 64 | 65 | (define null-tag #b100) 66 | (define void-tag #b110) 67 | 68 | (define true-rep #b111101) 69 | (define false-rep #b101101) 70 | 71 | (define null-rep #b100101) 72 | (define void-rep #b110101) 73 | 74 | 75 | (define (type-rep x) 76 | (cond 77 | [(equal? (void) x) void-rep] 78 | [(integer? x) 79 | (bitwise-arithmetic-shift-left x type-shift)] 80 | [(boolean? x) (if x true-rep false-rep)] 81 | [(or (null? x) 82 | (and (pair? x) (equal? (car x) 'quote )) 83 | (and (pair? x) (null? (cadr x))) ) 84 | null-rep] 85 | [(symbol? x) 86 | x 87 | ] 88 | [(string? x) 89 | x 90 | ] 91 | [else 92 | (error 'type-rep "unsupport primitive " x) 93 | ] 94 | )) 95 | 96 | (define (type-pair? x) 97 | (cond 98 | [(integer? x) (= (logand x type-mask) pair-tag) ] 99 | [else #f] 100 | ) 101 | ) 102 | 103 | (define (type-fixnum? x) 104 | (cond 105 | [(integer? x) (= (logand x type-mask) fixnum-tag)] 106 | [else #f] 107 | ) 108 | ) 109 | 110 | (define (type-string? x) 111 | (cond 112 | [(integer? x) (= (logand x type-mask) string-tag)] 113 | [else #f] 114 | ) 115 | ) 116 | 117 | (define (type-vector? x) 118 | (cond 119 | [(integer? x) (= (logand x type-mask) vector-tag) ] 120 | [else #f] 121 | ) 122 | ) 123 | 124 | (define (type-box? x) 125 | (cond 126 | [(integer? x) (= (logand x type-mask) box-tag) ] 127 | [else #f] 128 | ) 129 | ) 130 | 131 | (define (type-const? x) 132 | (cond 133 | [(integer? x) (or (type-boolean? x) (type-null? x) (type-void? x)) ] 134 | [else #f] 135 | ) 136 | ) 137 | 138 | (define (type-boolean? x) 139 | (cond 140 | [(symbol? x) 141 | (or (equal? x 'true-rep) (equal? x 'false-rep))] 142 | [(integer? x) (= (logand x boolean-mask) boolean-tag) ] 143 | [else #f] 144 | ) 145 | ) 146 | 147 | (define (type-null? x) 148 | (cond 149 | [(symbol? x) (equal? x 'null-rep)] 150 | [(integer? x) (= x null-rep) ] 151 | [else #f] 152 | ) 153 | ) 154 | 155 | (define (type-void? x) 156 | (cond 157 | [(symbol? x) (equal? x 'void-rep)] 158 | [(integer? x) (= x void-rep) ] 159 | [else #f] 160 | ) 161 | ) 162 | 163 | (define (type-symbol? x) 164 | (cond 165 | [(symbol? x) (not (or (type-void? x) 166 | (type-boolean? x) 167 | (type-fixnum? x) 168 | (type-null? x) )) 169 | ] 170 | [else #f] 171 | ) 172 | ) 173 | 174 | (define (type-value x) 175 | (cond 176 | [(type-boolean? x) x] 177 | [(type-void? x) void-rep] 178 | [(type-null? x) null-rep] 179 | [(type-const? x) x] 180 | [(type-fixnum? x) (bitwise-arithmetic-shift-right x type-shift) ] 181 | [(type-pair? x) (bitwise-arithmetic-shift-right x type-shift) ] 182 | [(type-vector? x) (bitwise-arithmetic-shift-right x type-shift)] 183 | [(type-string? x) (bitwise-arithmetic-shift-right x type-shift)] 184 | [(type-box? x) (bitwise-arithmetic-shift-right x type-shift)] 185 | [(type-symbol? x) x] 186 | [else (error 'type-value "unsupport primitive" x)] 187 | ) 188 | ) 189 | 190 | (define (type? x) 191 | (cond 192 | [(pair? x) #f] 193 | [(type-void? x) #t] 194 | [(type-null? x) #t] 195 | [(type-boolean? x) #t] 196 | [(type-const? x) #t] 197 | [(type-fixnum? x) #t] 198 | [(type-symbol? x) #t] 199 | [else #f] 200 | ) 201 | ) 202 | 203 | ) -------------------------------------------------------------------------------- /common/common.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (common common) 7 | (export 8 | string-replace 9 | type-case 10 | id 11 | void? 12 | try 13 | symbol->asm-id 14 | gen-sym 15 | symbol-append 16 | get-sym 17 | clear-sym 18 | asm-data-add 19 | asm-data-get 20 | asm-data-clear 21 | get-asm-data-define 22 | mapc 23 | ) 24 | 25 | (import 26 | (scheme) 27 | (rename (scheme) (div div2) ) 28 | ) 29 | 30 | (define mapc for-each) 31 | 32 | (define asm-data-define (make-hashtable equal-hash equal?)) 33 | 34 | (define (asm-data-add key val) 35 | (hashtable-set! asm-data-define (symbol->asm-id key) val) 36 | ) 37 | 38 | (define (asm-data-get key val) 39 | (hashtable-ref asm-data-define key val) 40 | ) 41 | 42 | (define (asm-data-clear) 43 | (set! asm-data-define (make-hashtable equal-hash equal?)) 44 | ) 45 | 46 | (define (get-asm-data-define) 47 | asm-data-define 48 | ) 49 | 50 | (define symbols (make-hashtable equal-hash equal?)) 51 | 52 | (define (get-sym) 53 | symbols 54 | ) 55 | (define (clear-sym) 56 | (set! symbols (make-hashtable equal-hash equal?)) 57 | ) 58 | 59 | (define (gen-sym prefix) 60 | (if (null? prefix ) 61 | '() 62 | (let ((val (hashtable-ref symbols prefix 0))) 63 | (hashtable-set! symbols prefix (+ val 1)) 64 | (string->symbol (string-append (symbol->string prefix) "." (number->string val))) 65 | ))) 66 | 67 | (define (symbol-append s1 s2) 68 | (string->symbol (string-append (symbol->string s1) "." (symbol->string s2))) 69 | ) 70 | 71 | (define (symbol->asm-id s) 72 | (if (symbol? s) 73 | (set! s (symbol->string s ))) 74 | (let ((str s)) 75 | (set! str (string-replace "-" "." str)) 76 | (set! str (string-replace "%" "percent" str)) 77 | (set! str (string-replace " " ".space" str)) 78 | (set! str (string-replace #\- #\. str)) 79 | (set! str (string-replace #\space ".space" str)) 80 | (set! str (string-replace #\+ ".add" str)) 81 | (set! str (string-replace #\- ".minus" str)) 82 | (set! str (string-replace #\* ".multi" str)) 83 | (set! str (string-replace #\/ ".div" str)) 84 | (set! str (string-replace #\= ".eq" str)) 85 | (set! str (string-replace #\= ".eq" str)) 86 | (set! str (string-replace #\% ".percent" str)) 87 | (set! str (string-replace #\% ".percent" str)) 88 | (set! str (string-replace #\( ".left_quote" str)) 89 | (set! str (string-replace #\) ".right_quote" str)) 90 | (set! str (string-replace #\[ ".sl_brackets" str)) 91 | (set! str (string-replace #\] ".sr_brackets" str)) 92 | (set! str (string-replace #\> ".larger" str)) 93 | (set! str (string-replace #\\ #\_ str)) 94 | (set! str (string-replace #\, ".comma" str)) 95 | (set! str (string-replace #\# ".b" str)) 96 | (set! str (string-replace #\! ".ex" str)) 97 | (set! str (string-replace #\newline ".newline" str)) 98 | ;(printf ";symbol->asm-id:~a==>~a\n" s str) 99 | ; (let ((r (symbol->asm-id str))) 100 | ; (if (not (string=? str r)) 101 | ; (set! str r))) 102 | str 103 | ; (format "str.~a" (string-hash str)) 104 | ) 105 | ) 106 | 107 | (define (string-replace old new str) 108 | (let ((ss str)) 109 | (cond 110 | [(symbol? str) 111 | (set! ss (symbol->string str) ) 112 | (let ((s (string-copy ss))) 113 | (string->symbol (string-replace-one old new s)) 114 | ) 115 | ] 116 | [(string? str) 117 | (let ((s (string-copy ss))) 118 | (string-replace-one old new s) 119 | ) 120 | ] 121 | [else (error 'string-replace "unsupport type" str) ] 122 | ) 123 | ) 124 | ) 125 | 126 | (define (string-index-of p ch) 127 | (let loop ((len (string-length p)) 128 | (i 0)) 129 | (if (< i len) 130 | (begin 131 | ;;(printf " i=~a=~a ~a\n" i (string-ref p i) ch ) 132 | (if (char=? (string-ref p i) ch) 133 | i 134 | (loop len (+ i 1)) 135 | )) 136 | -1 137 | )) 138 | ) 139 | 140 | (define (string-replace-one old new str) 141 | (if (char? old) 142 | (set! old (string old)) 143 | ) 144 | (if (char? new) 145 | (set! new (string new)) 146 | ) 147 | (let ((len (string-length str)) 148 | (len-old (string-length old)) 149 | (len-new (string-length new)) 150 | ) 151 | (cond 152 | [(= len 1) new] 153 | [(= len-old 1) 154 | (let ((pos (string-index-of str (string-ref old 0)))) 155 | ;;(printf "pos=>~a\n" pos) 156 | (if (>= pos 0) 157 | (let ((r (string-append (substring str 0 pos ) new (substring str (+ pos len-old) len )) )) 158 | ; (printf ";1=pos=~a old=~a ~a === ~a\n" pos old str r) 159 | r) 160 | str 161 | ) 162 | ) 163 | ] 164 | [else 165 | (let ((pos (bmh str old))) 166 | ; (printf ";pos=>>~a\n" pos) 167 | (if (>= pos 0) 168 | (let ((r (string-append (substring str 0 pos) new (substring str (+ pos len-old) len )) )) 169 | ; (printf ";;replace ~a === ~a\n" str r) 170 | r 171 | ) 172 | str 173 | )) 174 | ] 175 | ) 176 | )) 177 | 178 | (define (compute-last-occ p) 179 | (let ((last-occ (make-vector 128 -1))) 180 | (let loop ((len (- (string-length p) 1)) 181 | (i 0)) 182 | (if (< i len) 183 | (begin 184 | (vector-set! last-occ (char->integer (string-ref p i)) i) 185 | (loop len (+ i 1)) 186 | ))) 187 | last-occ 188 | )) 189 | 190 | (define (bmh t p) 191 | (let ((last-occ (compute-last-occ p)) 192 | (i0 0) 193 | (n (string-length t)) 194 | (m (string-length p)) 195 | (j -1) 196 | (ret -1) 197 | (is-not-ret #t) ) 198 | (let loop () 199 | (if (< i0 (- n m)) 200 | (begin 201 | (set! j (- m 1)) 202 | (let loop2 () 203 | (if (char=? (string-ref p j) (string-ref t (+ i0 j)) ) 204 | (begin 205 | (set! j (- j 1)) 206 | (if (< j 0) 207 | (begin 208 | (set! is-not-ret #f) 209 | (set! ret i0) ) 210 | (loop2) 211 | )))) 212 | (if is-not-ret 213 | (begin 214 | (set! i0 (+ i0 215 | (- m 1) 216 | (- (vector-ref last-occ 217 | (char->integer (string-ref t (+ i0 m -1))) ) ) )) 218 | (loop))) 219 | ))) 220 | ret)) 221 | 222 | (define (id x) x) 223 | 224 | (define (void? x) 225 | (equal? x (void)) 226 | ) 227 | 228 | (define-syntax type-case 229 | (syntax-rules (else) 230 | [(_ expr 231 | [(pred1 pred2 ...) e1 e2 ...] ... 232 | [else ee1 ee2 ...]) 233 | (let ([t expr]) 234 | (cond 235 | [(or (pred1 t) (pred2 t) ...) e1 e2 ...] 236 | ... 237 | [else ee1 ee2 ...]))])) 238 | 239 | 240 | (define-syntax try 241 | (syntax-rules (catch) 242 | ((_ body (catch catcher)) 243 | (call-with-current-continuation 244 | (lambda (exit) 245 | (with-exception-handler 246 | (lambda (condition) 247 | (catcher condition) 248 | (exit condition)) 249 | (lambda () body))))))) 250 | 251 | ) -------------------------------------------------------------------------------- /common/test.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (common test) 8 | (export test add-test-case add-test 9 | test-all 10 | add-test-string 11 | add-test-print 12 | ) 13 | 14 | (import (scheme) (duck duck) (common logger) (common common) (common trace) (duck options) 15 | ) 16 | 17 | 18 | (define all-tests (list)) 19 | 20 | 21 | 22 | (define shell 23 | (lambda (s . args) 24 | (system (apply format s args)))) 25 | 26 | (define (run-shell cmd) 27 | (let-values ([(to-stdin from-stdout from-stderr pid) 28 | (open-process-ports 29 | cmd 30 | (buffer-mode block) 31 | (native-transcoder))]) 32 | (close-output-port to-stdin) 33 | (let ([out (get-string-all from-stdout)] 34 | [err (get-string-all from-stderr)]) 35 | (close-input-port from-stdout) 36 | (close-input-port from-stderr) 37 | (unless (eof-object? err) (error 'test err)) 38 | (if (eof-object? out) (set! out "")) 39 | out) 40 | )) 41 | 42 | (define (get-arch-cmd test-name) 43 | (case (option-get 'arch 'x86) 44 | ['x86 45 | (format "./~a" test-name)] 46 | ['wasm 47 | (format "wasm-interp ./~a.wasm" test-name)] 48 | ['llvm 49 | (format "./~a" test-name)] 50 | ['llvm-bc 51 | (format "./~a.bc" test-name)] 52 | [else 53 | (format "./~a" test-name)] 54 | ) 55 | ) 56 | 57 | (define (get-arch-obj-name) 58 | (case (option-get 'arch 'x86) 59 | ['x86 60 | ".s"] 61 | ['wasm 62 | ".wasm"] 63 | ['llvm 64 | ".ll"] 65 | [else 66 | ".s"] 67 | ) 68 | ) 69 | 70 | (define (test case) 71 | ;;(pretty-one-line-limit 1) 72 | (option-set 'obj.name (get-arch-obj-name)) 73 | (let ((name (car case)) 74 | (exps (cadr case)) 75 | (cmp (if (procedure? (caddr case)) (caddr case) equal? )) 76 | (total 0) 77 | (passed 0) 78 | (failed 0) 79 | (compile-wrong 0) 80 | ) 81 | (set! exps (map (lambda (d) 82 | (if (pair? d) 83 | d 84 | (list d d)) ) exps)) 85 | (printf "test ~a\n" name) 86 | (let loop ((exp exps) (i 0)) 87 | (if (pair? exp) 88 | (let* ((e (car exp)) 89 | (ret '()) 90 | (out '()) 91 | (result (cdr e)) 92 | (test-name (format "~a.~a" (string-replace #\space #\. (string-replace #\space #\. name)) i)) 93 | ) 94 | (set! total (+ total 1)) 95 | ;;(printf " exp=~a\n" (cadar e) ) ;;(cadadr e ) 96 | (if (pair? e) 97 | (set! result (cadr e)) 98 | ) 99 | (set! ret (duck-compile-exp (car e) test-name) ) 100 | (printf "[test~a]:" i ) 101 | (pretty-print (car e ) ) 102 | ;;(pretty-print ret ) 103 | (if (= ret 0) 104 | (begin 105 | ; (printf "cmd=>~a\n" (get-arch-cmd test-name)) 106 | (set! out (run-shell (get-arch-cmd test-name))) 107 | (if (cmp out result) 108 | (begin 109 | (set! passed (+ passed 1)) 110 | (printf " ==>passed ~a=~a\n" out result) 111 | ) 112 | (begin 113 | (set! failed (+ failed 1)) 114 | (printf " ==>failed ~a=~a\n" out result))) 115 | ) 116 | (begin 117 | (set! compile-wrong (+ compile-wrong 1)) 118 | (printf " ==>compile erro ~a ./~a.s\n" ret test-name) 119 | (error 'compile test-name (car e ) ) 120 | ) 121 | 122 | ) 123 | 124 | (loop (cdr exp) (+ i 1)) 125 | ) 126 | ) 127 | ) 128 | (printf "\n") 129 | (list total passed failed compile-wrong) 130 | )) 131 | 132 | (define (test-all) 133 | (pretty-format 'set '(_ x y)) 134 | (pretty-format 'local '(_ x)) 135 | (pretty-format 'print-value '(_ x)) 136 | (pretty-format 'null? '(_ x)) 137 | (pretty-format 'block '(_ name 0 ... )) 138 | (pretty-format 'program '(_ name args 0 vars ... )) 139 | (pretty-one-line-limit 100) 140 | (let ((total 0) 141 | (passed 0) 142 | (failed 0) 143 | (compile-wrong 0) 144 | (test-result (map test all-tests) ) 145 | ) 146 | (let loop ([result test-result]) 147 | (if (pair? result) 148 | (let ((ret (car result))) 149 | (set! total (+ total (list-ref ret 0))) 150 | (set! passed (+ passed (list-ref ret 1))) 151 | (set! failed (+ failed (list-ref ret 2))) 152 | (set! compile-wrong (+ compile-wrong (list-ref ret 3))) 153 | (loop (cdr result) )))) 154 | (printf "test-all total:~a passed:~a failed:~a compile erro:~a\n" total passed failed compile-wrong) 155 | )) 156 | 157 | (define (add-test-case name exps cmp) 158 | (set! all-tests 159 | (append! all-tests (list (list name exps cmp) ))) ) 160 | 161 | (define-syntax add-test 162 | (lambda (x) 163 | (syntax-case x () 164 | [(_ name sexps ... ) 165 | ;;#'(printf "====>~a\n" (list ''sexps ...) ) 166 | #'(add-test-case name '( sexps ...) '()) 167 | ] 168 | ))) 169 | 170 | (define (conver-to-string a) 171 | (type-case a 172 | [(symbol?) (symbol->string a)] 173 | [(number?) (number->string a)] 174 | [(string?) a] 175 | [(boolean?) (if a "#t" "#f")] 176 | [(null?) "()"] 177 | [(void?) "(void)"] 178 | [else 179 | (with-output-to-string 180 | (lambda () (printf "~a" a ))) 181 | ]) 182 | ) 183 | 184 | (define (string-cmp a b) 185 | (set! a (conver-to-string a)) 186 | (set! b (conver-to-string b)) 187 | (string-ci=? a b) 188 | ) 189 | 190 | 191 | 192 | (define-syntax add-test-print 193 | (lambda (x) 194 | (define (pp exp) 195 | (let ((d (syntax->datum exp))) 196 | ; (printf "pp=>~a ~a\n" d (pair? d)) 197 | (if (not (pair? d)) 198 | (set! d (list d d)) 199 | ) 200 | (printf "d==>~a=~a\n" d (car d) ) 201 | ; (set! d (datum->syntax #'k d)) 202 | ; #`((printf "%s" #,(car d)) #,(cadr d) ) 203 | ; #`( (printf "%s" '#,(car '#,@exp) ) 10) 204 | ; (datum->syntax #'k d) ;; #,@exp 205 | ; (datum->syntax #'k d) 206 | (if (or (equal? (car d) 'quote ) (equal? (car d) 'void ) ) 207 | (with-syntax ((e (datum->syntax #'k d )) 208 | (e2 (datum->syntax #'k d))) 209 | (syntax 210 | ((print-value e) e2) 211 | )) 212 | (with-syntax ((e (datum->syntax #'k (car d) )) 213 | (e2 (datum->syntax #'k (cadr d) )) ) 214 | (syntax 215 | ((print-value e) e2) 216 | )) 217 | ) 218 | 219 | )) 220 | 221 | (syntax-case x () 222 | [(_ name sexps ... ) 223 | #`(add-test-case name '#,(map pp #'(sexps ...) ) string-cmp ) 224 | ] 225 | ))) 226 | 227 | (define-syntax add-test-string 228 | (lambda (x) 229 | (syntax-case x () 230 | [(_ name sexps ... ) 231 | ;;#'(printf "====>~a\n" (list ''sexps ...) ) 232 | #'(add-test-case name '( sexps ...) string-cmp ) 233 | ] 234 | ))) 235 | 236 | ) -------------------------------------------------------------------------------- /arch/wasm.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (arch wasm) 7 | (export 8 | reg0 reg1 reg2 reg3 reg4 reg5 reg6 reg7 regs regs-map 9 | asm set mref mset note 10 | add label sar sal mul sub div 11 | shl shr ret 12 | call jmp cmp-jmp cmp 13 | land xor save restore 14 | nop local proc 15 | 16 | fcall ccall 17 | stext sexit 18 | asm-compile-exp 19 | data sdata 20 | arch-bits 21 | ) 22 | 23 | (import 24 | (rename (scheme) (div div2) ) 25 | (common) 26 | ) 27 | 28 | ;;reg 29 | (define reg0 'eax) ;for object ptr 30 | (define reg1 'ebx) ; 31 | (define reg2 'ecx) 32 | (define reg3 'edx) 33 | (define reg4 'esi) ;for alloc base 34 | (define reg5 'edi) 35 | (define reg6 'ebp) 36 | (define reg7 'esp) 37 | 38 | (define r0 'ax) 39 | (define r0l 'al) 40 | (define r0h 'ah) 41 | 42 | (define r1l 'bl) 43 | (define r1h 'bh) 44 | 45 | (define regs (list reg0 reg1 reg2 reg3 reg4 reg5 reg6 reg7 r0 r0l r0h r1l r1h)) 46 | (define regs-map (list 'reg0 reg0 'reg1 reg1 'reg2 reg2 'reg3 reg3 'reg4 reg4 'reg5 reg5 'reg6 reg6 'reg7 reg7 'r0 r0 'r0l r0l 'r0h r0h )) 47 | 48 | 49 | (define arch-bits 32) 50 | 51 | (define all-data (make-hashtable equal-hash equal?)) 52 | (define data-offset 0) 53 | 54 | (define (get-data var ) 55 | (let ((ret (hashtable-ref all-data var '()))) 56 | (if (null? ret) 57 | (begin (set-data var) 58 | (- data-offset 1)) 59 | ret 60 | )) 61 | ) 62 | 63 | (define (set-data var) 64 | (hashtable-set! all-data var data-offset) 65 | (set! data-offset (+ data-offset 1)) 66 | ) 67 | 68 | 69 | (define (asm-compile-exp exp name) 70 | (let ((asm 71 | (case (machine-type) 72 | ((arm32le) "") 73 | ((a6nt i3nt ta6nt ti3nt) (format "" name name name)) 74 | ((a6osx i3osx ta6osx ti3osx) (format "wat2wasm ~a.s -o ~a.wasm" name name)) 75 | ((a6le i3le ta6le ti3le) (format "" name name name)))) 76 | ) 77 | (printf "~a\n" asm) 78 | (system asm) 79 | ) 80 | ) 81 | 82 | (define (stext arg) 83 | (if (equal? arg 'start) 84 | (begin 85 | (asm "(module") 86 | (asm "(table 0 anyfunc)") 87 | (asm "(memory $0 1)") 88 | (map (lambda (x) 89 | (asm "(global $~a (mut i32) (i32.const 0))" x) ) regs) 90 | ;;(asm "(import \"env\" \"consoleLog\" (func $consoleLog (param i32)))") 91 | (asm "(func $start (param i32) (param i32) (result i32)") 92 | ) 93 | (begin 94 | (sexit 0) 95 | (asm "(return ~a) )" (operands-rep reg0) ) 96 | ) 97 | ) 98 | ) 99 | 100 | (define (sexit code) 101 | (note "call exit 0") 102 | 103 | ) 104 | 105 | (define (sdata arg) 106 | (if (equal? 'start arg) 107 | (begin 108 | (note "section .data") 109 | (gen-define) 110 | ) 111 | (asm ")") 112 | ) 113 | ) 114 | 115 | (define (gen-define) 116 | ;;(asm "section .data") 117 | (let-values ([(keyvec valvec) (hashtable-entries (get-asm-data-define))]) 118 | (vector-for-each 119 | (lambda (key val) 120 | (data key val)) 121 | keyvec valvec)) 122 | ) 123 | 124 | 125 | ;;asm code here 126 | (define (operands-rep x) 127 | (cond 128 | [(integer? x) 129 | (format "(i32.const ~a)" (get-data x)) ] 130 | [(memq x regs) 131 | (format "(global.get $~a)" x) 132 | ] 133 | [(memq x regs-map) 134 | ; (printf "(memq x regs)=>~a ===========> ~a\n" (memq x regs-map) (cadr (memq x regs-map))) 135 | (format "(global.get $~a)" (cadr (memq x regs-map))) 136 | ] 137 | [(string? x) 138 | (format "(i32.const ~a)" (get-data x)) 139 | ] 140 | [(symbol? x) 141 | (format "(i32.const ~a)" (get-data x)) 142 | ] 143 | ; [(list? x) 144 | ; (let loop ((e x) (s "[")) 145 | ; (if (pair? e) 146 | ; (begin 147 | ; (loop (cdr e) (string-append s (format "~a + " (car e) ))) 148 | ; ) 149 | ; (string-append s "0]") 150 | ; ) 151 | ; ) 152 | ; ] 153 | [else 154 | (note "operands-rep else ~a" x) 155 | (format "~a" x ) ] 156 | ) 157 | ) 158 | 159 | (define (data var val) 160 | (note "data var=~a val=~a" var val) 161 | (let ((offset (get-data var))) 162 | (cond 163 | [(string? val) 164 | (asm "(data (i32.const ~a) \"~a\")" offset val)] 165 | [(number? val) 166 | (asm "(data (i32.const ~a) \"\\~x\" )" offset val)] 167 | [else 168 | (asm "(data (i32.const ~a) \"~a\")" offset val)] 169 | )) 170 | 171 | ;(asm "(data (;0;) (i32.const 1024) \"~a\" )" val) 172 | ) 173 | 174 | (define (local index) 175 | (format "(local.get ~a)" index) 176 | ) 177 | 178 | (define (fcall l . args) 179 | (note "fcall") 180 | ) 181 | 182 | (define (ccall l . args) 183 | (note "ccall") 184 | ) 185 | 186 | (define (gen-args args) 187 | (let loop [(i args) (ret "")] 188 | (if (pair? i) 189 | (begin 190 | (loop (cdr i) (string-append ret (format "~a " (operands-rep (car i))) )) 191 | ) 192 | ret 193 | ) 194 | ) 195 | ) 196 | 197 | (define (call l . args) 198 | (asm "(call $~a ~a )" (symbol->asm-id l ) (gen-args args) ) 199 | ) 200 | 201 | (define (jmp l) 202 | (note "jmp") 203 | (asm "br $~a" (symbol->asm-id l)) 204 | 205 | ) 206 | 207 | (define (cmp-jmp val1 val2 l1 l2) 208 | (note "cmp-jmp") 209 | ; ;;param eax 210 | ; (asm "cmp ~a,~a" (operands-rep val1) (operands-rep val2)) 211 | ; (if (not (null? l1) ) 212 | ; (asm "je ~a" (symbol->asm-id l1) )) ;; goto equal 213 | ; ; (printf "===========>~a\n" (symbol? l2)) 214 | ; (if (not (null? l2) ) 215 | ; (asm "jne ~a" (symbol->asm-id l2) )) ;; goto not equal 216 | ) 217 | 218 | 219 | (define (cmp type a b) 220 | (note "cmp") 221 | ) 222 | 223 | ;; set symbol? [a], string a ,reg 224 | ;; set reg,reg mem,reg reg,mem 225 | (define set 226 | (case-lambda 227 | [(a b) 228 | (unless (equal? a b) 229 | (begin 230 | (note "set ~a ~a (list? a)=~a number b?=~a" a b (list? a) (number? b)) 231 | (asm "(i32.store ~a ~a)" (operands-rep a) (operands-rep b)) 232 | )) 233 | ] 234 | [(a b c) 235 | (note "set") 236 | ])) 237 | 238 | ;;ref reg,[reg] reg,[mem] 239 | (define mref 240 | (case-lambda 241 | [(a b) 242 | 243 | (note "mref a b")] 244 | [(a b c) 245 | (note "mref a b c")])) 246 | 247 | ;;set [reg],reg [mem],reg 248 | (define mset 249 | (case-lambda 250 | [(a b) 251 | 252 | (note "mset a b")] 253 | [(a b c) 254 | (note "mset a b c")])) 255 | 256 | 257 | 258 | (define (sub a b) 259 | (asm "(global.set $~a (i32.sub ~a ~a))" reg0 (operands-rep a) (operands-rep b) ) 260 | ) 261 | 262 | (define (add a b) 263 | (asm "(global.set $~a (i32.add ~a ~a))" reg0 (operands-rep a) (operands-rep b) ) 264 | ) 265 | 266 | (define (mul a b) 267 | (asm "(global.set $~a (i32.mul ~a ~a))" reg0 (operands-rep a) (operands-rep b) ) 268 | ) 269 | 270 | (define (div a b) 271 | (asm "(global.set $~a (i32.div ~a ~a))" reg0 (operands-rep a) (operands-rep b) ) 272 | ) 273 | 274 | 275 | (define (gen-params args) 276 | (let loop [(i args) (ret "(param ")] 277 | (if (pair? i) 278 | (begin 279 | 280 | (loop (cdr i) (string-append ret "i32 ") ) 281 | ) 282 | (string-append ret ") ") 283 | ) 284 | ) 285 | ) 286 | 287 | (define (proc l args) 288 | (note "\n") 289 | (note "proc ~a ~a" l args) 290 | (asm "(func $~a ~a (result i32)" (symbol->asm-id l) (gen-params args) ) 291 | ;;(label l) 292 | 293 | ) 294 | 295 | (define (ret) 296 | (note "ret") 297 | (asm "(return ~a)" (operands-rep reg0)) 298 | (asm ")") 299 | ) 300 | 301 | (define (label l) 302 | (asm "(block $~a)" (symbol->asm-id l )) 303 | ) 304 | 305 | (define (sar a b) 306 | (asm "(global.set $~a (i32.shr_s ~a ~a))" reg0 (operands-rep a) (operands-rep b) ) 307 | ) 308 | 309 | (define (sal a b) 310 | (asm "(global.set $~a (i32.shl ~a ~a))" reg0 (operands-rep a) (operands-rep b) )) 311 | 312 | (define (shl a b) 313 | (asm "(global.set $~a (i32.shl ~a ~a))" reg0 (operands-rep a) (operands-rep b) )) 314 | 315 | (define (shr a b) 316 | (asm "(global.set $~a (i32.shr_u ~a ~a))" reg0 (operands-rep a) (operands-rep b) )) 317 | 318 | (define (land a b) 319 | (asm "(global.set $~a (i32.and ~a ~a))" reg0 (operands-rep a) (operands-rep b) )) 320 | 321 | (define (xor a b) 322 | (asm "(global.set $~a (i32.xor ~a ~a))" reg0 (operands-rep a) (operands-rep b) )) 323 | 324 | 325 | (define (save a) 326 | (note "push ~a" (operands-rep a))) 327 | 328 | (define (restore a) 329 | (note "pop ~a" (operands-rep a))) 330 | 331 | (define (nop) 332 | (asm "(nop)")) 333 | 334 | 335 | 336 | ) -------------------------------------------------------------------------------- /duck/primitive.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | 7 | (library (duck primitive) 8 | (export 9 | print-dot 10 | print-list 11 | print-value 12 | 13 | emit-print-const-value 14 | emit-print-type-value 15 | emit-print-value 16 | emit-printf 17 | emit-alloc 18 | emit-free 19 | emit-prim 20 | prim? 21 | binop? 22 | ) 23 | 24 | (import 25 | ;;(scheme) 26 | (rename (scheme) (div div2) ) 27 | (common match) 28 | (common trace) 29 | (common common) 30 | (arch arch) 31 | (duck type) 32 | ) 33 | 34 | 35 | (define (prim? prim) 36 | (memq prim '(printc void cons car cdr pair? null? alloc free) ) 37 | ) 38 | 39 | (define (binop? op) 40 | (memq op '(+ - * / ) ) 41 | ) 42 | 43 | ;;asm inst 44 | (define (emit-print-type-value tag str lend) 45 | (let ((l1 (gen-sym 'ltype)) 46 | (l2 (gen-sym 'ltype))) 47 | (set reg0 reg1) 48 | (land reg0 type-mask) 49 | (cmp-jmp reg0 tag l1 l2) 50 | (label l1) 51 | (set reg0 reg1) 52 | (sar reg0 type-shift) 53 | (emit-printf str reg0) 54 | (jmp lend) 55 | (label l2) 56 | ) 57 | ) 58 | 59 | (define (emit-print-const-value tag str lend) 60 | (let ((l1 (gen-sym 'lconst)) 61 | (l2 (gen-sym 'lconst)) 62 | (l3 (gen-sym 'lconst)) ) 63 | (set reg0 reg1) 64 | (land reg0 type-mask) 65 | (cmp-jmp reg0 const-tag l1 l2) 66 | (label l1) ;;is const 67 | (set reg0 reg1) 68 | (land reg0 const-mask) 69 | (sar reg0 type-shift) 70 | (cmp-jmp reg0 tag l3 l2) 71 | (label l3) ;; is tag 72 | (emit-printf str reg0) 73 | (jmp l2) 74 | (label l2) 75 | ) 76 | ) 77 | 78 | (define (emit-printc fmt . args) 79 | (note "printc ~a args=~a" fmt args) 80 | (apply ccall 'printf fmt args) 81 | ) 82 | 83 | (define (emit-printf fmt . args) 84 | (note "printf fmt=~a args=~a fmt string?=~a" fmt args (string? fmt)) 85 | ; (data (symbol->asm-id fmt) fmt) 86 | (let ((str (if (string? fmt) (string-append "fmt" fmt) fmt) )) 87 | (note "here") 88 | (asm-data-add str fmt) 89 | (save reg0) 90 | (apply fcall 'printf str args) 91 | (restore reg0) 92 | (note "printf end") 93 | ) 94 | ) 95 | 96 | (define (word-size n) 97 | (flonum->fixnum (* n (/ arch-bits 8.0))) 98 | ) 99 | 100 | (define (emit-cons args) 101 | (note "emit-cons ~a " args) 102 | (emit-alloc (word-size 2)) ;;car cdr 103 | (set reg4 reg0) ;;save reg0 104 | 105 | ; (emit-printf "emit-alloc=%x " reg0) 106 | ; (set reg0 reg4) 107 | 108 | (set reg5 (car args) "reg5=a" ) 109 | (mset reg0 reg5 "[reg0]=reg5=a set-car") 110 | (add reg0 (word-size 1)) 111 | (set reg5 (cadr args) "reg5=b") 112 | (mset reg0 reg5 "[reg0+1]=reg5=b set-cdr") ;;set cdr 113 | (set reg0 reg4 "reg0=malloc addr") 114 | (sal reg0 type-shift) 115 | (note "add reg0 pair-tag") 116 | (add reg0 pair-tag) 117 | 118 | (note "end emit-cons") 119 | ) 120 | 121 | (define (emit-print-value . args) 122 | (note "emit-print-value ~a " args) 123 | (apply call "print-value" args) 124 | ) 125 | 126 | 127 | (define (emit-alloc val) 128 | (note "emit-alloc ~a" val) 129 | (cond 130 | [(string? val) 131 | (note "emit-alloc string ~a" val) 132 | ; (foreign-call 'malloc (string-length val)) 133 | ; (set reg2 (string-length val) ";;count") 134 | ; (set reg4 ";;si") 135 | ; (set reg5 ";;di") 136 | ; (call 'copy-string) 137 | (let ((str (string-append "str." (symbol->asm-id val) ) )) 138 | (asm-data-add str val) 139 | (set reg0 str) 140 | (sal reg0 type-shift) 141 | (add reg0 string-tag) 142 | ) 143 | ] 144 | [(symbol? val) 145 | (note "emit-alloc symbol ~a" val) 146 | (let ((str (string-append "sym." (symbol->asm-id (symbol->string val) ) ))) 147 | (asm-data-add str val) 148 | (set reg0 str) 149 | (sal reg0 type-shift) 150 | (add reg0 symbol-tag) 151 | ) 152 | ] 153 | [(number? val) 154 | (note "emit-alloc size ~a" val) 155 | ;(set reg0 0) 156 | (fcall 'malloc val) 157 | (set reg1 reg0) 158 | 159 | ; (emit-printf "malloc=%x" reg0) 160 | ; (set reg0 reg1) 161 | 162 | (note "end emit-alloc size ~a" val) 163 | ] 164 | ; [(pair? val) 165 | ; val 166 | ; ] 167 | [else (error 'emit-alloc "not support" val) ] 168 | ) 169 | ) 170 | 171 | 172 | (define (emit-free a) 173 | (note "free ~a" a) 174 | (fcall 'free a) 175 | ) 176 | 177 | 178 | ;;prim 179 | (define (emit-prim app args) 180 | (case app 181 | ['printc 182 | (apply emit-printc args) 183 | ] 184 | ['void "" ] 185 | ['cons (emit-cons args)] 186 | ['car 187 | (note "car ~a" args) 188 | (set reg2 (car args)) 189 | (sar reg2 type-shift) 190 | (mref reg0 reg2 "car pair") 191 | ; (emit-print-value (list reg0)) 192 | ] 193 | ['cdr 194 | (note "cdr ~a" args) 195 | (set reg2 (car args)) 196 | (sar reg2 type-shift) 197 | (note "add reg2 word-size 1") 198 | (add reg2 (word-size 1)) 199 | (mref reg0 reg2 "cdr pair") 200 | ] 201 | ['pair? 202 | (let ((l1 (gen-sym 'pair)) 203 | (l2 (gen-sym 'pair)) 204 | (l3 (gen-sym 'pair)) 205 | ) 206 | (set reg2 (car args)) 207 | (land reg2 type-mask) 208 | (cmp-jmp reg2 pair-tag l1 l2) 209 | (label l1) 210 | (set reg0 true-rep) 211 | (jmp l3) 212 | (label l2) 213 | (set reg0 false-rep) 214 | (label l3) 215 | ) 216 | ] 217 | ['null? 218 | (let ((l1 (gen-sym 'null)) 219 | (l2 (gen-sym 'null)) 220 | (l3 (gen-sym 'null)) 221 | ) 222 | (set reg2 (car args)) 223 | (cmp-jmp reg2 null-rep l1 l2) 224 | (label l1) 225 | (set reg0 true-rep) 226 | (jmp l3) 227 | (label l2) 228 | (set reg0 false-rep) 229 | (label l3) 230 | ) 231 | ] 232 | ['alloc 233 | (apply emit-alloc args) 234 | ] 235 | ['free 236 | (apply emit-free args) 237 | ] 238 | ) 239 | ) 240 | 241 | (define-syntax define-primitive 242 | (syntax-rules () 243 | [(_ (prim-name arg* ...) body body* ...) 244 | (define prim-name 245 | (lambda () 246 | `(block (label prim-name arg* ... ) body body* ... ) ;;(local arg* ... ) 247 | ) 248 | ) 249 | ])) 250 | 251 | (define-primitive (print-dot arg0) 252 | (set reg0 (local 0)) 253 | ;;(set reg0 reg1) 254 | (sar reg0 ,type-shift) 255 | (set reg2 reg0) 256 | (save reg0) 257 | (save reg1) 258 | (save reg2) 259 | 260 | (mref reg0 reg2 "car pair") 261 | (emit-print-value reg0) 262 | 263 | (restore reg2) 264 | (restore reg1) 265 | (restore reg0) 266 | 267 | (set reg0 reg1) 268 | (sar reg0 ,type-shift) 269 | (set reg2 reg0) 270 | (add reg2 ,(word-size 1) ) 271 | (mref reg0 reg2 "cdr pair") 272 | 273 | (note "is null?") 274 | (cmp-jmp reg0 null-rep print-dot-l4 print-dot-l3) 275 | (label print-dot-l3) 276 | 277 | (save reg0) 278 | (save reg1) 279 | (save reg2) 280 | (emit-print-value reg0) 281 | (restore reg2) 282 | (restore reg1) 283 | (restore reg0) 284 | (label print-dot-l4) 285 | (lret) 286 | ) 287 | 288 | (define-primitive (print-list arg0) 289 | (save reg0) 290 | (save reg1) 291 | (save reg2) 292 | ;;save arg0 to reg1 293 | (set reg1 (local 0)) 294 | (set reg0 reg1) 295 | 296 | (jmp print-list-l1) 297 | (label print-list-l1) 298 | 299 | (note "is pair?") 300 | (land reg0 ,type-mask) 301 | (cmp-jmp reg0 ,pair-tag print-list-l2 print-list-lend) 302 | 303 | ;;reg0 is pair 304 | (label print-list-l2) 305 | ;;reg0=car(pair) 306 | (set reg0 reg1) 307 | (sar reg0 ,type-shift) 308 | (set reg2 reg0) 309 | (mref reg0 reg2 "reg0=car pair") 310 | ;;print car value 311 | (emit-print-value reg0) 312 | 313 | ;;reg1=cdr(pair) 314 | (set reg0 reg1) 315 | (sar reg0 ,type-shift) 316 | (add reg0 ,(word-size 1)) 317 | (mref reg1 reg0 "reg1=cdr pair") 318 | 319 | ;;reg1=cdr(pair) 320 | ;;is cdr ==0 321 | (set reg0 reg1) 322 | (note "is end break") 323 | (cmp-jmp reg0 0 print-list-lend print-list-l3) 324 | (label print-list-l3) 325 | (note "check reg1=cdr(pair) is null") 326 | (cmp-jmp reg0 null-rep print-list-lend ()) 327 | (note "check reg1=cdr(pair) is pair") 328 | (land reg0 ,type-mask) 329 | (cmp-jmp reg0 ,pair-tag print-list-l4 print-list-l6) 330 | ;;reg0 =cdr(pair) is pair 331 | (label print-list-l4) 332 | (emit-printf " ") 333 | (jmp print-list-l8) 334 | ;; is dot 335 | (label print-list-l6) 336 | (emit-printf " . ") 337 | (emit-print-value reg1) 338 | 339 | (jmp print-list-l8) 340 | (label print-list-l8) 341 | ;;loop next 342 | (set reg0 reg1) 343 | (jmp print-list-l1) 344 | 345 | (label print-list-lend) 346 | (restore reg2) 347 | (restore reg1) 348 | (restore reg0) 349 | 350 | (lret) 351 | ) 352 | 353 | (define-primitive (print-value arg0) 354 | ;;param reg0 355 | ;;save param0 356 | (save reg0) 357 | (save reg1) 358 | (save reg2) 359 | (set reg1 (local 0)) 360 | ;;print pair 361 | (note "print pair") 362 | ; (let ((l1 (gen-sym 'lpair)) 363 | ; (l2 (gen-sym 'lpair)) 364 | ; (l3 (gen-sym 'lpair)) 365 | ; (l4 (gen-sym 'lpair))) 366 | (set reg0 reg1) 367 | 368 | (land reg0 ,type-mask) 369 | (cmp-jmp reg0 ,pair-tag print-value-l1 print-value-l2) 370 | (label print-value-l1) 371 | (note "print pair") 372 | (set reg0 reg1) 373 | (sar reg0 ,type-shift) 374 | 375 | (emit-printf "(") 376 | 377 | ;;(call "print-dot" (arg reg0)) 378 | ;;reg1 is origin value 379 | (call "print-list" reg1) 380 | 381 | (emit-printf ")") 382 | (jmp print-value-lend) 383 | (label print-value-l2) 384 | ; ) 385 | 386 | 387 | ;; print int 388 | (note "print int") 389 | (emit-print-type-value ,fixnum-tag "%d" print-value-lend) 390 | 391 | ;;print symbol 392 | (note "print symbol") 393 | (emit-print-type-value ,symbol-tag "%s" print-value-lend) 394 | 395 | ;;print string 396 | (note "print string") 397 | (emit-print-type-value ,string-tag "%s" print-value-lend) 398 | 399 | ;;print boolean 400 | (note "print boolean") 401 | (emit-print-const-value ,true-tag "#t" print-value-lend) 402 | (emit-print-const-value ,false-tag "#f" print-value-lend) 403 | 404 | ;;print void 405 | (note "print void") 406 | (emit-print-const-value ,void-tag "(void)" print-value-lend) 407 | ;;print null 408 | (note "print null") 409 | (emit-print-const-value ,null-tag "()" print-value-lend) 410 | 411 | (jmp print-value-lend) 412 | (label print-value-lend) 413 | 414 | (restore reg2) 415 | (restore reg1) 416 | (restore reg0) 417 | (lret) 418 | ) 419 | 420 | 421 | ) -------------------------------------------------------------------------------- /arch/llvm.ss: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;Copyright 2016-2080 evilbinary. 3 | ;作者:evilbinary on 12/24/16. 4 | ;邮箱:rootdebug@163.com 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | (library (arch llvm) 7 | (export 8 | reg0 reg1 reg2 reg3 reg4 reg5 reg6 reg7 regs regs-map 9 | asm set mref mset note 10 | add label sar sal mul sub div 11 | shl shr ret 12 | call jmp cmp-jmp cmp 13 | land xor save restore 14 | nop local proc lproc pret lret 15 | 16 | fcall ccall 17 | stext sexit 18 | asm-compile-exp 19 | data sdata 20 | arch-bits 21 | ) 22 | 23 | (import 24 | (rename (scheme) (div div2) ) 25 | (duck options) 26 | (common common) 27 | ) 28 | 29 | ;;reg 30 | (define reg0 '%eax) ;for object ptr 31 | (define reg1 '%ebx) ; 32 | (define reg2 '%ecx) 33 | (define reg3 '%edx) 34 | (define reg4 '%esi) ;for alloc base 35 | (define reg5 '%edi) 36 | (define reg6 '%ebp) 37 | (define reg7 '%esp) 38 | 39 | (define r0 '%ax) 40 | (define r0l '%al) 41 | (define r0h '%ah) 42 | 43 | (define r1l '%bl) 44 | (define r1h '%bh) 45 | 46 | (define regs (list reg0 reg1 reg2 reg3 reg4 reg5 reg6 reg7 )) 47 | (define regs-map (list 'reg0 reg0 'reg1 reg1 'reg2 reg2 'reg3 reg3 'reg4 reg4 'reg5 reg5 'reg6 reg6 'reg7 reg7 'r0 r0 'r0l r0l 'r0h r0h )) 48 | 49 | 50 | (define arch-bits 32) 51 | 52 | (define all-data (make-hashtable equal-hash equal?)) 53 | 54 | (define (get-data var ) 55 | (let ((val (hashtable-ref all-data var '()))) 56 | (if (null? val) 57 | (asm-data-get var '()) 58 | ) 59 | ) 60 | ) 61 | 62 | (define (set-data var val) 63 | (hashtable-set! all-data var val) 64 | ) 65 | 66 | (define symbol-prefix 67 | (case (machine-type) 68 | ((arm32le) "_") 69 | ((a6nt i3nt ta6nt ti3nt) "_") 70 | ((a6osx i3osx ta6osx ti3osx) "") 71 | ((a6le i3le ta6le ti3le) ""))) 72 | 73 | 74 | (define (asm-compile-exp exp name) 75 | (let ((asm 76 | (case (machine-type) 77 | ((arm32le) "") 78 | ((a6nt i3nt ta6nt ti3nt) (format "" name name name)) 79 | ((a6osx i3osx ta6osx ti3osx) (format "llvm-gcc ~a~a -o ~a" name (option-get 'obj.name ".s") name)) 80 | ((a6le i3le ta6le ti3le) (format "" name name name)))) 81 | ) 82 | (printf "~a\n" asm) 83 | (system asm) 84 | ) 85 | ) 86 | 87 | (define (stext arg) 88 | (if (equal? arg 'start) 89 | (begin 90 | (asm "; ModuleID = 'duck'") 91 | (asm "declare i32 @printf(i32*, ...)") 92 | 93 | (asm "define i32 @main(i32,i32 ) {") 94 | (map (lambda (x) 95 | (asm "~a = alloca i32, align 4" x) 96 | ;;(asm "%~a = load i32, i32* %.~a, align 4" x x) 97 | ) regs) 98 | (gen-local-params '(arg0 arg1)) 99 | ) 100 | (begin 101 | (sexit 0) 102 | (asm "ret i32 0") 103 | (asm "}") 104 | ) 105 | ) 106 | ) 107 | 108 | (define (sexit code) 109 | (note "call exit 0") 110 | 111 | ) 112 | 113 | (define (sdata arg) 114 | (if (equal? 'start arg) 115 | (begin 116 | (note "section .data") 117 | (gen-define) 118 | ) 119 | (asm "") 120 | ) 121 | ) 122 | 123 | (define (gen-define) 124 | ;;(asm "section .data") 125 | (let-values ([(keyvec valvec) (hashtable-entries (get-asm-data-define))]) 126 | (vector-for-each 127 | (lambda (key val) 128 | (data key val)) 129 | keyvec valvec)) 130 | ) 131 | 132 | 133 | ;;asm code here 134 | (define (operands-rep x) 135 | (cond 136 | [(integer? x) 137 | x ] 138 | [(memq x regs) 139 | x 140 | ] 141 | [(memq x regs-map) 142 | ; (printf "(memq x regs)=>~a ===========> ~a\n" (memq x regs-map) (cadr (memq x regs-map))) 143 | (cadr (memq x regs-map)) 144 | ] 145 | [(string? x) 146 | x 147 | ] 148 | [(symbol? x) 149 | x 150 | ] 151 | ; [(list? x) 152 | ; (let loop ((e x) (s "[")) 153 | ; (if (pair? e) 154 | ; (begin 155 | ; (loop (cdr e) (string-append s (format "~a + " (car e) ))) 156 | ; ) 157 | ; (string-append s "0]") 158 | ; ) 159 | ; ) 160 | ; ] 161 | [else 162 | (note "operands-rep else ~a" x) 163 | (format "~a" x ) ] 164 | ) 165 | ) 166 | 167 | (define (data var val) 168 | (note "data var=~a val=~a" var val) 169 | (set-data var val) 170 | (cond 171 | [(string? val) 172 | (asm "@~a = constant [~a x i8] c\"~a\", align 1" var (string-length val) val)] 173 | [(number? val) 174 | (asm "@~a = constant i32 ~a" var val)] 175 | [else 176 | (asm "@~a = global i32 \"~a\"" var val)] 177 | ) 178 | 179 | ;(asm "(data (;0;) (i32.const 1024) \"~a\" )" val) 180 | ) 181 | 182 | (define (local index) 183 | (string->symbol (format "%local.~a" index)) 184 | ) 185 | 186 | (define (fcall l . args) 187 | (note "fcall ~a ~a" l args) 188 | (let ((def "")) 189 | (if (equal? l 'printf) 190 | (set! def "(i32*, ...)") 191 | ) 192 | (asm "%call.ret.~a = call i32 ~a @~a~a(~a)" binary-offset def symbol-prefix (symbol->asm-id l) (gen-call-args args)) 193 | ) 194 | ) 195 | 196 | (define (ccall l . args) 197 | (note "ccall") 198 | ) 199 | 200 | (define (gen-args args) 201 | (let loop [(i args) (ret "")] 202 | (if (pair? i) 203 | (begin 204 | (loop (cdr i) (string-append ret (format "~a " (operands-rep (car i))) )) 205 | ) 206 | ret 207 | ) 208 | ) 209 | ) 210 | 211 | 212 | (define (gen-call-args args) 213 | (let loop [(i args) (ret "")] 214 | (if (pair? i) 215 | (begin 216 | (note "arg=~a" (car i)) 217 | (cond 218 | [(string? (operands-rep (car i))) 219 | ;;(asm "%call.arg.~a = load i8, i8* ~a, align 4" binary-offset (operands-rep (car i)) ) 220 | (asm "%call.arg.~a = alloca i32, align 4" binary-offset) 221 | (asm "store i32 ptrtoint ([~a x i8]* @~a to i32), i32* %call.arg.~a, align 4" 222 | (string-length (get-data (symbol->asm-id (car i)) ) ) 223 | (symbol->asm-id (car i)) 224 | binary-offset ) 225 | (set! ret (string-append ret (format "i32* %call.arg.~a," binary-offset ))) 226 | ] 227 | [else 228 | (asm "%call.arg.~a = load i32, i32* ~a, align 4" binary-offset (operands-rep (car i)) ) 229 | (set! ret (string-append ret (format "i32 %call.arg.~a," binary-offset ))) 230 | ] 231 | ) 232 | (set! binary-offset (+ binary-offset 1)) 233 | (loop (cdr i) ret ) 234 | ) 235 | (substring ret 0 (- (string-length ret) 1) ) 236 | ) 237 | ) 238 | ) 239 | 240 | (define (call l . args) 241 | (note "call $~a ~a" (symbol->asm-id l ) (gen-args args) ) 242 | (let ((ret (format "%call.ret.~a" binary-offset ))) 243 | (asm "~a = call i32 @~a(~a)" ret (symbol->asm-id l) (gen-call-args args) ) 244 | (asm "store i32 ~a, i32* ~a, align 4" ret reg0) 245 | ) 246 | ) 247 | 248 | (define (jmp l) 249 | (note "jmp") 250 | (asm "br label %~a" (symbol->asm-id l)) 251 | 252 | ) 253 | 254 | (define (cmp-jmp val1 val2 l1 l2) 255 | (note "cmp-jmp ~a ~a ~a ~a" val1 val2 l1 l2) 256 | ; ;;param eax 257 | (cond 258 | [(and (memq (operands-rep val1) regs) (memq (operands-rep val2) regs) ) 259 | (note "1") 260 | (asm "%cmp.a.~a = load i32, i32* ~a, align 4" binary-offset (operands-rep val1) ) 261 | (asm "%cmp.b.~a = load i32, i32* ~a, align 4" binary-offset (operands-rep val2) ) 262 | (asm "%cmp.~a = icmp eq i32 %cmp.a.~a, %cmp.b.~a" binary-offset binary-offset ) 263 | ] 264 | [(and (memq (operands-rep val1) regs) (number? (operands-rep val2)) ) 265 | (note "2") 266 | (asm "%cmp.a.~a = load i32, i32* ~a, align 4" binary-offset (operands-rep val1) ) 267 | (asm "%cmp.~a = icmp eq i32 %cmp.a.~a, ~a" binary-offset binary-offset (operands-rep val2) ) 268 | ] 269 | [(and (memq (operands-rep val1) regs) (symbol? (operands-rep val2)) ) 270 | (note "3") 271 | (asm "%cmp.a.~a = load i32, i32* ~a, align 4" binary-offset (operands-rep val1) ) 272 | (asm "%cmp.b.~a = load i32, i32* @~a, align 4" binary-offset (symbol->asm-id (operands-rep val2) )) 273 | (asm "%cmp.~a = icmp eq i32 %cmp.a.~a, %cmp.b.~a" binary-offset binary-offset binary-offset ) 274 | ] 275 | [else 276 | (note "4") 277 | (asm "%cmp.~a = icmp eq i32 ~a, ~a" binary-offset (operands-rep val1) (operands-rep val2)) 278 | ] 279 | ) 280 | (cond 281 | [(and (not (null? l1)) (not (null? l2))) 282 | (asm "br i1 %cmp.~a, label %~a, label %~a" binary-offset (symbol->asm-id l1) (symbol->asm-id l2) ) 283 | ] 284 | [(and (not (null? l1)) (null? l2)) 285 | (set! l2 (format "label.~a" binary-offset)) 286 | (asm "br i1 %cmp.~a, label %~a, label %~a" binary-offset (symbol->asm-id l1) l2 ) 287 | (asm "~a:" l2) 288 | ] 289 | [(and (not (null? l2)) (null? l1)) 290 | (set! l1 (format "label.~a" binary-offset)) 291 | (asm "br i1 %cmp.~a, label %~a, label %~a" binary-offset l1 (symbol->asm-id l2) ) 292 | (asm "~a:" l1) 293 | ] 294 | ) 295 | 296 | (set! binary-offset (+ binary-offset 1)) 297 | ; (asm "cmp.~a = icmp eq ~a, nop " binary-offset (operands-rep val1) (operands-rep val2)) 298 | ; (if (not (null? l1) ) 299 | ; (asm "je ~a" (symbol->asm-id l1) )) ;; goto equal 300 | ; ; (printf "===========>~a\n" (symbol? l2)) 301 | ; (if (not (null? l2) ) 302 | ; (asm "jne ~a" (symbol->asm-id l2) )) ;; goto not equal 303 | 304 | ) 305 | 306 | 307 | (define (cmp type a b) 308 | (note "cmp") 309 | ) 310 | 311 | (define (is-reg x) 312 | (or (memq x regs) (memq x regs-map) ) 313 | ) 314 | 315 | ;; set symbol? [a], string a ,reg 316 | ;; set reg,reg mem,reg reg,mem 317 | (define set 318 | (case-lambda 319 | [(a b) 320 | (let ((type "set")) 321 | (set! a (operands-rep a )) 322 | (set! b (operands-rep b )) 323 | 324 | (unless (equal? a b) 325 | (note "set ~a ~a (list? a)=~a (string? a)=~a (number? b)=~a" a b (list? a) (string? a) (number? b)) 326 | (cond 327 | [(and (memq a regs) (memq b regs) ) 328 | (note "1") 329 | (asm "%~a.a~a = load i32, i32* ~a, align 4" type binary-offset a) 330 | (asm "store i32 %~a.a~a, i32* ~a, align 4" type binary-offset b) 331 | ] 332 | [(and (string? a) (memq b regs) ) ;;str a=>b 333 | (note "2") 334 | (asm "store i32 ptrtoint ([~a x i8]* @~a to i32), i32* ~a, align 4" (string-length (get-data a)) a b) 335 | ] 336 | [(and (string? b) (memq a regs) ) ;;str b=>a 337 | (note "3") 338 | (asm "store i32 ptrtoint ([~a x i8]* @~a to i32), i32* ~a, align 4" (string-length (get-data b)) b a) 339 | ] 340 | [(and (memq a regs) (symbol? b )) ;; local0=>reg0 b=>a 341 | (note "4") 342 | (asm "%~a.a~a = load i32, i32* ~a, align 4" type binary-offset a) 343 | (asm "store i32 %~a.a~a, i32* ~a, align 4" type binary-offset b) 344 | ] 345 | [(and (memq b regs) (symbol? a )) ;; reg b=> local a 346 | (note "5") 347 | (asm "%~a.a~a = load i32, i32* ~a, align 4" type binary-offset b) 348 | (asm "store i32 %~a.a~a, i32* ~a, align 4" type binary-offset a) 349 | ] 350 | [(and (symbol? a) (number? b)) 351 | (asm "store i32 ~a, i32* ~a, align 4" b a) 352 | ] 353 | [(and (symbol? b) (number? a)) 354 | (asm "store i32 ~a, i32* ~a, align 4" a b) 355 | ] 356 | [else 357 | (asm "error") 358 | ] 359 | ) 360 | (set! binary-offset (+ binary-offset 1)) 361 | ) 362 | ) 363 | ] 364 | [(a b c) 365 | (note "set") 366 | ]) 367 | ) 368 | 369 | ;;ref reg,[reg] reg,[mem] 370 | (define mref 371 | (case-lambda 372 | [(a b) 373 | 374 | (note "mref a b")] 375 | [(a b c) 376 | (note "mref a b c")])) 377 | 378 | ;;set [reg],reg [mem],reg 379 | (define mset 380 | (case-lambda 381 | [(a b) 382 | 383 | (note "mset a b")] 384 | [(a b c) 385 | (note "mset a b c")])) 386 | 387 | (define binary-offset 0) 388 | (define (binary-op type a b ) 389 | (note "~a ~a,~a" type a b ) 390 | (set! a (operands-rep a )) 391 | (set! b (operands-rep b )) 392 | (cond 393 | [(and (memq a regs) (memq b regs) ) 394 | (asm "%~a.a~a = load i32, i32* ~a, align 4" type binary-offset a) 395 | (asm "%~a.b~a = load i32, i32* ~a, align 4" type binary-offset b) 396 | (asm "%~a.ret~a = ~a i32 %~a.a~a, %~a.b~a" type binary-offset type type binary-offset type binary-offset) 397 | (asm "store i32 %~a.ret~a, i32* ~a, align 4" type binary-offset reg0 ) 398 | ] 399 | [(and (memq a regs) (number? b) ) 400 | (asm "%~a.a~a = load i32, i32* ~a, align 4" type binary-offset a) 401 | (asm "%~a.ret~a = ~a i32 %~a.a~a, ~a" type binary-offset type type binary-offset b) 402 | (asm "store i32 %~a.ret~a, i32* ~a, align 4" type binary-offset reg0) 403 | ] 404 | [(and (memq b regs) (number? a) ) 405 | (asm "%~a.b~a = load i32, i32* ~a, align 4" type binary-offset b) 406 | (asm "%~a.ret~a = ~a i32 %~a.a~a, ~a" type binary-offset type type binary-offset a) 407 | (asm "store i32 %~a.ret~a, i32* ~a, align 4" type binary-offset reg0) 408 | ] 409 | [(and (number? a) (number? b)) 410 | (asm "store i32 ~a, i32* ~a, align 4" (+ a b) reg0) 411 | ] 412 | [else 413 | (asm "error ") 414 | ] 415 | 416 | ) 417 | (set! binary-offset (+ binary-offset 1)) 418 | ) 419 | 420 | (define (sub a b) 421 | (binary-op 'sub a b ) 422 | ) 423 | 424 | (define (add a b) 425 | (binary-op 'add a b ) 426 | ) 427 | 428 | (define (mul a b) 429 | (binary-op 'mul a b ) 430 | ) 431 | 432 | (define (div a b) 433 | (binary-op 'div a b ) 434 | ) 435 | 436 | 437 | (define (gen-params args) 438 | (let loop [(i args) (ret " ")] 439 | (if (pair? i) 440 | (begin 441 | (loop (cdr i) (string-append ret (format "i32 ," )) ) 442 | ) 443 | (substring ret 0 (- (string-length ret) 1) ) 444 | ) 445 | ) 446 | ) 447 | 448 | (define (gen-local-params args) 449 | (let loop [(i args) (offset 0)] 450 | (if (pair? i) 451 | (begin 452 | (asm "%local.~a = alloca i32, align 4" offset) 453 | (asm "store i32 %~a, i32* %local.~a, align 4" offset offset) 454 | (loop (cdr i) (+ offset 1)) 455 | ) 456 | ) 457 | ) 458 | ) 459 | 460 | (define (proc l args) 461 | (set! binary-offset 0) 462 | (note "\n") 463 | (note "proc ~a ~a" l args) 464 | (asm "define i32 @~a(~a) { " (symbol->asm-id l) (gen-params args) ) 465 | (map (lambda (x) 466 | (asm "~a = alloca i32, align 4" x) 467 | ;;(asm "%~a = load i32, i32* %.~a, align 4" x x) 468 | ) regs) 469 | (gen-local-params args) 470 | 471 | 472 | ) 473 | 474 | (define (lproc l args) 475 | (proc l args) 476 | ) 477 | 478 | (define (pret) 479 | (ret) 480 | ) 481 | 482 | (define (lret) 483 | (ret) 484 | ) 485 | 486 | (define (ret) 487 | (note "ret") 488 | ;;(asm "ret i32 0" (operands-rep reg0)) 489 | (asm "ret i32 0") 490 | (asm "}") 491 | ) 492 | 493 | (define (label l) 494 | ;;(note "label ~a" (symbol->asm-id l)) 495 | (asm "~a:" (symbol->asm-id l)) 496 | ;;(asm ";