1 ;;; semantic-ia-utest.el --- Analyzer unit tests
3 ;; Copyright (C) 2008, 2009 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/teststruct.cpp"
46 "tests/testtemplates.cpp"
47 "tests/testfriends.cpp"
50 "tests/testsppcomplete.c"
51 "tests/testvarnames.c"
52 "tests/testjavacomp.java"
54 "List of files with analyzer completion test points.")
56 (defvar semantic-ia-utest-error-log-list nil
57 "List of errors occuring during a run.")
60 (defun semantic-ia-utest (&optional arg
)
61 "Run the semantic ia unit test against stored sources.
62 Argument ARG specifies which set of tests to run.
66 4 - symref count utests"
70 (let ((fl semantic-ia-utest-file-list
)
71 (semantic-ia-utest-error-log-list nil
)
74 (cedet-utest-log-setup "ANALYZER")
76 (set-buffer (semantic-find-file-noselect
77 (or (locate-library "semantic-ia-utest.el")
78 "semantic-ia-utest.el")))
82 ;; Make sure we have the files we think we have.
83 (when (not (file-exists-p (car fl
)))
84 (error "Cannot find unit test file: %s" (car fl
)))
87 (let ((fb (find-buffer-visiting (car fl
)))
88 (b (semantic-find-file-noselect (car fl
) t
)))
90 ;; Run the test on it.
94 ;; This line will also force the include, scope, and typecache.
95 (semantic-clear-toplevel-cache)
96 ;; Force tags to be parsed.
99 (semantic-ia-utest-log " ** Starting tests in %s"
102 (when (or (not arg
) (= arg
1))
103 (semantic-ia-utest-buffer))
105 (when (or (not arg
) (= arg
2))
107 (semantic-ia-utest-buffer-refs))
109 (when (or (not arg
) (= arg
3))
111 (semantic-sr-utest-buffer-refs))
113 (when (or (not arg
) (= arg
4))
115 (semantic-src-utest-buffer-refs))
117 (semantic-ia-utest-log " ** Completed tests in %s\n"
121 ;; If it wasn't already in memory, whack it.
127 (cedet-utest-log-shutdown
129 (when semantic-ia-utest-error-log-list
130 (format "%s Failures found."
131 (length semantic-ia-utest-error-log-list
))))
132 (when semantic-ia-utest-error-log-list
133 (error "Failures found during analyzer unit tests"))
137 (defun semantic-ia-utest-buffer ()
138 "Run analyzer completion unit-test pass in the current buffer."
149 ;; Exclude unpredictable system files in the
150 ;; header include list.
151 (semanticdb-find-default-throttle
152 (remq 'system semanticdb-find-default-throttle
))
154 ;; Keep looking for test points until we run out.
155 (while (save-excursion
156 (setq regex-p
(concat "//\\s-*-" (number-to-string idx
) "-" )
157 regex-a
(concat "//\\s-*#" (number-to-string idx
) "#" ))
158 (goto-char (point-min))
160 (when (re-search-forward regex-p nil t
)
161 (setq p
(match-beginning 0))))
163 (when (re-search-forward regex-a nil t
)
164 (setq a
(match-end 0))))
171 (let* ((ctxt (semantic-analyze-current-context))
174 (semantic-analyze-possible-completions ctxt
)
176 (setq actual
(mapcar 'semantic-tag-name acomp
)))
180 (let ((bss (buffer-substring-no-properties (point) (point-at-eol))))
182 (setq desired
(read bss
))
183 (error (setq desired
(format " FAILED TO PARSE: %S"
186 (if (equal actual desired
)
187 (setq pass
(cons idx pass
))
188 (setq fail
(cons idx fail
))
189 (semantic-ia-utest-log
190 " Failed %d. Desired: %S Actual %S"
192 (add-to-list 'semantic-ia-utest-error-log-list
193 (list (buffer-name) idx desired actual
)
204 (semantic-ia-utest-log
205 " Unit tests (completions) failed tests %S"
208 (semantic-ia-utest-log " Unit tests (completions) passed (%d total)"
213 (defun semantic-ia-utest-buffer-refs ()
214 "Run a analyze-refs unit-test pass in the current buffer."
221 ;; Exclude unpredictable system files in the
222 ;; header include list.
223 (semanticdb-find-default-throttle
224 (remq 'system semanticdb-find-default-throttle
))
226 ;; Keep looking for test points until we run out.
227 (while (save-excursion
228 (setq regex-p
(concat "//\\s-*\\^" (number-to-string idx
) "^" )
230 (goto-char (point-min))
232 (when (re-search-forward regex-p nil t
)
233 (setq p
(match-beginning 0))))
241 (let* ((ct (semantic-current-tag))
242 (refs (semantic-analyze-tag-references ct
))
243 (impl (semantic-analyze-refs-impl refs t
))
244 (proto (semantic-analyze-refs-proto refs t
))
250 (if (and impl proto
(car impl
) (car proto
))
251 (let (ct2 ref2 impl2 proto2
254 ((semantic-equivalent-tag-p (car impl
) ct
)
255 ;; We are on an IMPL. Go To the proto, and find matches.
256 (semantic-go-to-tag (car proto
))
257 (setq newstart
(car proto
))
259 ((semantic-equivalent-tag-p (car proto
) ct
)
260 ;; We are on a PROTO. Go to the imple, and find matches
261 (semantic-go-to-tag (car impl
))
262 (setq newstart
(car impl
))
265 ;; No matches is a fail.
268 ;; Get the new tag, does it match?
269 (setq ct2
(semantic-current-tag))
272 (when (not (semantic-equivalent-tag-p ct2 newstart
))
275 ;; Can we double-jump?
276 (setq ref2
(semantic-analyze-tag-references ct
)
277 impl2
(semantic-analyze-refs-impl ref2 t
)
278 proto2
(semantic-analyze-refs-proto ref2 t
))
280 (when (or (not (and impl2 proto2
))
282 (and (semantic-equivalent-tag-p
283 (car impl
) (car impl2
))
284 (semantic-equivalent-tag-p
285 (car proto
) (car proto2
)))))
289 ;; Else, no matches at all, so another fail.
295 (setq pass
(cons idx pass
))
297 (setq fail
(cons idx fail
))
298 (semantic-ia-utest-log
299 " Failed %d. For %s (Num impls %d) (Num protos %d)"
300 idx
(if ct
(semantic-tag-name ct
) "<No tag found>")
301 (length impl
) (length proto
))
302 (add-to-list 'semantic-ia-utest-error-log-list
303 (list (buffer-name) idx
)
314 (semantic-ia-utest-log
315 " Unit tests (refs) failed tests")
317 (semantic-ia-utest-log " Unit tests (refs) passed (%d total)"
322 (defun semantic-sr-utest-buffer-refs ()
323 "Run a symref unit-test pass in the current buffer."
325 ;; This line will also force the include, scope, and typecache.
326 (semantic-clear-toplevel-cache)
327 ;; Force tags to be parsed.
328 (semantic-fetch-tags)
338 (symref-tool-used nil
)
339 ;; Exclude unpredictable system files in the
340 ;; header include list.
341 (semanticdb-find-default-throttle
342 (remq 'system semanticdb-find-default-throttle
))
344 ;; Keep looking for test points until we run out.
345 (while (save-excursion
346 (setq regex-p
(concat "//\\s-*\\%" (number-to-string idx
) "%" )
348 (goto-char (point-min))
350 (when (re-search-forward regex-p nil t
)
351 (setq tag
(semantic-current-tag))
352 (goto-char (match-end 0))
353 (setq desired
(read (buffer-substring (point) (point-at-eol))))
357 (setq actual-result
(semantic-symref-find-references-by-name
358 (semantic-tag-name tag
) 'target
361 (if (not actual-result
)
363 (setq fail
(cons idx fail
))
364 (semantic-ia-utest-log
365 " Failed FNames %d: No results." idx
)
366 (semantic-ia-utest-log
367 " Failed Tool: %s" (object-name symref-tool-used
))
369 (add-to-list 'semantic-ia-utest-error-log-list
370 (list (buffer-name) idx
)
374 (setq actual
(list (sort (mapcar
375 'file-name-nondirectory
376 (semantic-symref-result-get-files actual-result
))
380 'semantic-format-tag-canonical-name
381 (semantic-symref-result-get-tags actual-result
))
385 (if (equal desired actual
)
387 (setq pass
(cons idx pass
))
389 (setq fail
(cons idx fail
))
390 (when (not (equal (car actual
) (car desired
)))
391 (semantic-ia-utest-log
392 " Failed FNames %d: Actual: %S Desired: %S"
393 idx
(car actual
) (car desired
))
394 (semantic-ia-utest-log
395 " Failed Tool: %s" (object-name symref-tool-used
))
397 (when (not (equal (car (cdr actual
)) (car (cdr desired
))))
398 (semantic-ia-utest-log
399 " Failed TNames %d: Actual: %S Desired: %S"
400 idx
(car (cdr actual
)) (car (cdr desired
)))
401 (semantic-ia-utest-log
402 " Failed Tool: %s" (object-name symref-tool-used
))
404 (add-to-list 'semantic-ia-utest-error-log-list
405 (list (buffer-name) idx
)
414 (semantic-ia-utest-log
415 " Unit tests (symrefs) failed tests")
417 (semantic-ia-utest-log " Unit tests (symrefs) passed (%d total)"
422 (defun semantic-src-utest-buffer-refs ()
423 "Run a sym-ref counting unit-test pass in the current buffer."
425 ;; This line will also force the include, scope, and typecache.
426 (semantic-clear-toplevel-cache)
427 ;; Force tags to be parsed.
428 (semantic-fetch-tags)
437 ;; Exclude unpredictable system files in the
438 ;; header include list.
439 (semanticdb-find-default-throttle
440 (remq 'system semanticdb-find-default-throttle
))
442 ;; Keep looking for test points until we run out.
443 (while (save-excursion
444 (setq regex-p
(concat "//\\s-*@"
445 (number-to-string idx
)
446 "@\\s-+\\(\\w+\\)" ))
447 (goto-char (point-min))
449 (when (re-search-forward regex-p nil t
)
450 (goto-char (match-beginning 1))
451 (setq desired
(read (buffer-substring (point) (point-at-eol))))
452 (setq start
(match-beginning 0))
454 (setq actual
(semantic-symref-test-count-hits-in-tag))
459 (setq fail
(cons idx fail
))
460 (semantic-ia-utest-log
461 " Failed symref count %d: No results." idx
)
463 (add-to-list 'semantic-ia-utest-error-log-list
464 (list (buffer-name) idx
)
468 (if (equal desired actual
)
470 (setq pass
(cons idx pass
))
472 (setq fail
(cons idx fail
))
473 (when (not (equal actual desired
))
474 (semantic-ia-utest-log
475 " Failed symref count %d: Actual: %S Desired: %S"
479 (add-to-list 'semantic-ia-utest-error-log-list
480 (list (buffer-name) idx
)
489 (semantic-ia-utest-log
490 " Unit tests (symrefs counter) failed tests")
492 (semantic-ia-utest-log " Unit tests (symrefs counter) passed (%d total)"
497 (defun semantic-ia-utest-start-log ()
498 "Start up a testlog for a run."
499 ;; Redo w/ CEDET utest framework.
500 (cedet-utest-log-start "semantic: analyzer tests"))
502 (defun semantic-ia-utest-log (&rest args
)
503 "Log some test results.
504 Pass ARGS to format to create the log message."
505 ;; Forward to CEDET utest framework.
506 (apply 'cedet-utest-log args
))
508 (provide 'semantic-ia-utest
)
510 ;; arch-tag: 03ede3fb-7ef0-4500-a7c2-bbf647957310
511 ;;; semantic-ia-utest.el ends here