├── .gitignore
├── LICENSE
├── Makefile
├── README.md
├── arch
    ├── arch.ss
    ├── arm.ss
    ├── arm64.ss
    ├── llvm.ss
    ├── wasm.ss
    ├── x86-64.ss
    └── x86.ss
├── common
    ├── common.ss
    ├── logger.ss
    ├── match.ss
    ├── test.ss
    └── trace.ss
├── docs
    └── exp.txt
├── duck
    ├── duck.ss
    ├── egg.ss
    ├── libs.ss
    ├── options.ss
    ├── primitive.ss
    └── type.ss
├── scripts
    ├── run-test.sh
    └── run-tests.sh
└── tests
    ├── test-all.ss
    ├── test-asm.ss
    ├── test-basic.ss
    ├── test-begin.ss
    ├── test-cmp.ss
    ├── test-define.ss
    ├── test-exp.ss
    ├── test-fib.ss
    ├── test-if.ss
    ├── test-lambda.ss
    ├── test-let.ss
    ├── test-llvm.ss
    ├── test-prim.ss
    ├── test-print.ss
    ├── test-remove-code.ss
    ├── test-set.ss
    ├── test-tail-call.ss
    ├── test-var.ss
    ├── test-wasm.ss
    └── test0
        ├── duck.c
        ├── make-rand.ss
        ├── rand.ss
        ├── test-bm.ss
        ├── test-let.s
        ├── test-list.ss
        ├── test-print
        ├── test-print.s
        ├── test-string-replace.ss
        ├── test.c
        ├── test.s
        ├── test1.s
        ├── test2.c
        ├── test2.s
        ├── test3.c
        ├── test3.s
        ├── test4.c
        └── test4.s


