Translation from Scheme to GHIL, and compilation to GLIL work.

* src/*.c:  Removed calls to `scm_must_malloc', `SCM_MUST_MALLOC' and
  `scm_must_free'.  Same for `SCM_INUMP', `SCM_INUM', `SCM_STRING_CHARS',
  and the likes.
* module/system/base/syntax.scm:  Do not import `(ice-9 match)' and do
  not re-export `match', do not export `syntax-error' which was not
  defined here.
* module/system/base/compile.scm (call-with-compile-error-catch):  Use
  the `catch' form instead of `try'.
* src/instructions.c:  Use `scm_from_char ()' instead of the deprecated
  macro `SCM_MAKINUM ()'.
* src/instructions.h (scm_instruction):  Made `npop' a signed char.

git-archimport-id: lcourtes@laas.fr--2004-libre/guile-vm--revival--0.6--patch-2

module/system/base/compile.scm

@@ -41,9 +41,10 @@
   (throw 'syntax-error loc msg exp))
 
 (define-public (call-with-compile-error-catch thunk)
-  (try (thunk)
+  (catch 'syntax-error
-    ((syntax-error loc msg exp)
+	 (thunk)
-     (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
+	 (lambda (key loc msg exp)
+	   (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
 
 
 ;;;

module/system/base/syntax.scm

@@ -20,10 +20,9 @@
 ;;; Code:
 
 (define-module (system base syntax)
-  :use-module (ice-9 match)
   :use-module (ice-9 receive)
   :use-module (ice-9 and-let-star)
-  :export (stack-catch match syntax-error receive and-let*))
+  :export (stack-catch receive and-let*))
 
 
 ;;;

module/system/vm/assemble.scm

@@ -27,7 +27,7 @@
   :use-module (ice-9 match)
   :use-module (ice-9 regex)
   :use-module (ice-9 common-list)
-  :export (assemble))
+  :export (preprocess assemble))
 
 (define (assemble glil env . opts)
   (codegen (preprocess glil #f) #t))

src/envs.c

@@ -50,8 +50,8 @@ scm_t_bits scm_tc16_env;
 SCM
 scm_c_make_env (void)
 {
-  struct scm_env *p = scm_must_malloc (sizeof (struct scm_env),
+  struct scm_env *p = scm_gc_malloc (sizeof (struct scm_env),
-				       "scm_c_make_env");
+				     "env");
   p->identifier = SCM_BOOL_F;
   p->obarray    = scm_c_make_hash_table (ENV_OBARRAY_SIZE);
   SCM_RETURN_NEWSMOB (scm_tc16_env, p);
@@ -68,8 +68,9 @@ env_mark (SCM obj)
 static scm_sizet
 env_free (SCM obj)
 {
-  scm_must_free (SCM_ENV_DATA (obj));
+  scm_gc_free (SCM_ENV_DATA (obj), sizeof (struct scm_env),
-  return sizeof (struct scm_env);
+	       "env");
+  return 0;
 }
 
 

src/frames.c

@@ -52,10 +52,12 @@ scm_c_make_heap_frame (SCM *fp)
   SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
   SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
   size_t size = sizeof (SCM) * (upper - lower + 1);
-  SCM *p = scm_must_malloc (size, "scm_c_make_heap_frame");
+  SCM *p = scm_gc_malloc (size, "frame");
+
   SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
   p[0] = frame; /* self link */
   memcpy (p + 1, lower, size - sizeof (SCM));
+
   return frame;
 }
 
@@ -80,8 +82,10 @@ heap_frame_free (SCM obj)
   SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
   SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
   size_t size = sizeof (SCM) * (upper - lower + 1);
-  scm_must_free (SCM_HEAP_FRAME_DATA (obj));
+
-  return size;
+  scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame");
+
+  return 0;
 }
 
 /* Scheme interface */
@@ -113,7 +117,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
   SCM_VALIDATE_HEAP_FRAME (1, frame);
   SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
   return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
-			     SCM_INUM (index));
+			     scm_to_int (index));
 }
 #undef FUNC_NAME
 
