diff lisp/cedet/semantic/sort.el @ 105260:bbd7017a25d9

CEDET (development tools) package merged. * cedet/*.el: * cedet/ede/*.el: * cedet/semantic/*.el: * cedet/srecode/*.el: New files.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/cedet/semantic/sort.el	Mon Sep 28 15:15:00 2009 +0000
@@ -0,0 +1,570 @@
+;;; sort.el --- Utilities for sorting and re-arranging tag tables.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <[e-mail]>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Tag tables originate in the order they appear in a buffer, or source file.
+;; It is often useful to re-arrange them is some predictable way for browsing
+;; purposes.  Re-organization may be alphabetical, or even a complete
+;; reorganization of parents and children.
+;;
+;; Originally written in semantic-util.el
+;;
+
+(require 'semantic)
+(eval-when-compile
+  (require 'semantic/find))
+
+(declare-function semanticdb-find-tags-external-children-of-type
+		  "semantic/db-find")
+
+;;; Alphanumeric sorting
+;;
+;; Takes a list of tags, and sorts them in a case-insensitive way
+;; at a single level.
+
+;;; Code:
+(defun semantic-string-lessp-ci (s1 s2)
+  "Case insensitive version of `string-lessp'.
+Argument S1 and S2 are the strings to compare."
+  ;; Use downcase instead of upcase because an average name
+  ;; has more lower case characters.
+  (if (fboundp 'compare-strings)
+      (eq (compare-strings s1 0 nil s2 0 nil t) -1)
+    (string-lessp (downcase s1) (downcase s2))))
+
+(defun semantic-sort-tag-type (tag)
+  "Return a type string for TAG guaranteed to be a string."
+  (let ((ty (semantic-tag-type tag)))
+    (cond ((stringp ty)
+	   ty)
+	  ((listp ty)
+	   (or (car ty) ""))
+	  (t ""))))
+
+(defun semantic-tag-lessp-name-then-type (A B)
+  "Return t if tag A is < tag B.
+First sorts on name, then sorts on the name of the :type of
+each tag."
+  (let ((na (semantic-tag-name A))
+	(nb (semantic-tag-name B))
+	)
+    (if (string-lessp na nb)
+	t ; a sure thing.
+      (if (string= na nb)
+	  ;; If equal, test the :type which might be different.
+	  (let* ((ta (semantic-tag-type A))
+		 (tb (semantic-tag-type B))
+		 (tas (cond ((stringp ta)
+			     ta)
+			    ((semantic-tag-p ta)
+			     (semantic-tag-name ta))
+			    (t nil)))
+		 (tbs (cond ((stringp tb)
+			     tb)
+			    ((semantic-tag-p tb)
+			     (semantic-tag-name tb))
+			    (t nil))))
+	    (if (and (stringp tas) (stringp tbs))
+		(string< tas tbs)
+	      ;; This is if A == B, and no types in A or B
+	      nil))
+	;; This nil is if A > B, but not =
+	nil))))
+
+(defun semantic-sort-tags-by-name-increasing (tags)
+  "Sort TAGS by name in increasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (string-lessp (semantic-tag-name a)
+			     (semantic-tag-name b)))))
+
+(defun semantic-sort-tags-by-name-decreasing (tags)
+  "Sort TAGS by name in decreasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (string-lessp (semantic-tag-name b)
+			     (semantic-tag-name a)))))
+
+(defun semantic-sort-tags-by-type-increasing (tags)
+  "Sort TAGS by type in increasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (string-lessp (semantic-sort-tag-type a)
+			     (semantic-sort-tag-type b)))))
+
+(defun semantic-sort-tags-by-type-decreasing (tags)
+  "Sort TAGS by type in decreasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (string-lessp (semantic-sort-tag-type b)
+			     (semantic-sort-tag-type a)))))
+
+(defun semantic-sort-tags-by-name-increasing-ci (tags)
+  "Sort TAGS by name in increasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (semantic-string-lessp-ci (semantic-tag-name a)
+					 (semantic-tag-name b)))))
+
+(defun semantic-sort-tags-by-name-decreasing-ci (tags)
+  "Sort TAGS by name in decreasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (semantic-string-lessp-ci (semantic-tag-name b)
+					 (semantic-tag-name a)))))
+
+(defun semantic-sort-tags-by-type-increasing-ci (tags)
+  "Sort TAGS by type in increasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (semantic-string-lessp-ci (semantic-sort-tag-type a)
+					 (semantic-sort-tag-type b)))))
+
+(defun semantic-sort-tags-by-type-decreasing-ci (tags)
+  "Sort TAGS by type in decreasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b)
+	       (semantic-string-lessp-ci (semantic-sort-tag-type b)
+					 (semantic-sort-tag-type a)))))
+
+(defun semantic-sort-tags-by-name-then-type-increasing (tags)
+  "Sort TAGS by name, then type in increasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b))))
+
+(defun semantic-sort-tags-by-name-then-type-decreasing (tags)
+  "Sort TAGS by name, then type in increasing order with side effects.
+Return the sorted list."
+  (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a))))
+
+;;; Unique
+;;
+;; Scan a list of tags, removing duplicates.
+;; This must first sort the tags by name alphabetically ascending.
+;;
+;; Useful for completion lists, or other situations where the
+;; other data isn't as useful.
+
+(defun semantic-unique-tag-table-by-name (tags)
+  "Scan a list of TAGS, removing duplicate names.
+This must first sort the tags by name alphabetically ascending.
+For more complex uniqueness testing used by the semanticdb
+typecaching system, see `semanticdb-typecache-merge-streams'."
+  (let ((sorted (semantic-sort-tags-by-name-increasing
+		 (copy-sequence tags)))
+	(uniq nil))
+    (while sorted
+      (if (or (not uniq)
+	      (not (string= (semantic-tag-name (car sorted))
+			    (semantic-tag-name (car uniq)))))
+	  (setq uniq (cons (car sorted) uniq)))
+      (setq sorted (cdr sorted))
+      )
+    (nreverse uniq)))
+
+(defun semantic-unique-tag-table (tags)
+  "Scan a list of TAGS, removing duplicates.
+This must first sort the tags by position ascending.
+TAGS are removed only if they are equivalent, as can happen when
+multiple tag sources are scanned.
+For more complex uniqueness testing used by the semanticdb
+typecaching system, see `semanticdb-typecache-merge-streams'."
+  (let ((sorted (sort (copy-sequence tags)
+		      (lambda (a b)
+			(cond ((not (semantic-tag-with-position-p a))
+			       t)
+			      ((not (semantic-tag-with-position-p b))
+			       nil)
+			      (t
+			       (< (semantic-tag-start a)
+				  (semantic-tag-start b)))))))
+	(uniq nil))
+    (while sorted
+      (if (or (not uniq)
+	      (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
+	  (setq uniq (cons (car sorted) uniq)))
+      (setq sorted (cdr sorted))
+      )
+    (nreverse uniq)))
+
+
+;;; Tag Table Flattening
+;;
+;; In the 1.4 search API, there was a parameter "search-parts" which
+;; was used to find tags inside other tags.  This was used
+;; infrequently, mostly for completion/jump routines.  These types
+;; of commands would be better off with a flattened list, where all
+;; tags appear at the top level.
+
+;;;###autoload
+(defun semantic-flatten-tags-table (&optional table)
+  "Flatten the tags table TABLE.
+All tags in TABLE, and all components of top level tags
+in TABLE will appear at the top level of list.
+Tags promoted to the top of the list will still appear
+unmodified as components of their parent tags."
+  (let* ((table (semantic-something-to-tag-table table))
+	 ;; Initialize the starting list with our table.
+	 (lists (list table)))
+    (mapc (lambda (tag)
+	    (let ((components (semantic-tag-components tag)))
+	      (if (and components
+		       ;; unpositined tags can be hazardous to
+		       ;; completion.  Do we need any type of tag
+		       ;; here?  - EL
+		       (semantic-tag-with-position-p (car components)))
+		  (setq lists (cons
+			       (semantic-flatten-tags-table components)
+			       lists)))))
+	  table)
+    (apply 'append (nreverse lists))
+    ))
+
+
+;;; Buckets:
+;;
+;; A list of tags can be grouped into buckets based on the tag class.
+;; Bucketize means to take a list of tags at a given level in a tag
+;; table, and reorganize them into buckets based on class.
+;;
+(defvar semantic-bucketize-tag-class
+  ;; Must use lambda because `semantic-tag-class' is a macro.
+  (lambda (tok) (semantic-tag-class tok))
+  "Function used to get a symbol describing the class of a tag.
+This function must take one argument of a semantic tag.
+It should return a symbol found in `semantic-symbol->name-assoc-list'
+which `semantic-bucketize' uses to bin up tokens.
+To create new bins for an application augment
+`semantic-symbol->name-assoc-list', and
+`semantic-symbol->name-assoc-list-for-type-parts' in addition
+to setting this variable (locally in your function).")
+
+(defun semantic-bucketize (tags &optional parent filter)
+  "Sort TAGS into a group of buckets based on tag class.
+Unknown classes are placed in a Misc bucket.
+Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
+If PARENT is specified, then TAGS belong to this PARENT in some way.
+This will use `semantic-symbol->name-assoc-list-for-type-parts' to
+generate bucket names.
+Optional argument FILTER is a filter function to be applied to each bucket.
+The filter function will take one argument, which is a list of tokens, and
+may re-organize the list with side-effects."
+  (let* ((name-list (if parent
+			semantic-symbol->name-assoc-list-for-type-parts
+		      semantic-symbol->name-assoc-list))
+	 (sn name-list)
+	 (bins (make-vector (1+ (length sn)) nil))
+	 ask tagtype
+	 (nsn nil)
+	 (num 1)
+	 (out nil))
+    ;; Build up the bucket vector
+    (while sn
+      (setq nsn (cons (cons (car (car sn)) num) nsn)
+	    sn (cdr sn)
+	    num (1+ num)))
+    ;; Place into buckets
+    (while tags
+      (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
+	    ask (assq tagtype nsn)
+	    num (or (cdr ask) 0))
+      (aset bins num (cons (car tags) (aref bins num)))
+      (setq tags (cdr tags)))
+    ;; Remove from buckets into a list.
+    (setq num 1)
+    (while (< num (length bins))
+      (when (aref bins num)
+	(setq out
+	      (cons (cons
+		     (cdr (nth (1- num) name-list))
+		     ;; Filtering, First hacked by David Ponce [e-mail]
+		     (funcall (or filter 'nreverse) (aref bins num)))
+		    out)))
+      (setq num (1+ num)))
+    (if (aref bins 0)
+	(setq out (cons (cons "Misc"
+			      (funcall (or filter 'nreverse) (aref bins 0)))
+			out)))
+    (nreverse out)))
+
+;;; Adoption
+;;
+;; Some languages allow children of a type to be defined outside
+;; the syntactic scope of that class.  These routines will find those
+;; external members, and bring them together in a cloned copy of the
+;; class tag.
+;;
+(defvar semantic-orphaned-member-metaparent-type "class"
+  "In `semantic-adopt-external-members', the type of 'type for metaparents.
+A metaparent is a made-up type semantic token used to hold the child list
+of orphaned members of a named type.")
+(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
+
+(defvar semantic-mark-external-member-function nil
+  "Function called when an externally defined orphan is found.
+By default, the token is always marked with the `adopted' property.
+This function should be locally bound by a program that needs
+to add additional behaviors into the token list.
+This function is called with two arguments.  The first is TOKEN which is
+a shallow copy of the token to be modified.  The second is the PARENT
+which is adopting TOKEN.  This function should return TOKEN (or a copy of it)
+which is then integrated into the revised token list.")
+
+(defun semantic-adopt-external-members (tags)
+  "Rebuild TAGS so that externally defined members are regrouped.
+Some languages such as C++ and CLOS permit the declaration of member
+functions outside the definition of the class.  It is easier to study
+the structure of a program when such methods are grouped together
+more logically.
+
+This function uses `semantic-tag-external-member-p' to
+determine when a potential child is an externally defined member.
+
+Note: Applications which use this function must account for token
+types which do not have a position, but have children which *do*
+have positions.
+
+Applications should use `semantic-mark-external-member-function'
+to modify all tags which are found as externally defined to some
+type.  For example, changing the token type for generating extra
+buckets with the bucket function."
+  (let ((parent-buckets nil)
+	(decent-list nil)
+	(out nil)
+	(tmp nil)
+	)
+    ;; Rebuild the output list, stripping out all parented
+    ;; external entries
+    (while tags
+      (cond
+       ((setq tmp (semantic-tag-external-member-parent (car tags)))
+	(let ((tagcopy (semantic-tag-clone (car tags)))
+	      (a (assoc tmp parent-buckets)))
+	  (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
+	  (if a
+	      ;; If this parent is already in the list, append.
+	      (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
+	    ;; If not, prepend this new parent bucket into our list
+	    (setq parent-buckets
+		  (cons (cons tmp (list tagcopy)) parent-buckets)))
+	  ))
+       ((eq (semantic-tag-class (car tags)) 'type)
+	;; Types need to be rebuilt from scratch so we can add in new
+	;; children to the child list.  Only the top-level cons
+	;; cells need to be duplicated so we can hack out the
+	;; child list later.
+	(setq out (cons (semantic-tag-clone (car tags)) out))
+	(setq decent-list (cons (car out) decent-list))
+	)
+       (t
+	;; Otherwise, append this tag to our new output list.
+	(setq out (cons (car tags) out)))
+       )
+      (setq tags (cdr tags)))
+    ;; Rescan out, by descending into all types and finding parents
+    ;; for all entries moved into the parent-buckets.
+    (while decent-list
+      (let* ((bucket (assoc (semantic-tag-name (car decent-list))
+			    parent-buckets))
+	     (bucketkids (cdr bucket)))
+	(when bucket
+	  ;; Run our secondary marking function on the children
+	  (if semantic-mark-external-member-function
+	      (setq bucketkids
+		    (mapcar (lambda (tok)
+			      (funcall semantic-mark-external-member-function
+				       tok (car decent-list)))
+			    bucketkids)))
+	  ;; We have some extra kids.  Merge.
+	  (semantic-tag-put-attribute
+	   (car decent-list) :members
+	   (append (semantic-tag-type-members (car decent-list))
+		   bucketkids))
+	  ;; Nuke the bucket label so it is not found again.
+	  (setcar bucket nil))
+	(setq decent-list
+	      (append (cdr decent-list)
+		      ;; get embedded types to scan and make copies
+		      ;; of them.
+		      (mapcar
+		       (lambda (tok) (semantic-tag-clone tok))
+		       (semantic-find-tags-by-class 'type
+			(semantic-tag-type-members (car decent-list)))))
+	      )))
+    ;; Scan over all remaining lost external methods, and tack them
+    ;; onto the end.
+    (while parent-buckets
+      (if (car (car parent-buckets))
+	  (let* ((tmp (car parent-buckets))
+		 (fauxtag (semantic-tag-new-type
+			   (car tmp)
+			   semantic-orphaned-member-metaparent-type
+			   nil ;; Part list
+			   nil ;; parents (unknown)
+			   ))
+		 (bucketkids (cdr tmp)))
+	    (semantic-tag-set-faux fauxtag) ;; properties
+	    (if semantic-mark-external-member-function
+		(setq bucketkids
+		      (mapcar (lambda (tok)
+				(funcall semantic-mark-external-member-function
+					 tok fauxtag))
+			      bucketkids)))
+	    (semantic-tag-put-attribute fauxtag :members bucketkids)
+	    ;; We have a bunch of methods with no parent in this file.
+	    ;; Create a meta-type to hold it.
+	    (setq out (cons fauxtag out))
+	    ))
+      (setq parent-buckets (cdr parent-buckets)))
+    ;; Return the new list.
+    (nreverse out)))
+
+
+;;; External children
+;;
+;; In order to adopt external children, we need a few overload methods
+;; to enable the feature.
+
+;;;###autoload
+(define-overloadable-function semantic-tag-external-member-parent (tag)
+  "Return a parent for TAG when TAG is an external member.
+TAG is an external member if it is defined at a toplevel and
+has some sort of label defining a parent.  The parent return will
+be a string.
+
+The default behavior, if not overridden with
+`tag-member-parent' gets the 'parent extra
+specifier of TAG.
+
+If this function is overridden, use
+`semantic-tag-external-member-parent-default' to also
+include the default behavior, and merely extend your own."
+  )
+
+(defun semantic-tag-external-member-parent-default (tag)
+  "Return the name of TAGs parent only if TAG is not defined in it's parent."
+  ;; Use only the extra spec because a type has a parent which
+  ;; means something completely different.
+  (let ((tp (semantic-tag-get-attribute tag :parent)))
+    (when (stringp tp)
+      tp)))
+
+(define-overloadable-function semantic-tag-external-member-p (parent tag)
+  "Return non-nil if PARENT is the parent of TAG.
+TAG is an external member of PARENT when it is somehow tagged
+as having PARENT as it's parent.
+PARENT and TAG must both be semantic tags.
+
+The default behavior, if not overridden with
+`tag-external-member-p' is to match :parent attribute in
+the name of TAG.
+
+If this function is overridden, use
+`semantic-tag-external-member-children-p-default' to also
+include the default behavior, and merely extend your own."
+  )
+
+(defun semantic-tag-external-member-p-default (parent tag)
+  "Return non-nil if PARENT is the parent of TAG."
+  ;; Use only the extra spec because a type has a parent which
+  ;; means something completely different.
+  (let ((tp (semantic-tag-external-member-parent tag)))
+    (and (stringp tp)
+	 (string= (semantic-tag-name parent) tp))))
+
+(define-overloadable-function semantic-tag-external-member-children (tag &optional usedb)
+  "Return the list of children which are not *in* TAG.
+If optional argument USEDB is non-nil, then also search files in
+the Semantic Database.  If USEDB is a list of databases, search those
+databases.
+
+Children in this case are functions or types which are members of
+TAG, such as the parts of a type, but which are not defined inside
+the class.  C++ and CLOS both permit methods of a class to be defined
+outside the bounds of the class' definition.
+
+The default behavior, if not overridden with
+`tag-external-member-children' is to search using
+`semantic-tag-external-member-p' in all top level definitions
+with a parent of TAG.
+
+If this function is overridden, use
+`semantic-tag-external-member-children-default' to also
+include the default behavior, and merely extend your own."
+  )
+
+(defun semantic-tag-external-member-children-default (tag &optional usedb)
+  "Return list of external children for TAG.
+Optional argument USEDB specifies if the semantic database is used.
+See `semantic-tag-external-member-children' for details."
+  (if (and usedb
+	   (require 'semantic/db-mode)
+	   (semanticdb-minor-mode-p)
+	   (require 'semantic/db-find))
+      (let ((m (semanticdb-find-tags-external-children-of-type
+		(semantic-tag-name tag))))
+	(if m (apply #'append (mapcar #'cdr m))))
+    (semantic--find-tags-by-function
+     `(lambda (tok)
+	;; This bit of annoying backquote forces the contents of
+	;; tag into the generated lambda.
+       (semantic-tag-external-member-p ',tag tok))
+     (current-buffer))
+    ))
+
+(define-overloadable-function semantic-tag-external-class (tag)
+  "Return a list of real tags that faux TAG might represent.
+
+In some languages, a method can be defined on an object which is
+not in the same file.  In this case,
+`semantic-adopt-external-members' will create a faux-tag.  If it
+is necessary to get the tag from which for faux TAG was most
+likely derived, then this function is needed."
+  (unless (semantic-tag-faux-p tag)
+    (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
+  (:override)
+  )
+
+(defun semantic-tag-external-class-default (tag)
+  "Return a list of real tags that faux TAG might represent.
+See `semantic-tag-external-class' for details."
+  (if (and (require 'semantic/db-mode)
+	   (semanticdb-minor-mode-p))
+      (let* ((semanticdb-search-system-databases nil)
+	     (m (semanticdb-find-tags-by-class
+		 (semantic-tag-class tag)
+		 (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
+	(semanticdb-strip-find-results m 'name))
+    ;; Presumably, if the tag is faux, it is not local.
+    nil))
+
+(provide 'semantic/sort)
+
+;; Local variables:
+;; generated-autoload-file: "loaddefs.el"
+;; generated-autoload-feature: semantic/loaddefs
+;; generated-autoload-load-name: "semantic/sort"
+;; End:
+
+;;; semantic-sort.el ends here