23 files changed, 479 insertions, 0 deletions
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
new file mode 100644
index 000000000..2bc78142c
--- /dev/null
+++ b/testsuite/Makefile.am
@@ -0,0 +1,27 @@
+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/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm
new file mode 100644
index 000000000..39e7bf117
--- /dev/null
+++ b/testsuite/run-vm-tests.scm
@@ -0,0 +1,91 @@
+;;; run-vm-tests.scm -- Run Guile-VM's test suite.
+;;;
+;;; Copyright 2005, 2009 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 base compile)
+	     (system base language)
+             (language scheme spec)
+             (language objcode spec)
+	     (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 objcode))
+
+(define (run-vm-program objcode)
+  "Run VM program contained into @var{objcode}."
+  (vm-load (the-vm) objcode))
+
+(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 @var{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/testsuite/t-basic-contructs.scm b/testsuite/t-basic-contructs.scm
new file mode 100644
index 000000000..53ee81dcd
--- /dev/null
+++ b/testsuite/t-basic-contructs.scm
@@ -0,0 +1,16 @@
+;;; 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/testsuite/t-call-cc.scm b/testsuite/t-call-cc.scm
new file mode 100644
index 000000000..05e4de98c
--- /dev/null
+++ b/testsuite/t-call-cc.scm
@@ -0,0 +1,16 @@
+(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))
diff --git a/testsuite/t-catch.scm b/testsuite/t-catch.scm
new file mode 100644
index 000000000..9cc3e0e14
--- /dev/null
+++ b/testsuite/t-catch.scm
@@ -0,0 +1,10 @@
+;; 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/testsuite/t-closure.scm b/testsuite/t-closure.scm
new file mode 100644
index 000000000..3d791979e
--- /dev/null
+++ b/testsuite/t-closure.scm
@@ -0,0 +1,8 @@
+(define func
+  (let ((x 2))
+    (lambda ()
+      (let ((x++ (+ 1 x)))
+	(set! x x++)
+	x++))))
+
+(list (func) (func) (func))
diff --git a/testsuite/t-closure2.scm b/testsuite/t-closure2.scm
new file mode 100644
index 000000000..fd1df34fd
--- /dev/null
+++ b/testsuite/t-closure2.scm
@@ -0,0 +1,10 @@
+
+(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/testsuite/t-closure3.scm b/testsuite/t-closure3.scm
new file mode 100644
index 000000000..2295a511a
--- /dev/null
+++ b/testsuite/t-closure3.scm
@@ -0,0 +1,7 @@
+(define (stuff)
+  (let* ((x 2)
+	 (chbouib (lambda (z)
+		    (+ 7 z x))))
+    (chbouib 77)))
+
+(stuff)
diff --git a/testsuite/t-closure4.scm b/testsuite/t-closure4.scm
new file mode 100644
index 000000000..61258012f
--- /dev/null
+++ b/testsuite/t-closure4.scm
@@ -0,0 +1,22 @@
+(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/testsuite/t-do-loop.scm b/testsuite/t-do-loop.scm
new file mode 100644
index 000000000..6455bcdb2
--- /dev/null
+++ b/testsuite/t-do-loop.scm
@@ -0,0 +1,5 @@
+(let ((n+ 0))
+  (do ((n- 5  (1- n-))
+       (n+ n+ (1+ n+)))
+      ((= n- 0))
+    (format #f "n- = ~a~%" n-)))
diff --git a/testsuite/t-global-bindings.scm b/testsuite/t-global-bindings.scm
new file mode 100644
index 000000000..c8ae3692c
--- /dev/null
+++ b/testsuite/t-global-bindings.scm
@@ -0,0 +1,13 @@
+;; 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/testsuite/t-literal-integers.scm b/testsuite/t-literal-integers.scm
new file mode 100644
index 000000000..bf015a4ff
--- /dev/null
+++ b/testsuite/t-literal-integers.scm
@@ -0,0 +1,5 @@
+;; 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/testsuite/t-macros.scm b/testsuite/t-macros.scm
new file mode 100644
index 000000000..bb44b46b7
--- /dev/null
+++ b/testsuite/t-macros.scm
@@ -0,0 +1,4 @@
+;; Are built-in macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))
+(read-options)
diff --git a/testsuite/t-macros2.scm b/testsuite/t-macros2.scm
new file mode 100644
index 000000000..4cc258278
--- /dev/null
+++ b/testsuite/t-macros2.scm
@@ -0,0 +1,17 @@
+;; 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/testsuite/t-map.scm b/testsuite/t-map.scm
new file mode 100644
index 000000000..76bf1730f
--- /dev/null
+++ b/testsuite/t-map.scm
@@ -0,0 +1,10 @@
+; 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/testsuite/t-match.scm b/testsuite/t-match.scm
new file mode 100644
index 000000000..ed56ae7ef
--- /dev/null
+++ b/testsuite/t-match.scm
@@ -0,0 +1,26 @@
+;;; Pattern matching with `(ice-9 match)'.
+;;;
+
+(use-modules (ice-9 match)
+             (srfi srfi-9))  ;; record type (FIXME: See `t-records.scm')
+
+(define-record-type <stuff>
+  (%make-stuff chbouib)
+  stuff?
+  (chbouib stuff:chbouib stuff:set-chbouib!))
+
+(define (matches? obj)
+;  (format #t "matches? ~a~%" obj)
+  (match obj
+	 (($ stuff) #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/testsuite/t-mutual-toplevel-defines.scm b/testsuite/t-mutual-toplevel-defines.scm
new file mode 100644
index 000000000..795c74423
--- /dev/null
+++ b/testsuite/t-mutual-toplevel-defines.scm
@@ -0,0 +1,8 @@
+(define (even? x)
+  (or (zero? x)
+      (not (odd? (1- x)))))
+
+(define (odd? x)
+  (not (even? (1- x))))
+
+(even? 20)
diff --git a/testsuite/t-or.scm b/testsuite/t-or.scm
new file mode 100644
index 000000000..0c581e9c7
--- /dev/null
+++ b/testsuite/t-or.scm
@@ -0,0 +1,29 @@
+;; 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/testsuite/t-proc-with-setter.scm b/testsuite/t-proc-with-setter.scm
new file mode 100644
index 000000000..f6ffe15b0
--- /dev/null
+++ b/testsuite/t-proc-with-setter.scm
@@ -0,0 +1,20 @@
+(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/testsuite/t-quasiquote.scm b/testsuite/t-quasiquote.scm
new file mode 100644
index 000000000..08e306c39
--- /dev/null
+++ b/testsuite/t-quasiquote.scm
@@ -0,0 +1,12 @@
+(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/testsuite/t-records.scm b/testsuite/t-records.scm
new file mode 100644
index 000000000..0cb320da3
--- /dev/null
+++ b/testsuite/t-records.scm
@@ -0,0 +1,15 @@
+;;; SRFI-9 Records.
+;;;
+
+(use-modules (srfi srfi-9))
+
+(define-record-type <stuff>
+  (%make-stuff chbouib)
+  stuff?
+  (chbouib stuff:chbouib stuff:set-chbouib!))
+
+
+(and (stuff? (%make-stuff 12))
+     (= 7 (stuff:chbouib (%make-stuff 7)))
+     (not (stuff? 12))
+     (not (false-if-exception (%make-stuff))))
diff --git a/testsuite/t-values.scm b/testsuite/t-values.scm
new file mode 100644
index 000000000..f4c0516a3
--- /dev/null
+++ b/testsuite/t-values.scm
@@ -0,0 +1,13 @@
+(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))
+
diff --git a/testsuite/the-bug.txt b/testsuite/the-bug.txt
new file mode 100644
index 000000000..95683f445
--- /dev/null
+++ b/testsuite/the-bug.txt
@@ -0,0 +1,95 @@
+-*- Outline -*-
+
+Once (system vm assemble) is compiled, things start to fail in
+unpredictable ways.
+
+* `compile-file' of non-closure-using programs works
+
+$ guile-disasm t-records.go > t-records.ref.asm
+...
+$ diff -uBb t-macros.*.asm
+$ diff -uBb t-records.*.asm
+$ diff -uBb t-global-bindings.*.asm
+
+* `compile-file' of closure-using programs fails
+
+ERROR: During compiling t-closure.scm:
+ERROR: VM: Wrong type to apply: #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) [IP offset: 28]
+
+guile> (vm-debugger (the-vm))
+debug> bt
+#1 #<variable 30b12468 value: (#(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 0) (nexts . 1))) (#(<glil-const> 2) #(<glil-bind> ((x external 0))) #(<glil-external> set 0 0) #(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 1) (nexts . 0))) (#(<glil-module> ref #f +) #(<glil-const> 1) #(<glil-external> ref 1 0) #(<glil-call> call 2) #(<glil-source> (2 . 15)) #(<glil-bind> ((x++ local 0))) #(<glil-local> set 0) #(<glil-local> ref 0) #(<glil-external> set 1 0) #(<glil-local> ref 0) #(<glil-call> return 0) #(<glil-unbind>))) #(<glil-call> return 0) #(<glil-unbind>))) #<directory (guile-user) 100742d0> ())>
+#2 (#<program 30ae74b8> #(<glil-vars> ...) (#(<glil-const> ...) #(<glil-bind> ...) ...))   
+#3 (#<program 30af7090>)
+#4 (#<program 30af94c0> #(<glil-vars> ...) (#(<glil-module> ...) #(<glil-const> ...) ...)) 
+#5 (#<program 30b00108>)
+#6 (#<program 30b02590> ref ...)
+#7 (_l 1 #(<venv> ...))
+guile> (vm-debugger (the-vm))
+debug> stack
+(#t closure? #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) #<procedure #f (struct name val)> #<primitive-generic map> #<primitive-generic map> #<program 30998470>)
+
+* Compiling anything "by hand" fails
+
+** Example 1:  the read/compile/run loop
+
+guile> (set! %load-path (cons "/home/ludo/src/guile-vm/module" %load-path))
+guile> (use-modules (system vm assemble)(system vm core)(system repl repl))
+guile> (start-repl 'scheme)
+Guile Scheme interpreter 0.5 on Guile 1.7.2
+Copyright (C) 2001 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+scheme@guile-user> (use-modules (ice-9 match)
+	     (system base syntax)
+	     (system vm assemble))
+
+(define (%preprocess x e)
+  (match x
+    (($ <glil-asm> vars body)
+     (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
+	    (body (map (lambda (x) (preprocess x venv)) body)))
+       (<vm-asm> :venv venv :glil x :body body)))
+    (($ <glil-external> op depth index)
+     (do ((d depth (1- d))
+	  (e e (slot e 'parent)))
+	 ((= d 0))
+       (set! (slot e 'closure?) #t))
+     x)
+    (else x)))
+
+scheme@guile-user> preprocess
+#<procedure preprocess (x e)>
+scheme@guile-user> (getpid)
+470
+scheme@guile-user> (set! preprocess %preprocess)
+scheme@guile-user> preprocess
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user> getpid
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user>
+
+
+** Example 2:  the test suite (which also reads/compiles/runs)
+
+All the closure-using tests fail.
+
+ludo@lully:~/src/guile-vm/testsuite $ make check
+../src/guile-vm -L ../module            \
+            -l run-vm-tests.scm -e run-vm-tests \
+            t-global-bindings.scm t-closure.scm t-closure2.scm t-closure3.scm t-do-loop.scm t-macros.scm t-proc-with-setter.scm t-values.scm t-records.scm t-match.scm
+
+running `t-global-bindings.scm'...  reading...  compiling...  running...  ok
+running `t-closure.scm'...  reading...  compiling...  [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure2.scm'...  reading...  compiling...  [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure3.scm'...  reading...  compiling...  [vm-error/(vm-run VM: Wrong ype to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-do-loop.scm'...  reading...  compiling...  [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-macros.scm'...  reading...  compiling...  running...  ok
+running `t-proc-with-setter.scm'...  reading...  compiling...  running...  ok
+running `t-values.scm'...  reading...  compiling...  running...  ok
+running `t-records.scm'...  reading...  compiling...  running...  ok
+running `t-match.scm'...  reading...  compiling...  running...  ok
+
+4 tests failed out of 10
+make: *** [check] Error 4
+