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

Now passing 682 tests in 64-bit mode.

This commit is contained in:
Abdulaziz Ghuloum 2008-04-09 05:34:36 -04:00
parent f63f85e1cc
commit 866b2b1c17
5 changed files with 138 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
scheme/ikarus.compiler.altcogen.ss
View File

@ -2338,6 +2338,16 @@
(E (make-asm-instr 'move u a))
(make-asm-instr op u b)))
x)]
[(and (not (mem? a)) (not (small-operand? a)))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u a))
(P (make-asm-instr op u b))))]
[(and (not (mem? b)) (not (small-operand? b)))
(let ([u (mku)])
(make-seq
(E (make-asm-instr 'move u b))
(P (make-asm-instr op a u))))]
[(and (mem? a) (mem? b))
(let ([u (mku)])
(make-seq

9
scheme/ikarus.intel-assembler.ss
View File

@ -401,11 +401,11 @@
[(and (imm8? a0) (reg32? a1))
(ModRM 1 /d a1 (IMM8 a0 ac))]
[(and (imm? a0) (reg32? a1))
(ModRM 2 /d a1 (IMM a0 ac))]
(ModRM 2 /d a1 (IMM32 a0 ac))]
[(and (imm8? a1) (reg32? a0))
(ModRM 1 /d a0 (IMM8 a1 ac))]
[(and (imm? a1) (reg32? a0))
(ModRM 2 /d a0 (IMM a1 ac))]
(ModRM 2 /d a0 (IMM32 a1 ac))]
[(and (reg32? a0) (reg32? a1))
(RegReg /d a0 a1 ac)]
[(and (imm? a0) (imm? a1))
@ -536,6 +536,7 @@
(define (CCI32 c0 c1 i32 ac)
(CODE c0 (CODE c1 (IMM32 i32 ac))))
(define (dotrace orig ls)
(printf "TRACE: ~s\n"
(let f ([ls ls])
@ -580,7 +581,7 @@
[(addl src dst)
(cond
[(and (imm8? src) (reg? dst)) (CR* #x83 '/0 dst (IMM8 src ac))]
[(and (imm32? src) (eq? dst '%eax)) (CODE #x05 (IMM32 src ac))]
[(and (imm32? src) (eq? dst '%eax)) (C #x05 (IMM32 src ac))]
[(and (imm32? src) (reg? dst)) (CR* #x81 '/0 dst (IMM32 src ac))]
[(and (reg? src) (reg? dst)) (CR* #x01 src dst ac)]
[(and (mem? src) (reg? dst)) (CR* #x03 dst src ac)]
@ -590,7 +591,7 @@
[(subl src dst)
(cond
[(and (imm8? src) (reg? dst)) (CR* #x83 '/5 dst (IMM8 src ac))]
[(and (imm32? src) (eq? dst '%eax)) (CODE #x2D (IMM32 src ac))]
[(and (imm32? src) (eq? dst '%eax)) (C #x2D (IMM32 src ac))]
[(and (imm32? src) (reg? dst)) (CR* #x81 '/5 dst (IMM32 src ac))]
[(and (reg? src) (reg? dst)) (CR* #x29 src dst ac)]
[(and (mem? src) (reg? dst)) (CR* #x2B dst src ac)]

2
scheme/last-revision
View File

@ -1 +1 @@
1441
1442

96
scheme/test64.ss
View File

@ -101,10 +101,14 @@
[char->fixnum $char->fixnum]
[procedure? procedure?]
[fxzero? $fxzero?]
[vector vector]
[symbol? symbol?]
))
(define (fixup x)
(define (P x)
`(primitive ,x))
(define (Expr x env)
(match x
[,n (guard (self-evaluating? n)) `(quote ,n)]
@ -130,6 +134,22 @@
,(map (lambda (x) (Expr x env)) body*)
...)])
,rhs* ...)))]
[(letrec ([,lhs* ,rhs*] ...) ,body ,body* ...)
(let* ([nlhs* (map gensym lhs*)]
[env (append (map cons lhs* nlhs*) env)]
[E (lambda (x) (Expr x env))])
`(letrec ([,nlhs* ,(map E rhs*)] ...)
(begin
,(E body)
,(map E body*) ...)))]
[(letrec* ([,lhs* ,rhs*] ...) ,body ,body* ...)
(let* ([nlhs* (map gensym lhs*)]
[env (append (map cons lhs* nlhs*) env)]
[E (lambda (x) (Expr x env))])
`(letrec* ([,nlhs* ,(map E rhs*)] ...)
(begin
,(E body)
,(map E body*) ...)))]
[(lambda (,fml* ...) ,body ,body* ...)
(let ([g* (map gensym fml*)])
(let ([env (append (map cons fml* g*) env)])
@ -138,8 +158,77 @@
(begin ,(Expr body env)
,(map (lambda (x) (Expr x env)) body*)
...)])))]
[(lambda (,fml* ... . ,fml) ,body ,body* ...)
(let ([g* (map gensym fml*)]
[g (gensym fml)])
(let ([env (append (map cons
(cons fml fml*)
(cons g g*))
env)])
`(case-lambda
[(,g* ... . ,g)
(begin ,(Expr body env)
,(map (lambda (x) (Expr x env)) body*)
...)])))]
[(begin ,[e] ,[e*] ...)
`(begin ,e ,e* ...)]
[(and) ''#t]
[(and ,[e]) e]
[(and ,[e] ,e* ...)
`(if ,e ,(Expr `(and ,e* ...) env) (quote #f))]
[(or) ''#f]
[(or ,[e]) e]
[(or ,[e] ,e* ...)
(let ([t (gensym)])
`((case-lambda
[(,t)
(if ,t ,t ,(Expr `(or ,e* ...) env))])
,e))]
[(when ,[e] ,[b] ,[b*] ...)
`(if ,e
(begin ,b ,b* ...)
(,(P 'void)))]
[(unless ,[e] ,[b] ,[b*] ...)
`(if (,(P 'not) ,e)
(begin ,b ,b* ...)
(,(P 'void)))]
[(cond) `(,(P 'void))]
[(cond ,cls* ... ,cls)
(let ()
(define (fst-clause x rest)
(match x
[(,e ,arr ,v)
(guard (and (eq? arr '=>) (not (assq arr env))))
(let ([t (gensym)])
`((case-lambda
[(,t)
(if ,t (,(Expr v env) ,t) ,rest)])
,(Expr e env)))]
[(,e)
(let ([t (gensym)])
`((case-lambda
[(,t)
(if ,t ,t ,rest)])
,(Expr e env)))]
[(,e ,e* ...)
`(if ,(Expr e env)
(begin ,(map (lambda (x) (Expr x env)) e*) ...)
,rest)]
[,others (error 'cond "invalid clause" others)]))
(define (last-clause x)
(match x
[(,els ,e ,e* ...)
(guard (and (eq? els 'else) (not (assq els env))))
`(begin ,(Expr e env)
,(map (lambda (x) (Expr x env)) e*)
...)]
[,others
(fst-clause others `(,(P 'void)))]))
(let f ([cls* cls*] [ac (last-clause cls)])
(cond
[(null? cls*) ac]
[else (fst-clause (car cls*)
(f (cdr cls*) ac))])))]
[(set! ,x ,[v])
(cond
[(assq x env) => (lambda (p) `(set! ,(cdr p) ,v))]
@ -168,13 +257,16 @@
(include "tests/tests-1.9-req.scm")
(include "tests/tests-2.1-req.scm")
(include "tests/tests-2.2-req.scm")
(include "tests/tests-2.3-req.scm"))
(include "tests/tests-2.3-req.scm")
(include "tests/tests-2.4-req.scm")
(include "tests/tests-2.6-req.scm")
(include "tests/tests-2.8-req.scm"))
(current-primitive-locations
(lambda (x)
(define prims
'(do-overflow
do-vararg-overflow
error
$do-event
$apply-nonprocedure-error-handler

17
src/ikarus-print.c
View File

@ -84,7 +84,9 @@ print(FILE* fh, ikptr x){
}
#endif
else if(tagof(x) == vector_tag){
ikptr len = ref(x, off_vector_length);
ikptr fst = ref(x, off_vector_length);
if(is_fixnum(fst)){
ikptr len = fst;
if(len == 0){
fprintf(fh, "#()");
} else {
@ -99,6 +101,19 @@ print(FILE* fh, ikptr x){
}
fprintf(fh, ")");
}
} else if (fst == symbol_record_tag){
ikptr str = ref(x, off_symbol_record_string);
ikptr fxlen = ref(str, off_string_length);
int len = unfix(fxlen);
int * data = (int*)(str + off_string_data);
int i;
for(i=0; i<len; i++){
char c = (data[i]) >> char_shift;
fprintf(fh, "%c", c);
}
} else {
fprintf(fh, "#<unknown fst=0x%p>", (void*)fst);
}
}
else if(is_closure(x)){
fprintf(fh, "#<procedure>");