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

passing tests-1.5

This commit is contained in:
Abdulaziz Ghuloum 2008-01-04 04:41:20 -05:00
parent 71fcccd764
commit 976694a3ab
3 changed files with 48 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2143,6 +2143,14 @@
(S* (cdr ls) (S* (cdr ls)
(lambda (d) (lambda (d)
(k (cons a 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) (define (mem? x)
(or (disp? x) (fvar? x))) (or (disp? x) (fvar? x)))
;;; unspillable effect ;;; unspillable effect
@ -2158,6 +2166,13 @@
(cond (cond
[(and (eq? op 'move) (eq? a b)) [(and (eq? op 'move) (eq? a b))
(make-primcall 'nop '())] (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)) [(and (mem? a) (mem? b))
(let ([u (mku)]) (let ([u (mku)])
(make-seq (make-seq

2
scheme/last-revision
View File

@ -1 +1 @@
1322 1323

41
scheme/test64.ss
View File

@ -53,16 +53,38 @@
(define (self-evaluating? x) (define (self-evaluating? x)
(or (number? x) (char? x) (boolean? x) (null? x) (string? x))) (or (number? x) (char? x) (boolean? x) (null? x) (string? x)))
(define (primitive? x) (define prims-alist
(memq x '($fxadd1 $fxsub1 $fixnum->char $char->fixnum fixnum? $fxzero? '([$fxadd1 $fxadd1]
null? boolean? char? not $fxlognot))) [$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) (define (fixup x)
(match x (match x
[,n (guard (self-evaluating? n)) `(quote ,n)] [,n (guard (self-evaluating? n)) `(quote ,n)]
[(,prim ,[args] ...) [(,prim ,[args] ...)
(guard (primitive? prim)) (guard (assq prim prims-alist))
`((primitive ,prim) ,args ...)] `((primitive ,(cadr (assq prim prims-alist))) ,args ...)]
[(if ,[e0] ,[e1] ,[e2]) [(if ,[e0] ,[e1] ,[e2])
`(if ,e0 ,e1 ,e2)] `(if ,e0 ,e1 ,e2)]
[,_ (error 'fixup "invalid expression" _)])) [,_ (error 'fixup "invalid expression" _)]))
@ -77,10 +99,11 @@
(list (fixup 'test) string) (list (fixup 'test) string)
...)))]))) ...)))])))
(include "tests/tests-1.1-req.scm") ;(include "tests/tests-1.1-req.scm")
(include "tests/tests-1.2-req.scm") ;(include "tests/tests-1.2-req.scm")
(include "tests/tests-1.3-req.scm") ;(include "tests/tests-1.3-req.scm")
(include "tests/tests-1.4-req.scm") ;(include "tests/tests-1.4-req.scm")
(include "tests/tests-1.5-req.scm")
(test-all) (test-all)
(printf "Passed ~s tests\n" (length all-tests)) (printf "Passed ~s tests\n" (length all-tests))