From 866b2b1c176fd6598d162399a25917aede9b01ba Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Wed, 9 Apr 2008 05:34:36 -0400 Subject: [PATCH] Now passing 682 tests in 64-bit mode. --- scheme/ikarus.compiler.altcogen.ss | 10 ++++ scheme/ikarus.intel-assembler.ss | 9 +-- scheme/last-revision | 2 +- scheme/test64.ss | 96 +++++++++++++++++++++++++++++- src/ikarus-print.c | 41 +++++++++---- 5 files changed, 138 insertions(+), 20 deletions(-) diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index 5f37a15..9ee0af0 100644 --- a/scheme/ikarus.compiler.altcogen.ss +++ b/scheme/ikarus.compiler.altcogen.ss @@ -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 diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index 6239edc..787ff34 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/scheme/ikarus.intel-assembler.ss @@ -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)] diff --git a/scheme/last-revision b/scheme/last-revision index 4d851a7..45917ca 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1441 +1442 diff --git a/scheme/test64.ss b/scheme/test64.ss index 48f315a..c95dc06 100755 --- a/scheme/test64.ss +++ b/scheme/test64.ss @@ -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 diff --git a/src/ikarus-print.c b/src/ikarus-print.c index 8299527..17ec413 100644 --- a/src/ikarus-print.c +++ b/src/ikarus-print.c @@ -84,20 +84,35 @@ print(FILE* fh, ikptr x){ } #endif else if(tagof(x) == vector_tag){ - ikptr len = ref(x, off_vector_length); - if(len == 0){ - fprintf(fh, "#()"); - } else { - fprintf(fh, "#("); - ikptr data = x + off_vector_data; - print(fh, ref(data, 0)); - ikptr i = (ikptr)wordsize; - while(i> char_shift; + fprintf(fh, "%c", c); + } + } else { + fprintf(fh, "#", (void*)fst); } } else if(is_closure(x)){