From 976694a3aba389c8fb6cc4dfe893e7bed48c874f Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Fri, 4 Jan 2008 04:41:20 -0500
Subject: [PATCH] passing tests-1.5

---
 scheme/ikarus.compiler.altcogen.ss | 15 +++++++++++
 scheme/last-revision               |  2 +-
 scheme/test64.ss                   | 41 +++++++++++++++++++++++-------
 3 files changed, 48 insertions(+), 10 deletions(-)

diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss
index 79e5fb4..45658f3 100644
--- a/scheme/ikarus.compiler.altcogen.ss
+++ b/scheme/ikarus.compiler.altcogen.ss
@@ -2143,6 +2143,14 @@
               (S* (cdr ls) 
                   (lambda (d)
                     (k (cons a d))))))]))
+    (define (long-imm? x) 
+      (struct-case x 
+        [(constant n) 
+         (cond
+           [(integer? n) 
+            (not (<= (- (expt 2 31)) n (- (expt 2 31) 1)))]
+           [else #t])]
+        [else #f]))
     (define (mem? x)
       (or (disp? x) (fvar? x)))
     ;;; unspillable effect
@@ -2158,6 +2166,13 @@
             (cond
               [(and (eq? op 'move) (eq? a b)) 
                (make-primcall 'nop '())]
+              [(and (= wordsize 8) 
+                    (not (eq? op 'move)) 
+                    (long-imm? b))
+               (let ([u (mku)])
+                 (make-seq
+                   (E (make-asm-instr 'move u b))
+                   (E (make-asm-instr op a u))))]
               [(and (mem? a) (mem? b)) 
                (let ([u (mku)])
                  (make-seq
diff --git a/scheme/last-revision b/scheme/last-revision
index 0c9a077..f011551 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1322
+1323
diff --git a/scheme/test64.ss b/scheme/test64.ss
index 80337fd..c74b8d5 100755
--- a/scheme/test64.ss
+++ b/scheme/test64.ss
@@ -53,16 +53,38 @@
 (define (self-evaluating? x)
   (or (number? x) (char? x) (boolean? x) (null? x) (string? x)))
 
-(define (primitive? x)
-  (memq x '($fxadd1 $fxsub1 $fixnum->char $char->fixnum fixnum? $fxzero?
-            null? boolean? char? not $fxlognot)))
+(define prims-alist
+  '([$fxadd1 $fxadd1]
+    [$fxsub1 $fxsub1]
+    [$fixnum->char $fixnum->char]
+    [$char->fixnum $char->fixnum]
+    [fixnum? fixnum?]
+    [$fxzero? $fxzero?]
+    [null? null?]
+    [boolean? boolean?]
+    [char? char?]
+    [not not]
+    [$fxlognot $fxlognot]
+    [fx+ $fx+]
+    [fx- $fx-]
+    [fx* $fx*]
+    [fxlogor $fxlogor]
+    [fxlogand $fxlogand]
+    [fxlognot $fxlognot]
+    [fx= $fx=]
+    [fx< $fx<]
+    [fx<= $fx<=]
+    [fx> $fx>]
+    [fx>= $fx>=]
+    ))
+
 
 (define (fixup x)
   (match x
     [,n (guard (self-evaluating? n)) `(quote ,n)]
     [(,prim ,[args] ...) 
-     (guard (primitive? prim))
-     `((primitive ,prim) ,args ...)]
+     (guard (assq prim prims-alist))
+     `((primitive ,(cadr (assq prim prims-alist))) ,args ...)]
     [(if ,[e0] ,[e1] ,[e2]) 
      `(if ,e0 ,e1 ,e2)]
     [,_ (error 'fixup "invalid expression" _)]))
@@ -77,10 +99,11 @@
                 (list (fixup 'test) string) 
                 ...)))])))
 
-(include "tests/tests-1.1-req.scm")
-(include "tests/tests-1.2-req.scm")
-(include "tests/tests-1.3-req.scm")
-(include "tests/tests-1.4-req.scm")
+;(include "tests/tests-1.1-req.scm")
+;(include "tests/tests-1.2-req.scm")
+;(include "tests/tests-1.3-req.scm")
+;(include "tests/tests-1.4-req.scm")
+(include "tests/tests-1.5-req.scm")
 
 (test-all)
 (printf "Passed ~s tests\n" (length all-tests))