add memoized expression accessors to scheme

* libguile/eval.c: Fix a comment.
  (eval): Abstract out the variable memoization into a function,
  scm_memoize_variable_access_x.

* libguile/memoize.c (memoized_tags): Fix a couple names.
  (scm_memoize_variable_access_x): New internal function. Actually it's
  public to Scheme, but we can't do much about that, because the new
  evaluator will need it.
  (scm_memoized_expression_typecode, scm_memoized_expression_data): New
  accessors for memoized code, for Scheme.
  (scm_memoized_typecode): Looks up the typecode for a symbol.

libguile/eval.c

@@ -120,13 +120,6 @@
 
 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
 
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_unbound_variable (SCM symbol)
-{
-  scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
-	     scm_list_1 (symbol), SCM_BOOL_F);
-}
-
 static void error_used_before_defined (void)
 {
   scm_error (scm_unbound_variable_key, NULL,
@@ -151,7 +144,7 @@ scm_badargsp (SCM formals, SCM args)
 static SCM apply (SCM proc, SCM args);
 
 /* the environment:
-   ((SYM . VAL) (SYM . VAL) ... . MOD)
+   (VAL ... . MOD)
    If MOD is #f, it means the environment was captured before modules were
    booted.
    If MOD is the literal value '(), we are evaluating at the top level, and so
@@ -347,14 +340,10 @@ eval (SCM x, SCM env)
         return SCM_VARIABLE_REF (mx);
       else
         {
-          SCM var;
           while (scm_is_pair (env))
             env = scm_cdr (env);
-          var = scm_module_variable (CAPTURE_ENV (env), mx);
+          return SCM_VARIABLE_REF
-          if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+            (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
-            error_unbound_variable (mx);
-          SCM_SET_SMOB_OBJECT (x, var);
-          return SCM_VARIABLE_REF (var);
         }
 
     case SCM_M_TOPLEVEL_SET:
@@ -370,11 +359,9 @@ eval (SCM x, SCM env)
           {
             while (scm_is_pair (env))
               env = scm_cdr (env);
-            var = scm_module_variable (CAPTURE_ENV (env), var);
+            SCM_VARIABLE_SET
-            if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+              (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
-              error_unbound_variable (CAR (mx));
+               val);
-            SCM_SETCAR (mx, var);
-            SCM_VARIABLE_SET (var, val);
             return SCM_UNSPECIFIED;
           }
       }
@@ -383,16 +370,8 @@ eval (SCM x, SCM env)
       if (SCM_VARIABLEP (mx))
         return SCM_VARIABLE_REF (mx);
       else
-        {
+        return SCM_VARIABLE_REF
-          SCM mod, var;
+          (scm_memoize_variable_access_x (x, SCM_BOOL_F));
-          mod = scm_resolve_module (CAR (mx));
-          if (scm_is_true (CDDR (mx)))
-            mod = scm_module_public_interface (mod);
-          var = scm_module_lookup (mod, CADR (mx));
-          if (scm_is_true (scm_variable_bound_p (var)))
-            SCM_SET_SMOB_OBJECT (x, var);
-          return scm_variable_ref (var);
-        }
 
     case SCM_M_MODULE_SET:
       if (SCM_VARIABLEP (CDR (mx)))
@@ -402,13 +381,9 @@ eval (SCM x, SCM env)
         }
       else
         {
-          SCM mod, var;
+          SCM_VARIABLE_SET
-          mod = scm_resolve_module (CADR (mx));
+            (scm_memoize_variable_access_x (x, SCM_BOOL_F),
-          if (scm_is_true (CDDDR (mx)))
+             eval (CAR (mx), env));
-            mod = scm_module_public_interface (mod);
-          var = scm_module_lookup (mod, CADDR (mx));
-          SCM_SET_SMOB_OBJECT (x, var);
-          SCM_VARIABLE_SET (var, eval (CAR (mx), env));
           return SCM_UNSPECIFIED;
         }
 

libguile/memoize.c

@@ -236,7 +236,7 @@ static const char *const memoized_tags[] =
   "quote",
   "define",
   "apply",
-  "call-with-current-continuation",
+  "call/cc",
   "call-with-values",
   "call",
   "lexical-ref",
@@ -244,7 +244,7 @@ static const char *const memoized_tags[] =
   "toplevel-ref",
   "toplevel-set!",
   "module-ref",
-  "module-set",
+  "module-set!",
 };
 
 static int
@@ -1121,6 +1121,126 @@ SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0, 
+            (SCM m),
+	    "Return the typecode from the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_expression_typecode
+{
+  SCM_VALIDATE_MEMOIZED (1, m);
+  return scm_from_uint16 (SCM_MEMOIZED_TAG (m));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0, 
+            (SCM m),
+	    "Return the data from the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_expression_data
+{
+  SCM_VALIDATE_MEMOIZED (1, m);
+  return SCM_MEMOIZED_ARGS (m);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0, 
+            (SCM sym),
+	    "Return the memoized typecode corresponding to the symbol @var{sym}.")
+#define FUNC_NAME s_scm_memoized_typecode
+{
+  int i;
+
+  SCM_VALIDATE_SYMBOL (1, sym);
+
+  for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
+    if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
+      return scm_from_int32 (i);
+
+  return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_unbound_variable (SCM symbol)
+{
+  scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
+	     scm_list_1 (symbol), SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, 
+            (SCM m, SCM mod),
+	    "Look up and cache the variable that @var{m} will access, returning the variable.")
+#define FUNC_NAME s_scm_memoized_expression_data
+{
+  SCM mx;
+  SCM_VALIDATE_MEMOIZED (1, m);
+  mx = SCM_MEMOIZED_ARGS (m);
+  switch (SCM_MEMOIZED_TAG (m))
+    {
+    case SCM_M_TOPLEVEL_REF:
+      if (SCM_VARIABLEP (mx))
+        return mx;
+      else
+        {
+          SCM var = scm_module_variable (mod, mx);
+          if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
+            error_unbound_variable (mx);
+          SCM_SET_SMOB_OBJECT (m, var);
+          return var;
+        }
+
+    case SCM_M_TOPLEVEL_SET:
+      {
+        SCM var = CAR (mx);
+        if (SCM_VARIABLEP (var))
+          return var;
+        else
+          {
+            var = scm_module_variable (mod, var);
+            if (scm_is_false (var))
+              error_unbound_variable (CAR (mx));
+            SCM_SETCAR (mx, var);
+            return var;
+          }
+      }
+
+    case SCM_M_MODULE_REF:
+      if (SCM_VARIABLEP (mx))
+        return mx;
+      else
+        {
+          SCM var;
+          mod = scm_resolve_module (CAR (mx));
+          if (scm_is_true (CDDR (mx)))
+            mod = scm_module_public_interface (mod);
+          var = scm_module_lookup (mod, CADR (mx));
+          if (scm_is_false (scm_variable_bound_p (var)))
+            error_unbound_variable (CADR (mx));
+          SCM_SET_SMOB_OBJECT (m, var);
+          return var;
+        }
+
+    case SCM_M_MODULE_SET:
+      /* FIXME: not quite threadsafe */
+      if (SCM_VARIABLEP (CDR (mx)))
+        return CDR (mx);
+      else
+        {
+          SCM var;
+          mod = scm_resolve_module (CADR (mx));
+          if (scm_is_true (CDDDR (mx)))
+            mod = scm_module_public_interface (mod);
+          var = scm_module_lookup (mod, CADDR (mx));
+          SCM_SETCDR (mx, var);
+          return var;
+        }
+
+    default:
+      scm_wrong_type_arg (FUNC_NAME, 1, m);
+      return SCM_BOOL_F;
+    }
+}
+#undef FUNC_NAME
+
 
 
 

libguile/memoize.h

@@ -92,6 +92,10 @@ enum
 
 SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
 SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_expression_typecode (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_expression_data (SCM memoized);
+SCM_INTERNAL SCM scm_memoized_typecode (SCM sym);
+SCM_INTERNAL SCM scm_memoize_variable_access_x (SCM memoized, SCM module);
 SCM_API SCM scm_memoized_p (SCM obj);
 
 SCM_INTERNAL void scm_init_memoize (void);