summaryrefslogtreecommitdiff
path: root/test-suite/standalone/sassy/tests/run-tests.scm
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/standalone/sassy/tests/run-tests.scm')
-rw-r--r--test-suite/standalone/sassy/tests/run-tests.scm541
1 files changed, 541 insertions, 0 deletions
diff --git a/test-suite/standalone/sassy/tests/run-tests.scm b/test-suite/standalone/sassy/tests/run-tests.scm
new file mode 100644
index 000000000..d10db1e1b
--- /dev/null
+++ b/test-suite/standalone/sassy/tests/run-tests.scm
@@ -0,0 +1,541 @@
+ ;=========================;
+ ; ;
+ ; Sassy test suite ;
+ ; ;
+ ;=========================;
+
+; The three files generate-nasm.scm, generate-prims.scm, and
+; generate-direc.scm generate the baselines for these tests. Of the
+; three, only generate-nasm.scm should really ever be run again unless
+; Sassy's language actually changes, since the corectness of the output
+; for generate-prims and generate-direc has to be verified by hand.
+
+; (generate-nasm generates nasm versions of the Sassy code and assembles
+; them by calling nasm -f bin ??. For mzscheme)
+
+(define %%%include-test '((entry foo)))
+
+(define (sassy-run-tests . args)
+
+ (define (sassy-symbol-get r n)
+ (hash-table-ref (sassy-symbol-table r) n))
+
+ (define (sassy-reloc->list reloc)
+ (list (sassy-reloc-name reloc)
+ (sassy-reloc-section reloc)
+ (sassy-reloc-offset reloc)
+ (sassy-reloc-type reloc)))
+
+ (define (file-chars->list file)
+ (with-input-from-file file
+ (lambda ()
+ (let iter ((new (read-byte)))
+ (if (eof-object? new)
+ '()
+ (cons new (iter (read-byte))))))))
+
+ (define (l->hex lst)
+ (map (lambda (x)
+ (number->string x 16))
+ lst))
+
+ (define (match-lists subl longl)
+ (let iter ((rs subl)
+ (rl longl))
+ (cond ((null? rs) rl)
+ ((= (car rs) (car rl))
+ (iter (cdr rs) (cdr rl)))
+ (else (newline)
+ (display (l->hex subl))
+ (newline)
+ (display (l->hex longl))
+ (newline)
+ #f))))
+
+ (define (match-opcodes l1 l2)
+ (cond ((and (null? l1) (null? l2)) #t)
+ ((or (null? l1) (null? l2)) #f)
+ ((= (car l1) (car l2)) (match-opcodes (cdr l1) (cdr l2)))
+ ;be forgiving about prefixes
+ ((and (not (null? (cdr l1)))
+ (not (null? (cdr l2)))
+ (or (and (= (car l1) #x66) (= (cadr l1) #x67)
+ (= (car l2) #x67) (= (cadr l2) #x66))
+ (and (= (car l1) #x67) (= (cadr l1) #x66)
+ (= (car l2) #x66) (= (cadr l2) #x67))))
+ (match-opcodes (cddr l1) (cddr l2)))
+ (else #f)))
+
+
+ (define (sassy-raw c bits32?)
+ (sassy-text-list
+ (sassy (if bits32?
+ `((text (label foo)
+ (begin ,@c)))
+ `((bits 16)
+ (text (label foo)
+ (begin ,@c)))))))
+
+ (define (succeed x)
+ (display "test passed: ")
+ (display x)
+ (newline))
+
+ (define (fail x)
+ (display "TEST FAILED: ")
+ (display x)
+ (newline))
+
+
+;============================================================================;
+; opcode-test ;
+; ================ ;
+; The opcode tests are fairly exhaustive. Every opcode is tested, and ;
+; every possible successful parse, whether the opcode(s) use a "gen-" ;
+; template or has its own. The output is compared to NASM's. ;
+;============================================================================;
+ (define (opcode-test bits32?)
+ (newline)
+ (for-each
+ (lambda (x)
+ (let* ((the-codes (with-input-from-file x (lambda () (read))))
+ (sassy-res (sassy-raw the-codes bits32?))
+ (nasm-res (file-chars->list
+ (string-append
+ (substring x 0 (- (string-length x) 4))
+ (if bits32? "" "16")))))
+ (if (match-opcodes nasm-res sassy-res)
+ (succeed (if bits32? x (string-append "(16 bit) " x)))
+ (begin (fail (if bits32? x (string-append "(16 bit) " x)))
+ (let iter ((codes the-codes))
+ (let ((foo (match-lists
+ (sassy-raw (list (car codes)) bits32?)
+ nasm-res)))
+ (if foo
+ (begin (set! nasm-res foo)
+ (iter (cdr codes)))
+ (begin (display (car codes))
+ (newline)))))
+ (error "")))))
+ (if bits32?
+ the-opcode-files
+ the-opcode16-files)))
+
+ (define the-opcode-files
+ (list "tests/mem-ref.scm"
+ "tests/non.scm"
+ "tests/alu.scm"
+ "tests/bt.scm"
+ "tests/shift.scm"
+ "tests/setcc.scm"
+ "tests/cmovcc.scm"
+ "tests/decinc.scm"
+ "tests/plier.scm"
+ "tests/load.scm"
+ "tests/movx.scm"
+ "tests/r-rm.scm"
+ "tests/rm.scm"
+ "tests/rm2.scm"
+ "tests/aa.scm"
+ "tests/ret.scm"
+ "tests/doub-shift.scm"
+ "tests/cmpx.scm"
+ "tests/misc1.scm"
+ "tests/misc2.scm"
+ "tests/misc3.scm"
+ "tests/jcc.scm"
+ "tests/jumps.scm"
+ "tests/prefix.scm"
+ "tests/fp0.scm"
+ "tests/fp1.scm"
+ "tests/fp2.scm"
+ "tests/fp3.scm"
+ "tests/mmx.scm"
+ "tests/sse1.scm"
+ "tests/sse2.scm"
+ "tests/sse3.scm"
+ "tests/seg.scm"
+ "tests/brt.scm"
+ ))
+
+ (define the-opcode16-files
+ (list
+ "tests/alu.scm"
+ "tests/bt.scm"
+ "tests/cmpx.scm"
+ "tests/decinc.scm"
+ "tests/doub-shift.scm"
+ "tests/jcc.scm"
+ "tests/jumps.scm"
+ "tests/load.scm"
+ "tests/mem-ref.scm"
+ "tests/misc1.scm"
+ "tests/misc2.scm"
+ "tests/movx.scm"
+ "tests/non.scm"
+ "tests/plier.scm"
+ "tests/prefix.scm"
+ "tests/ret.scm"
+ "tests/rm2.scm"
+ "tests/rm.scm"
+ "tests/r-rm.scm"
+ "tests/setcc.scm"
+ "tests/shift.scm"
+ "tests/seg.scm"))
+
+
+;================================;
+; direc-test ;
+; ========== ;
+; The basic functionality ;
+;================================;
+
+ (define (direc-test)
+ (newline)
+ (test-export)
+ (test-import)
+ (test-heap)
+ (test-misc)
+ (test-data)
+ (test-data-locals)
+ (test-data-reloc))
+
+ (define (test-export)
+ (let ((o (sassy '((export foo quux)
+ (text (label bar (pop eax))
+ (label wizo (push eax)))
+ (export wizo)))))
+ (or (and (eqv? 'export (sassy-symbol-scope (sassy-symbol-get o 'foo)))
+ (eqv? 'export (sassy-symbol-scope (sassy-symbol-get o 'quux)))
+ (eqv? 'export (sassy-symbol-scope (sassy-symbol-get o 'wizo)))
+ (eqv? 'local (sassy-symbol-scope (sassy-symbol-get o 'bar)))
+ (succeed "exports"))
+ (fail "exports"))))
+
+ (define (test-import)
+ (let ((o (sassy '((export bar)
+ (import wizo)
+ (text (label bar (pop eax))
+ (label foo (push edx)))
+ (import qadr)))))
+ (or (and (eqv? 'export (sassy-symbol-scope (sassy-symbol-get o 'bar)))
+ (eqv? 'import (sassy-symbol-scope (sassy-symbol-get o 'wizo)))
+ (eqv? 'import (sassy-symbol-scope (sassy-symbol-get o 'qadr)))
+ (eqv? 'local (sassy-symbol-scope (sassy-symbol-get o 'foo)))
+ (succeed "imports"))
+ (fail "imports"))))
+
+ (define (test-heap)
+ (let ((o (sassy '((heap (align 128)
+ (label foo (bytes 5))
+ (words 32)
+ (align 16)
+ (label bar (dwords 100)))))))
+ (or (and (= 480 (sassy-heap-size o))
+ (= 128 (sassy-heap-align o))
+ (let ((foo-s (sassy-symbol-get o 'foo)))
+ (and (= 0 (sassy-symbol-offset foo-s))
+ (= 5 (sassy-symbol-size foo-s))))
+ (let ((bar-s (sassy-symbol-get o 'bar)))
+ (and (= 80 (sassy-symbol-offset bar-s))
+ (= 400 (sassy-symbol-size bar-s))))
+ (succeed "heap"))
+ (fail "heap"))))
+
+ (define (test-misc)
+ (let ((o (sassy '((org 1000)
+ (include %%%include-test "tests/include.scm")))))
+ (succeed "include")
+ (and (or (and (eqv? 'foo (sassy-entry-point o))
+ (succeed "entry"))
+ (fail "entry"))
+ (or (and (= 1000 (sassy-text-org o))
+ (= 1024 (sassy-symbol-offset (sassy-symbol-get o 'foo)))
+ (succeed "org"))
+ (fail "org"))
+ (or (and (= 32 (sassy-text-align o))
+ (equal? (sassy-text-list o)
+ (append (make-list 24 #x90) (list 80)))
+ (succeed "text-align"))
+ (fail "text-align")))))
+
+ (define (test-data)
+ (let ((o (sassy '((data (label foo (dwords "ab"))
+ (align 8)
+ (label bar (dwords 100 quux))
+ (dwords -3242.52)
+ (qwords -84930284902.48392048)
+ (label quux (dwords -1 #\A bar)))))))
+ (and (or (and (= 40 (sassy-data-size o))
+ (= 8 (sassy-data-align o))
+ (succeed "data-align"))
+ (fail "data-align"))
+ (or (and (= 4 (sassy-symbol-size (sassy-symbol-get o 'foo)))
+ (= 0 (sassy-symbol-offset (sassy-symbol-get o 'foo)))
+ (= 8 (sassy-symbol-size (sassy-symbol-get o 'bar)))
+ (= 8 (sassy-symbol-offset (sassy-symbol-get o 'bar)))
+ (= 12 (sassy-symbol-size (sassy-symbol-get o 'quux)))
+ (= 28 (sassy-symbol-offset (sassy-symbol-get o 'quux)))
+ (equal? (sassy-data-list o)
+ '(97 98 0 0 0 0 0 0 100 0 0 0 28 0 0 0 82
+ 168 74 197 226 123 102 77 61 198 51
+ 194 255 255 255 255 65 0 0 0 8 0 0 0))
+ (succeed "data"))
+ (fail "data")))))
+
+ (define (test-data-locals)
+ (let ((o (sassy '((data
+ (dwords 0)
+ (label foo (dwords "abcd" "efgh"))
+ (locals (foo)
+ (label foo
+ (dwords #xeeeeeeee #xffffffff)
+ (dwords foo)))
+ (dwords foo))))))
+ (if (equal? (sassy-data-list o)
+ '(0 0 0 0 97 98 99 100 101 102 103 104 238 238 238 238 255
+ 255 255 255 12 0 0 0 4 0 0 0))
+ (succeed "data-locals")
+ (fail "data-locals"))))
+
+ (define (test-data-reloc)
+ (let ((o (sassy '((data (dwords 100 (reloc abs $here 8))
+ (label foo (dwords (reloc abs $here)
+ (reloc blah quux))))
+ (text
+ (begin (push eax)
+ (nop)
+ (nop)
+ (nop))
+ (label quux (push edx)))))))
+ (or (and (equal? (sassy-data-list o)
+ '(100 0 0 0 12 0 0 0 8 0 0 0 4 0 0 0))
+ (equal? '(quux data 12 blah)
+ (sassy-reloc->list (car (sassy-reloc-list o))))
+ (equal? '(#f data 8 abs)
+ (sassy-reloc->list (cadr (sassy-reloc-list o))))
+ (equal? '(#f data 4 abs)
+ (sassy-reloc->list (caddr (sassy-reloc-list o))))
+ (succeed "data-reloc"))
+ (fail "data-reloc"))))
+
+;============================================================================;
+; prim-test ;
+; ========= ;
+; A series of several short tests of some probably (hopefully) common ;
+; usage idioms of the primitives. ;
+;============================================================================;
+ (define (prim-test)
+ (newline)
+ (for-each
+ (lambda (x)
+ (let* ((goal (file-chars->list
+ (substring x 0 (- (string-length x) 4))))
+ (source (sassy-text-list (sassy x))))
+ (if (equal? goal source)
+ (succeed x)
+ (begin (fail x)
+ (error "")))))
+ the-prim-files))
+
+ (define the-prim-files
+ (list "tests/prims/seq1.scm"
+ "tests/prims/seq2.scm"
+ "tests/prims/seq3.scm"
+ "tests/prims/alt1.scm"
+ "tests/prims/alt2.scm"
+ "tests/prims/alt3.scm"
+ "tests/prims/alt4.scm"
+ "tests/prims/begin1.scm"
+ "tests/prims/begin2.scm"
+ "tests/prims/begin3.scm"
+ "tests/prims/begin4.scm"
+ "tests/prims/begin5.scm"
+ "tests/prims/if1.scm"
+ "tests/prims/if2.scm"
+ "tests/prims/if3.scm"
+ "tests/prims/if4.scm"
+ "tests/prims/inv1.scm"
+ "tests/prims/inv2.scm"
+ "tests/prims/inv3.scm"
+ "tests/prims/inv4.scm"
+ "tests/prims/inv5.scm"
+ "tests/prims/inv6.scm"
+ "tests/prims/iter1.scm"
+ "tests/prims/iter2.scm"
+ "tests/prims/iter3.scm"
+ "tests/prims/iter4.scm"
+ "tests/prims/iter5.scm"
+ "tests/prims/iter6.scm"
+ "tests/prims/leap-mark1.scm"
+ "tests/prims/leap-mark2.scm"
+ "tests/prims/leap-mark3.scm"
+ "tests/prims/while1.scm"
+ "tests/prims/while2.scm"
+ "tests/prims/while3.scm"
+ "tests/prims/with-win1.scm"
+ "tests/prims/with-win2.scm"
+ "tests/prims/with-win3.scm"
+ "tests/prims/with-win4.scm"
+ "tests/prims/with-win5.scm"
+ "tests/prims/with-lose1.scm"
+ "tests/prims/with-lose2.scm"
+ "tests/prims/with-lose3.scm"
+ "tests/prims/with-win-lose1.scm"
+ "tests/prims/with-win-lose2.scm"
+ "tests/prims/with-win-lose3.scm"
+ "tests/prims/with-win-lose4.scm"
+ "tests/prims/with-win-lose5.scm"
+ "tests/prims/exp-k1.scm"
+ "tests/prims/exp-k2.scm"
+ "tests/prims/exp-k3.scm"
+ "tests/prims/exp-k4.scm"
+ "tests/prims/esc1.scm"
+ "tests/prims/esc2.scm"
+ "tests/prims/esc3.scm"
+ "tests/prims/esc4.scm"
+ "tests/prims/esc5.scm"
+ "tests/prims/esc6.scm"
+ "tests/prims/esc7.scm"
+ "tests/prims/label1.scm"
+ "tests/prims/label2.scm"
+ "tests/prims/label3.scm"
+ "tests/prims/label4.scm"
+ "tests/prims/locals1.scm"
+ "tests/prims/locals2.scm"
+ "tests/prims/locals3.scm"
+ "tests/prims/locals4.scm"
+ "tests/prims/locals5.scm"
+ "tests/prims/locals6.scm"
+ "tests/prims/locals7.scm"
+ "tests/prims/locals8.scm"
+
+
+ "tests/prims16/16alt1.scm"
+ "tests/prims16/16alt2.scm"
+ "tests/prims16/16alt3.scm"
+ "tests/prims16/16alt4.scm"
+ "tests/prims16/16begin1.scm"
+ "tests/prims16/16begin2.scm"
+ "tests/prims16/16begin3.scm"
+ "tests/prims16/16begin4.scm"
+ "tests/prims16/16begin5.scm"
+ "tests/prims16/16if1.scm"
+ "tests/prims16/16if2.scm"
+ "tests/prims16/16if3.scm"
+ "tests/prims16/16if4.scm"
+ "tests/prims16/16inv1.scm"
+ "tests/prims16/16inv2.scm"
+ "tests/prims16/16inv3.scm"
+ "tests/prims16/16inv4.scm"
+ "tests/prims16/16inv5.scm"
+ "tests/prims16/16inv6.scm"
+ "tests/prims16/16iter1.scm"
+ "tests/prims16/16iter2.scm"
+ "tests/prims16/16iter3.scm"
+ "tests/prims16/16iter4.scm"
+ "tests/prims16/16iter5.scm"
+ "tests/prims16/16iter6.scm"
+ "tests/prims16/16exp-k1.scm"
+ "tests/prims16/16exp-k2.scm"
+ "tests/prims16/16exp-k3.scm"
+ "tests/prims16/16exp-k4.scm"
+ "tests/prims16/16label1.scm"
+ "tests/prims16/16label2.scm"
+ "tests/prims16/16label3.scm"
+ "tests/prims16/16label4.scm"
+ "tests/prims16/16leap-mark1.scm"
+ "tests/prims16/16leap-mark2.scm"
+ "tests/prims16/16leap-mark3.scm"
+ "tests/prims16/16locals1.scm"
+ "tests/prims16/16locals2.scm"
+ "tests/prims16/16locals3.scm"
+ "tests/prims16/16locals4.scm"
+ "tests/prims16/16locals5.scm"
+ "tests/prims16/16locals6.scm"
+ "tests/prims16/16locals7.scm"
+ "tests/prims16/16locals8.scm"
+ "tests/prims16/16seq1.scm"
+ "tests/prims16/16seq2.scm"
+ "tests/prims16/16seq3.scm"
+ "tests/prims16/16while1.scm"
+ "tests/prims16/16while2.scm"
+ "tests/prims16/16while3.scm"
+ "tests/prims16/16with-lose1.scm"
+ "tests/prims16/16with-lose2.scm"
+ "tests/prims16/16with-lose3.scm"
+ "tests/prims16/16with-win1.scm"
+ "tests/prims16/16with-win2.scm"
+ "tests/prims16/16with-win3.scm"
+ "tests/prims16/16with-win4.scm"
+ "tests/prims16/16with-win5.scm"
+ "tests/prims16/16with-win-lose1.scm"
+ "tests/prims16/16with-win-lose2.scm"
+ "tests/prims16/16with-win-lose3.scm"
+ "tests/prims16/16with-win-lose4.scm"
+ "tests/prims16/16with-win-lose5.scm"
+
+ ))
+
+;============================================================================;
+; elf-test ;
+; ========= ;
+; A series of several short tests of some probably (hopefully) common ;
+; usage idioms of the primitives. ;
+;============================================================================;
+ (define (elf-test)
+ (newline)
+ (for-each
+ (lambda (x)
+ (let* ((source-name
+ (string-append
+ (substring x 0 (- (string-length x) 4))
+ ".new.o"))
+ (goal (file-chars->list
+ (string-append
+ (substring x 0 (- (string-length x) 4))
+ ".o")))
+ (source (begin (sassy-make-elf source-name
+ (sassy x))
+ (file-chars->list source-name))))
+ (if (equal? goal source)
+ (succeed x)
+ (begin (fail x)
+ (error "")))))
+ the-elf-files))
+
+ (define the-elf-files
+ (list "tests/sysexit.scm"
+ "tests/fac5.scm"
+ "tests/cell.scm"
+
+ "tests/sysexit2.scm" ; static linking
+ "tests/count.scm"
+
+ "tests/libhello.scm" ; dynamic linking
+ "tests/libgoodbye.scm"
+ "tests/hello.scm"
+ "tests/bye.scm"
+
+ "tests/localdata1.scm"
+ "tests/localdata2.scm"
+ "tests/localdata3.scm"
+ "tests/localdata4.scm"
+
+ "tests/sect.scm")) ; sections of anon relocs
+
+ (if (eqv? 'all (car args))
+ (begin (opcode-test #t)
+ (opcode-test #f)
+ (prim-test)
+ (direc-test)
+ (elf-test))
+ (let iter ((r args))
+ (if (not (null? r))
+ (begin (case (car r)
+ ((opcodes) (opcode-test #t))
+ ((opcodes16) (opcode-test #f))
+ ((prims) (prim-test))
+ ((direcs) (direc-test))
+ ((elf) (elf-test)))
+ (iter (cdr r)))))))
View Lorry Controller Status