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

doc/Makefile.am

@@ -1,2 +1 @@
-texi_TEXINFOS = guile-vm.texi
+info_TEXINFOS = guile-vm.texi
-MAINTAINERCLEANFILES = Makefile.in

doc/guile-vm.texi

@@ -102,6 +102,9 @@ However, be warned that important parts still correspond to version
 * Variable Management::         
 * Instruction Set::             
 * The Compiler::                
+* Concept Index::               
+* Function and Instruction Index::  
+* Command and Variable Index::  
 
 @detailmenu
  --- The Detailed Node Listing ---
@@ -528,7 +531,7 @@ itself, in the environment in which it will evaluate at run-time.  In
 a sense, a program's environment and its bindings are an implicit
 parameter of every program.
 
-@cindex Object table
+@cindex object table
 In order to handle such bindings, each program has an @dfn{object
 table} associated to it.  This table (actually a Scheme vector)
 contains all constant objects referenced by the program.  The object
@@ -723,7 +726,7 @@ Push @code{#t} onto the stack.
 
 
 
-@node The Compiler,  , Instruction Set, Top
+@node The Compiler, Concept Index, Instruction Set, Top
 @chapter The Compiler
 
 This section describes Guile-VM's compiler and the compilation process
@@ -743,6 +746,13 @@ Set}).
 
 Compilation in Guile-VM is a three-stage process:
 
+@cindex intermediate language
+@cindex assembler
+@cindex compiler
+@cindex GHIL
+@cindex GLIL
+@cindex bytecode
+
 @enumerate
 @item the source programming language (e.g. R5RS Scheme) is read and
 translated into GHIL, @dfn{Guile's High-Level Intermediate Language};
@@ -756,6 +766,8 @@ The use of two separate intermediate languages eases the
 implementation of front-ends since the gap between high-level
 languages like Scheme and GHIL is relatively small.
 
+@findex compile-file
+@vindex guilec
 From an end-user viewpoint, compiling a Guile program into bytecode
 can be done either by using the @command{guilec} command-line tool, or
 by using the @code{compile-file} procedure exported by the
@@ -899,6 +911,8 @@ This is not unlike the VM's assembly language described in
 @node The Assembler,  , GLIL, The Compiler
 @section The Assembler
 
+@findex code->bytes
+
 The final compilation step consists in converting the GLIL instruction
 sequence into VM bytecode.  This is what the @code{assemble} procedure
 defined in the @code{(system vm assemble)} module is for.  It relies
@@ -917,25 +931,24 @@ form of an SRFI-4 @code{u8vector} or a @code{<bytespec>} object.
 @end deffn
 
 
-
+
 @c *********************************************************************
-@c @node Concept Index, Command Index, Related Information, Top
+@node Concept Index, Function and Instruction Index, The Compiler, Top
-@c @unnumbered Concept Index
+@unnumbered Concept Index
-@c @printindex cp
+@printindex cp
 
-@c @node Command Index, Variable Index, Concept Index, Top
+@node Function and Instruction Index, Command and Variable Index, Concept Index, Top
-@c @unnumbered Command Index
+@unnumbered Function and Instruction Index
-@c @printindex fn
+@printindex fn
 
-@c @node Variable Index,  , Command Index, Top
+@node Command and Variable Index,  , Function and Instruction Index, Top
-@c @unnumbered Variable Index
+@unnumbered Command and Variable Index
-@c @printindex vr
+@printindex vr
 
 @bye
-
+
 @c Local Variables:
-@c mode:outline-minor
+@c ispell-local-dictionary: "american";
-@c outline-regexp:"@\\(ch\\|sec\\|subs\\)"
 @c End:
 
 @c  LocalWords:  bytecode

module/language/scheme/translate.scm

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

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))
        (set! (slot e 'closure?) #t))
-;     (format #t "returning due to external~%")
      x)
-    (else
+    (else x)))
-     (begin
-;       (format #t "returning~%")
-       x))))
 
 
 ;;;

src/frames.c

