--- /dev/null
+;;; cc-engine-2.el --- Extensuions to cc-engine.el
+;;
+;; $Id$
+;;
+;; Copyright (C) 2000 Stefan Bund
+
+;; cc-engine-2.el 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 2, or (at
+;; your option) any later version.
+
+;; cc-engine-2.el 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.
+
+;;; Commentary:
+
+;;; Change-Log:
+
+;; $Log$
+;;
+
+;;; Variables:
+
+(defconst c-template-arglist-syntax
+ (let ((table (copy-syntax-table c-mode-syntax-table)))
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ table))
+
+(defconst c-any-key
+ (eval-when-compile
+ (concat (regexp-opt '("break" "continue" "do" "else" "for" "if"
+ "return" "switch" "while" "sizeof" "typedef"
+ "extern" "auto" "register" "static" "friend"
+ "volatile" "const" "restrict" "enum"
+ "struct" "union" "class" "char" "short"
+ "int" "long" "signed" "unsigned" "float"
+ "double" "void" "complex" "case" "goto"
+ "inline" "try" "catch" "throw" "inline_"
+ "throw_" "virtual" "new" "delete" "explicit"
+ "prefix_" "typename" "template") t)
+ "\\b[^_]")))
+
+(defconst c-blocking-key
+ (eval-when-compile
+ (concat (regexp-opt '("if" "while" "for" "switch")) "\\b[^_]")))
+
+(defconst c-class-scope-key "\\(class\\|struct\\|union\\)\\b[^_]")
+(defconst c-namespace-scope-key "namespace\\b[^_]")
+(defconst c-scope-key "\\(class\\|struct\\|union\\|namespace\\)");\\b[^_]")
+(defconst c-struct-scope-key "struct\\b[^_]")
+(defconst c-template-key "template\\b[^_]")
+(defconst c-operator-key "operator\\b[^_]")
+(defconst c-operator-operators nil)
+(defconst c-typedef-key "typedef\\b[^_]")
+(defconst c-friend-key "friend\\b[^_]")
+(defconst c-access-key "\\(public\\|protected\\|private\\)\\s-*:")
+(defconst c-access-keys
+ '(("public\\s-*:" . public)
+ ("protected\\s-*:" . protected)
+ ("private\\s-*:" . private)))
+(defconst c-inheritance-spec-key "\\(public\\|protected\\|private\\|virtual\\)\\b[^_]")
+
+(let ((assable '("+" "-" "*" "/" "%" "^" "&" "|" "~" "!" "=" "<" ">" ">>" "<<"))
+ (others '("&&" "||" "++" "--" "->*" "," "->" "[]" "()" "new" "new[]"
+ "delete" "delete[]" "bool")))
+ (setq c-operator-operators
+ (regexp-opt (nconc (mapcar (function (lambda (x) (concat x "=")))
+ assable)
+ assable others) t)))
+
+(defconst c-operator-word
+ (concat "operator\\s-*" c-operator-operators))
+
+(defconst c-skip-syntaxes '(? ?. ?'))
+
+;;; Code:
+
+(require 'cl)
+(require 'cc-engine)
+(require 'cc-langs)
+(require 'cc-defs)
+
+(defmacro c-with-temporary-syntax-table (table &rest body)
+ ;; evaluate BODY temporarily binding the syntax table to TABLE
+ (let ((saved-syntax-table (make-symbol "saved-syntax-table")))
+ `(let ((,saved-syntax-table (syntax-table)))
+ (unwind-protect
+ (progn
+ (set-syntax-table ,table)
+ ,@body)
+ (set-syntax-table ,saved-syntax-table)))))
+
+(def-edebug-spec c-with-temporary-syntax-table (sexp body))
+(put 'c-with-temporary-syntax-table 'lisp-indent-function 1)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; moving by syntactic entities
+
+(defun c-skip-non-sexp-chars-forward ()
+ ;; skip char's not considered part of sexps forward
+ (c-forward-syntactic-ws)
+ (while (and (not (eq (following-char) ?<))
+ (memq (char-syntax (following-char)) c-skip-syntaxes)
+ (not (eobp)))
+ (forward-char 1)
+ (c-forward-syntactic-ws)))
+
+(defun c-skip-non-sexp-chars-backward ()
+ ;; skip char's not considered part of sexps backward
+ (c-backward-syntactic-ws)
+ (while (and (not (eq (preceding-char) ?>))
+ (memq (char-syntax (preceding-char)) c-skip-syntaxes)
+ (not (bobp)))
+ (forward-char -1)
+ (c-backward-syntactic-ws)))
+
+;; support for teplate arglists
+
+(defun c-forward-template-arglist ()
+ ;; skip forward over the <> delimited template arglist at
+ ;; point. This temporarily changes the syntax-table to include <> as
+ ;; matching delimiters and uses c-forward-sexp
+ (c-skip-non-sexp-chars-forward)
+ (if (not (eq (following-char) ?<))
+ (c-forward-sexp)
+ (let ((level 1))
+ (forward-char 1)
+ (while (and (> level 0)
+ (re-search-forward "[[({<>]" nil t))
+ (if (not (c-in-literal))
+ (cond ((memq (preceding-char) '(?\[ ?\( ?{))
+ (up-list 1))
+
+ ((eq (preceding-char) ?<)
+ (setq level (1+ level)))
+
+ ((eq (preceding-char) ?>)
+ (setq level (1- level)))))))))
+
+(defun c-backward-template-arglist ()
+ ;; reverse of c-forward-template-arglist
+ (c-skip-non-sexp-chars-backward)
+ (if (not (eq (preceding-char) ?>))
+ (c-backward-sexp)
+ (let ((level 1))
+ (forward-char -1)
+ (while (and (> level 0)
+ (re-search-backward "[])}<>]" nil t))
+ (if (not (c-in-literal))
+ (cond ((memq (following-char) '(?\] ?\) ?}))
+ (up-list -1))
+
+ ((eq (following-char) ?>)
+ (setq level (1+ level)))
+
+ ((eq (following-char) ?<)
+ (setq level (1- level)))))))))
+
+(defsubst c-at-symbol-p ()
+ (memq (char-syntax (following-char)) '(?w ?_)))
+
+(defsubst c-after-symbol-p ()
+ (memq (char-syntax (preceding-char)) '(?w ?_)))
+
+(defun c-forward-extended-sexp ()
+ ;; Move forward one sexp. This function tries to correctly skip
+ ;; template argument lists delimited by angle brackets.
+ (c-skip-non-sexp-chars-forward)
+ (if (and (eq (following-char) ?<)
+ (condition-case nil
+ (let ((start (point)))
+ (c-forward-template-arglist)
+ (if (or (not (eq (preceding-char) ?>))
+ (c-crosses-statement-barrier-p start (point)))
+ (progn (goto-char start) nil) t))
+ (error nil)))
+ nil
+ (c-forward-sexp)))
+
+(defun c-backward-extended-sexp ()
+ ;; reverse of c-forward-extenden-sexp
+ (c-skip-non-sexp-chars-backward)
+ (if (and (eq (preceding-char) ?>)
+ (condition-case nil
+ (let ((start (point)))
+ (c-backward-template-arglist)
+ (if (or (not (eq (following-char) ?<))
+ (c-crosses-statement-barrier-p (point) start))
+ (progn (goto-char start) nil) t))
+ (error nil)))
+ nil
+ (c-backward-sexp)))
+
+;; names
+
+(defun c-forward-scoped-name ()
+ ;; skip forward over a possibly fully scoped name at point
+ ;; optionally containing template arglists. return list of scope
+ ;; separators in the name
+ (c-forward-syntactic-ws)
+ (let (points)
+ (while
+ (progn
+ (setq points (cons (point) points))
+ (if (looking-at "::")
+ (forward-char 2))
+ (c-forward-syntactic-ws)
+ (if (and (cond ((looking-at c-operator-word)
+ (goto-char (match-end 0)))
+ ((looking-at "~")
+ (forward-char 1)
+ (prog1
+ (c-at-symbol-p)
+ (c-forward-token-1)))
+ (t
+ (prog1
+ (c-at-symbol-p)
+ (c-forward-token-1))))
+ (eq (following-char) ?<))
+ (progn
+ (c-forward-template-arglist)
+ (c-forward-syntactic-ws)))
+ (looking-at "::")))
+ (nreverse points)))
+
+(defun c-backward-scoped-name ()
+ ;; reverse of c-forward-scoped-name
+ (c-backward-syntactic-ws)
+ (while
+ (progn
+ (if (and (eq (preceding-char) ?>)
+ (not (save-excursion
+ (re-search-backward (concat c-operator-word "\\=") nil t))))
+ (c-backward-template-arglist))
+ (c-backward-syntactic-ws)
+ (if (re-search-backward (concat c-operator-word "\\=") nil t)
+ (goto-char (match-beginning 0))
+ (c-backward-token-1)
+ (if (and (c-at-symbol-p)
+ (eq (preceding-char) ?~))
+ (forward-char -1)))
+ (c-backward-syntactic-ws)
+ (if (eq (preceding-char) ?:)
+ (progn
+ (forward-char -1)
+ (if (eq (preceding-char) ?:)
+ (progn
+ (forward-char -1)
+ (c-backward-syntactic-ws)
+ t)
+ (forward-char 1)
+ nil)))))
+ (c-forward-syntactic-ws))
+
+(defun c-forward-balanced-token ()
+ (c-forward-syntactic-ws)
+ (cond ((or (c-at-symbol-p)
+ (looking-at c-operator-word))
+ (c-forward-scoped-name))
+ ((memq (following-char) '(?\( ?{ ?<))
+ (c-forward-extended-sexp))
+ (t
+ (c-forward-token-1))))
+
+(defun c-backward-balanced-token ()
+ (c-backward-syntactic-ws)
+ (cond ((or (c-after-symbol-p)
+ (re-search-backward (concat c-operator-word "\\=") nil t))
+ (c-backward-scoped-name))
+ ((memq (preceding-char) '(?\) ?} ?>))
+ (c-backward-extended-sexp))
+ (t
+ (c-backward-token-1))))
+
+;; defun's
+
+(defun c-move-to-start-of-defun (&optional limit)
+ ;; move point to start of current defun. point is left at the start
+ ;; of the function's name. Use (c-beginning-of-statement-1) to get
+ ;; to the start of the declaration. returns point of body's opening
+ ;; brace if defun found, otherwise nil. if LIMIT is non-nil, don't
+ ;; move farther back than that.
+ (let (new-point brace-point)
+ (save-excursion
+ (while
+ (and (c-save-uplist -1)
+ (or (not limit)
+ (> (point) limit))
+ (not (setq new-point
+ (if (and (eq (following-char) ?{)
+ (c-just-after-func-arglist-p))
+ (progn
+ (setq brace-point (point))
+ (c-beginning-of-statement-1)
+ (while (and (< (point) brace-point)
+ (not (eq (following-char) ?\()))
+ (c-forward-extended-sexp)
+ (c-forward-syntactic-ws))
+ (if (eq (following-char) ?\()
+ (progn
+ (c-backward-syntactic-ws)
+ (c-backward-scoped-name)
+ (if (not (looking-at c-conditional-key))
+ (point)))))))))))
+ (if new-point
+ (goto-char new-point))
+ (and new-point brace-point)))
+
+(defun c-beginning-of-defun-or-decl ()
+ (c-move-to-start-of-defun)
+ (let ((point (point)) beg)
+ (c-beginning-of-statement-1)
+ (setq beg (point))
+ (c-end-of-statement-1)
+ (if (> (point) point)
+ (goto-char beg)
+ (goto-char point))
+ (c-forward-syntactic-ws)))
+
+(defun c-forward-out-of-comment ()
+ (while (memq (c-in-literal) '(c c++))
+ (forward-char 1)))
+
+(defun c-beginning-of-statement-2 ()
+ ;; Move to the REAL beginning of the statement, ignoring all subexpressions
+ (let ((point (point))
+ (state (c-parse-state))
+ (last (point)))
+ (while (and state
+ (not (consp (car state)))
+ (progn
+ (goto-char (car state))
+ (looking-at "(")))
+ (setq last (car state)
+ state (cdr state)))
+ (if (and state last
+ (not (consp (car state))))
+ (goto-char last))
+ (c-beginning-of-statement-1)
+ (while (and (< (point) point)
+ (or (c-crosses-statement-barrier-p (point) point)
+ (not (equal (c-parse-state) state))))
+ (c-end-of-statement-1))
+ (c-forward-syntactic-ws)
+ (while (looking-at c-any-key)
+ (if (looking-at c-blocking-key)
+ (progn
+ (c-forward-token-1)
+ (c-forward-sexp))
+ (c-forward-token-1))
+ (c-forward-syntactic-ws))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; information on scopes (nesting levels)
+
+(defun c-aggressive-search-uplist-for-classkey ()
+ ;; like search-uplist-for-classkey but agressively retry at all
+ ;; scoping levels until classkey found
+ (save-excursion
+ (let (state)
+ (loop for state = (c-parse-state)
+ while state
+ thereis (loop for substate on state
+ thereis (c-search-uplist-for-classkey substate))
+ for elt = (car (last state))
+ do (goto-char (if (consp elt) (car elt) elt))))))
+
+(defun c-search-uplist-for-scopekey (state)
+ (let ((c-class-key c-scope-key))
+ (c-search-uplist-for-classkey state)))
+
+(defun c-aggressive-search-uplist-for-scopekey ()
+ (let ((c-class-key c-scope-key))
+ (c-aggressive-search-uplist-for-classkey)))
+
+(defun c-save-uplist (arg)
+ ;; like up-list but return nil on error
+ (condition-case nil
+ (progn
+ (up-list arg)
+ (point))
+ (scan-error nil)))
+
+(defun c-full-parse-state ()
+ ;; return the complete parse-state from the beginning of buffer up
+ ;; to (point)
+ (save-excursion
+ (let (state s elt)
+ (while (setq s (c-parse-state)
+ elt (car (last s)))
+ (goto-char (if (consp elt) (car elt) elt))
+ (setq state (nconc state s)))
+ state)))
+
+(defun c-get-block-scope ()
+ ;; return a list of scoping levels for point. Every scoping level is
+ ;; identified by thier 'class for a class scope, or 'namespace for a
+ ;; namespace scope For 'class and 'struct scopes, optional template
+ ;; declarations are returned.
+ (save-excursion
+ (let (key element keys)
+ (while (setq key (c-aggressive-search-uplist-for-scopekey))
+ (goto-char (aref key 0))
+ (setq element (vector nil
+ (aref key 0)
+ (aref key 1)
+ nil))
+ (cond ((looking-at c-class-scope-key)
+ (aset element 0 'class)
+ (c-backward-syntactic-ws)
+ (if (eq (preceding-char) ?>)
+ ;; this is a templated class/struct declaration
+ (save-excursion
+ (c-backward-template-arglist)
+ (c-backward-token-1)
+ (if (looking-at c-template-key)
+ (aset element 3 (point))))))
+
+ ((looking-at c-namespace-scope-key)
+ (aset element 0 'namespace)))
+
+ (if (aref element 0)
+ (setq keys (cons element keys))))
+ keys)))
+
+(defun c-get-scope ()
+ ;; This is like c-get-block-scope. Additionaly, if in a function
+ ;; declaration or definition this will add a 'defun entry at the
+ ;; end detailing the function information (and having an optional
+ ;; template spec). The start of the function entry is the first char
+ ;; of the functions typespec, the last char is just after the
+ ;; closing paren of the function defn or decl.
+ (let ((scope (c-get-block-scope)))
+ (save-excursion
+ (if (c-move-to-start-of-defun (and scope (aref (car (last scope)) 1)))
+ (let ((element (vector 'defun (point) nil nil)))
+ (c-forward-scoped-name)
+ (aset element 2 (point))
+ (c-beginning-of-statement-1)
+ (if (looking-at c-template-key)
+ (aset element 3 (point)))
+ (nconc scope (list element)))
+ scope))))
+
+(defun c-scope-name (p &optional strip)
+ ;; return the name of the scope at P. if STRIP is non-nil, strip
+ ;; that many elements from the name
+ (save-excursion
+ (goto-char p)
+ (if (looking-at c-scope-key)
+ (c-forward-token-1))
+ (let ((points (c-forward-scoped-name)))
+ (c-backward-syntactic-ws)
+ (buffer-substring-no-properties (car points)
+ (or (and strip (> strip 0)
+ (or (and (<= strip (length points))
+ (car
+ (last
+ (nbutlast points
+ (1- strip)))))
+ (car points)))
+ (point))))))
+
+(defun c-get-class-at-point ()
+ ;; Return block scope for class at point.
+ (save-excursion
+ (c-forward-syntactic-ws)
+ (while (looking-at c-template-key)
+ (goto-char (match-end 0))
+ (c-forward-extended-sexp)
+ (c-forward-syntactic-ws))
+ (and (looking-at c-class-scope-key)
+ (search-forward "{" nil t))
+ (last (c-get-block-scope))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; template functions
+
+(defun c-parse-template-declaration ()
+ ;; parse the template declaration at point. return a list of
+ ;; cons'es of argument def ranges.
+ (save-excursion
+ (if (looking-at c-template-key)
+ (c-forward-token-1)
+ (c-forward-syntactic-ws))
+ (if (eq (following-char) ?<)
+ (c-parse-arglist (point)
+ (progn (c-forward-template-arglist) (point))))))
+
+(defun c-parse-arglist (start end)
+ ;; parse arglist between START and END. The region between START end
+ ;; END must include the delimiteres (parens or angle brackets) even
+ ;; though theese delimiters are completely ignored
+ (setq end (1- end))
+ (let (args arg-start)
+ (save-excursion
+ (goto-char start)
+ (while (and (not (eobp))
+ (< (point) end))
+ (forward-char 1)
+ (c-forward-syntactic-ws)
+ (setq arg-start (point))
+ (condition-case nil
+ (while (progn
+ (c-forward-extended-sexp)
+ (and (not (eobp))
+ (< (point) end)
+ (not (eq (following-char) ?,)))))
+ (scan-error nil))
+ (save-excursion
+ (c-backward-syntactic-ws)
+ (if (> (point) end)
+ (goto-char end))
+ (if (> (point) arg-start)
+ (setq args (cons (cons arg-start (point))
+ args))))))
+ (nreverse args)))
+
+(defun c-move-to-template-argument (start end)
+ ;; move to the template argument name within the template argument
+ ;; between START and END
+ (if (c-move-to-initializer start end)
+ (forward-char -1)
+ (goto-char end))
+ (while (and (>= (point) start)
+ (not (c-at-symbol-p))
+ (not (bobp)))
+ (c-backward-extended-sexp))
+ (c-at-symbol-p))
+
+(defun c-get-template-argument-name (start end)
+ ;; get the argument name of the template argument defined between
+ ;; START and END
+ (save-excursion
+ (c-move-to-template-argument start end)
+ (buffer-substring-no-properties (point)
+ (progn
+ (c-forward-token-1)
+ (c-backward-syntactic-ws)
+ (point)))))
+
+(defun c-get-template-prefix (args)
+ ;; return the template prefix for the template declared with
+ ;; arguments ARGS
+ (concat "<"
+ (mapconcat (function (lambda (x)
+ (c-get-template-argument-name (car x) (cdr x))))
+ args
+ ",")
+ ">"))
+
+(defun c-is-template-id (p)
+ ;; return t if scoped name at P is a template_id
+ (save-excursion
+ (goto-char p)
+ (if (looking-at c-scope-key)
+ (c-forward-token-1))
+ (c-forward-scoped-name)
+ (c-backward-syntactic-ws)
+ (eq (preceding-char) ?>)))
+
+(defun c-move-to-initializer (start end)
+ ;; move point to the initializer for the argument declared between
+ ;; START and END. return t if initializer found, otherwise nil. if
+ ;; no initializer is found, point is left at START
+ (goto-char start)
+ (search-forward "=" end t))
+
+(defun c-get-templates (scope)
+ ;; return list of ranges of template specs in SCOPE
+ (loop for level in scope
+ if (aref level 3)
+ collect (progn
+ (goto-char (aref level 3))
+ (c-forward-token-1)
+ (c-forward-template-arglist)
+ (c-backward-syntactic-ws)
+ (cons (aref level 3) (point)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; functions to parse defuns
+
+(defun c-get-full-prefix (scope &optional strip)
+ ;; return the full prefix for scope. if STRIP is non-nil, strip the
+ ;; name of the current method, if any.
+ (save-excursion
+ (loop with last-p = (last scope)
+ for elem-p on scope
+ for elem = (car elem-p)
+ for next = nil then t
+ for last = (eq elem-p last-p)
+ if (and last strip (eq (aref elem 0) 'defun))
+ concat (let ((name (c-scope-name (aref elem 1) 1)))
+ (if (> (length name) 0)
+ (concat (if next "::" "") name) ""))
+ else
+ concat (concat (if next "::" "")
+ (c-scope-name (aref elem 1))
+ (if (and (aref elem 3)
+ (not (c-is-template-id (aref elem 1))))
+ (progn
+ (goto-char (aref elem 3))
+ (c-get-template-prefix
+ (c-parse-template-declaration)))
+ "")))))
+
+(defun c-parse-defun ()
+ ;; parse function definition or declaration at point. Returns a vector
+ ;; of positions: [template type name arglist modifiers initializers body end]
+ (save-excursion
+ (c-beginning-of-defun-or-decl)
+ (let (template type name arglist modifiers initializers body end)
+ (if (looking-at c-template-key)
+ (progn
+ (setq template (point))
+ (while (looking-at c-template-key)
+ (c-forward-token-1)
+ (c-forward-template-arglist)
+ (c-forward-syntactic-ws))))
+ (setq type (point))
+ (while (not (or (eq (following-char) ?\()
+ (c-crosses-statement-barrier-p type (point))))
+ (c-forward-balanced-token)
+ (c-forward-syntactic-ws))
+ (save-excursion
+ (c-backward-scoped-name)
+ (setq name (point))
+ (if (eq name type)
+ (setq type nil)))
+ (setq arglist (point))
+ (c-forward-sexp)
+ (c-forward-syntactic-ws)
+ (if (not (memq (following-char) '(?{ ?\; ?:)))
+ (progn
+ (setq modifiers (point))
+ (while (not (or (memq (following-char) '(?{ ?\; ?:))
+ (c-crosses-statement-barrier-p modifiers (point))
+ (eobp)))
+ (c-forward-extended-sexp)
+ (c-forward-syntactic-ws))))
+ (if (eq (following-char) ?:)
+ (progn
+ (setq initializers (point))
+ (while (not (or (memq (following-char) '(?{ ?\;))
+ (c-crosses-statement-barrier-p modifiers (point))))
+ (c-forward-extended-sexp)
+ (c-forward-syntactic-ws))))
+ (if (eq (following-char) ?{)
+ (progn
+ (setq body (point))
+ (c-forward-sexp)))
+ (setq end (point))
+ (vector template type name arglist modifiers initializers body end))))
+
+(defun c-get-defun-state ()
+ ;; this extends c-parse-defun. it returns a vector containing the
+ ;; following items:
+ ;; o templates: a list of cons'es each containing the range of a
+ ;; template specification
+ ;; o type: a cons containing the range for the return type
+ ;; specification of the function
+ ;; o name: a cons containing the range for the functions name
+ ;; o args: a list of cons'es, each containing the range of a
+ ;; function argument
+ ;; o modifiers: a cons containing the range of the modifiers
+ ;; o initializers: a list of cons'es each containing the range of
+ ;; an initializer
+ ;; o body: a cons containing the range for the body or nil, if no
+ ;; body
+ ;; o prototype: nil, if body is non-nil, otherwise the end of the
+ ;; prototype.
+ ;; o scope: the scope structure (as returned by c-get-block-scope)
+ ;; for this function
+ (save-excursion
+ (let ((defun (c-parse-defun))
+ (scope (c-get-block-scope))
+ templates type name args modifiers initializers body prototype)
+ (setq templates (c-get-templates scope))
+ (if (aref defun 0)
+ (progn
+ (goto-char (aref defun 0))
+ (while (looking-at c-template-key)
+ (setq templates (nconc templates
+ (list (cons (point)
+ (progn
+ (c-forward-token-1)
+ (c-forward-template-arglist)
+ (c-backward-syntactic-ws)
+ (point))))))
+ (c-forward-syntactic-ws))))
+ (if (aref defun 1)
+ (progn
+ (goto-char (aref defun 2))
+ (c-backward-syntactic-ws)
+ (setq type (cons (aref defun 1) (point)))))
+ (goto-char (aref defun 3))
+ (c-backward-syntactic-ws)
+ (setq name (cons (aref defun 2) (point)))
+ (goto-char (aref defun 3))
+ (let ((start (point)))
+ (c-forward-sexp)
+ (setq args (c-parse-arglist start (point))))
+ (if (aref defun 4)
+ (progn
+ (goto-char (or (aref defun 5) (aref defun 6) (aref defun 7)))
+ (c-backward-syntactic-ws)
+ (setq modifiers (cons (aref defun 4) (point)))))
+ (if (aref defun 5)
+ (setq initializers (c-parse-arglist (aref defun 5)
+ (1+ (or (aref defun 6)
+ (aref defun 7))))))
+ (if (aref defun 6)
+ (setq body (cons (aref defun 6) (aref defun 7))))
+ (if (not body)
+ (setq prototype (1+ (aref defun 7))))
+ (vector templates type name args modifiers
+ initializers body prototype scope))))
+
+(defun c-defun-full-name (state)
+ ;; return the full name of the defun in state
+ (string-replace "[ \t\n\r]+" ""
+ (concat (c-get-full-prefix (aref state 8))
+ (if (aref state 8) "::" "")
+ (buffer-substring-no-properties (car (aref state 2))
+ (cdr (aref state 2))))
+ t))
+
+(defun c-defun-short-name (state)
+ ;; return the short name of the defun in state. This is the name of the defun
+ ;; without template args or namespace/class prefix
+ (let (p)
+ (save-excursion
+ (goto-char (cdr (aref state 2)))
+ (if (and (eq (preceding-char) ?>)
+ (not (save-excursion
+ (re-search-forward (concat c-operator-word "\\=") nil t))))
+ (c-backward-template-arglist))
+ (c-backward-syntactic-ws)
+ (setq p (point))
+ (if (re-search-backward (concat c-operator-word "\\=") nil t)
+ (goto-char (match-beginning 0))
+ (c-backward-token-1)
+ (if (and (c-at-symbol-p)
+ (eq (preceding-char) ?~))
+ (forward-char -1)))
+ (buffer-substring-no-properties p (point)))))
+
+(defun c-goto-beginning-of-defun (defun)
+ (goto-char (or (car (aref defun 1))
+ (car (aref defun 2))))
+ (loop for point = (point)
+ for tmpl in (reverse (aref defun 0))
+ do (c-backward-syntactic-ws)
+ while (= (cdr tmpl) (point))
+ do (progn
+ (goto-char (car tmpl))
+ (setq point (point)))
+ finally do (goto-char point)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; functions to parse classes
+
+(defun c-parse-class (scope)
+ ;; parse class at point. returns vector of positions: [template
+ ;; class bases start ( members )] each member is a cons ( type
+ ;; . start ) where type is one of 'typedef 'class 'friend 'variable
+ ;; 'method or 'combo (combo is a combinded struct/class/union +
+ ;; variable declaration)
+ (save-excursion
+ (let ((scope (car (last scope)))
+ end template class bases start members)
+ (if (not (eq (aref scope 0) 'class))
+ nil
+ (setq template (aref scope 3))
+ (setq class (aref scope 1))
+ (setq start (aref scope 2))
+ (goto-char start)
+ (while (and (< (skip-chars-backward "^:" class) 0)
+ (or (progn
+ (forward-char -1)
+ (and (eq (char-before) ?:) (progn (forward-char -1) t)))
+ (c-in-literal))))
+ (if (eq (following-char) ?:)
+ (progn
+ (forward-char 1)
+ (c-forward-syntactic-ws)
+ (setq bases (point))))
+ (goto-char start)
+ (save-excursion
+ (c-forward-sexp)
+ (setq end (point)))
+ (forward-char 1)
+ (while (progn (c-end-of-statement-1)
+ (< (point) end))
+ (let ((bc (char-before))
+ (this (point)))
+ (if (eq bc ?{)
+ (save-excursion
+ (forward-char -1)
+ (c-forward-sexp)
+ (setq this (point))))
+ (if (or (eq bc ?\;) (eq bc ?{))
+ (progn
+ (forward-char -1)
+ (if (re-search-backward "=\\s-*0\\s-*\\=" start t)
+ (goto-char (match-beginning 0)))
+ (if (c-just-after-func-arglist-p)
+ ;; OK. It's a method (defn or decl)
+ (progn
+ (c-beginning-of-statement-1)
+ (setq members (cons (cons 'method (point))
+ members)))
+ (if (eq bc ?{)
+ ;; this should be a class or struct decl. Maybe
+ ;; a variable.
+ (let (pos decl beg)
+ (setq pos (point))
+ (c-beginning-of-statement-1)
+ (setq beg (point))
+ (if (looking-at c-class-scope-key)
+ ;; it really IS a class/struct/union
+ (progn
+ (goto-char (match-end 0))
+ (c-forward-syntactic-ws)
+ (setq decl (looking-at "[a-zA-Z_]"))
+ (goto-char pos)
+ (c-forward-sexp)
+ (c-forward-syntactic-ws)
+ (if (eq (following-char) ?\;)
+ ;; no variable defn
+ (if decl
+ (setq members (cons (cons 'class beg)
+ members)))
+ (save-excursion
+ (goto-char this)
+ (c-end-of-statement-1)
+ (setq this (point)))
+ (setq members (cons (cons (if decl 'combo 'variable)
+ beg)
+ members))))))
+ ;; then it's a variable decl or typedef or friend
+ (c-beginning-of-statement-1)
+ (cond ((looking-at c-typedef-key)
+ (setq members (cons (cons 'typedef (point)) members)))
+ ((looking-at c-friend-key)
+ (setq members (cons (cons 'friend (point)) members)))
+ (t
+ (setq members (cons (cons 'variable (point)) members))))
+ ))))
+ (goto-char this)))
+ (vector template class bases start (nreverse members))))))
+
+(defun c-current-access-level ()
+ ;; returm current access level: 'public, 'protected or 'private
+ (save-excursion
+ (let ((scope (car (last (c-get-block-scope)))))
+ (while (and (re-search-backward c-access-key (aref scope 2) t)
+ (or (c-in-literal)
+ (not (eq (aref (car (c-get-block-scope)) 1) (aref scope 1))))))
+ (loop for (re . sym) in c-access-keys
+ if (looking-at re)
+ return sym
+ finally return (progn
+ (goto-char (aref scope 1))
+ (if (looking-at c-struct-scope-key)
+ 'public
+ 'private))))))
+
+(defun c-get-variable-members (class)
+ ;; return list of names of all variables of CLASS
+ (save-excursion
+ (loop for (type . pos) in (aref class 4)
+ for end = (progn (goto-char pos) (c-end-of-statement-1) (1- (point)))
+ if (or (eq type 'variable) (eq type 'combo))
+ collect (c-get-template-argument-name pos end))))
+
+(defun c-get-variable-members-with-type (class)
+ ;; return list of conses of (name . type) of all variables of CLASS
+ (save-excursion
+ (loop for (type . pos) in (aref class 4)
+ for end = (progn (goto-char pos) (c-end-of-statement-1) (1- (point)))
+ if (eq type 'variable)
+ collect (c-get-variable-with-type pos end))))
+
+(defun c-get-variable-with-type (start end)
+ (c-move-to-template-argument start end)
+ (let ((arg (save-excursion
+ (buffer-substring-no-properties (point)
+ (progn
+ (c-forward-token-1)
+ (c-backward-syntactic-ws)
+ (point))))))
+ (c-backward-syntactic-ws)
+ (cons arg (buffer-substring-no-properties start (point)))))
+
+(defun c-get-base-classes (class)
+ ;; return list of base class names (including template specs)
+ (and (aref class 2)
+ (save-excursion
+ (goto-char (aref class 2))
+ (loop while (< (point) (aref class 3))
+ do (progn (c-forward-syntactic-ws)
+ (while (looking-at c-inheritance-spec-key)
+ (c-forward-token-1)
+ (c-forward-syntactic-ws)))
+ for start = (point)
+ do (progn (c-forward-scoped-name) (c-backward-syntactic-ws))
+ collect (buffer-substring-no-properties start (point))
+ do (progn
+ (while (and (> (skip-chars-forward "^," (aref class 3)) 0)
+ (c-in-literal))
+ (forward-char 1))
+ (forward-char 1))))))
+
+(provide 'cc-engine-2)
+
+\f
+;;; Local Variables:
+;;; elisp-project-autoload-file-name: "cc-autoload.el"
+;;; End:
--- /dev/null
+;;; cc-helper.el --- helper and generator functions for C++
+;;
+;; $Id$
+;;
+;; Copyright (C) 2000 Stefan Bund
+
+;; cc-helper.el 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 2, or (at
+;; your option) any later version.
+
+;; cc-helper.el 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.
+
+;;; Commentary:
+
+;;; Change-Log:
+
+;; $Log$
+;;
+
+;;; Variables:
+
+(defvar c-max-def-column 95
+ "*Maximum length of generated argdef lines")
+
+(defconst c-special-key "\\(static\\|virtual\\|friend\\|explicit\\)\\b")
+
+;;; Code:
+
+(require 'cc-engine-2)
+(require 'cc-vars)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; generators (functions generating new sourcecode)
+
+(defun c-kill-special-keywords ()
+ ;; kill all keywords in c-special-key directly after point
+ (c-forward-syntactic-ws)
+ (while (looking-at c-special-key)
+ (delete-region (point) (match-end 1))
+ (delete-region (point) (progn (c-forward-syntactic-ws) (point)))))
+
+(defun c-build-template-specs (templates cbuf)
+ ;; build temlate specs for TEMPLATES
+ (loop for template in templates
+ do (insert
+ (save-excursion
+ (set-buffer cbuf)
+ (save-excursion
+ (goto-char (car template))
+ (concat "template <"
+ (loop for arg in (c-parse-template-declaration)
+ for sep = "" then ", "
+ concat sep
+ concat (progn
+ (buffer-substring-no-properties
+ (car arg) (if (c-move-to-initializer
+ (car arg) (cdr arg))
+ (progn
+ (forward-char -1)
+ (c-backward-syntactic-ws)
+ (point))
+ (cdr arg)))))
+ ">"))))
+ do (insert "\n")))
+
+(defun c-build-defun (&optional add-words no-kill)
+ ;; build a function definition header for the current defun. if
+ ;; ADD-WORDS is non-nil, it is prepended to the definition header
+ ;; after any template specifications. the return value is a cons of
+ ;; the name of the function and the complete text of the header.
+ ;; c-build-defun tries hard to keep the with of the declaration
+ ;; below c-max-def-column
+ (save-excursion
+ (c-beginning-of-defun-or-decl)
+ (let* ((tbuf (get-buffer-create " *cc-temp-buffer*"))
+ (state (c-get-defun-state))
+ (prefix (c-get-full-prefix (aref state 8)))
+ (cbuf (current-buffer))
+ p1 p2 p3 c maxc fname)
+ (set-buffer tbuf)
+ (erase-buffer)
+ (c-build-template-specs (aref state 0) cbuf)
+ (if (aref state 1)
+ (progn
+ (insert-buffer-substring cbuf (car (aref state 1)) (cdr (aref state 1)))
+ (if (not no-kill)
+ (progn
+ (beginning-of-line)
+ (c-kill-special-keywords)
+ (goto-char (point-max))))
+ (insert " ")))
+ (if add-words
+ (progn
+ (beginning-of-line)
+ (insert add-words " ")
+ (goto-char (point-max))))
+ (setq p1 (point))
+ (insert prefix)
+ (if (> (length prefix) 0)
+ (progn
+ (insert "::")
+ (setq p2 (point))))
+ (save-excursion
+ (insert-buffer-substring cbuf (car (aref state 2)) (cdr (aref state 2))))
+ (save-excursion
+ (while (re-search-forward "\\s-+" nil t)
+ (replace-match "")))
+ (if (not p2)
+ (progn
+ (c-with-temporary-syntax-table c-mode-syntax-table
+ (setq p2 (car (last (c-forward-scoped-name))))
+ (if p2
+ (setq p2 (+ p2 2))))))
+ (goto-char (point-max))
+ (setq fname (buffer-substring-no-properties p1 (point)))
+ (if (> (current-column) c-max-def-column)
+ (progn
+ (goto-char p1)
+ (delete-char -1)
+ (insert "\n")
+ (end-of-line)
+ (setq p1 nil)))
+ (insert "(")
+ (setq p3 (point))
+ (setq c (current-column)
+ maxc 0)
+ (insert "\n")
+ (loop for arg in (aref state 3)
+ for next = nil then t
+ if next do (insert ",\n")
+ do (progn
+ (save-excursion
+ (insert-buffer-substring cbuf (car arg) (cdr arg)))
+ (save-excursion
+ (if (search-forward "=" nil t)
+ (progn
+ (forward-char -1)
+ (c-backward-syntactic-ws)
+ (forward-char 1)
+ (delete-region (1- (point)) (progn (end-of-line) (point))))))
+ (replace-regexp "\\s-+" " ")
+ (end-of-line)
+ (let ((cc (current-column)))
+ (if (> cc maxc)
+ (setq maxc cc)))))
+ (if (> (+ c maxc) c-max-def-column)
+ (progn
+ (if (and p1
+ (progn
+ (goto-char p1)
+ (> (1- (current-column))
+ (- (+ c maxc) c-max-def-column))))
+ (progn
+ (delete-char -1)
+ (insert "\n"))
+ (if p2
+ (progn
+ (goto-char p2)
+ (insert "\n")
+ (setq p3 (1+ p3)))))))
+ (goto-char p3)
+ (setq c (current-column))
+ (loop for next = nil then t
+ for p = (point)
+ while (not (eobp))
+ do (progn
+ (if next (insert " "))
+ (delete-char 1)
+ (end-of-line)
+ (if (and next (> (current-column) c-max-def-column))
+ (progn
+ (goto-char p)
+ (delete-char 1)
+ (insert "\n" (make-string c ? ))
+ (end-of-line)))))
+ (insert ")")
+ (if (aref state 4)
+ (progn
+ (insert "\n ")
+ (save-excursion
+ (insert-buffer-substring cbuf (car (aref state 4)) (cdr (aref state 4))))
+ (replace-regexp "\\s-+" " ")
+ (end-of-line)))
+ (if (aref state 5)
+ (progn
+ (insert "\n : ")
+ (loop with first = t
+ for initializer in (aref state 5)
+ for next = nil then t
+ for p = (point)
+ do (progn
+ (if next (insert ", "))
+ (save-excursion
+ (insert-buffer-substring cbuf (car initializer)
+ (cdr initializer)))
+ (replace-regexp "\\s-+" " ")
+ (end-of-line)
+ (if (not first)
+ (if (> (current-column) c-max-def-column)
+ (progn
+ (goto-char (1+ p))
+ (delete-char 1)
+ (insert "\n ")
+ (setq first t)
+ (end-of-line)))
+ (setq first nil))))))
+ (prog1
+ (list fname
+ (buffer-substring-no-properties (point-min) (point-max))
+ state)
+ (kill-buffer tbuf)))))
+
+(defun c-build-create-constructor ()
+ (save-excursion
+ (c-beginning-of-defun-or-decl)
+ (let* ((tbuf (get-buffer-create " *cc-temp-buffer*"))
+ (cbuf (current-buffer))
+ (state (c-get-defun-state))
+ (indent (make-string (current-indentation) ? ))
+ (fname (buffer-substring-no-properties (car (aref state 2))
+ (cdr (aref state 2)))))
+ (set-buffer tbuf)
+ (if (aref state 1)
+ (error "Not a constructor"))
+ (insert indent "static ptr create(")
+ (let ((indent2 (make-string (current-column) ? ))
+ ml)
+ (save-excursion
+ (insert "\n")
+ (loop for arg in (aref state 3)
+ for next = nil then t
+ if next do (insert ",\n")
+ do (progn
+ (save-excursion
+ (insert-buffer-substring cbuf (car arg) (cdr arg)))
+ (replace-regexp "\\s-+" " ")
+ (end-of-line))))
+ (loop for next = nil then t
+ for p = (point)
+ while (not (eobp))
+ do (progn
+ (if next (insert " "))
+ (delete-char 1)
+ (end-of-line)
+ (if (and next (> (current-column) c-max-def-column))
+ (progn
+ (setq ml t)
+ (goto-char p)
+ (delete-char 1)
+ (insert "\n" indent2)
+ (end-of-line)))))
+ (insert ")");
+ (if (aref state 4)
+ (progn
+ (insert " ")
+ (let ((p (point)))
+ (save-excursion
+ (insert-buffer-substring cbuf
+ (car (aref state 4))
+ (cdr (aref state 4))))
+ (replace-regexp "\\s-+" " ")
+ (end-of-line)
+ (if (or ml (> (current-column) c-max-def-column))
+ (progn
+ (goto-char p)
+ (insert "\n" indent (make-string c-basic-offset ? ))
+ (end-of-line))))))
+ (insert ";\n"))
+ (prog1
+ (list "create"
+ (buffer-substring-no-properties (point-min) (point-max))
+ state)
+ (kill-buffer tbuf)))))
+
+(defun c-build-create-constructor-impl (&optional add-words no-kill)
+ (save-excursion
+ (let* ((proto (c-build-defun add-words no-kill))
+ (cbuf (current-buffer))
+ (tbuf (get-buffer-create " *cc-temp-buffer*"))
+ (indent (make-string c-basic-offset ? )))
+ (set-buffer tbuf)
+ (erase-buffer)
+ (insert (nth 1 proto) "\n{\n" indent "return ptr(new "
+ (save-excursion
+ (set-buffer cbuf)
+ (c-scope-name (aref (car (last (aref (nth 2 proto) 8))) 1)))
+ "(")
+ (let ((indent2 (make-string (current-column) ? )))
+ (save-excursion
+ (insert "\n")
+ (loop for arg in (aref (nth 2 proto) 3)
+ for next = nil then t
+ if next do (insert ",\n")
+ do (insert (save-excursion
+ (set-buffer cbuf)
+ (c-get-template-argument-name (car arg) (cdr arg))))))
+ (loop for next = nil then t
+ for p = (point)
+ while (not (eobp))
+ do (progn
+ (if next (insert " "))
+ (delete-char 1)
+ (end-of-line)
+ (if (and next (> (current-column) c-max-def-column))
+ (progn
+ (goto-char p)
+ (delete-char 1)
+ (insert "\n" indent2)
+ (end-of-line)))))
+ (insert "));\n}\n"))
+ (prog1
+ (list (car proto)
+ (buffer-substring-no-properties (point-min) (point-max))
+ (cdr proto))
+ (kill-buffer tbuf)))))
+
+(eval-when-compile (autoload 'ccide-reformat-defun "cc-ide"))
+
+(defun c-build-default-funcions-impl ()
+ (save-excursion
+ (let* ((scope (c-get-block-scope))
+ (templates (c-get-templates scope))
+ (prefix (c-get-full-prefix scope))
+ (class (c-parse-class scope))
+ (bases (c-get-base-classes class))
+ (variables (c-get-variable-members class))
+ (name (c-scope-name (aref (car (last scope)) 1)))
+ (in (make-string c-basic-offset ? ))
+ (cbuf (current-buffer))
+ (tbuf (get-buffer-create " *cc-temp-buffer-2*"))
+ template-specs)
+ (set-buffer tbuf)
+ (erase-buffer)
+ (c-build-template-specs templates cbuf)
+ (setq template-specs (buffer-substring (point-min) (point-max)))
+ (save-excursion
+ (insert "prefix_ " prefix "::" name "()\n")
+ (if ccide-gen-throw
+ (insert in "throw_(())\n"))
+ (insert "{}\n"
+ "\n"))
+ (ccide-reformat-defun)
+ (goto-char (point-max))
+ (insert template-specs)
+ (save-excursion
+ (insert "prefix_ " prefix "::" name "(const " name "& other)\n")
+ (if ccide-gen-throw
+ (insert in "throw_(())\n"))
+ (insert in ": "
+ (mapconcat (function (lambda (x) (concat x "(other)")))
+ bases ", ")
+ (if (and bases variables) ", " "")
+ (mapconcat (function (lambda (x) (concat x "(other." x ")")))
+ variables ", ")
+ "\n{}\n\n"))
+ (ccide-reformat-defun)
+ (goto-char (point-max))
+ (insert template-specs)
+ (save-excursion
+ (insert "prefix_ " prefix " & " prefix "::operator=(const "
+ name "& other)\n")
+ (if ccide-gen-throw
+ (insert in "throw_(())\n"))
+ (insert "{\n"
+ (mapconcat (function (lambda (x)
+ (concat in "*((" x "*)this) = other;\n")))
+ bases "")
+ (mapconcat (function (lambda (x)
+ (concat in x " = other." x ";\n")))
+ variables "")
+ in "return *this"
+ "}\n\n"))
+ (ccide-reformat-defun)
+ (goto-char (point-max))
+ (insert template-specs)
+ (save-excursion
+ (insert "prefix_ " prefix "::~" name "()\n{}\n"))
+ (ccide-reformat-defun)
+ (prog1
+ (list prefix
+ (buffer-substring-no-properties (point-min) (point-max)))
+ (kill-buffer tbuf)))))
+
+(provide 'cc-helper)
+
+\f
+;;; Local Variables:
+;;; elisp-project-autoload-file-name: "cc-autoload.el"
+;;; End:
--- /dev/null
+;;; cc-ide.el --- C++ IDE
+;;
+;; $Id$
+;;
+;; Copyright (C) 2000 Stefan Bund
+
+;; cc-ide.el 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 2, or (at your
+;; option) any later version.
+
+;; cc-ide.el 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.
+
+;;; Commentary:
+
+;;; Change-Log:
+
+;; $Log$
+;;
+
+;;; Variables:
+
+(defvar ccide-compile-opts "DEBUG=1"
+ "*Additional options to make command")
+
+(defvar ccide-file-vars nil)
+
+(defvar ccide-default-author "")
+(defvar ccide-default-copyright "")
+
+(defvar ccide-corba-skel-dir "")
+(defvar ccide-corba-idl-dir "")
+(defvar ccide-corba-idl-command "omniidl2 -w")
+
+(defvar c-user-prefixes '("inline" "static" "prefix_")
+ "*List of possible prefixes for function definitions.")
+
+(defvar ccide-default-prefix "prefix_"
+ "*Prefix added to every implementation header. Probably eiter empty or 'prefix_'")
+
+(defvar ccide-gen-throw nil
+ "*If non-nil, generate throw_ specs")
+
+(defconst c-user-prefix-re (regexp-opt c-user-prefixes t))
+
+(defconst ccide-doxy-tag-re
+ "\\\\(group\\|defgroup\\|see\\|author\\|version\\|id\\|since\\|returns?\\|throws\\|exception\\|raises\\|param\\|li\\|short\\|internal\\)\\b")
+
+(defconst ccide-special-extensions
+ '(".h" ".hh" ".mpp" ".ih" ".cc" ".cpp" ".ct" ".cti" ".cci"))
+
+(defconst ccide-implementation-extensions
+ '(".h" ".hh" ".ih" ".cc" ".cpp" ".ct" ".cti" ".cci"))
+
+(defconst ccide-class-defaults-word
+ "// \\(default\\|no\\|protected\\|private\\|disabled\\|my\\)")
+
+(defconst ccide-bindings
+ '(
+ ;; file level
+ ("fc" ccide-file-comment "File comment")
+ ("fs" ccide-syncronize-includes "Sync includes")
+ (nil nil separator)
+
+ ;; class level
+ ("cc" ccide-class-comment "Class comment")
+ ("cg" ccide-gen-class "Generate class")
+ ("cd" ccide-gen-class-defaults "Generate class defaults")
+ ("cD" ccide-gen-class-defaults-impl "Generate class defaults impl")
+
+ ("csd" ccide-set-class-defaults-default "Set class defaults comment" "Default")
+ ("csn" ccide-set-class-defaults-no "Set class defaults comment" "No")
+ ("csp" ccide-set-class-defaults-protected "Set class defaults comment" "Protected")
+ ("csr" ccide-set-class-defaults-private "Set class defaults comment" "Private")
+ ("csx" ccide-set-class-defaults-disabled "Set class defaults comment" "Disabled")
+ ("csm" ccide-set-class-defaults-my "Set class defaults comment" "My")
+
+ ("cS" ccide-gen-struct-constructors "Generate structure constructors")
+
+ ("ci" ccide-class-impl-comment "Generate class implemenation comment")
+
+ (nil nil separator)
+
+ ;; method level
+ ("mc" ccide-function-comment "Method comment")
+ ("mp" ccide-grab-prototype "Grab prototype")
+ ("mr" ccide-reformat-defun "Reformat defun")
+ ("mx" ccide-replace-defun "Replace defun")
+ ("mt" ccide-prefix-defun-type-with-class "Prefix defun type with class")
+ ("mn" ccide-prefix-defun-type-with-namespace "Prefix defun type with namespace")
+ ("mi" ccide-grab-inline-decl "Grab inline decl")
+ ("mA" ccide-grab-all-inlines "Grab ALL inline decls")
+ ("mC" ccide-grab-create-constructor "Grab CREATE constructor")
+ ("mI" ccide-grab-create-constructor-impl "Build CREATE cosntructor")
+ ("mf" ccide-find-implementation "Find method implementation")
+ ("mT" ccide-insert-defun-prefix "Insert current defun prefix at point")
+ (nil nil separator)
+
+ ;; variable level
+ ("vc" ccide-variable-comment "Variable comment")
+ ("vf" ccide-grab-acces-fn "Grab access methods")
+ (nil nil separator)
+
+ ;; CORBA
+ ("Cg" ccide-gen-corba-impl "Generate CORBA impl")
+ ("Cm" ccide-gen-corba-impl-methods "Generate CORBA impl methods")
+ (nil nil separator)
+
+ ;; templates
+; ("ts" ccide-scan-mantemps "Scan mantemps")
+; (nil nil separator)
+
+ ;; other
+ ("of" ccide-open-compilation-frame "Open *compilation* frame")
+ ("oc" ccide-compile-compile "Make -> Compile")
+ ("ox" ccide-compile-clean "Make -> Clean")
+ ("od" ccide-compile-cleandepends "Make -> Clean depends")
+ ("ok" ccide-compile-kill "Kill compilation")
+ ("oh" ccide-hide-compilation "Hide *compilation* buffer")))
+
+;;; Code:
+
+(require 'cc-engine-2)
+(require 'cc-helper)
+(require 'c++)
+(require 'cl)
+(require 'hideshow)
+;(require 'mantemp)
+(require 'locate)
+(require 'lucid)
+(require 'varcmd)
+(require 'misc-local)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utils
+
+(defsubst ccide-match-string (n)
+ (buffer-substring-no-properties (match-beginning n) (match-end n)))
+
+(defun ccide-file-macro-name (&optional file-name)
+ (concat (upcase (file-name-extension (or file-name (buffer-file-name))))
+ "_"
+ (string-replace "\\." "_" (file-name-sans-extension
+ (file-name-nondirectory
+ (or file-name (buffer-file-name))))
+ t nil t t)
+ "_"))
+
+(defun ccide-file-name (&optional extension file-name directory)
+ (concat (if directory (file-name-as-directory directory) "")
+ (file-name-sans-extension
+ (file-name-nondirectory
+ (or file-name (buffer-file-name))))
+ extension))
+
+(defun ccide-in-doxy-comment ()
+ (save-excursion
+ (back-to-indentation)
+ (if (eq (c-in-literal) 'c)
+ (progn
+ (goto-char (car (c-literal-limits)))
+ (and (looking-at "/\\*\\*[ \t\n\r@]")
+ (current-column))))))
+
+(defun ccide-shell-command (command)
+ (let ((obuf (get-buffer-create "*ccide shell command*"))
+ exit-status)
+ (save-excursion
+ (set-buffer obuf)
+ (erase-buffer)
+ (insert command "\n"))
+ (setq exit-status (call-process shell-file-name nil "*ccide shell command*" nil
+ shell-command-switch command))
+ (and exit-status (equal exit-status 0))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; file level
+
+(defun ccide-file-comment ()
+ "Add a comment to this source file."
+ (interactive)
+ (let ((mode "c++")
+ point)
+ (push-mark)
+ (goto-char (point-min))
+ (insert "// $Id$\n"
+ "//\n"
+ "// Copyright (C) " (number-to-string (nth 5 (decode-time)))
+ " " ccide-default-author "\n"
+ ccide-default-copyright
+ "\n")
+ (cond ((string-match "\\.hh?$" (buffer-file-name))
+ (insert "#ifndef " (ccide-file-macro-name) "\n"
+ "#define " (ccide-file-macro-name) " 1\n\n"
+ "// Custom includes\n\n"
+ "//#include \"" (ccide-file-name ".mpp") "\"\n"
+ "///////////////////////////////hh.p////////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////hh.e////////////////////////////////////////\n"
+ "//#include \"" (ccide-file-name ".cci") "\"\n"
+ "//#include \"" (ccide-file-name ".ct") "\"\n"
+ "//#include \"" (ccide-file-name ".cti") "\"\n"
+ "//#include \"" (ccide-file-name ".mpp") "\"\n"
+ "#endif"))
+ ((string-match "\\.mpp$" (buffer-file-name))
+ (insert "#if !BOOST_PP_IS_ITERATING\n"
+ "#ifndef " (ccide-file-macro-name) "\n\n"
+ "// Custom includes\n\n"
+ "//////////////////////////////mpp.p////////////////////////////////////////\n"
+ "// Local Macros\n\n"
+ "//////\n"
+ "#endif\n"
+ "#else\n"
+ "///////////////////////////////////////////////////////////////////////////\n\n"
+ "//////\n"
+ "#if BOOST_PP_ITERATION_FLAGS()==1\n"
+ "///////////////////////////////////////////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n//////\n"
+ "#endif\n"
+ "#endif\n"
+ "#if !BOOST_PP_IS_ITERATING\n"
+ "#ifdef " (ccide-file-macro-name) "\n"
+ "///////////////////////////////////////////////////////////////////////////\n"
+ "// Undefine local Macros\n\n"
+ "//////////////////////////////mpp.e////////////////////////////////////////\n"
+ "#else\n"
+ "#define " (ccide-file-macro-name) " 1\n"
+ "#endif\n"
+ "#endif"))
+ ((string-match "\\.ih$" (buffer-file-name))
+ (insert "#ifndef " (ccide-file-macro-name) "\n"
+ "#define " (ccide-file-macro-name) " 1\n\n"
+ "// Custom includes\n\n"
+ "///////////////////////////////ih.p////////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////ih.e////////////////////////////////////////\n"
+ "#endif"))
+ ((or (string-match "\\.test\\.cc$" (buffer-file-name))
+ (string-match "\\.test\\.cpp$" (buffer-file-name)))
+ (insert "// Unit tests\n\n"
+ "//#include \"" (ccide-file-name ".hh") "\"\n"
+ "//#include \"" (ccide-file-name ".ih") "\"\n\n"
+ "// Custom includes\n"
+ "#include \"" (ccide-file-name ".hh" (ccide-file-name)) "\"\n\n"
+ "#include <boost/test/auto_unit_test.hpp>\n"
+ "#include <boost/test/test_tools.hpp>\n\n"
+ "#define prefix_\n"
+ "///////////////////////////////cc.p////////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////cc.e////////////////////////////////////////\n"
+ "#undef prefix_"))
+ ((or (string-match "\\.cc$" (buffer-file-name))
+ (string-match "\\.cpp$" (buffer-file-name)))
+ (insert "// Definition of non-inline non-template functions\n\n"
+ "//#include \"" (ccide-file-name ".hh") "\"\n"
+ "//#include \"" (ccide-file-name ".ih") "\"\n\n"
+ "// Custom includes\n\n"
+ "//#include \"" (ccide-file-name ".mpp") "\"\n"
+ "#define prefix_\n"
+ "///////////////////////////////cc.p////////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////cc.e////////////////////////////////////////\n"
+ "#undef prefix_\n"
+ "//#include \"" (ccide-file-name ".mpp") "\""))
+ ((string-match "\\.cci$" (buffer-file-name))
+ (insert "// Definition of inline non-template functions\n\n"
+ "// Custom includes\n\n"
+ "#define prefix_ inline\n"
+ "///////////////////////////////cci.p///////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////cci.e///////////////////////////////////////\n"
+ "#undef prefix_"))
+ ((string-match "\\.ct$" (buffer-file-name))
+ (insert "// Definition of non-inline template functions\n\n"
+ "//#include \"" (ccide-file-name ".ih") "\"\n\n"
+ "// Custom includes\n\n"
+ "#define prefix_\n"
+ "///////////////////////////////ct.p////////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////ct.e////////////////////////////////////////\n"
+ "#undef prefix_"))
+ ((string-match "\\.cti$" (buffer-file-name))
+ (insert "// Definition of inline template functions\n\n"
+ "//#include \"" (ccide-file-name ".ih") "\"\n\n"
+ "// Custom includes\n\n"
+ "#define prefix_ inline\n"
+ "///////////////////////////////cti.p///////////////////////////////////////\n\n")
+ (setq point (point))
+ (goto-char (point-max))
+ (insert "\n\n///////////////////////////////cti.e///////////////////////////////////////\n"
+ "#undef prefix_"))
+ ((string-match "\\.java$" (buffer-file-name))
+ (setq mode "jde")
+ (setq point (point))
+ (goto-char (point-max)))
+ (t
+ (setq point (point))
+ (goto-char (point-max))))
+ (insert "\n\n\f\n"
+ "// Local Variables:\n"
+ "// mode: " mode "\n")
+ (loop for (var . value) in ccide-file-vars
+ do (insert "// " (symbol-name var) ": " (prin1-to-string value) "\n"))
+ (insert "// End:\n")
+ (if point
+ (goto-char point))
+ (if (equal mode "jde")
+ (let ((package (file-name-directory (buffer-file-name))))
+ (jdeap-initialize-setup)
+ (if (not (equal jdeap-current-source-directory "."))
+ (if (string-match
+ (concat "^" (regexp-quote jdeap-current-source-directory))
+ package)
+ (progn
+ (setq package (substring package
+ (match-end 0)
+ (1- (length package))))
+ (insert "package "
+ (string-replace "/" "." package t)
+ ";\n\n"))))
+ (insert "class " (file-name-sans-extension
+ (file-name-nondirectory
+ (buffer-file-name))) "\n{}")
+ (beginning-of-line)))))
+
+(defun ccide-syncronize-includes ()
+ "Syncronize include's in all other files"
+ (interactive)
+ (let (buffer-map)
+ (loop for extension in ccide-special-extensions
+ for file-name = (ccide-file-name extension)
+ do (setq buffer-map
+ (cons (cons file-name
+ (or (find-buffer-visiting file-name)
+ (and (file-readable-p file-name)
+ (find-file-noselect file-name))))
+ buffer-map)))
+ (save-excursion
+ (loop for buffer in buffer-map
+ if (cdr buffer)
+ do (progn
+ (set-buffer (cdr buffer))
+ (save-excursion
+ (loop for include in buffer-map
+ do (progn
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "^\\(//\\)?#\\s-*include \""
+ (regexp-quote (car include))
+ "\"\\s-*$")
+ nil t)
+ (goto-char (match-beginning 0))
+ (if (looking-at "//")
+ (if (cdr include)
+ (delete-char 2))
+ (if (not (cdr include))
+ (insert "//")))
+ (forward-line 1))))))))))
+
+(defun ccide-auto-decorate-new-files ()
+ (if (= (point-min) (point-max))
+ (let ((status (buffer-modified-p)))
+ (ccide-file-comment)
+ (set-buffer-modified-p status))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; class level
+
+(defun ccide-class-comment ()
+ "Add comment to start of current class definition"
+ (interactive)
+ (let ((class (c-get-class-at-point)))
+ (if (not class)
+ (error "No class found")
+ (goto-char (or (aref (car class) 3)
+ (aref (car class) 1)))
+ (if (save-excursion
+ (forward-line -1)
+ (ccide-in-doxy-comment))
+ (progn
+ (search-backward "/**" nil t)
+ (forward-char 4))
+ (let ((indent (make-string (current-indentation) ? )))
+ (insert "/** ")
+ (save-excursion
+ (insert "\n"
+ indent " @short \n"
+ indent " */\n"
+ indent)))))))
+
+(defun ccide-gen-class (name &optional defns)
+ "Generate class declaration template"
+ (interactive (list (read-string (concat "Class name (default "
+ (ccide-file-name)
+ "): ")
+ nil nil (ccide-file-name))))
+ (insert "class " name)
+ (indent-according-to-mode)
+ (let ((in (make-string c-basic-offset ? ))
+ (ofs (make-string (current-indentation) ? )))
+ (save-excursion
+ (beginning-of-line)
+ (open-line 1)
+ (insert ofs "/** \\brief\n"
+ ofs " */"))
+ (insert "\n" ofs)
+ (save-excursion
+ (insert "{\n"
+ ofs "public:\n"
+ ofs in "///////////////////////////////////////////////////////////////////////////\n"
+ ofs in "// Types\n\n"
+ ofs in "///////////////////////////////////////////////////////////////////////////\n"
+ ofs in "///\\name Structors and default members\n"
+ ofs in "///@{\n\n"
+ ofs in "// default default constructor\n"
+ ofs in "// default copy constructor\n"
+ ofs in "// default copy assignment\n"
+ ofs in "// default destructor\n\n"
+ ofs in "// no conversion constructors\n\n"
+ ofs in "///@}\n"
+ ofs in "///////////////////////////////////////////////////////////////////////////\n"
+ ofs in "///\\name Accessors\n"
+ ofs in "///@{\n\n"
+ ofs in "///@}\n"
+ ofs in "///////////////////////////////////////////////////////////////////////////\n"
+ ofs in "///\\name Mutators\n"
+ ofs in "///@{\n\n"
+ ofs in "///@}\n\n")
+ (loop for defn in defns
+ do (insert ofs in defn ";\n"))
+ (if defns
+ (insert "\n"))
+ (insert ofs "protected:\n\n"
+ ofs "private:\n\n"
+ ofs "};\n"))))
+
+(defun ccide-gen-class-defaults ()
+ "Generate signatures of the default functions: default constructor,
+copy constructor, assignment operator and destructor."
+ (indent-according-to-mode)
+ (let* ((name (c-scope-name (aref (car (c-get-class-at-point)) 1)))
+ (in (make-string c-basic-offset ? ))
+ (ofs (make-string (current-indentation) ? ))
+ (tspec (if ccide-gen-throw (concat "\n" ofs in "throw_(());\n") ";\n"))
+ (colon 0))
+ (while (string-match "::" name colon)
+ (setq colon (match-end 0)))
+ (setq name (substring name colon))
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (loop with exit = nil
+ do (message (concat "1-dflt constr, 2-destr, "
+ "3-copy constr, 4-copy assmnt, "
+ "c-all copy, d-all dflt, RET-all/done: "))
+ for ch = (read-event)
+ for first = t then nil
+ do (cond ((eq ch 'return)
+ (if first
+ (insert ofs name "()"
+ tspec
+ ofs name "(const " name "& other)"
+ tspec
+ ofs "~" name "();\n"
+ ofs name "& operator=(const " name "& other)"
+ tspec))
+ (setq exit t))
+ ((eq ch ?1)
+ (insert ofs name "()"
+ tspec))
+ ((eq ch ?2)
+ (insert ofs "~" name "();\n"))
+ ((eq ch ?3)
+ (insert ofs name "(const " name "& other)"
+ tspec))
+ ((eq ch ?4)
+ (insert ofs name "& operator=(const " name "& other)"
+ tspec))
+ ((eq ch ?c)
+ (insert ofs name "(const " name "& other)"
+ tspec
+ ofs name "& operator=(const " name "& other)"
+ tspec))
+ ((eq ch ?d)
+ (insert ofs name "()"
+ tspec
+ ofs "~" name "();\n"))
+ (t (setq unread-command-events (cons ch unread-command-events))
+ (setq exit t)))
+ while (not exit))))
+
+(defun ccide-gen-class-defaults-impl ()
+ "Generate default implementations for class default functions"
+ (interactive)
+ (let ((defn (c-build-default-funcions-impl)))
+ (kill-new (cadr defn))
+ (message (concat (car defn) " default members"))))
+
+(defun ccide-set-class-defaults-comment (word)
+ (save-excursion
+ (back-to-indentation)
+ (if (not (looking-at ccide-class-defaults-word))
+ (message "Not at class defaults commnet")
+ (replace-match word t t nil 1))))
+
+(defmacro ccide-build-class-defaults-f (sym)
+ (let ((fn (intern (concat "ccide-set-class-defaults-"
+ (symbol-name sym)))))
+ `(defun ,fn ()
+ (interactive)
+ (ccide-set-class-defaults-comment ,(symbol-name sym)))))
+
+(ccide-build-class-defaults-f no)
+(ccide-build-class-defaults-f default)
+(ccide-build-class-defaults-f my)
+(ccide-build-class-defaults-f protected)
+(ccide-build-class-defaults-f private)
+(ccide-build-class-defaults-f disabled)
+
+(defun ccide-gen-struct-constructors ()
+ (save-excursion
+ (beginning-of-line)
+ (open-line 1)
+ (indent-according-to-mode)
+ (let* ((scope (c-get-block-scope))
+ (class (c-parse-class scope))
+ (variables (c-get-variable-members-with-type class))
+ (name (c-scope-name (aref (car (last scope)) 1)))
+ (in (make-string (current-indentation) ? ))
+ (inin (make-string (+ (current-indentation) c-basic-offset) ? )))
+ (insert name "()\n" inin ": ")
+ (indent-according-to-mode)
+ (loop for var in variables
+ for first = t then nil
+ if (not first) do (insert ", ")
+ do (insert (car var) "()"))
+ (insert "\n" in "{}\n"
+ in name "(")
+ (loop for var in variables
+ for first = t then nil
+ if (not first) do (insert ", ")
+ do (insert (cdr var) " " (car var) "_"))
+ (insert ")\n" inin ": ")
+ (loop for var in variables
+ for first = t then nil
+ if (not first) do (insert ", ")
+ do (insert (car var) "(" (car var) "_)"))
+ (insert "\n" in "{}"))))
+
+(defun ccide-class-impl-comment ()
+ "Get implementation comment for current class"
+ (interactive)
+ (let* ((scope (c-get-block-scope))
+ (name (c-get-full-prefix scope)))
+ (kill-new (concat (make-string 75 ?/) "\n"
+ "// " name "\n\n"
+ "// protected\n\n"
+ "// private\n\n"))
+ (message name)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; function/method level
+
+(defun ccide-function-comment ()
+ "Add comment to start of current function"
+ (interactive)
+ (c-forward-out-of-comment)
+ (let ((defun (c-get-defun-state))
+ place indent)
+ (c-goto-beginning-of-defun defun)
+ (setq indent (make-string (current-indentation) ? ))
+ (if (save-excursion
+ (forward-line -1)
+ (ccide-in-doxy-comment))
+ ()
+ (insert "/** ")
+ (setq place (point))
+ (insert "\n\n"
+ indent " @li @em PRE : \n"
+ indent " @li @em POST : \n\n"
+ indent " @short \n"
+ indent " */\n" indent)
+ (setq defun (c-get-defun-state)))
+ (ccide-function-comment-adjust defun indent)
+ (if place (goto-char place))))
+
+(defun ccide-function-comment-grab-args ()
+ (let ((limit (save-excursion
+ (search-backward "/**" nil t)
+ (point)))
+ (end (progn (forward-line -1) (point)))
+ begin start args argend)
+ (if (search-backward "@throws" limit t)
+ (setq argend (progn (beginning-of-line) (point)))
+ (setq argend end))
+ (while (or (search-backward "@param" limit t)
+ (search-backward "@return" limit t)))
+ (beginning-of-line)
+ (setq start (point))
+ (setq begin start)
+ (while (search-forward "@param" argend t)
+ (or (search-forward "@param" argend t)
+ (search-forward "@return" argend t)
+ (search-forward "@throws" argend t)
+ (goto-char argend))
+ (beginning-of-line)
+ (setq args (cons (ccide-function-comment-parse-arg start (point))
+ args))
+ (setq start (point)))
+ (prog1
+ (if (not (search-forward "@return" argend t))
+ (cons nil args)
+ (beginning-of-line)
+ (cons (buffer-substring (point) argend) args))
+ (delete-region begin end))))
+
+(defun ccide-function-comment-parse-arg (start end)
+ (save-excursion
+ (goto-char start)
+ (re-search-forward "@param\\s-*\\(\\S-*\\)" end t)
+ (cons (match-string 1)
+ (cons (buffer-substring start (match-beginning 1))
+ (buffer-substring (match-end 1) end)))))
+
+(defun ccide-function-comment-get-throws (defun)
+ (if (aref defun 4)
+ (save-excursion
+ (goto-char (car (aref defun 4)))
+ (if (re-search-forward "\\(throw_\\|throw\\)((?\\s-*\\([^()]*\\))?)"
+ (cdr (aref defun 4)) t)
+ (let ((spec (match-string 2)))
+ (if (> (length spec) 0)
+ spec))))))
+
+(defun ccide-function-comment-adjust (defun indent)
+ (let* ((defargs (mapcar (function (lambda (x)
+ (c-get-template-argument-name (car x) (cdr x))))
+ (aref defun 3)))
+ (defret (and (aref defun 1)
+ (not (string-match (concat "^\\("
+ c-special-key
+ "\\s-*\\)*\\s-*void$")
+ (buffer-substring (car (aref defun 1))
+ (cdr (aref defun 1)))))))
+ (throws (ccide-function-comment-get-throws defun))
+ (xargs (ccide-function-comment-grab-args))
+ (docargs (cdr xargs))
+ (docret (car xargs))
+ (def-in-doc (loop for defarg in defargs always (assoc defarg docargs)))
+ (doc-in-def (loop for docarg in docargs always (member (car docarg) defargs)))
+ (size-eq (= (length defargs) (length docargs))))
+ (if (or defargs defret throws)
+ (if (not (save-excursion
+ (forward-line -1)
+ (looking-at "\\s-*$")))
+ (insert "\n")))
+ ;; We differentiate four types changes
+ ;; - new arguments
+ ;; - removed arguments
+ ;; - reordered arguments
+ ;; - renamed arguments
+ ;;
+ ;; If the change cannot be described by one of the above, it has
+ ;; to be resolved manually
+ (save-excursion
+ (cond (doc-in-def
+ ;; reordered arguments or new arguments (or no change)
+ (loop for defarg in defargs
+ for docarg = (assoc defarg docargs)
+ do (if docarg
+ (insert (cadr docarg) (car docarg) (cddr docarg))
+ (insert indent " @param " defarg " \n"))))
+ (size-eq ; and (not doc-in-def)
+ ;; renamed arguments
+ (loop for defarg in defargs
+ for docarg in docargs
+ do (insert (cadr docarg) defarg (cddr docarg))))
+ (def-in-doc
+ ;; removed arguments
+ (loop for defarg in defargs
+ for docarg = (assoc defarg docargs)
+ do (insert (cadr docarg) (car docarg) (cddr docarg))))
+ (t (error "Arg change too complex. Resolve manualy.")))
+ ;; return value is simple
+ (if defret
+ (if docret
+ (insert docret)
+ (insert indent " @return \n")))
+ (if throws
+ (insert indent " @throws " throws "\n")))
+ (back-to-indentation)))
+
+(defun ccide-grab-prototype (&optional prefix)
+ "Grab prototype of function defined or declared at point. Prefix
+arg, if given, specifies the kind of prefix (inline, static, ...) to use."
+ (interactive "P")
+ (let* ((prfx (or (and prefix (nth (prefix-numeric-value prefix) c-user-prefixes))
+ ccide-default-prefix))
+ (defn (c-build-defun prfx)))
+ (kill-new (concat (cadr defn) "\n{}\n"))
+ (message (concat (or prfx "")
+ (if prfx " " "")
+ (car defn)))))
+
+(defun ccide-reformat-defun ()
+ "Reformat the defn of the current defun."
+ (interactive)
+ (save-excursion
+ (c-beginning-of-defun-or-decl)
+ (let ((defn (c-build-defun nil t)))
+ (delete-region (or (caar (aref (caddr defn) 0))
+ (car (aref (caddr defn) 1))
+ (car (aref (caddr defn) 2)))
+ (or (car (aref (caddr defn) 6))
+ (aref (caddr defn) 7)))
+ (insert (cadr defn) "\n"))))
+
+(defun ccide-replace-defun ()
+ "Replace the function header with the one on the top of the kill
+ring (presumably placed there using c++-grab-prototype)."
+ (interactive)
+ (save-excursion
+ (c-beginning-of-defun-or-decl)
+ (let ((parse (c-parse-defun)))
+ (delete-region (or (aref parse 0)
+ (aref parse 1)
+ (aref parse 2))
+ (or (aref parse 5)
+ (aref parse 6)))
+ (yank)
+ (delete-char -3))))
+
+(defun ccide-prefix-defun-type-with-class (&optional strip)
+ "If a non-keyword type symbol is found prefixing the current defun,
+it will be prefixed with the current class prefix."
+ (interactive "p")
+ (save-excursion
+ (c-beginning-of-defun-or-decl)
+ (let* ((parse (c-parse-defun))
+ (prefix (c-scope-name (aref parse 2) (+ (or strip 0) 0))))
+ (goto-char (aref parse 1))
+ (while (and (or (looking-at c-any-key)
+ (looking-at c-user-prefix-re)
+ (not (c-at-symbol-p)))
+ (< (point) (aref parse 2))
+ (not (eobp)))
+ (c-forward-token-1)
+ (c-forward-syntactic-ws))
+ (if (and (c-at-symbol-p)
+ (< (point) (aref parse 2))
+ (not (looking-at (regexp-quote prefix))))
+ (let ((pos (string-match "<" prefix)))
+ (if (and pos (looking-at (concat (substring prefix 0 pos)
+ "\\b[^_]")))
+ (progn
+ (goto-char (match-end 0))
+ (c-backward-syntactic-ws)
+ (insert (substring prefix pos)))
+ (insert prefix "::"))
+ (ccide-reformat-defun))))))
+
+(defun ccide-prefix-defun-type-with-namespace (&optional strip)
+ (interactive "p")
+ (ccide-prefix-defun-type-with-class (+ (or strip 0) 1)))
+
+(defun ccide-insert-defun-prefix (&optional strip)
+ "Insert the current defun prefix at point."
+ (interactive "p")
+ (let* ((parse (c-parse-defun))
+ (prefix (c-scope-name (aref parse 2) (+ (or strip 0) 0))))
+ (insert prefix "::")))
+
+(defun ccide-kill-inline-decl (defn)
+ (save-excursion
+ (if (aref (caddr defn) 6)
+ (progn
+ (goto-char (cdr (aref (caddr defn) 6)))
+ (let ((end-mark (point-marker)))
+ (goto-char (car (aref (caddr defn) 6)))
+ (indent-rigidly (point) end-mark
+ (- (current-column)))
+ (prog1
+ (concat (cadr defn)
+ "\n"
+ (buffer-substring-no-properties (point) end-mark)
+ "\n")
+ (when (aref (caddr defn) 5)
+ (goto-char (caar (aref (caddr defn) 5)))
+ (c-backward-syntactic-ws)
+ (skip-chars-backward ":"))
+ (c-backward-syntactic-ws)
+ (delete-region (point) end-mark)
+ (insert ";"))))
+ (concat (cadr defn) "\n{}\n"))))
+
+(defun ccide-grab-inline-decl ()
+ "Grab the inline decl at point at turn it into an out-of-line inline
+declaration at the top of the kill ring."
+ (interactive)
+ (let ((defn (c-build-defun (or ccide-default-prefix "inline"))))
+ (kill-new (ccide-kill-inline-decl defn))
+ (message (concat (or ccide-default-prefix "indline")
+ " "
+ (car defn)))))
+
+(defun ccide-grab-all-inlines ()
+ "Grab all inline decls in the current class"
+ (interactive)
+ (let ((class (c-parse-class (c-get-block-scope)))
+ defns)
+ (when class
+ (loop for method in (nreverse (aref class 4))
+ do (when (eq (car method) 'method)
+ (let ((defn (save-excursion
+ (goto-char (cdr method))
+ (c-build-defun (or ccide-default-prefix "inline")))))
+ (if (aref (caddr defn) 6)
+ (setq defns (nconc defns (list (ccide-kill-inline-decl defn))))))))
+ (kill-new (loop for defn in (nreverse defns)
+ for next = nil then t
+ if next concat "\n";
+ concat defn))
+ (message (format "%d inlines grabed to kill ring" (length defns))))))
+
+
+(defun ccide-grab-create-constructor ()
+ (interactive)
+ (let ((defn (c-build-create-constructor)))
+ (kill-new (cadr defn))
+ (message (car defn))))
+
+(defun ccide-grab-create-constructor-impl (&optional prefix)
+ (interactive "P")
+ (let* ((prfx (or (and prefix (nth (prefix-numeric-value prefix) c-user-prefixes))
+ ccide-default-prefix))
+ (defn (c-build-create-constructor-impl prfx)))
+ (kill-new (cadr defn))
+ (message (concat (or prfx "")
+ (if prfx " " "")
+ (car defn)))))
+
+;; (defun ccide-find-implementation (&optional other-window)
+;; "Find implementation of method declared at point."
+;; (interactive "P")
+;; (let ((def (c-build-defun))
+;; match pos)
+;; (setq match (concat (regexp-quote (car def)) "[ \t\n\r]*("))
+;; (setq match (string-replace "::" "::[ \t\n\r]*" match t nil t t))
+;; (message match)
+;; (loop for ext in ccide-implementation-extensions
+;; do (let* ((filename (ccide-file-name ext))
+;; (buf (and (file-readable-p filename) (find-file-noselect filename))))
+;; (if buf
+;; (save-excursion
+;; (set-buffer buf)
+;; (goto-char (point-min))
+;; (if (loop while (search-forward-regexp match nil t)
+;; do (forward-char -1)
+;; thereis (c-at-toplevel-p))
+;; (setq pos (cons buf (point)))))))
+;; until pos)
+;; (if pos
+;; (let ((win (get-buffer-window (car pos))))
+;; (if win
+;; (select-window win)
+;; (if other-window
+;; (switch-to-buffer-other-window (car pos))
+;; (switch-to-buffer (car pos))))
+;; (goto-char (cdr pos))
+;; (forward-char -1)
+;; (c-beginning-of-defun-or-decl))
+;; (message (concat "Implementation of " (car def) " not found.")))))
+
+(defun ccide-find-implementation (&optional other-window)
+ "Find implementation of method declared at point."
+ (interactive "P")
+ (let* ((state (c-get-defun-state))
+ (name (c-defun-short-name state))
+ (scoped-name (c-defun-full-name state))
+ (args (ccide-implementation-args state))
+ rv fallback)
+
+ (loop for ext in ccide-implementation-extensions
+ for filename = (ccide-file-name ext)
+ while (not rv)
+ do (progn
+ (let ((buf (or (find-buffer-visiting filename)
+ (and (file-readable-p filename)
+ (find-file-noselect filename)))))
+ (when buf
+ (let ((found (save-excursion
+ (set-buffer buf)
+ (ccide-find-implementation-1 name scoped-name args
+ (car (aref state 2))))))
+ (if found
+ (if (cdr found)
+ (setq rv (cons buf found))
+ (if (not fallback) (setq fallback (cons buf found))))))))))
+ (if (not rv) (setq rv fallback))
+ (if rv
+ (let* ((buf (car rv))
+ (pos (cadr rv))
+ (win (get-buffer-window buf)))
+ (if win
+ (select-window win)
+ (if other-window
+ (switch-to-buffer-other-window buf)
+ (switch-to-buffer buf)))
+ (goto-char pos)
+ (forward-char -1)
+ (c-beginning-of-defun-or-decl))
+ (message (concat "Implementation of " scoped-name " not found.")))))
+
+(defun ccide-implementation-args (state)
+ (string-replace "[ \t\n\r]+" ""
+ (loop for (start . end) in (aref state 3)
+ for sep = "" then ","
+ concat sep
+ concat (buffer-substring-no-properties
+ start (save-excursion
+ (goto-char start)
+ (if (search-forward "=" end 'move) (forward-char -1))
+ (point))))
+
+ t))
+
+(defun ccide-find-implementation-1 (name scoped-name args skip-def)
+ ;; Within the current buffer, search for all implementations of the
+ ;; given function. The rv is a list of conses. The car holds the
+ ;; buffer position of the implementation, the cdr is t if the name,
+ ;; scoped-name and args are matched, otherwise the args did not match.
+ (save-excursion
+ (goto-char (point-min))
+ (let (fallback rv check-state)
+ (while (and (not rv) (search-forward name nil t))
+ (if (and (c-at-toplevel-p)
+ (not (c-in-literal))
+ (setq check-state (condition-case nil (c-get-defun-state) (error nil)))
+ (not (= (car (aref check-state 2)) skip-def)))
+ (if (string= scoped-name (c-defun-full-name check-state))
+ (if (string= args (ccide-implementation-args check-state))
+ (setq rv (cons (point) t))
+ (if (not fallback)
+ (setq fallback (cons (point) nil)))))))
+ (or rv fallback))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; variable/type level
+
+(defun ccide-variable-comment ()
+ "Add a comment to current variable declaration."
+ (interactive)
+ (push-mark)
+ (beginning-of-line)
+ (open-line 1)
+ (insert "/// ")
+ (indent-according-to-mode))
+
+(defun ccide-grab-access-fn ()
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at (concat c++-simple-type-regexp "[ \t\n\r][a-zA-Z0-9_]+[ \t\n\r]*;"))
+ (let ((vardef (match-string 0))
+ (in (make-string c-basic-offset ? ))
+ type varname ws doc)
+ (forward-line -1)
+ (back-to-indentation)
+ (if (looking-at "///[ \t\n\r]*")
+ (setq doc (buffer-substring (match-end 0)
+ (progn (end-of-line) (point)))))
+ (string-match "^[ \t\n\r]*\\(.*\\)[ \t\n\r]\\([a-zA-Z0-9_]+\\)[ \t\n\r]*;$"
+ vardef)
+ (setq varname (match-string 2 vardef)
+ type (match-string 1 vardef)
+ ws (substring vardef 0 (match-beginning 1)))
+ (if (string-match "^[ \t\n\r]*" type)
+ (setq type (substring type (match-end 0))))
+ (kill-new (concat (if doc
+ (concat ws "/** Setze " doc ".\n\n"
+ ws " @param _" varname " neu: " doc "\n"
+ ws " @return alt: " doc "\n"
+ ws " */\n")
+ "")
+ ws type " q_" varname "(" type " _" varname ")\n"
+ ws in "{\n"
+ ws in in type " old" varname " = " varname ";\n"
+ ws in in varname " = _" varname ";\n"
+ ws in in "return(old" varname ");\n"
+ ws in "}\n\n"
+ (if doc
+ (concat ws "/** Hole " doc ".\n\n"
+ ws " @return " doc "\n"
+ ws "*/\n")
+ "")
+ ws type " q_" varname "(void) const\n"
+ ws in "{ return(" varname "); }\n"))
+
+ (message varname))
+ (message "No variable found"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; doxy comment support functions
+
+(defun ccide-special-indent-function ()
+ "Function to indent doxy comments correctly"
+ (let ((indent (ccide-in-doxy-comment)))
+ (if indent
+ (let ((lim (save-excursion
+ (back-to-indentation)
+ (c-literal-limits)))
+ (pos (- (point-max) (point))))
+ (incf indent 4)
+ (save-excursion
+ (back-to-indentation)
+ (if (looking-at "*/")
+ (incf indent -3)
+ (let ((para (or (save-excursion (re-search-backward "^\\s-*$" (car lim) t))
+ (car lim))))
+ (if (and (not (looking-at ccide-doxy-tag-re))
+ (re-search-backward (concat "^\\s-*"
+ ccide-doxy-tag-re)
+ para t))
+ (incf indent 4)))))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (back-to-indentation) (point)))
+ (indent-to indent)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos)))))))
+
+(defun ccide-fill-function ()
+ "auto-fill function for doxy comments"
+ (if (do-auto-fill)
+ (if (not fill-prefix)
+ (indent-according-to-mode))))
+
+(defun ccide-hide-all-doxy-comments ()
+ "Hide all doxy comments"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^\\s-*/\\*\\*" nil t)
+ (beginning-of-line)
+ (forward-line -1)
+ (if (not (looking-at "\\s-*$"))
+ (forward-line 1))
+ (forward-char -1)
+ (let ((start (point)))
+ (if (re-search-forward "\\*/" nil t)
+ (progn
+ (if (looking-at "\\s-*\n")
+ (forward-line 1))
+ (forward-char -1)
+ (let ((overlay (make-overlay start (point))))
+ (overlay-put overlay 'intangible 'hs)
+ (overlay-put overlay 'invisible 'hs)))))))
+ (message "Done."))
+
+(defun ccide-show-all-comments ()
+ "Show all comments"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (goto-char (next-overlay-change (point)))
+ (loop for overlay in (overlays-at (point))
+ if (eq (overlay-get overlay 'invisible) 'hs)
+ do (delete-overlay overlay))))
+ (message "Done."))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CORBA support (omniORB2)
+
+(defun ccide-get-corba-headers ()
+ (let (files)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "#include\\s-*[\"<]\\([^\">]*\\)\\.hh[\">]" nil t)
+ (setq files (cons (ccide-match-string 1) files)))
+ (nreverse files))))
+
+(defun ccide-corba-maybe-build-hh (file)
+ (let ((skel (ccide-file-name ".hh" file ccide-corba-skel-dir))
+ (idl (ccide-file-name ".idl" file ccide-corba-idl-dir)))
+ (if (and (file-readable-p idl)
+ (or (not (file-readable-p skel))
+ (file-newer-than-file-p idl skel)))
+ (let ((buffer (find-buffer-visiting (ccide-file-name ".hh" file))))
+ (if buffer
+ (kill-buffer buffer))
+ (message "Please wait ... building %s" (ccide-file-name ".hh" file))
+ (if (ccide-shell-command (concat "cd "
+ (real-path-name ccide-corba-skel-dir)
+ " && "
+ ccide-corba-idl-command
+ (if (> (length ccide-corba-idl-dir) 0)
+ (concat " -I" ccide-corba-idl-dir))
+ " "
+ idl))
+ ()
+ (display-buffer (get-buffer-create "*ccide shell command*"))
+ (error "Generation of %s failed" (ccide-file-name ".hh")))))
+ (if (not (file-readable-p skel))
+ (error "No file %s or %s"
+ (ccide-file-name ".hh" file) (ccide-file-name ".idl" file)))))
+
+(defun ccide-corba-list-skeletons-1 (hh-file)
+ (ccide-corba-maybe-build-hh hh-file)
+ (let ((hh-buf (find-file-noselect (ccide-file-name ".hh" hh-file)))
+ skels)
+ (save-excursion
+ (set-buffer hh-buf)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^\\s-*class\\s-+_sk_\\([a-zA-Z0-9_]+\\)\\s-+:"
+ nil t)
+ (setq skels (cons (ccide-match-string 1) skels)))))
+ (mapcar (function (lambda (x) (cons x hh-file)))
+ (sort skels 'string-lessp))))
+
+(defun ccide-corba-list-skeletons ()
+ (let ((files (ccide-get-corba-headers)))
+ (loop for file in files
+ append (ccide-corba-list-skeletons-1 file))))
+
+(defun ccide-gen-corba-impl (class)
+ (interactive (list (completing-read "Class name of skeleton: "
+ (ccide-corba-list-skeletons)
+ nil t)))
+ (let* ((skels (ccide-corba-list-skeletons))
+ (hh-file (ccide-file-name ".hh" (cdr (assoc class skels))
+ ccide-corba-skel-dir))
+ (hh-buf (find-file-noselect (ccide-file-name ".hh" hh-file
+ ccide-corba-skel-dir))))
+ (ccide-gen-class (concat class "_i"))
+ (insert (make-string c-basic-offset ? ) ": public virtual _sk_" class "\n")
+ (save-excursion
+ (search-forward "protected:" nil t)
+ (forward-line -1)
+ (ccide-gen-corba-impl-methods)
+ (insert "\n"))))
+
+(defun ccide-get-corba-defns (hh-file class)
+ (let ((hh-buf (find-file-noselect hh-file))
+ defns)
+ (save-excursion
+ (set-buffer hh-buf)
+ (save-excursion
+ (goto-char (point-min))
+ (if (not (re-search-forward (concat "^\\s-*class\\s-+_sk_" class "\\s-+:")
+ nil t))
+ (error "CORBA skeleton class not found.")
+ (search-forward "{")
+ (forward-char -1)
+ (let ((end (save-excursion (forward-sexp) (point))))
+ (while (and (< (point) end)
+ (< (forward-line 1) 1))
+ (if (looking-at "\\s-+virtual\\s-+\\(.*)\\)\\s-*=\\s-*0;\\s-*$")
+ (setq defns (cons (match-string 1) defns))))))))
+ (nreverse defns)))
+
+(defun ccide-gen-corba-impl-methods ()
+ (interactive)
+ (let* ((class (c-get-class-at-point))
+ (point (point)))
+ (if (not class)
+ (error "No class at point."))
+ (save-excursion
+ (goto-char (aref (car class) 1))
+ (if (not (re-search-forward ":\\s-*public\\s-*virtual\\s-*_sk_\\([^ \t\n\r{},:]*\\)"
+ nil t))
+ (error "No CORBA impl at point."))
+ (let* ((name (ccide-match-string 1))
+ (skels (ccide-corba-list-skeletons))
+ (hh-file (ccide-file-name ".hh" (cdr (assoc name skels))
+ ccide-corba-skel-dir))
+ (defns (ccide-get-corba-defns hh-file name))
+ end)
+ (goto-char (aref (car class) 2))
+ (save-excursion
+ (c-forward-sexp)
+ (setq end (point)))
+ (if (re-search-forward "^\\s-*// CORBA$" end t)
+ (let ((start (match-beginning 0)))
+ (if (re-search-forward "^\\s-*// END-CORBA$" end t)
+ (let ((eend (match-end 0)))
+ (goto-char start)
+ (forward-line 1)
+ (if (re-search-forward "/\\*\\|//" (match-beginning 0) t)
+ (if (y-or-n-p "Remove CORBA Funktion comments? (y/n)")
+ (delete-region start (1+ eend))
+ (goto-char eend)
+ (beginning-of-line)
+ (delete-region (point) (progn
+ (end-of-line)
+ (1+ (point))))
+ (save-excursion
+ (goto-char start)
+ (delete-region (point) (progn
+ (end-of-line)
+ (1+ (point)))))
+ (insert "\n"))
+ (delete-region start (1+ eend))))))
+ (goto-char point))
+ (indent-according-to-mode)
+ (insert "// CORBA\n")
+ (loop for defn in defns
+ do (progn
+ (save-excursion (insert defn ";"))
+ (indent-according-to-mode)
+ (let ((start (point)) end)
+ (end-of-line)
+ (setq end (point))
+ (goto-char start)
+ (while (re-search-forward "\\s-+" end t)
+ (replace-match " ")
+ (setq end (- end (- (match-end 0) (match-beginning 0) 1))))
+ (end-of-line)
+ (loop with done = nil
+ while (> (current-column) c-max-def-column)
+ do (while (and (> (current-column) c-max-def-column)
+ (search-backward "," start t)))
+ do (if (looking-at ",")
+ (progn
+ (forward-char 1)
+ (insert "\n")
+ (open-line 1)
+ (indent-according-to-mode)
+ (delete-char 2)
+ (setq start (point))
+ (end-of-line))
+ (setq done t))
+ while (not done)))
+ (insert "\n")))
+ (indent-according-to-mode)
+ (insert "// END-CORBA\n")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; template support
+
+(defun ccide-scan-mantemps ()
+ "Scan *compilation* buffer for errors and generate manual template
+instatiations at point."
+ (interactive)
+ (save-excursion
+ (set-buffer "*compilation*")
+ (goto-char (point-min)))
+ (save-excursion
+ (set-buffer (get-buffer-create "*mantemps*"))
+ (erase-buffer)
+ (loop for temp = (ccide-get-mantemp)
+ while temp
+ do (insert temp "\n"))
+ (mantemp-make-mantemps-buffer)
+ (goto-char (point-min))
+ (while (progn
+ (ccide-fix-mantemp)
+ (< (forward-line 1) 1))))
+ (insert-buffer-substring "*mantemps*"))
+
+(defun ccide-get-mantemp ()
+ (save-excursion
+ (set-buffer "*compilation*")
+ (if (search-forward "undefined reference to `" nil t)
+ (let ((start (point)))
+ (end-of-line)
+ (search-backward "'" nil t)
+ (buffer-substring start (point))))))
+
+(defun ccide-fix-mantemp ()
+ (let ((end (save-excursion
+ (end-of-line) (point))))
+ (if (and (save-excursion (search-forward "(" end t))
+ (search-forward " class" end t))
+ (progn
+ (forward-char -6)
+ (delete-char 6)))))
+
+(provide 'cc-ide)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; other stuff
+
+(defun ccide-open-compilation-frame ()
+ (interactive)
+ (let ((c-frame (selected-frame))
+ (compilation-frame (make-frame '((minibuffer . nil)
+ (unsplittable . t)
+ (menu-bar-lines . 0)
+ (top . -87)
+ (left . 36)
+ (width . 169)
+ (height . 9)))))
+ (select-frame compilation-frame)
+ (switch-to-buffer "*compilation*")
+ (set-window-dedicated-p (selected-window) t)))
+
+(defun ccide-compile (command)
+ (delete-other-windows)
+ (split-window-horizontally)
+ (compile command)
+ (save-excursion
+ (set-buffer "*compilation*")
+ (let ((point (point-max)))
+ (goto-char point)
+ (loop for window in (get-buffer-window-list "*compilation*" nil t)
+ do (set-window-point window point)))))
+
+(defun ccide-compile-compile ()
+ (interactive)
+ (ccide-compile (concat "make -k " ccide-compile-opts)))
+
+(defun ccide-compile-clean ()
+ (interactive)
+ (ccide-compile (concat "make -k " ccide-compile-opts " clean")))
+
+(defun ccide-compile-cleandepends ()
+ (interactive)
+ (ccide-compile (concat "make -k " ccide-compile-opts " cleandepends")))
+
+(defun ccide-compile-kill ()
+ (interactive)
+ (set-buffer "*compilation*")
+ (kill-compilation))
+
+(defun ccide-hide-compilation ()
+ (interactive)
+ (let ((active (selected-window)))
+ (unwind-protect
+ (loop for window in (get-buffer-window-list "*compilation*")
+ do (progn (select-window window)
+ (switch-to-buffer (other-buffer "*compilation*"))))
+ (select-window active))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; keymap and installation
+
+(defun ccide-bind-keys (prefix map)
+ (loop for binding in ccide-bindings
+ do (apply 'vcmd-define-key
+ map
+ (concat prefix (car binding))
+ (cadr binding)
+ "IDE"
+ (cddr binding))))
+
+(defun ccide-install-it ()
+ (save-excursion
+ (hs-minor-mode 1)
+ (hs-show-all))
+ (local-unset-key "\C-c;")
+ (local-unset-key [menu-bar IDE])
+ (ccide-bind-keys "\C-c;" (current-local-map))
+ (local-set-key "\C-cC" 'ccide-hide-all-doxy-comments)
+ (local-set-key "\C-cS" 'ccide-show-all-comments)
+ (set (make-local-variable 'auto-fill-function) 'ccide-fill-function)
+ (auto-fill-mode -1)
+ (ccide-auto-decorate-new-files))
+
+(add-hook 'c-mode-hook 'ccide-install-it)
+(add-hook 'c++-mode-hook 'ccide-install-it)
+(add-hook 'c-special-indent-hook 'ccide-special-indent-function)
+
+(loop for extension in ccide-special-extensions
+ for re = (concat (regexp-quote extension) "$")
+ if (not (assoc re auto-mode-alist))
+ do (setq auto-mode-alist (append auto-mode-alist
+ (list (cons re 'c++-mode)))))
+
+(defadvice c-indent-line (after c-indent-less compile disable) ;activate
+ ;; new indent function for c-mode: do standard indentation first. If line
+ ;; is to long using standard indentation, just indent by c-basic-indentation.
+ (let ((cc (save-excursion (end-of-line) (current-column)))
+ indent)
+ (if (> cc 85)
+ (let ((pos (- (point-max) (point))))
+ (beginning-of-line)
+ (let ((point (point))
+ (line (1+ (count-lines 1 (point))))
+ indent)
+ (c-beginning-of-statement-2)
+ (if (and (not (c-crosses-statement-barrier-p (point) point))
+ (not (eq (+ (count-lines 1 (point))
+ (if (bolp) 1 0))
+ line)))
+ (progn
+ (setq indent (+ (current-indentation) c-basic-offset))
+ (goto-char point)
+ (if (< indent (current-indentation))
+ (progn
+ (setq ad-return-value
+ (+ ad-return-value
+ (- (current-indentation) indent)))
+ (delete-region (c-point 'bol) (c-point 'boi))
+ (indent-to indent))))))
+ (if (< (point) (c-point 'boi))
+ (back-to-indentation)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos))))))))
+
+
+\f
+;;; Local Variables:
+;;; elisp-project-autoload-file-name: "cc-autoload.el"
+;;; End:
--- /dev/null
+;;; cc-ide.el --- Add all g0dilstuff lisp dirs to the load path
+;;
+;; $Id$
+;;
+;; Copyright (C) 2000 Stefan Bund
+
+;; cc-ide.el 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 2, or (at your
+;; option) any later version.
+
+;; cc-ide.el 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.
+
+;;; Commentary:
+
+;;; Change-Log:
+
+;; $Log$
+;;
+
+;;; Variables:
+
+;;; Code:
+
+(require 'cl)
+
+(let* ((self (locate-library "g0dilstuff-init"))
+ (self-dir (file-name-directory self)))
+ (loop for dir in (directory-files self-dir t)
+ if (file-directory-p dir) do (add-to-list 'load-path (file-name-as-directory dir))))
+
+(provide 'g0dilstuff-init)
--- /dev/null
+;; Miscellaneous local functions
+;;
+;; $Id: misc-local.el,v 1.20 2003/08/04 13:27:17 admin Exp $
+
+;;; Change-Log:
+
+;; $Log: misc-local.el,v $
+;; Revision 1.20 2003/08/04 13:27:17 admin
+;; Import der neuen Version
+;;
+;; Revision 1.19 2000/02/08 20:27:36 bund
+;; Besseres *scratch*-Buffer handling in kill-most-buffers
+;; setf in put-hashq/put-hash
+;;
+;; Revision 1.18 2000/02/04 13:16:45 bund
+;; *scratch*-Buffer verwaltung in kill-most-buffers verbessert
+;;
+;; Revision 1.17 2000/02/03 09:10:53 bund
+;; put-hash
+;;
+;; Revision 1.16 2000/02/01 11:21:18 bund
+;; Added emi-split-string
+;; Added put-hashq
+;;
+;; Revision 1.15 2000/01/26 15:26:58 bund
+;; better prefix-arg handling in kill-most-buffers
+;;
+;; Revision 1.14 2000/01/12 14:38:42 bund
+;; Neue funktion: kill-most-buffers
+;;
+;; Revision 1.13 1999/06/03 15:46:17 bund
+;; Added template-document-name function
+;;
+;; Revision 1.12 1999/02/02 12:48:45 bund
+;; Neue implementiereung von date-time-fielname-string et. al.
+;;
+;; Revision 1.11 1998/10/10 09:35:20 admin
+;; BUGFIX: fixed hook dependencies
+;;
+;; Revision 1.10 1998/10/07 14:33:28 bund
+;; Implemented window-size-change-functions hook for dedicated windows
+;;
+;; Revision 1.9 1998/10/07 13:44:46 bund
+;; Implemeted open-dedicated-window and it's friends
+;;
+;; Revision 1.8 1998/06/17 15:58:30 bund
+;; added query-filename-and-check
+;;
+;; Revision 1.7 1998/06/05 16:22:45 bund
+;; added load-add-hook-or-run
+;;
+;; Revision 1.7 1998/05/17 15:51:38 bund
+;; moved adabas-convert-char-byte to dataface.el
+;;
+;; Revision 1.6 1998/04/23 17:09:52 bund
+;; implemented hsxstring conversion functions
+;;
+;; Revision 1.5 1998/04/16 11:52:48 bund
+;; fixed (args-out-of-range) bug in string-replace
+;;
+;; Revision 1.4 1998/04/14 09:42:45 bund
+;; Implemented grep-list and grep-map-list[*]
+;;
+;; Revision 1.3 1998/03/31 12:47:28 bund
+;; misc changes
+;;
+;; Revision 1.2 1998/03/30 08:39:34 bund
+;; Added emi-mapcar*
+;;
+
+;;; Variables:
+
+(defvar kill-most-buffers-nokill-list
+ '("*desktop*" " *Adabas*"))
+
+;;; Code:
+
+(require 'cl)
+
+(defun emi-mapcar* (f &rest args)
+ "Apply FUNCTION to successive cars of all ARGS.
+Return the list of results."
+ (if (not (memq 'nil args))
+ (cons (apply f (mapcar 'car args))
+ (apply 'emi-mapcar* f
+ (mapcar 'cdr args)))))
+
+(defun string-noempty (str)
+ "Return STR if (length STR) > 0, nil otherwise"
+ (if (> (length str) 0)
+ str
+ nil))
+
+(defun date-time-filename-string (date &optional num)
+ "Return the string YYYYMMDDHHMMSS[nn] for the date DATE.
+ Append nn if NUM is non-nil."
+ (concat (format "%04d%02d%02d%02d%02d%02d"
+ (nth 5 date) (nth 4 date) (nth 3 date)
+ (nth 2 date) (nth 1 date) (nth 0 date))
+ (if num (format "%02d" num) "")))
+
+(defun date-time-string (date)
+ "Return DD.MM.YYYY HH:MM for the date DATE."
+ (format "%2d.%02d.%04d %2d:%02d"
+ (nth 3 date) (nth 4 date) (nth 5 date)
+ (nth 2 date) (nth 1 date)))
+
+(defun current-date-time-filename-string (&optional num)
+ "Return the string YYYYMMDDHHMMSS[nn] for the current date-and-time.
+If called interactively insert string at POINT"
+ (interactive)
+ (if (interactive-p)
+ (insert (date-time-filename-string (decode-time (current-time))))
+ (date-time-filename-string (decode-time (current-time)))))
+
+(defun current-date-time-string ()
+ "Return the string DD.MM.YYYY HH:MM for the current date-and-time."
+ (interactive)
+ (if (interactive-p)
+ (insert (date-time-string (decode-time (current-time))))
+ (date-time-string (decode-time (current-time)))))
+
+(defun template-document-name (template)
+ (if (string-match "\\.tmpl$" template)
+ (substring template 0 (match-beginning 0))
+ template))
+
+(defun template-document-extension (template)
+ "Return the extension of TEMPLATE without the trailing .tmpl.
+That is, if TEMPLATE is 'filename.ext.tmpl', return '.ext'. If
+TEMPLATE does not have the '.tmpl' extension or the '.ext' part is
+mising, return nil"
+ (if (string-match "\\.tmpl$" template)
+ (progn
+ (setq template (replace-match "" t t template))
+ (if (string-match "^.*\\." template)
+ (replace-match "" t t template)
+ nil))
+ nil))
+
+(defun read-file-name-with-default (prompt default &optional existing)
+ "Read file name from user prompting with PROMPT. The user
+will get DEFAULT provided as default choice"
+ (let (dir name)
+ (save-match-data
+ (if (string-match "^.*/" default)
+ (progn
+ (setq dir (match-string 0 default)
+ name (substring default (match-end 0))))
+ (setq dir ""
+ name default)))
+ (read-file-name prompt
+ dir
+ default
+ existing
+ name)))
+
+(defun string-replace (from to string &optional n start fixedcase literal subexp)
+ "Replate first N occurences, all if T, one if NIL of FROM in STRING
+with TO. Returns the new string. FIXEDCASE, LITERAL and SUBEXP have
+the same meaning as in replace-match."
+ (if (not (or (numberp n) n))
+ (setq n 1))
+ (while (and (if (numberp n) (> n 0) t)
+ (or (not start) (< start (length string)))
+ (string-match from string start))
+ (setq start (- (match-end 0) (length string))
+ string (replace-match to fixedcase literal string subexp)
+ start (+ start (length string)))
+ (if (numberp n)
+ (setq n (1- n))))
+ string)
+
+(defun emi-split-string (string separator &optional N)
+ "Split STRING at SEPARATOR (a regex). Return list of strings. If N
+is given, split at most that many times. The last string return will
+contain the remaining string."
+ (let ((start 0)
+ strings)
+ (while (and (or (not N) (> N 0))
+ (string-match separator string start))
+ (setq strings (cons (substring string start (match-beginning 0))
+ strings)
+ start (match-end 0)
+ N (if N (- N 1))))
+ (nreverse (cons (substring string start) strings))))
+
+(defun grep-list (func list)
+ "Create a new list from LIST keeping only elements, for which
+FUNC returns non-nil."
+ (if list
+ (if (funcall func (car list))
+ (cons (car list)
+ (grep-list func (cdr list)))
+ (grep-list func (cdr list)))))
+
+(defun grep-map-list (func list)
+ "Apply FUNC to all elements of LIST and build a new list from the
+return values of FUNC (like mapcar) excluding all nil elements."
+ (if list
+ (let ((elem (funcall func (car list))))
+ (if elem
+ (cons elem
+ (grep-map-list func (cdr list)))
+ (grep-map-list func (cdr list))))))
+
+(defun grep-map-list* (func &rest args)
+ "grep-map-list* is to grep-map-list, what emi-mapcar* is to mapcar."
+ (if (not (memq nil args))
+ (let ((elem (apply func (mapcar 'car args))))
+ (if elem
+ (cons elem
+ (apply 'grep-map-list* func (mapcar 'cdr args)))
+ (apply 'grep-map-list* func (mapcar 'cdr args))))))
+
+(defun hex-to-nibble (d)
+ (if (and (not (string< d "0"))
+ (or (string< d "9")
+ (string= d "9")))
+ (- (string-to-char d) ?0)
+ (+ (- (string-to-char (upcase d)) ?A) 10)))
+
+(defun hex-to-byte (string)
+ (+ (if (> (length string) 0) (* (hex-to-nibble (substring string 0 1)) 16) 0)
+ (if (> (length string) 1) (hex-to-nibble (substring string 1 2)) 0)))
+
+(defun nibble-to-hex (n)
+ (if (< n 10)
+ (char-to-string (+ ?0 n))
+ (char-to-string (+ ?A (- n 10)))))
+
+(defun byte-to-hex (n)
+ (concat (nibble-to-hex (% (/ n 16) 16))
+ (nibble-to-hex (% n 16))))
+
+(defun string-to-hexstring (value)
+ (let ((v ""))
+ (while (> (length value) 0)
+ (setq v (concat v (byte-to-hex (string-to-char value)))
+ value (substring value 1)))
+ v))
+
+(defun hexstring-to-string (value)
+ (let ((v ""))
+ (while (> (length value) 1)
+ (setq v (concat v (char-to-string (hex-to-byte value)))
+ value (substring value 2)))
+ v))
+
+(defun load-hook-add-or-run (feature hook-symbol hook)
+ "If FEATURE is present, immediately execute HOOK, otherwise add it to
+HOOK-SYMBOL (preferably a load hook symbol)"
+ (if (featurep feature)
+ (funcall hook)
+ (add-hook hook-symbol hook)))
+
+(defun query-filename-and-check (prompt &optional directory default initial)
+ "Query the user for the name of a new file. If FILENAME allready exists,
+query wether to overwrite it and delete the file in the affirmative case.
+Returns the filename entered. If the user terminates the request, a quit
+condition is generated."
+ (let* ((filename (read-file-name prompt directory default nil initial))
+ (filebuffer (find-buffer-visiting filename))
+ (fileexists (file-readable-p filename)))
+ (if (not (if (or filebuffer fileexists)
+ (yes-or-no-p (concat "Overwrite " filename "? "))
+ t))
+ (setq quit-flag t)
+ (if fileexists (delete-file filename))
+ (if filebuffer (kill-buffer filebuffer)))
+ filename))
+
+(defvar assign-window-buffer-window nil)
+(defvar assign-window-buffer-buffers nil)
+(put 'assign-window-buffer-window 'permanent-local t)
+(put 'assign-window-buffer-buffers 'permanent-local t)
+(make-variable-buffer-local 'assign-window-buffer-window)
+(make-variable-buffer-local 'assign-window-buffer-buffers)
+(put 'kill-buffer-hook 'permanent-local t)
+(defvar assign-window-windows nil)
+(defvar assign-window-hook-running nil)
+
+(defun assign-window-to-buffer (buffer window &optional window-conf other-buffers)
+ "Assigns WINDOW to be fixed on displaying BUFFER. If BUFFER is
+killed, the WINDOW is killed to. If WINDOW-CONF is given, instead of
+killing the buffer, the WINDOW-CONFiguration is restored. If
+OTHER-BUFFERS is given, theese buffers are killed together with
+BUFFER, if BUFFER is killed."
+ (select-window window)
+ (switch-to-buffer buffer)
+ (setq buffer (get-buffer buffer))
+ (make-local-hook 'kill-buffer-hook)
+ (setq assign-window-buffer-window (cons window window-conf)
+ assign-window-buffer-buffers
+ (delq buffer (mapcar (function
+ (lambda (buffer)
+ (get-buffer buffer)))
+ other-buffers)))
+ (add-hook 'kill-buffer-hook 'assign-window-to-buffer-hook t t)
+ (setq assign-window-windows (cons (cons window buffer) assign-window-windows))
+ (set-window-dedicated-p window t))
+
+;;;FIXME: There's an emacs bug: If the dedicated window is the
+;;; right/top one of a split, killing the dedicated window will
+;;; result in the combined window having the dedicated flag
+;;; set. Workaround ???
+(defun assign-window-change-hook (frame)
+ (let ((p assign-window-windows)
+ (assign-window-hook-running t)
+ last)
+ (while p
+ (if (not (window-live-p (car (car p))))
+ (progn
+ (if (buffer-live-p (cdr (car p)))
+ (kill-buffer (cdr (car p))))
+ (if last
+ (setcdr last (cdr p))
+ (setq assign-window-windows (cdr p)))
+ (setq p (cdr p)))
+ (setq last p
+ p (cdr p))))))
+
+(if (not (memq 'assign-window-change-hook window-size-change-functions))
+ (setq window-size-change-functions
+ (cons 'assign-window-change-hook window-size-change-functions)))
+
+(defun assign-window-to-buffer-hook ()
+ (if (and (boundp 'assign-window-buffer-window)
+ (boundp 'assign-window-buffer-buffers))
+ (let ((window assign-window-buffer-window)
+ (buffers assign-window-buffer-buffers)
+ (old-assign-window-hook-running (and (boundp 'assign-window-hook-running)
+ assign-window-hook-running))
+ (assign-window-hook-running t))
+ (setq assign-window-windows
+ (delete-if (function
+ (lambda (x) (eq (cdr x) (current-buffer))))
+ assign-window-windows))
+ (if (window-live-p (car window))
+ (set-window-dedicated-p (car window) nil))
+ (if (cdr window)
+ (if (not old-assign-window-hook-running)
+ (set-window-configuration (cdr window)))
+ (if (window-live-p (car window))
+ (delete-window (car window))))
+ (if buffers
+ (mapcar (function (lambda (buffer)
+ (if (buffer-live-p buffer) (kill-buffer buffer))))
+ buffers)))))
+
+(defun save-split-window (&optional size horizontal)
+ "Split the current window vertically, horizontally if HORIZONTAL is
+non-nil, if the size of the current frame permits.
+
+size is passed to split-window-[horizontally|vertically] but adjusted
+using window-min-width or window-min-height respectively.
+
+The selected window will be the old one, i.e. the left/top one. The
+return value will be the new window, or nil if the window was not
+split."
+ (if (if horizontal
+ (> (window-width) (+ (* 2 window-min-width) 2))
+ (> (window-height) (+ (* 2 window-min-height) 1)))
+ (progn
+ (if size
+ (if (< size 0)
+ (if horizontal
+ (setq size (- (max window-min-width (- size))))
+ (setq size (- (max window-min-height (- size)))))
+ (if horizontal
+ (setq size (max window-min-width size))
+ (setq size (max window-min-height size)))))
+ (if horizontal
+ (split-window-horizontally size)
+ (split-window-vertically size)))))
+
+(defun open-dedicated-window (buffer &optional size horizontal)
+ "Open a new window visiting BUFFER. This new window will be assign
+to BUFFER using assign-window-to-buffer. If SIZE is given, it gives
+the size of the new window to open. By default the current window is
+split vertically. If HORIZONTAL is non-nil, the window is split
+horizontally.
+
+If SIZE is positive, the left/top window after splitting will be the
+new window, if SIZE is negative, the right/bottom window will be
+used. if SIZE is not nil and not a number, the right/bottom window
+will be used, but no explicit SIZE is requested.
+
+The selected buffer and window will be the newly opened window with
+it's bufer. The return value will be the window showing the buffer
+active before calling this function. If the window could not be split,
+because the frame is to small, BUFFER will be the selected buffer in
+the current window and the return value is nil."
+ (let ((size (and (numberp size) size))
+ (which (if (numberp size) (< size 0) size))
+ (wc (current-window-configuration))
+ this other)
+ (if (setq other (save-split-window size horizontal))
+ (if which
+ (progn
+ (setq this other
+ other (selected-window))
+ (select-window this))
+ (setq this (selected-window))))
+ (assign-window-to-buffer buffer (selected-window) wc)
+ other))
+
+(defun kill-most-buffers (arg)
+ "Kill all Buffers exept those in kill-most-buffers-nokill-list.
+
+If called with a negative prefix- argument, the current buffer will
+not be killed. If called with a positive prefix argument only
+non-displayed buffers are killed.
+
+Additionally will make all windows in all frames schow the `*scratch*'
+buffer."
+ (interactive "P")
+ (loop for buffer being the buffers
+ if (not (or (and arg
+ (if (> (prefix-numeric-value arg) 0)
+ (get-buffer-window buffer t)
+ (eq buffer (current-buffer))))
+ (member (buffer-name buffer)
+ kill-most-buffers-nokill-list)))
+ do (kill-buffer buffer))
+ (if (get-buffer "*scratch*")
+ (kill-buffer "*scratch*"))
+ (get-buffer-create "*scratch*")
+ (if (not (and arg (> (prefix-numeric-value arg) 0)))
+ (loop for window being the windows
+ if (not (and arg (eq window (selected-window))))
+ do (set-window-buffer window "*scratch*"))))
+
+(defmacro put-hashq (element hash)
+ "Place ELEMENT into HASH."
+ (let ((x (make-symbol "x"))
+ (y (make-symbol "y")))
+ `(let* ((,x ,element)
+ (,y (assq (car ,x) ,hash)))
+ (if ,y
+ (progn (setcdr ,y (cdr ,x)) ,y)
+ (progn (setf ,hash (cons ,x ,hash)) ,x)))))
+
+(defmacro put-hash (element hash)
+ "Place ELEMENT into HASH."
+ (let ((x (make-symbol "x"))
+ (y (make-symbol "y")))
+ `(let* ((,x ,element)
+ (,y (assoc (car ,x) ,hash)))
+ (if ,y
+ (progn (setcdr ,y (cdr ,x)) ,y)
+ (progn (setf ,hash (cons ,x ,hash)) ,x)))))
+
+(provide 'misc-local)
--- /dev/null
+;;; varcmd.el --- Flexible command handling
+;;
+;; $Id: varcmd.el,v 1.14 2000/02/26 10:20:47 bund Exp $
+;;
+;; Copyright (C) 1998 Stefan Bund
+
+;; varcmd.el 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 2, or (at your
+;; option) any later version.
+
+;; varcmd.el 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.
+
+;;; Commentary:
+
+;;; Change-Log:
+
+;; $Log: varcmd.el,v $
+;; Revision 1.14 2000/02/26 10:20:47 bund
+;; Support für separator und undefine aktualisiert
+;;
+;; Revision 1.13 2000/02/13 21:17:49 bund
+;; define-key-last implementiert und verwendet
+;; vcmd-define-menu implementiert
+;;
+;; Revision 1.12 2000/01/26 15:32:08 bund
+;; call-interactively anstelle von command-execute verwenden
+;; backquote in vcmd-bind-menu
+;;
+;; Revision 1.11 2000/01/08 16:13:23 bund
+;; vcmd-flag-handler implementiert
+;;
+;; Revision 1.10 1999/11/22 14:30:18 bund
+;; Weitere XEmacs anpassungen
+;;
+;; Revision 1.9 1999/08/03 07:55:33 bund
+;; erste (alpha) anpassung an xemacs
+;;
+;; Revision 1.8 1999/05/07 11:40:31 bund
+;; noforms implementiert
+;;
+;; Revision 1.7 1998/09/03 11:25:29 bund
+;; added 'expression vcmd type
+;;
+;; Revision 1.6 1998/07/11 19:17:53 bund
+;; BUGFIX: seperator->separator :-)
+;;
+;; Revision 1.5 1998/07/06 09:08:37 bund
+;; added 'separator to vcmd-bind-menu
+;;
+;; Revision 1.4 1998/07/03 08:56:16 bund
+;; add menu-bar items added by vcmd-define-entry to menu-bar-final-items
+;;
+;; Revision 1.3 1998/06/26 15:41:29 bund
+;; BUGFIX: nil-command interpreted correctly
+;;
+;; Revision 1.2 1998/06/22 08:55:34 bund
+;; new semantics for handlers: Call with the args to the handler symbol
+;; as arguments, not with a list of the arguments
+;; modulized vcmd-define-key
+;;
+;; Revision 1.1 1998/06/19 10:44:50 bund
+;; added varcmd.el
+;;
+;;
+
+;;; Variables:
+
+(defvar vcmd-handlers
+ '((function . vcmd-call-function)
+ (lambda . vcmd-call-lambda-expression)
+ (macro . cvmd-call-kbd-macro)
+ (value . vcmd-return-value)
+ (expression . vcmd-expression))
+ "Alist of handlers for different command types")
+
+(defvar vcmd-flag-handlers nil
+ "Alist of flag handlers for differnt flags")
+
+(defvar vcmd-command-symbol 0
+ "Sequence number for generation of unique command names")
+
+;;; Code:
+
+(defun vcmd (command &optional value interactive)
+ "Call COMMAND as en extended command as defined in vcmd-handlers.
+
+If COMMAND is a cons cell and the car of COMMAND can be found in vcmd-handlers,
+the COMMAND is executed by passing the cdr of COMMAND to the handler found in
+vcmd-handlers. vcmd then returns the return value of the handler.
+
+If no handler is found, and optional VALUE is non-nil, the return value of
+vcmd is COMMAND.
+
+If VALUE is not given or is nil, then COMMAND should be an executable entry,
+e.g. a symbol or an array (keyboard macro).
+
+If INTERACTIVE is non-nil, then the function is called interactively. If
+a handler is used to execute the command, the handler is passed t as second arg."
+ (if (consp command)
+ (let ((handler (cdr (assq (car command) vcmd-handlers))))
+ (if handler
+ (apply handler interactive (cdr command))
+ command))
+ (if value
+ command
+ (if (arrayp command)
+ (execute-kbd-macro command)
+ (if interactive
+ (if (commandp command)
+ (call-interactively command)
+ (funcall command))
+ (funcall command))))))
+
+(defun vcmd-call-function (interactive fn &rest args)
+ "Call (car ARG) or ARG as function, suplying (cdr ARG) as arguments.
+If ARG is a consp then if INTERACTIVE is non-nil, (cdr ARG) is non-nil
+and (car ARG) is a command, call function with command-execute otherwise
+use apply.
+
+If ARG is not a cons cell, call ARG with command-execute, if it is a
+command, otherwise use funcall."
+ (if (and interactive
+ (null args)
+ (commandp fn))
+ (command-execute fn)
+ (apply fn args)))
+
+(defun vcmd-call-lambda-expression (interactive &rest body)
+ "call ARG as a lambda expression (without leading lambda).
+If INTERACTIVE is non-nil and (cons 'lambda ARG) is a command, use
+command-execute, otherwise use funcall."
+ (if (and interactive
+ (commandp (cons 'lambda body)))
+ (command-execute (cons 'lambda body))
+ (funcall (cons 'lambda body))))
+
+(defun vcmd-call-kbd-macro (interactive macro)
+ "call ARG as keyboard macro"
+ (execute-kbd-macro macro))
+
+(defun vcmd-return-value (interactive value)
+ "return ARG as return value"
+ value)
+
+(defun vcmd-expression (interactive &rest expression)
+ (eval (cons 'progn expression)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun vcmd-encapsulate-fn (definition forms)
+ "Encapsulate call of DEFINITION using vcmd and return the
+lambda expression."
+ (let ((flag (and (consp definition)
+ (assq (car definition) vcmd-flag-handlers))))
+ (if flag
+ (funcall (cdr flag) (cdr definition) forms)
+ (append forms
+ (list (list 'vcmd
+ (list 'quote
+ definition)
+ nil
+ t))))))
+
+(defun vcmd-get-symbol (definition &rest forms)
+ "Fetch a new symbol and set it's function definition to a call of
+DEFINITION. If FORMS is non-nil, theese forms are executed prior to
+calling DEFINITION. If DEFINITION is nil, an unbound symbol is returned."
+ (setq vcmd-command-symbol (1+ vcmd-command-symbol))
+ (let ((sym (intern (concat "vcmd-cmd-"
+ (number-to-string vcmd-command-symbol)))))
+ (fset sym `(lambda ()
+ (interactive)
+ (let ((current-prefix-arg current-prefix-arg))
+ ,@(vcmd-encapsulate-fn definition forms))))
+ sym))
+
+(defun define-key-last (keymap key def)
+ "Like define-key, mat make KEY the last entry in KEYMAP instead of
+the first. KEY must contain just one event."
+ (let ((last-key (loop for def in (reverse keymap)
+ if (and (consp def)
+ (not (eq (car def) t)))
+ return (car def)
+ finally return nil)))
+ (if last-key
+ (define-key-after keymap key def last-key)
+ (define-key keymap key def))))
+
+(defun vcmd-bind-menu-FSF (keymap binding &rest menu)
+ "Define the menu entry descripbed by MENU in KEYMAP to BINDING.
+If (car MENU) is a consp, use (car MENU) as menu list, otherwise use
+MENU."
+ (setq menu (apply 'append
+ (mapcar '(lambda (x)
+ (if (consp x)
+ x
+ (list x)))
+ menu)))
+ (while (cdr menu)
+ (let* ((menu-symbol (if (symbolp (car menu))
+ (car menu)
+ (intern (car menu))))
+ (menu-name (if (symbolp (car menu))
+ (symbol-name (car menu))
+ (car menu)))
+ (next-keymap (lookup-key keymap (vector menu-symbol))))
+ (if next-keymap
+ (setq keymap next-keymap)
+ (define-key-last
+ keymap
+ (vector menu-symbol)
+ (cons menu-name
+ (setq next-keymap (make-sparse-keymap menu-name))))
+ (setq keymap next-keymap))
+ (setq menu (cdr menu))))
+ (if menu
+ (if (eq (car menu) 'separator)
+ (define-key-last
+ keymap
+ (vector (vcmd-get-symbol nil))
+ '("--" . nil))
+ (if binding
+ (if (symbolp (car menu))
+ (define-key-last
+ keymap
+ (vector (car menu))
+ (cons (symbol-name (car menu))
+ binding))
+ (define-key-last
+ keymap
+ (vector (intern (car menu)))
+ (cons (car menu)
+ binding)))))))
+
+(defun vcmd-bind-menu-lucid (keymap binding &rest menu)
+ "Define the menu entry descripbed by MENU in KEYMAP to BINDING.
+If (car MENU) is a consp, use (car MENU) as menu list, otherwise use
+MENU."
+ (setq menu (apply 'append
+ (mapcar '(lambda (x)
+ (if (consp x)
+ x
+ (list x)))
+ menu)))
+ (setq menu (nreverse (cdr menu)))
+ (apply 'add-menu-button
+ (reverse (cdr menu))
+ (list (vector (if (eq (car menu) 'separator)
+ "--"
+ (if (symbolp (car menu))
+ (symbol-name (car menu))
+ (car menu)))
+ binding
+ ':active t)))
+ (set-menubar-dirty-flag))
+
+(defun vcmd-bind-key (keymap binding sequence)
+ (if binding
+ (define-key keymap sequence binding)))
+
+(defun vcmd-bind-entry (keymap sequence command forms menu)
+ "Bind SEQUENCE and MENU in KEYMAP to COMMAND. Before calling
+COMMAND, FORMS will be executed."
+ (let ((fn (if command (apply 'vcmd-get-symbol command forms))))
+ (if sequence
+ (vcmd-bind-key keymap fn sequence))
+ (if menu
+ (let ((symbol (if (symbolp (car menu))
+ (car menu)
+ (intern (car menu)))))
+ (vcmd-bind-menu keymap fn (cons 'menu-bar menu))))))
+
+(defun vcmd-define-key (keymap sequence command &rest menu)
+ "Bind key SEQUENCE in KEYMAP to COMMAND indirectly using vcmd."
+ (vcmd-bind-entry keymap sequence command nil menu))
+
+(defun vcmd-global-set-key (sequence command &rest menu)
+ "Bind SEQUENCE to COMMAND and possibly MENU in the global keymap.
+
+See vvmd-define-key for further documentation."
+ (apply 'vcmd-define-key global-map sequence command menu))
+
+;;;###autoload
+(defun vcmd-define-menu (keymap sequence commands &rest menu)
+ "COMMANDS must be a list of lists of the form
+
+ (tag menu command)
+
+SEQUENCE is bound to a function, which alows the user to select a
+tag. The menu entries of the commands will appear as a submenu under
+MENU."
+ (let ((menu-keymap (and (car menu) (make-sparse-keymap (car menu)))))
+ (if (and menu-keymap commands)
+ (progn
+ (loop for command in (reverse commands)
+ do (define-key
+ menu-keymap
+ (vector (intern (car command)))
+ (cons (cadr command)
+ (vcmd-get-symbol (caddr command)))))
+ (if sequence
+ (setf (car (last menu))
+ (concat (car (last menu))
+ " ("
+ (key-description sequence)
+ ")")))
+ (vcmd-bind-menu keymap
+ menu-keymap
+ (cons 'menu-bar menu))))
+ (if (and sequence commands)
+ (vcmd-bind-key global-map
+ `(lambda () (interactive) (vcmd-select-command ',commands))
+ sequence))))
+
+(defun vcmd-select-command (commands)
+ (let ((tag (completing-read "Command: "
+ (mapcar (function (lambda (x) (cons (car x) (cadr x))))
+ commands)
+ nil t)))
+ (vcmd (caddr (assoc tag commands)) nil t)))
+
+(defun vcmd-handler (type handler)
+ "Install HANDLER as handler for TYPE.
+
+HANDLER must be a function callable with two arguments, the additional
+arguments from the vcmd call and an interactive flag, which is set
+on interactive call."
+ (let ((h (assq type vcmd-handlers)))
+ (if h
+ (setcdr h handler)
+ (setq vcmd-handlers (cons (cons type handler)
+ vcmd-handlers)))))
+
+(defun vcmd-flag-handler (flag handler)
+ "Install HANDLER as flag-handler for FLAG.
+
+HANDLER must be a function callable with two arguments: the definition
+of a vcmd binding and an aditional list of lisp-forms to evaluate
+before the vcmd binding. The return value of HANDLER must be a lisp
+form evaluating the above mentioned expressions. Normally HANDLER will
+call vcmd-encapsulate-fn on its arguments and wrap the result into
+additional lisp forms."
+ (let ((h (assq flag vcmd-flag-handlers)))
+ (if h
+ (setcdr h handler)
+ (setq vcmd-flag-handlers (cons (cons flag handler)
+ vcmd-flag-handlers)))))
+
+(fset 'vcmd-bind-menu
+ (if (string-match "XEmacs" emacs-version)
+ (symbol-function 'vcmd-bind-menu-lucid)
+ (symbol-function 'vcmd-bind-menu-FSF)))
+
+(provide 'varcmd)
+
+\f
+;;; Local Variables:
+;;; elisp-project-autoload-file-name: "varcmd-autoload.el"
+;;; End:
projects / emacsstuff.git / commitdiff