[Guile-commits] GNU Guile branch, wip-eval-cleanup, updated. release_1-9-5-76-gba0417c

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ba0417cdd0840224d7ecb8cef5f850dd3c1fbe5a

The branch, wip-eval-cleanup has been updated
       via  ba0417cdd0840224d7ecb8cef5f850dd3c1fbe5a (commit)
      from  67e2d80a6a97b51aefea701cf10112102b09b392 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ba0417cdd0840224d7ecb8cef5f850dd3c1fbe5a
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 1 23:54:25 2009 +0100

    really boot primitive-eval from scheme.
    
    * libguile/debug.h:
    * libguile/debug.c (scm_bless_closure_with_current_module): New terrible
      function. The deal is, the expander uses procedure-module to determine
      the module that was current when a macro was defined, but the fact
      that all interpreted procedures share the same code defeats this. So
      add this hack.
    
    * libguile/eval.c (scm_primitive_eval, scm_c_primitive_eval):
      (scm_init_eval): Rework so that scm_primitive_eval always calls out to
      the primitive-eval variable. The previous definition is the default
      value, which is probably overridden by scm_init_eval_in_scheme.
    
    * libguile/init.c (scm_i_init_guile): Move ports and load-path up, so we
      can debug when initing eval. Call scm_init_eval_in_scheme. Awesome.
    
    * libguile/load.h:
    * libguile/load.c (scm_init_eval_in_scheme): New procedure, loads up
      ice-9/eval.scm to replace the primitive-eval definition, if everything
      is there and up-to-date.
    
    * libguile/modules.c (scm_module_transformer): Export to Scheme, so it's
      there for eval.go.
    
    * module/ice-9/boot-9.scm: No need to define module-transformer.
    
    * module/ice-9/eval.scm (capture-env): Only reference the-root-module if
      modules are booted.
      (primitive-eval): Bless closures with the current module. Also inline
      a definition for identity.

-----------------------------------------------------------------------

Summary of changes:
 libguile/debug.c        |   24 ++++++++++++++++++++++++
 libguile/debug.h        |    1 +
 libguile/eval.c         |   23 +++++++++++++++++------
 libguile/init.c         |    5 +++--
 libguile/load.c         |   16 ++++++++++++++++
 libguile/load.h         |    1 +
 libguile/modules.c      |   12 +++++++++---
 module/ice-9/boot-9.scm |    2 +-
 module/ice-9/eval.scm   |   35 +++++++++++++++++++----------------
 9 files changed, 91 insertions(+), 28 deletions(-)

diff --git a/libguile/debug.c b/libguile/debug.c
index f0dd29a..fa1adda 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -213,6 +213,30 @@ SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 
0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_bless_closure_with_current_module,
+            "bless-closure-with-current-module", 1, 0, 0, 
+           (SCM proc),
+           "Bless @var{proc} so that @code{(procedure-module @var{proc})} "
+            "will return the current module.")
+#define FUNC_NAME s_scm_bless_closure_with_current_module
+{
+  SCM objs;
+
+  SCM_VALIDATE_PROGRAM (SCM_ARG1, proc);
+
+  /* really evil. */
+  objs = SCM_PROGRAM_OBJTABLE (proc);
+  if (scm_is_true (objs))
+    {
+      SCM v = scm_vector_copy (objs);
+      scm_c_vector_set_x (v, 0, scm_current_module ());
+      SCM_PROGRAM_OBJTABLE (proc) = v;
+    }
+
+  return proc;
+}
+#undef FUNC_NAME
+
 
 
 
diff --git a/libguile/debug.h b/libguile/debug.h
index 24c6b9e..97ffe0b 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -109,6 +109,7 @@ SCM_API SCM scm_debug_object_p (SCM obj);
 SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
 SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
 SCM_API SCM scm_procedure_module (SCM proc);
+SCM_INTERNAL SCM scm_bless_closure_with_current_module (SCM proc);
 SCM_API SCM scm_procedure_source (SCM proc);
 SCM_API SCM scm_procedure_name (SCM proc);
 SCM_API SCM scm_with_traps (SCM thunk);
diff --git a/libguile/eval.c b/libguile/eval.c
index 1f3c36b..d540595 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -848,11 +848,8 @@ scm_closure (SCM code, SCM env)
 }
 
 
-SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
-           (SCM exp),
-           "Evaluate @var{exp} in the top-level environment specified by\n"
-           "the current module.")
-#define FUNC_NAME s_scm_primitive_eval
+static SCM
+scm_c_primitive_eval (SCM exp)
 {
   SCM transformer = scm_current_module_transformer ();
   if (scm_is_true (transformer))
@@ -860,7 +857,14 @@ SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
   exp = scm_memoize_expression (exp);
   return eval (exp, SCM_EOL);
 }
-#undef FUNC_NAME
+
+static SCM var_primitive_eval;
+SCM
+scm_primitive_eval (SCM exp)
+{
+  return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
+                       &exp, 1);
+}
 
 
 /* Eval does not take the second arg optionally.  This is intentional
@@ -928,6 +932,8 @@ scm_apply (SCM proc, SCM arg1, SCM args)
 void 
 scm_init_eval ()
 {
+  SCM primitive_eval;
+
   scm_init_opts (scm_evaluator_traps,
                 scm_evaluator_trap_table);
   scm_init_opts (scm_eval_options_interface,
@@ -938,6 +944,11 @@ scm_init_eval ()
   f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
   scm_permanent_object (f_apply);
 
+  primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
+                                     scm_c_primitive_eval);
+  var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
+                                   primitive_eval);
+
 #include "libguile/eval.x"
 }
 
diff --git a/libguile/init.c b/libguile/init.c
index a7434b3..3712a9a 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -551,15 +551,16 @@ scm_i_init_guile (SCM_STACKITEM *base)
   scm_init_weaks ();
   scm_init_guardians ();
   scm_init_vports ();
+  scm_init_standard_ports ();  /* Requires fports */
   scm_bootstrap_vm ();
   scm_init_memoize ();
   scm_init_eval ();
