Source

semantic / semantic-el.el

Diff from to

semantic-el.el

-;;; semantic-ex.el --- Semantic details for some languages
+;;; semantic-el.el --- Semantic details for Emacs Lisp
 
-;;; Copyright (C) 1999, 2000 Eric M. Ludlam
+;;; Copyright (C) 1999, 2000, 2001 Eric M. Ludlam
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>
 ;; X-RCS: $Id$
   `((bovine-toplevel
      (semantic-list
       ,(lambda (vals start end)
-	 (let ((i (semantic-bovinate-from-nonterminal
-		   start end 'extract-toplevel nil
-		   ;; NOTE, currently the longest item we have is 6 long,
-		   ;; so only ask the flexer to go out 6 tokens.
-		   6)))
-	   (append (nreverse (cdr (cdr (reverse i))))
-		   (list start end)))))
-     (extract-toplevel))
-    ;; When parsing at depth 0, we need to extract elements from semantic
-    ;; lists at bovine-toplevel.  This symbol provides the needed redirection.
-    (extract-toplevel
-     (function)
-     (variable)
-     (type)
-     (include)
-     (package)
-     (method)
-     (advice)
-     (code)
-     (comment) )
-    ;; A type is defined by extended tools like CL, or EIEIO
-    (type
-     (open-paren symbol "defclass" symbol arg-list
-		 field-list doc-string
-		 ,(semantic-lambda
-		   (list (nth 2 vals) 'type
-			 "class"
-			 (nth 4 vals) (nth 3 vals) nil
-			 (car-safe (nth 5 vals))))))
-    ;; A function is anything that starts with a (defun
-    (function
-     (open-paren symbol "defun\\|defmacro\\|defsubst" symbol arg-list doc-string
-		 ,(semantic-lambda
-		    (list (nth 2 vals) 'function nil (nth 3 vals) nil
-			  (car-safe (nth 4 vals))))))
-    (method
-     (open-paren symbol "defmethod\\|defgeneric" symbol opt-label arg-list
-		 doc-string
-		 ,(semantic-lambda
-		    (list (nth 2 vals) 'function nil (nth 4 vals) nil
-			  (car-safe (nth 5 vals))))))
-    (advice
-     (open-paren symbol "defadvice" symbol arg-list
-		 doc-string
-		 ,(semantic-lambda
-		   (list (nth 2 vals) 'function nil (nth 3 vals) nil
-			 (car-safe (nth 4 vals))))))
-    ;; A variable can be a defvar or defconst.
-    (variable
-     (open-paren symbol "defvar\\|defconst\\|defcustom\\|defface\\|defimage"
-		 symbol expression doc-string
-		 ,(semantic-lambda
-		    (list (nth 2 vals) 'variable nil
-			  (if (string= (nth 1 vals) "defconst") t nil)
-			  nil nil (car-safe (nth 4 vals))))))
-    ;; In elisp, an include is just the require statement.
-    (include
-     (open-paren symbol "require" quote symbol
-		 ,(semantic-lambda
-		    (list (nth 3 vals) 'include nil nil))))
-    ;; in elisp, a package statement is the same as the provide token.
-    (package
-     (open-paren symbol "provide" quote symbol opt-filestring close-paren
-		 ,(semantic-lambda
-		    (list (nth 3 vals) 'package (nth 4 vals) nil))))
-    (opt-filestring
-     (string)
-     ( ,(lambda (vals start end) (list nil))))
-    ;; Some random code stuck in there.
-    (code
-     (open-paren symbol
-		 ,(semantic-lambda
-		    (let ((sym (if (nth 1 vals) (intern-soft (nth 1 vals)))))
-		      (if (and sym (fboundp sym))
-			  (list (nth 1 vals) 'code))))))
-    ;; Doc strings are sometimes optional, and always just return the
-    ;; start position.
-    (doc-string
-     (string ,(lambda (vals start end) (list start start end)))
-     (comment ,(lambda  (vals start end) (list start start end)))
-     ())
-    ;; Quotes are oft optional in some cases
-    (quote (punctuation "'"))
-    ;; Backquotes are also optional for macro type thingies
-    (backquote (punctuation "`"))
-    ;; Something that can be evaluated out to something.
-    (expression
-     (quote expression ,(semantic-lambda (list (car (cdr vals)))))
-     (backquote expression ,(semantic-lambda (list (car (cdr vals)))))
-     (semantic-list) (symbol) (string))
-    ;; An argument list to a function
-    (arg-list
-     (symbol "nil" ,(lambda (vals start end) (list nil)))
-     (semantic-list ,(lambda (vals start end)
-		       (semantic-bovinate-from-nonterminal start end 'argsyms)
-		       ))
-     ;; If it's already opened, what to do??
-     )
-    (argsyms
-     (open-paren close-paren ,(semantic-lambda
-				(list nil)))
-     (open-paren argsyms ,(semantic-lambda (car (cdr vals))))
-     (symbol argsyms ,(semantic-lambda
-			(append (cons (car vals) (car (cdr vals))))))
-     (semantic-list argsyms
-		    ,(semantic-lambda
-		      (let ((e (read (buffer-substring (car (nth 0 vals))
-						      (cdr (nth 0 vals))))))
-			(cons (symbol-name (car e))
-			      (car (cdr vals))))))
-     (symbol close-paren ,(semantic-lambda (list (car vals))))
-     (semantic-list close-paren
-		    ,(semantic-lambda
-		      (let ((e (read (buffer-substring (car (nth 0 vals))
-						       (cdr (nth 0 vals))))))
-			(list (symbol-name (car e)))))))
-    ;; This guys is some number of argument symbols...
-    (field-list
-     (semantic-list
-      ,(lambda (vals start end)
-	 (semantic-bovinate-from-nonterminal-full start end 'fieldsyms)
-	 )))
-    (fieldsyms
-     (semantic-list ,(semantic-lambda
-		      (let ((e (read (buffer-substring (car (nth 0 vals))
-						       (cdr (nth 0 vals))))))
-			(list (symbol-name (car e))))))
-     )
-    ;; Labels
-    (opt-label
-     (symbol "^:" ,(semantic-lambda (car vals)))
-     ())
+	 (append (semantic-elisp-use-read (car vals))
+		 (list start end)))))
     )
   "Top level bovination table for elisp.")
 
