lisp/cedet/semantic/fw.el

   1 ;;; semantic/fw.el --- Framework for Semantic
   2
   3 ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; Semantic has several core features shared across it's lex/parse/util
  26 ;; stages.  This used to clutter semantic.el some.  These routines are all
  27 ;; simple things that are not parser specific, but aid in making
  28 ;; semantic flexible and compatible amongst different Emacs platforms.
  29
  30 ;;; Code:
  31 ;;
  32 (require 'mode-local)
  33 (require 'eieio)
  34 (load "semantic/loaddefs" nil 'nomessage)
  35
  36 ;;; Compatibility
  37
  38 (defalias 'semantic-buffer-local-value      'buffer-local-value)
  39 (defalias 'semantic-overlay-live-p          'overlay-buffer)
  40 (defalias 'semantic-make-overlay            'make-overlay)
  41 (defalias 'semantic-overlay-put             'overlay-put)
  42 (defalias 'semantic-overlay-get             'overlay-get)
  43 (defalias 'semantic-overlay-properties      'overlay-properties)
  44 (defalias 'semantic-overlay-move            'move-overlay)
  45 (defalias 'semantic-overlay-delete          'delete-overlay)
  46 (defalias 'semantic-overlays-at             'overlays-at)
  47 (defalias 'semantic-overlays-in             'overlays-in)
  48 (defalias 'semantic-overlay-buffer          'overlay-buffer)
  49 (defalias 'semantic-overlay-start           'overlay-start)
  50 (defalias 'semantic-overlay-end             'overlay-end)
  51 (defalias 'semantic-overlay-size            'overlay-size)
  52 (defalias 'semantic-overlay-next-change     'next-overlay-change)
  53 (defalias 'semantic-overlay-previous-change 'previous-overlay-change)
  54 (defalias 'semantic-overlay-lists           'overlay-lists)
  55 (defalias 'semantic-overlay-p               'overlayp)
  56 (defalias 'semantic-read-event              'read-event)
  57 (defalias 'semantic-popup-menu              'popup-menu)
  58 (defalias 'semantic-make-local-hook         'identity)
  59 (defalias 'semantic-mode-line-update        'force-mode-line-update)
  60 (defalias 'semantic-run-mode-hooks          'run-mode-hooks)
  61 (defalias 'semantic-compile-warn            'byte-compile-warn)
  62 (defalias 'semantic-menu-item               'identity)
  63
  64 (defun semantic-event-window (event)
  65   "Extract the window from EVENT."
  66   (car (car (cdr event))))
  67
  68 (defun semantic-delete-overlay-maybe (overlay)
  69   "Delete OVERLAY if it is a semantic token overlay."
  70   (if (semantic-overlay-get overlay 'semantic)
  71       (semantic-overlay-delete overlay)))
  72
  73 ;;; Positional Data Cache
  74 ;;
  75 (defvar semantic-cache-data-overlays nil
  76   "List of all overlays waiting to be flushed.")
  77
  78 (defun semantic-cache-data-to-buffer (buffer start end value name &optional lifespan)
  79   "In BUFFER over the region START END, remember VALUE.
  80 NAME specifies a special name that can be searched for later to
  81 recover the cached data with `semantic-get-cache-data'.
  82 LIFESPAN indicates how long the data cache will be remembered.
  83 The default LIFESPAN is 'end-of-command.
  84 Possible Lifespans are:
  85   'end-of-command - Remove the cache at the end of the currently
  86                     executing command.
  87   'exit-cache-zone - Remove when point leaves the overlay at the
  88                     end of the currently executing command."
  89   ;; Check if LIFESPAN is valid before to create any overlay
  90   (or lifespan (setq lifespan 'end-of-command))
  91   (or (memq lifespan '(end-of-command exit-cache-zone))
  92       (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s"
  93              lifespan))
  94   (let ((o (semantic-make-overlay start end buffer)))
  95     (semantic-overlay-put o 'cache-name   name)
  96     (semantic-overlay-put o 'cached-value value)
  97     (semantic-overlay-put o 'lifespan     lifespan)
  98     (setq semantic-cache-data-overlays
  99           (cons o semantic-cache-data-overlays))
 100     ;;(message "Adding to cache: %s" o)
 101     (add-hook 'post-command-hook 'semantic-cache-data-post-command-hook)
 102     ))
 103
 104 (defun semantic-cache-data-post-command-hook ()
 105   "Flush `semantic-cache-data-overlays' based 'lifespan property.
 106 Remove self from `post-command-hook' if it is empty."
 107   (let ((newcache nil)
 108         (oldcache semantic-cache-data-overlays))
 109     (while oldcache
 110       (let* ((o    (car oldcache))
 111              (life (semantic-overlay-get o 'lifespan))
 112              )
 113         (if (or (eq life 'end-of-command)
 114                 (and (eq life 'exit-cache-zone)
 115                      (not (member o (semantic-overlays-at (point))))))
 116             (progn
 117               ;;(message "Removing from cache: %s" o)
 118               (semantic-overlay-delete o)
 119               )
 120           (setq newcache (cons o newcache))))
 121       (setq oldcache (cdr oldcache)))
 122     (setq semantic-cache-data-overlays (nreverse newcache)))
 123
 124   ;; Remove ourselves if we have removed all overlays.
 125   (unless semantic-cache-data-overlays
 126     (remove-hook 'post-command-hook
 127                  'semantic-cache-data-post-command-hook)))
 128
 129 (defun semantic-get-cache-data (name &optional point)
 130   "Get cached data with NAME from optional POINT."
 131   (save-excursion
 132     (if point (goto-char point))
 133     (let ((o (semantic-overlays-at (point)))
 134           (ans nil))
 135       (while (and (not ans) o)
 136         (if (equal (semantic-overlay-get (car o) 'cache-name) name)
 137             (setq ans (car o))
 138           (setq o (cdr o))))
 139       (when ans
 140         (semantic-overlay-get ans 'cached-value)))))
 141
 142 ;;; Obsoleting various functions & variables
 143 ;;
 144 (defun semantic-overload-symbol-from-function (name)
 145   "Return the symbol for overload used by NAME, the defined symbol."
 146   (let ((sym-name (symbol-name name)))
 147     (if (string-match "^semantic-" sym-name)
 148         (intern (substring sym-name (match-end 0)))
 149       name)))
 150
 151 (defun semantic-alias-obsolete (oldfnalias newfn when)
 152   "Make OLDFNALIAS an alias for NEWFN.
 153 Mark OLDFNALIAS as obsolete, such that the byte compiler
 154 will throw a warning when it encounters this symbol."
 155   (defalias oldfnalias newfn)
 156   (make-obsolete oldfnalias newfn when)
 157   (when (and (function-overload-p newfn)
 158              (not (overload-obsoleted-by newfn))
 159              ;; Only throw this warning when byte compiling things.
 160              (boundp 'byte-compile-current-file)
 161              byte-compile-current-file
 162              (not (string-match "cedet" byte-compile-current-file))
 163              )
 164     (make-obsolete-overload oldfnalias newfn when)
 165     (semantic-compile-warn
 166      "%s: `%s' obsoletes overload `%s'"
 167      byte-compile-current-file
 168      newfn
 169      (semantic-overload-symbol-from-function oldfnalias))
 170     ))
 171
 172 (defun semantic-varalias-obsolete (oldvaralias newvar when)
 173   "Make OLDVARALIAS an alias for variable NEWVAR.
 174 Mark OLDVARALIAS as obsolete, such that the byte compiler
 175 will throw a warning when it encounters this symbol."
 176   (make-obsolete-variable oldvaralias newvar when)
 177   (condition-case nil
 178       (defvaralias oldvaralias newvar)
 179     (error
 180      ;; Only throw this warning when byte compiling things.
 181      (when (and (boundp 'byte-compile-current-file)
 182                 byte-compile-current-file)
 183        (semantic-compile-warn
 184         "variable `%s' obsoletes, but isn't alias of `%s'"
 185         newvar oldvaralias)
 186      ))))
 187 \f
 188 ;;; Help debugging
 189 ;;
 190 (defmacro semantic-safe (format &rest body)
 191   "Turn into a FORMAT message any error caught during eval of BODY.
 192 Return the value of last BODY form or nil if an error occurred.
 193 FORMAT can have a %s escape which will be replaced with the actual
 194 error message.
 195 If `debug-on-error' is set, errors are not caught, so that you can
 196 debug them.
 197 Avoid using a large BODY since it is duplicated."
 198   ;;(declare (debug t) (indent 1))
 199   `(if debug-on-error
 200        ;;(let ((inhibit-quit nil)) ,@body)
 201        ;; Note to self: Doing the above screws up the wisent parser.
 202        (progn ,@body)
 203      (condition-case err
 204          (progn ,@body)
 205        (error
 206         (message ,format (format "%S - %s" (current-buffer)
 207                                  (error-message-string err)))
 208         nil))))
 209 (put 'semantic-safe 'lisp-indent-function 1)
 210
 211 ;;; Misc utilities
 212 ;;
 213 (defsubst semantic-map-buffers (function)
 214   "Run FUNCTION for each Semantic enabled buffer found.
 215 FUNCTION does not have arguments.  When FUNCTION is entered
 216 `current-buffer' is a selected Semantic enabled buffer."
 217   (mode-local-map-file-buffers function #'semantic-active-p))
 218
 219 (defalias 'semantic-map-mode-buffers 'mode-local-map-mode-buffers)
 220
 221 (semantic-alias-obsolete 'define-mode-overload-implementation
 222                          'define-mode-local-override "23.2")
 223
 224 (defun semantic-install-function-overrides (overrides &optional transient mode)
 225   "Install the function OVERRIDES in the specified environment.
 226 OVERRIDES must be an alist ((OVERLOAD .  FUNCTION) ...) where OVERLOAD
 227 is a symbol identifying an overloadable entry, and FUNCTION is the
 228 function to override it with.
 229 If optional argument TRANSIENT is non-nil, installed overrides can in
 230 turn be overridden by next installation.
 231 If optional argument MODE is non-nil, it must be a major mode symbol.
 232 OVERRIDES will be installed globally for this major mode.  If MODE is
 233 nil, OVERRIDES will be installed locally in the current buffer.  This
 234 later installation should be done in MODE hook."
 235   (mode-local-bind
 236    ;; Add the semantic- prefix to OVERLOAD short names.
 237    (mapcar
 238     #'(lambda (e)
 239         (let ((name (symbol-name (car e))))
 240           (if (string-match "^semantic-" name)
 241               e
 242             (cons (intern (format "semantic-%s" name)) (cdr e)))))
 243     overrides)
 244    (list 'constant-flag (not transient)
 245          'override-flag t)
 246    mode))
 247 \f
 248 ;;; User Interrupt handling
 249 ;;
 250 (defvar semantic-current-input-throw-symbol nil
 251   "The current throw symbol for `semantic-exit-on-input'.")
 252
 253 (defmacro semantic-exit-on-input (symbol &rest forms)
 254   "Using SYMBOL as an argument to `throw', execute FORMS.
 255 If FORMS includes a call to `semantic-thow-on-input', then
 256 if a user presses any key during execution, this form macro
 257 will exit with the value passed to `semantic-throw-on-input'.
 258 If FORMS completes, then the return value is the same as `progn'."
 259   `(let ((semantic-current-input-throw-symbol ,symbol))
 260      (catch ,symbol
 261        ,@forms)))
 262 (put 'semantic-exit-on-input 'lisp-indent-function 1)
 263
 264 (defmacro semantic-throw-on-input (from)
 265   "Exit with `throw' when in `semantic-exit-on-input' on user input.
 266 FROM is an indication of where this function is called from as a value
 267 to pass to `throw'.  It is recommended to use the name of the function
 268 calling this one."
 269   `(when (and semantic-current-input-throw-symbol
 270               (or (input-pending-p) (accept-process-output)))
 271      (throw semantic-current-input-throw-symbol ,from)))
 272
 273 \f
 274 ;;; Special versions of Find File
 275 ;;
 276 (defun semantic-find-file-noselect (file &optional nowarn rawfile wildcards)
 277   "Call `find-file-noselect' with various features turned off.
 278 Use this when referencing a file that will be soon deleted.
 279 FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'"
 280   (let* ((recentf-exclude '( (lambda (f) t) ))
 281          ;; This is a brave statement.  Don't waste time loading in
 282          ;; lots of modes.  Especially decoration mode can waste a lot
 283          ;; of time for a buffer we intend to kill.
 284          (semantic-init-hook nil)
 285          ;; This disables the part of EDE that asks questions
 286          (ede-auto-add-method 'never)
 287          ;; Ask font-lock to not colorize these buffers, nor to
 288          ;; whine about it either.
 289          (font-lock-maximum-size 0)
 290          (font-lock-verbose nil)
 291          ;; Disable revision control
 292          (vc-handled-backends nil)
 293          ;; Don't prompt to insert a template if we visit an empty file
 294          (auto-insert nil)
 295          ;; We don't want emacs to query about unsafe local variables
 296          (enable-local-variables
 297           (if (featurep 'xemacs)
 298               ;; XEmacs only has nil as an option?
 299               nil
 300             ;; Emacs 23 has the spiffy :safe option, nil otherwise.
 301             (if (>= emacs-major-version 22)
 302                 nil
 303               :safe)))
 304          ;; ... or eval variables
 305          (enable-local-eval nil)
 306          )
 307     (save-match-data
 308       (if (featurep 'xemacs)
 309           (find-file-noselect file nowarn rawfile)
 310         (find-file-noselect file nowarn rawfile wildcards)))
 311     ))
 312
 313 ;;; Database restriction settings
 314 ;;
 315 (defmacro semanticdb-without-unloaded-file-searches (forms)
 316   "Execute FORMS with `unloaded' removed from the current throttle."
 317   `(let ((semanticdb-find-default-throttle
 318           (if (featurep 'semantic/db-find)
 319               (remq 'unloaded semanticdb-find-default-throttle)
 320             nil)))
 321      ,forms))
 322 (put 'semanticdb-without-unloaded-file-searches 'lisp-indent-function 1)
 323
 324 \f
 325 ;; ;;; Editor goodies ;-)
 326 ;; ;;
 327 ;; (defconst semantic-fw-font-lock-keywords
 328 ;;   (eval-when-compile
 329 ;;     (let* (
 330 ;;            ;; Variable declarations
 331 ;;         (vl nil)
 332 ;;            (kv (if vl (regexp-opt vl t) ""))
 333 ;;            ;; Function declarations
 334 ;;         (vf '(
 335 ;;               "define-lex"
 336 ;;               "define-lex-analyzer"
 337 ;;               "define-lex-block-analyzer"
 338 ;;               "define-lex-regex-analyzer"
 339 ;;               "define-lex-spp-macro-declaration-analyzer"
 340 ;;               "define-lex-spp-macro-undeclaration-analyzer"
 341 ;;               "define-lex-spp-include-analyzer"
 342 ;;               "define-lex-simple-regex-analyzer"
 343 ;;               "define-lex-keyword-type-analyzer"
 344 ;;               "define-lex-sexp-type-analyzer"
 345 ;;               "define-lex-regex-type-analyzer"
 346 ;;               "define-lex-string-type-analyzer"
 347 ;;               "define-lex-block-type-analyzer"
 348 ;;               ;;"define-mode-overload-implementation"
 349 ;;               ;;"define-semantic-child-mode"
 350 ;;               "define-semantic-idle-service"
 351 ;;               "define-semantic-decoration-style"
 352 ;;               "define-wisent-lexer"
 353 ;;               "semantic-alias-obsolete"
 354 ;;               "semantic-varalias-obsolete"
 355 ;;               "semantic-make-obsolete-overload"
 356 ;;               "defcustom-mode-local-semantic-dependency-system-include-path"
 357 ;;               ))
 358 ;;            (kf (if vf (regexp-opt vf t) ""))
 359 ;;            ;; Regexp depths
 360 ;;            (kv-depth (if kv (regexp-opt-depth kv) nil))
 361 ;;            (kf-depth (if kf (regexp-opt-depth kf) nil))
 362 ;;            )
 363 ;;       `((,(concat
 364 ;;            ;; Declarative things
 365 ;;            "(\\(" kv "\\|" kf "\\)"
 366 ;;            ;; Whitespaces & names
 367 ;;            "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?"
 368 ;;            )
 369 ;;          (1 font-lock-keyword-face)
 370 ;;          (,(+ 1 kv-depth kf-depth 1)
 371 ;;           (cond ((match-beginning 2)
 372 ;;                  font-lock-type-face)
 373 ;;                 ((match-beginning ,(+ 1 kv-depth 1))
 374 ;;                  font-lock-function-name-face)
 375 ;;                 )
 376 ;;           nil t)
 377 ;;          (,(+ 1 kv-depth kf-depth 1 1)
 378 ;;           (cond ((match-beginning 2)
 379 ;;                  font-lock-variable-name-face)
 380 ;;                 )
 381 ;;           nil t)))
 382 ;;       ))
 383 ;;   "Highlighted Semantic keywords.")
 384
 385 ;; (when (fboundp 'font-lock-add-keywords)
 386 ;;   (font-lock-add-keywords 'emacs-lisp-mode
 387 ;;                           semantic-fw-font-lock-keywords))
 388 \f
 389 ;;; Interfacing with edebug
 390 ;;
 391 (defun semantic-fw-add-edebug-spec ()
 392   (def-edebug-spec semantic-exit-on-input 'def-body))
 393
 394 (add-hook 'edebug-setup-hook 'semantic-fw-add-edebug-spec)
 395
 396 (provide 'semantic/fw)
 397
 398 ;; arch-tag: e7eeffbf-112b-4665-92fc-5f69479ca2c4
 399 ;;; semantic/fw.el ends here