[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-7-gae88d9b

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

The branch, stable-2.0 has been updated
       via  ae88d9bcf622baa6745a91fafb9be2fb331ad6c0 (commit)
       via  319dd08936ec2d14272f68c16f778c411ed4b505 (commit)
       via  a8c10aa131eb5dd104f134d2ed66afe225fea8e6 (commit)
       via  c1e3e9aafff8ef669fd3573f7c92d2f5ff7c2d66 (commit)
      from  21b6df302fbc372a4b359f73a7441752cd6c1306 (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 ae88d9bcf622baa6745a91fafb9be2fb331ad6c0
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 7 12:45:30 2011 +0200

    fix CPL of <extended-generic-with-setter> and <extended-accessor>
    
    * libguile/goops.c (fix_cpl): Fix bug in placement of debug assertion.
      (create_standard_classes): Put <extended-generic> before
      <generic-with-setter> in <extended-generic-with-setter>'s direct
      supers, so that the slot allocation is a superset of
      <generic-with-setter>, which results in the `setter' being allocated
      in the same place.
    
      Likewise fix <extended-accessor> to place <extended-generic> before
      <generic-with-setter>, not just <generic>.

commit 319dd08936ec2d14272f68c16f778c411ed4b505
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 7 12:21:48 2011 +0200

    fix invocation of duplicate handlers for merge-generics
    
    * libguile/modules.c (resolve_duplicate_binding): Fix unbound -> #f
      conversion for the imported bindings.  Pass the existing entry in the
      import obarray as the resolved var (7th arg), and properly pass #f as
      the value (8th arg) if there is no such binding.  Fixes
      merge-generics; before, the <boolean> type test (indicating no
      previous value) was not being triggered.  This bug has been present
      since 2007 at least, though it was not in 1.8.
    
    * test-suite/tests/modules.test ("duplicate bindings"): Add a test that
      the var and val are both #f.  These types are used by GOOPS.

commit a8c10aa131eb5dd104f134d2ed66afe225fea8e6
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 7 12:17:08 2011 +0200

    goops.scm cleanups
    
    * module/oop/goops.scm (make-generic, make-extended-generic):
      (ensure-generic, make-accessor, ensure-accessor): Use optional
      arguments for #:name.  `make-extended-generic' also accepts empty
      extension lists.

commit c1e3e9aafff8ef669fd3573f7c92d2f5ff7c2d66
Author: Andy Wingo <address@hidden>
Date:   Wed Jul 6 14:01:03 2011 +0200

    more precision for ,time
    
    * module/system/repl/command.scm (time): Use the high-precision timers
      instead of stime(2).  Changes the output format of `,time' too;
      perhaps there is a better way.

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

Summary of changes:
 libguile/goops.c               |   15 +++++--
 libguile/modules.c             |   75 ++++++++++++++++++++--------------
 module/oop/goops.scm           |   87 +++++++++++++++++++---------------------
 module/system/repl/command.scm |   22 +++++-----
 test-suite/tests/modules.test  |    4 ++
 5 files changed, 110 insertions(+), 93 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index dfe26c3..c2eb88f 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -2280,15 +2280,21 @@ SCM_DEFINE (scm_sys_method_more_specific_p, 
"%method-more-specific?", 3, 0, 0,
  *
  
******************************************************************************/
 
+/* Munge the CPL of C in place such that BEFORE appears before AFTER,
+   assuming that currently the reverse is true.  Recalculate slots and
+   associated getters-n-setters.  */
 static void
 fix_cpl (SCM c, SCM before, SCM after)
 {
   SCM cpl = SCM_SLOT (c, scm_si_cpl);
   SCM ls = scm_c_memq (after, cpl);
-  SCM tail = scm_delq1_x (before, SCM_CDR (ls));
+  SCM tail;
+
   if (scm_is_false (ls))
     /* if this condition occurs, fix_cpl should not be applied this way */
     abort ();
+
+  tail = scm_delq1_x (before, SCM_CDR (ls));
   SCM_SETCAR (ls, before);
   SCM_SETCDR (ls, scm_cons (after, tail));
   {
@@ -2414,8 +2420,8 @@ create_standard_classes (void)
   make_stdcls (&scm_class_extended_generic_with_setter,
               "<extended-generic-with-setter>",
               scm_class_applicable_struct_class,
-              scm_list_2 (scm_class_generic_with_setter,
-                          scm_class_extended_generic),
+              scm_list_2 (scm_class_extended_generic,
+                           scm_class_generic_with_setter),
               SCM_EOL);
   SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
                       SCM_CLASSF_PURE_GENERIC);
@@ -2424,8 +2430,9 @@ create_standard_classes (void)
               scm_list_2 (scm_class_accessor,
                           scm_class_extended_generic_with_setter),
               SCM_EOL);
+  /* <extended-generic> is misplaced.  */
   fix_cpl (scm_class_extended_accessor,
-          scm_class_extended_generic, scm_class_generic);
+          scm_class_extended_generic, scm_class_generic_with_setter);
   SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
 
   /* Primitive types classes */
diff --git a/libguile/modules.c b/libguile/modules.c
index ca8875d..6c3f262 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -294,39 +294,46 @@ resolve_duplicate_binding (SCM module, SCM sym,
                           SCM iface1, SCM var1,
                           SCM iface2, SCM var2)
 {
+  SCM args[8];
+  SCM handlers;
   SCM result = SCM_BOOL_F;
 
-  if (!scm_is_eq (var1, var2))
+  if (scm_is_eq (var1, var2))
+    return var1;
+  
+  args[0] = module;
+  args[1] = sym;
+  args[2] = iface1;
+  args[3] = SCM_VARIABLE_REF (var1);
+  if (SCM_UNBNDP (args[3]))
+    args[3] = SCM_BOOL_F;
+  args[4] = iface2;
+  args[5] = SCM_VARIABLE_REF (var2);
+  if (SCM_UNBNDP (args[5]))
+    args[5] = SCM_BOOL_F;
+  args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, 
SCM_BOOL_F);
+  args[7] = SCM_BOOL_F;
+      
+  handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
+  if (scm_is_false (handlers))
+    handlers = default_duplicate_binding_handlers ();
+
+  for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
     {
-      SCM val1, val2;
-      SCM handlers, h, handler_args;
-
-      val1 = SCM_VARIABLE_REF (var1);
-      val2 = SCM_VARIABLE_REF (var2);
-
-      val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
-      val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
-
-      handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
-      if (scm_is_false (handlers))
-       handlers = default_duplicate_binding_handlers ();
-
-      handler_args = scm_list_n (module, sym,
-                                iface1, val1, iface2, val2,
-                                var1, val1,
-                                SCM_UNDEFINED);
-
-      for (h = handlers;
-          scm_is_pair (h) && scm_is_false (result);
-          h = SCM_CDR (h))
-       {
-         result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
-       }
+      if (scm_is_true (args[6])) 
+        {
+          args[7] = SCM_VARIABLE_REF (args[6]);
+          if (SCM_UNBNDP (args[7]))
+            args[7] = SCM_BOOL_F;
+        }
+      
+      result = scm_call_n (SCM_CAR (handlers), args, 8);
+
+      if (scm_is_true (result))
+        return result;
     }
-  else
-    result = var1;
 
-  return result;
+  return SCM_BOOL_F;
 }
 
 /* No lock is needed for access to this variable, as there are no
@@ -368,9 +375,15 @@ module_imported_variable (SCM module, SCM sym)
              {
                /* SYM is a duplicate binding (imported more than once) so we
                   need to resolve it.  */
-               found_var = resolve_duplicate_binding (module, sym,
-                                                      found_iface, found_var,
-                                                      iface, var);
+                found_var = resolve_duplicate_binding (module, sym,
+                                                       found_iface, found_var,
+                                                       iface, var);
+
+                /* Note that it could be that FOUND_VAR doesn't belong
+                   either to FOUND_IFACE or to IFACE, if it was created
+                   by merge-generics.  The right thing to do there would
+                   be to treat the import obarray as the iface, but the
+                   import obarray isn't actually a module.  Oh well.  */
                if (scm_is_eq (found_var, var))
                  found_iface = iface;
              }
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 1f9fd50..0845d29 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -336,13 +336,11 @@
                   names))
         (goops-error "no prefixes supplied"))))
 
-(define (make-generic . name)
-  (let ((name (and (pair? name) (car name))))
-    (make <generic> #:name name)))
+(define* (make-generic #:optional name)
+  (make <generic> #:name name))
 
-(define (make-extended-generic gfs . name)
-  (let* ((name (and (pair? name) (car name)))
-        (gfs (if (pair? gfs) gfs (list gfs)))
+(define* (make-extended-generic gfs #:optional name)
+  (let* ((gfs (if (list? gfs) gfs (list gfs)))
         (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
     (let ((ans (if gws?
                   (let* ((sname (and name (make-setter-name name)))
@@ -379,18 +377,17 @@
                         (delq! eg (slot-ref gf 'extended-by))))
            gfs))
 
-(define (ensure-generic old-definition . name)
-  (let ((name (and (pair? name) (car name))))
-    (cond ((is-a? old-definition <generic>) old-definition)
-         ((procedure-with-setter? old-definition)
-          (make <generic-with-setter>
-                #:name name
-                #:default (procedure old-definition)
-                #:setter (setter old-definition)))
-         ((procedure? old-definition)
-           (if (generic-capability? old-definition) old-definition
-               (make <generic> #:name name #:default old-definition)))
-         (else (make <generic> #:name name)))))
+(define* (ensure-generic old-definition #:optional name)
+  (cond ((is-a? old-definition <generic>) old-definition)
+        ((procedure-with-setter? old-definition)
+         (make <generic-with-setter>
+           #:name name
+           #:default (procedure old-definition)
+           #:setter (setter old-definition)))
+        ((procedure? old-definition)
+         (if (generic-capability? old-definition) old-definition
+             (make <generic> #:name name #:default old-definition)))
+        (else (make <generic> #:name name))))
 
 ;; same semantics as <generic>
 (define-syntax define-accessor
@@ -404,34 +401,32 @@
 (define (make-setter-name name)
   (string->symbol (string-append "setter:" (symbol->string name))))
 
-(define (make-accessor . name)
-  (let ((name (and (pair? name) (car name))))
-    (make <accessor>
-         #:name name
-         #:setter (make <generic>
-                        #:name (and name (make-setter-name name))))))
-
-(define (ensure-accessor proc . name)
-  (let ((name (and (pair? name) (car name))))
-    (cond ((and (is-a? proc <accessor>)
-               (is-a? (setter proc) <generic>))
-          proc)
-         ((is-a? proc <generic-with-setter>)
-          (upgrade-accessor proc (setter proc)))
-         ((is-a? proc <generic>)
-          (upgrade-accessor proc (make-generic name)))
-         ((procedure-with-setter? proc)
-          (make <accessor>
-                #:name name
-                #:default (procedure proc)
-                #:setter (ensure-generic (setter proc) name)))
-         ((procedure? proc)
-           (ensure-accessor (if (generic-capability? proc)
-                                (make <generic> #:name name #:default proc)
-                                (ensure-generic proc name))
-                            name))
-         (else
-          (make-accessor name)))))
+(define* (make-accessor #:optional name)
+  (make <accessor>
+    #:name name
+    #:setter (make <generic>
+               #:name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #:optional name)
+  (cond ((and (is-a? proc <accessor>)
+              (is-a? (setter proc) <generic>))
+         proc)
+        ((is-a? proc <generic-with-setter>)
+         (upgrade-accessor proc (setter proc)))
+        ((is-a? proc <generic>)
+         (upgrade-accessor proc (make-generic name)))
+        ((procedure-with-setter? proc)
+         (make <accessor>
+           #:name name
+           #:default (procedure proc)
+           #:setter (ensure-generic (setter proc) name)))
+        ((procedure? proc)
+         (ensure-accessor (if (generic-capability? proc)
+                              (make <generic> #:name name #:default proc)
+                              (ensure-generic proc name))
+                          name))
+        (else
+         (make-accessor name))))
 
 (define (upgrade-accessor generic setter)
   (let ((methods (slot-ref generic 'methods))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 109b533..a2f2a6f 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -485,21 +485,19 @@ Disassemble a file."
   "time EXP
 Time execution."
   (let* ((gc-start (gc-run-time))
-        (tms-start (times))
+        (real-start (get-internal-real-time))
+        (run-start (get-internal-run-time))
         (result (repl-eval repl (repl-parse repl form)))
-        (tms-end (times))
+        (run-end (get-internal-run-time))
+        (real-end (get-internal-real-time))
         (gc-end (gc-run-time)))
-    (define (get proc start end)
-      (exact->inexact (/ (- (proc end) (proc start)) 
internal-time-units-per-second)))
+    (define (diff start end)
+      (/ (- end start) 1.0 internal-time-units-per-second))
     (repl-print repl result)
-    (display "clock utime stime cutime cstime gctime\n")
-    (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
-           (get tms:clock tms-start tms-end)
-           (get tms:utime tms-start tms-end)
-           (get tms:stime tms-start tms-end)
-           (get tms:cutime tms-start tms-end)
-           (get tms:cstime tms-start tms-end)
-           (get identity gc-start gc-end))
+    (format #t ";; ~,6Fs real time, ~,6Fs run time.  ~,6Fs spent in GC.\n"
+            (diff real-start real-end)
+            (diff run-start run-end)
+            (diff gc-start gc-end))
     result))
 
 (define-meta-command (profile repl (form) . opts)
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index 5f34d9e..79e3c98 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -290,6 +290,10 @@
            (import2 (make-module))
            (handler-invoked? #f)
            (handler (lambda (module name int1 val1 int2 val2 var val)
+                      ;; We expect both VAR and VAL to be #f, as there
+                      ;; is no previous binding for 'imported in M.
+                      (if var (error "unexpected var" var))
+                      (if val (error "unexpected val" val))
                       (set! handler-invoked? #t)
                       ;; Keep the first binding.
                       (or var (module-local-variable int1 name)))))


hooks/post-receive
-- 
GNU Guile