/.gitignore:
--------------------------------------------------------------------------------
 1 | *.ss~
 2 | *.ss#*
 3 | .#*.ss
 4 | 
 5 | *.scm~
 6 | *.scm#*
 7 | .#*.scm
 8 | 
 9 | build/*
10 | *.log
11 | 


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


--------------------------------------------------------------------------------
/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/*


--------------------------------------------------------------------------------
/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]


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


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


--------------------------------------------------------------------------------
/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 "; <label>:~a: " (symbol->asm-id l))
497 |   )
498 | 
499 | (define (sar a b)
500 |   (binary-op 'ashr a b ) )
501 | 
502 | (define (sal a b)
503 |   (binary-op 'shl a b ))
504 | 
505 | (define (shl a b)
506 |   (binary-op 'shl a b ))
507 | 
508 | (define (shr a b)
509 |   (binary-op 'lshr a b ) )
510 | 
511 | (define (land a b)
512 |   (binary-op 'and a b ))
513 | 
514 | (define (xor a b)
515 |   (binary-op 'xor a b ) )
516 | 
517 | 
518 | (define (save a)
519 |   (note "push ~a" (operands-rep a)))
520 | 
521 | (define (restore a)
522 |   (note "pop ~a" (operands-rep a)))
523 | 
524 | (define (nop)
525 |   (asm "(nop)"))
526 | 
527 | 
528 | 
529 | )


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


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


--------------------------------------------------------------------------------
/arch/x86.ss:
--------------------------------------------------------------------------------
  1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2 | ;Copyright 2016-2080 evilbinary.
  3 | ;作者:evilbinary on 12/24/16.
  4 | ;邮箱:rootdebug@163.com
  5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6 | (library (arch x86)
  7 |   (export 
  8 |     reg0 reg1 reg2 reg3 reg4 reg5 reg6 reg7 regs regs-map
  9 |     r0h r0l r1h r1l
 10 |     asm set mref mset note
 11 |     add label sar sal mul sub div
 12 |     shl shr ret
 13 |     call jmp cmp-jmp cmp
 14 |     land lor xor save restore
 15 |     nop local proc pret lproc lret
 16 | 
 17 |     fcall ccall
 18 |     stext sexit
 19 |     asm-compile-exp
 20 |     data sdata
 21 |     arch-bits
 22 |     operands-rep
 23 |   )
 24 | 
 25 | (import 
 26 |     (rename (scheme) (div div2) )
 27 |     (common common)
 28 |     (common trace)
 29 |     (duck type)
 30 |     )
 31 | 
 32 | (define arch-bits 32)
 33 | ;;reg
 34 | (define reg0 'eax) ;for object ptr
 35 | (define reg1 'ebx) ;
 36 | (define reg2 'ecx)
 37 | (define reg3 'edx)
 38 | (define reg4 'esi) ;for alloc base
 39 | (define reg5 'edi)
 40 | (define reg6 'ebp)
 41 | (define reg7 'esp)
 42 | 
 43 | (define r0 'ax)
 44 | (define r0l 'al)
 45 | (define r0h 'ah)
 46 | 
 47 | (define r1l 'bl)
 48 | (define r1h 'bh)
 49 | 
 50 | (define regs (list reg0  reg1 reg2 reg3 reg4 reg5 reg6 reg7 r0 r0l r0h r1l r1h))
 51 | (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 ))
 52 | 
 53 | 
 54 | (define symbol-prefix
 55 |   (case (machine-type)
 56 |     ((arm32le) "_")
 57 |     ((a6nt i3nt ta6nt ti3nt)  "_")
 58 |     ((a6osx i3osx ta6osx ti3osx)  "_")
 59 |     ((a6le i3le ta6le ti3le) "")))
 60 | 
 61 | ;;opt lib
 62 | (define (copy-string ecx esi edi)
 63 |           (asm "push ecx")
 64 |           (asm "push esi")
 65 |           (asm "push edi")
 66 |           (asm "cld")
 67 |           (asm "rep movsb")
 68 |           (asm "pop ecx")
 69 |           (asm "pop esi")
 70 |           (asm "pop edi")
 71 |           (ret)
 72 | )
 73 | 
 74 | (define (gen-define)
 75 |   ;;(asm "section .data")
 76 |   (let-values ([(keyvec valvec) (hashtable-entries (get-asm-data-define))])
 77 |       (vector-for-each
 78 |         (lambda (key val)
 79 |             (data key val))
 80 |         keyvec valvec))
 81 | )
 82 | 
 83 | (define note
 84 |   (case-lambda 
 85 |     [(a) (asm ";;~a" a)]
 86 |     [(fmt . val) 
 87 |       (printf ";;")
 88 |       (apply asm fmt val)]))
 89 | 
 90 | (define (asm . args)
 91 |   (apply printf  args)
 92 |   (newline ))
 93 | 
 94 | 
 95 | (define data
 96 |   (case-lambda 
 97 |   [(var val)
 98 |     (note "data var=~a val=~a" var val)
 99 |     (cond 
100 |       [(string? val)
101 |         (asm  "~a db \"~a\",0 " (symbol->asm-id var) val)]
102 |       [(number? val)
103 |         (asm  "~a dd ~a" (symbol->asm-id var) val)]
104 |       [else
105 |         (asm  "~a dd ~a" (symbol->asm-id var) val)]
106 |     )
107 |   ]
108 |   [(var val len)
109 |     (note "data var=~a val=~a len=~a" var val len)
110 |     (asm  "~a db ~a" (symbol->asm-id var) val)
111 |     (asm "times ~a db 0" len)
112 |   ]
113 |   )
114 | 
115 | )
116 | 
117 | (define (asm-compile-exp exp name)
118 |   (let ((asm
119 |         (case (machine-type)
120 |           ((arm32le) "")
121 |           ((a6nt i3nt ta6nt ti3nt)  (format "`which  nasm` ~a.s -f win32 && ld -arch i386 -e _start -no_pie -lc ~a.o -o ~a"  name  name name))
122 |           ((a6osx i3osx ta6osx ti3osx)   (format "`which  nasm` ~a.s -f macho && ld -macosx_version_min 10.6  -arch i386  -e _start -no_pie -lc ~a.o -o ~a"  name  name name))
123 |           ((a6le i3le ta6le ti3le) (format "`which  nasm` ~a.s -f elf32 && ld -dynamic-linker /lib/i386-linux-gnu/ld-linux.so.2 -lc  -m elf_i386 -e _start  ~a.o -o ~a"  name  name name))))
124 |       )
125 |       (printf "~a\n" asm)
126 |       (system asm)
127 |   )
128 | )
129 | 
130 | ;;asm code here
131 | (define (operands-rep x)
132 |   (cond
133 |       [(integer? x) x]
134 |       [(memq x regs)
135 |         x
136 |       ]
137 |       [(memq x regs-map)
138 |         ; (printf "(memq x regs)=>~a ===========> ~a\n" (memq x regs-map) (cadr (memq x regs-map)))
139 |        (cadr (memq x regs-map))]
140 |       [(symbol? x)
141 |         (let ((s (symbol->string x)))
142 |           (if (equal? (string-ref s 0) #\&)
143 |             (format "~a \n sal eax,3" (symbol->asm-id  (substring s 1 (string-length s)) ))
144 |             (format "[~a]" (symbol->asm-id s)))
145 |         )]
146 |       [(list? x)
147 |         (let loop ((e x) (s "["))
148 |           (if (pair? e)
149 |             (begin 
150 |               (loop (cdr e) (string-append  s  (format "~a + " (car e) )))
151 |             )
152 |             (string-append s "0]")
153 |           )
154 |         )
155 |       ]
156 |       [else 
157 |         (note "operands-rep else ~a" x)
158 |         (format "~a" x ) ]     
159 |   )
160 | )
161 | 
162 | (define (arg . args)
163 |   (if (> (length args) 0)
164 |       (let l ((arg  args) (i 0)) 
165 |           (if (pair? arg)
166 |               (begin
167 |                 (cond
168 |                   [(number? (car arg))
169 |                     (note "number arg=~a 0x~x" (car arg) (car arg))
170 |                     (asm "mov dword [esp+ ~a], ~a" (* i 4) (car arg))
171 |                   ]
172 |                   [(list? (car arg)) 
173 |                     (note "list arg=~a" (car arg))
174 |                     (asm "mov ~a,~a" reg0 (operands-rep (car arg)) )
175 |                     (asm "mov dword [esp+ ~a], ~a" (* i 4) reg0)
176 |                   ]
177 |                   [(string? (car arg))
178 |                     (note "string arg=~a" (car arg))
179 |                     (asm "mov dword [esp+ ~a], ~a"  (* i 4) (symbol->asm-id (car arg)))
180 |                   ]
181 |                   [(memq (car arg) regs-map) 
182 |                     (note "reg arg=~a" (car arg))
183 |                     (asm "mov dword [esp+ ~a], ~a" (* i 4) (operands-rep (car arg)) )
184 |                   ]
185 |                   [(void? (car arg))
186 |                     (note "void arg")
187 |                   ]
188 |                   [else
189 |                     (note "else arg=~a" (car arg))
190 |                     (asm "mov ~a,~a" reg0 (operands-rep (car arg)) )
191 |                     (asm "mov dword [esp+ ~a],~a" (* i 4) reg0)
192 |                   ]
193 |               )
194 |               (l (cdr arg)  (+ i 1)))
195 |           )
196 |       )
197 |   )
198 | )
199 | 
200 | (define (carg . args)
201 |   (if (> (length args) 0)
202 |       (let l ((arg  args) (i 0)) 
203 |           (if (pair? arg)
204 |               (begin
205 |                 (cond
206 |                   [(number? (car arg))
207 |                     (note "number arg=~a 0x~x" (car arg) (car arg))
208 |                     (asm "mov ~a,~a" reg0 (car arg))
209 |                     (sar reg0 type-shift)
210 |                     (asm "mov dword [esp+ ~a], ~a" (* i 4) reg0 )
211 |                   ]
212 |                   [(list? (car arg)) 
213 |                     (note "list arg=~a" (car arg))
214 |                     (asm "mov ~a,~a" reg0 (operands-rep (car arg)) )
215 |                     (sar reg0 type-shift)
216 |                     (asm "mov dword [esp+ ~a], ~a" (* i 4) reg0)
217 |                   ]
218 |                   [(string? (car arg))
219 |                     (note "string arg=~a" (car arg))
220 |                     (asm "mov ~a,~a" reg0 (symbol->asm-id (car arg)) )
221 |                     (sar reg0 type-shift)
222 |                     (asm "mov dword [esp+ ~a], ~a"  (* i 4) reg0 )
223 |                   ]
224 |                   [(memq (car arg) regs-map) 
225 |                     (note "reg arg=~a" (car arg))
226 |                     (asm "mov ~a,~a" reg0 (operands-rep (car arg)) )
227 |                     (sar reg0 type-shift)
228 |                     (asm "mov dword [esp+ ~a], ~a" (* i 4) reg0 )
229 |                   ]
230 |                   [else
231 |                     (note "else arg=~a" (car arg))
232 |                     (asm "mov ~a,~a" reg0 (operands-rep (car arg)) )
233 |                     (sar reg0 type-shift)
234 |                     (asm "mov dword [esp+ ~a],~a" (* i 4) reg0)
235 |                   ]
236 |               )
237 |               (l (cdr arg)  (+ i 1)))
238 |           )
239 |       )
240 |   )
241 | )
242 | 
243 | (define cmp->inst
244 |     (lambda (op)
245 |       (case op
246 |         [(>) 'jg]
247 |         [(<) 'jl]
248 |         [(>=) 'jae]
249 |         [(<=) 'jle]
250 |         [(=) 'je]
251 |         [else (printf "erro binop ~s" op)])))
252 |         
253 | (define (emit-cmp binop v1 v2)   
254 |       (let* ((l1 (gen-sym (cmp->inst binop) ))
255 |             (l2 (symbol-append l1 'end)) )
256 |           ; (xor reg0 reg0)
257 |           (note "cmp ~a ~a ~a" binop v1 v2)
258 |           (set reg0  (operands-rep v1))
259 |           ; (set reg1 v2)
260 |           ; (sar reg0 type-shift)
261 |           ; (sar reg1 type-shift)
262 |           (asm "cmp ~a,~a" reg0 (operands-rep v2))
263 |           (asm "~a ~a" (cmp->inst binop) l1)
264 |           (set reg0 'false-rep)
265 |           (jmp l2)
266 |           (label l1)
267 |           (set reg0 'true-rep)
268 |           (label l2)
269 |           (note binop)
270 |       )
271 | )
272 | 
273 | (define (stext arg)
274 |   (if (equal? arg 'start)
275 |     (begin 
276 |       (asm (format "extern ~aprintf" symbol-prefix))
277 |       (asm (format "extern ~aexit" symbol-prefix))
278 |       (asm (format "extern ~amalloc" symbol-prefix))
279 |       (asm "")
280 |       (asm "section .text")
281 |       (asm "global _start")
282 | 
283 |       (asm "%macro cproc 1
284 |         push ebx
285 |         mov ebx, esp        ; remember current esp
286 |         and esp, 0xFFFFFFF0 ; align to next 16 byte boundary (could be zero offset!)
287 |         sub esp, 12         ; skip ahead 12 so we can store original esp
288 |         push ebx            ; store esp (16 bytes aligned again)
289 |         sub esp, %1         ; pad for arguments (make conditional?)
290 |     %endmacro
291 | 
292 |     ; arg must match most recent call to clib_prolog
293 |     %macro ceproc 1
294 |         add esp, %1         ; remove arg padding
295 |         pop ebx             ; get original esp
296 |         mov esp, ebx        ; restore
297 |         pop ebx
298 |     %endmacro
299 |     ")
300 | 
301 |       (asm "_start:")
302 |       (asm "push ebp")
303 |       (asm "mov	ebp, esp")
304 |       (asm "and esp,0xFFFFFFF0")
305 |       (asm "sub esp,12")
306 | 
307 |       ; (asm "mov eax ,dword [ebp+4 ]")
308 |       ; (asm "mov eax ,dword [ebp+0 ]")
309 |       ; (asm "pop eax  ;;argc to eax")
310 |       ; (asm "pop ebx  ;;argv to ebx")
311 |       ; (asm "mov ebp,esp")
312 |       ; (asm "and esp,0xFFFFFFF0")
313 |       ; (asm "sub esp,16")
314 |     )
315 |     (begin 
316 |       (sexit 0)
317 |     )
318 |   )
319 |   
320 | )
321 | 
322 | (define (sexit code)
323 |   (note "call exit 0")
324 |   (fcall 'exit 0)
325 |   (asm "pop ebp")
326 |   (asm "ret")
327 | )
328 | 
329 | (define (sdata arg)
330 |     (if (equal? 'start arg)
331 |       (begin 
332 |         (asm "section .data")
333 |         (gen-define)
334 |     ))
335 | )
336 | 
337 | (define (local index)
338 |   (if (number? index)
339 |     (list 'ebp (* 4 index))
340 |     index
341 |   )
342 | )
343 | 
344 | (define (align args)
345 |   (* 16 (flonum->fixnum (+ 0.9 (/ (* 4 (length args)) 16))))
346 | )
347 | 
348 | (define (ccall l . args)
349 |   (asm "cproc ~a" (align args))
350 |   ; (if (> (length args) 0)
351 |   ;   (begin 
352 |   ;     (asm "and esp,0xFFFFFFF0")
353 |   ;     (asm "sub  esp,~a" (align args))
354 |   ;    ))
355 |   (apply carg args)
356 |   (asm "call ~a~a" symbol-prefix (symbol->asm-id l))
357 |   ; (if (> (length args) 0)
358 |   ;   (asm "add esp, ~a" (align args) )
359 |   ;   )
360 |   (asm "ceproc ~a" (align args))
361 |   )
362 | 
363 | (define (fcall l . args)
364 |   (asm "cproc ~a" (align args))
365 |   ; (if (> (length args) 0)
366 |   ;   (begin 
367 |   ;     (asm "and esp,0xFFFFFFF0")
368 |   ;     (asm "sub  esp,~a" (align args))
369 |   ;    ))
370 |   (apply arg args)
371 |   (asm "call ~a~a"  symbol-prefix (symbol->asm-id l))
372 |   ; (if (> (length args) 0)
373 |   ;   (asm "add esp, ~a" (align args) )
374 |   ;   )
375 |   (asm "ceproc ~a" (align args))
376 |   )
377 | 
378 | (define (call l . args)
379 |   (if (> (length args) 0)
380 |     (begin 
381 |       (asm "sub  esp,~a" (align args))
382 |      ))
383 |   (apply arg args)
384 |   (asm "call ~a" (symbol->asm-id l))
385 |   (if (> (length args) 0)
386 |     (asm "add esp, ~a" (align args) )
387 |     )
388 |   )
389 | 
390 | (define (jmp l)
391 |   (asm "jmp ~a" (symbol->asm-id l)))
392 | 
393 | (define (cmp-jmp val1 val2 l1 l2)
394 |     ;;param eax
395 |     (asm "cmp ~a,~a" (operands-rep val1)  (operands-rep val2))
396 |     (if (not (null? l1) )
397 |       (asm "je ~a" (symbol->asm-id l1) )) ;; goto equal
398 |     ; (printf "===========>~a\n" (symbol? l2))
399 |     (if (not (null? l2) )
400 |       (asm "jne ~a" (symbol->asm-id l2) )) ;; goto not equal
401 | )
402 | 
403 | (define (cmp type a b)
404 |   (emit-cmp type a b)
405 | )
406 | 
407 | ;; set symbol? [a], string a ,reg 
408 | ;; set reg,reg mem,reg reg,mem
409 | (define set
410 |   (case-lambda 
411 |     [(a b) 
412 |       (note "set ~a ~a (list? a)=~a number b?=~a" a b (list? a) (number? b))
413 |       (unless (equal? a b) 
414 |           (cond
415 |             [(and (symbol? a) (number? b))
416 |               (asm "mov ~a,~a" (operands-rep a) b)
417 |             ]
418 |             [(and (list? a) (or (list? b) (symbol? b))) 
419 |                 (asm "mov ~a,~a" reg0 (operands-rep b) )
420 |                 (asm "mov ~a,~a" (operands-rep a) reg0 )
421 |               ]
422 |             [else 
423 |               (asm "mov ~a~a,~a" (if (list? a) "dword " "") (operands-rep a) (operands-rep b) )
424 |             ]
425 | 
426 |           )
427 |         )]
428 |     [(a b c)
429 |     (unless (equal? a b)
430 |       (asm "mov ~a,~a ;;~a" (operands-rep a) (operands-rep b) c ))]))
431 | 
432 | ;;ref reg,[reg] reg,[mem]
433 | (define mref
434 |   (case-lambda 
435 |     [(a b) 
436 |       (asm "mov ~a,[~a]" (operands-rep a) (operands-rep b) )]
437 |     [(a b c)
438 |       (asm "mov ~a,[~a] ;;~a" (operands-rep a) (operands-rep b) c )]))
439 | 
440 | ;;set [reg],reg [mem],reg
441 | (define mset
442 |   (case-lambda 
443 |     [(a b) 
444 |       (unless (equal? a b)
445 |         (asm "mov [~a],~a" (operands-rep a) (operands-rep b) ))]
446 |     [(a b size)
447 |     (unless (equal? a b)
448 |       (if (pair? size)
449 |         (cond 
450 |           [(equal? (car size) 'word )
451 |             (asm "mov eax,~a" (operands-rep a))
452 |             (asm "mov ebx,~a" (operands-rep b))
453 |             (asm "mov word [eax],bx ;;~a"  size )
454 |           ]
455 |           [(equal? (car size) 'byte )
456 |             (asm "mov eax,~a" (operands-rep a))
457 |             (asm "mov ebx,~a" (operands-rep b))
458 |             (asm "mov byte [eax],bl ;;~a"  size )
459 |           ]
460 |           [else
461 |             (asm "mov [~a],~a ;;~a" (operands-rep a) (operands-rep b) size )
462 |           ]
463 |         )
464 |         (asm "mov [~a],~a ;;~a" (operands-rep a) (operands-rep b) size )
465 | 
466 |       )
467 |     )]
468 |     ))
469 | 
470 | 
471 | (define (add a b)
472 |   (if (or (number? a) (list? a))
473 |     (begin 
474 |       (asm "mov ~a,~a" reg0 (operands-rep a))
475 |       (asm "add ~a,~a" reg0 (operands-rep b))
476 |     )
477 |     (asm "add ~a,~a" (operands-rep a) (operands-rep b))
478 |   )
479 |   )
480 | 
481 | (define (sub a b)
482 |   (if (or (number? a) (list? a))
483 |     (begin 
484 |       (asm "mov ~a,~a" reg0 (operands-rep a))
485 |       (asm "sub ~a,~a" reg0 (operands-rep b))
486 |     )
487 |     (asm "sub ~a,~a" (operands-rep a) (operands-rep b))
488 |   )
489 |   
490 |   )
491 | 
492 | (define (mul a b)
493 |   (asm "xor edx,edx")
494 |   (asm "mov ~a,~a" reg0 (operands-rep a))
495 |   (asm "mov ~a,~a" reg2 (operands-rep b))
496 |   (asm "mul ~a"  reg2)
497 |   (sar reg0 type-shift)
498 |   )
499 | 
500 | (define (div a b)
501 |   (asm "xor edx,edx")
502 |   (asm "mov ~a,~a" reg0 (operands-rep a))
503 |   (asm "mov ~a,~a" reg2 (operands-rep b))
504 |   (asm "div ~a" reg2) ;;余数 edx=>reg3 商eax=>reg0
505 |   (sal reg0 type-shift)
506 |   ;;(sal reg3 type-shift)
507 |   )
508 | 
509 | (define (proc l args)
510 |   (note "\n")
511 |   (note "proc ~a" l)
512 |   (label l)
513 |   (asm "push ebp")
514 |   ; (asm "push esp")
515 |   (asm "mov	ebp, esp")
516 |   (asm "add ebp, 8")
517 |   (saves)
518 | )
519 | 
520 | (define (pret)
521 |   (restores)
522 |   ; (asm "pop esp")
523 |   (asm "pop ebp")
524 |   
525 |   (asm "ret"))
526 | 
527 | 
528 | (define (lproc l args)
529 |   (note "\n")
530 |   (note "lproc ~a" l)
531 |   (label l)
532 |   (asm "push ebp")
533 |   ; (asm "push esp")
534 |   (asm "mov	ebp, esp")
535 |   (asm "add ebp, 8")
536 | )
537 | 
538 | (define (lret)
539 |   (asm "pop ebp")
540 |   (asm "ret"))
541 | 
542 | (define (ret)
543 |   (asm "ret"))
544 | 
545 | (define (label l)
546 |   (asm "~a:" (symbol->asm-id  l ))
547 |   )
548 | 
549 | (define (shift op a b)
550 |   (cond
551 |     [(number? b)
552 |       (asm "~a ~a,~a" op (operands-rep a) (operands-rep b) )
553 |     ]
554 |     [else
555 |       (asm "mov ecx,~a" (operands-rep b))
556 |       (asm "~a ~a,cl" op (operands-rep a))
557 |     ]
558 |       ))
559 | 
560 | (define (sar a b)
561 |   (shift 'sar a b))
562 | 
563 | (define (sal a b)
564 |   (shift 'sal a b))
565 | 
566 | (define (shl a b)
567 |   (shift 'shl a b))
568 | 
569 | (define (shr a b)
570 |   (shift 'shr a b))
571 | 
572 | (define (land a b)
573 |   (asm "and ~a,~a" (operands-rep a) (operands-rep b) ))
574 | 
575 | (define (lor a b)
576 |   (asm "or ~a,~a" (operands-rep a) (operands-rep b)))
577 | 
578 | (define (xor a b)
579 |   (asm "xor ~a,~a" (operands-rep a) (operands-rep b)))
580 | 
581 | (define (save a)
582 |   (asm "push ~a" (operands-rep a)))
583 | 
584 | (define (restore a)
585 |   (asm "pop ~a" (operands-rep a)))
586 | 
587 | (define (nop)
588 |   (asm "nop"))
589 | 
590 | 
591 | ;;instruct start here
592 | 
593 | (define (saves)
594 |   (asm "pushfd")
595 |   (save reg1)
596 |   (save reg2)
597 |   (save reg3)
598 |   (save reg4)
599 |   (save reg5)
600 |  
601 | )
602 | 
603 | (define (restores)
604 |   (restore reg5)
605 |   (restore reg4)
606 |   (restore reg3)
607 |   (restore reg2)
608 |   (restore reg1)
609 |   (asm "popfd")
610 | )
611 | 
612 | 
613 | )


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


--------------------------------------------------------------------------------
/common/match.ss:
--------------------------------------------------------------------------------
  1 | ;;; match.ss
  2 | 
  3 | ;;; This program was originally designed and implemented by Dan
  4 | ;;; Friedman.  It was redesigned and implemented by Erik Hilsdale;
  5 | ;;; some improvements were suggested by Steve Ganz.  Additional
  6 | ;;; modifications were made by Kent Dybvig.
  7 | 
  8 | ;; [3 February 2008]
  9 | ;; rkd modified overloaded quasiquote to handle expressions followed
 10 | ;; by more than one ellipsis.
 11 | 
 12 | ;; [3 February 2008]
 13 | ;; aziz modified mapper to quote the inserted empty lists
 14 | 
 15 | ;; [3 March 2007]
 16 | ;; aziz minor change to eagerly catch malformed clauses (e.g. a clause
 17 | ;; that's not a list of 2 or more subforms).
 18 | 
 19 | ;; [13 March 2002]
 20 | ;; rkd added following change by Friedman and Ganz to the main source
 21 | ;; code thread and fixed a couple of minor problems.
 22 | 
 23 | ;; [9 March 2002]
 24 | ;; Dan Friedman and Steve Ganz added the ability to use identical pattern
 25 | ;; variables.  The patterns represented by the variables are compared
 26 | ;; using the value of the parameter match-equality-test, which defaults
 27 | ;; to equal?.
 28 | ;;
 29 | ;; > (match '(1 2 1 2 1)
 30 | ;;     [(,a ,b ,a ,b ,a) (guard (number? a) (number? b)) (+ a b)])
 31 | ;; 3
 32 | ;; ;;
 33 | ;; > (match '((1 2 3) 5 (1 2 3))
 34 | ;;     [((,a ...) ,b (,a ...)) `(,a ... ,b)])
 35 | ;; (1 2 3 5)
 36 | ;; ;;
 37 | ;; > (parameterize ([match-equality-test (lambda (x y) (equal? x (reverse y)))])
 38 | ;;     (match '((1 2 3) (3 2 1))   
 39 | ;;       [(,a ,a) 'yes]
 40 | ;;       [,oops 'no]))
 41 | ;; yes
 42 | 
 43 | ;; [10 Jan 2002]
 44 | ;; eh fixed bug that caused (match '((1 2 3 4)) (((,a ... ,d) . ,x) a)) to
 45 | ;; blow up.  The bug was caused by a bug in the sexp-dispatch procedure
 46 | ;; where a base value empty list was passed to an accumulator from inside
 47 | ;; the recursion, instead of passing the old value of the accumulator.
 48 | 
 49 | ;; [14 Jan 2001]
 50 | ;; rkd added syntax checks to unquote pattern parsing to weed out invalid
 51 | ;; patterns like ,#(a) and ,[(vector-ref d 1)].
 52 | 
 53 | ;; [14 Jan 2001]
 54 | ;; rkd added ,[Cata -> Id* ...] to allow specification of recursion
 55 | ;; function.  ,[Id* ...] recurs to match; ,[Cata -> Id* ...] recurs
 56 | ;; to Cata.
 57 | 
 58 | ;; [14 Jan 2001]
 59 | ;; rkd tightened up checks for ellipses and nested quasiquote; was comparing
 60 | ;; symbolic names, which, as had been noted in the source, is a possible
 61 | ;; hygiene bug.  Replaced error call in guard-body with syntax-error to
 62 | ;; allow error to include source line/character information.
 63 | 
 64 | ;; [13 Jan 2001]
 65 | ;; rkd fixed match patterns of the form (stuff* ,[x] ... stuff+), which
 66 | ;; had been recurring on subforms of each item rather than on the items
 67 | ;; themselves.
 68 | 
 69 | ;; Previous changelog listings at end of file.
 70 | 
 71 | ;;; ============================================================
 72 | 
 73 | ;; Exp    ::= (match              Exp Clause)
 74 | ;;         || (trace-match        Exp Clause)
 75 | ;;         || (match+       (Id*) Exp Clause*)
 76 | ;;         || (trace-match+ (Id*) Exp Clause*)
 77 | ;;         || OtherSchemeExp
 78 | 
 79 | ;; Clause ::= (Pat Exp+) || (Pat (guard Exp*) Exp+)
 80 | 
 81 | ;; Pat    ::= (Pat ... . Pat)
 82 | ;;         || (Pat . Pat)
 83 | ;;         || ()
 84 | ;;         || #(Pat* Pat ... Pat*)
 85 | ;;         || #(Pat*)
 86 | ;;         || ,Id
 87 | ;;         || ,[Id*]
 88 | ;;         || ,[Cata -> Id*]
 89 | ;;         || Id
 90 | 
 91 | ;; Cata   ::= Exp
 92 | 
 93 | ;; YOU'RE NOT ALLOWED TO REFER TO CATA VARS IN GUARDS. (reasonable!)
 94 | 
 95 | (library (common match) 
 96 |   (export 
 97 |     trace-match+
 98 |     trace-match
 99 |     match
100 |     match+ match-help match-help1 clause-body let-values**
101 |       guard-body convert-pat mapper my-backquote extend-backquote
102 |       sexp-dispatch)
103 | 
104 | (import (scheme))
105 | 
106 | (define match-equality-test
107 |   (make-parameter
108 |     equal?
109 |     (lambda (x)
110 |       (unless (procedure? x)
111 |         (errorf 'match-equality-test "~s is not a procedure" x))
112 |       x)))
113 | 
114 | (define-syntax match+
115 |   (lambda (x)
116 |     (syntax-case x ()
117 |       [(k (ThreadedId ...) Exp Clause ...)
118 |        #'(let f ((ThreadedId ThreadedId) ... (x Exp))
119 |            (match-help k f x (ThreadedId ...) Clause ...))])))
120 | 
121 | (define-syntax match
122 |   (lambda (x)
123 |     (syntax-case x ()
124 |       [(k Exp Clause ...)
125 |        #'(let f ((x Exp))
126 |            (match-help k f x () Clause ...))])))
127 | 
128 | (define-syntax trace-match+
129 |   (lambda (x)
130 |     (syntax-case x ()
131 |       [(k (ThreadedId ...) Name Exp Clause ...)
132 |        #'(letrec ((f (trace-lambda Name (ThreadedId ... x)
133 |                        (match-help k f x (ThreadedId ...) Clause ...))))
134 |            (f ThreadedId ... x))])))
135 | 
136 | (define-syntax trace-match
137 |   (lambda (x)
138 |     (syntax-case x ()
139 |       [(k Name Exp Clause ...)
140 |        #'(letrec ((f (trace-lambda Name (x)
141 |                        (match-help k f x () Clause ...))))
142 |            (f Exp))])))
143 | 
144 | ;;; ------------------------------
145 | 
146 | (define-syntax let-values**
147 |   (syntax-rules ()
148 |     ((_ () B0 B ...) (begin B0 B ...))
149 |     ((_ ((Formals Exp) Rest ...) B0 B ...)
150 |      (let-values** (Rest ...) 
151 |        (call-with-values (lambda () Exp)
152 |          (lambda Formals B0 B ...))))))
153 | 
154 | (define-syntax match-help
155 |   (lambda (x)
156 |     (syntax-case x ()
157 |       ((_ Template Cata Obj ThreadedIds)
158 |        ;; RRN: Adding source locations:
159 |        #'(begin 
160 | 	   ;(inspect #'Template)
161 | 	   (errorf 'match "Unmatched datum.\n  Datum: ~s\n  Source Location: ~s\n" Obj #'Template)))
162 |       ((_ Template Cata Obj ThreadedIds (Pat B0 B ...) Rest ...)
163 |        #'(convert-pat Pat
164 |            (match-help1 Template Cata Obj ThreadedIds 
165 |              (B0 B ...)
166 |              Rest ...)))
167 |       ((_ Template Cata Obj ThreadedIds cls Rest ...)
168 |        (syntax-error #'cls "invalid match clause")))))
169 |     
170 | 
171 | (define-syntax match-help1
172 |   (lambda (x)
173 |     (syntax-case x (guard)
174 |       [(_ PatLit Vars () Cdecls Template Cata Obj ThreadedIds
175 |          ((guard) B0 B ...) Rest ...)
176 |        #'(let ((ls/false (sexp-dispatch Obj PatLit)))
177 |            (if ls/false
178 |                (apply (lambda Vars
179 |                         (clause-body Cata Cdecls ThreadedIds
180 |                           (extend-backquote Template B0 B ...)))
181 |                  ls/false)
182 |                (match-help Template Cata Obj ThreadedIds Rest ...)))]
183 |       [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
184 |          ((guard G ...) B0 B ...) Rest ...)
185 |        #'(let ((ls/false (sexp-dispatch Obj PatLit)))
186 |            (if (and ls/false (apply (lambda Vars
187 |                                       (guard-body Cdecls
188 |                                         (extend-backquote Template
189 |                                           (and PG ... G ...))))
190 |                                ls/false))
191 |                (apply (lambda Vars
192 |                         (clause-body Cata Cdecls ThreadedIds
193 |                           (extend-backquote Template B0 B ...)))
194 |                  ls/false)
195 |                (match-help Template Cata Obj ThreadedIds Rest ...)))]
196 |       [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
197 |          (B0 B ...) Rest ...)
198 |        #'(match-help1 PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
199 |            ((guard) B0 B ...) Rest ...)])))
200 | 
201 | (define-syntax clause-body
202 |   (lambda (x)
203 |     (define build-mapper
204 |       (lambda (vars depth cata tIds)
205 |         (if (zero? depth)
206 |             cata
207 |             (with-syntax ((rest (build-mapper vars (- depth 1) cata tIds))
208 |                           (vars vars)
209 |                           (tIds tIds))
210 |               #'(mapper rest vars tIds)))))
211 |     (syntax-case x ()
212 |       ((_ Cata ((CVar CDepth CMyCata CFormal ...) ...) (ThreadedId ...) B)
213 |        (with-syntax (((Mapper ...)
214 |                       (map (lambda (mycata formals depth)
215 |                              (build-mapper formals
216 |                                (syntax->datum depth)
217 |                                (syntax-case mycata ()
218 |                                  [#f #'Cata]
219 |                                  [exp #'exp])
220 |                                #'(ThreadedId ...)))
221 |                         #'(CMyCata ...)
222 |                         #'((CFormal ...) ...)
223 |                         #'(CDepth ...))))
224 |          #'(let-values** (([ThreadedId ... CFormal ...]
225 |                            (Mapper ThreadedId ... CVar))
226 |                           ...)
227 |              B))))))
228 | 
229 | (define-syntax guard-body
230 |   (lambda (x)
231 |     (syntax-case x ()
232 |       ((_ ((Cvar Cdepth MyCata Cformal ...) ...) B)
233 |        (with-syntax (((CF ...) (apply append #'((Cformal ...) ...))))
234 |          #'(let-syntax
235 |                ((CF
236 |                   (lambda (x)
237 |                     (syntax-case x ()
238 |                       (Name
239 |                         (syntax-error #'Name
240 |                           "guard cannot refer to return-value variable")))))
241 |                 ...)
242 |              B))))))
243 | 
244 | (define-syntax convert-pat
245 |   ;; returns sexp-pat x vars x guards x cdecls
246 |   (let ()
247 |     (define ellipsis?
248 |       (lambda (x)
249 |         (and (identifier? x) (free-identifier=? x #'(... ...)))))
250 |     (define Var?
251 |       (lambda (x)
252 |         (syntax-case x (->)
253 |           [-> #f]
254 |           [id (identifier? #'id)])))
255 |     (define fVar
256 |       (lambda (var vars guards)
257 |         (let loop ([ls vars])
258 |           (if (null? ls)
259 |               (values (cons var vars) guards)
260 |               (if (bound-identifier=? var (car ls))
261 |                   (with-syntax ([(tmp) (generate-temporaries (list var))]
262 |                                 [var (car ls)])
263 |                     (values (cons #'tmp vars)
264 |                             (cons #'((match-equality-test) tmp var) guards)))
265 |                   (loop (cdr ls)))))))
266 |     (define (f syn vars guards cdecls depth)
267 |       (syntax-case syn (unquote)
268 |         ((unquote . stuff) ; separate for better error detection
269 |          (syntax-case syn (unquote ->)
270 |            ((unquote [MyCata -> Var ...])
271 |             (andmap Var? #'(Var ...))
272 |             (with-syntax (((Temp) (generate-temporaries '(x)))
273 |                           (Depth depth))
274 |               (values #'any
275 |                       (cons #'Temp vars)
276 |                       guards
277 |                       (cons #'[Temp Depth MyCata Var ...] cdecls))))
278 |            ((unquote [Var ...])
279 |             (andmap Var? #'(Var ...))
280 |             (with-syntax (((Temp) (generate-temporaries '(x)))
281 |                           (Depth depth))
282 |               (values #'any
283 |                       (cons #'Temp vars)
284 |                       guards
285 |                       (cons #'[Temp Depth #f Var ...] cdecls))))
286 |            ((unquote Var)
287 |             (Var? #'Var)
288 |             (let-synvalues* ([(vars guards) (fVar #'Var vars guards)])
289 |               (values #'any #'vars #'guards cdecls)))))
290 |         (((unquote . stuff) Dots)
291 |          (ellipsis? #'Dots)
292 |          (syntax-case syn (unquote ->)
293 |            (((unquote [MyCata -> Var ...]) Dots)
294 |             (andmap Var? #'(Var ...))
295 |             (with-syntax (((Temp) (generate-temporaries '(x)))
296 |                           (Depth+1 (add1 depth)))
297 |               (values #'each-any
298 |                       (cons #'Temp vars)
299 |                       guards
300 |                       (cons #'[Temp Depth+1 MyCata Var ...] cdecls))))
301 |            (((unquote [Var ...]) Dots)
302 |             (andmap Var? #'(Var ...))
303 |             (with-syntax (((Temp) (generate-temporaries '(x)))
304 |                           (Depth+1 (add1 depth)))
305 |               (values #'each-any
306 |                       (cons #'Temp vars)
307 |                       guards
308 |                       (cons #'[Temp Depth+1 #f Var ...] cdecls))))
309 |            (((unquote Var) Dots)
310 |             (Var? #'Var)
311 |             (let-synvalues* ([(vars guards) (fVar #'Var vars guards)])
312 |               (values #'each-any #'vars #'guards cdecls)))
313 |            ((expr Dots) (syntax-error #'expr "match-pattern unquote syntax"))))
314 |         ((Pat Dots)
315 |          (ellipsis? #'Dots)
316 |          (let-synvalues* (((Dpat Dvars Dguards Dcdecls)
317 |                            (f #'Pat vars guards cdecls (add1 depth))))
318 |            (with-syntax ((Size (- (length #'Dvars) (length vars))))
319 |              (values #'#(each Dpat Size) #'Dvars #'Dguards #'Dcdecls))))
320 |         ((Pat Dots . Rest)
321 |          (ellipsis? #'Dots)
322 |          (let-synvalues* (((Rpat Rvars Rguards Rcdecls)
323 |                            (f #'Rest vars guards cdecls depth))
324 |                           ((Dpat Dvars Dguards Dcdecls)
325 |                            (f #'(Pat (... ...)) #'Rvars #'Rguards #'Rcdecls
326 |                              depth)))
327 |            (with-syntax ((Size (- (length #'Dvars) (length #'Rvars)))
328 |                          ((RevRestTl . RevRest) (reverseX #'Rpat '())))
329 |              (values #'#(tail-each Dpat Size RevRest RevRestTl)
330 |                      #'Dvars #'Dguards #'Dcdecls))))
331 |         ((X . Y)
332 |          (let-synvalues* (((Ypat Yvars Yguards Ycdecls)
333 |                            (f #'Y vars guards cdecls depth))
334 |                           ((Xpat Xvars Xguards Xcdecls)
335 |                            (f #'X #'Yvars #'Yguards #'Ycdecls depth)))
336 |            (values #'(Xpat . Ypat) #'Xvars #'Xguards #'Xcdecls)))
337 |         (() (values #'() vars guards cdecls))
338 |         (#(X ...)
339 |          (let-synvalues* (((Pat Vars Eqvars Cdecls)
340 |                            (f #'(X ...) vars guards cdecls depth)))
341 |            (values #'#(vector Pat) #'Vars #'Eqvars #'Cdecls)))
342 |         (Thing (values #'#(atom Thing) vars guards cdecls))))
343 |     (define reverseX
344 |       (lambda (ls acc)
345 |         (if (pair? ls)
346 |             (reverseX (cdr ls) (cons (car ls) acc))
347 |             (cons ls acc))))
348 |     (define-syntax let-synvalues*
349 |       (syntax-rules ()
350 |         ((_ () B0 B ...) (begin B0 B ...))
351 |         ((_ (((Formal ...) Exp) Decl ...) B0 B ...)
352 |          (call-with-values (lambda () Exp)
353 |            (lambda (Formal ...)
354 |              (with-syntax ((Formal Formal) ...)
355 |                (let-synvalues* (Decl ...) B0 B ...)))))))
356 |     (lambda (syn) 
357 |       (syntax-case syn ()
358 |         ((_ syn (kh . kt))
359 |          (let-synvalues* (((Pat Vars Guards Cdecls) (f #'syn '() '() '() 0)))
360 |            #'(kh 'Pat Vars Guards Cdecls . kt)))))))
361 | 
362 | (define-syntax mapper
363 |   (lambda (x)
364 |     (syntax-case x ()
365 |       ((_ F (RetId ...) (ThreadId ...))
366 |        (with-syntax (((t ...) (generate-temporaries #'(RetId ...)))
367 |                      ((ts ...) (generate-temporaries #'(RetId ...)))
368 |                      ((null ...) (map (lambda (x) #''()) #'(RetId ...))))
369 |          #'(let ((fun F))
370 |              (rec g
371 |                (lambda (ThreadId ... ls)
372 |                  (if (null? ls)
373 |                      (values ThreadId ... null ...)
374 |                      (call-with-values
375 |                          (lambda () (g ThreadId ... (cdr ls)))
376 |                        (lambda (ThreadId ... ts ...)
377 |                          (call-with-values
378 |                              (lambda () (fun ThreadId ... (car ls)))
379 |                            (lambda (ThreadId ... t ...)
380 |                              (values ThreadId ... (cons t ts) ...))))))))))))))
381 | 
382 | ;;; ------------------------------
383 | 
384 | (define-syntax my-backquote
385 |   (lambda (x)
386 |     (define ellipsis?
387 |       (lambda (x)
388 |         (and (identifier? x) (free-identifier=? x #'(... ...)))))
389 |     (define-syntax with-values
390 |       (syntax-rules ()
391 |         ((_ P C) (call-with-values (lambda () P) C))))
392 |     (define-syntax syntax-lambda
393 |       (lambda (x)
394 |         (syntax-case x ()
395 |           ((_ (Pat ...) Body0 Body ...)
396 |            (with-syntax (((X ...) (generate-temporaries #'(Pat ...))))
397 |              #'(lambda (X ...)
398 |                  (with-syntax ((Pat X) ...)
399 |                    Body0 Body ...)))))))
400 |     (define-syntax with-temp
401 |       (syntax-rules ()
402 |         ((_ V Body0 Body ...)
403 |          (with-syntax (((V) (generate-temporaries '(x))))
404 |            Body0 Body ...))))
405 |     (define-syntax with-temps
406 |       (syntax-rules ()
407 |         ((_ (V ...) (Exp ...) Body0 Body ...)
408 |          (with-syntax (((V ...) (generate-temporaries #'(Exp ...))))
409 |            Body0 Body ...))))
410 |     (define destruct
411 |       (lambda (Orig x depth)
412 |         (syntax-case x (quasiquote unquote unquote-splicing)
413 |           ;; inner quasiquote
414 |           ((Exp dots1 dots2 . Rest)
415 |            (and (zero? depth) (ellipsis? #'dots1) (ellipsis? #'dots2))
416 |            (let f ([Exp #'(... ((Exp ...) ...))] [Rest #'Rest] [ndots 2])
417 |              (syntax-case Rest ()
418 |                [(dots . Rest)
419 |                 (ellipsis? #'dots)
420 |                 (with-syntax ([Exp Exp])
421 |                   (f #'(... (Exp ...)) #'Rest (+ ndots 1)))]
422 |                [Rest
423 |                 (with-values (destruct Orig Exp depth)
424 |                   (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
425 |                     (if (null? #'(ExpVar ...))
426 |                         (syntax-error Orig "Bad ellipsis")
427 |                         (with-values (destruct Orig #'Rest depth)
428 |                           (syntax-lambda (RestBuilder RestVars RestExps)
429 |                             (values
430 |                               #`(append
431 |                                   #,(let f ([ndots ndots])
432 |                                       (if (= ndots 1)
433 |                                           #'ExpBuilder
434 |                                           #`(apply append #,(f (- ndots 1)))))
435 |                                   RestBuilder)
436 |                               (append #'(ExpVar ...) #'RestVars)
437 |                               (append #'(ExpExp ...) #'RestExps)))))))])))
438 |           ((quasiquote Exp)
439 |            (with-values (destruct Orig #'Exp (add1 depth))
440 |              (syntax-lambda (Builder Vars Exps)
441 |                (if (null? #'Vars)
442 |                    (values #''(quasiquote Exp) '() '())
443 |                    (values #'(list 'quasiquote Builder) #'Vars #'Exps)))))
444 |           ;; unquote
445 |           ((unquote Exp)
446 |            (zero? depth)
447 |            (with-temp X
448 |              (values #'X (list #'X) (list #'Exp))))
449 |           ((unquote Exp)
450 |            (with-values (destruct Orig #'Exp (sub1 depth))
451 |              (syntax-lambda (Builder Vars Exps)
452 |                (if (null? #'Vars)
453 |                    (values #''(unquote Exp) '() '())
454 |                    (values #'(list 'unquote Builder) #'Vars #'Exps)))))
455 |           ;; splicing
456 |           (((unquote-splicing Exp))
457 |            (zero? depth)
458 |            (with-temp X
459 |              (values #'X (list #'X) (list #'Exp))))
460 |           (((unquote-splicing Exp ...))
461 |            (zero? depth)
462 |            (with-temps (X ...) (Exp ...)
463 |              (values #'(append X ...) #'(X ...) #'(Exp ...))))
464 |           (((unquote-splicing Exp ...) . Rest)
465 |            (zero? depth)
466 |            (with-values (destruct Orig #'Rest depth)
467 |              (syntax-lambda (Builder Vars Exps)
468 |                (with-temps (X ...) (Exp ...)
469 |                  (if (null? #'Vars)
470 |                      (values #'(append X ... 'Rest)
471 |                              #'(X ...) #'(Exp ...))
472 |                      (values #'(append X ... Builder)
473 |                              #'(X ... . Vars) #'(Exp ... . Exps)))))))
474 |           ((unquote-splicing Exp ...)
475 |            (with-values (destruct Orig #'(Exp ...) (sub1 depth))
476 |              (syntax-lambda (Builder Vars Exps)
477 |                (if (null? #'Vars)
478 |                    (values #''(unquote-splicing Exp ...) '() '())
479 |                    (values #'(cons 'unquote-splicing Builder)
480 |                            #'Vars #'Exps)))))
481 |           ;; dots
482 |           (((unquote Exp) Dots)
483 |            (and (zero? depth) (ellipsis? #'Dots))
484 |            (with-temp X
485 |              (values #'X (list #'X) (list #'Exp))))
486 |           (((unquote Exp) Dots . Rest)
487 |            (and (zero? depth) (ellipsis? #'Dots))
488 |            (with-values (destruct Orig #'Rest depth)
489 |              (syntax-lambda (RestBuilder RestVars RestExps)
490 |                (with-syntax ((TailExp
491 |                                (if (null? #'RestVars)
492 |                                    #''Rest
493 |                                    #'RestBuilder)))
494 |                  (with-temp X
495 |                    (values #'(append X TailExp)
496 |                            (cons #'X #'RestVars)
497 |                            (cons #'Exp #'RestExps)))))))
498 |           ((Exp Dots . Rest)
499 |            (and (zero? depth) (ellipsis? #'Dots))
500 |            (with-values (destruct Orig #'Exp depth)
501 |              (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
502 |                (if (null? #'(ExpVar ...))
503 |                    (syntax-error Orig "Bad ellipsis")
504 |                    (with-values (destruct Orig #'Rest depth)
505 |                      (syntax-lambda (RestBuilder RestVars RestExps)
506 |                        (with-syntax ((TailExp
507 |                                        (if (null? #'RestVars)
508 |                                            #''Rest
509 |                                            #'RestBuilder))
510 |                                      (Orig Orig))
511 |                          (values #'(let f ((ExpVar ExpVar) ...)
512 |                                      (if (and (pair? ExpVar) ...)
513 |                                          (cons
514 |                                            (let ((ExpVar (car ExpVar)) ...)
515 |                                              ExpBuilder)
516 |                                            (f (cdr ExpVar) ...))
517 |                                          (if (and (null? ExpVar) ...)
518 |                                              TailExp
519 |                                              (errorf 'unquote
520 |                                                "Mismatched lists in ~a"
521 |                                                Orig))))
522 |                                  (append #'(ExpVar ...) #'RestVars)
523 |                                  (append #'(ExpExp ...) #'RestExps)))))))))
524 |           ;; Vectors
525 |           (#(X ...)
526 |            (with-values (destruct Orig #'(X ...) depth)
527 |              (syntax-lambda (LsBuilder LsVars LsExps)
528 |                (values #'(list->vector LsBuilder) #'LsVars #'LsExps))))
529 |           ;; random stuff
530 |           ((Hd . Tl)
531 |            (with-values (destruct Orig #'Hd depth)
532 |              (syntax-lambda (HdBuilder HdVars HdExps)
533 |                (with-values (destruct Orig #'Tl depth)
534 |                  (syntax-lambda (TlBuilder TlVars TlExps)
535 |                    (with-syntax ((Hd (if (null? #'HdVars)
536 |                                          #''Hd
537 |                                          #'HdBuilder))
538 |                                  (Tl (if (null? #'TlVars)
539 |                                          #''Tl
540 |                                          #'TlBuilder)))
541 |                      (values #'(cons Hd Tl)
542 |                              (append #'HdVars #'TlVars)
543 |                              (append #'HdExps #'TlExps))))))))
544 |           (OtherThing
545 |             (values #''OtherThing '() '())))))
546 |     ;; macro begins
547 |     (syntax-case x ()
548 |       ((_ Datum)
549 |        (with-values (destruct #'(quasiquote Datum) #'Datum 0)
550 |          (syntax-lambda (Builder (Var ...) (Exp ...))
551 |            (if (null? #'(Var ...))
552 |                #''Datum
553 |                #'(let ((Var Exp) ...)
554 |                    Builder))))))))
555 | 
556 | (define-syntax extend-backquote
557 |   (lambda (x)
558 |     (syntax-case x ()
559 |       [(_ Template Exp ...)
560 |        (with-syntax ([quasiquote (datum->syntax #'Template 'quasiquote)])
561 |          #'(let-syntax ([quasiquote
562 |                           (lambda (x)
563 |                             (syntax-case x ()
564 |                               ((_ Foo) #'(my-backquote Foo))))])
565 | 	     ;; RRN: Adding a new scope here for internal defines:
566 | 	     (let () Exp ...)))])))
567 | 
568 | ;;; ------------------------------
569 | 
570 | (define-syntax with-values
571 |   (syntax-rules ()
572 |     ((_ P C) (call-with-values (lambda () P) C))))
573 | 
574 | (define-syntax letcc
575 |   (syntax-rules ()
576 |     ;; RRN: changing this to a one-shot continuation:
577 |     ((_ V B0 B ...) (call/1cc (lambda (V) B0 B ...)))))
578 | 
579 | (define classify-list
580 |   (lambda (ls)
581 |     (cond
582 |       ((null? ls) 'proper)
583 |       ((not (pair? ls)) 'improper)
584 |       (else
585 |         (let f ((tortoise ls) (hare (cdr ls)))
586 |           (cond
587 |             ((eq? tortoise hare) 'infinite)
588 |             ((null? hare) 'proper)
589 |             ((not (pair? hare)) 'improper)
590 |             (else
591 |               (let ((hare (cdr hare)))
592 |                 (cond
593 |                   ((null? hare) 'proper)
594 |                   ((not (pair? hare)) 'improper)
595 |                   (else (f (cdr ls) (cdr hare))))))))))))
596 | 
597 | (define ilist-copy-flat
598 |   (lambda (ils)
599 |     (let f ((tortoise ils) (hare (cdr ils)))
600 |       (if (eq? tortoise hare)
601 |           (list (car tortoise))
602 |           (cons (car tortoise) (f (cdr tortoise) (cddr hare)))))))
603 | 
604 | (define sexp-dispatch
605 |   (lambda (obj pat);; #f or list of vars
606 |     (letcc escape
607 |       (let ((fail (lambda () (escape #f))))
608 |         (let f ((pat pat) (obj obj) (vals '()))
609 |           (cond
610 |             ((eq? pat 'any)
611 |              (cons obj vals))
612 |             ((eq? pat 'each-any)
613 |              ;; handle infinities
614 |              (case (classify-list obj)
615 |                ((proper infinite) (cons obj vals))
616 |                ((improper) (fail))))
617 |             ((pair? pat)
618 |              (if (pair? obj)
619 |                  (f (car pat) (car obj) (f (cdr pat) (cdr obj) vals))
620 |                  (fail)))
621 |             ((vector? pat)
622 |              (case (vector-ref pat 0)
623 |                ((atom)
624 |                 (let ((a (vector-ref pat 1)))
625 |                   (if (eqv? obj a)
626 |                       vals
627 |                       (fail))))
628 |                ((vector)
629 |                 (if (vector? obj)
630 |                     (let ((vec-pat (vector-ref pat 1)))
631 |                       (f vec-pat (vector->list obj) vals))
632 |                     (fail)))
633 |                ((each)
634 |                 ;; if infinite, copy the list as flat, then do the matching,
635 |                 ;; then do some set-cdrs. 
636 |                 (let ((each-pat (vector-ref pat 1))
637 |                       (each-size (vector-ref pat 2)))
638 |                   (case (classify-list obj)
639 |                     ((improper) (fail))
640 |                     ((infinite)
641 |                      (let ((each-vals (f pat (ilist-copy-flat obj) '())))
642 |                        (for-each (lambda (x) (set-cdr! (last-pair x) x))
643 |                          each-vals)
644 |                        (append each-vals vals)))
645 |                     ((proper)
646 |                      (append
647 |                        (let g ((obj obj))
648 |                          (if (null? obj)
649 |                              (make-list each-size '())
650 |                              (let ((hd-vals (f each-pat (car obj) '()))
651 |                                    (tl-vals (g (cdr obj))))
652 |                                (map cons hd-vals tl-vals))))
653 |                        vals)))))
654 |                ((tail-each)
655 |                 (let ((each-pat (vector-ref pat 1))
656 |                       (each-size (vector-ref pat 2))
657 |                       (revtail-pat (vector-ref pat 3))
658 |                       (revtail-tail-pat (vector-ref pat 4)))
659 |                   (when (eq? (classify-list obj) 'infinite) (fail))
660 |                   (with-values
661 |                       (let g ((obj obj))
662 |                         ;; in-tail?, vals, revtail-left/ls
663 |                         (cond
664 |                           ((pair? obj)
665 |                            (with-values (g (cdr obj))
666 |                              (lambda (in-tail? vals tail-left/ls)
667 |                                (if in-tail?
668 |                                    (if (null? tail-left/ls)
669 |                                        (values #f vals (list (car obj)))
670 |                                        (values #t (f (car tail-left/ls)
671 |                                                     (car obj)
672 |                                                     vals)
673 |                                                (cdr tail-left/ls)))
674 |                                    (values #f vals
675 |                                            (cons (car obj) tail-left/ls))))))
676 |                           (else
677 |                             (values #t
678 |                                     (f revtail-tail-pat obj vals)
679 |                                     revtail-pat))))
680 |                     (lambda (in-tail? vals tail-left/ls)
681 |                       (if in-tail?
682 |                           (if (null? tail-left/ls)
683 |                               (append (make-list each-size '())
684 |                                 vals)
685 |                               (fail))
686 |                           (f each-pat tail-left/ls vals))))))))
687 |             (else
688 |               (if (eqv? obj pat)
689 |                   vals
690 |                   (fail)))))))))
691 | )
692 | 
693 | ; #!eof
694 | 
695 | ;;; examples of passing along threaded information.
696 | 
697 | ;;; Try (collect-symbols '(if (x y 'a 'c zz) 'b 'c))
698 | ;;; Note that it commonizes the reference to c. 
699 | 
700 | ; (define-syntax with-values
701 | ;   (syntax-rules ()
702 | ;     ((_ P C) (call-with-values (lambda () P) C))))
703 | ; (define collect-symbols
704 | ;   (lambda (exp)
705 | ;     (with-values (collect-symbols-help exp)
706 | ;       (lambda (symbol-decls exp)
707 | ;         (match symbol-decls
708 | ;           (((,symbol-name . ,symbol-var) ...)
709 | ;            `(let ((,symbol-var (quote ,symbol-name)) ...) ,exp)))))))
710 | ; (define collect-symbols-help
711 | ;   (lambda (exp)
712 | ;     (let ((symbol-env '()))
713 | ;       (match+ (symbol-env) exp
714 | ;         (,x
715 | ;           (guard (symbol? x))
716 | ;           (values symbol-env x))
717 | ;         ((quote ,x)
718 | ;          (guard (symbol? x))
719 | ;          (let ((pair/false (assq x symbol-env)))
720 | ;            (if pair/false
721 | ;                (values symbol-env (cdr pair/false))
722 | ;                (let ((v (gensym)))
723 | ;                  (values (cons (cons x v) symbol-env)
724 | ;                          v)))))
725 | ;         ((quote ,x)
726 | ;          (values symbol-env `(quote ,x)))
727 | ;         ((if ,[t] ,[c] ,[a])
728 | ;          (values symbol-env `(if ,t ,c ,a)))
729 | ;         ((,[op] ,[arg] ...)
730 | ;          (values symbol-env `(,op ,arg ...)))))))
731 | 
732 | ; ;;; the grammar for this one is just if-exprs and everything else
733 | 
734 | ; (define collect-leaves
735 | ;   (lambda (exp acc)
736 | ;     (match+ (acc) exp
737 | ;       ((if ,[] ,[] ,[])
738 | ;        acc)
739 | ;       ((,[] ,[] ...)
740 | ;        acc)
741 | ;       (,x
742 | ;         (cons x acc)))))
743 | 
744 | ; ;; here's something that takes apart quoted stuff. 
745 | 
746 | ; (define destruct
747 | ;   (lambda (datum)
748 | ;     (match datum
749 | ;       (() `'())
750 | ;       ((,[X] . ,[Y])`(cons ,X ,Y))
751 | ;       (#(,[X] ...) `(vector ,X ...))
752 | ;       (,thing
753 | ;         (guard (symbol? thing))
754 | ;         `',thing)
755 | ;       (,thing
756 | ;         thing))))
757 | 
758 | ; ;; examples using explicit Catas
759 | 
760 | ; (define sumsquares
761 | ;   (lambda (ls)
762 | ;     (define square 
763 | ;       (lambda (x)
764 | ;         (* x x)))
765 | ;     (match ls 
766 | ;       [(,[a*] ...) (apply + a*)]
767 | ;       [,[square -> n] n])))
768 | 
769 | ; (define sumsquares
770 | ;   (lambda (ls)
771 | ;     (define square 
772 | ;       (lambda (x)
773 | ;         (* x x)))
774 | ;     (let ([acc 0])
775 | ;       (match+ (acc) ls 
776 | ;         [(,[] ...) acc]
777 | ;         [,[(lambda (acc x) (+ acc (square x))) ->] acc]))))
778 | 
779 | ; ;;; The following uses explicit Catas to parse programs in the
780 | ; ;;; simple language defined by the grammar below
781 | 
782 | ; ;;; <Prog> -> (program <Stmt>* <Expr>)
783 | ; ;;; <Stmt> -> (if <Expr> <Stmt> <Stmt>)
784 | ; ;;;         | (set! <var> <Expr>)
785 | ; ;;; <Expr> -> <var>
786 | ; ;;;         | <integer>
787 | ; ;;;         | (if <Expr> <Expr> <Expr>)
788 | ; ;;;         | (<Expr> <Expr*>)
789 | 
790 | ; (define parse
791 | ;   (lambda (x)
792 | ;     (define Prog
793 | ;       (lambda (x)
794 | ;         (match x
795 | ;           [(program ,[Stmt -> s*] ... ,[Expr -> e])
796 | ;            `(begin ,s* ... ,e)]
797 | ;           [,other (errorf 'parse "invalid program ~s" other)])))
798 | ;     (define Stmt
799 | ;       (lambda (x)
800 | ;         (match x
801 | ;           [(if ,[Expr -> e] ,[Stmt -> s1] ,[Stmt -> s2])
802 | ;            `(if ,e ,s1 ,s2)]
803 | ;           [(set! ,v ,[Expr -> e])
804 | ;            (guard (symbol? v))
805 | ;            `(set! ,v ,e)]
806 | ;           [,other (errorf 'parse "invalid statement ~s" other)])))
807 | ;     (define Expr
808 | ;       (lambda (x)
809 | ;         (match x
810 | ;           [,v (guard (symbol? v)) v]
811 | ;           [,n (guard (integer? n)) n]
812 | ;           [(if ,[e1] ,[e2] ,[e3])
813 | ;            `(if ,e1 ,e2 ,e3)]
814 | ;           [(,[rator] ,[rand*] ...) `(,rator ,rand* ...)]
815 | ;           [,other (errorf 'parse "invalid expression ~s" other)])))
816 | ;     (Prog x)))
817 | 
818 | ;;; (parse '(program (set! x 3) (+ x 4)))) => (begin (set! x 3) (+ x 4))
819 | 
820 | ;; CHANGELOG (most recent changes are logged at the top of this file)
821 | 
822 | ;; [29 Feb 2000]
823 | ;; Fixed a case sensitivity bug.
824 | 
825 | ;; [24 Feb 2000]
826 | ;; Matcher now handles vector patterns.  Quasiquote also handles
827 | ;; vector patterns, but does NOT do the csv6.2 optimization of
828 | ;; `#(a 1 ,(+ 3 4) x y) ==> (vector 'a 1 (+ 3 4) 'x 'y).
829 | ;; Also fixed bug in (P ... . P) matching code. 
830 | 
831 | ;; [23 Feb 2000]
832 | ;; KSM fixed bug in unquote-splicing inside quasiquote.
833 | 
834 | ;; [10 Feb 2000]
835 | ;; New forms match+ and trace-match+ thread arguments right-to-left.
836 | ;; The pattern (P ... . P) now works the way you might expect.
837 | ;; Infinite lists are now properly matched (and not matched).
838 | ;; Removed the @ pattern.
839 | ;; Internal: No longer converting into syntax-case. 
840 | 
841 | ;; [6 Feb 2000]
842 | ;; Added expansion-time error message for referring to cata variable
843 | ;; in a guard.
844 | 
845 | ;; [4 Feb 2000]
846 | ;; Fixed backquote so it can handle nested backquote (oops).
847 | ;; Double-backquoted elipses are neutralized just as double-backquoted
848 | ;; unquotes are.  So:
849 | ;;   `(a ,'(1 2 3) ... b)    =eval=> (a 1 2 3 b)
850 | ;;   ``(a ,'(1 2 3) ... b)   =eval=> `(a ,'(1 2 3) ... b)
851 | ;;   ``(a ,(,(1 2 3) ...) b) =eval=> `(a ,(1 2 3) b)
852 | ;; Added support for
853 | ;;   `((unquote-splicing x y z) b) =expand==> (append x y z (list 'b))
854 | 
855 | ;; [1 Feb 2000]
856 | ;; Fixed a bug involving forgetting to quote stuff in the revised backquote.
857 | ;; Recognized unquote-splicing and signalled errors in the appropriate places.
858 | ;; Added support for deep elipses in backquote.
859 | ;; Rewrote backquote so it does the rebuilding directly instead of
860 | ;; expanding into Chez's backquote. 
861 | 
862 | ;; [31 Jan 2000]
863 | ;; Kent Dybvig fixed template bug.
864 | 
865 | ;; [31 Jan 2000]
866 | ;; Added the trace-match form, and made guards contain
867 | ;; an explicit and expression:
868 | ;;    (guard E ...) ==> (guard (and E ...))
869 | 
870 | ;; [26 Jan 2000]
871 | ;; Inside the clauses of match expressions, the following
872 | ;; transformation is performed inside backquote expressions:
873 | ;;    ,v ...      ==> ,@v
874 | ;;    (,v ,w) ... ==> ,@(map list v w)
875 | ;;    etc.


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


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


--------------------------------------------------------------------------------
/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 | #<unspecified>
 25 | > (set-cdr! x (cons 2 '()))
 26 | #<unspecified>
 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 <stdio.h>
 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)))


--------------------------------------------------------------------------------
/duck/duck.ss:
--------------------------------------------------------------------------------
  1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2 | ;Copyright 2016-2080 evilbinary.
  3 | ;作者:evilbinary on 12/24/16.
  4 | ;邮箱:rootdebug@163.com
  5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6 | (library (duck duck)
  7 |   (export duck-compile
  8 |   duck-compile-exp
  9 |   ast-conversion
 10 |   )
 11 | 
 12 | (import (scheme)
 13 |         (common match)
 14 |         (duck egg)
 15 |         (common trace)
 16 |         (common common)
 17 |         (common logger)
 18 |         )
 19 | 
 20 | (define (print-exp exp)
 21 |   (pretty-print exp)
 22 |   exp)
 23 | 
 24 | (define (clear-gen-symbol exp)
 25 |   (clear-sym)
 26 |   exp
 27 | )  
 28 | 
 29 | (define (c-main) "
 30 |   int main(int argc, char** argv){
 31 |     return 0;
 32 |   }
 33 | ")
 34 | 
 35 | (define (macro-conversion exp)
 36 |   (define (read-file name)
 37 |     (let ((p (open-input-file name)))
 38 |         (let f ((x (read p)))
 39 |             (if (eof-object? x)
 40 |                 (begin
 41 |                 (close-input-port p)
 42 |                 '())
 43 |                 (cons x (f (read p)))))))
 44 |   (define (include file)
 45 |     (let ((code (read-file (format "~a" file))))
 46 |          `(begin ,@code ) 
 47 |       )
 48 |   )
 49 |   (define (mconv ex)
 50 |     (match ex
 51 |       [($include ,file)
 52 |         (log-debug "include file ~a" file)
 53 |         (include file)
 54 |       ]
 55 |       [(begin ,exps ... )
 56 |         `(begin ,@(map macro-conversion exps))
 57 |       ]
 58 |       [(,app ,e* ...)
 59 |         `(,app ,@(map mconv e*))
 60 |       ]
 61 |       [,e
 62 |       e
 63 |       ]
 64 |     )
 65 |   )
 66 |   (mconv exp)
 67 | )
 68 | 
 69 | 
 70 | (define (ast-conversion exp)
 71 | (log-debug "exp ~a" exp)
 72 | (match exp
 73 |   [(define (,v ,e* ...) ,e1)
 74 |     (ast-conversion `(define ,v (lambda (,@e*) ,e1)) )
 75 |   ]
 76 |   [(define ,v (lambda (,args ...) ,body ))
 77 |     (ast-conversion 
 78 |     `(let ((,v  (lambda (,args ...) ,body ) )) ,v )
 79 |         )
 80 |   ]
 81 |   [(define ,v)
 82 |     `(define ,v 0)
 83 |   ]
 84 |   [(define ,v ,e)
 85 |     (guard (or (string? e) (number? e)))
 86 |     `($data ,v ,e)
 87 |   ]
 88 |   [(define ,v ,e)
 89 |     (log-debug "define ~a ~a(" v e)
 90 |     ;;`(set! ,v ,(ast-conversion e) )
 91 |     (ast-conversion 
 92 |     `(let ((,v ,e )) ,v )
 93 |         )
 94 |     ]
 95 |   ; [(begin ,e1 ,e2) 
 96 |   ;   `(let ((,e1))
 97 |   ;       ,(ast-conversion e2))
 98 |   ; ]
 99 |   ; [(begin ,e1 ())
100 |   ;   `(begin ,e1)
101 |   ; ]
102 |   [(begin . ,e1 )
103 |     (log-debug "begin ~a len=~a(" e1 (length e1))
104 |     (if (null? e1)
105 |     '()
106 |     (if (> (length  e1) 1 )
107 |       `(let ([,(gen-sym 'var) ,(ast-conversion (car e1) ) ] )
108 |             ,(ast-conversion `(begin ,@(cdr e1) ) )
109 |         )
110 |         (ast-conversion (car e1))
111 |         ))
112 |   ]
113 |   [(let ((,e1 ,e2) ,e* ...) ,e3* ...)
114 |     (log-debug "let->~a , ~a(" e1 e3* )
115 |     (if (null? e*)
116 |       (if (null? e3*)
117 |         `(let ((,e1 ,(ast-conversion e2) )) (void) ) ;;syntax erro
118 |         `(let ((,e1 ,(ast-conversion e2) )) ,(ast-conversion `(begin ,@e3* ) ) )
119 |         )
120 |       `(let ((,e1 ,(ast-conversion e2) ))
121 |         ,(ast-conversion `(let ,e* ,@(ast-conversion e3* )  ) ) )
122 |       )
123 |   ]
124 |   [(let () ,e1 ...)
125 |     (ast-conversion `(begin ,@e1) )
126 |   ]
127 |   [(let ,e1 () )
128 |     `(let ,e1 )
129 |   ]
130 |   [(let ,e ([,e1* ,e2*] ...) ,e3* ...)
131 |     (log-debug ">>>>>>>>>>>>>>>>let ===~a ~a(" e1* e2*)
132 |     (ast-conversion `(let ((,e (lambda ,e1*  ,@e3* ) ))
133 |         (,e ,@e2*)
134 |       ))
135 |   ]
136 |   [(lambda (,e1 ...) ,e2 ...)
137 |     (log-debug "lambda====>~a(" e2)
138 |     `(lambda ,e1 ,(ast-conversion `(begin ,@e2 ) ) )
139 |   ]
140 |   [(if ,e1 ,e2 ,e3)
141 |     (log-debug "if====>(")
142 |     `(if ,(ast-conversion e1) ,(ast-conversion e2) ,(ast-conversion e3))
143 |   ]
144 |   [(if ,e1 ,e2)
145 |     (log-debug "if1====>(")
146 |     `(if ,(ast-conversion e1) ,(ast-conversion e2) (void) )
147 |   ]
148 |   [(if ,e1 )
149 |     (log-debug "if2====>(")
150 |     `(if ,(ast-conversion e1) (void) (void) )
151 |   ]
152 |   ; [((,e)) `(,e)]
153 |   [(()) '()]
154 |   [(quote ,e)
155 |     (log-debug "quote ~a(" exp)
156 |     (cond
157 |       [(pair? e) `(cons ,(ast-conversion `(quote  ,(car e))) ,(ast-conversion `(quote ,(cdr e))) ) ]
158 |       [else `(quote ,e) ]
159 |     )
160 |   ]
161 |   [(,app ,arg)
162 |     (log-debug "app ~a(" exp)
163 |     `(,app ,(ast-conversion arg))
164 |   ]
165 |   [(,binop ,e1 ,e2 ...)
166 |     (guard (memq binop '(+ - * /) ))
167 |     (log-debug "prim ~a ee=>~a(" binop e2)
168 |     (if (> (length e2) 1)
169 |     `(,binop ,(ast-conversion e1) ,(ast-conversion `(,binop ,@e2 )) )
170 |     `(,binop ,(ast-conversion e1) ,(ast-conversion (car e2) ) )
171 |       )
172 |   ]
173 |   [(,app ,e1 ...)
174 |     `(,app ,@(map ast-conversion e1))
175 |   ]
176 |   [,exp 
177 |     (log-debug "other exp->~a(" exp)
178 |     exp
179 |   ]
180 |   )
181 | )
182 | 
183 | (define (alpha-conversion exp)
184 |     (define (alpha-conv exp env)
185 |       (match exp
186 |       [(define ,v ,e)
187 |         `(set! ,v ,e)
188 |         ]
189 |       [,exp exp]
190 |       )
191 |     )
192 |     (alpha-conv exp '())
193 |   )
194 | 
195 | (define (closure-conversion exp)
196 |   exp
197 | )
198 | 
199 | (define (cps-conversion exp)
200 |   exp
201 | )
202 | 
203 | (define (type? v)
204 |   (or (number? v)
205 |       (symbol? v)
206 |       (boolean? v)
207 |       ; (string? v)
208 |       (null? v)
209 |       (void? v)
210 |       ; (equal? 'quote (car v))
211 |       )
212 | )
213 | 
214 | (define (anf-term exp) (anf exp id))
215 | 
216 | (define (anf-name exp k)
217 |   (log-debug "=======>anf-name ~a type=>(" exp )
218 |   (anf exp (lambda (n)
219 |     (if (type? n)
220 |       (begin 
221 |         ; (log-debug "=======>anf-name type->ret=~a  ~a(" (k n)   n)
222 |         (k n)
223 |       )
224 |       (let ([t (gen-sym 'var)])
225 |         (log-debug "=======>gen->~a(" t)
226 |         `(let ([,t ,n]) ,(k t) )
227 |       )
228 |     )
229 |   ))
230 | )
231 | 
232 | (define (anf-name* exp* k)
233 |   (log-debug "=======>anf-name* ~a(" exp* )
234 |   (if (null? exp*)
235 |     (begin 
236 |       (log-debug "----------->exps end exp*=~a(" exp*)
237 |       (k exp*)
238 |     )
239 |      (anf-name (car exp*) 
240 |       (lambda (t)
241 |         (log-debug "=========>(car exp*)=~a ~a(" (car exp*) t)
242 |         (anf-name* (cdr exp*) (lambda (t*) 
243 |         (log-debug "=======>anf-name3 ===>t*=~a(" t*)
244 |         (k `(,t . ,t*)))) ))
245 |   )
246 | )
247 | 
248 | (define (anf exp k)
249 |   (log-debug "anf exp ~a(" exp)
250 |   (match exp
251 |     [,v ;;atom
252 |       (guard (type? v))
253 |       (k v)]
254 |     [(lambda (,params ...) ,body)
255 |       (k `(lambda ,params ,(anf-term body)))
256 |     ]
257 |     [($asm ,args ...)
258 |       (k `($asm ,@args))
259 |     ]
260 |     [(if ,e1 ,e2 ,e3)
261 |       (log-debug "if->~a ~a ~a k=~a(" e1 e2 e3 k)
262 |       ; `(if ,(anf e1 id) ,(anf e2 k) ,(anf e3 k) )
263 |       (k `(if ,(anf e1 id) ,(anf e2 id) ,(anf e3 id)) )
264 |     ]
265 |     [(let ((,v ,exp1) ) ,exp3)
266 |       (log-debug "let->~a ~a ~a(" v exp1 exp3)
267 |       (anf exp1 
268 |         (lambda (aexp1)
269 |           `(let ([,v ,aexp1]  )
270 |               ,(anf exp3 k) )))
271 |     ]
272 |     ; [(set! ,e1 ,e2 )
273 |     ;   `(set! ,e1 ,(anf e2 k) )
274 |     ; ]
275 |     [(()) '()]
276 |     [(void) (k `(void) ) ]
277 |     [(quote ,e)
278 |       (log-debug "quote-> ~a ~a(" e `(quote ,e ))
279 |       ; `(quote ,(anf e k) )
280 |       (k `(quote ,e))
281 |     ]
282 |     [(,fn . ,e*)
283 |       (log-debug "fn->~a arg->~a(" fn e*)
284 |       (anf-name fn (lambda (t) 
285 |         (log-debug "=======>anf-name2 ~a(" t)
286 |         (let ((ret (anf-name* e* (lambda (t*)
287 |               (k `(,t . ,t*)))) ))
288 |           (log-debug "=======>anf-name2 ret ~a(" ret)
289 |           ret
290 |         )
291 |         
292 |         ))
293 |       ]
294 |     [,?
295 |     (log-debug "?->~a(" (k ?) )
296 |     (k ?)]
297 |   )
298 | )
299 | 
300 | (define (anf-conversion exp )
301 |   (anf exp id)
302 | )
303 | 
304 | ;;lift lambda to let global scope
305 | (define (lift-lambda exp)
306 |   (define gvars '())
307 |   (define add-gvar
308 |         (lambda (v) 
309 |           (set! gvars (append gvars (list v)))
310 |           (log-debug "add-gvar ~a vars=~a" v gvars)
311 |           ))
312 |   (define (find-free e)
313 |     (define vars '())
314 |     (define free-vars '())
315 |     (define add-var
316 |         (lambda (v) 
317 |           (set! vars (append vars (list v)))
318 |           (log-debug "add-var ~a vars=~a" v vars)
319 |           ))
320 |     (define (find-free-var x)
321 |       ;;(log-debug "match->~a" x)
322 |       (match x
323 |         [(let ([,fn (lambda (,u* ...) ,e* ... )] ) ,e ...)
324 |           (log-debug "find-free-var1 ~a" x)
325 |           (add-var fn)
326 |           (add-gvar fn)
327 |           (map add-var u*)
328 |           `(let ([,fn (lambda  (,@u* ) ,@(map find-free-var e*) )] ) ,@(map find-free-var e ))
329 |         ]
330 |         [(let ([,v ,e]) ,e* ...)
331 |           (log-debug "find-free-var2 ~a" x)
332 |           (add-var v)
333 |           `(let ([,v ,(find-free-var e)])
334 |               ,@(map find-free-var e* ))
335 |         ]
336 |         [($asm ,bodys ...)
337 |           (log-debug "$asm ==>~a" bodys)
338 |           `($asm ,@bodys)
339 |         ]
340 |         [(,app ,args ...)
341 |           `(,app ,@(map find-free-var args))
342 |         ]
343 |         [,v
344 |           (guard (number? v))
345 |           v
346 |         ]
347 |         [,v
348 |           (guard (memq v vars))
349 |           v
350 |         ]
351 |         [,v
352 |           (guard (memq v gvars))
353 |           v
354 |         ]
355 |         [,unconver
356 |           (guard (symbol? unconver))
357 |           (log-debug "unconver====>~a" unconver)
358 |           (if (not (memq unconver free-vars))
359 |             (set! free-vars (append free-vars (list unconver)))
360 |           )
361 |           (log-debug "free-vars ====>~a" free-vars)
362 |           unconver
363 |         ]
364 |         [,e
365 |           (log-debug "rest exp->~a" e)
366 |           e
367 |         ]
368 |       ))
369 |     (find-free-var e)
370 |     free-vars
371 |   )
372 |   (define (add-params x name params)
373 |       (define (map-all-params e)
374 |         (map (lambda (o) (add-params o name params))  e )
375 |       )
376 |       ;;(log-debug "add-params x=~a ~a" x name)
377 |       (match x
378 |         [(let ([,fn (lambda (,u* ...) ,e* ... )]  ) ,e ...)
379 |           (log-debug "add-param1 ~a" x)
380 |           `(let ([,fn (lambda (,u* ...) ,e* ... )] ) ,@(map-all-params e) )
381 |         ]
382 |         [(let ([,v ,e]) ,e* ...)
383 |           (log-debug "add-param2 ~a" x)
384 |           `(let ([,v ,(add-params e name params)])
385 |               ,@(map-all-params e*) )
386 |         ]
387 |         [([,fn (lambda (,u* ...) ,e* ... )]  )
388 |         `([,fn (lambda (,u* ...) ,@(map-all-params e* ) )]  )
389 |         ]
390 |         [((,e* ...))
391 |           `(,@(map-all-params e*))
392 |         ]
393 |         [(,app ,args ...)
394 |           (log-debug "find fn ~a name=~a eq=~a" app name (equal? app name) )
395 |           (if (equal? app name)
396 |             `(,app ,@(map-all-params args) ,@params)
397 |             `(,app ,@(map-all-params args) ))
398 |         ]
399 |         [,v
400 |           v
401 |         ]
402 |       )
403 |     )
404 | 
405 |   (define lift-letrec
406 |     (lambda (x)
407 |       (define top* '())
408 |       (define add-top*
409 |         (lambda (def) (set! top* (append def top*))))
410 |       (define lift
411 |         (lambda (x)
412 |           (match x
413 |             [,x (guard (atom? x)) x]
414 |             [(let ([,fn* (lambda (,u* ...) ,[e*])] ...) ,[e] )
415 |               (log-debug "let exp=~a" x)
416 |               (let ((free (find-free `(let ([,fn* (lambda (,u* ...) ,e* )] ...) ,e ) ) ))
417 |                 (log-debug "find-free=~a fn=~a u*=~a" free fn* u*)
418 |                 (set-car! u*  (append (car u*) free) )
419 |                 (log-debug "get==>~a" `([,fn* (lambda ( ,u*  ) ,e*)] ... )  )
420 |                 (log-debug "=============>")
421 |                 (if (null? free)
422 |                   (add-top* `([,fn* (lambda (,u* ...) ,e* )] ... ))
423 |                   (add-top* (add-params `([,fn* (lambda ( ,u* ... ) ,e* ) ] ... ) (car fn*) free))
424 |                 )
425 |                (add-params e (car fn*) free)
426 |               )
427 |             ]
428 |             [(,[a] . ,[d]) 
429 |               ;;(log-debug "f====>~a ~a" a d)
430 |               `(,a . ,d)])))
431 |         (let ([new-bd (lift x)]
432 |             )
433 |           (let loop [(i top*)]
434 |               (if (pair? i)
435 |                 (begin
436 |                   (set! new-bd `(let (,(car i)) ,new-bd) )
437 |                   (loop (cdr i))
438 |                 )
439 |               )
440 |           )
441 |           new-bd
442 |             )))
443 |   (lift-letrec exp)
444 | )
445 | 
446 | 
447 | (define (mark-tail exp fn)
448 |   (log-debug "mark-tail->~a(" exp)
449 |   (match exp
450 |     [(lambda ,e1 ,e2)
451 |       `(lambda ,e1 ,(mark-tail e2 fn) )
452 |     ]
453 |     [(let ,e1 ,e2)
454 |       `(let ,e1 ,(mark-tail e2 fn) )
455 |     ]
456 |     [(if ,e1 ,e2 ,e3)
457 |       `(if ,(mark-tail e1 fn) ,(mark-tail e2 fn) ,(mark-tail e3 fn))
458 |     ]
459 |     [(,app ,args ...)
460 |       (if (equal? fn app)
461 |       `(tail ,app ,@args)
462 |       exp
463 |       )
464 |     ]
465 |     [,exp 
466 |       (log-debug "exp->~a(" exp)
467 |       exp]
468 |   )
469 | )
470 | 
471 | (define (tail-convert e)
472 |   (define (T-ae ae)
473 |     (log-debug "tail ~a(" ae)
474 |     (match ae
475 |       [,x
476 |         (guard (type? x))
477 |        x]
478 |       [(lambda (,x) ,e0)
479 |        (define k (gen-sym 'k))
480 |        `(lambda (,k ,x) ,(T-e e0 k))]
481 |       [else ae]))
482 |   (define (T-e e cae)
483 |   (log-debug "tail T-e ~a(" e)
484 |     (match e
485 |       [,x
486 |         (guard (symbol? x))
487 |        `(,cae ,x ,x)]
488 |       [(lambda . ,rest)
489 |        `(,cae 0 ,(T-ae e))]
490 |        [(let ([,x ,e0]) ,e1)
491 |        (define _x (gen-sym 'k))
492 |         (T-e e0 `(lambda (,_x ,x) ,(T-e e1 cae)))]
493 |       ; [(let ([,x ,e0]) ,e1)
494 |       ;  (define _x (gen-sym 'k))
495 |       ;  `(let (( ,(T-e e0 `(lambda (,_x ,x) ,(T-e e1 cae))) )))
496 |       ;  ]
497 |       [(if ,ae ,e0 ,e1)
498 |        `(if ,ae ,(T-e e0 cae) ,(T-e e1 cae))]
499 |       [(,aef ,aes ...)
500 |         (if (equal? cae '())
501 |         `(,(T-ae aef) ,@(map T-ae aes))
502 |         `(,(T-ae aef) ,cae ,@(map T-ae aes))
503 |         )
504 |        ]
505 |        [else e]
506 |        ))
507 |   (T-e e `() )
508 | 
509 |     ; (log-debug ">>>>>tail convert== ~a(" e)
510 |     ; (match e
511 |     ;   [(let ([,e0 (,e1 ,app)]) ,e2)
512 |     ;     (log-debug ">>>>>tail convert let2 = (~a ~a)(" e0 e1 )
513 | 
514 |     ;     (let ((k (gen-sym 'k)))
515 |     ;     `(let ([,k (lambda (,e0) ,(tail-convert e2) ) ])
516 |     ;       (,k ,(tail-convert `(,e1 ,app) ))
517 |     ;       ))
518 |     ;   ]
519 |     ;   [(let ([,e0 ,e1]) ,e2)
520 |     ;   (log-debug ">>>>>tail convert let = (~a ~a)(" e0 e1 )
521 |     ;   ;  (if (equal? (car e1) '( ))
522 |     ;   ;   (let ((k (gen-sym 'k)))
523 |     ;   ;   `(let ([,k (lambda (,e0) ,(tail-convert e2) ) ])
524 |     ;   ;     (,k ,(tail-convert e1) )
525 |     ;   ;     ))
526 |     ;     `(let ([,e0 ,(tail-convert e1) ])
527 |     ;         ,(tail-convert e2)
528 |     ;       )
529 |     ;       ; )
530 |     ;   ]
531 |       
532 |     ;   [(if ,e1 ,e2 ,e3)
533 |     ;     `(if ,e1 ,(tail-convert e2) ,(tail-convert e3) )
534 |     ;   ]
535 |     ;   [(lambda ,e1 ,e2)
536 |     ;     `(lambda ,e1 ,(tail-convert e2 ) )
537 |     ;   ]
538 |     ;   [,e e]
539 |     ;   )
540 | 
541 |   )
542 | 
543 | (define (tail exp)
544 |   (match exp
545 |     [(let ((,v ,exp1)) ,exp2)
546 |         ;;(log-debug "==>tail ~a ,~a(" v exp1)
547 |         (if (and (pair? exp1) (equal? (car exp1) 'lambda))
548 |              ;;mark tail
549 |              (begin
550 |              (log-debug "==>mark tail ~a(" (mark-tail exp1 v))
551 |              `(let ((,v ,(mark-tail exp1 v) )) ,(tail exp2) )
552 |             ;  (tail-convert `(let ((,v ,(mark-tail exp1 v) )) ,(tail exp2) ) )
553 | 
554 |              )
555 |         `(let ((,v ,(tail exp1) )) ,(tail exp2) )
556 |       )
557 |     ]
558 |     [,exp 
559 |     (log-debug "exp->~a(" exp)
560 |     exp]
561 |   )
562 | )
563 | 
564 | (define (tail-conversion exp)
565 |   (tail exp)
566 | )
567 | 
568 | (define (compile-steps exps steps)
569 |    (let loop ((it steps) (exp exps) (i 0))
570 |       (if (pair? it)
571 |         (let ((ret '()))
572 |           (log-info "~a.step ~a(" i (car it) )
573 |           ;;(log-debug "   exp =~a(" exp)
574 |           (log-info " exp=>")
575 |           (pretty-print exp)
576 |           ;;(log-debug "symbol ~a("   (car it))
577 |           (if (pair? (car it))
578 |             (set! ret (apply (car (car it)) exp (cdr (car it)) ))
579 |             (set! ret ((car it) exp)))
580 |           ;;(log-debug "   ret =~a\n(" ret)
581 |           (log-info " ret=>")
582 |           (pretty-print ret)
583 |           (loop (cdr it) ret (+ i 1)))
584 |         exp
585 |         )
586 |     )
587 | )
588 | 
589 | (define (duck-compile-exp exp out)
590 |     ;;asm-gen
591 |     (let ((compile-exp (duck-compile exp)))
592 |       (log-info " compile=>" )
593 |       (pretty-print compile-exp)
594 |       (log-info " gen file=>~a" out)
595 |       (asm-gen-file compile-exp out))
596 | )
597 | 
598 | (define (duck-compile exps)
599 |   (let ((out 'out))
600 |     (clear-gen-symbol '())
601 |     (compile-steps exps (list
602 |       macro-conversion
603 |       ast-conversion
604 |       ;;alpha-conversion
605 |       ;;cps-conversion
606 |       anf-conversion
607 |       lift-lambda
608 |       ;;tail-convert
609 |       tail-conversion
610 |       ; closure-conversion
611 |       represent-conversion
612 |       flatten-conversion
613 |       instruct-conversion
614 |       instruct-optimize
615 |       assign-conversion
616 |       restruct-block
617 |     ) ))
618 | )
619 | 
620 | )


--------------------------------------------------------------------------------
/duck/egg.ss:
--------------------------------------------------------------------------------
  1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2 | ;Copyright 2016-2080 evilbinary.
  3 | ;作者:evilbinary on 12/24/16.
  4 | ;邮箱:rootdebug@163.com
  5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6 | 
  7 | (library (duck egg)
  8 |   (export 
  9 |     asm-gen-file
 10 |     asm-gen
 11 |     represent-conversion
 12 |     flatten-conversion
 13 |     instruct-conversion
 14 |     assign-conversion
 15 |     restruct-block
 16 |     instruct-optimize
 17 |     remove-code
 18 |   )
 19 | 
 20 | (import
 21 |     (rename (scheme) (div div2) )
 22 |     (common match)
 23 |     (common trace)
 24 |     (common common)
 25 |     (arch arch)
 26 |     (duck libs)
 27 |     (duck type)
 28 |     (duck options)
 29 |     (common logger)
 30 |     )
 31 | 
 32 | (define symbols (get-sym))
 33 | 
 34 | (define (clear-gen-symbol)
 35 |   (clear-sym)
 36 | )
 37 | 
 38 | 
 39 | (define (represent-conversion exp)
 40 |   (note "represent-conversion ~a" exp)
 41 |   (match exp
 42 |     [() `null-rep ]
 43 |     [(void) `null-rep ]
 44 |     [#t `true-rep ]
 45 |     [#f `false-rep ]
 46 |     [(let ((,v ,exp1)) ,exp2)
 47 |       (log-debug "==>let ~a ~a" v exp1 )
 48 |       `(let ([,v ,(represent-conversion exp1) ])
 49 |           ,(represent-conversion exp2) )
 50 |     ]
 51 |     [($asm ,args ...)
 52 |       `($asm ,@args)
 53 |     ]
 54 |     [,v
 55 |       (guard (string? v))
 56 |       (note "alloc string ~a" v)
 57 |       `(alloc ,v)
 58 |     ]
 59 |     [,v (guard (integer? v))
 60 |       (note "integer  ~a" v )
 61 |       (type-rep v)
 62 |     ]
 63 |     [(lambda () ,e)
 64 |     `(lambda () ,(represent-conversion e))
 65 |     ]
 66 |     [(if ,e1 ,e2 ,e3)
 67 |       `(if ,(represent-conversion e1) ,(represent-conversion e2) ,(represent-conversion e3))
 68 |     ]
 69 |     [(quote ,e)
 70 |       (note "quote ~a" e)
 71 |       (cond
 72 |         [(integer? e) (represent-conversion e)]
 73 |         [(boolean? e) (represent-conversion e)]
 74 |         [(null? e) (represent-conversion e)]
 75 |         [(equal? (void) e) (represent-conversion e)]
 76 |         ; [(pair? e)  
 77 |         ;   (note "pair ~a . ~a" (car e) (cdr e) )
 78 |         ;   `(cons ,(represent-conversion (car e)) ,(represent-conversion `(quote ,(cdr e))) )
 79 |         ; ]
 80 |         [else 
 81 |         `(alloc ,(represent-conversion e))
 82 |         ])
 83 |     ]
 84 |     [,v 
 85 |       (guard (symbol? v))
 86 |       (note "symbol ~a" v)
 87 |       v
 88 |     ]
 89 |     [(,binop ,arg1 ,arg2)
 90 |       (guard (binop? binop))
 91 |       `(,binop ,(represent-conversion arg1) ,(represent-conversion arg2) )
 92 |     ]
 93 |     [(,prim ,args ...)
 94 |       (guard (prim? prim))
 95 |       (note "prim ~a" prim)
 96 |       `(,prim ,@(map represent-conversion args ))
 97 |     ]
 98 |     [(,app ,args ...)
 99 |       `(,app ,@(map represent-conversion args ))
100 |     ]
101 |     [,exp 
102 |       (log-debug "unkown exp->~a" exp)
103 |     exp]
104 |   )
105 | )
106 | 
107 | ;;anf let to program
108 | (define (flatten-conversion exp)
109 |   (define (find-vars cur vars)
110 |     (log-debug "find-vars==>~a" cur)
111 |     (match cur
112 |       [(let ((,var ,e1)) ,e2)
113 |         (log-debug "find-vars let=>~a ~a ~a" var e1 e2)
114 |         (set! vars (append vars (list var)  (find-vars e1 vars) (find-vars e2 vars)))
115 |         (log-debug "vars=>~a" vars)
116 |         vars
117 |       ]
118 |       [(if ,a ,b ,c)
119 |         (log-debug "find-vars if=>~a ~a ~a" a b c)
120 |         (set! vars (append vars
121 |           (find-vars a vars)
122 |           (find-vars b vars)
123 |           (find-vars c vars)))
124 |         vars
125 |       ]
126 |       [(,app ,args ...)
127 |         (log-debug "find-vars app ==> ~a ~a" app args)
128 |         vars
129 |       ]
130 |       [,v
131 |         (guard (or (number? v) (symbol? v)))
132 |         (log-debug "symbol/number ==> ~a" v)
133 |         vars
134 |       ]
135 |       [,exp 
136 |         ;;(log-debug "unkown exp->~a" exp)
137 |         (error 'flatten "find-vars erro" exp )
138 |         vars
139 |       ]
140 |     )
141 |   )
142 | 
143 |   (define (flatten exp)
144 |     (log-debug "flatten===>~a" exp)
145 |     (match exp
146 |       [(let ((,proc (lambda (,args ...) ,body ))) ,e)
147 |         (log-debug "proc==> ~a args=~a body=~a  e=~a" proc args  body  e)
148 |         `(
149 |            (program ,proc
150 |               ,args ;;args
151 |               ,(find-vars body '()) ;;vars
152 |               ,@(flatten body))
153 | 
154 |               ; ,@(flatten e)
155 |             (program main
156 |               () ;;args
157 |               (,proc ,@(find-vars e '())) ;;vars
158 |               ,@(flatten e))
159 |           )
160 |       ]
161 |       [(let ((,var ,e1)) ,e2)
162 |         (log-debug "let ==> ~a ~a ~a" var e1 e2)
163 |         `( (set ,var ,e1) ,@(flatten e2))
164 |       ]
165 |       [(if ,a ,b ,c)
166 |        `((if ,a ,b ,c))
167 |        ]
168 |       [(,app ,args ...)
169 |         (log-debug "app ==> ~a ~a" app args)
170 |         `((,app ,@args))
171 |       ]
172 |       [,v
173 |         (guard (or (number? v) (symbol? v)))
174 |         (log-debug "symbol/number ==> ~a" v)
175 |         `(,v)
176 |       ]
177 |       [,exp 
178 |         ;;(log-debug "unkown exp->~a" exp)
179 |         (error 'flatten "flatten erro" exp)
180 |       ]
181 |     ))
182 | 
183 |   ;;program main start
184 |   `(program all
185 |       () ;;args
186 |       ,(find-vars exp '()) ;;vars
187 |       ,@(flatten exp))
188 | )
189 | 
190 | 
191 | (define (remove-code e)
192 |     (define result '())
193 |     (define (collect-exp ex)
194 |       (set! result (append result (list ex)))
195 |     )
196 |     (define (match-exp ex)
197 |       (match ex
198 |         [(,app ,args ...)
199 |           (guard (not (equal? app 'code)))
200 |           #t
201 |         ]
202 |         [,v #f]
203 |       )
204 |     )
205 | 
206 |     (define (remove-p e k)
207 |       (log-debug ">>>>>>>>>>remove-p ~a" e)
208 |       (match e
209 |         ; [(code (,apps ...))
210 |         ;   (log-debug " remove-code1 ~a" apps)
211 |         ;   (k `( ,@apps))
212 |         ; ]
213 |         [(code ,exps ...)
214 |           (log-debug " remove-code3 ~a" e)
215 |           (let ((ret (remove-p* exps id) ))
216 |             ; (if (match-exp ret)
217 |             ;   (k `(code ,@ret ))
218 |             ;   (k `( ,@ret))
219 |             ; )
220 |             (k `(code ,@ret))
221 |           )
222 |         ]
223 |         [(,apps ...)
224 |           (k `(,@apps))
225 |         ]
226 |         [,v
227 |           (guard (or (number? v) (symbol? v)))
228 |           (k v)
229 |         ]
230 |         [,exp 
231 |         (log-debug "unkown exp->~a" exp)
232 |         (error 'remove-code "remove-code erro" exp)
233 |       ]
234 |       )
235 |     )
236 | 
237 |   (define (remove-p* exp* k)
238 |     (log-debug "=======>remove-p* ~a" exp* )
239 |     (if (null? exp*)
240 |       (begin 
241 |         (log-debug "----------->exps end exp*=~a" exp*)
242 |         (k exp*)
243 |       )
244 |       (remove-p (car exp*) 
245 |         (lambda (t)
246 |           (log-debug " (car exp*)=~a ret=>~a match=~a" (car exp*) t (match-exp t))  
247 |           (if (match-exp t)
248 |             (collect-exp t)
249 |           )        
250 |           (remove-p* (cdr exp*)
251 |             (lambda (t*) 
252 |               (log-debug "=======>t=~a t*=~a" t t*)
253 |               (k `(,t . ,t*)))) ))
254 |     )
255 |   )
256 |   (remove-p e id)
257 |   result
258 | )
259 | 
260 | ;;conver codes =>instruct
261 | (define (instruct-conversion exp)
262 |   (log-debug "instruct-conversion ~a" exp)
263 |   (match exp
264 |     [(program ,name ,vars ,args ,e ...)
265 |       (log-debug "   program=> ~a ~a ~a ~a" name vars args e)
266 |       (let ((instructs (map instruct-conversion e)))
267 |         (log-debug "   instructs=>~a" instructs)
268 |         (set! instructs (remove-code `(code ,@instructs)) )
269 |         (log-debug "   instructs2=>~a" instructs)
270 |         `(program ,name ,vars ,args 
271 |             ,@instructs ))
272 |     ]
273 |     [(let ((,var ,e1)) ,e2)
274 |       (log-debug "let ==> ~a ~a ~a" var e1 e2)
275 |       `(code
276 |         ,(instruct-conversion e1)
277 |         (set ,var reg0)
278 |         ,(instruct-conversion e2) 
279 |         )
280 |     ]
281 |     [(if ,a ,b ,c)
282 |         (let ((l1 (gen-sym 'ifa))
283 |               (l2 (gen-sym 'ifb))
284 |               (l3 (gen-sym 'ifend)))
285 |         (log-debug "--->if ==> ~a ~a ~a" l1 l2 l3)
286 |         `(code
287 |             ,(instruct-conversion a)
288 |             (cmp-jmp reg0 false-rep ,l2 ,l1)
289 |             (label ,l1)
290 |             ,(instruct-conversion b)
291 |              (jmp ,l3)
292 |             (label ,l2)
293 |             ,(instruct-conversion c)
294 |             (label ,l3)
295 |           )
296 |         )
297 |     ]
298 |     [(set ,var (,e ...) )
299 |       (log-debug "set1 ~a ~a" var e)
300 |       `(code
301 |         ,(instruct-conversion `(,@e) )
302 |         (set ,var reg0)
303 |       )
304 |     ]
305 |     [(set ,var ,val)
306 |       (log-debug "set2 ~a ~a" var val)
307 |       `(code
308 |         (set ,var ,val)
309 |       )
310 |     ]
311 |     [($asm ,args ...)
312 |       `($asm ,@args)
313 |       ]
314 |     [(,app ,args ...)
315 |       (guard (prim? app))
316 |       `(code (,app ,@args ))
317 |     ]
318 |     [(tail ,app ,args ...)
319 |       `(code (,app ,@args))
320 |     ]
321 |     [(,app ,args ...)
322 |       `(code (,app ,@args))
323 |     ]
324 |     [,v
325 |       (guard (or (number? v) (symbol? v)))
326 |       (log-debug "symbol ==> ~a" v)
327 |        `(code (set reg0 ,v))
328 |       ]
329 |     [,exp 
330 |       ;;(log-debug "unkown exp->~a" exp)
331 |       (error 'instruct-conversion "instruct-conversion erro" exp)
332 |     ]
333 |   )    
334 | )
335 | 
336 | (define (instruct-optimize exp)
337 |   (match exp
338 |       [(program ,name ,vars ,args ,e ...)
339 |       (log-debug "   program=> ~a ~a ~a ~a" name vars args e)
340 |       (let ((instructs (map instruct-optimize e)))
341 |         (log-debug "instructs=>~a" instructs)
342 |         `(program ,name ,vars ,args 
343 |             ,@instructs ))
344 |     ]
345 |     [(set ,var (set ,var2 ,val))
346 |       (if (equal? var var2 )
347 |         `(set ,var ,val)
348 |         `(set ,var (set ,var2 ,val))
349 |       )
350 |     ]
351 |     [,v
352 |       v
353 |     ]
354 |   )
355 | )
356 | 
357 | ;;remove vars
358 | (define (assign-conversion exp)
359 |   (define (lookup key env)
360 |     (log-debug "   lookup key=~a env=~a" key env)
361 |     (cond
362 |       [(assq key env) => cdr]
363 |       [else '()]))
364 | 
365 |   (define (lookup-value val env)
366 |     (log-debug "   lookup val=~a env=~a" val env)
367 |     (cond
368 |       [(> (length (filter (lambda(x) (= 0 (cdr x))) env)) 0) val]
369 |       [else '()]))
370 | 
371 |   (define (ext key val env)
372 |     (cond
373 |       [(eq? key val) env]
374 |       [(not (pair? val))
375 |         (cons `(,key . ,val) env)]
376 |       [else env]))
377 | 
378 |   (define genv '())
379 |   
380 |   (define (assign cur env)
381 |     (match cur
382 |       [(program ,name ,args ,vars ,c* ...)
383 |           (set! genv (ext name (length genv) genv))
384 |           (let ((lenv '()))
385 |             (mapc (lambda (x)
386 |                     (set! lenv (ext  x (length lenv) lenv))) 
387 |                   args)
388 |             (mapc (lambda (x)
389 |                     (set! lenv (ext  x (length lenv) lenv)))
390 |                   vars)
391 |             (log-debug "prgram name=~a args vars env =>~a" name lenv)
392 |           `(program ,name ,args ,@(map (lambda (i) 
393 |               (log-debug "   env=> ~a" lenv)
394 |               (assign i lenv) ) c*) )
395 |           )
396 |       ]
397 |       [($asm ,args ...)
398 |       `($asm ,@args)
399 |       ]
400 |       [(,binop ,a ,b)
401 |         (guard (memq binop '(> < >= < <= = + - * /) ))
402 |         `(,binop ,(assign a env)
403 |                   ,(assign b env)
404 |           )
405 |       ]
406 |       [(set ,a ,b)
407 |         `(set ,(assign a env) ,(assign b env))
408 |       ]
409 |       [(,app ,args ...)
410 |         (log-debug "assign=~a ~a" app args)
411 |         `(,(assign app env)
412 |               ,@(map (lambda (x) 
413 |                         (assign x env))
414 |                      args ))
415 |       ]
416 |       [,var
417 |         (guard (and (symbol? var)  (equal? (string-ref (symbol->string var)  0) #\&)) )
418 |         var
419 |       ]
420 |       [,var 
421 |         (guard (symbol? var))
422 |         (log-debug "var==>~a env=~a genv=~a" var env genv)
423 |         (let ((it (lookup var env))
424 |               (git (lookup var genv)) )
425 |           (if (null? git)
426 |             (if (null? it)
427 |               var
428 |               `(local ,it )
429 |             )
430 |             var
431 |              ) )
432 |       ]
433 |       [,exp 
434 |           (log-debug "assign-conversion unkown exp->~a" exp)
435 |           exp
436 |       ]
437 |     ) 
438 |   )
439 |   (assign exp genv)
440 | )
441 | 
442 | (define (collect-block cur main-block fn-block data-block)
443 |     (match cur
444 |       [(program all ,args ,bodys ...)
445 |         (log-debug "programe all collect=> ~a" bodys )
446 |         (let ((b (map (lambda (x) 
447 |                    (collect-block x main-block fn-block data-block))
448 |                     bodys)))
449 |         (set-box! main-block 
450 |           (append b
451 |                  (unbox main-block)  ))
452 |         )
453 |       ]
454 |       [(program ,name ,args ,bodys ... )
455 |           (log-debug "program-> name=~a body=~a" name bodys)
456 |           (if (equal? 'main name)
457 |             (let ((b  (map (lambda (x) 
458 |                    (collect-block x main-block fn-block data-block))
459 |                     bodys)))
460 |               (set-box! main-block (append b (unbox main-block) ) )
461 |                '()
462 |             )
463 |             (let ((mb (box '() ))
464 |                   (fb (box '()))
465 |                   (b '())
466 |                   )
467 |               (set! b (map (lambda (x) 
468 |                    (collect-block x mb fb data-block))
469 |                     bodys))
470 |               (set-box! fn-block (append (unbox fn-block) 
471 |                           (list `(block (function ,name ,@args) ,@b ,@(unbox mb)))
472 |                           (unbox fb)
473 |                                  ) )
474 |               ; `(block (function ,name ,@args) ,@bodys )
475 |               `()
476 |             )
477 |           )        
478 |       ]
479 |       [($asm ,bodys ...)
480 |         (log-debug "$asm ==>~a" bodys)
481 |         `($asm ,@bodys)
482 |       ]
483 |       [(block (,fn ,args ...) ,bodys ...)
484 |         ;`(block-> (,fn ,args ...) ,@(map collect bodys))
485 |         `()
486 |       ]
487 |       [($data ,v ,e ...)
488 |         (set-box! data-block (append (list `(data ,v ,@e)) (unbox data-block) ) )
489 |         v
490 |       ]
491 |       ;;default in main
492 |       [,exp  
493 |         (log-debug "else==>~a block-main=>~a" exp (unbox main-block))
494 |         exp
495 |       ]
496 |     )
497 |   )
498 | 
499 | ;;add proc to last 
500 | (define (restruct-block exp)
501 |   (log-set-level '())
502 |   (let ((block-defs '() ) 
503 |         (block-main '())
504 |         (block-data `(
505 |           (data ,(symbol->asm-id 'true-rep) ,true-rep)
506 |           (data ,(symbol->asm-id 'false-rep) ,false-rep)
507 |           (data ,(symbol->asm-id 'void-rep) ,void-rep)
508 |           (data ,(symbol->asm-id 'null-rep) ,null-rep)
509 |           ))
510 |         (block-libs `(
511 |           ,(assign-conversion `,(print-value))
512 |           ; (assign-conversion ,(print-dot))
513 |           ,(assign-conversion `,(print-list))
514 |            ))
515 |        )
516 |   
517 |   (log-set-level 'info)
518 |   (let ((main-block (box block-main))
519 |         (fn-block (box block-defs ))
520 |         (data-block (box block-data))
521 |         )
522 |       (collect-block exp main-block fn-block data-block)
523 |       (set! block-main (unbox main-block))
524 |       (set! block-defs (unbox fn-block))
525 |       (set! block-data (unbox data-block))
526 |   )
527 | 
528 |   `(block all 
529 |     ;;main block
530 |     (block main
531 |       (stext start)
532 |       ,@block-main
533 |       (stext end)
534 |     )
535 |     ;;defs block
536 |     ,@block-defs
537 |     ;;
538 |     ,@(if (option-get 'need-primitive) block-libs `() )
539 |     ;;data block
540 |     (block data
541 |       (sdata start)
542 |       ,@block-data
543 |       (sdata end)
544 |     )
545 |   )
546 | )   
547 | )
548 | 
549 | ;; flatten code 
550 | ;; (code ....)
551 | (define (emit-code exp env)
552 |   (define (emit-p cur env)
553 |     (note "emit-code ~a" cur)
554 |     (match cur
555 |     [(block (label ,name ,args ...) ,blocks ...)
556 |         (lproc name '())
557 |         (let loop [(i blocks)]
558 |             (if (pair? i)
559 |               (begin 
560 |                 ; (note "====> ~a" (car i))
561 |                 (emit-code (car i) env)
562 |                 (loop (cdr i))
563 |               )
564 |             )
565 |         )
566 |        ]
567 |       [(block (function ,name ,args ...) ,blocks ...)
568 |         (note "block function ~a" name )
569 |         (proc name '())
570 |         (let loop [(i blocks)]
571 |           (if (pair? i)
572 |             (begin 
573 |               ; (note "====> ~a" (car i))
574 |               (emit-code (car i) env)
575 |               (loop (cdr i))
576 |             )
577 |           )
578 |         )
579 |         (pret)
580 |        ]
581 |       [(block ,name ,blocks ...)
582 |         (note "block name=~a" name )
583 |         (let loop [(i blocks)]
584 |               (if (pair? i)
585 |                 (begin 
586 |                   ; (note "====> ~a" (car i))
587 |                   (emit-code (car i) env)
588 |                   (loop (cdr i))
589 |                 )
590 |               )
591 |           )
592 |       ]
593 |       [(sdata ,arg)
594 |         (sdata arg)
595 |       ]
596 |       [(data . ,args)
597 |         (apply data args)
598 |       ]
599 |       [(stext ,arg)
600 |         (stext arg)
601 |       ]
602 |       [,atom 
603 |         (guard (null? atom))
604 |         (note "null")
605 |       ]
606 |       [,atom
607 |         (guard (number? atom))
608 |         atom
609 |       ]
610 |       [,atom
611 |         (guard (string? atom))
612 |         atom
613 |       ]
614 |       [,type
615 |         (guard (type? type))
616 |         type
617 |       ]
618 |       [,reg
619 |         (guard (memq reg regs-map))
620 |         ;;(log-debug "reg=>~a" reg)
621 |         reg
622 |       ]
623 |       [(label ,var)
624 |         (label var)
625 |       ]
626 |       [(proc ,var ,args ...)
627 |         (proc var args)
628 |       ]
629 |       [(local ,index)
630 |         (local index)
631 |       ]
632 |       [(set ,var ,val)
633 |         (let ((l  (emit-p var env) )
634 |             (r (emit-p val env)))
635 |           (if (void? r)
636 |             (set! r reg0)
637 |           )
638 |           (if (void? l)
639 |             (set! l reg0)
640 |           )
641 |           (set l r)
642 |           )
643 |       ]
644 |       [(ret)
645 |         (ret)
646 |       ]
647 |        [(lret)
648 |         (lret)
649 |       ]
650 |       [(cmp-jmp ,a ,b ,c)
651 |         (cmp-jmp a b c)
652 |       ]
653 |       [(cmp-jmp ,val1 ,val2 ,l1 ,l2)
654 |         (cmp-jmp val1 val2 l1 l2)
655 |       ]
656 |       [(,binop ,a ,b)
657 |         (guard (memq binop '(> < >= < <= =) ))
658 |         (cmp binop (emit-p a env) (emit-p b env))
659 |       ]
660 |       ; [(,binop ,a ,b)
661 |       ;   (guard (memq binop '(sub mul div) ))
662 |       ;   (binop (emit-p a env) (emit-p b env))
663 |       ; ]
664 |       [(,binop ,a ,b)
665 |         (guard (memq binop '(+ add)))
666 |         (add (emit-p a env) (emit-p b env))
667 |       ]
668 |       [(,binop ,a ,b)
669 |         (guard (memq binop '(* mul)))
670 |         (mul (emit-p a env) (emit-p b env))
671 |       ]
672 |       [(,binop ,a ,b)
673 |         (guard (memq binop '(- sub)))
674 |         (sub (emit-p a env) (emit-p b env))
675 |       ]
676 |       [(,binop ,a ,b)
677 |         (guard (memq binop '(/ div)))
678 |         (div (emit-p a env) (emit-p b env))
679 |       ]
680 |       [(shr ,a ,b)
681 |         (shr a b)
682 |       ]
683 |       [(sar ,a ,b)
684 |         (sar a b)
685 |       ]
686 |       [(sal ,a ,b)
687 |         (sal a b)
688 |       ]
689 |       [(shl ,a ,b)
690 |         (shl a b)
691 |       ]
692 |       [(note ,x ...)
693 |         (note x)
694 |       ]
695 |       [(land ,a ,b)
696 |         (land a b)
697 |       ]
698 |       [(lor ,a ,b)
699 |         (lor a b)
700 |       ]
701 |       [(jmp ,l)
702 |         (jmp l)
703 |       ]
704 |       [(save ,a)
705 |         (save a)
706 |       ]
707 |       [(restore ,a)
708 |         (restore a)
709 |       ]
710 |       [(mref ,a ,b ,x ...)
711 |         (mref a b x)
712 |       ]
713 |       [(mset ,a ,b ,x ...)
714 |         (mset a b x)
715 |       ]
716 | 
717 |       ;;primitive start
718 |       [(emit-print-value ,args ...)
719 |         (apply emit-print-value args)
720 |       ]
721 |       [(emit-printf ,fmt  ,args ...)
722 |         (apply emit-printf fmt args)
723 |       ]
724 |       [(emit-print-type-value ,tag  ,str ,lend)
725 |         (emit-print-type-value tag  str lend)
726 |       ]
727 |       [(emit-print-const-value ,tag  ,str ,lend)
728 |         (emit-print-const-value tag  str lend)
729 |       ]
730 |       [(print-value) (print-value)]
731 |       [(print-list) (print-list)]
732 |       [(print-dot) (print-dot)]
733 |       [(asm ,e )
734 |         (note "$asm ~a" e)
735 |         (asm e)
736 |       ]
737 |       [($asm ,args ...)
738 |         (note "$asm ~a" args )
739 |         (mapc  (lambda (e)
740 |             (emit-p e env)) args )
741 |       ]
742 |       ;;prim call 
743 |       [(,app ,args ...)
744 |         (guard (prim? app))
745 |         (note "prim call ~a" app)
746 |         (emit-prim app (map  (lambda (e)
747 |             (emit-p e env)) args ))        
748 |       ]
749 |       [(fcall ,app ,args ...)
750 |         ; (arg (emit-p args env))
751 |         ;(log-debug "call app= ~a ~a" app args)
752 |         ;;call name
753 |         (apply fcall app 
754 |           (map  (lambda (e)
755 |             (emit-p e env)) args ))
756 |       ]
757 |       ;;direct call
758 |       [(call ,app ,args ...)
759 |         (guard (pair? app))
760 |         (set reg1 (emit-p app env) )
761 |         (apply call reg1 
762 |           (map  (lambda (e)
763 |             (emit-p e env)) args ))
764 |       ]
765 |       [(call ,app ,args ...)
766 |         ; (arg (emit-p args env))
767 |         ;(log-debug "call app= ~a ~a" app args)
768 |         ;;call name
769 |         (apply call app 
770 |           (map  (lambda (e)
771 |             (emit-p e env)) args ))
772 |       ]
773 |       [(call ,app)
774 |         (call app )
775 |       ]
776 | 
777 |       ;;direct call
778 |       [(,app ,args ...)
779 |         (guard (pair? app))
780 |         (emit-p `(call ,app ,@args) env)
781 |       ]
782 |       [(,app ,args ...)
783 |         (emit-p `(call ,app ,@args) env)
784 |       ]
785 |       [(,app)
786 |         (emit-p  `(call ,app) env)
787 |       ]
788 | 
789 | 
790 |       
791 |       [,?
792 |         (error 'emit-code "gen asm unknow " ?)
793 |       ]
794 |   ))
795 |   (emit-p exp env)
796 | )
797 | 
798 | (define (asm-gen exp)
799 |   ;;(stack-trace-exception)
800 |   (clear-gen-symbol)
801 |   (log-info "asm-gen=>")
802 |   (pretty-print exp)
803 |   (let ((out-asm 
804 |       (with-output-to-string
805 |         ; (
806 |           (lambda () 
807 |            (try
808 |               (let ((env '())) 
809 |                 (note "gen by Lisp依依鸭 evilbinary on ~a" (date-and-time))
810 |                 (note exp)
811 |                 (note "code start")
812 |                 (emit-code exp env)
813 |                 (note "code end")                
814 |               )
815 |               (catch (lambda (x) 
816 |                 (display-condition x) 
817 |               )))
818 | 
819 |             ))))
820 |     ;;(log-debug "out-asm \n~a" out-asm)
821 |     out-asm)  
822 |   )
823 | 
824 |   (define (asm-gen-file exp name)
825 |     (let ([o (open-file-output-port (format "~a~a" name (option-get 'obj.name ".s") ) (file-options replace)
826 |                 (buffer-mode block) (current-transcoder))])
827 |           (display (asm-gen exp) o)  
828 |       (close-output-port o))
829 |     (asm-compile-exp exp name)
830 |   )  
831 | 
832 | )


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


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


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


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


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


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


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


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


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


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


--------------------------------------------------------------------------------
/tests/test0/duck.c:
--------------------------------------------------------------------------------
 1 | #include <stdio.h>
 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 | 


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


--------------------------------------------------------------------------------
/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/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/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/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-print:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/evilbinary/duck-compiler/8c64a521f012aa6b2b7b9385f11976b216cc07e0/tests/test0/test-print


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


--------------------------------------------------------------------------------
/tests/test0/test-string-replace.ss:
--------------------------------------------------------------------------------
1 | (import (common))
2 | 
3 | (printf "string-replace-one=> ~a\n" (string-replace ")" "quote" "adfas)" ) )


--------------------------------------------------------------------------------
/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 | }


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


--------------------------------------------------------------------------------
/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.c:
--------------------------------------------------------------------------------
1 | #include <stdlib.h>
2 | 
3 | int main(void)
4 | {
5 |     void* a=malloc(8);
6 |       return 0;
7 | }
8 | 


--------------------------------------------------------------------------------
/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/test0/test3.c:
--------------------------------------------------------------------------------
1 | #include <stdlib.h>
2 | 
3 | int main(int argc,char* argv[])
4 | {
5 |       return 0;
6 | }
7 | 


--------------------------------------------------------------------------------
/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/test4.c:
--------------------------------------------------------------------------------
 1 | #include <stdlib.h>
 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/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 | 


--------------------------------------------------------------------------------