From 23b587b0a1e73940b167f67a1d1f7273b7fc5f79 Mon Sep 17 00:00:00 2001
From: Ludovic Courtes <ludovic.courtes@laas.fr>
Date: Mon, 2 Jan 2006 18:04:04 +0000
Subject: [PATCH] Encode the length of constant lists/vectors on 2 octets
 instead of 1.

* module/system/vm/assemble.scm (dump-object!): New sub-procedure
  `too-long'.  For `list' and `vector', encode the length on 2 octets
  instead of 1 and report an error if a list/vector is longer than 65535.

* module/system/vm/disasm.scm (original-value): New sub-procedure
  `list-or-vector?'; when true, return the number of elements for that
  list/vector.

* src/vm_system.c (list): Fetch the length as a two-octet integer.
  (vector): Likewise.

* testsuite/t-basic-contructs.scm: New.

* testsuite/Makefile.am (vm_test_files): Added the above file.

* module/system/vm/core.scm (load-compiled): Added a bit of
  documentation.

git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-11
---
 module/system/vm/assemble.scm   | 13 ++++++++++---
 module/system/vm/core.scm       |  2 ++
 module/system/vm/disasm.scm     | 10 +++++++++-
 src/vm_system.c                 | 16 ++++++++++------
 testsuite/Makefile.am           |  1 +
 testsuite/t-basic-contructs.scm | 16 ++++++++++++++++
 6 files changed, 48 insertions(+), 10 deletions(-)
 create mode 100644 testsuite/t-basic-contructs.scm

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 3570c20f1..a37314aca 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -213,9 +213,12 @@
 ;;; Object dump
 ;;;
 
-;; NOTE: undumpped in vm_load.c.
+;; NOTE: undumpped in vm_system.c
 
 (define (dump-object! push-code! x)
+  (define (too-long x)
+    (error (string-append x " too long")))
+
   (let dump! ((x x))
     (cond
      ((object->code x) => push-code!)
@@ -269,13 +272,17 @@
 		       ,(symbol->string (keyword-dash-symbol x)))))
 	(($ list)
 	 (for-each dump! x)
-	 (push-code! `(list ,(length x))))
+	 (let ((len (length x)))
+	   (if (>= len 65536) (too-long 'list))
+	   (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
 	(($ pair)
 	 (dump! (car x))
 	 (dump! (cdr x))
 	 (push-code! `(cons)))
 	(($ vector)
 	 (for-each dump! (vector->list x))
-	 (push-code! `(vector ,(vector-length x))))
+	 (let ((len (vector-length x)))
+	   (if (>= len 65536) (too-long 'vector))
+	   (push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
 	(else
 	 (error "assemble: unrecognized object" x)))))))
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
index 9e60b17c3..55c3c8465 100644
--- a/module/system/vm/core.scm
+++ b/module/system/vm/core.scm
@@ -163,4 +163,6 @@
 (define-public (vm-load vm objcode)
   (vm (objcode->program objcode)))
 
+;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules'
+;; and friends.
 (set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index f571d1089..9d0bb9c24 100644
--- a/module/system/vm/disasm.scm
+++ b/module/system/vm/disasm.scm
@@ -113,8 +113,16 @@
 (define (original-value addr code objs)
   (define (branch-code? code)
     (string-match "^br" (symbol->string (car code))))
+  (define (list-or-vector? code)
+    (case (car code)
+      ((list vector) #t)
+      (else #f)))
+
   (let ((code (code-unpack code)))
-    (cond ((code->object code) => object->string)
+    (cond ((list-or-vector? code)
+	   (let ((len (+ (* (cadr code) 256) (caddr code))))
+	     (format #f "~a element~a" len (if (> len 1) "s" ""))))
+	  ((code->object code) => object->string)
 	  ((branch-code? code)
 	   (let ((offset (+ (* (cadr code) 256) (caddr code))))
 	     (format #f "-> ~A" (+ addr offset 3))))
diff --git a/src/vm_system.c b/src/vm_system.c
index e220b613c..4dcafb113 100644
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -149,17 +149,21 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (list, "list", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
 {
-  int n = FETCH ();
-  POP_LIST (n);
+  unsigned h = FETCH ();
+  unsigned l = FETCH ();
+  unsigned len = ((h << 8) + l);
+  POP_LIST (len);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (vector, "vector", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
 {
-  int n = FETCH ();
-  POP_LIST (n);
+  unsigned h = FETCH ();
+  unsigned l = FETCH ();
+  unsigned len = ((h << 8) + l);
+  POP_LIST (len);
   *sp = scm_vector (*sp);
   NEXT;
 }
diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index ac569d792..a3e8921c2 100644
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -4,6 +4,7 @@
 GUILE_VM = $(top_srcdir)/src/guile-vm
 
 vm_test_files =					\
+      t-basic-contructs.scm			\
       t-global-bindings.scm			\
       t-closure.scm				\
       t-closure2.scm				\
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))))
+