Now passing 682 tests in 64-bit mode.

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

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

scheme/last-revision

@@ -1 +1 @@
-1441
+1442

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 

src/ikarus-print.c

@@ -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>");