[slime-cvs] CVS /slime

[mbaringer]

Update of /project/slime/cvsroot//slime
In directory common-lisp:/tmp/cvs-serv29825

Modified Files:
	swank-openmcl.lisp ChangeLog 
Log Message:


--- /project/slime/cvsroot//slime/swank-openmcl.lisp	2006/02/02 10:29:14	1.104
+++ /project/slime/cvsroot//slime/swank-openmcl.lisp	2006/02/18 13:44:10	1.105
@@ -110,10 +110,46 @@
 (defun specializer-name (spec)
   (etypecase spec
     (cons spec)
-    (class (swank-mop:class-name spec))
-    (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec))))
-  )
+    (class (class-name spec))
+    (ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec)))))
 
+(defun swank-mop:compute-applicable-methods-using-classes (gf args)
+  (let* ((methods (ccl::%gf-methods gf))
+         (args-length (length args))
+         (bits (ccl::inner-lfun-bits gf))
+         arg-count res)
+    (when methods
+      (setq arg-count (length (ccl::%method-specializers (car methods))))
+      (unless (<= arg-count args-length)
+        (error "Too few args to ~s" gf))
+      (unless (or (logbitp ccl::$lfbits-rest-bit bits)
+                  (logbitp ccl::$lfbits-restv-bit bits)
+                  (logbitp ccl::$lfbits-keys-bit bits)
+                  (<= args-length 
+                      (+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits))))
+        (error "Too many args to ~s" gf))
+      (let ((cpls (make-list arg-count)))
+        (declare (dynamic-extent cpls))
+        (do* ((args-tail args (cdr args-tail))
+              (cpls-tail cpls (cdr cpls-tail)))
+             ((null cpls-tail))
+          (setf (car cpls-tail)
+                (ccl::%class-precedence-list (car args-tail))))
+        (flet ((%method-applicable-p (method args cpls)
+                 (do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs))
+                       (args args (ccl::%cdr args))
+                       (cpls cpls (ccl::%cdr cpls)))
+                      ((null specs) t)
+                   (let ((spec (ccl::%car specs)))
+                     (if (typep spec 'ccl::eql-specializer)
+                         (unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec)))
+                           (return nil))
+                         (unless (ccl:memq spec (ccl::%car cpls))
+                           (return nil)))))))
+          (dolist (m methods)
+            (if (%method-applicable-p m args cpls)
+                (push m res))))
+        (ccl::sort-methods res cpls (ccl::%gf-precedence-list gf))))))
 
 ;;; TCP Server
 
--- /project/slime/cvsroot//slime/ChangeLog	2006/02/18 13:43:05	1.841
+++ /project/slime/cvsroot//slime/ChangeLog	2006/02/18 13:44:10	1.842
@@ -1,3 +1,5 @@
+2006-02-18  mb  <mb at soma.local>
+
 2006-02-18  Marco Baringer  <mb at bese.it>
 
 	* slime.el (slime-macroexpansion-minor-mode): New minor mode for
@@ -13,6 +15,8 @@
 	(slime-sexp-at-point-or-error): New function. Like
 	slime-sexp-at-point but signals an error when slime-sexp-at-point
 	would return nil.
+	* swank-openmcl.lisp (swank-mop:compute-applicable-methods-using-classes): 
+	Implement.
  
 2006-02-16  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>