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

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index e6b2d13..49a47ee 100644 (file)
--- a/module/system/base/compile.scm
+++ b/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)
-    ((syntax-error loc msg exp)
-     (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
+  (catch 'syntax-error
+        (thunk)
+        (lambda (key loc msg exp)
+          (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
 
 \f
 ;;;

diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index fba2167..bcc926b 100644 (file)
--- a/module/system/base/syntax.scm
+++ b/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*))
 
 \f
 ;;;

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 36dd24a..726312a 100644 (file)
--- a/module/system/vm/assemble.scm
+++ b/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))

diff --git a/src/envs.c b/src/envs.c
index f1b3cee..2f3212b 100644 (file)
--- a/src/envs.c
+++ b/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),
-                                      "scm_c_make_env");
+  struct scm_env *p = scm_gc_malloc (sizeof (struct scm_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));
-  return sizeof (struct scm_env);
+  scm_gc_free (SCM_ENV_DATA (obj), sizeof (struct scm_env),
+              "env");
+  return 0;
 }
 
 \f

diff --git a/src/frames.c b/src/frames.c
index dc216e9..f2f1664 100644 (file)
--- a/src/frames.c
+++ b/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

diff --git a/src/instructions.c b/src/instructions.c
index 6cfdf63..93115de 100644 (file)
--- a/src/instructions.c
+++ b/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);
 }

diff --git a/src/instructions.h b/src/instructions.h
index 6b67574..6f1a146 100644 (file)
--- a/src/instructions.h
+++ b/src/instructions.h
@@ -57,9 +57,13 @@ enum scm_opcode {
 
 struct scm_instruction {
   enum scm_opcode opcode;      /* opcode */
-  char *name;                  /* instruction name */
-  char len;                    /* instruction length */
-  char npop;                   /* the number of values popped */
+  const char *name;            /* instruction name */
+  signed char len;             /* Instruction length.  This may be -1 for
+                                  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 */
 };
 

diff --git a/src/objcodes.c b/src/objcodes.c
index ad0d2e7..f845105 100644 (file)
--- a/src/objcodes.c
+++ b/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
-    {
-      size += p->size;
-      scm_must_free (p->base);
-    }
+    scm_gc_free (p->base, p->size, "objcode-base");
+
+  scm_gc_free (p, size, "objcode");
 
-  scm_must_free (p);
-  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[9] =  SCM_INUM (nexts);
-  memcpy (base + 10, SCM_STRING_CHARS (bytecode), size - 10);
+  base[8] = scm_to_int (nlocs);
+  base[9] = scm_to_int (nexts);
+
+  /* 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

diff --git a/src/programs.c b/src/programs.c
index 39f43de..5c1cb49 100644 (file)
--- a/src/programs.c
+++ b/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))
-    {
-      size += p->size;
-      scm_must_free (p->base);
-    }
-  scm_must_free (p);
-  return size;
+    scm_gc_free (p->base, p->size, "program-base");
+
+  scm_gc_free (p, size, "program");
+
+  return 0;
 }
 
 static SCM

diff --git a/src/vm.c b/src/vm.c
index e0904f8..8a4fa17 100644 (file)
--- a/src/vm.c
+++ b/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),
-                                  "capture_vm_cont");
+  p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
+                                "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_must_free (p);
-  return size;
+
+  scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
+  scm_gc_free (p, sizeof (struct scm_vm), "vm");
+
+  return 0;
 }
 
 \f
@@ -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_must_free (vp);
-  return size;
+
+  scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
+              "stack-base");
+  scm_gc_free (vp, sizeof (struct scm_vm), "vm");
+
+  return 0;
 }
 
 SCM_SYMBOL (sym_debug, "debug");

diff --git a/src/vm_loader.c b/src/vm_loader.c
index cd2eb21..fb30b54 100644 (file)
--- a/src/vm_loader.c
+++ b/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->nrest = SCM_INUM (sp[1]);
-      p->nlocs = SCM_INUM (sp[2]);
-      p->nexts = SCM_INUM (sp[3]);
+      p->nargs = scm_to_int (sp[0]);
+      p->nrest = scm_to_int (sp[1]);
+      p->nlocs = scm_to_int (sp[2]);
+      p->nexts = scm_to_int (sp[3]);
     }
 
   PUSH (prog);

diff --git a/src/vm_scheme.c b/src/vm_scheme.c
index bb552d9..a134dfe 100644 (file)
--- a/src/vm_scheme.c
+++ b/src/vm_scheme.c
@@ -164,12 +164,12 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
  */
 
 #undef REL
-#define REL(crel,srel)                                 \
-{                                                      \
-  ARGS2 (x, y);                                                \
-  if (SCM_INUMP (x) && SCM_INUMP (y))                  \
-    RETURN (SCM_BOOL (SCM_INUM (x) crel SCM_INUM (y)));        \
-  RETURN (srel (x, y));                                        \
+#define REL(crel,srel)                                         \
+{                                                              \
+  ARGS2 (x, y);                                                        \
+  if (scm_is_integer (x) && scm_is_integer (y))                        \
+    RETURN (SCM_BOOL (scm_to_int (x) crel scm_to_int (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);                                        \
-  if (SCM_INUMP (x) && SCM_INUMP (y))                  \
+  ARGS2 (x, 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));                               \
 }