Update CEDET from upstream.

1 files changed, 237 insertions, 31 deletions

diff --git a/lisp/cedet/semantic/tag-ls.el b/lisp/cedet/semantic/tag-ls.el
index e4c248934c3..d6d2c203aa8 100644
--- a/lisp/cedet/semantic/tag-ls.el
+++ b/lisp/cedet/semantic/tag-ls.el
@@ -30,9 +30,217 @@
 ;; the information.
 
 (require 'semantic)
+(require 'semantic/find)
 
 ;;; Code:
 
+;;; TAG SIMILARITY:
+;;
+;; Two tags that represent the same thing are "similar", but not the "same".
+;; Similar tags might have the same name, but one is a :prototype, while
+;; the other is an implementation.
+;;
+;; Each language will have different things that can be ignored
+;; between two "similar" tags, so similarity checks involve a series
+;; of mode overridable features.  Some are "internal" features.
+(defvar semantic-tag-similar-ignorable-attributes '(:prototype-flag)
+  "The tag attributes that can be ignored during a similarity test.")
+
+(define-overloadable-function semantic--tag-similar-names-p (tag1 tag2 blankok)
+  "Compare the names of TAG1 and TAG2.
+If BLANKOK is false, then the names must exactly match.
+If BLANKOK is true, then if either of TAG1 or TAG2 has blank
+names, then that is ok, and this returns true, but if they both
+have values, they must still match.")
+
+(defun semantic--tag-similar-names-p-default (tag1 tag2 blankok)
+  "Compare the names of TAG1 and TAG2.
+If BLANKOK is false, then the names must exactly match.
+If BLANKOK is true, then if either of TAG1 or TAG2 has blank
+names, then that is ok, and this returns true, but if they both
+have values, they must still match."
+  (let ((n1 (semantic-tag-name tag1))
+	(n2 (semantic-tag-name tag2)))
+    (or (and blankok (or (null n1) (null n2) (string= n1 "") (string= n2 "")))
+	(string= n1 n2))))
+
+(define-overloadable-function semantic--tag-similar-types-p (tag1 tag2)
+  "Compare the types of TAG1 and TAG2.
+This functions can be overriden, for example to compare a fully
+qualified with an unqualified type."
+  (cond
+   ((and (null (semantic-tag-type tag1))
+	 (null (semantic-tag-type tag2)))
+    t)
+   ((or (null (semantic-tag-type tag1))
+	(null (semantic-tag-type tag2)))
+    nil)
+   (t
+    (:override))))
+
+(defun semantic--tag-similar-types-p-default (tag1 tag2)
+  "Compare the types of TAG1 and TAG2.
+This functions can be overriden, for example to compare a fully
+qualified with an unqualified type."
+  (semantic-tag-of-type-p tag1 (semantic-tag-type tag2)))
+
+(define-overloadable-function semantic--tag-attribute-similar-p (attr value1 value2 ignorable-attributes)
+  "Test to see if attribute ATTR is similar for VALUE1 and VALUE2.
+IGNORABLE-ATTRIBUTES is described in `semantic-tag-similar-p'.
+This function is internal, but allows customization of `semantic-tag-similar-p'
+for a given mode at a more granular level.
+
+Note that :type, :name, and anything in IGNORABLE-ATTRIBUTES will
+not be passed to this function.
+
+Modes that override this function can call `semantic--tag-attribute-similar-p-default'
+to do the default equality tests if ATTR is not special for that mode.")
+
+(defun semantic--tag-attribute-similar-p-default (attr value1 value2 ignorable-attributes)
+  "For ATTR, VALUE1, VALUE2 and IGNORABLE-ATTRIBUTES, test for similarness."
+  (cond
+   ;; Tag sublists require special testing.
+   ((and (listp value1) (semantic-tag-p (car value1))
+	 (listp value2) (semantic-tag-p (car value2)))
+    (let ((ans t)
+	  (taglist1 value1)
+	  (taglist2 value2))
+      (when (not (eq (length taglist1) (length taglist2)))
+	(setq ans nil))
+      (while (and ans taglist1 taglist2)
+	(setq ans (apply 'semantic-tag-similar-p
+			 (car taglist1) (car taglist2)
+			 ignorable-attributes)
+	      taglist1 (cdr taglist1)
+	      taglist2 (cdr taglist2)))
+      ans))
+
+   ;; The attributes are not the same?
+   ((not (equal value1 value2))
+    nil)
+
+   (t t))
+  )
+
+(define-overloadable-function semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
+  "Test to see if TAG1 and TAG2 are similar.
+Two tags are similar if their name, datatype, and various attributes
+are the same.
+
+Similar tags that have sub-tags such as arg lists or type members,
+are similar w/out checking the sub-list of tags.
+Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity.
+By default, `semantic-tag-similar-ignorable-attributes' is referenced for
+attributes, and IGNOREABLE-ATTRIBUTES will augment this list.
+
+Note that even though :name is not an attribute, it can be used to
+to indicate lax comparison of names via `semantic--tag-similar-names-p'")
+
+;; Note: optional thing is because overloadable fcns don't handle this
+;; quite right.
+(defun semantic-tag-similar-p-default (tag1 tag2 &optional ignorable-attributes)
+  "Test to see if TAG1 and TAG2 are similar.
+Two tags are similar if their name, datatype, and various attributes
+are the same.
+
+IGNORABLE-ATTRIBUTES are tag attributes that can be ignored.
+
+See `semantic-tag-similar-p' for details."
+  (let* ((ignore (append ignorable-attributes semantic-tag-similar-ignorable-attributes))
+	 (A1 (and (semantic--tag-similar-names-p tag1 tag2 (memq :name ignore))
+		  (semantic--tag-similar-types-p tag1 tag2)
+		  (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))))
+	 (attr1 (semantic-tag-attributes tag1))
+	 (attr2 (semantic-tag-attributes tag2))
+	 (A2 t)
+	 (A3 t)
+	 )
+    ;; Test if there are non-ignorable attributes in A2 which are not present in A1
+    (while (and A2 attr2)
+      (let ((a (car attr2)))
+	(unless (or (eq a :type) (memq a ignore))
+	  (setq A2 (semantic-tag-get-attribute tag1 a)))
+	(setq attr2 (cdr (cdr attr2)))))
+    (while (and A2 attr1 A3)
+      (let ((a (car attr1)))
+
+	(cond ((or (eq a :type) ;; already tested above.
+		   (memq a ignore)) ;; Ignore them...
+	       nil)
+
+	      (t
+	       (setq A3
+		     (semantic--tag-attribute-similar-p
+		      a (car (cdr attr1)) (semantic-tag-get-attribute tag2 a)
+		      ignorable-attributes)))
+	      ))
+      (setq attr1 (cdr (cdr attr1))))
+    (and A1 A2 A3)))
+
+;;; FULL NAMES
+;;
+;; For programmer convenience, a full name is not specified in source
+;; code.  Instead some abbreviation is made, and the local environment
+;; will contain the info needed to determine the full name.
+(define-overloadable-function semantic-tag-full-package (tag &optional stream-or-buffer)
+  "Return the fully qualified package name of TAG in a package hierarchy.
+STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-stream',
+but must be a toplevel semantic tag stream that contains TAG.
+A Package Hierarchy is defined in UML by the way classes and methods
+are organized on disk.  Some languages use this concept such that a
+class can be accessed via it's fully qualified name, (such as Java.)
+Other languages qualify names within a Namespace (such as C++) which
+result in a different package like structure.
+
+Languages which do not override this function will just search the
+stream for a tag of class 'package, and return that."
+  (let ((stream (semantic-something-to-tag-table
+                 (or stream-or-buffer tag))))
+    (:override-with-args (tag stream))))
+
+(defun semantic-tag-full-package-default (tag stream)
+  "Default method for `semantic-tag-full-package' for TAG.
+Return the name of the first tag of class `package' in STREAM."
+  (let ((pack (car-safe (semantic-find-tags-by-class 'package stream))))
+    (when (and pack (semantic-tag-p pack))
+      (semantic-tag-name pack))))
+
+(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
+  "Return the fully qualified name of TAG in the package hierarchy.
+STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream',
+but must be a toplevel semantic tag stream that contains TAG.
+A Package Hierarchy is defined in UML by the way classes and methods
+are organized on disk.  Some languages use this concept such that a
+class can be accessed via it's fully qualified name, (such as Java.)
+Other languages qualify names within a Namespace (such as C++) which
+result in a different package like structure.
+
+Languages which do not override this function with
+`tag-full-name' will combine `semantic-tag-full-package' and
+`semantic-tag-name', separated with language separator character.
+Override functions only need to handle STREAM-OR-BUFFER with a
+tag stream value, or nil.
+
+TODO - this function should probably also take a PARENT to TAG to
+resolve issues where a method in a class in a package is present."
+  (let ((stream (semantic-something-to-tag-table
+                 (or stream-or-buffer tag))))
+    (:override-with-args (tag stream))))
+
+(make-obsolete-overload 'semantic-nonterminal-full-name
+                        'semantic-tag-full-name "23.2")
+
+(defun semantic-tag-full-name-default (tag stream)
+  "Default method for `semantic-tag-full-name'.
+Return the name of TAG found in the toplevel STREAM."
+  (let ((pack (semantic-tag-full-package tag stream))
+	(name (semantic-tag-name tag)))
+    (if pack
+	(concat pack
+		(car semantic-type-relation-separator-character)
+		name)
+      name)))
+
 ;;; UML features:
 ;;
 ;; UML can represent several types of features of a tag
@@ -93,10 +301,38 @@ See `semantic-tag-protection'."
 			((string= s "private")
 			 'private)
 			((string= s "protected")
-			 'protected)))))
+			 'protected)
+			((string= s "package")
+			 'package)
+			))))
       (setq mods (cdr mods)))
     prot))
 
+(defun semantic-tag-package-protected-p (tag &optional parent currentpackage)
+  "Non-nil if TAG is not available via package access control.
+For languages (such as Java) where a method is package protected,
+this method will return nil if TAG, as found in PARENT is available
+for access from a file in CURRENTPACKAGE.
+If TAG is not protected by PACKAGE, also return t.  Use
+`semantic-tag-protected-p' instead.
+If PARENT is not provided, it will be derived when passed to
+`semantic-tag-protection'.
+If CURRENTPACKAGE is not provided, it will be derived from the current
+buffer."
+  (let ((tagpro (semantic-tag-protection tag parent)))
+    (if (not (eq tagpro 'package))
+	t ;; protected
+
+      ;; package protection, so check currentpackage.
+      ;; Deriving the package is better from the parent, as TAG is
+      ;; probably a field or method.
+      (if (not currentpackage)
+	  (setq currentpackage (semantic-tag-full-package nil (current-buffer))))
+      (let ((tagpack (semantic-tag-full-package (or parent tag))))
+	(if (string= currentpackage tagpack)
+	    nil
+	  t)) )))
+
 (defun semantic-tag-protected-p (tag protection &optional parent)
   "Non-nil if TAG is protected.
 PROTECTION is a symbol which can be returned by the method
@@ -213,36 +449,6 @@ something without an implementation."
      (t nil))
     ))
 
-;;; FULL NAMES
-;;
-;; For programmer convenience, a full name is not specified in source
-;; code.  Instead some abbreviation is made, and the local environment
-;; will contain the info needed to determine the full name.
-
-(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
-  "Return the fully qualified name of TAG in the package hierarchy.
-STREAM-OR-BUFFER can be anything convertible by `semantic-something-to-stream',
-but must be a toplevel semantic tag stream that contains TAG.
-A Package Hierarchy is defined in UML by the way classes and methods
-are organized on disk.  Some language use this concept such that a
-class can be accessed via it's fully qualified name, (such as Java.)
-Other languages qualify names within a Namespace (such as C++) which
-result in a different package like structure.  Languages which do not
-override this function with `tag-full-name' will use
-`semantic-tag-name'.  Override functions only need to handle
-STREAM-OR-BUFFER with a tag stream value, or nil."
-  (let ((stream (semantic-something-to-tag-table
-                 (or stream-or-buffer tag))))
-    (:override-with-args (tag stream))))
-
-(make-obsolete-overload 'semantic-nonterminal-full-name
-                        'semantic-tag-full-name "23.2")
-
-(defun semantic-tag-full-name-default (tag stream)
-  "Default method for `semantic-tag-full-name'.
-Return the name of TAG found in the toplevel STREAM."
-  (semantic-tag-name tag))
-
 (provide 'semantic/tag-ls)
 
 ;; Local variables: