[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-78-gf32e67b

[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=f32e67be0b1390f22382eed10459016ca37c126d

The branch, stable-2.0 has been updated
       via  f32e67be0b1390f22382eed10459016ca37c126d (commit)
       via  534491d0b7fcd17558751110610bcef971d414a8 (commit)
       via  0b0e066a26b437f7320abd126ec05a7a7c056dd9 (commit)
       via  ef8e9356de2494d378948614945ec9aa4498d91c (commit)
      from  65ea26c5824bc3be9d327b4470d19e67d7b5d44d (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 f32e67be0b1390f22382eed10459016ca37c126d
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 8 20:57:41 2011 +0100

    add scm_call_{5,6}
    
    * libguile/eval.h:
    * libguile/eval.c (scm_call_5, scm_call_6): New scm_call functions; why
      not.

commit 534491d0b7fcd17558751110610bcef971d414a8
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 8 09:30:33 2011 +0100

    fix scm_setter
    
    * libguile/procs.c (scm_setter): Only get at the setter slot if the pure
      generic actually has a setter.  Needs test.
    
    * test-suite/tests/goops.test ("defining generics"):
      ("defining accessors"): Add `setter' tests.

commit 0b0e066a26b437f7320abd126ec05a7a7c056dd9
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 8 09:29:24 2011 +0100

    core eval-string uses (ice-9 eval-string)
    
    * libguile/strports.c (scm_eval_string_in_module): Use eval-string from
      (ice-9 eval-string).

commit ef8e9356de2494d378948614945ec9aa4498d91c
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 8 09:27:23 2011 +0100

    add scm_c_public_ref et al
    
    * libguile/modules.h:
    * libguile/modules.c (scm_public_lookup, scm_private_lookup)
      (scm_c_public_lookup, scm_c_private_lookup, scm_public_ref)
      (scm_private_ref, scm_c_public_ref, scm_c_private_ref)
      (scm_public_variable, scm_private_variable, scm_c_public_variable)
      (scm_c_private_variable): New helpers to get at variables and values
      in modules.

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

Summary of changes:
 libguile/eval.c             |   15 +++++
 libguile/eval.h             |    6 ++-
 libguile/modules.c          |  122 +++++++++++++++++++++++++++++++++++++++++++
 libguile/modules.h          |   17 ++++++-
 libguile/procs.c            |    3 +-
 libguile/strports.c         |   33 ++++--------
 test-suite/tests/goops.test |   11 +++-
 7 files changed, 179 insertions(+), 28 deletions(-)

diff --git a/libguile/eval.c b/libguile/eval.c
index b52cc27..e660714 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -477,6 +477,21 @@ scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM 
arg4)
 }
 
 SCM
+scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
+{
+  SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
+  return scm_c_vm_run (scm_the_vm (), proc, args, 5);
+}
+
+SCM
+scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+            SCM arg6)
+{
+  SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
+  return scm_c_vm_run (scm_the_vm (), proc, args, 6);
+}
+
+SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
   return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
diff --git a/libguile/eval.h b/libguile/eval.h
index 969cce1..f193ad6 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -3,7 +3,7 @@
 #ifndef SCM_EVAL_H
 #define SCM_EVAL_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010
+/* Copyright (C) 
1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -68,6 +68,10 @@ SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
 SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
 SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
 SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
+SCM_API SCM scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+                        SCM arg5);
+SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+                        SCM arg5, SCM arg6);
 SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
 SCM_API SCM scm_apply_0 (SCM proc, SCM args);
 SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
diff --git a/libguile/modules.c b/libguile/modules.c
index 40f9c84..e060821 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -56,6 +56,9 @@ static SCM module_public_interface_var;
 static SCM module_export_x_var;
 static SCM default_duplicate_binding_procedures_var;
 
+/* The #:ensure keyword.  */
+static SCM k_ensure;
+
 
 static SCM unbound_variable (const char *func, SCM sym)
 {
@@ -752,6 +755,124 @@ scm_lookup (SCM sym)
 }
 
 SCM
+scm_public_variable (SCM module_name, SCM name)
+{
+  SCM mod, iface;
+  
+  mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
+                    k_ensure, SCM_BOOL_F);
+
+  if (scm_is_false (mod))
+    scm_misc_error ("public-lookup", "Module named ~s does not exist",
+                    scm_list_1 (module_name));
+  
+  iface = scm_module_public_interface (mod);
+
+  if (scm_is_false (iface))
+    scm_misc_error ("public-lookup", "Module ~s has no public interface",
+                    scm_list_1 (mod));
+  
+  return scm_module_variable (iface, name);
+}
+
+SCM
+scm_private_variable (SCM module_name, SCM name)
+{
+  SCM mod;
+  
+  mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
+                    k_ensure, SCM_BOOL_F);
+
+  if (scm_is_false (mod))
+    scm_misc_error ("private-lookup", "Module named ~s does not exist",
+                    scm_list_1 (module_name));
+  
+  return scm_module_variable (mod, name);
+}
+
+SCM
+scm_c_public_variable (const char *module_name, const char *name)
+{
+  return scm_public_variable (convert_module_name (module_name),
+                              scm_from_locale_symbol (name));
+}
+
+SCM
+scm_c_private_variable (const char *module_name, const char *name)
+{
+  return scm_private_variable (convert_module_name (module_name),
+                               scm_from_locale_symbol (name));
+}
+
+SCM
+scm_public_lookup (SCM module_name, SCM name)
+{
+  SCM var;
+  
+  var = scm_public_variable (module_name, name);
+
+  if (scm_is_false (var))
+    scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
+                    scm_list_2 (name, module_name));
+  
+  return var;
+}
+
+SCM
+scm_private_lookup (SCM module_name, SCM name)
+{
+  SCM var;
+  
+  var = scm_private_variable (module_name, name);
+
+  if (scm_is_false (var))
+    scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
+                    scm_list_2 (name, module_name));
+  
+  return var;
+}
+
+SCM
+scm_c_public_lookup (const char *module_name, const char *name)
+{
+  return scm_public_lookup (convert_module_name (module_name),
+                            scm_from_locale_symbol (name));
+}
+
+SCM
+scm_c_private_lookup (const char *module_name, const char *name)
+{
+  return scm_private_lookup (convert_module_name (module_name),
+                             scm_from_locale_symbol (name));
+}
+
+SCM
+scm_public_ref (SCM module_name, SCM name)
+{
+  return scm_variable_ref (scm_public_lookup (module_name, name));
+}
+
+SCM
+scm_private_ref (SCM module_name, SCM name)
+{
+  return scm_variable_ref (scm_private_lookup (module_name, name));
+}
+
+SCM
+scm_c_public_ref (const char *module_name, const char *name)
+{
+  return scm_public_ref (convert_module_name (module_name),
+                         scm_from_locale_symbol (name));
+}
+
+SCM
+scm_c_private_ref (const char *module_name, const char *name)
+{
+  return scm_private_ref (convert_module_name (module_name),
+                          scm_from_locale_symbol (name));
+}
+
+SCM
 scm_c_module_define (SCM module, const char *name, SCM value)
 {
   return scm_module_define (module, scm_from_locale_symbol (name), value);
@@ -903,6 +1024,7 @@ scm_post_boot_init_modules ()
   default_duplicate_binding_procedures_var = 
     scm_c_lookup ("default-duplicate-binding-procedures");
   module_public_interface_var = scm_c_lookup ("module-public-interface");
+  k_ensure = scm_from_locale_keyword ("ensure");
 
   scm_module_system_booted_p = 1;
 }
diff --git a/libguile/modules.h b/libguile/modules.h
index aef7d3b..07dc2c3 100644
--- a/libguile/modules.h
+++ b/libguile/modules.h
@@ -3,7 +3,7 @@
 #ifndef SCM_MODULES_H
 #define SCM_MODULES_H
 
-/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008 Free Software 
Foundation, Inc.
+/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008, 2011 Free 
Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -93,6 +93,21 @@ SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM 
val);
 SCM_API SCM scm_module_export (SCM module, SCM symbol_list);
 SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);
 
+SCM_API SCM scm_public_variable (SCM module_name, SCM name);
+SCM_API SCM scm_private_variable (SCM module_name, SCM name);
+SCM_API SCM scm_c_public_variable (const char *module_name, const char *name);
+SCM_API SCM scm_c_private_variable (const char *module_name, const char *name);
+
+SCM_API SCM scm_public_lookup (SCM module_name, SCM name);
+SCM_API SCM scm_private_lookup (SCM module_name, SCM name);
+SCM_API SCM scm_c_public_lookup (const char *module_name, const char *name);
+SCM_API SCM scm_c_private_lookup (const char *module_name, const char *name);
+
+SCM_API SCM scm_public_ref (SCM module_name, SCM name);
+SCM_API SCM scm_private_ref (SCM module_name, SCM name);
+SCM_API SCM scm_c_public_ref (const char *module_name, const char *name);
+SCM_API SCM scm_c_private_ref (const char *module_name, const char *name);
+
 SCM_API SCM scm_c_resolve_module (const char *name);
 SCM_API SCM scm_resolve_module (SCM name);
 SCM_API SCM scm_c_define_module (const char *name,
diff --git a/libguile/procs.c b/libguile/procs.c
index 2b7225e..a096591 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -149,7 +149,8 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
   SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
   if (SCM_STRUCT_SETTER_P (proc))
     return SCM_STRUCT_SETTER (proc);
-  if (SCM_PUREGENERICP (proc))
+  if (SCM_PUREGENERICP (proc)
+      && SCM_IS_A_P (proc, scm_class_generic_with_setter))
     /* FIXME: might not be an accessor */
     return SCM_GENERIC_SETTER (proc);
   SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
diff --git a/libguile/strports.c b/libguile/strports.c
index 957c6a1..594d030 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -507,25 +507,6 @@ scm_c_eval_string_in_module (const char *expr, SCM module)
 }
 
 
-static SCM
-inner_eval_string (void *data)
-{
-  SCM port = (SCM)data;
-  SCM form;
-  SCM ans = SCM_UNSPECIFIED;
-
-  /* Read expressions from that port; ignore the values.  */
-  while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
-    ans = scm_primitive_eval_x (form);
-
-  /* Don't close the port here; if we re-enter this function via a
-     continuation, then the next time we enter it, we'll get an error.
-     It's a string port anyway, so there's no advantage to closing it
-     early.  */
-
-  return ans;
-}
-
 SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, 
             (SCM string, SCM module),
            "Evaluate @var{string} as the text representation of a Scheme\n"
@@ -537,14 +518,20 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 
1, 0,
             "procedure returns.")
 #define FUNC_NAME s_scm_eval_string_in_module
 {
-  SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
-                           FUNC_NAME);
+  static SCM eval_string = SCM_BOOL_F, k_module = SCM_BOOL_F;
+
+  if (scm_is_false (eval_string))
+    {
+      eval_string = scm_c_public_lookup ("ice-9 eval-string", "eval-string");
+      k_module = scm_from_locale_keyword ("module");
+    }
+  
   if (SCM_UNBNDP (module))
     module = scm_current_module ();
   else
     SCM_VALIDATE_MODULE (2, module);
-  return scm_c_call_with_current_module (module,
-                                        inner_eval_string, (void *)port);
+
+  return scm_call_3 (scm_variable_ref (eval_string), string, k_module, module);
 }
 #undef FUNC_NAME
 
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index 908d1e7..2bf7d69 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,6 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, 
Inc.
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011 Free Software 
Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -234,7 +234,11 @@
       (eval '(define-generic foo) (current-module))
       (eval '(and (is-a? foo <generic>)
                  (null? (generic-function-methods foo)))
-           (current-module)))))
+           (current-module)))
+
+    (pass-if-exception "getters do not have setters"
+                       exception:wrong-type-arg
+                       (eval '(setter foo) (current-module)))))
 
 (with-test-prefix "defining methods"
 
@@ -294,6 +298,9 @@
                  (null? (generic-function-methods foo-1)))
            (current-module)))
 
+    (pass-if "accessors have setters"
+      (procedure? (eval '(setter foo-1) (current-module))))
+
     (pass-if "overwriting a top-level binding to a non-accessor"
       (eval '(define (foo) #f) (current-module))
       (eval '(define-accessor foo) (current-module))


hooks/post-receive
-- 
GNU Guile