@@ -124,7 +128,8 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
 {
   SCM_VALIDATE_HEAP_FRAME (1, frame);
   SCM_VALIDATE_INUM (2, index); /* FIXME: Check the range! */
-  SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), SCM_INUM (index)) = val;
+  SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+		      scm_to_int (index)) = val;
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME

src/instructions.c

@@ -58,10 +58,22 @@ struct scm_instruction *
 scm_lookup_instruction (SCM name)
 {
   struct scm_instruction *ip;
+  char *symbol;
+
   if (SCM_SYMBOLP (name))
     for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
-      if (strcmp (ip->name, SCM_SYMBOL_CHARS (name)) == 0)
+      {
-	return ip;
+	symbol = scm_to_locale_string (scm_symbol_to_string (name));
+	if ((symbol) && (strcmp (ip->name, symbol) == 0))
+	  {
+	    free (symbol);
+	    return ip;
+	  }
+
+	if (symbol)
+	  free (symbol);
+      }
+
   return 0;
 }
 
@@ -95,7 +107,7 @@ SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
 #define FUNC_NAME s_scm_instruction_length
 {
   SCM_VALIDATE_INSTRUCTION (1, inst);
-  return SCM_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
+  return scm_from_schar (SCM_INSTRUCTION_LENGTH (inst));
 }
 #undef FUNC_NAME
 
@@ -105,7 +117,7 @@ SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
 #define FUNC_NAME s_scm_instruction_pops
 {
   SCM_VALIDATE_INSTRUCTION (1, inst);
-  return SCM_MAKINUM (SCM_INSTRUCTION_POPS (inst));
+  return scm_from_schar (SCM_INSTRUCTION_POPS (inst));
 }
 #undef FUNC_NAME
 
@@ -115,7 +127,7 @@ SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
 #define FUNC_NAME s_scm_instruction_pushes
 {
   SCM_VALIDATE_INSTRUCTION (1, inst);
-  return SCM_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
+  return scm_from_char (SCM_INSTRUCTION_PUSHES (inst));
 }
 #undef FUNC_NAME
 
@@ -125,7 +137,7 @@ SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
 #define FUNC_NAME s_scm_instruction_to_opcode
 {
   SCM_VALIDATE_INSTRUCTION (1, inst);
-  return SCM_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+  return scm_from_char (SCM_INSTRUCTION_OPCODE (inst));
 }
 #undef FUNC_NAME
 
@@ -136,7 +148,7 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
 {
   int i;
   SCM_VALIDATE_INUM (1, op);
-  i = SCM_INUM (op);
+  i = scm_to_int (op);
   SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
   return scm_str2symbol (scm_instruction_table[i].name);
 }

src/instructions.h

@@ -57,9 +57,13 @@ enum scm_opcode {
 
 struct scm_instruction {
   enum scm_opcode opcode;	/* opcode */
-  char *name;			/* instruction name */
+  const char *name;		/* instruction name */
-  char len;			/* instruction length */
+  signed char len;		/* Instruction length.  This may be -1 for
-  char npop;			/* the number of values popped */
+				   the loader (see the `VM_LOADER'
+				   macro).  */
+  signed char npop;		/* The number of values popped.  This may be
+				   -1 for insns like `call' which can take
+				   any number of arguments.  */
   char npush;			/* the number of values pushed */
 };
 

src/objcodes.c

@@ -62,9 +62,10 @@ static SCM
 make_objcode (size_t size)
 #define FUNC_NAME "make_objcode"
 {
-  struct scm_objcode *p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
+  struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
+					 "objcode");
   p->size = size;
-  p->base = SCM_MUST_MALLOC (size);
+  p->base = scm_gc_malloc (size, "objcode-base");
   p->fd   = -1;
   SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
 }
@@ -85,7 +86,7 @@ make_objcode_by_mmap (int fd)
   addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
   if (addr == MAP_FAILED) SCM_SYSERROR;
 
-  p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
+  p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
   p->size = st.st_size;
   p->base = addr;
   p->fd   = fd;
@@ -97,7 +98,7 @@ static scm_sizet
 objcode_free (SCM obj)
 #define FUNC_NAME "objcode_free"
 {
-  size_t size = (sizeof (struct scm_objcode));
+  size_t size = sizeof (struct scm_objcode);
   struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
 
   if (p->fd >= 0)
@@ -109,13 +110,11 @@ objcode_free (SCM obj)
       if (rv < 0) SCM_SYSERROR;
     }
   else
-    {
+    scm_gc_free (p->base, p->size, "objcode-base");
-      size += p->size;
-      scm_must_free (p->base);
-    }
 
-  scm_must_free (p);
+  scm_gc_free (p, size, "objcode");
-  return size;
+
+  return 0;
 }
 #undef FUNC_NAME
 
