* src/objcodes.c (make_objcode_by_mmap): Fixed the error type when the

object file is too small.

* doc/guile-vm.texi:  Documented `make-closure'.  Improved the documentation
  of `load-program'.

* testsuite:  New directory.

* configure.in:  Added `testsuite/Makefile' to `AC_OUTPUT'.

* Makefile.am (SUBDIRS):  Added `testsuite'.

* src/vm_engine.h (VM_CHECK_OBJECT):  New option.
  (CHECK_OBJECT):  New macro.

* src/vm_system.c (object-ref):  Use VM_CHECK_OBJECT.

* module/system/vm/assemble.scm (preprocess):  Commented out the debugging
  code.

* benchmark/lib.scm (do-loop):  New procedure.

git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-2

testsuite/Makefile.am

@@ -0,0 +1,24 @@
+# The test programs.
+
+# The Libtool executable.
+GUILE_VM = $(top_srcdir)/src/guile-vm
+
+vm_test_files =					\
+      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
+
+EXTRA_DIST = run-vm-tests.scm $(vm_test_files)
+
+
+check:
+	$(GUILE_VM) -L $(top_srcdir)/module		\
+	            -l run-vm-tests.scm -e run-vm-tests	\
+		    $(vm_test_files)

testsuite/run-vm-tests.scm

@@ -0,0 +1,73 @@
+;;; A simple test-running script.
+
+(use-modules (system vm core)
+	     (system vm disasm)
+	     (system base compile)
+	     (system base language)
+
+	     (srfi srfi-1))
+
+
+(define *scheme* (lookup-language 'scheme))
+
+(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-in sexp (current-module) *scheme*))
+
+(define (run-vm-program objcode)
+  "Run VM program contained into @var{objcode}."
+  (vm-load (the-vm) objcode))
+
+(define (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)
+  (let* ((res (map (lambda (file)
+		     (format #t "running `~a'...  " file)
+		     (if (catch #t
+				(lambda ()
+				  (run-test-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)
+	(begin
+	  (format #t "~%All ~a tests passed~%" total)
+	  (exit 0))
+	(begin
+	  (format #t "~%~a tests failed out of ~a~%"
+		  failed total)
+	  (exit failed)))))
+

testsuite/t-closure.scm

@@ -0,0 +1,5 @@
+(let ((x 2))
+  (lambda ()
+    (let ((x++ (+ 1 x)))
+      (set! x x++)
+      x++)))

testsuite/t-closure2.scm

@@ -0,0 +1,8 @@
+
+(define (uid)
+  (let* ((x 2)
+	 (do-uid (lambda ()
+		   (let ((x++ (+ 1 x)))
+		     (set! x x++)
+		     x++))))
+    (do-uid)))

testsuite/t-closure3.scm

@@ -0,0 +1,5 @@
+(define (stuff)
+  (let* ((x 2)
+	 (chbouib (lambda (z)
+		    (+ 7 z x))))
+    (chbouib 77)))

testsuite/t-do-loop.scm

@@ -0,0 +1,5 @@
+(let ((n+ 0))
+  (do ((n- 5  (1- n-))
+       (n+ n+ (1+ n+)))
+      ((= n- 0))
+    (format #t "n- = ~a~%" n-)))

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)))
+

testsuite/t-macros.scm

@@ -0,0 +1,3 @@
+;; Are macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))

testsuite/t-match.scm

@@ -0,0 +1,23 @@
+(use-modules (ice-9 match)
+	     (srfi srfi-9))  ;; record type
+
+(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)))

testsuite/t-proc-with-setter.scm

@@ -0,0 +1,14 @@
+(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)))))

testsuite/t-records.scm

@@ -0,0 +1,12 @@
+(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))))

testsuite/t-values.scm

@@ -0,0 +1,8 @@
+(use-modules (ice-9 receive))
+
+(define (do-stuff x y)
+  (values x y))
+
+(call-with-values (lambda ()    (values 1 2))
+		  (lambda (x y) (cons x y)))
+

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
+