testsuite/run-vm-tests.scm

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