conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* racompile passes 1.4

This commit is contained in:
Abdulaziz Ghuloum 2007-02-05 20:38:22 -05:00
parent 4698e0fd92
commit caf234c0c3
1 changed files with 15 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/racompiler.ss
View File

@ -45,6 +45,7 @@
(module (primitive? arg-count-ok? primitive-context) (module (primitive? arg-count-ok? primitive-context)
(define primitives (define primitives
'([$fxadd1 1 v] '([$fxadd1 1 v]
[$fxsub1 1 v]
[$fxlognot 1 v] [$fxlognot 1 v]
[$fixnum->char 1 v] [$fixnum->char 1 v]
[$char->fixnum 1 v] [$char->fixnum 1 v]
@ -86,6 +87,10 @@
[(and (pair? x) (symbol? (car x))) [(and (pair? x) (symbol? (car x)))
(case (car x) (case (car x)
[(quote) (mkconst (cadr x))] [(quote) (mkconst (cadr x))]
[(if)
(mkif (E (cadr x) r)
(E (caddr x) r)
(E (cadddr x) r))]
[else (error who "invalid expression ~s" x)])] [else (error who "invalid expression ~s" x)])]
[(pair? x) [(pair? x)
(let ([a (car x)]) (let ([a (car x)])
@ -114,6 +119,8 @@
(make-constant #t))) (make-constant #t)))
(record-case x (record-case x
[(constant c) (make-constant (if c #t #f))] [(constant c) (make-constant (if c #t #f))]
[(conditional e0 e1 e2)
(mkif (P e0) (P e1) (P e2))]
[(primcall op rands) [(primcall op rands)
(case (primitive-context op) (case (primitive-context op)
[(v) (predicafy (V x))] [(v) (predicafy (V x))]
@ -125,6 +132,8 @@
(define (V x) (define (V x)
(record-case x (record-case x
[(constant) x] [(constant) x]
[(conditional e0 e1 e2)
(mkif (P e0) (V e1) (V e2))]
[(primcall op rands) [(primcall op rands)
(case (primitive-context op) (case (primitive-context op)
[(v) (make-primcall op (map V rands))] [(v) (make-primcall op (map V rands))]
@ -193,6 +202,8 @@
(mkprm 'int= (V (car rands)) (immediate-rep 0))] (mkprm 'int= (V (car rands)) (immediate-rep 0))]
[(null?) [(null?)
(mkprm 'int= (V (car rands)) (immediate-rep '()))] (mkprm 'int= (V (car rands)) (immediate-rep '()))]
[(eq?)
(mkprm 'int= (V (car rands)) (V (cadr rands)))]
[else (error who "invalid value prim ~s" op)])] [else (error who "invalid value prim ~s" op)])]
[else (error who "invalid value ~s" x)])) [else (error who "invalid value ~s" x)]))
(define (V x) (define (V x)
@ -207,6 +218,8 @@
(case op (case op
[($fxadd1) [($fxadd1)
(mkprm 'int+ (V (car rands)) (immediate-rep 1))] (mkprm 'int+ (V (car rands)) (immediate-rep 1))]
[($fxsub1)
(mkprm 'int+ (V (car rands)) (immediate-rep -1))]
[($fxlognot) [($fxlognot)
(mkprm 'intxor (V (car rands)) (immediate-rep -1))] (mkprm 'intxor (V (car rands)) (immediate-rep -1))]
[($char->fixnum) [($char->fixnum)
@ -358,7 +371,7 @@
(cond (cond
[(and lt lf) [(and lt lf)
(list* `(,(cjumpop cnd) (label ,lt)) (list* `(,(cjumpop cnd) (label ,lt))
`(jmp (label lf)) `(jmp (label ,lf))
ac)] ac)]
[lt [lt
(list* `(,(cjumpop cnd) (label ,lt)) (list* `(,(cjumpop cnd) (label ,lt))
@ -540,5 +553,6 @@
(load "tests/tests-1.1-req.scm") (load "tests/tests-1.1-req.scm")
(load "tests/tests-1.2-req.scm") (load "tests/tests-1.2-req.scm")
(load "tests/tests-1.3-req.scm") (load "tests/tests-1.3-req.scm")
(load "tests/tests-1.4-req.scm")
(printf "ALL IS GOOD :-)\n") (printf "ALL IS GOOD :-)\n")