+  scm_init_load_path ();
+  scm_init_eval_in_scheme ();
   scm_init_evalext ();
   scm_init_debug ();   /* Requires macro smobs */
   scm_init_random ();
   scm_init_simpos ();
-  scm_init_load_path ();
-  scm_init_standard_ports ();  /* Requires fports */
   scm_init_dynamic_linking ();
   scm_bootstrap_i18n ();
 #if SCM_ENABLE_ELISP
diff --git a/libguile/load.c b/libguile/load.c
index 5c0c61e..fd3626f 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -837,6 +837,22 @@ scm_c_primitive_load_path (const char *filename)
   return scm_primitive_load_path (scm_from_locale_string (filename));
 }
 
+void
+scm_init_eval_in_scheme (void)
+{
+  SCM eval_scm, eval_go;
+  eval_scm = scm_search_path (*scm_loc_load_path,
+                              scm_from_locale_string ("ice-9/eval.scm"),
+                              SCM_EOL);
+  eval_go = scm_search_path (*scm_loc_load_compiled_path,
+                             scm_from_locale_string ("ice-9/eval.go"),
+                             SCM_EOL);
+  
+  if (scm_is_true (eval_scm) && scm_is_true (eval_go)
+      && compiled_is_fresh (eval_scm, eval_go))
+    scm_load_compiled_with_vm (eval_go);
+}
+
 
 /* Information about the build environment.  */
 
diff --git a/libguile/load.h b/libguile/load.h
index 81fbfba..0feabad 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -39,6 +39,7 @@ SCM_API SCM scm_c_primitive_load_path (const char *filename);
 SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
 SCM_INTERNAL void scm_init_load_path (void);
 SCM_INTERNAL void scm_init_load (void);
+SCM_INTERNAL void scm_init_eval_in_scheme (void);
 
 #endif  /* SCM_LOAD_H */
 
diff --git a/libguile/modules.c b/libguile/modules.c
index e653571..c48c2e8 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -561,8 +561,10 @@ scm_current_module_lookup_closure ()
 
 SCM_SYMBOL (sym_sys_pre_modules_transformer, "%pre-modules-transformer");
 
-SCM
-scm_module_transformer (SCM module)
+SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0,
+           (SCM module),
+           "Returns the syntax expander for the given module.")
+#define FUNC_NAME s_scm_module_transformer
 {
   if (SCM_UNLIKELY (scm_is_false (module)))
     { SCM v = scm_hashq_ref (scm_pre_modules_obarray,
@@ -574,8 +576,12 @@ scm_module_transformer (SCM module)
         return SCM_VARIABLE_REF (v);
     }
   else
-    return SCM_MODULE_TRANSFORMER (module);
+    {
+      SCM_VALIDATE_MODULE (SCM_ARG1, module);
+      return SCM_MODULE_TRANSFORMER (module);
+    }
 }
+#undef FUNC_NAME
 
 SCM
 scm_current_module_transformer ()
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index c271ffe..f4274f7 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1397,7 +1397,7 @@
 ;; NOTE: This binding is used in libguile/modules.c.
 (define module-eval-closure (record-accessor module-type 'eval-closure))
 
-(define module-transformer (record-accessor module-type 'transformer))
+;; (define module-transformer (record-accessor module-type 'transformer))
 (define set-module-transformer! (record-modifier module-type 'transformer))
 ;; (define module-name (record-accessor module-type 'name)) wait until mods 
are booted
 (define set-module-name! (record-modifier module-type 'name))
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 5c66903..6552b54 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -37,7 +37,8 @@
        (if (null? env)
            (current-module)
            (if (not env)
-               the-root-module
+               ;; the and current-module checks that modules are booted
+               (and (current-module) the-root-module)
                env)))))
 
   ;; could be more straightforward if we had better copy propagation
@@ -108,20 +109,21 @@
       
         (('lambda (nreq rest? . body))
          (let ((env (capture-env env)))
-           (lambda args
-             (let lp ((env env) (nreq nreq) (args args))
-               (if (zero? nreq)
-                   (eval body
-                         (if rest?
-                             (cons args env)
-                             (if (not (null? args))
-                                 (error "too many args" args)
-                                 env)))
-                   (if (null? args)
-                       (error "too few args" nreq)
-                       (lp (cons (car args) env)
-                           (1- nreq)
-                           (cdr args))))))))
+           (bless-closure-with-current-module
+            (lambda args
+              (let lp ((env env) (nreq nreq) (args args))
+                (if (zero? nreq)
+                    (eval body
+                          (if rest?
+                              (cons args env)
+                              (if (not (null? args))
+                                  (error "too many args" args)
+                                  env)))
+                    (if (null? args)
+                        (error "too few args" nreq)
+                        (lp (cons (car args) env)
+                            (1- nreq)
+                            (cdr args)))))))))
 
         (('quote x)
          x)
@@ -194,7 +196,8 @@
   
     (lambda (exp)
       (eval 
-       (memoize-expression ((or (module-transformer (current-module)) identity)
+       (memoize-expression ((or (module-transformer (current-module))
+                                (lambda (x) x))
                             exp))
        '()))))
 


hooks/post-receive
-- 
GNU Guile