@@ -139,21 +138,26 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
 #define FUNC_NAME s_scm_bytecode_to_objcode
 {
   size_t size;
-  char *base;
+  char *base, *c_bytecode;
   SCM objcode;
 
   SCM_VALIDATE_STRING (1, bytecode);
   SCM_VALIDATE_INUM (2, nlocs);
   SCM_VALIDATE_INUM (3, nexts);
 
-  size = SCM_STRING_LENGTH (bytecode) + 10;
+  size = scm_c_string_length (bytecode) + 10;
   objcode = make_objcode (size);
   base = SCM_OBJCODE_BASE (objcode);
 
   memcpy (base, OBJCODE_COOKIE, 8);
-  base[8] =  SCM_INUM (nlocs);
+  base[8] = scm_to_int (nlocs);
-  base[9] =  SCM_INUM (nexts);
+  base[9] = scm_to_int (nexts);
-  memcpy (base + 10, SCM_STRING_CHARS (bytecode), size - 10);
+
+  /* FIXME:  We should really use SRFI-4 u8vectors!  (Ludovic) */
+  c_bytecode = scm_to_locale_string (bytecode);
+  memcpy (base + 10, c_bytecode, size - 10);
+  free (c_bytecode);
+
   return objcode;
 }
 #undef FUNC_NAME

src/programs.c

@@ -53,7 +53,8 @@ SCM
 scm_c_make_program (void *addr, size_t size, SCM holder)
 #define FUNC_NAME "scm_c_make_program"
 {
-  struct scm_program *p = SCM_MUST_MALLOC (sizeof (struct scm_program));
+  struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
+					 "program");
   p->size     = size;
   p->nargs    = 0;
   p->nrest    = 0;
@@ -66,7 +67,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
 
   /* If nobody holds bytecode's address, then allocate a new memory */
   if (SCM_FALSEP (holder))
-    p->base = SCM_MUST_MALLOC (size);
+    p->base = scm_gc_malloc (size, "program-base");
   else
     p->base = addr;
 
@@ -98,13 +99,13 @@ program_free (SCM obj)
 {
   struct scm_program *p = SCM_PROGRAM_DATA (obj);
   scm_sizet size = (sizeof (struct scm_program));
+
   if (SCM_FALSEP (p->holder))
-    {
+    scm_gc_free (p->base, p->size, "program-base");
-      size += p->size;
+
-      scm_must_free (p->base);
+  scm_gc_free (p, size, "program");
-    }
+
-  scm_must_free (p);
+  return 0;
-  return size;
 }
 
 static SCM

src/vm.c

@@ -68,10 +68,10 @@ scm_t_bits scm_tc16_vm_cont;
 static SCM
 capture_vm_cont (struct scm_vm *vp)
 {
-  struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
+  struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
   p->stack_size = vp->stack_limit - vp->sp;
-  p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
+  p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
-				   "capture_vm_cont");
+				 "capture_vm_cont");
   p->stack_limit = p->stack_base + p->stack_size - 2;
   p->ip = vp->ip;
   p->sp = (SCM *) (vp->stack_limit - vp->sp);
@@ -110,10 +110,11 @@ static scm_sizet
 vm_cont_free (SCM obj)
 {
   struct scm_vm *p = SCM_VM_CONT_VP (obj);
-  int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
+
-  scm_must_free (p->stack_base);
+  scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
-  scm_must_free (p);
+  scm_gc_free (p, sizeof (struct scm_vm), "vm");
-  return size;
+
+  return 0;
 }
 
 
