current-environment

[Aaron VanDevender]

Here is a patch which adds the ability to obtain an environment
and eval using it.

enjoy.

cya
.sig


diff -ru guile/guile-core/libguile/eval.c guile-new/guile-core/libguile/eval.c
--- guile/guile-core/libguile/eval.c    2003-03-14 18:30:58.000000000 -0600
+++ guile-new/guile-core/libguile/eval.c        2003-03-14 19:51:43.000000000 
-0600
@@ -1169,6 +1169,17 @@
   return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
 }
 
+SCM_SYNTAX (s_current_environment, "current-environment", scm_makmmacro, 
scm_m_current_environment);
+SCM_GLOBAL_SYMBOL(scm_sym_current_environment, s_current_environment);
+
+SCM
+scm_m_current_environment (SCM xorig, SCM env SCM_UNUSED)
+{
+  SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 0,
+             scm_s_expression, s_current_environment);
+  return scm_cons (SCM_IM_CURRENT_ENVIRONMENT, SCM_CDR (xorig));
+}
+
 SCM
 scm_m_expand_body (SCM xorig, SCM env)
 {
@@ -1498,6 +1509,9 @@
        case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
          ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
          goto loop;
+       case (SCM_ISYMNUM (SCM_IM_CURRENT_ENVIRONMENT)):
+         ls = z = scm_cons (scm_sym_current_environment, SCM_UNSPECIFIED);
+         goto loop;
        default:
          /* appease the Sun compiler god: */ ;
        }
@@ -2655,7 +2669,11 @@
            return SCM_APPLY (proc, arg1, SCM_EOL);
          }
 
-
+       case (SCM_ISYMNUM(SCM_IM_CURRENT_ENVIRONMENT)):
+         {
+           return (env);
+         }
+         
        default:
          goto badfun;
        }
@@ -4501,12 +4519,35 @@
             "is reset to its previous value when @var{eval} returns.")
 #define FUNC_NAME s_scm_eval
 {
-  SCM_VALIDATE_MODULE (2, module);
+  if (!(SCM_MODULEP (module))) {
+    if (SCM_CONSP(module)) {
+      /* 
+       * Is there a better way to find out if this is a proper environment?
+       * It would be nice if there was a tag for it but all i can see is that
+       * its an alist with an eval-closure at the end.
+       */
+      SCM a,b;
+      b = module;
+      while ((a = (SCM_CAR(b)))) {
+       b = SCM_CDR(b);
+       if (!(SCM_CONSP(a))) {
+         if ((SCM_EVAL_CLOSURE_P(a)) && (SCM_NULLP(b)))
+           return scm_i_eval (exp, module);
+         break;
+       }
+       if (!(SCM_CONSP(b)))
+         break;
+      }
+    }
+  } else {
+    return scm_internal_dynamic_wind 
+      (change_environment, inner_eval, restore_environment,
+       (void *) SCM_UNPACK (exp),
+       (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+  }
+
+  scm_wrong_type_arg_msg(FUNC_NAME,2,module,"module or environment");
 
-  return scm_internal_dynamic_wind 
-    (change_environment, inner_eval, restore_environment,
-     (void *) SCM_UNPACK (exp),
-     (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
 }
 #undef FUNC_NAME
 
diff -ru guile/guile-core/libguile/eval.h guile-new/guile-core/libguile/eval.h
--- guile/guile-core/libguile/eval.h    2003-03-13 08:56:08.000000000 -0600
+++ guile-new/guile-core/libguile/eval.h        2003-03-14 19:51:43.000000000 
-0600
@@ -187,6 +187,7 @@
 SCM_API SCM scm_sym_atapply;
 SCM_API SCM scm_sym_atcall_cc;
 SCM_API SCM scm_sym_at_call_with_values;
+SCM_API SCM scm_sym_current_environment;
 SCM_API SCM scm_sym_delay;
 SCM_API SCM scm_sym_arrow;
 SCM_API SCM scm_sym_else;
@@ -232,6 +233,7 @@
 #endif /* SCM_ENABLE_ELISP */
 SCM_API SCM scm_m_atbind (SCM xorig, SCM env);
 SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+SCM_API SCM scm_m_current_environment (SCM xorig, SCM env);
 SCM_API int scm_badargsp (SCM formals, SCM args);
 SCM_API SCM scm_ceval (SCM x, SCM env);
 SCM_API SCM scm_deval (SCM x, SCM env);
diff -ru guile/guile-core/libguile/tags.h guile-new/guile-core/libguile/tags.h
--- guile/guile-core/libguile/tags.h    2002-12-15 08:24:34.000000000 -0600
+++ guile-new/guile-core/libguile/tags.h        2003-03-14 19:51:43.000000000 
-0600
@@ -477,6 +477,7 @@
 
 /* The Elisp nil value. */
 #define SCM_ELISP_NIL          SCM_MAKIFLAG (31)
+#define SCM_IM_CURRENT_ENVIRONMENT SCM_MAKISYM (32)