+(defun semantic-elisp-desymbolify (arglist)
+  "Convert symbols to strings for ARGLIST."
+  (let ((out nil))
+    (while arglist
+      (setq out
+	    (cons
+	     (if (symbolp (car arglist))
+		 (symbol-name (car arglist))
+	       (if (and (listp (car arglist))
+			(symbolp (car (car arglist))))
+		   (symbol-name (car (car arglist)))
+		 (format "%S" (car arglist))))
+	     out)
+	    arglist (cdr arglist)))
+    (nreverse out)))
+
+(defun semantic-elisp-form-to-doc-string (form)
+  "After reading a form FORM, covert it to a doc string.
+For Emacs Lisp, sometimes that string is non-existant.
+Recently discovered, sometimes it is a form which is evaluated
+at compile time, permitting compound strings."
+  (cond ((stringp form) form)
+	((and (listp form) (eq (car form) 'concat)
+	      (stringp (nth 1 form)))
+	 (nth 1 form))
+	(t nil)))
+
+(defun semantic-elisp-use-read (sl)
+  "Use `read' on the semantic list SL.
+Return a bovination list to use."
+  (let* ((rt (read (buffer-substring (car sl) (cdr sl)))) ; read text
+	 (ts (car rt)) ; type symbol
+	 (tss (nth 1 rt))
+	 (ss (if (not (listp tss)) tss
+	       (if (eq (car tss) 'quote)
+		   (nth 1 tss)
+		 (car tss))))
+	 (sn (format "%S" ss))
+	 )
+    (cond
+     ((listp ts)
+      ;; If the first elt is a list, then it is some arbitrary code.
+      (list "anonymous" 'code))
+     ((or (eq ts 'defvar)
+	  (eq ts 'defconst)
+	  (eq ts 'defcustom)
+	  (eq ts 'defface)
+	  (eq ts 'defimage))
+      (let ((doc (semantic-elisp-form-to-doc-string (nth 3 rt))))
+        ;; Variables and constants
+        (list sn 'variable nil (nth 2 rt)
+              (semantic-bovinate-make-assoc-list
+               'const (if (eq ts 'defconst) t nil)
+               'user-visible (and doc
+                                  (> (length doc) 0)
+                                  (= (aref doc 0) ?*))
+               )
+              doc)
+        ))
+     ((or (eq ts 'defun)
+	  (eq ts 'defsubst)
+	  (eq ts 'defmacro))
+      ;; functions and macros
+      (list sn 'function nil (semantic-elisp-desymbolify (nth 2 rt))
+	    (semantic-bovinate-make-assoc-list
+	     'user-visible (equal (car-safe (nth 4 rt)) 'interactive)
+	     )
+	    (nth 3 rt))
+      )
+     ((or (eq ts 'defmethod)
+	  (eq ts 'defgeneric))
+      ;; methods
+      (let* ((a2 (nth 2 rt))
+	     (a3 (nth 3 rt))
+	     (args (if (listp a2) a2 a3))
+	     (doc (nth (if (listp a2) 3 4) rt)))
+	(list sn 'function nil
+	      (if (listp (car args))
+		  (cons (symbol-name (car (car args)))
+			(semantic-elisp-desymbolify (cdr args)))
+		(semantic-elisp-desymbolify (cdr args)))
+	      (semantic-bovinate-make-assoc-list
+	       'parent (symbol-name
+			(if (listp (car args)) (car (cdr (car args))))))
+	      doc)
+	))
+     ((eq ts 'defadvice)
+      ;; Advice
+      (list sn 'function nil (semantic-elisp-desymbolify (nth 2 rt))
+	    nil (nth 3 rt)))
+     ((eq ts 'defclass)
+      ;; classes
+      (let ((docpart (nth 4 rt)))
+	(list sn 'type "class" (semantic-elisp-desymbolify (nth 3 rt))
+	      (semantic-elisp-desymbolify (nth 2 rt))
+	      (semantic-bovinate-make-assoc-list
+	       'typemodifiers
+	       (semantic-elisp-desymbolify
+		(if (not (stringp docpart))
+		    docpart))
+	       )
+	      (if (stringp docpart)
+		  docpart
+		(car (cdr (member :documentation docpart))))))
+      )
+     ((eq ts 'defstruct)
+      ;; structs
+      (list sn 'type "struct" (semantic-elisp-desymbolify (nthcdr 2 rt))
+	    nil ;(semantic-elisp-desymbolify (nth 2 rt))
+	    nil (nth 4 rt))
+      )
+     ;; Now for other stuff
+     ((eq ts 'require)
+      (list sn 'include nil nil))
+     ((eq ts 'provide)
+      (list sn 'package (nth 3 rt) nil))
+     (t
+      ;; Other stuff
+      (list (symbol-name ts) 'code)
+      ))))
+
 (defun semantic-elisp-find-dependency (token)
   "Find the file BUFFER depends on described by TOKEN."
   (let ((f (file-name-sans-extension
 	    (locate-library (semantic-token-name token)))))
     (concat f ".el")))
 
+(defun semantic-elisp-prototype-nonterminal (token &optional parent color)
+  "Return a prototype for the Emacs Lisp nonterminal TOKEN.
+PARENT and COLOR as for `semantic-prototype-nonterminal'."
+  (let* ((tok (semantic-token-token token))
+	 (args (semantic-nonterminal-children token))
+	 )
+    (if (eq tok 'function)
+	(concat (semantic-name-nonterminal token parent color) " ("
+		(mapconcat (lambda (a)
+			     (if color
+				 (if (string-match "^&" a)
+				     ;; This is a keyword
+				     (semantic-colorize-text a 'keyword)
+				   (semantic-colorize-text a 'variable))
+			       a))
+			   args " ")
+		")")
+      (semantic-prototype-nonterminal-default token parent color))))
+
+(defun semantic-elisp-find-documentation (token &optional nosnarf)
+  "Return the documentation string for TOKEN.
+Optional argument NOSNARF is ignored."
+  (let ((d (semantic-token-docstring token)))
+    (if (and d (> (length d) 0) (= (aref d 0) ?*))
+	(substring d 1)
+      d)))
+
+(defun semantic-elisp-insert-foreign-token (token tokenfile)
+  "Insert TOKEN from TOKENFILE at point.
+Attempts a simple prototype for calling or using TOKEN."
+  (cond ((eq (semantic-token-token token) 'function)
+	 (insert "(" (semantic-token-name token) " )")
+	 (forward-char -1))
+	(t
+	 (insert (semantic-token-name token)))))
+
 (defun semantic-default-elisp-setup ()
   "Setup hook function for Emacs Lisp files and Semantic."
+  (semantic-install-function-overrides
+   '((find-dependency . semantic-elisp-find-dependency)
+     (prototype-nonterminal . semantic-elisp-prototype-nonterminal)
+     (concise-prototype-nonterminal . semantic-elisp-prototype-nonterminal)
+     (find-documentation . semantic-elisp-find-documentation)
+     (insert-foreign-token . semantic-elisp-insert-foreign-token)
+     )
+   t)
   (setq semantic-toplevel-bovine-table semantic-toplevel-elisp-bovine-table
-	semantic-override-table
-	'((find-dependency . semantic-elisp-find-dependency))
 	semantic-symbol->name-assoc-list
 	'( (variable . "Variables")
 	   (type     . "Types")