1 ;;; semantic-ia-utest.el --- Analyzer unit tests
3 ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; Use marked-up files in the test directory and run the analyzer
25 ;; on them. Make sure the answers are correct.
27 ;; Each file has cursor keys in them of the form:
28 ;; // -#- ("ans1" "ans2" )
29 ;; where # is 1, 2, 3, etc, and some sort of answer list.
33 (require 'semantic
/analyze
)
34 (require 'semantic
/analyze
/refs
)
35 (require 'semantic
/symref
)
36 (require 'semantic
/symref
/filter
)
38 (load-file "cedet-utests.el")
40 (defvar semantic-ia-utest-file-list
42 "tests/testdoublens.cpp"
43 "tests/testsubclass.cpp"
44 "tests/testtypedefs.cpp"
45 "tests/testfriends.cpp"
47 "tests/testsppcomplete.c"
48 "tests/testvarnames.c"
49 "tests/testjavacomp.java"
51 "List of files with analyzer completion test points.")
53 (defvar semantic-ia-utest-error-log-list nil
54 "List of errors occurring during a run.")
57 (defun semantic-ia-utest (&optional arg
)
58 "Run the semantic ia unit test against stored sources.
59 Argument ARG specifies which set of tests to run.
63 4 - symref count utests"
67 (let ((fl semantic-ia-utest-file-list
)
68 (semantic-ia-utest-error-log-list nil
)
71 (cedet-utest-log-setup "ANALYZER")
73 (set-buffer (semantic-find-file-noselect
74 (or (locate-library "semantic-ia-utest.el")
75 "semantic-ia-utest.el")))
79 ;; Make sure we have the files we think we have.
80 (when (not (file-exists-p (car fl
)))
81 (error "Cannot find unit test file: %s" (car fl
)))
84 (let ((fb (find-buffer-visiting (car fl
)))
85 (b (semantic-find-file-noselect (car fl
) t
)))
87 ;; Run the test on it.
91 ;; This line will also force the include, scope, and typecache.
92 (semantic-clear-toplevel-cache)
93 ;; Force tags to be parsed.
96 (semantic-ia-utest-log " ** Starting tests in %s"
99 (when (or (not arg
) (= arg
1))
100 (semantic-ia-utest-buffer))
102 (when (or (not arg
) (= arg
2))
104 (semantic-ia-utest-buffer-refs))
106 (when (or (not arg
) (= arg
3))
108 (semantic-sr-utest-buffer-refs))
110 (when (or (not arg
) (= arg
4))
112 (semantic-src-utest-buffer-refs))
114 (semantic-ia-utest-log " ** Completed tests in %s\n"
118 ;; If it wasn't already in memory, whack it.
124 (cedet-utest-log-shutdown
126 (when semantic-ia-utest-error-log-list
127 (format "%s Failures found."
128 (length semantic-ia-utest-error-log-list
))))
129 (when semantic-ia-utest-error-log-list
130 (error "Failures found during analyzer unit tests"))
134 (defun semantic-ia-utest-buffer ()
135 "Run analyzer completion unit-test pass in the current buffer."
146 ;; Exclude unpredictable system files in the
147 ;; header include list.
148 (semanticdb-find-default-throttle
149 (remq 'system semanticdb-find-default-throttle
))
151 ;; Keep looking for test points until we run out.
152 (while (save-excursion
153 (setq regex-p
(concat "//\\s-*-" (number-to-string idx
) "-" )
154 regex-a
(concat "//\\s-*#" (number-to-string idx
) "#" ))
155 (goto-char (point-min))
157 (when (re-search-forward regex-p nil t
)
158 (setq p
(match-beginning 0))))
160 (when (re-search-forward regex-a nil t
)
161 (setq a
(match-end 0))))
168 (let* ((ctxt (semantic-analyze-current-context))
171 (semantic-analyze-possible-completions ctxt
)
173 (setq actual
(mapcar 'semantic-tag-name acomp
)))
177 (let ((bss (buffer-substring-no-properties (point) (point-at-eol))))
179 (setq desired
(read bss
))
180 (error (setq desired
(format " FAILED TO PARSE: %S"
183 (if (equal actual desired
)
184 (setq pass
(cons idx pass
))
185 (setq fail
(cons idx fail
))
186 (semantic-ia-utest-log
187 " Failed %d. Desired: %S Actual %S"
189 (add-to-list 'semantic-ia-utest-error-log-list
190 (list (buffer-name) idx desired actual
)
201 (semantic-ia-utest-log
202 " Unit tests (completions) failed tests %S"
205 (semantic-ia-utest-log " Unit tests (completions) passed (%d total)"
210 (defun semantic-ia-utest-buffer-refs ()
211 "Run an analyze-refs unit-test pass in the current buffer."
218 ;; Exclude unpredictable system files in the
219 ;; header include list.
220 (semanticdb-find-default-throttle
221 (remq 'system semanticdb-find-default-throttle
))
223 ;; Keep looking for test points until we run out.
224 (while (save-excursion
225 (setq regex-p
(concat "//\\s-*\\^" (number-to-string idx
) "^" )
227 (goto-char (point-min))
229 (when (re-search-forward regex-p nil t
)
230 (setq p
(match-beginning 0))))
238 (let* ((ct (semantic-current-tag))
239 (refs (semantic-analyze-tag-references ct
))
240 (impl (semantic-analyze-refs-impl refs t
))
241 (proto (semantic-analyze-refs-proto refs t
))
247 (if (and impl proto
(car impl
) (car proto
))
248 (let (ct2 ref2 impl2 proto2
251 ((semantic-equivalent-tag-p (car impl
) ct
)
252 ;; We are on an IMPL. Go To the proto, and find matches.
253 (semantic-go-to-tag (car proto
))
254 (setq newstart
(car proto
))
256 ((semantic-equivalent-tag-p (car proto
) ct
)
257 ;; We are on a PROTO. Go to the imple, and find matches
258 (semantic-go-to-tag (car impl
))
259 (setq newstart
(car impl
))
262 ;; No matches is a fail.
265 ;; Get the new tag, does it match?
266 (setq ct2
(semantic-current-tag))
269 (when (not (semantic-equivalent-tag-p ct2 newstart
))
272 ;; Can we double-jump?
273 (setq ref2
(semantic-analyze-tag-references ct
)
274 impl2
(semantic-analyze-refs-impl ref2 t
)
275 proto2
(semantic-analyze-refs-proto ref2 t
))
277 (when (or (not (and impl2 proto2
))
279 (and (semantic-equivalent-tag-p
280 (car impl
) (car impl2
))
281 (semantic-equivalent-tag-p
282 (car proto
) (car proto2
)))))
286 ;; Else, no matches at all, so another fail.
292 (setq pass
(cons idx pass
))
294 (setq fail
(cons idx fail
))
295 (semantic-ia-utest-log
296 " Failed %d. For %s (Num impls %d) (Num protos %d)"
297 idx
(if ct
(semantic-tag-name ct
) "<No tag found>")
298 (length impl
) (length proto
))
299 (add-to-list 'semantic-ia-utest-error-log-list
300 (list (buffer-name) idx
)
311 (semantic-ia-utest-log
312 " Unit tests (refs) failed tests")
314 (semantic-ia-utest-log " Unit tests (refs) passed (%d total)"
319 (defun semantic-sr-utest-buffer-refs ()
320 "Run a symref unit-test pass in the current buffer."
322 ;; This line will also force the include, scope, and typecache.
323 (semantic-clear-toplevel-cache)
324 ;; Force tags to be parsed.
325 (semantic-fetch-tags)
335 (symref-tool-used nil
)
336 ;; Exclude unpredictable system files in the
337 ;; header include list.
338 (semanticdb-find-default-throttle
339 (remq 'system semanticdb-find-default-throttle
))
341 ;; Keep looking for test points until we run out.
342 (while (save-excursion
343 (setq regex-p
(concat "//\\s-*\\%" (number-to-string idx
) "%" )
345 (goto-char (point-min))
347 (when (re-search-forward regex-p nil t
)
348 (setq tag
(semantic-current-tag))
349 (goto-char (match-end 0))
350 (setq desired
(read (buffer-substring (point) (point-at-eol))))
354 (setq actual-result
(semantic-symref-find-references-by-name
355 (semantic-tag-name tag
) 'target
358 (if (not actual-result
)
360 (setq fail
(cons idx fail
))
361 (semantic-ia-utest-log
362 " Failed FNames %d: No results." idx
)
363 (semantic-ia-utest-log
364 " Failed Tool: %s" (object-name symref-tool-used
))
366 (add-to-list 'semantic-ia-utest-error-log-list
367 (list (buffer-name) idx
)
371 (setq actual
(list (sort (mapcar
372 'file-name-nondirectory
373 (semantic-symref-result-get-files actual-result
))
377 'semantic-format-tag-canonical-name
378 (semantic-symref-result-get-tags actual-result
))
382 (if (equal desired actual
)
384 (setq pass
(cons idx pass
))
386 (setq fail
(cons idx fail
))
387 (when (not (equal (car actual
) (car desired
)))
388 (semantic-ia-utest-log
389 " Failed FNames %d: Actual: %S Desired: %S"
390 idx
(car actual
) (car desired
))
391 (semantic-ia-utest-log
392 " Failed Tool: %s" (object-name symref-tool-used
))
394 (when (not (equal (car (cdr actual
)) (car (cdr desired
))))
395 (semantic-ia-utest-log
396 " Failed TNames %d: Actual: %S Desired: %S"
397 idx
(car (cdr actual
)) (car (cdr desired
)))
398 (semantic-ia-utest-log
399 " Failed Tool: %s" (object-name symref-tool-used
))
401 (add-to-list 'semantic-ia-utest-error-log-list
402 (list (buffer-name) idx
)
411 (semantic-ia-utest-log
412 " Unit tests (symrefs) failed tests")
414 (semantic-ia-utest-log " Unit tests (symrefs) passed (%d total)"
419 (defun semantic-src-utest-buffer-refs ()
420 "Run a sym-ref counting unit-test pass in the current buffer."
422 ;; This line will also force the include, scope, and typecache.
423 (semantic-clear-toplevel-cache)
424 ;; Force tags to be parsed.
425 (semantic-fetch-tags)
434 ;; Exclude unpredictable system files in the
435 ;; header include list.
436 (semanticdb-find-default-throttle
437 (remq 'system semanticdb-find-default-throttle
))
439 ;; Keep looking for test points until we run out.
440 (while (save-excursion
441 (setq regex-p
(concat "//\\s-*@"
442 (number-to-string idx
)
443 "@\\s-+\\(\\w+\\)" ))
444 (goto-char (point-min))
446 (when (re-search-forward regex-p nil t
)
447 (goto-char (match-beginning 1))
448 (setq desired
(read (buffer-substring (point) (point-at-eol))))
449 (setq start
(match-beginning 0))
451 (setq actual
(semantic-symref-test-count-hits-in-tag))
456 (setq fail
(cons idx fail
))
457 (semantic-ia-utest-log
458 " Failed symref count %d: No results." idx
)
460 (add-to-list 'semantic-ia-utest-error-log-list
461 (list (buffer-name) idx
)
465 (if (equal desired actual
)
467 (setq pass
(cons idx pass
))
469 (setq fail
(cons idx fail
))
470 (when (not (equal actual desired
))
471 (semantic-ia-utest-log
472 " Failed symref count %d: Actual: %S Desired: %S"
476 (add-to-list 'semantic-ia-utest-error-log-list
477 (list (buffer-name) idx
)
486 (semantic-ia-utest-log
487 " Unit tests (symrefs counter) failed tests")
489 (semantic-ia-utest-log " Unit tests (symrefs counter) passed (%d total)"
494 (defun semantic-ia-utest-start-log ()
495 "Start up a testlog for a run."
496 ;; Redo w/ CEDET utest framework.
497 (cedet-utest-log-start "semantic: analyzer tests"))
499 (defun semantic-ia-utest-log (&rest args
)
500 "Log some test results.
501 Pass ARGS to format to create the log message."
502 ;; Forward to CEDET utest framework.
503 (apply 'cedet-utest-log args
))
505 (provide 'semantic-ia-utest
)
507 ;; arch-tag: 03ede3fb-7ef0-4500-a7c2-bbf647957310
508 ;;; semantic-ia-utest.el ends here