Source

semantic / semantic-ctxt.el

Diff from to

File semantic-ctxt.el

 ;;; semantic-ctxt.el --- Context calculations for Semantic tools.
 
-;;; Copyright (C) 1999, 2000, 2001 Eric M. Ludlam
+;;; Copyright (C) 1999, 2000, 2001, 2002 Eric M. Ludlam
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>
 ;; Keywords: syntax
 
 (defvar semantic-function-argument-separation-character
  ","
-  "String which indicates the end of a command.
-Used for identifying the end of a single command.")
+  "String which indicates the end of an argument.
+Used for identifying arguments to functions.")
 (make-variable-buffer-local 'semantic-function-argument-separation-character)
 
 ;;; Local variable parsing.
 ;;
-(defun semantic-up-context (&optional point)
+(defun semantic-up-context (&optional point bounds-type)
   "Move point up one context from POINT.
 Return non-nil if there are no more context levels.
-Overloaded functions using `up-context' take no parameters."
-  (if point (goto-char (point)))
-  (let ((s (semantic-fetch-overload 'up-context)))
-    (if s (funcall s)
-      (semantic-up-context-default)
-      )))
+Overloaded functions using `up-context' take no parameters.
+BOUNDS-TYPE is a symbol representing a token type to restrict
+movement to.  If this is nil, 'function is used.
+This will find the smallest token of that type (function, variable,
+type, etc) and make sure non-nil is returned if you cannot
+go up past the bounds of that token."
+  (if point (goto-char point))
+  (let ((nar (semantic-current-nonterminal-of-type (or bounds-type 'function)))
+	(s (semantic-fetch-overload 'up-context)))
+    (if nar
+	(semantic-with-buffer-narrowed-to-token
+	    nar
+	  (if s (funcall s)
+	    (semantic-up-context-default)))
+      (if bounds-type (error "No context of type %s to advance in" bounds-type))
+      (if s (funcall s)
+	(semantic-up-context-default)))))
 
 (defun semantic-up-context-default ()
   "Move the point up and out one context level.
 Return non-nil if there is no upper context.
 The default behavior uses `semantic-up-context'.  It can
 be overridden with `beginning-of-context'."
-  (if point (goto-char (point)))
+  (if point (goto-char point))
   (let ((s (semantic-fetch-overload 'beginning-of-context)))
     (if s (funcall s)
       (semantic-beginning-of-context-default)
 Return non-nil if there is no upper context.
 Be default, this uses `semantic-up-context', and assumes parenthetical
 block delimiters.  This can be overridden with `end-of-context'."
-  (if point (goto-char (point)))
+  (if point (goto-char point))
   (let ((s (semantic-fetch-overload 'end-of-context)))
     (if s (funcall s)
       (semantic-end-of-context-default)
     (forward-char -1)
     nil))
 
+(defun semantic-narrow-to-context ()
+  "Narrow the buffer to the extent of the current context."
+  (let (b e)
+    (save-excursion
+      (if (semantic-beginning-of-context)
+	  nil
+	(setq b (point))))
+    (save-excursion
+      (if (semantic-end-of-context)
+	  nil
+	(setq e (point))))
+    (if (and b e) (narrow-to-region b e))))
+
+(defmacro semantic-with-buffer-narrowed-to-context (&rest body)
+  "Execute BODY with the buffer narrowed to the current context."
+  `(save-restriction
+     (semantic-narrow-to-context)
+     ,@body))
+(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 1)
+(add-hook 'edebug-setup-hook
+	  (lambda ()
+	    (def-edebug-spec semantic-with-buffer-narrowed-to-context
+	      (def-body))))
+
 (defun semantic-get-local-variables (&optional point)
   "Get the local variables based on POINT's context.
 Local variables are returned in Semantic token format.
 parse tokens at the beginning of the context.
 This can be overriden with `get-local-variables'."
   (save-excursion
-    (if point (goto-char (point)))
-    (let ((s (semantic-fetch-overload 'get-local-variables))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-get-local-variables-default)
-	))))
+    (if point (goto-char point))
+    (let ((vars
+	   (let ((s (semantic-fetch-overload 'get-local-variables))
+		 (case-fold-search semantic-case-fold))
+	     (if s (funcall s)
+	       (semantic-get-local-variables-default)
+	       ))))
+      (semantic-deoverlay-list vars)
+      vars)))
 
 (defun semantic-get-local-variables-default ()
   "Get local values from a specific context.
 Uses the bovinator with the special top-symbol `bovine-inner-scope'
 to collect tokens, such as local variables or prototypes."
+  ;; The working status is to let the parser work properly
   (working-status-forms "Local" "done"
-    (let ((semantic-bovination-working-type nil))
-      (semantic-bovinate-region-until-error
-       (point) (save-excursion (semantic-end-of-context) (point))
-       'bovine-inner-scope))))
+    (let ((semantic-bovination-working-type nil)
+	  ;; We want nothing to do with funny syntaxing while doing this.
+	  (semantic-unmatched-syntax-hook nil)
+	  ;; Disable parsing messages
+	  (working-status-dynamic-type nil)
+	  (vars nil))
+      (while (not (semantic-up-context (point) 'function))
+	(save-excursion
+	  (forward-char 1)
+	  (setq vars
+		(append (semantic-bovinate-region-until-error
+			 (point)
+			 (save-excursion (semantic-end-of-context) (point))
+			 'bovine-inner-scope)
+			vars))))
+      vars)))
 
 (defun semantic-get-local-arguments (&optional point)
   "Get arguments (variables) from the current context at POINT.
 This function returns a list of tokens.  If the local token returns
 just a list of strings, then this function will convert them to tokens.
 Part of this behavior can be overridden with `get-local-arguments'."
-  (if point (goto-char (point)))
+  (if point (goto-char point))
   (let* ((s (semantic-fetch-overload 'get-local-arguments))
 	 (case-fold-search semantic-case-fold)
 	 (params (if s (funcall s)
 		   (semantic-get-local-arguments-default)))
-	 (rparams nil))
+	 (rparams nil)
+         tok)
     ;; convert unsafe params to the right thing.
     (while params
-      (setq rparams
-	    (cons (cond ((semantic-token-p (car params))
-			 (car params))
-			((stringp (car params))
-			 (list (car params) 'variable))
-			(t (error "Unknown parameter element")))
-		  rparams)
-	    params (cdr params)))
+      (setq tok     (car params)
+            params  (cdr params)
+            rparams (cons
+                     (cond
+                      ((semantic-token-p tok)
+                       (when (semantic-overlay-p
+                              (semantic-token-overlay tok))
+                         ;; Return a copy of token without overlay.
+                         ;; Don't use `semantic-deoverlay-token' here
+                         ;; because the original overlay must be kept!
+                         (setq tok (copy-sequence tok))
+                         (setcar (semantic-token-overlay-cdr tok)
+                                 (vector (semantic-token-start tok)
+                                         (semantic-token-end tok))))
+                       tok)
+                      ((stringp (car params))
+                       (list (car params) 'variable))
+                      (t
+                       (error "Unknown parameter element")))
+                     rparams)))
     (nreverse rparams)))
 
 (defun semantic-get-local-arguments-default ()
 This can be overridden with `get-all-local-variables'.
 Optional argument POINT is the location to start getting the variables from."
   (save-excursion
-    (if point (goto-char (point)))
+    (if point (goto-char point))
     (let ((s (semantic-fetch-overload 'get-all-local-variables))
 	  (case-fold-search semantic-case-fold))
       (if s (funcall s)
 	))))
 
 (defun semantic-get-all-local-variables-default ()
-  "Get all local variables for this context, and parent contexts.
-Local variables are returned in Semantic token format.
-Uses `semantic-beginning-of-context', `semantic-end-of-context',
-`semantic-up-context', and `semantic-get-local-variables' to collect
-this information."
-  (let ((varlist nil)
-	(sublist nil))
-    (save-excursion
-      (while (not (semantic-beginning-of-context))
-	;; Get the local variables
-	(setq sublist (semantic-get-local-variables))
-	(if sublist
-	    (setq varlist (cons sublist varlist)))
-	;; Move out of this context to the next.
-	(semantic-up-context)))
-    ;; arguments to some local function
-    (setq sublist (semantic-get-local-arguments))
-    (if sublist (setq varlist (cons sublist varlist)))
-    ;; fix er up.
-    (nreverse varlist)))
+  "Get all local variables for this context.
+That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where:
+
+- LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'.
+- LOCAL-VARIABLES is collected by `semantic-get-local-variables'."
+  (cons (semantic-get-local-arguments)
+        (semantic-get-local-variables)))
 
 ;;; Local context parsing
 ;;
   "Move to the end of the current command.
 Be default, uses `semantic-command-separation-character'.
 Override with `end-of-command'."
-    (let ((s (semantic-fetch-overload 'end-of-command))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-end-of-command-default)
-	)))
+  (semantic-with-buffer-narrowed-to-context
+      (let ((s (semantic-fetch-overload 'end-of-command))
+	    (case-fold-search semantic-case-fold))
+	(if s (funcall s)
+	  (semantic-end-of-command-default)
+	  ))))
 
 (defun semantic-end-of-command-default ()
   "Move to the beginning of the current command.
 Depends on `semantic-command-separation-character' to find the
 beginning and end of a command."
-  (let ((nt (semantic-current-nonterminal)))
-    (if (re-search-forward (regexp-quote semantic-command-separation-character)
-			   (if nt (semantic-token-end nt))
-			   t)
-	(forward-char -1))))
+  (if (re-search-forward (regexp-quote semantic-command-separation-character)
+			 nil t)
+      (forward-char -1)
+    ;; If there wasn't a command after this, we are the last
+    ;; command, and we are incomplete.
+    (goto-char (point-max))))
 
 (defun semantic-beginning-of-command ()
   "Move to the beginning of the current command.
 Be default, users `semantic-command-separation-character'.
 Override with `beginning-of-command'."
-    (let ((s (semantic-fetch-overload 'beginning-of-command))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-beginning-of-command-default)
-	)))
+  (semantic-with-buffer-narrowed-to-context
+      (let ((s (semantic-fetch-overload 'beginning-of-command))
+	    (case-fold-search semantic-case-fold))
+	(if s (funcall s)
+	  (semantic-beginning-of-command-default)
+	  ))))
 
 (defun semantic-beginning-of-command-default ()
   "Move to the beginning of the current command.
 Depends on `semantic-command-separation-character' to find the
 beginning and end of a command."
-  (let ((nt (semantic-current-nonterminal)))
-    (if (or
-	 (and nt
-	      (re-search-backward (regexp-quote semantic-command-separation-character)
-				  (semantic-token-start nt)
-				  t))
-	 (re-search-backward (regexp-quote semantic-command-separation-character)
-			     nil
-			     t))
-	(progn
-	  ;; Here is a speedy way to skip over junk between the end of
-	  ;; the last command, and the beginning of the next.
-	  (forward-word 1)
-	  (forward-word -1)))))
+  (skip-chars-backward semantic-command-separation-character)
+  (if (re-search-backward (regexp-quote semantic-command-separation-character)
+			  nil t)
+      (goto-char (match-end 0))
+    ;; If there wasn't a command after this, we are the last
+    ;; command, and we are incomplete.
+    (goto-char (point-min)))
+  (skip-chars-forward " \t\n")
+  )
+
+
+(defsubst semantic-point-at-beginning-of-command ()
+  "Return the point at the beginning of the current command."
+  (save-excursion (semantic-beginning-of-command) (point)))
+
+(defsubst semantic-point-at-end-of-command ()
+  "Return the point at the beginning of the current command."
+  (save-excursion (semantic-end-of-command) (point)))
+
+(defsubst semantic-narrow-to-command ()
+  "Narrow the current buffer to the current command."
+  (narrow-to-region (semantic-point-at-beginning-of-command)
+		    (semantic-point-at-end-of-command)))
+
+(defmacro semantic-with-buffer-narrowed-to-command (&rest body)
+  "Execute BODY with the buffer narrowed to the current command."
+  `(save-restriction
+     (semantic-narrow-to-command)
+     ,@body))
+(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 1)
+(add-hook 'edebug-setup-hook
+	  (lambda ()
+	    (def-edebug-spec semantic-with-buffer-narrowed-to-command
+	      (def-body))))
+
 
 (defun semantic-ctxt-current-symbol (&optional point)
   "Return the current symbol the cursor is on at POINT in a list.
 This will include a list of type/field names when applicable.
 This can be overridden using `ctxt-current-symbol'."
-    (if point (goto-char (point)))
-    (let ((s (semantic-fetch-overload 'ctxt-current-symbol))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-ctxt-current-symbol-default)
-	)))
+  (if point (goto-char point))
+  (let ((s (semantic-fetch-overload 'ctxt-current-symbol))
+	(case-fold-search semantic-case-fold))
+    (if s (funcall s)
+      (semantic-ctxt-current-symbol-default)
+      )))
 
 (defun semantic-ctxt-current-symbol-default ()
   "Return the current symbol the cursor is on at POINT in a list.
 			       "\\|"))
 	 (fieldsep (concat "\\(" fieldsep1 "\\)\\(\\w\\|\\s_\\)"))
 	 (symlist nil)
-	 end begin)
+	 end)
     (save-excursion
       (if (looking-at "\\w\\|\\s_")
 	  (forward-sexp 1)
 	    (setq symlist (cons (buffer-substring-no-properties (point) end)
 				symlist))
 	    ;; Skip the next syntactic expression backwards, then go forwards.
-	    (forward-sexp -1)
-	    (forward-sexp 1)
+	    (let ((cp (point)))
+	      (forward-sexp -1)
+	      (forward-sexp 1)
+	      ;; If we end up at the same place we started, we are at the
+	      ;; beginning of a buffer, or narrowed to a command and
+	      ;; have to stop.
+	      (if (<= cp (point)) (error nil)))
 	    (if (looking-at fieldsep)
 		(setq end (point))
 	      (error nil))
 Return a list as per `semantic-ctxt-current-symbol'.
 Return nil if there is nothing relevant.
 Override with `ctxt-current-assignment'."
-    (if point (goto-char (point)))
-    (let ((s (semantic-fetch-overload 'ctxt-current-assignment))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-ctxt-current-assignment-default)
-	)))
+  (if point (goto-char point))
+  (let ((s (semantic-fetch-overload 'ctxt-current-assignment))
+	(case-fold-search semantic-case-fold))
+    (if s (funcall s)
+      (semantic-ctxt-current-assignment-default)
+      )))
 
 (defun semantic-ctxt-current-assignment-default ()
   "Return the current assignment near the cursor at POINT.
 By default, assume that \"=\" indicates an assignment."
   (condition-case nil
-      (let* ((begin (save-excursion (semantic-beginning-of-command) (point)))
-	     (upc (save-excursion (semantic-up-context) (point)))
-	     (nearest (if (< begin upc) upc begin)))
-	(save-excursion
-	  ;; TODO: Skip a regexp backwards with whitespace from the
-	  ;; syntax table.
-	  (skip-chars-backward " \t\n")
-	  ;; Lets wander backwards till we find an assignment.
-	  (while (and (not (= (preceding-char) ?=))
-		      (> (point) nearest))
+      (semantic-with-buffer-narrowed-to-command
+	  (save-excursion
+	    (skip-chars-forward " \t=")
+	    (condition-case nil (forward-char 1) (error nil))
+	    (re-search-backward "[^=]=\\([^=]\\|$\\)")
+	    ;; We are at an equals sign.  Go backwards a sexp, and
+	    ;; we'll have the variable.  Otherwise we threw an error
 	    (forward-sexp -1)
-	    (skip-chars-backward " \t\n")
-	    )
-	  ;; We are at an equals sign.  Go backwards a sexp, and
-	  ;; we'll have the variable
-	  (forward-sexp -1)
-	  (semantic-ctxt-current-symbol)))
+	    (semantic-ctxt-current-symbol)))
     (error nil)))
 
 (defun semantic-ctxt-current-function (&optional point)
   "Return the current function the cursor is in at POINT.
 The function returned is the one accepting the arguments that
-the cursor is currently in.
+the cursor is currently in.  It will not return function symbol if the
+cursor is on the text representing that function.
 This can be overridden with `ctxt-current-function'."
-    (if point (goto-char (point)))
-    (let ((s (semantic-fetch-overload 'ctxt-current-function))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-ctxt-current-function-default)
-	)))
+  (if point (goto-char point))
+  (let ((s (semantic-fetch-overload 'ctxt-current-function))
+	(case-fold-search semantic-case-fold))
+    (if s (funcall s)
+      (semantic-ctxt-current-function-default)
+      )))
 
 (defun semantic-ctxt-current-function-default ()
-  "Return the current symbol the cursor is on at POINT in a list."
+  "Default function for `semantic-ctxt-current-function'."
   (save-excursion
     (semantic-up-context)
     (when (looking-at "(")
   )
 
 (defun semantic-ctxt-current-argument (&optional point)
-  "Return the current symbol the cursor is on at POINT.
+  "Return the index of the argument position the cursor is on at POINT.
 Override with `ctxt-current-argument'."
-    (if point (goto-char (point)))
-    (let ((s (semantic-fetch-overload 'ctxt-current-argument))
-	  (case-fold-search semantic-case-fold))
-      (if s (funcall s)
-	(semantic-ctxt-current-argument-default)
-	)))
+  (if point (goto-char point))
+  (let ((s (semantic-fetch-overload 'ctxt-current-argument))
+	(case-fold-search semantic-case-fold))
+    (if s (funcall s)
+      (semantic-ctxt-current-argument-default)
+      )))
 
  (defun semantic-ctxt-current-argument-default ()
-  "Return the current symbol the cursor is on at POINT in a list.
+  "Return the index of the argument the cursor is on.
 Depends on `semantic-function-argument-separation-character'."
   (when (semantic-ctxt-current-function)
     (save-excursion
 	  (setq idx (1+ idx)))
 	idx))))
 
-;;; Context analysis routines
-;;
-;; These routines use the override methods to provides high level
-;; predicates, and to come up with intelligent suggestions about
-;; the current context.
-(defun semantic-suggest-lookup-item (name  &optional tokentype returntype)
-  "Find a token definition matching NAME with TOKENTYPE.
-Optional RETURNTYPE is a return value to match against also."
-  (let* ((locals (semantic-get-all-local-variables))
-	 (case-fold-search semantic-case-fold)
-	 (option
-	  (or (let ((found nil))
-		(while (and locals (not found))
-		  (setq found (semantic-find-nonterminal-by-name
-			       name (car locals) t)
-			locals (cdr locals)))
-		found)
-	      (semantic-find-nonterminal-by-name
-	       name (current-buffer) t)
-	      (and (featurep 'semanticdb)
-		   (semanticdb-minor-mode-p)
-		   (semanticdb-find-nonterminal-by-name name nil t nil t)))))
-    ;; This part is lame right now.  It needs to eventually
-    ;; do the tokentype and returntype filters across all databases.
-    ;; Some of the above return one token, instead of a list.  Deal with
-    ;; that too.
-    (if (listp option)
-	(if (semantic-token-p option)
-	    option
-          ;; `semanticdb-find-nonterminal-by-name' returns a list
-          ;; ((DB-TABLE . TOKEN) ...)
-	  (setq option (cdr (car option))))
-      (if (stringp option)
-	  (list option 'variable)
-	))))
+(defun semantic-ctxt-scoped-types (&optional point)
+  "Return a list of type names currently in scope at POINT.
+Override with `ctxt-scoped-types'."
+  (if point (goto-char point))
+  (let ((s (semantic-fetch-overload 'ctxt-scoped-types))
+	(case-fold-search semantic-case-fold))
+    (if s (funcall s)
+      (semantic-ctxt-scoped-types-default)
+      )))
 
-(defun semantic-suggest-variable-token-hierarchy ()
-  "Analyze the current line, and return a series of tokens.
-The tokens represent a hierarchy of dereferences.  For example, a
-variable name will return a list with one token representing that
-variable's declaration.  If that variable is being dereferenced, then
-return a list starting with the variable declaration, followed by all
-fields being extracted.
-
-For example, in c, \"foo->bar\" would return a list (VARTOKEN FIELDTOKEN)
-where VARTOKEN is a semantic token of the variable foo's declaration.
-FIELDTOKEN is either a string, or a semantic token representing
-the field in foo's type."
-  (let ((v (semantic-ctxt-current-symbol))
-	(case-fold-search semantic-case-fold)
-	(name nil)
-	(tok nil)
-	(chil nil)
-	(toktype nil))
-    ;; First, take the first element of V, and find its type.
-    (setq tok (semantic-suggest-lookup-item (car v) 'variable))
-    ;; Now refer to it's type.
-    (setq toktype (semantic-token-type tok))
-    (if (and (semantic-token-p toktype)
-	     (not (semantic-token-type-parts toktype)))
-	(setq toktype (semantic-suggest-lookup-item
-		       (if (semantic-token-p toktype)
-			   (semantic-token-name toktype)
-			 (if (stringp toktype)
-			     toktype
-			   (error "Unknown token type")))
-		       'type)))
-    (if toktype
-	(cond ((and (semantic-token-p toktype)
-		    (setq chil (semantic-nonterminal-children toktype)))
-	       ;; We now have the type of the start variable.  Now we
-	       ;; have to match the list of additional fields with the
-	       ;; children of the type we found.
-	       (let ((chosenfields (cdr tok))
-		     (returnlist (list toktype)))
-		 (while chosenfields
-		   ;; Find this field in the current toktype
-		   
-		   (setq chosenfields (cdr chosenfields)))
-		 (nreverse returnlist))
-	       )
-	      ((semantic-token-p toktype)
-	       (list toktype))
-	      ((stringp toktype)
-	       (list (list toktype 'type)))
-	      (t nil)))))
-
-(defun semantic-suggest-current-type ()
-  "Return the recommended type at the current location."
-  (let ((recommendation (semantic-suggest-variable-token-hierarchy)))
-    (car (nreverse recommendation))))
+(defun semantic-ctxt-scoped-types-default ()
+  "Return a list of scoped types by name for the current context.
+This is very different for various languages, and does nothing unless
+overriden."
+  nil)
 
 (provide 'semantic-ctxt)