Commit | Line | Data |
---|---|---|
b6368dbb LC |
1 | ;;; run-vm-tests.scm -- Run Guile-VM's test suite. |
2 | ;;; | |
1b00f4c7 | 3 | ;;; Copyright 2005, 2009, 2010, 2013 Free Software Foundation, Inc. |
b6368dbb | 4 | ;;; |
83ba2d37 NJ |
5 | ;;; This program is free software; you can redistribute it and/or |
6 | ;;; modify it under the terms of the GNU Lesser General Public License | |
7 | ;;; as published by the Free Software Foundation; either version 3 of | |
8 | ;;; the License, or (at your option) any later version. | |
b6368dbb LC |
9 | ;;; |
10 | ;;; This program is distributed in the hope that it will be useful, | |
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
83ba2d37 | 13 | ;;; GNU Lesser General Public License for more details. |
b6368dbb | 14 | ;;; |
83ba2d37 | 15 | ;;; You should have received a copy of the GNU Lesser General Public License |
b6368dbb LC |
16 | ;;; along with this program; if not, write to the Free Software |
17 | ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
0b5f0e49 | 19 | |
d0927dde | 20 | (use-modules (system vm vm) |
473d5637 | 21 | (system vm loader) |
1b00f4c7 | 22 | (system vm program) |
0b5f0e49 LC |
23 | (system base compile) |
24 | (system base language) | |
1b00f4c7 | 25 | (srfi srfi-1) |
b6368dbb | 26 | (ice-9 r5rs)) |
0b5f0e49 LC |
27 | |
28 | \f | |
0b5f0e49 LC |
29 | (define (fetch-sexp-from-file file) |
30 | (with-input-from-file file | |
31 | (lambda () | |
32 | (let loop ((sexp (read)) | |
33 | (result '())) | |
34 | (if (eof-object? sexp) | |
35 | (cons 'begin (reverse result)) | |
36 | (loop (read) (cons sexp result))))))) | |
37 | ||
38 | (define (compile-to-objcode sexp) | |
39 | "Compile the expression @var{sexp} into a VM program and return it." | |
691697de | 40 | (compile sexp #:from 'scheme #:to 'bytecode)) |
0b5f0e49 | 41 | |
1b00f4c7 AW |
42 | (define (run-vm-program bv) |
43 | "Run VM program contained into @var{bv}." | |
44 | ((load-thunk-from-memory bv))) | |
0b5f0e49 | 45 | |
b6368dbb | 46 | (define (compile/run-test-from-file file) |
0b5f0e49 LC |
47 | "Run test from source file @var{file} and return a value indicating whether |
48 | it succeeded." | |
49 | (run-vm-program (compile-to-objcode (fetch-sexp-from-file file)))) | |
50 | ||
51 | \f | |
52 | (define-macro (watch-proc proc-name str) | |
53 | `(let ((orig-proc ,proc-name)) | |
54 | (set! ,proc-name | |
55 | (lambda args | |
56 | (format #t (string-append ,str "... ")) | |
57 | (apply orig-proc args))))) | |
58 | ||
59 | (watch-proc fetch-sexp-from-file "reading") | |
60 | (watch-proc compile-to-objcode "compiling") | |
61 | (watch-proc run-vm-program "running") | |
62 | ||
63 | \f | |
64 | ;; The program. | |
65 | ||
66 | (define (run-vm-tests files) | |
b6368dbb LC |
67 | "For each file listed in @var{files}, load it and run it through both the |
68 | interpreter and the VM (after having it compiled). Both results must be | |
91a214eb | 69 | equal in the sense of @code{equal?}." |
0b5f0e49 LC |
70 | (let* ((res (map (lambda (file) |
71 | (format #t "running `~a'... " file) | |
72 | (if (catch #t | |
73 | (lambda () | |
6297d229 | 74 | (equal? (compile/run-test-from-file file) |
32aa2111 | 75 | (primitive-eval (fetch-sexp-from-file file)))) |
0b5f0e49 LC |
76 | (lambda (key . args) |
77 | (format #t "[~a/~a] " key args) | |
78 | #f)) | |
79 | (format #t "ok~%") | |
80 | (begin (format #t "FAILED~%") #f))) | |
81 | files)) | |
82 | (total (length files)) | |
83 | (failed (length (filter not res)))) | |
84 | ||
85 | (if (= 0 failed) | |
10331eac | 86 | (exit 0) |
0b5f0e49 LC |
87 | (begin |
88 | (format #t "~%~a tests failed out of ~a~%" | |
89 | failed total) | |
90 | (exit failed))))) | |
91 |