Removed a few more deprecated function calls; documented closures.

* src/Makefile.am (.c.x):  Fixed the rule.

* src/envs.c:  Use `scm_hash_get_handle ()' instead of
  `scm_sym2ovcell_soft ()' and `scm_hash_create_handle_x ()' instead of
  `scm_intern_symbol ()'.

* src/objcodes.c (bytecode->objcode):  Don't use `SCM_VALIDATE_INUM', use
  `SCM_VALIDATE_NUMBER' instead.
  (make_objcode_by_mmap):  Check whether the file is smaller than the
  magic cookies; check whether the magic cookies are there.

* src/frames.c (frame-local-ref):  Likewise, but use `SCM_MAKE_VALIDATE'.
  (frame-local-set!):  Likewise.

* src/instructions.c (opcode->instruction):  Likewise.

* src/programs.c (program-external-set!):  New function.

* src/guile-disasm.in:  New file.

* src/Makefile.am:  Produce `guile-disasm'.

* doc/guile-vm.texi:  Documented `external-ref', `external-set', `local-ref'
  and `local-set'.

* module/system/vm/disasm.scm (disassemble-bytecode):  Fixed the way
  `load-program' is represented.

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

11 files changed, 149 insertions, 43 deletions

diff --git a/doc/guile-vm.texi b/doc/guile-vm.texi
index ecf6d5808..8dee2e48f 100644
--- a/doc/guile-vm.texi
+++ b/doc/guile-vm.texi
@@ -516,19 +516,80 @@ As an example, let us look at what a simple function call looks like:
 This call yields the following sequence of instructions:
 
 @example
-(link "+")      ;; lookup binding "x"
+(link "+")      ;; lookup binding "+"
 (variable-ref)  ;; dereference it
 (make-int8 2)   ;; push immediate value `2'
 (make-int8 3)   ;; push immediate value `3'
 (tail-call 2)   ;; call the proc at sp[-3] with two args
 @end example
 
-@itemize
-@item %alloc
-@item %bind
-@item %export
-@item %unbind
-@end itemize
+@deffn @insn{} local-ref offset
+Push onto the stack the value of the local variable located at
+@var{offset} within the current stack frame.
+@end deffn
+
+@deffn @insn{} local-set offset
+Pop the Scheme object located on top of the stack and make it the new
+value of the local variable located at @var{offset} within the current
+stack frame.
+@end deffn
+
+@deffn @insn{} external-ref offset
+Push the value of the closure variable located at position
+@var{offset} within the program's list of external variables.
+@end deffn
+
+@deffn @insn{} external-set offset
+Pop the Scheme object located on top of the stack and make it the new
+value of the closure variable located at @var{offset} within the
+program's list of external variables.
+@end deffn
+
+Let's look at a more complete example:
+
+@example
+(let ((x 2))
+  (lambda ()
+    (let ((x++ (+ 1 x)))
+      (set! x x++)
+      x++)))
+@end example
+
+The resulting program has one external (closure) variable, i.e. its
+@var{nexts} is set to 1 (@pxref{Subprogram Control Instructions}).
+This yields the following code:
+
+@example
+   ;; the traditional program prologue
+   0    (make-int8 2)
+   2    (external-set 0)
+   4    (make-int8 4)
+   6    (link "+")    ;; lookup `+'
+   9    (vector 1)    ;; create the external variable vector for
+                      ;; later use by `object-ref' and `object-set'
+        ...
+  40    (load-program ##34#)
+  59    (return)
+@end example
+
+The program loaded here by @var{load-program} contains the following
+sequence of instructions:
+
+@example
+   0    (object-ref 0)     ;; push the variable for `+'
+   2    (variable-ref)     ;; dereference `+'
+   3    (make-int8:1)      ;; push 1
+   4    (external-ref 0)   ;; push the value of `x'
+   6    (call 2)           ;; call `+' and push the result
+   8    (local-set 0)      ;; make it the new value of `x++'
+  10    (local-ref 0)      ;; push the value of `x++'
+  12    (external-set 0)   ;; make it the new value of `x'
+  14    (local-ref 0)      ;; push the value of `x++'
+  16    (return)           ;; return it
+@end example
+
+At this point, you know pretty much everything about the three types
+of variables a program may need to access.
 
 
 @node Branch Instructions, Subprogram Control Instructions, Environment Control Instructions, Instruction Set
@@ -619,7 +680,7 @@ This yields the following assembly code:
 (make-int8 64)   ;; number of args, vars, etc. (see below)
 (link "frob")
 (link "%magic")
-(vector 2)
+(vector 2)       ;; object table (external bindings)
 ...
 (load-program #u8(20 0 23 21 0 20 1 23 36 2))
 (return)
@@ -637,7 +698,7 @@ argument which is the bytecode of the program itself.  Disassembled,
 this bytecode looks like:
 
 @example
-(object-ref 0)  ;; push the variable object of `frob'
+z(object-ref 0)  ;; push the variable object of `frob'
 (variable-ref)  ;; dereference it
 (local-ref 0)   ;; push the value of `x'
 (object-ref 1)  ;; push the variable object of `%magic'
@@ -646,7 +707,9 @@ this bytecode looks like:
 @end example
 
 This clearly shows that there is little difference between references
-to local variables and references to externally bound variables.
+to local variables and references to externally bound variables since
+lookup of externally bound variables if performed only once before the
+program is run.
 
 @deffn @insn{} load-program bytecode
 Load the program whose bytecode is @var{bytecode} (a u8vector), pop
@@ -664,8 +727,8 @@ object table);
 representing respectively the number of arguments taken by the
 function (@var{nargs}), the number of @dfn{rest arguments}
 (@var{nrest}, 0 or 1), the number of local variables (@var{nlocs}) and
-the number of external variables (@var{nexts}) (see the example
-above).
+the number of external variables (@var{nexts}) (@pxref{Environment
+Control Instructions}).
 @end itemize
 
 @end deffn
@@ -684,12 +747,16 @@ Call the procedure, continuation or program located at
 @code{sp[-nargs]} with the @var{nargs} arguments located from
 @code{sp[0]} to @code{sp[-nargs + 1]}.  The
 procedure/continuation/program and its arguments are dropped from the
-stack and the result is pushed.
+stack and the result is pushed.  When calling a program, the
+@code{call} instruction reserves room for its local variables on the
+stack, and initializes its list of closure variables and its vector of
+externally bound variables.
 @end deffn
 
 @deffn @insn{} tail-call nargs
 Same as @code{call} except that, for tail-recursive calls to a
 program, the current stack frame is re-used, as required by RnRS.
+This instruction is otherwise similar to @code{call}.
 @end deffn
 
 
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm
index 453175752..9250829e0 100644
--- a/module/system/vm/conv.scm
+++ b/module/system/vm/conv.scm
@@ -26,7 +26,7 @@
   :use-module (srfi srfi-4)
   :use-module (srfi srfi-1)
   :export (code-pack code-unpack object->code code->object code->bytes
-		     make-byte-decoder))
+	   make-byte-decoder))
 
 ;;;
 ;;; Code compress/decompression
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 771389a9b..f571d1089 100644
--- a/module/system/vm/disasm.scm
+++ b/module/system/vm/disasm.scm
@@ -76,7 +76,7 @@
 	  (('load-program x)
 	   (let ((sym (gensym "")))
 	     (set! programs (acons sym x programs))
-	     (print-info addr (format #f "load-program #~A" sym) #f)))
+	     (print-info addr (format #f "(load-program #~A)" sym) #f)))
 	  (else
 	   (let ((info (list->info code))
 		 (extra (original-value addr code objs)))
diff --git a/src/Makefile.am b/src/Makefile.am
index e1d8db014..82d8604d4 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -1,5 +1,5 @@
 bin_PROGRAMS = guile-vm
-bin_SCRIPTS = guilec
+bin_SCRIPTS = guilec guile-disasm
 guile_vm_SOURCES = guile-vm.c
 guile_vm_LDADD = libguilevm.la 
 guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
@@ -14,7 +14,8 @@ libguilevm_la_SOURCES =							\
 	vm_engine.h vm_expand.h
 libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
 libguilevm_la_LDFLAGS += -pg
-EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
+EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c \
+             guilec.in guile-disasm.in
 BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
 	envs.x frames.x instructions.x objcodes.x programs.x vm.x
 
@@ -32,7 +33,7 @@ SUFFIXES = .i .x
 	grep '^VM_DEFINE' $< > $@
 
 .c.x:
-	$(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+	$(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
 	|| { rm $@; false; }
 
 
@@ -44,9 +45,9 @@ SUFFIXES = .i .x
 %.s: %.c
 	$(CC) -S -dA $(DEFS) $(INCLUDES) $(CFLAGS) $(CPPFLAGS) -o $@ $<
 
-GUILE = "$(bindir)/guile"
-guilec: guilec.in
-	sed "s!@guile@!$(GUILE)!" guilec.in > guilec
-	@chmod 755 guilec
+
+%: %.in
+	sed "s!@guile@!$(GUILE)!" $^ > $@
+	@chmod 755 $@
 
 $(BUILT_SOURCES): config.h vm_expand.h
diff --git a/src/envs.c b/src/envs.c
index 2f3212b8f..c6ace0300 100644
--- a/src/envs.c
+++ b/src/envs.c
@@ -85,7 +85,7 @@ SCM
 scm_c_lookup_env (SCM identifier)
 {
   /* Check if the env is already loaded */
-  SCM vcell = scm_sym2ovcell_soft (identifier, env_table);
+  SCM vcell = scm_hash_get_handle (env_table, identifier);
 
   /* If not, load the env */
   if (SCM_FALSEP (vcell))
@@ -95,21 +95,24 @@ scm_c_lookup_env (SCM identifier)
       if (!SCM_ENV_P (env))
 	scm_misc_error ("scm_c_lookup_env",
 			"Invalid env: ~S", SCM_LIST1 (env));
-      scm_intern_symbol (env_table, identifier);
-      vcell = scm_sym2ovcell_soft (identifier, env_table);
-      SCM_SETCDR (vcell, env);
+      vcell = scm_hash_create_handle_x (env_table, identifier, env);
     }
 
-  return SCM_CDR (vcell);
+  return (SCM_CDR (vcell));
 }
 
 SCM
 scm_c_env_vcell (SCM env, SCM name, int intern)
 {
+  SCM vcell;
   SCM ob = SCM_ENV_OBARRAY (env);
+
   if (intern)
-    scm_intern_symbol (ob, name);
-  return scm_sym2ovcell_soft (name, ob);
+    vcell = scm_hash_create_handle_x (ob, name, SCM_UNSPECIFIED);
+  else
+    vcell = scm_hash_get_handle (ob, name);
+
+  return vcell;
 }
 
 
@@ -162,10 +165,13 @@ SCM_DEFINE (scm_env_bound_p, "env-bound?", 2, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_env_bound_p
 {
-  SCM vcell;
+  SCM obarray, vcell;
   SCM_VALIDATE_ENV (1, env);
   SCM_VALIDATE_SYMBOL (2, name);
-  vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+
+  obarray = SCM_ENV_OBARRAY (env);
+  vcell = scm_hash_get_handle (obarray, name);
+
   return SCM_BOOL (!SCM_FALSEP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
 }
 #undef FUNC_NAME
@@ -178,7 +184,7 @@ SCM_DEFINE (scm_env_ref, "env-ref", 2, 0, 0,
   SCM vcell;
   SCM_VALIDATE_ENV (1, env);
   SCM_VALIDATE_SYMBOL (2, name);
-  vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+  vcell = scm_hash_get_handle (name, SCM_ENV_OBARRAY (env));
   if (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell)))
     SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
 		    SCM_LIST2 (env, name));
@@ -194,11 +200,12 @@ SCM_DEFINE (scm_env_set_x, "env-set!", 3, 0, 0,
   SCM vcell;
   SCM_VALIDATE_ENV (1, env);
   SCM_VALIDATE_SYMBOL (2, name);
-  vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+  vcell = scm_hash_get_handle (name, SCM_ENV_OBARRAY (env));
   if (SCM_FALSEP (vcell))
     SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
 		    SCM_LIST2 (env, name));
   SCM_SETCDR (vcell, val);
+
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
diff --git a/src/envs.h b/src/envs.h
index 79a410de7..455cd1daa 100644
--- a/src/envs.h
+++ b/src/envs.h
@@ -47,10 +47,12 @@
 
 extern scm_t_bits scm_tc16_env;
 
-struct scm_env {
+struct scm_env
+{
   SCM identifier;
   SCM obarray;
 };
+typedef struct scm_env scm_env_t;
 
 #define SCM_ENV_P(x)		SCM_SMOB_PREDICATE (scm_tc16_env, x)
 #define SCM_ENV_DATA(x)		((struct scm_env *) SCM_SMOB_DATA (x))
diff --git a/src/frames.c b/src/frames.c
index 1b83bf022..80c2147af 100644
--- a/src/frames.c
+++ b/src/frames.c
@@ -115,7 +115,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
 #define FUNC_NAME s_scm_frame_local_ref
 {
   SCM_VALIDATE_HEAP_FRAME (1, frame);
-  SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
+  SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
   return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
 			     SCM_I_INUM (index));
 }
@@ -127,7 +127,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
 #define FUNC_NAME s_scm_frame_local_set_x
 {
   SCM_VALIDATE_HEAP_FRAME (1, frame);
-  SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
+  SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
   SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
 		      SCM_I_INUM (index)) = val;
   return SCM_UNSPECIFIED;
diff --git a/src/guile-disasm.in b/src/guile-disasm.in
new file mode 100644
index 000000000..08095f505
--- /dev/null
+++ b/src/guile-disasm.in
@@ -0,0 +1,11 @@
+#!@guile@ -s
+!#
+
+;; Obviously, this is -*- Scheme -*-.
+
+(use-modules (system vm core)
+	     (system vm disasm))
+
+(for-each (lambda (file)
+	    (disassemble-objcode (load-objcode file)))
+	  (cdr (command-line)))
diff --git a/src/instructions.c b/src/instructions.c
index ae04d82d4..f2a2b1ec9 100644
--- a/src/instructions.c
+++ b/src/instructions.c
@@ -147,7 +147,7 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
 #define FUNC_NAME s_scm_opcode_to_instruction
 {
   int i;
-  SCM_VALIDATE_INUM (1, op);
+  SCM_MAKE_VALIDATE (1, op, I_INUMP);
   i = SCM_I_INUM (op);
   SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
   return scm_from_locale_symbol (scm_instruction_table[i].name);
diff --git a/src/objcodes.c b/src/objcodes.c
index 0e494b77a..8903bd338 100644
--- a/src/objcodes.c
+++ b/src/objcodes.c
@@ -82,10 +82,15 @@ make_objcode_by_mmap (int fd)
   struct scm_objcode *p;
 
   ret = fstat (fd, &st);
-  if (ret < 0) SCM_SYSERROR;
+  if ((ret < 0) || (st.st_size <= strlen (OBJCODE_COOKIE)))
+    SCM_SYSERROR;
 
   addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
-  if (addr == MAP_FAILED) SCM_SYSERROR;
+  if (addr == MAP_FAILED)
+    SCM_SYSERROR;
+
+  if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+    SCM_SYSERROR;
 
   p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
   p->size = st.st_size;
@@ -179,8 +184,8 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
 
   if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
     scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
-  SCM_VALIDATE_INUM (2, nlocs);
-  SCM_VALIDATE_INUM (3, nexts);
+  SCM_VALIDATE_NUMBER (2, nlocs);
+  SCM_VALIDATE_NUMBER (3, nexts);
 
   c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
   assert (increment == 1);
@@ -191,8 +196,8 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
   base = SCM_OBJCODE_BASE (objcode);
 
   memcpy (base, OBJCODE_COOKIE, 8);
-  base[8] = SCM_I_INUM (nlocs);
-  base[9] = SCM_I_INUM (nexts);
+  base[8] = scm_to_uint8 (nlocs);
+  base[9] = scm_to_uint8 (nexts);
 
   memcpy (base + 10, c_bytecode, size - 10);
 
diff --git a/src/programs.c b/src/programs.c
index 423b14b11..50848a774 100644
--- a/src/programs.c
+++ b/src/programs.c
@@ -186,6 +186,19 @@ SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
+	    (SCM program, SCM external),
+	    "Modify the list of closure variables of @var{program} (for "
+	    "debugging purposes).")
+#define FUNC_NAME s_scm_program_external_set_x
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  SCM_VALIDATE_LIST (2, external);
+  SCM_PROGRAM_DATA (program)->external = external;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
 	    (SCM program),
 	    "Return a u8vector containing @var{program}'s bytecode.")