mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
691697de09
"RTL" didn't make any sense, and now that there's no other bytecode to disambiguate against, just call it bytecode. * module/Makefile.am: * module/ice-9/eval-string.scm: * module/language/bytecode.scm: * module/language/bytecode/spec.scm: * module/language/cps/arities.scm: * module/language/cps/compile-bytecode.scm: * module/language/cps/compile-rtl.scm: * module/language/cps/contification.scm: * module/language/cps/elide-values.scm: * module/language/cps/primitives.scm: * module/language/cps/reify-primitives.scm: * module/language/cps/spec.scm: * module/language/cps/specialize-primcalls.scm: * module/language/rtl.scm: * module/language/rtl/spec.scm: * module/scripts/compile.scm: * module/system/base/compile.scm: * module/system/repl/common.scm: * module/system/vm/assembler.scm: * module/system/vm/debug.scm: * module/system/vm/disassembler.scm: * module/system/vm/dwarf.scm: * test-suite/tests/cross-compilation.test: * test-suite/tests/dwarf.test: * test-suite/tests/rtl-compilation.test: * test-suite/tests/rtl.test: * test-suite/vm/run-vm-tests.scm: Fixups.
91 lines
2.8 KiB
Scheme
91 lines
2.8 KiB
Scheme
;;; run-vm-tests.scm -- Run Guile-VM's test suite.
|
||
;;;
|
||
;;; Copyright 2005, 2009, 2010, 2013 Free Software Foundation, Inc.
|
||
;;;
|
||
;;; This program is free software; you can redistribute it and/or
|
||
;;; modify it under the terms of the GNU Lesser General Public License
|
||
;;; as published by the Free Software Foundation; either version 3 of
|
||
;;; the License, or (at your option) any later version.
|
||
;;;
|
||
;;; This program is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU Lesser General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU Lesser General Public License
|
||
;;; along with this program; if not, write to the Free Software
|
||
;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(use-modules (system vm vm)
|
||
(system vm loader)
|
||
(system vm program)
|
||
(system base compile)
|
||
(system base language)
|
||
(srfi srfi-1)
|
||
(ice-9 r5rs))
|
||
|
||
|
||
(define (fetch-sexp-from-file file)
|
||
(with-input-from-file file
|
||
(lambda ()
|
||
(let loop ((sexp (read))
|
||
(result '()))
|
||
(if (eof-object? sexp)
|
||
(cons 'begin (reverse result))
|
||
(loop (read) (cons sexp result)))))))
|
||
|
||
(define (compile-to-objcode sexp)
|
||
"Compile the expression @var{sexp} into a VM program and return it."
|
||
(compile sexp #:from 'scheme #:to 'bytecode))
|
||
|
||
(define (run-vm-program bv)
|
||
"Run VM program contained into @var{bv}."
|
||
((load-thunk-from-memory bv)))
|
||
|
||
(define (compile/run-test-from-file file)
|
||
"Run test from source file @var{file} and return a value indicating whether
|
||
it succeeded."
|
||
(run-vm-program (compile-to-objcode (fetch-sexp-from-file file))))
|
||
|
||
|
||
(define-macro (watch-proc proc-name str)
|
||
`(let ((orig-proc ,proc-name))
|
||
(set! ,proc-name
|
||
(lambda args
|
||
(format #t (string-append ,str "... "))
|
||
(apply orig-proc args)))))
|
||
|
||
(watch-proc fetch-sexp-from-file "reading")
|
||
(watch-proc compile-to-objcode "compiling")
|
||
(watch-proc run-vm-program "running")
|
||
|
||
|
||
;; The program.
|
||
|
||
(define (run-vm-tests files)
|
||
"For each file listed in @var{files}, load it and run it through both the
|
||
interpreter and the VM (after having it compiled). Both results must be
|
||
equal in the sense of @code{equal?}."
|
||
(let* ((res (map (lambda (file)
|
||
(format #t "running `~a'... " file)
|
||
(if (catch #t
|
||
(lambda ()
|
||
(equal? (compile/run-test-from-file file)
|
||
(primitive-eval (fetch-sexp-from-file file))))
|
||
(lambda (key . args)
|
||
(format #t "[~a/~a] " key args)
|
||
#f))
|
||
(format #t "ok~%")
|
||
(begin (format #t "FAILED~%") #f)))
|
||
files))
|
||
(total (length files))
|
||
(failed (length (filter not res))))
|
||
|
||
(if (= 0 failed)
|
||
(exit 0)
|
||
(begin
|
||
(format #t "~%~a tests failed out of ~a~%"
|
||
failed total)
|
||
(exit failed)))))
|
||
|