1 ;;; ada-fix-error.el --- utilities for automatically fixing -*- lexical-binding:t -*-
2 ;; errors reported by the compiler.
4 ;; Copyright (C) 1999-2009, 2012-2015 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 excluding leading pragmas. Called with no arguments;
41 return (BEGIN . END). BEGIN and END must be at beginning of line.
42 If there is no context clause, BEGIN = END, at start of
45 (defun ada-fix-context-clause ()
46 (when ada-fix-context-clause
47 (funcall ada-fix-context-clause)))
49 (defun ada-fix-insert-unit-name (unit-name)
50 "Insert UNIT-NAME at point and capitalize it."
51 ;; unit-name is normally gotten from a file-name, and is thus all lower-case.
52 (let ((start-point (point))
55 (setq search-bound (point))
56 (insert " ") ; separate from following words, if any, for ada-case-adjust-identifier
57 (goto-char start-point)
58 (while (search-forward "." search-bound t)
60 (ada-case-adjust-identifier)
62 (goto-char search-bound)
63 (ada-case-adjust-identifier)
66 (defun ada-fix-sort-context-pred (a b)
67 "Predicate for `sort-subr'; sorts \"limited with\", \"private with\" last.
68 Returns non-nil if a should preceed b in buffer."
69 ;; a, b are buffer ranges in the current buffer
73 (string= pat (buffer-substring-no-properties (car reg)
75 (+(car reg) (length pat)))))))
78 (starts-with "limited with" a)
79 (starts-with "private with" b))
83 (starts-with "limited with" a)
84 (not (starts-with "limited with" b)))
88 (not (starts-with "limited with" a))
89 (starts-with "limited with" b))
93 (starts-with "private with" a)
94 (not (starts-with "private with" b)))
98 (not (starts-with "private with" a))
99 (starts-with "private with" b))
103 (> 0 (compare-buffer-substrings
105 nil (car b) (cdr b))) )
108 (defun ada-fix-sort-context-clause (beg end)
109 "Sort context clauses in range BEG END."
112 (narrow-to-region beg end)
113 (goto-char (point-min))
114 (sort-subr nil 'forward-line 'end-of-line nil nil 'ada-fix-sort-context-pred)
117 (defun ada-fix-add-with-clause (package-name)
118 "Add a with_clause for PACKAGE_NAME.
119 If ada-fix-sort-context-clause, sort the context clauses using
121 (let ((context-clause (ada-fix-context-clause)))
122 (when (not context-clause)
123 (error "no compilation unit found"))
125 (goto-char (cdr context-clause))
127 (ada-fix-insert-unit-name package-name)
130 (when (and (< (car context-clause) (cdr context-clause))
131 ada-fix-sort-context-clause)
132 (ada-fix-sort-context-clause (car context-clause) (point)))
135 (defun ada-fix-extend-with-clause (child-name)
136 "Assuming point is in a selected name, just before CHILD-NAME, add or
137 extend a with_clause to include CHILD-NAME . "
138 (let ((parent-name-end (point)))
139 ;; Find the full parent name; skip back to whitespace, then match
141 (skip-syntax-backward "w_.")
142 (search-forward-regexp ada-name-regexp parent-name-end)
143 (let ((parent-name (match-string 0))
144 (context-clause (ada-fix-context-clause)))
145 (goto-char (car context-clause))
146 (if (search-forward-regexp (concat "^with " parent-name ";") (cdr context-clause) t)
147 ;; found exisiting 'with' for parent; extend it
149 (forward-char -1) ; skip back over semicolon
150 (insert "." child-name))
152 ;; not found; we are in a package body, with_clause for parent is in spec.
154 (ada-fix-add-with-clause (concat parent-name "." child-name)))
157 (defun ada-fix-add-use-type (type)
158 "Insert `use type' clause for TYPE at start of declarative part for current construct."
159 (ada-goto-declarative-region-start); leaves point after 'is'
161 (insert "use type " type ";")
164 (indent-according-to-mode))
166 (defun ada-fix-add-use (package)
167 "Insert `use' clause for PACKAGE at start of declarative part for current construct."
168 (ada-goto-declarative-region-start); leaves point after 'is'
170 (insert "use " package ";")
173 (indent-according-to-mode))
175 (defvar ada-fix-error-hook nil
176 ;; determined by ada_compiler, set by *-select-prj-compiler
177 "Hook to recognize and fix errors.
178 Hook functions are called with three args:
180 MSG, the `compilation--message' struct for the current error
182 SOURCE-BUFFER, the buffer containing the source to be fixed
184 SOURCE-WINDOW, the window displaying SOURCE-BUFFER.
186 Point in SOURCE-BUFFER is at error location; point in
187 `compilation-last-buffer' is at MSG location. Focus is in
190 Hook functions should return t if the error is recognized and
191 fixed, leaving point at fix. Otherwise, they should preserve
192 point and return nil.")
194 (defun ada-get-compilation-message ()
195 "Get compilation message at line beginning."
196 (get-text-property (line-beginning-position) 'compilation-message))
198 (defun ada-fix-compiler-error ()
199 "Attempt to fix the current compiler error. Leave point at fixed code."
202 (let ((source-buffer (current-buffer))
203 (source-window (selected-window))
204 (line-move-visual nil)); screws up next-line otherwise
206 (with-current-buffer compilation-last-buffer
207 (when (not (ada-get-compilation-message))
209 (message "FIXME: ada-fix-compiler-error")
210 ;; not clear why this can happen, but it has
211 (compilation-next-error 1))
212 (let ((comp-buf-pt (point))
214 (run-hook-with-args-until-success
216 (compilation-next-error 0)
219 ;; restore compilation buffer point
220 (set-buffer compilation-last-buffer)
221 (goto-char comp-buf-pt)
224 ;; none of the hooks handled the error
225 (error "error not recognized"))
228 (provide 'ada-fix-error)