comparison lisp/cedet/semantic/format.el @ 104489:25e047f7f6a2

Synch to Eric Ludlam's upstream CEDET repository. * cedet/semantic/wisent/java-tags.el: * cedet/semantic/wisent/javat-wy.el: New files. * cedet/semantic/wisent/java.el: * cedet/semantic/wisent/java-wy.el: Files removed. * cedet/semantic/java.el (semantic-java-prototype-function) (semantic-java-prototype-variable, semantic-java-prototype-type): Doc fix (java-mode::semantic-format-tag-prototype): Renamed from semantic-format-prototype-tag, which didn't match the overloadable function. * cedet/semantic/bovine/c.el (semantic-c-dereference-namespace-alias): Deal correctly with nested namespaces. Make sure type actually exists in original namespace. * cedet/semantic/lex-spp.el (semantic-lex-spp-hack-depth): New. (semantic-lex-spp-lex-text-string): Use above to enable recursion. * cedet/semantic/format.el: Whitespace cleanup. (semantic-test-all-format-tag-functions): Move to end. (semantic-format-tag-prototype, semantic-format-tag-name) (semantic-format-tag-name-default): Revert to original upstream positions. * cedet/semantic/elp.el: File removed. * cedet/semantic/analyze.el (semantic-adebug-analyze): New function, moved here from semantic/adebug. * cedet/semantic/adebug.el: Declare external semanticdb functions. (semantic-adebug-analyze, semantic-adebug-edebug-expr): Deleted. * emacs-lisp/eieio.el (eieio-unbound): Default value is now robust to recompile. * emacs-lisp/eieio-datadebug.el: Add eieio objects to the list of data debug things to recognize. * emacs-lisp/eieio-comp.el: Synch to upstream. * cedet/data-debug.el: Don't require eieio and semantic/tag. If eieio is loaded, require eieio-datadebug. (data-debug-insert-ring-button): Do not be specific about the ring contents. (data-debug-thing-alist): Remove eieio and semantic specific entries. (data-debug-add-specialized-thing): New function. * cedet/cedet.el: Update commentary. * cedet/cedet-edebug.el: Require edebug and debug.

104488:7042156f9f43

;; In addition, macros for setting up customizable variables that let
;; the user choose their default format type are also provided.
;;

