view lisp/cedet/srecode/ctxt.el @ 107984:bef5d1738c0b

Make variable forwarding explicit rather the using special values. Basically, this makes the structure of buffer-local values and object forwarding explicit in the type of Lisp_Symbols rather than use special Lisp_Objects for that. This tends to lead to slightly more verbose code, but is more C-like, simpler, and makes it easier to make sure we handled all cases, among other things by letting the compiler help us check it. * lisp.h (enum Lisp_Misc_Type, union Lisp_Misc): Removing forwarding objects. (enum Lisp_Fwd_Type, enum symbol_redirect, union Lisp_Fwd): New types. (struct Lisp_Symbol): Make the various forms of variable-forwarding explicit rather than hiding them inside Lisp_Object "values". (XFWDTYPE): New macro. (XINTFWD, XBOOLFWD, XOBJFWD, XKBOARD_OBJFWD): Redefine. (XBUFFER_LOCAL_VALUE): Remove. (SYMBOL_VAL, SYMBOL_ALIAS, SYMBOL_BLV, SYMBOL_FWD, SET_SYMBOL_VAL) (SET_SYMBOL_ALIAS, SET_SYMBOL_BLV, SET_SYMBOL_FWD): New macros. (SYMBOL_VALUE, SET_SYMBOL_VALUE): Remove. (struct Lisp_Intfwd, struct Lisp_Boolfwd, struct Lisp_Objfwd) (struct Lisp_Buffer_Objfwd, struct Lisp_Kboard_Objfwd): Remove the Lisp_Misc_* header. (struct Lisp_Buffer_Local_Value): Redefine. (BLV_FOUND, SET_BLV_FOUND, BLV_VALUE, SET_BLV_VALUE): New macros. (struct Lisp_Misc_Any): Add filler to get the right size. (struct Lisp_Free): Use struct Lisp_Misc_Any rather than struct Lisp_Intfwd. (DEFVAR_LISP, DEFVAR_LISP_NOPRO, DEFVAR_BOOL, DEFVAR_INT) (DEFVAR_KBOARD): Allocate a forwarding object. * data.c (do_blv_forwarding, store_blv_forwarding): New macros. (let_shadows_global_binding_p): New function. (union Lisp_Val_Fwd): New type. (make_blv): New function. (swap_in_symval_forwarding, indirect_variable, do_symval_forwarding) (store_symval_forwarding, swap_in_global_binding, Fboundp) (swap_in_symval_forwarding, find_symbol_value, Fset) (let_shadows_buffer_binding_p, set_internal, default_value) (Fset_default, Fmake_variable_buffer_local, Fmake_local_variable) (Fkill_local_variable, Fmake_variable_frame_local) (Flocal_variable_p, Flocal_variable_if_set_p) (Fvariable_binding_locus): * xdisp.c (select_frame_for_redisplay): * lread.c (Fintern, Funintern, init_obarray, defvar_int) (defvar_bool, defvar_lisp_nopro, defvar_lisp, defvar_kboard): * frame.c (store_frame_param): * eval.c (Fdefvaralias, Fuser_variable_p, specbind, unbind_to): * bytecode.c (Fbyte_code) <varref, varset>: Adapt to the new symbol value structure. * buffer.c (PER_BUFFER_SYMBOL): Move from buffer.h. (clone_per_buffer_values): Only adjust markers into the current buffer. (reset_buffer_local_variables): PER_BUFFER_IDX is never -2. (Fbuffer_local_value, set_buffer_internal_1) (swap_out_buffer_local_variables): Adapt to the new symbol value structure. (DEFVAR_PER_BUFFER): Allocate a Lisp_Buffer_Objfwd object. (defvar_per_buffer): Take a new arg for the fwd object. (buffer_lisp_local_variables): Return a proper alist (different fix for bug#4138). * alloc.c (Fmake_symbol): Use SET_SYMBOL_VAL. (Fgarbage_collect): Don't handle buffer_defaults specially. (mark_object): Handle new symbol value structure rather than the old special Lisp_Misc_* objects. (gc_sweep) <symbols>: Free also the buffer-local-value objects. * term.c (set_tty_color_mode): * bidi.c (bidi_initialize): Don't access the ->value field directly. * buffer.h (PER_BUFFER_VAR_OFFSET): Don't bother with a buffer_local_flags. * print.c (print_object): Get rid of impossible forwarding objects.

;;; srecode/ctxt.el --- Derive a context from the source buffer.

;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <[e-mail]>

;; 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:
;;
;; Manage context calculations for Semantic Recoder.
;;
;; SRecode templates are always bound to a context.  By calculating
;; the current context, we can narrow down the selection of possible
;; templates to something reasonable.
;;
;; Alternately, code here will find a context for templates that
;; require different pieces of code placed in multiple areas.

(require 'semantic)
(require 'semantic/tag-ls)

(declare-function srecode-dictionary-show-section "srecode/dictionary")
(declare-function srecode-dictionary-set-value "srecode/dictionary")

;;; Code:

(define-overload srecode-calculate-context ()
  "Calculate the context at the current point.
The returned context is a list, with the top-most context first.
Each returned context is a string that that would show up in a `context'
statement in an `.srt' file.

Some useful context values used by the provided srecode templates are:
  \"file\" - Templates that for a file (such as an empty file.)
     \"empty\" - The file is empty
  \"declaration\" - Top-level declarations in a file.
     \"include\" - In or near include statements
     \"package\" - In or near provide statements
     \"function\" - In or near function statements
         \"NAME\" - Near functions within NAME namespace or class
     \"variable\" - In or near variable statements.
     \"type\"     - In or near type declarations.
     \"comment\"  - In a comment
  \"classdecl\" - Declarations within a class/struct/etc.
     \"variable\" - In or near class fields
     \"function\" - In or near methods/functions
        \"virtual\" - Nearby items are virtual
           \"pure\" - and those virtual items are pure virtual
     \"type\"     - In or near type declarations.
     \"comment\"  - In a comment in a block of code
     -- these items show up at the end of the context list. --
     \"public\", \"protected\", \"private\" -
                  In or near a section of public/pritected/private entries.
  \"code\" - In a block of code.
     \"string\" - In a string in a block of code
     \"comment\"  - In a comment in a block of code

    ... More later."
  )

(defun srecode-calculate-nearby-things ()
  ;; NOTE: May need to add bounes to this FCN
  "Calculate the CONTEXT type items nearby the current point.
Assume that what we want to insert next is based on what is just
before point.  If there is nothing, then assume it is whatever is
after point."
  ;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH
  ;;         thus classdecl "near" stuff cannot be
  ;;         outside the bounds of the type in question.
  (let ((near (semantic-find-tag-by-overlay-prev))
	(prot nil)
	(ans nil))
    (if (not near)
	(setq near (semantic-find-tag-by-overlay-next)))
    (when near
      ;; Calculate the type of thing we are near.
      (if (not (semantic-tag-of-class-p near 'function))
	  (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
	;; if the symbol NEAR has a parent,
	(let ((p (semantic-tag-function-parent near)))
	  (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
	  (cond ((semantic-tag-p p)
		 (setq ans (cons (semantic-tag-name p) ans)))
		((stringp p)
		 (setq ans (cons p ans)))
		(t nil)))
	;; Was it virtual?
	(when (semantic-tag-get-attribute near :virtual)
	  (setq ans (cons "virtual" ans)))
	;; Was it pure?
	(when (semantic-tag-get-attribute near :pure-virtual-flag)
	  (setq ans (cons "pure" ans)))
      )
      ;; Calculate the protection
      (setq prot (semantic-tag-protection near))
      (when (and prot (not (eq prot 'unknown)))
	(setq ans (cons (symbol-name prot) ans)))
      )
    (nreverse ans)))

(defun srecode-calculate-context-font-lock ()
  "Calculate an srecode context by using font-lock."
  (let ((face (get-text-property (point) 'face))
	)
    (cond ((member face '(font-lock-string-face
			  font-lock-doc-face))
	   (list "string"))
	  ((member face '(font-lock-comment-face
			  font-lock-comment-delimiter-face))
	   (list "comment"))
	  )
    ))

(defun srecode-calculate-context-default ()
  "Generic method for calculating a context for srecode."
  (if (= (point-min) (point-max))
      (list "file" "empty")

    (semantic-fetch-tags)
    (let ((ct (semantic-find-tag-by-overlay))
	  )
      (cond ((or (not ct)
		 ;; Ok, below is a bit C specific.
		 (and (eq (semantic-tag-class (car ct)) 'type)
		      (string= (semantic-tag-type (car ct)) "namespace")))
	     (cons "declaration"
		   (or (srecode-calculate-context-font-lock)
		       (srecode-calculate-nearby-things)
		       ))
	     )
	    ((eq (semantic-tag-class (car ct)) 'function)
	     (cons "code" (srecode-calculate-context-font-lock))
	     )
	    ((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace
	     (cons "classdecl"
		   (or (srecode-calculate-context-font-lock)
		       (srecode-calculate-nearby-things)))
	     )
	    ((and (car (cdr ct))
		  (eq (semantic-tag-class (car (cdr ct))) 'type))
	     (list "classdecl"
		   (symbol-name (semantic-tag-class (car ct))))
	     )
	    )
      )))


;;; HANDLERS
;;
;; The calculated context is one thing, but more info is often available.
;; The context handlers can add info into the active dictionary that is
;; based on the context, such as a method parent name, protection scheme,
;; or other feature.

(defun srecode-semantic-handle-:ctxt (dict &optional template)
  "Add macros into the dictionary DICT based on the current Emacs Lisp file.
Argument TEMPLATE is the template object adding context dictionary
entries.
This might add the following:
   VIRTUAL - show a section if a function is virtual
   PURE - show a section if a function is pure virtual.
   PARENT - The name of a parent type for functions.
   PROTECTION - Show a protection section, and what the protection is."
  (require 'srecode/dictionary)
  (when template

    (let ((name (oref template object-name))
	  (cc (if (boundp 'srecode-insertion-start-context)
		  srecode-insertion-start-context))
	  ;(context (oref template context))
	  )

;      (when (and cc
;		 (null (string= (car cc) context))
;		 )
;	;; No current context, or the base is different, then
;	;; this is the section where we need to recalculate
;	;; the context based on user choice, if possible.
;	;;
;	;; The recalculation is complex, as there are many possibilities
;	;; that need to be divined.  Set "cc" to the new context
;	;; at the end.
;	;;
;	;; @todo -
;
;	)

      ;; The various context all have different features.
      (let ((ct (nth 0 cc))
	    (it (nth 1 cc))
	    (last (last cc))
	    (parent nil)
	    )
	(cond ((string= it "function")
	       (setq parent (nth 2 cc))
	       (when parent
		 (cond ((string= parent "virtual")
			(srecode-dictionary-show-section dict "VIRTUAL")
			(when (nth 3 cc)
			  (srecode-dictionary-show-section dict "PURE"))
			)
		       (t
			(srecode-dictionary-set-value dict "PARENT" parent))))
	       )
	      ((and (string= it "type")
		    (or (string= name "function") (string= name "method")))
	       ;; If we have a type, but we insert a fcn, then use that type
	       ;; as the function parent.
	       (let ((near (semantic-find-tag-by-overlay-prev)))
		 (when (and near (semantic-tag-of-class-p near 'type))
		   (srecode-dictionary-set-value
		    dict "PARENT" (semantic-tag-name near))))
	       )
	      ((string= ct "code")
	       ;;(let ((analyzer (semantic-analyze-current-context)))
	       ;; @todo - Use the analyze to setup things like local
	       ;;         variables we might use or something.
	       nil
	       ;;)
	       )
	      (t
	       nil))
	(when (member last '("public" "private" "protected"))
	  ;; Hey, fancy that, we can do both.
	  (srecode-dictionary-set-value dict "PROTECTION" parent)
	  (srecode-dictionary-show-section dict "PROTECTION"))
	))
    ))


(provide 'srecode/ctxt)

;; arch-tag: 5a004702-28e5-4e26-9b14-8a78eae49865
;;; srecode/ctxt.el ends here