Changeset 11161

Timestamp:

Oct 18, 2008, 7:15:22 PM (12 years ago)

Author:

gz

Message:

some definition-type fixes from r11054

File:

• trunk/source/lib/source-files.lisp (modified) (4 diffs)

trunk/source/lib/source-files.lisp

@@ -69 +69 @@
 
 (defclass definition-type ()
-  ((name :allocation :class :reader definition-type-name))
+  ((name :allocation :class :reader definition-type-name :initform t))
   (:documentation "Superclass of all definition types"))
 
@@ -192 +192 @@
 (defparameter *function-definition-type* (definition-type-instance 'function))
 
-;; TODO: what about (:internal .... (method-name quals specs)) ?
 (defmethod definition-base-name ((dt function-definition-type) name)
-  (while (consp name)
-    (if (setf-function-name-p name)
-      (return-from definition-base-name (canonical-maybe-setf-name name))
-      (let ((x (last name)))
-        (setq name (or (cdr x) (car x))))))
-  name)
+  (while (and (consp name) (not (setf-function-name-p name)))
+    (let ((x (last name)))
+      (or (setq name (cdr x))
+          ;; Try to detect the (:internal .... <hairy-method-name>) case
+          (when (and (setq name (car x))
+                     ;;check for plausible method name
+                     (setq x (method-def-parameters name))
+                     (neq x 'setf)
+                     (not (keywordp x)))
+            (setq name x)))))
+  (canonical-maybe-setf-name name))
 
 (defmethod definition-bound-p ((dt function-definition-type) name)
@@ -223 +227 @@
 (defmethod definition-base-name ((dt method-definition-type) (name cons))
   (if (setf-function-name-p name)
-    name
+    (canonical-maybe-setf-name name)
     (definition-base-name *function-definition-type* (car name))))
 
@@ -420 +424 @@
 
 ;;; backward compatibility
-
 
 ;;; modified version of %method-applicable-p - args are class names