;;; Code:
(require 'semantic)
(require 'semantic/tag-ls)
(require 'ezimage)

(eval-when-compile
  (require 'font-lock)
  (require 'semantic/find))

;;; Tag to text overload functions
;;
;; abbreviations, prototypes, and coloring support.
(defvar semantic-format-tag-functions

would claim as a parent.
COLOR indicates that the generated text should be colored using
`font-lock'.")

(semantic-varalias-obsolete 'semantic-token->text-functions
                            'semantic-format-tag-functions)

(defvar semantic-format-tag-custom-list
  (append '(radio)
	  (mapcar (lambda (f) (list 'const f))
		  semantic-format-tag-functions)
	  '(function))
  "A List used by customizeable variables to choose a tag to text function.
Use this variable in the :type field of a customizable variable.")

(semantic-varalias-obsolete 'semantic-token->text-custom-list
                            'semantic-format-tag-custom-list)

(defcustom semantic-format-use-images-flag ezimage-use-images
  "Non-nil means semantic format functions use images.
Images can be used as icons instead of some types of text strings."
  :group 'semantic

(make-variable-buffer-local 'semantic-function-argument-separator)

(defvar semantic-format-parent-separator "::"
  "Text used to separate names when between namespaces/classes and functions.")
(make-variable-buffer-local 'semantic-format-parent-separator)

;;;###autoload
(define-overloadable-function semantic-format-tag-name (tag &optional parent color)
  "Return the name string describing TAG.
The name is the shortest possible representation.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors.")

(defun semantic-format-tag-name-default (tag &optional parent color)
  "Return an abbreviated string describing TAG.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
  (let ((name (semantic-tag-name tag))
	(destructor
	 (if (eq (semantic-tag-class tag) 'function)
	     (semantic-tag-function-destructor-p tag))))
    (when destructor
      (setq name (concat "~" name)))
    (if color
	(setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
    name))

;;;###autoload
(define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
  "Return a prototype for TAG.
This function should be overloaded, though it need not be used.
This is because it can be used to create code by language independent
tools.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors.")


(defun semantic-test-all-format-tag-functions (&optional arg)
  "Test all outputs from `semantic-format-tag-functions'.
Output is generated from the function under `point'.
Optional argument ARG specifies not to use color."
  (interactive "P")
  (require 'semantic/find)
  (semantic-fetch-tags)
  (let* ((tag (semantic-current-tag))
	 (par (semantic-current-tag-parent))
	 (fns semantic-format-tag-functions))
    (with-output-to-temp-buffer "*format-tag*"
      (princ "Tag->format function tests:")
      (while fns
	(princ "\n")
	(princ (car fns))
	(princ ":\n ")
	(let ((s (funcall (car fns) tag par (not arg))))
	  (save-excursion
	    (set-buffer "*format-tag*")
	    (goto-char (point-max))
	    (insert s)))
	(setq fns (cdr fns))))
      ))

(defvar semantic-format-face-alist
  `( (function . font-lock-function-name-face)
     (variable . font-lock-variable-name-face)
     (type . font-lock-type-face)

is a symbol representing a face.
Faces used are generated in `font-lock' for consistency, and will not
be used unless font lock is a feature.")

(semantic-varalias-obsolete 'semantic-face-alist
                            'semantic-format-face-alist)



;;; Coloring Functions
;;

	(put-text-property 0 (length text) 'face face newtext)
	newtext)
    text))

(make-obsolete 'semantic-colorize-text
               'semantic--format-colorize-text)

(defun semantic--format-colorize-merge-text (precoloredtext face-class)
  "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
FACE-CLASS is a tag type found in 'semantic-face-alist'.  See this
variable for details on adding new types."

      out)
    ))


;;; Abstract formatting functions

(defun semantic-format-tag-prin1 (tag &optional parent color)
  "Convert TAG to a string that is the print name for TAG.
PARENT and COLOR are ignored."
  (format "%S" tag))

	       (setq ans (semantic-format-tag-type anything color)))
	   ans))
	((and (listp anything)
	      (stringp (car anything)))
	 (semantic--format-colorize-text (car anything) colorhint))))

(declare-function semantic-go-to-tag "semantic/tag-file")

(defun semantic--format-tag-parent-tree (tag parent)
  "Under Consideration.

(defun semantic-format-tag-summarize-default (tag &optional parent color)
  "Summarize TAG in a reasonable way.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
  (let* ((proto (semantic-format-tag-prototype tag nil color))
         (names (if parent
                    semantic-symbol->name-assoc-list-for-type-parts
                  semantic-symbol->name-assoc-list))
         (tsymb (semantic-tag-class tag))
         (label (capitalize (or (cdr-safe (assoc tsymb names))
                                (symbol-name tsymb)))))
    (if color
        (setq label (semantic--format-colorize-text label 'label)))
    (concat label ": " proto)))

(define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
  "Like `semantic-format-tag-summarize', but with the file name.
Optional argument PARENT is the parent type if TAG is a detail.

(defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
  "Summarize TAG in a reasonable way.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
  (let* ((proto (semantic-format-tag-prototype tag nil color))
         (file (semantic-tag-file-name tag))
	 )
    ;; Nothing for tag?  Try parent.
    (when (and (not file) (and parent))
      (setq file (semantic-tag-file-name parent)))
    ;; Don't include the file name if we can't find one, or it is the

      (setq doc (semantic--format-colorize-text doc 'documentation)))
    doc
    ))

;;; Prototype generation

(defun semantic-format-tag-prototype-default (tag &optional parent color)
  "Default method for returning a prototype for TAG.
This will work for C like languages.
Optional argument PARENT is the parent type if TAG is a detail.

  (let* ((class (semantic-tag-class tag))
	 (name (semantic-format-tag-name tag parent color))
	 (type (if (member class '(function variable type))
		   (semantic-format-tag-type tag color)))
	 (args (if (member class '(function type))
                   (semantic--format-tag-arguments
                    (if (eq class 'function)
                        (semantic-tag-function-arguments tag)
		      (list "")
                      ;;(semantic-tag-type-members tag)
		      )
                    #'semantic-format-tag-prototype
                    color)))
	 (const (semantic-tag-get-attribute tag :constant-flag))
	 (tm (semantic-tag-get-attribute tag :typemodifiers))
	 (mods (append
		(if const '("const") nil)
		(cond ((stringp tm) (list tm))

	       'semantic-format-tag-concise-prototype
	       color)
	      ")"))
     ((eq class 'variable)
      (let* ((deref (semantic-tag-get-attribute
                     tag :dereference))
             (array "")
             )
        (while (and deref (/= deref 0))
          (setq array (concat array "[]")
                deref (1- deref)))
        (concat (semantic-format-tag-name tag parent color)
                array)))
     (t
      (semantic-format-tag-abbreviate tag parent color)))))

;;; UML display styles
;;

	(setq text (semantic--format-uml-post-colorize text tag parent)))
    text
    ))


;;; Compatibility and aliases
;;
(semantic-alias-obsolete 'semantic-prin1-nonterminal
			 'semantic-format-tag-prin1)

104489:25e047f7f6a2

;; In addition, macros for setting up customizable variables that let
;; the user choose their default format type are also provided.
;;

;;; Code:
(eval-when-compile (require 'font-lock))
(require 'semantic)
(require 'semantic/tag-ls)
(require 'ezimage)

(eval-when-compile (require 'semantic/find))

;;; Tag to text overload functions
;;
;; abbreviations, prototypes, and coloring support.
(defvar semantic-format-tag-functions

would claim as a parent.
COLOR indicates that the generated text should be colored using
`font-lock'.")

(semantic-varalias-obsolete 'semantic-token->text-functions
			    'semantic-format-tag-functions)

(defvar semantic-format-tag-custom-list
  (append '(radio)
	  (mapcar (lambda (f) (list 'const f))
		  semantic-format-tag-functions)
	  '(function))
  "A List used by customizeable variables to choose a tag to text function.
Use this variable in the :type field of a customizable variable.")

(semantic-varalias-obsolete 'semantic-token->text-custom-list
			    'semantic-format-tag-custom-list)

(defcustom semantic-format-use-images-flag ezimage-use-images
  "Non-nil means semantic format functions use images.
Images can be used as icons instead of some types of text strings."
  :group 'semantic

(make-variable-buffer-local 'semantic-function-argument-separator)

(defvar semantic-format-parent-separator "::"
  "Text used to separate names when between namespaces/classes and functions.")
(make-variable-buffer-local 'semantic-format-parent-separator)

(defvar semantic-format-face-alist
  `( (function . font-lock-function-name-face)
     (variable . font-lock-variable-name-face)
     (type . font-lock-type-face)

is a symbol representing a face.
Faces used are generated in `font-lock' for consistency, and will not
be used unless font lock is a feature.")

(semantic-varalias-obsolete 'semantic-face-alist
			    'semantic-format-face-alist)



;;; Coloring Functions
;;

	(put-text-property 0 (length text) 'face face newtext)
	newtext)
    text))

(make-obsolete 'semantic-colorize-text
	       'semantic--format-colorize-text)

(defun semantic--format-colorize-merge-text (precoloredtext face-class)
  "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
FACE-CLASS is a tag type found in 'semantic-face-alist'.  See this
variable for details on adding new types."

      out)
    ))


;;; Abstract formatting functions
;;

(defun semantic-format-tag-prin1 (tag &optional parent color)
  "Convert TAG to a string that is the print name for TAG.
PARENT and COLOR are ignored."
  (format "%S" tag))

	       (setq ans (semantic-format-tag-type anything color)))
	   ans))
	((and (listp anything)
	      (stringp (car anything)))
	 (semantic--format-colorize-text (car anything) colorhint))))

;;;###autoload
(define-overloadable-function semantic-format-tag-name (tag &optional parent color)
  "Return the name string describing TAG.
The name is the shortest possible representation.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors.")

(defun semantic-format-tag-name-default (tag &optional parent color)
  "Return an abbreviated string describing TAG.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
  (let ((name (semantic-tag-name tag))
	(destructor
	 (if (eq (semantic-tag-class tag) 'function)
	     (semantic-tag-function-destructor-p tag))))
    (when destructor
      (setq name (concat "~" name)))
    (if color
	(setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
    name))

(declare-function semantic-go-to-tag "semantic/tag-file")

(defun semantic--format-tag-parent-tree (tag parent)
  "Under Consideration.

(defun semantic-format-tag-summarize-default (tag &optional parent color)
  "Summarize TAG in a reasonable way.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
  (let* ((proto (semantic-format-tag-prototype tag nil color))
	 (names (if parent
		    semantic-symbol->name-assoc-list-for-type-parts
		  semantic-symbol->name-assoc-list))
	 (tsymb (semantic-tag-class tag))
	 (label (capitalize (or (cdr-safe (assoc tsymb names))
				(symbol-name tsymb)))))
    (if color
	(setq label (semantic--format-colorize-text label 'label)))
    (concat label ": " proto)))

(define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
  "Like `semantic-format-tag-summarize', but with the file name.
Optional argument PARENT is the parent type if TAG is a detail.

(defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
  "Summarize TAG in a reasonable way.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors."
  (let* ((proto (semantic-format-tag-prototype tag nil color))
	 (file (semantic-tag-file-name tag))
	 )
    ;; Nothing for tag?  Try parent.
    (when (and (not file) (and parent))
      (setq file (semantic-tag-file-name parent)))
    ;; Don't include the file name if we can't find one, or it is the

      (setq doc (semantic--format-colorize-text doc 'documentation)))
    doc
    ))

;;; Prototype generation
;;
;;;###autoload
(define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
  "Return a prototype for TAG.
This function should be overloaded, though it need not be used.
This is because it can be used to create code by language independent
tools.
Optional argument PARENT is the parent type if TAG is a detail.
Optional argument COLOR means highlight the prototype with font-lock colors.")

(defun semantic-format-tag-prototype-default (tag &optional parent color)
  "Default method for returning a prototype for TAG.
This will work for C like languages.
Optional argument PARENT is the parent type if TAG is a detail.

  (let* ((class (semantic-tag-class tag))
	 (name (semantic-format-tag-name tag parent color))
	 (type (if (member class '(function variable type))
		   (semantic-format-tag-type tag color)))
	 (args (if (member class '(function type))
		   (semantic--format-tag-arguments
		    (if (eq class 'function)
			(semantic-tag-function-arguments tag)
		      (list "")
		      ;;(semantic-tag-type-members tag)
		      )
		    #'semantic-format-tag-prototype
		    color)))
	 (const (semantic-tag-get-attribute tag :constant-flag))
	 (tm (semantic-tag-get-attribute tag :typemodifiers))
	 (mods (append
		(if const '("const") nil)
		(cond ((stringp tm) (list tm))

	       'semantic-format-tag-concise-prototype
	       color)
	      ")"))
     ((eq class 'variable)
      (let* ((deref (semantic-tag-get-attribute
		     tag :dereference))
	     (array "")
	     )
	(while (and deref (/= deref 0))
	  (setq array (concat array "[]")
		deref (1- deref)))
	(concat (semantic-format-tag-name tag parent color)
		array)))
     (t
      (semantic-format-tag-abbreviate tag parent color)))))

;;; UML display styles
;;

	(setq text (semantic--format-uml-post-colorize text tag parent)))
    text
    ))


;;; Test routines
;;
(defun semantic-test-all-format-tag-functions (&optional arg)
  "Test all outputs from `semantic-format-tag-functions'.
Output is generated from the function under `point'.
Optional argument ARG specifies not to use color."
  (interactive "P")
  (semantic-fetch-tags)
  (let* ((tag (semantic-current-tag))
	 (par (semantic-current-tag-parent))
	 (fns semantic-format-tag-functions))
    (with-output-to-temp-buffer "*format-tag*"
      (princ "Tag->format function tests:")
      (while fns
	(princ "\n")
	(princ (car fns))
	(princ ":\n ")
	(let ((s (funcall (car fns) tag par (not arg))))
	  (save-excursion
	    (set-buffer "*format-tag*")
	    (goto-char (point-max))
	    (insert s)))
	(setq fns (cdr fns))))
      ))


;;; Compatibility and aliases
;;
(semantic-alias-obsolete 'semantic-prin1-nonterminal
			 'semantic-format-tag-prin1)