1 ;;; ada-fix-error.el --- utilities for automatically fixing
2 ;; errors reported by the compiler.
4 ;; Copyright (C) 1999-2009, 2012-2014 Free Software Foundation, Inc.
6 ;; Author : Stephen Leake <Stephen_Leake@stephe-leake.org>
7 ;; Maintainer : Stephen Leake <Stephen_Leake@stephe-leake.org>
8 ;; Web site : http://www.stephe-leake.org/
9 ;; Keywords : languages ada error
11 ;; This file is part of GNU Emacs
13 ;; This program is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 3, or (at your option)
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to
25 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
33 (defcustom ada-fix-sort-context-clause t
34 "*If non-nil, sort context clause when inserting 'with'"
38 (defvar ada-fix-context-clause nil
39 "Function to return the region containing the context clause for the current buffer.
40 Called with no arguments; return (BEGIN . END). BEGIN and
41 END must be at beginning of line. If there is no context
42 clause, BEGIN = END, at start of compilation unit.")
44 (defun ada-fix-context-clause ()
45 (when ada-fix-context-clause
46 (funcall ada-fix-context-clause)))
48 (defun ada-fix-insert-unit-name (unit-name)
49 "Insert UNIT-NAME at point and capitalize it."
50 ;; unit-name is normally gotten from a file-name, and is thus all lower-case.
51 (let ((start-point (point))
54 (setq search-bound (point))
55 (insert " ") ; separate from following words, if any, for ada-case-adjust-identifier
56 (goto-char start-point)
57 (while (search-forward "." search-bound t)
59 (ada-case-adjust-identifier)
61 (goto-char search-bound)
62 (ada-case-adjust-identifier)
65 (defun ada-fix-add-with-clause (package-name)
66 "Add a with_clause for PACKAGE_NAME.
67 If ada-fix-sort-context-clause, sort the context clauses using
69 (let ((context-clause (ada-fix-context-clause)))
70 (when (not context-clause)
71 (error "no compilation unit found"))
73 (goto-char (cdr context-clause))
75 (ada-fix-insert-unit-name package-name)
78 (when (and (< (car context-clause) (cdr context-clause))
79 ada-fix-sort-context-clause)
80 ;; FIXME (later): this puts "limited with", "private with" at top of list; prefer at bottom
81 (sort-lines nil (car context-clause) (point)))
84 (defun ada-fix-extend-with-clause (child-name)
85 "Assuming point is in a selected name, just before CHILD-NAME, add or
86 extend a with_clause to include CHILD-NAME . "
87 (let ((parent-name-end (point)))
88 ;; Find the full parent name; skip back to whitespace, then match
90 (skip-syntax-backward "w_.")
91 (search-forward-regexp ada-name-regexp parent-name-end)
92 (let ((parent-name (match-string 0))
93 (context-clause (ada-fix-context-clause)))
94 (goto-char (car context-clause))
95 (if (search-forward-regexp (concat "^with " parent-name ";") (cdr context-clause) t)
96 ;; found exisiting 'with' for parent; extend it
98 (forward-char -1) ; skip back over semicolon
99 (insert "." child-name))
101 ;; not found; we are in a package body, with_clause for parent is in spec.
103 (ada-fix-add-with-clause (concat parent-name "." child-name)))
106 (defun ada-fix-add-use-type (type)
107 "Insert 'use type' clause for TYPE at start of declarative part for current construct."
108 (ada-goto-declarative-region-start); leaves point after 'is'
110 (insert "use type " type ";")
113 (indent-according-to-mode))
115 (defun ada-fix-add-use (package)
116 "Insert 'use' clause for PACKAGE at start of declarative part for current construct."
117 (ada-goto-declarative-region-start); leaves point after 'is'
119 (insert "use " package ";")
122 (indent-according-to-mode))
124 (defvar ada-fix-error-hook nil
125 ;; determined by ada_compiler, set by *-select-prj-compiler
126 "Hook to recognize and fix errors.
127 Hook functions are called with three args:
129 MSG, the `compilation--message' struct for the current error
131 SOURCE-BUFFER, the buffer containing the source to be fixed
133 SOURCE-WINDOW, the window displaying SOURCE-BUFFER.
135 Point in SOURCE-BUFFER is at error location; point in
136 `compilation-last-buffer' is at MSG location. Focus is in
139 Hook functions should return t if the error is recognized and
140 fixed, leaving point at fix. Otherwise, they should preserve
141 point and return nil.")
143 (defun ada-get-compilation-message ()
144 "Get compilation message at point.
145 Compatible with Emacs 23.4 and 24.x."
146 (cl-case emacs-major-version
147 (23 (get-text-property (point) 'message))
148 (24 (get-text-property (point) 'compilation-message))))
150 (defun ada-fix-compiler-error ()
151 "Attempt to fix the current compiler error. Leave point at fixed code."
154 (let ((source-buffer (current-buffer))
155 (source-window (selected-window))
156 (line-move-visual nil)); screws up next-line otherwise
158 (with-current-buffer compilation-last-buffer
159 (when (not (ada-get-compilation-message))
160 ;; not clear why this can happens, but it does
161 (compilation-next-error 1))
162 (let ((comp-buf-pt (point))
164 (run-hook-with-args-until-success
166 (compilation-next-error 0)
169 ;; restore compilation buffer point
170 (set-buffer compilation-last-buffer)
171 (goto-char comp-buf-pt)
174 ;; none of the hooks handled the error
175 (error "error not recognized"))
178 (provide 'ada-fix-error)