Fixed a Scheme translation bug; cleaned compilation with GCC 4.

* module/language/scheme/translate.scm (trans-pair): In the `set!' case,
  when a procedure-with-setter is passed, call `trans:pair' with an
  actual pair.  This fixes a long-lasting bug which prevented compilation
  of `set!' statements with procedures-with-setter (this showed up when
  compiling `(system vm assemble)').

* module/system/base/compile.scm: Added `objcode->u8vector' to the
  `#:select' clause.

* module/system/base/syntax.scm: Cosmetic changes.

* module/system/vm/assemble.scm (preprocess): Removed debugging
  statements.

* src/frames.c: Cosmetic changes.

* src/frames.h (SCM_FRAME_SET_DYNAMIC_LINK): New.

* src/objcodes.c: Use `scm_t_uint8' instead of `char' when relevant.

* src/vm.c (vm_heapify_frames_1): Use `SCM_FRAME_SET_DYNAMIC_LINK ()'.

* src/vm_loader.c: Added casts to mute GCC 4 warnings.

* testsuite/run-vm-tests.scm (*scheme*): Renamed to `%scheme'.
  (run-test-from-file): Renamed to `compile/run-test-from-file'.
  (run-vm-tests): Run each test using both the VM and the interpreter;
  compare the results.

* testsuite/t-proc-with-setter.scm: Try out `get/set'.

* doc/Makefile.am (info_TEXINFOS): New.

* doc/guile-vm.texi: Added index entries and indices.

* doc/texinfo.tex: New file.

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

module/language/scheme/translate.scm

@@ -43,13 +43,13 @@
   (cond ((pair? x)
 	 (let ((y (macroexpand x)))
 	   (if (eq? x y)
-	     (trans-pair e (or (location x) l) (car x) (cdr x))
-	     (trans e l y))))
+	       (trans-pair e (or (location x) l) (car x) (cdr x))
+	       (trans e l y))))
 	((symbol? x)
 	 (let ((y (symbol-expand x)))
 	   (if (symbol? y)
-	     (<ghil-ref> e l (ghil-lookup e y))
-	     (trans e l y))))
+	       (<ghil-ref> e l (ghil-lookup e y))
+	       (trans e l y))))
 	(else (<ghil-quote> e l x))))
 
 (define (symbol-expand x)
@@ -109,7 +109,7 @@
        ;; (set! (NAME ARGS...) VAL)
        ((((? symbol? name) . args) val)
 	;; -> ((setter NAME) ARGS... VAL)
-	(trans:pair `((setter ,name) (,@args ,val))))
+	(trans:pair `((setter ,name) . (,@args ,val))))
 
        (else (bad-syntax))))
 

module/system/base/compile.scm

@@ -25,7 +25,7 @@
   :use-module (system il compile)
   :use-module (system il glil)
   :use-module ((system vm core)
-	       #:select (the-vm vm-load))
+	       #:select (the-vm vm-load objcode->u8vector))
   :use-module (system vm assemble)
   :use-module (ice-9 regex))
 
@@ -68,9 +68,9 @@
 		 (if (memq :c opts)
 		   (pprint-glil objcode port)
 		   (uniform-vector-write (objcode->u8vector objcode) port)))))
-	   (format #t "Wrote ~A\n" comp))
+	   (format #t "wrote ~A\n" comp))
       (lambda (key . args)
-	(format #t "ERROR: During compiling ~A:\n" file)
+	(format #t "ERROR: during compilation of ~A:\n" file)
 	(display "ERROR: ")
 	(apply format #t (cadr args) (caddr args))
 	(newline)
@@ -128,7 +128,7 @@
     (lambda (key val) val)))
 
 ;;;
-;;; 
+;;;
 ;;;
 
 (define (compile-and-load file . opts)

module/system/base/syntax.scm

@@ -102,7 +102,7 @@
 		(def (if (pair? slot) (cdr slot) *unbound*))
 		(val (get-key args (symbol->keyword key) def)))
 	   (if (eq? val *unbound*)
-	     (error "Slot unbound:" key)
+	     (error "slot unbound" key)
 	     (cons key val))))
        slots))
 
@@ -116,14 +116,15 @@
    (lambda (struct name)
      (let ((data (assq name (vector-ref struct 1))))
        (cond ((not data)
-	      (error "Unknown slot:" name))
+	      (error "unknown slot" name))
 	     (else (cdr data)))))
    (lambda (struct name val)
      (let ((data (assq name (vector-ref struct 1))))
        (cond ((not data)
-	      (error "Unknown slot:" name))
+	      (error "unknown slot" name))
 	     (else (set-cdr! data val)))))))
 
+
 ;;;
 ;;; Variants
 ;;;

module/system/vm/assemble.scm

@@ -50,26 +50,18 @@
 ;;;
 
 (define (preprocess x e)
-;  (format #t "entering~%")
   (match x
     (($ <glil-asm> vars body)
-;     (format #t "preparing to recurse~%")
      (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)
-;     (format #t "preparing to return due to external: ~a ~a ~a [e=~a]~%"
-;	     op depth index e)
      (do ((d depth (- d 1))
-	  (e e (slot e 'parent)))
-	 ((= d 0))
+ 	  (e e (slot e 'parent)))
+ 	 ((= d 0))
        (set! (slot e 'closure?) #t))
-;     (format #t "returning due to external~%")
      x)
-    (else
-     (begin
-;       (format #t "returning~%")
-       x))))
+    (else x)))
 
 
 ;;;