diff --git a/configure.ac b/configure.ac index b43731e2e..bb9a9281f 100644 --- a/configure.ac +++ b/configure.ac @@ -1436,7 +1436,6 @@ AC_CONFIG_FILES([ guile-readline/Makefile test-suite/Makefile test-suite/standalone/Makefile - test-suite/vm/Makefile meta/Makefile bootstrap/Makefile module/Makefile diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index e15b92aff..3810197e2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,7 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, -## 2010, 2011, 2012, 2013, 2014 Software Foundation, Inc. +## Copyright 2001-2019 Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -20,7 +19,7 @@ ## write to the Free Software Foundation, Inc., 51 Franklin Street, ## Fifth Floor, Boston, MA 02110-1301 USA -SUBDIRS = standalone vm +SUBDIRS = standalone SCM_TESTS = tests/00-initial-env.test \ tests/00-repl-server.test \ diff --git a/test-suite/vm/Makefile.am b/test-suite/vm/Makefile.am deleted file mode 100644 index 0e6e974e2..000000000 --- a/test-suite/vm/Makefile.am +++ /dev/null @@ -1,48 +0,0 @@ -## Process this file with automake to produce Makefile.in. -## -## Copyright 2005, 2006, 2008, 2009, 2010 Software Foundation, Inc. -## -## This file is part of GUILE. -## -## GUILE 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, or -## (at your option) any later version. -## -## GUILE 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 GUILE; see the file COPYING.LESSER. If not, -## write to the Free Software Foundation, Inc., 51 Franklin Street, -## Fifth Floor, Boston, MA 02110-1301 USA - -TESTS_ENVIRONMENT = \ - $(top_builddir)/meta/guile \ - -l $(srcdir)/run-vm-tests.scm -e run-vm-tests - -TESTS = \ - t-basic-contructs.scm \ - t-global-bindings.scm \ - t-catch.scm \ - t-call-cc.scm \ - t-closure.scm \ - t-closure2.scm \ - t-closure3.scm \ - t-closure4.scm \ - t-do-loop.scm \ - t-literal-integers.scm \ - t-macros.scm \ - t-macros2.scm \ - t-map.scm \ - t-or.scm \ - t-proc-with-setter.scm \ - t-quasiquote.scm \ - t-values.scm \ - t-records.scm \ - t-match.scm \ - t-mutual-toplevel-defines.scm - -EXTRA_DIST = run-vm-tests.scm $(TESTS) diff --git a/test-suite/vm/run-vm-tests.scm b/test-suite/vm/run-vm-tests.scm deleted file mode 100644 index 48674df15..000000000 --- a/test-suite/vm/run-vm-tests.scm +++ /dev/null @@ -1,91 +0,0 @@ -;;; 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))))) - diff --git a/test-suite/vm/t-basic-contructs.scm b/test-suite/vm/t-basic-contructs.scm deleted file mode 100644 index 53ee81dcd..000000000 --- a/test-suite/vm/t-basic-contructs.scm +++ /dev/null @@ -1,16 +0,0 @@ -;;; Basic RnRS constructs. - -(and (eq? 2 (begin (+ 2 4) 5 2)) - ((lambda (x y) - (and (eq? x 1) (eq? y 2) - (begin - (set! x 11) (set! y 22) - (and (eq? x 11) (eq? y 22))))) - 1 2) - (let ((x 1) (y 3)) - (and (eq? x 1) (eq? y 3))) - (let loop ((x #t)) - (if (not x) - #t - (loop #f)))) - diff --git a/test-suite/vm/t-call-cc.scm b/test-suite/vm/t-call-cc.scm deleted file mode 100644 index 097f276ff..000000000 --- a/test-suite/vm/t-call-cc.scm +++ /dev/null @@ -1,30 +0,0 @@ -(let ((set-counter2 #f)) - (define (get-counter2) - (call/cc - (lambda (k) - (set! set-counter2 k) - 1))) - (define (loop counter1) - (let ((counter2 (get-counter2))) - (set! counter1 (1+ counter1)) - (cond ((not (= counter1 counter2)) - (error "bad call/cc behaviour" counter1 counter2)) - ((> counter1 10) - #t) - (else - (set-counter2 (1+ counter2)))))) - (loop 0)) - -(let* ((next #f) - (counter 0) - (result (call/cc - (lambda (k) - (set! next k) - 1)))) - (set! counter (+ 1 counter)) - (cond ((not (= counter result)) - (error "bad call/cc behaviour" counter result)) - ((> counter 10) - #t) - (else - (next (+ 1 counter))))) diff --git a/test-suite/vm/t-catch.scm b/test-suite/vm/t-catch.scm deleted file mode 100644 index 9cc3e0e14..000000000 --- a/test-suite/vm/t-catch.scm +++ /dev/null @@ -1,10 +0,0 @@ -;; Test that nonlocal exits of the VM work. - -(begin - (define (foo thunk) - (catch #t thunk (lambda args args))) - (foo - (lambda () - (let ((a 'one)) - (1+ a))))) - diff --git a/test-suite/vm/t-closure.scm b/test-suite/vm/t-closure.scm deleted file mode 100644 index 3d791979e..000000000 --- a/test-suite/vm/t-closure.scm +++ /dev/null @@ -1,8 +0,0 @@ -(define func - (let ((x 2)) - (lambda () - (let ((x++ (+ 1 x))) - (set! x x++) - x++)))) - -(list (func) (func) (func)) diff --git a/test-suite/vm/t-closure2.scm b/test-suite/vm/t-closure2.scm deleted file mode 100644 index fd1df34fd..000000000 --- a/test-suite/vm/t-closure2.scm +++ /dev/null @@ -1,10 +0,0 @@ - -(define (uid) - (let* ((x 2) - (do-uid (lambda () - (let ((x++ (+ 1 x))) - (set! x x++) - x++)))) - (do-uid))) - -(list (uid) (uid) (uid)) diff --git a/test-suite/vm/t-closure3.scm b/test-suite/vm/t-closure3.scm deleted file mode 100644 index 2295a511a..000000000 --- a/test-suite/vm/t-closure3.scm +++ /dev/null @@ -1,7 +0,0 @@ -(define (stuff) - (let* ((x 2) - (chbouib (lambda (z) - (+ 7 z x)))) - (chbouib 77))) - -(stuff) diff --git a/test-suite/vm/t-closure4.scm b/test-suite/vm/t-closure4.scm deleted file mode 100644 index 61258012f..000000000 --- a/test-suite/vm/t-closure4.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define (extract-symbols exp) - (define (process x out cont) - (cond ((pair? x) - (process (car x) - out - (lambda (car-x out) - ;; used to have a bug here whereby `x' was - ;; modified in the self-tail-recursion to (process - ;; (cdr x) ...), because we didn't allocate fresh - ;; externals when doing self-tail-recursion. - (process (cdr x) - out - (lambda (cdr-x out) - (cont (cons car-x cdr-x) - out)))))) - ((symbol? x) - (cont x (cons x out))) - (else - (cont x out)))) - (process exp '() (lambda (x out) out))) - -(extract-symbols '(a b . c)) diff --git a/test-suite/vm/t-do-loop.scm b/test-suite/vm/t-do-loop.scm deleted file mode 100644 index 6455bcdb2..000000000 --- a/test-suite/vm/t-do-loop.scm +++ /dev/null @@ -1,5 +0,0 @@ -(let ((n+ 0)) - (do ((n- 5 (1- n-)) - (n+ n+ (1+ n+))) - ((= n- 0)) - (format #f "n- = ~a~%" n-))) diff --git a/test-suite/vm/t-global-bindings.scm b/test-suite/vm/t-global-bindings.scm deleted file mode 100644 index c8ae3692c..000000000 --- a/test-suite/vm/t-global-bindings.scm +++ /dev/null @@ -1,13 +0,0 @@ -;; Are global bindings reachable at run-time? This relies on the -;; `object-ref' and `object-set' instructions. - -(begin - - (define the-binding "hello") - - ((lambda () the-binding)) - - ((lambda () (set! the-binding "world"))) - - ((lambda () the-binding))) - diff --git a/test-suite/vm/t-literal-integers.scm b/test-suite/vm/t-literal-integers.scm deleted file mode 100644 index bf015a4ff..000000000 --- a/test-suite/vm/t-literal-integers.scm +++ /dev/null @@ -1,5 +0,0 @@ -;; Check whether literal integers are correctly signed. - -(and (= 4294967295 (- (expt 2 32) 1)) ;; unsigned - (= -2147483648 (- (expt 2 31))) ;; signed - (= 2147483648 (expt 2 31))) ;; unsigned diff --git a/test-suite/vm/t-macros.scm b/test-suite/vm/t-macros.scm deleted file mode 100644 index bb44b46b7..000000000 --- a/test-suite/vm/t-macros.scm +++ /dev/null @@ -1,4 +0,0 @@ -;; Are built-in macros well-expanded at compilation-time? - -(false-if-exception (+ 2 2)) -(read-options) diff --git a/test-suite/vm/t-macros2.scm b/test-suite/vm/t-macros2.scm deleted file mode 100644 index 4cc258278..000000000 --- a/test-suite/vm/t-macros2.scm +++ /dev/null @@ -1,17 +0,0 @@ -;; Are macros well-expanded at compilation-time? - -(defmacro minus-binary (a b) - `(- ,a ,b)) - -(define-macro (plus . args) - `(let ((res (+ ,@args))) - ;;(format #t "plus -> ~a~%" res) - res)) - - -(plus (let* ((x (minus-binary 12 7)) ;; 5 - (y (minus-binary x 1))) ;; 4 - (plus x y 5)) ;; 14 - 12 ;; 26 - (expt 2 3)) ;; => 34 - diff --git a/test-suite/vm/t-map.scm b/test-suite/vm/t-map.scm deleted file mode 100644 index 76bf1730f..000000000 --- a/test-suite/vm/t-map.scm +++ /dev/null @@ -1,10 +0,0 @@ -; Currently, map is a C function, so this is a way of testing that the -; VM is reentrant. - -(begin - - (define (square x) - (* x x)) - - (map (lambda (x) (square x)) - '(1 2 3))) diff --git a/test-suite/vm/t-match.scm b/test-suite/vm/t-match.scm deleted file mode 100644 index 2032fbe17..000000000 --- a/test-suite/vm/t-match.scm +++ /dev/null @@ -1,26 +0,0 @@ -;;; Pattern matching with `(ice-9 match)'. -;;; - -(use-modules (ice-9 match) - (srfi srfi-9)) ;; record type (FIXME: See `t-records.scm') - -(define-record-type - (%make-stuff chbouib) - stuff? - (chbouib stuff:chbouib stuff:set-chbouib!)) - -(define (matches? obj) -; (format #t "matches? ~a~%" obj) - (match obj - (($ ) #t) -; (blurps #t) - ("hello" #t) - (else #f))) - - -;(format #t "go!~%") -(and (matches? (%make-stuff 12)) - (matches? (%make-stuff 7)) - (matches? "hello") -; (matches? 'blurps) - (not (matches? 66))) diff --git a/test-suite/vm/t-mutual-toplevel-defines.scm b/test-suite/vm/t-mutual-toplevel-defines.scm deleted file mode 100644 index 795c74423..000000000 --- a/test-suite/vm/t-mutual-toplevel-defines.scm +++ /dev/null @@ -1,8 +0,0 @@ -(define (even? x) - (or (zero? x) - (not (odd? (1- x))))) - -(define (odd? x) - (not (even? (1- x)))) - -(even? 20) diff --git a/test-suite/vm/t-or.scm b/test-suite/vm/t-or.scm deleted file mode 100644 index 0c581e9c7..000000000 --- a/test-suite/vm/t-or.scm +++ /dev/null @@ -1,29 +0,0 @@ -;; all the different permutations of or -(list - ;; not in tail position, no args - (or) - ;; not in tail position, one arg - (or 'what) - (or #f) - ;; not in tail position, two arg - (or 'what 'where) - (or #f 'where) - (or #f #f) - (or 'what #f) - ;; not in tail position, value discarded - (begin (or 'what (error "two")) 'two) - ;; in tail position (within the lambdas) - ((lambda () - (or))) - ((lambda () - (or 'what))) - ((lambda () - (or #f))) - ((lambda () - (or 'what 'where))) - ((lambda () - (or #f 'where))) - ((lambda () - (or #f #f))) - ((lambda () - (or 'what #f)))) diff --git a/test-suite/vm/t-proc-with-setter.scm b/test-suite/vm/t-proc-with-setter.scm deleted file mode 100644 index f6ffe15b0..000000000 --- a/test-suite/vm/t-proc-with-setter.scm +++ /dev/null @@ -1,20 +0,0 @@ -(define the-struct (vector 1 2)) - -(define get/set - (make-procedure-with-setter - (lambda (struct name) - (case name - ((first) (vector-ref struct 0)) - ((second) (vector-ref struct 1)) - (else #f))) - (lambda (struct name val) - (case name - ((first) (vector-set! struct 0 val)) - ((second) (vector-set! struct 1 val)) - (else #f))))) - -(and (eq? (vector-ref the-struct 0) (get/set the-struct 'first)) - (eq? (vector-ref the-struct 1) (get/set the-struct 'second)) - (begin - (set! (get/set the-struct 'second) 77) - (eq? (vector-ref the-struct 1) (get/set the-struct 'second)))) diff --git a/test-suite/vm/t-quasiquote.scm b/test-suite/vm/t-quasiquote.scm deleted file mode 100644 index 08e306c39..000000000 --- a/test-suite/vm/t-quasiquote.scm +++ /dev/null @@ -1,12 +0,0 @@ -(list - `() - `foo - `(foo) - `(foo bar) - `(1 2) - (let ((x 1)) `,x) - (let ((x 1)) `(,x)) - (let ((x 1)) ``(,x)) - (let ((head '(a b)) - (tail 'c)) - `(,@head . ,tail))) diff --git a/test-suite/vm/t-records.scm b/test-suite/vm/t-records.scm deleted file mode 100644 index 9aa4daac6..000000000 --- a/test-suite/vm/t-records.scm +++ /dev/null @@ -1,14 +0,0 @@ -;;; SRFI-9 Records. -;;; - -(use-modules (srfi srfi-9)) - -(define-record-type - (%make-stuff chbouib) - stuff? - (chbouib stuff:chbouib stuff:set-chbouib!)) - - -(and (stuff? (%make-stuff 12)) - (= 7 (stuff:chbouib (%make-stuff 7))) - (not (stuff? 12))) diff --git a/test-suite/vm/t-values.scm b/test-suite/vm/t-values.scm deleted file mode 100644 index f4c0516a3..000000000 --- a/test-suite/vm/t-values.scm +++ /dev/null @@ -1,13 +0,0 @@ -(list (call-with-values - (lambda () (values 1 2)) - (lambda (x y) (cons x y))) - - ;; the start-stack forces a bounce through the interpreter - (call-with-values - (lambda () (start-stack 'foo (values 1 2))) - list) - - (call-with-values - (lambda () (apply values '(1))) - list)) -