@@ -140,7 +140,8 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
 #define FUNC_NAME s_scm_frame_return_address
 {
   SCM_VALIDATE_HEAP_FRAME (1, frame);
-  return scm_from_ulong ((unsigned long) (SCM_FRAME_RETURN_ADDRESS
+  return scm_from_ulong ((unsigned long)
+			 (SCM_FRAME_RETURN_ADDRESS
 			  (SCM_HEAP_FRAME_POINTER (frame))));
 }
 #undef FUNC_NAME

src/frames.h

@@ -51,21 +51,26 @@
  * VM frames
  */
 
-/* 
+/* VM Frame Layout
+   ---------------
+
    |                  | <- fp + bp->nargs + bp->nlocs + 4
    +------------------+    = SCM_FRAME_UPPER_ADDRESS (fp)
    | Return address   |
    | Dynamic link     |
    | Heap link        |
    | External link    | <- fp + bp->nargs + bp->nlocs
-   | Local varialbe 1 |    = SCM_FRAME_DATA_ADDRESS (fp)
+   | Local variable 1 |    = SCM_FRAME_DATA_ADDRESS (fp)
    | Local variable 0 | <- fp + bp->nargs
    | Argument 1       |
    | Argument 0       | <- fp
    | Program          | <- fp - 1
    +------------------+    = SCM_FRAME_LOWER_ADDRESS (fp)
    |                  |
-*/
+
+   As can be inferred from this drawing, it is assumed that
+   `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
+   assumed to be as long as SCM objects.  */
 
 #define SCM_FRAME_DATA_ADDRESS(fp)				\
   (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs	\
@@ -76,10 +81,14 @@
 #define SCM_FRAME_BYTE_CAST(x)		((scm_byte_t *) SCM_UNPACK (x))
 #define SCM_FRAME_STACK_CAST(x)		((SCM *) SCM_UNPACK (x))
 
-#define SCM_FRAME_RETURN_ADDRESS(fp)	SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])
+#define SCM_FRAME_RETURN_ADDRESS(fp)				\
-#define SCM_FRAME_DYNAMIC_LINK(fp)	SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])
+  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
-#define SCM_FRAME_HEAP_LINK(fp)		SCM_FRAME_DATA_ADDRESS (fp)[1]
+#define SCM_FRAME_DYNAMIC_LINK(fp)				\
-#define SCM_FRAME_EXTERNAL_LINK(fp)	SCM_FRAME_DATA_ADDRESS (fp)[0]
+  (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl)		\
+  ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl);
+#define SCM_FRAME_HEAP_LINK(fp)		(SCM_FRAME_DATA_ADDRESS (fp)[1])
+#define SCM_FRAME_EXTERNAL_LINK(fp)	(SCM_FRAME_DATA_ADDRESS (fp)[0])
 #define SCM_FRAME_VARIABLE(fp,i)	fp[i]
 #define SCM_FRAME_PROGRAM(fp)		fp[-1]
 
@@ -92,7 +101,7 @@ extern scm_t_bits scm_tc16_heap_frame;
 
 #define SCM_HEAP_FRAME_P(x)	SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
 #define SCM_HEAP_FRAME_DATA(f)		((SCM *) SCM_SMOB_DATA (f))
-#define SCM_HEAP_FRAME_SELF(f)		(SCM_HEAP_FRAME_DATA (f)[0])
+#define SCM_HEAP_FRAME_SELF(f)		(SCM_HEAP_FRAME_DATA (f) + 0)
 #define SCM_HEAP_FRAME_POINTER(f)	(SCM_HEAP_FRAME_DATA (f) + 2)
 #define SCM_VALIDATE_HEAP_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
 

src/objcodes.c

@@ -183,7 +183,7 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
   ssize_t increment;
   scm_t_array_handle handle;
   char *base;
-  const char *c_bytecode;
+  const scm_t_uint8 *c_bytecode;
   SCM objcode;
 
   if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
@@ -235,7 +235,7 @@ SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_objcode_to_u8vector
 {
-  char *u8vector;
+  scm_t_uint8 *u8vector;
   size_t size;
 
   SCM_VALIDATE_OBJCODE (1, objcode);

src/programs.c

@@ -205,7 +205,7 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
 #define FUNC_NAME s_scm_program_bytecode
 {
   size_t size;
-  char *c_bytecode;
+  scm_t_uint8 *c_bytecode;
 
   SCM_VALIDATE_PROGRAM (1, program);
 

src/vm.c

@@ -175,7 +175,7 @@ vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
       frame = scm_c_make_heap_frame (fp);
       fp = SCM_HEAP_FRAME_POINTER (frame);
       SCM_FRAME_HEAP_LINK (fp)    = link;
-      SCM_FRAME_DYNAMIC_LINK (fp) = SCM_HEAP_FRAME_POINTER (link);
+      SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
     }
 
   /* Move stack data */

src/vm_loader.c

@@ -63,7 +63,7 @@ VM_DEFINE_LOADER (load_number, "load-number")
   size_t len;
 
   FETCH_LENGTH (len);
-  PUSH (scm_string_to_number (scm_from_locale_stringn (ip, len),
+  PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
 			      SCM_UNSPECIFIED /* radix = 10 */));
   /* Was: scm_istring2number (ip, len, 10)); */
   ip += len;
@@ -74,7 +74,7 @@ VM_DEFINE_LOADER (load_string, "load-string")
 {
   size_t len;
   FETCH_LENGTH (len);
-  PUSH (scm_from_locale_stringn (ip, len));
+  PUSH (scm_from_locale_stringn ((char *)ip, len));
   /* Was: scm_makfromstr (ip, len, 0) */
   ip += len;
   NEXT;
@@ -84,7 +84,7 @@ VM_DEFINE_LOADER (load_symbol, "load-symbol")
 {
   size_t len;
   FETCH_LENGTH (len);
-  PUSH (scm_from_locale_symboln (ip, len));
+  PUSH (scm_from_locale_symboln ((char *)ip, len));
   ip += len;
   NEXT;
 }
@@ -94,7 +94,7 @@ VM_DEFINE_LOADER (load_keyword, "load-keyword")
   SCM sym;
   size_t len;
   FETCH_LENGTH (len);
-  sym = scm_from_locale_symboln (ip, len);
+  sym = scm_from_locale_symboln ((char *)ip, len);
   PUSH (scm_make_keyword_from_dash_symbol (sym));
   ip += len;
   NEXT;
@@ -104,7 +104,7 @@ VM_DEFINE_LOADER (load_module, "load-module")
 {
   size_t len;
   FETCH_LENGTH (len);
-  PUSH (scm_c_lookup_env (scm_from_locale_symboln (ip, len)));
+  PUSH (scm_c_lookup_env (scm_from_locale_symboln ((char *)ip, len)));
   ip += len;
   NEXT;
 }
@@ -184,7 +184,7 @@ VM_DEFINE_LOADER (link, "link")
   size_t len;
 
   FETCH_LENGTH (len);
-  sym = scm_from_locale_symboln (ip, len);
+  sym = scm_from_locale_symboln ((char *)ip, len);
   ip += len;
 
 #if 0

testsuite/run-vm-tests.scm

@@ -1,14 +1,33 @@
-;;; A simple test-running script.
+;;; run-vm-tests.scm -- Run Guile-VM's test suite.
+;;;
+;;; Copyright 2005  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU 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 core)
 	     (system vm disasm)
 	     (system base compile)
 	     (system base language)
 
-	     (srfi srfi-1))
+	     (srfi srfi-1)
+	     (ice-9 r5rs))
 
 
-(define *scheme* (lookup-language 'scheme))
+(define %scheme (lookup-language 'scheme))
 
 (define (fetch-sexp-from-file file)
   (with-input-from-file file
@@ -21,13 +40,13 @@
 
 (define (compile-to-objcode sexp)
   "Compile the expression @var{sexp} into a VM program and return it."
-  (compile-in sexp (current-module) *scheme*))
+  (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)
+(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))))
@@ -48,11 +67,16 @@ it succeeded."
 ;; 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 ()
-				  (run-test-from-file file))
+				  (equal? (compile/run-test-from-file file)
+					  (eval (fetch-sexp-from-file file)
+						(interaction-environment))))
 				(lambda (key . args)
 				  (format #t "[~a/~a] " key args)
 				  #f))

testsuite/t-closure.scm

@@ -1,5 +1,8 @@
+(define func
   (let ((x 2))
     (lambda ()
       (let ((x++ (+ 1 x)))
 	(set! x x++)
-      x++)))
+	x++))))
+
+(list (func) (func) (func))

testsuite/t-closure2.scm

@@ -6,3 +6,5 @@
 		     (set! x x++)
 		     x++))))
     (do-uid)))
+
+(list (uid) (uid) (uid))

testsuite/t-closure3.scm

@@ -3,3 +3,5 @@
 	 (chbouib (lambda (z)
 		    (+ 7 z x))))
     (chbouib 77)))
+
+(stuff)

testsuite/t-do-loop.scm

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

testsuite/t-proc-with-setter.scm

@@ -12,3 +12,9 @@
        ((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))))