Commit | Line | Data |
---|---|---|
ba7e7139 | 1 | ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*- |
53e28ed9 AW |
2 | ;;;; |
3 | ;;;; This library is free software; you can redistribute it and/or | |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
53e28ed9 AW |
7 | ;;;; |
8 | ;;;; This library is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | ;;;; Lesser General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU Lesser General Public | |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
16 | ||
17 | (define-module (test-suite tests asm-to-bytecode) | |
07d22c02 | 18 | #:use-module (rnrs bytevectors) |
bde92e6b | 19 | #:use-module ((rnrs io ports) #:select (open-bytevector-output-port)) |
53e28ed9 AW |
20 | #:use-module (test-suite lib) |
21 | #:use-module (system vm instruction) | |
89f9dd70 | 22 | #:use-module (language assembly) |
6f787028 | 23 | #:use-module (language assembly compile-bytecode)) |
53e28ed9 | 24 | |
ccf77d95 AW |
25 | (define (->u8-list sym val) |
26 | (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) | |
27 | (uint32 4 ,bytevector-u32-native-set!)) | |
28 | sym))) | |
29 | (or entry (error "unknown sym" sym)) | |
30 | (let ((bv (make-bytevector (car entry)))) | |
31 | ((cadr entry) bv 0 val) | |
32 | (bytevector->u8-list bv)))) | |
33 | ||
53e28ed9 | 34 | (define (munge-bytecode v) |
ccf77d95 AW |
35 | (let lp ((i 0) (out '())) |
36 | (if (= i (vector-length v)) | |
bde92e6b | 37 | (u8-list->bytevector (reverse out)) |
ccf77d95 AW |
38 | (let ((x (vector-ref v i))) |
39 | (cond | |
40 | ((symbol? x) | |
41 | (lp (1+ i) (cons (instruction->opcode x) out))) | |
42 | ((integer? x) | |
43 | (lp (1+ i) (cons x out))) | |
44 | ((pair? x) | |
45 | (lp (1+ i) (append (reverse (apply ->u8-list x)) out))) | |
46 | (else (error "bad test bytecode" x))))))) | |
53e28ed9 AW |
47 | |
48 | (define (comp-test x y) | |
bde92e6b LC |
49 | (let* ((y (munge-bytecode y)) |
50 | (len (bytevector-length y)) | |
51 | (v #f)) | |
52 | ||
53e28ed9 AW |
53 | (run-test `(length ,x) #t |
54 | (lambda () | |
89f9dd70 AW |
55 | (let* ((wrapped `(load-program () ,(byte-length x) #f ,x)) |
56 | (bv (compile-bytecode wrapped '()))) | |
57 | (set! v (make-bytevector (- (bytevector-length bv) 8))) | |
58 | (bytevector-copy! bv 8 v 0 (bytevector-length v)) | |
59 | (= (bytevector-length v) len)))) | |
53e28ed9 AW |
60 | (run-test `(compile-equal? ,x ,y) #t |
61 | (lambda () | |
62 | (equal? v y))))) | |
63 | ||
44362a10 | 64 | \f |
53e28ed9 AW |
65 | (with-test-prefix "compiler" |
66 | (with-test-prefix "asm-to-bytecode" | |
67 | ||
68 | (comp-test '(make-int8 3) | |
69 | #(make-int8 3)) | |
70 | ||
53e28ed9 AW |
71 | (comp-test '(load-number "3.14") |
72 | (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.) | |
73 | (char->integer #\1) (char->integer #\4))) | |
74 | ||
75 | (comp-test '(load-string "foo") | |
94ff26b9 | 76 | (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o) |
53e28ed9 AW |
77 | (char->integer #\o))) |
78 | ||
79 | (comp-test '(load-symbol "foo") | |
94ff26b9 | 80 | (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) |
53e28ed9 | 81 | (char->integer #\o))) |
1caa6341 | 82 | |
ba7e7139 | 83 | (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string |
1caa6341 LC |
84 | (vector 'load-string 0 0 1 230)) |
85 | ||
ba7e7139 LC |
86 | (comp-test '(load-wide-string "λ") |
87 | (apply vector 'load-wide-string 0 0 4 | |
88 | (if (eq? (native-endianness) (endianness little)) | |
89 | '(187 3 0 0) | |
90 | '(0 0 3 187)))) | |
91 | ||
56164a5a | 92 | (comp-test '(load-program () 3 #f (make-int8 3) (return)) |
ccf77d95 | 93 | #(load-program |
ccf77d95 AW |
94 | (uint32 3) ;; len |
95 | (uint32 0) ;; metalen | |
96 | make-int8 3 | |
97 | return)) | |
1f1ec13b | 98 | |
28b119ee AW |
99 | ;; the nops are to pad meta to an 8-byte alignment. not strictly |
100 | ;; necessary for this test, but representative of the common case. | |
56164a5a AW |
101 | (comp-test '(load-program () 8 |
102 | (load-program () 3 | |
1f1ec13b AW |
103 | #f |
104 | (make-int8 3) (return)) | |
28b119ee AW |
105 | (make-int8 3) (return) |
106 | (nop) (nop) (nop) (nop) (nop)) | |
ccf77d95 | 107 | #(load-program |
28b119ee | 108 | (uint32 8) ;; len |
56164a5a | 109 | (uint32 11) ;; metalen |
ccf77d95 AW |
110 | make-int8 3 |
111 | return | |
28b119ee | 112 | nop nop nop nop nop |
ccf77d95 AW |
113 | (uint32 3) ;; len |
114 | (uint32 0) ;; metalen | |
115 | make-int8 3 | |
116 | return)))) |