@@ -232,9 +233,11 @@ make_vm (void)
 #define FUNC_NAME "make_vm"
 {
   int i;
-  struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
+  struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
-  vp->stack_base  = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM));
+  vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
+				   "stack-base");
   vp->stack_limit = vp->stack_base + vp->stack_size - 3;
   vp->ip    	  = NULL;
   vp->sp    	  = vp->stack_base - 1;
@@ -272,10 +275,12 @@ static scm_sizet
 vm_free (SCM obj)
 {
   struct scm_vm *vp = SCM_VM_DATA (obj);
-  int size = (sizeof (struct scm_vm) + vp->stack_size * sizeof (SCM));
+
-  scm_must_free (vp->stack_base);
+  scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
-  scm_must_free (vp);
+	       "stack-base");
-  return size;
+  scm_gc_free (vp, sizeof (struct scm_vm), "vm");
+
+  return 0;
 }
 
 SCM_SYMBOL (sym_debug, "debug");

src/vm_loader.c

@@ -138,9 +138,9 @@ VM_DEFINE_LOADER (load_program, "load-program")
 
   /* init parameters */
   /* NOTE: format defined in system/vm/assemble.scm */
-  if (SCM_INUMP (x))
+  if (scm_is_integer (x))
     {
-      int i = SCM_INUM (x);
+      int i = scm_to_int (x);
       if (-128 <= i && i <= 127)
 	{
 	  /* 8-bit representation */
@@ -162,10 +162,10 @@ VM_DEFINE_LOADER (load_program, "load-program")
     {
       /* Other cases */
       sp -= 4;
-      p->nargs = SCM_INUM (sp[0]);
+      p->nargs = scm_to_int (sp[0]);
-      p->nrest = SCM_INUM (sp[1]);
+      p->nrest = scm_to_int (sp[1]);
-      p->nlocs = SCM_INUM (sp[2]);
+      p->nlocs = scm_to_int (sp[2]);
-      p->nexts = SCM_INUM (sp[3]);
+      p->nexts = scm_to_int (sp[3]);
     }
 
   PUSH (prog);

src/vm_scheme.c

@@ -164,12 +164,12 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
  */
 
 #undef REL
-#define REL(crel,srel)					\
+#define REL(crel,srel)						\
-{							\
+{								\
-  ARGS2 (x, y);						\
+  ARGS2 (x, y);							\
-  if (SCM_INUMP (x) && SCM_INUMP (y))			\
+  if (scm_is_integer (x) && scm_is_integer (y))			\
-    RETURN (SCM_BOOL (SCM_INUM (x) crel SCM_INUM (y)));	\
+    RETURN (SCM_BOOL (scm_to_int (x) crel scm_to_int (y)));	\
-  RETURN (srel (x, y));					\
+  RETURN (srel (x, y));						\
 }
 
 VM_DEFINE_FUNCTION (ee, "ee?", 2)
@@ -206,11 +206,11 @@ VM_DEFINE_FUNCTION (ge, "ge?", 2)
 #define FUNC1(CEXP,SEXP)			\
 {						\
   ARGS1 (x);					\
-  if (SCM_INUMP (x))				\
+  if (scm_is_integer (x))			\
     {						\
       int n = CEXP;				\
       if (SCM_FIXABLE (n))			\
-	RETURN (SCM_MAKINUM (n));		\
+	RETURN (scm_from_int (n));		\
     }						\
   RETURN (SEXP);				\
 }
@@ -218,12 +218,12 @@ VM_DEFINE_FUNCTION (ge, "ge?", 2)
 #undef FUNC2
 #define FUNC2(CFUNC,SFUNC)				\
 {							\
-  ARGS2 (x, y);					\
+  ARGS2 (x, y);						\
-  if (SCM_INUMP (x) && SCM_INUMP (y))			\
+  if (scm_is_integer (x) && scm_is_integer (y))		\
     {							\
-      int n = SCM_INUM (x) CFUNC SCM_INUM (y);	\
+      int n = scm_to_int (x) CFUNC scm_to_int (y);	\
       if (SCM_FIXABLE (n))				\
-	RETURN (SCM_MAKINUM (n));			\
+	RETURN (scm_from_int (n));			\
     }							\
   RETURN (SFUNC (x, y));				\
 }