From: g0dil Date: Wed, 11 Oct 2006 10:14:52 +0000 (+0000) Subject: Added emacs cc-ide X-Git-Url: http://g0dil.de/git?p=emacsstuff.git;a=commitdiff_plain;h=ffb936d8c31bf8c466cc4130d701dd991548355a Added emacs cc-ide --- ffb936d8c31bf8c466cc4130d701dd991548355a diff --git a/cc-ide/cc-engine-2.el b/cc-ide/cc-engine-2.el new file mode 100644 index 0000000..a9ac744 --- /dev/null +++ b/cc-ide/cc-engine-2.el @@ -0,0 +1,923 @@ +;;; 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) + + +;;; Local Variables: +;;; elisp-project-autoload-file-name: "cc-autoload.el" +;;; End: diff --git a/cc-ide/cc-helper.el b/cc-ide/cc-helper.el new file mode 100644 index 0000000..e25f2e2 --- /dev/null +++ b/cc-ide/cc-helper.el @@ -0,0 +1,393 @@ +;;; 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) + + +;;; Local Variables: +;;; elisp-project-autoload-file-name: "cc-autoload.el" +;;; End: diff --git a/cc-ide/cc-ide.el b/cc-ide/cc-ide.el new file mode 100644 index 0000000..558a606 --- /dev/null +++ b/cc-ide/cc-ide.el @@ -0,0 +1,1417 @@ +;;; 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 \n" + "#include \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 \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)))))))) + + + +;;; Local Variables: +;;; elisp-project-autoload-file-name: "cc-autoload.el" +;;; End: diff --git a/g0dilstuff-init.el b/g0dilstuff-init.el new file mode 100644 index 0000000..b804c87 --- /dev/null +++ b/g0dilstuff-init.el @@ -0,0 +1,35 @@ +;;; 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) diff --git a/lib/misc-local.el b/lib/misc-local.el new file mode 100644 index 0000000..a5141b4 --- /dev/null +++ b/lib/misc-local.el @@ -0,0 +1,454 @@ +;; 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) diff --git a/lib/varcmd.el b/lib/varcmd.el new file mode 100644 index 0000000..fd22375 --- /dev/null +++ b/lib/varcmd.el @@ -0,0 +1,363 @@ +;;; 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) + + +;;; Local Variables: +;;; elisp-project-autoload-file-name: "varcmd-autoload.el" +;;; End: