[Guile-commits] 01/87: %compute-applicable-methods in Scheme

[Andy Wingo]

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit de43d84f60139815db4988685a3fb8583dd801c2
Author: Andy Wingo <address@hidden>
Date:   Thu Dec 18 12:51:11 2014 +0100

    %compute-applicable-methods in Scheme
    
    * libguile/goops.c: Move %compute-applicable-methods to Scheme.
      (scm_sys_goops_loaded): No need to initialize
      var_compute_applicable_methods.
    * libguile/goops.h (scm_sys_compute_applicable_methods): Remove.  This
      was internal so it shouldn't cause a problem.
    
    * module/oop/goops.scm (%sort-applicable-methods):
      (%compute-applicable-methods): New definitions.
---
 libguile/goops.c     |   23 -----------------------
 libguile/goops.h     |    3 +--
 module/oop/goops.scm |   31 +++++++++++++++++++++++++++++--
 3 files changed, 30 insertions(+), 27 deletions(-)

diff --git a/libguile/goops.c b/libguile/goops.c
index ab4d7d7..6fde1bf 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -2115,28 +2115,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long 
len, int find_method_p)
          : sort_applicable_methods (applicable, count, types));
 }
 
-#if 0
-SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 
0, 0, scm_sys_compute_applicable_methods);
-#endif
-
-static const char s_sys_compute_applicable_methods[] = 
"%compute-applicable-methods";
-
-SCM
-scm_sys_compute_applicable_methods (SCM gf, SCM args)
-#define FUNC_NAME s_sys_compute_applicable_methods
-{
-  long n;
-  SCM_VALIDATE_GENERIC (1, gf);
-  n = scm_ilength (args);
-  SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
-  return scm_compute_applicable_methods (gf, args, n, 1);
-}
-#undef FUNC_NAME
-
 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
-SCM_VARIABLE_INIT (var_compute_applicable_methods, 
"compute-applicable-methods",
-                   scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 
0,
-                                       scm_sys_compute_applicable_methods));
 
 /******************************************************************************
  *
@@ -2789,8 +2768,6 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 
0,
 #define FUNC_NAME s_scm_sys_goops_loaded
 {
   goops_loaded_p = 1;
-  var_compute_applicable_methods =
-    scm_module_variable (scm_module_goops, sym_compute_applicable_methods);
   var_slot_unbound =
     scm_module_variable (scm_module_goops, sym_slot_unbound);
   var_slot_missing =
diff --git a/libguile/goops.h b/libguile/goops.h
index b3071b0..f28bc63 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -3,7 +3,7 @@
 #ifndef SCM_GOOPS_H
 #define SCM_GOOPS_H
 
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011 Free 
Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011, 2014 
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
@@ -248,7 +248,6 @@ SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
 SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);
 
 SCM_API SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int 
scm_find_method);
-SCM_API SCM scm_sys_compute_applicable_methods (SCM gf, SCM args);
 #ifdef GUILE_DEBUG
 SCM_API SCM scm_pure_generic_p (SCM obj);
 #endif
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 95be42a..a0c6119 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -508,6 +508,34 @@
 ;;; {Methods}
 ;;;
 
+(define (%sort-applicable-methods methods types)
+  (sort methods (lambda (a b) (%method-more-specific? a b types))))
+
+(define (%compute-applicable-methods gf args)
+  (define (method-applicable? m types)
+    (let lp ((specs (method-specializers m)) (types types))
+      (cond
+       ((null? specs) (null? types))
+       ((not (pair? specs)) #t)
+       ((null? types) #f)
+       (else
+        (and (memq (car specs) (class-precedence-list (car types)))
+             (lp (cdr specs) (cdr types)))))))
+  (let ((n (length args))
+        (types (map class-of args)))
+    (let lp ((methods (generic-function-methods gf))
+             (applicable '()))
+      (if (null? methods)
+          (and (not (null? applicable))
+               (%sort-applicable-methods applicable types))
+          (let ((m (car methods)))
+            (lp (cdr methods)
+                (if (method-applicable? m types)
+                    (cons m applicable)
+                    applicable)))))))
+
+(define compute-applicable-methods %compute-applicable-methods)
+
 (define (toplevel-define! name val)
   (module-define! (current-module) name val))
 
@@ -1664,8 +1692,7 @@
 (set! compute-applicable-methods %%compute-applicable-methods)
 
 (define-method (sort-applicable-methods (gf <generic>) methods args)
-  (let ((targs (map class-of args)))
-    (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
+  (%sort-applicable-methods methods (map class-of args)))
 
 (define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
   (%method-more-specific? m1 m2 targs))