mirror of https://gitee.com/Nocallback/dejagnu.git
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
287 lines
8.8 KiB
287 lines
8.8 KiB
# Test procedures in lib/dg.exp -*- Tcl -*-
|
|
|
|
# Copyright (C) 2022 Free Software Foundation, Inc.
|
|
#
|
|
# This file is part of DejaGnu.
|
|
#
|
|
# DejaGnu 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 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# DejaGnu 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.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with DejaGnu; if not, write to the Free Software Foundation,
|
|
# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
|
|
|
|
foreach lib { default_procs mockutil mockvfs } {
|
|
set file $srcdir/$subdir/${lib}.tcl
|
|
if [ file exists $file] {
|
|
source $file
|
|
} else {
|
|
puts "ERROR: $file doesn't exist"
|
|
}
|
|
}
|
|
foreach lib { utils dg } {
|
|
set file $srcdir/../lib/${lib}.exp
|
|
if [ file exists $file] {
|
|
source $file
|
|
} else {
|
|
puts "ERROR: $file doesn't exist"
|
|
}
|
|
}
|
|
|
|
# callbacks required by dg.exp
|
|
|
|
proc mock-dg-test { prog what flags } {
|
|
set chan [open $prog r]
|
|
set linum 0
|
|
set output ""
|
|
|
|
while { [gets $chan line] >= 0 } {
|
|
incr linum
|
|
if { [regexp -- {^%([EWO])\s+([^\r\n{}]*)} $line -> item text] } {
|
|
switch -- $item {
|
|
E { append output "$prog:$linum: error: $text\n" }
|
|
W { append output "$prog:$linum: warning: $text\n" }
|
|
O { append output "$text\n" }
|
|
}
|
|
}
|
|
}
|
|
puts "<<< $prog $what $flags"
|
|
puts -nonewline $output
|
|
puts ">>> $prog $what $flags"
|
|
return [list $output a.out]
|
|
}
|
|
|
|
proc mock-dg-prune { target output } {
|
|
puts "<<< output pruning callback"
|
|
puts "target: $target"
|
|
puts "output:\n$output"
|
|
puts ">>> output pruning callback"
|
|
if { [regexp -- {--(unresolved|unsupported|untested): (.*)--} $output \
|
|
-> what why] } {
|
|
return "::${what}::${why}"
|
|
}
|
|
return $output
|
|
}
|
|
|
|
# testing...
|
|
# each item in testlist: { name code checks... }
|
|
proc eval_tests { sicmd testlist } {
|
|
set testlist [strip_comment_lines $testlist]
|
|
foreach { test } $testlist {
|
|
if { [llength $test] > 2 } {
|
|
eval [list test_proc_with_mocks [lindex $test 0] $sicmd \
|
|
[lindex $test 1]] [lrange $test 2 end]
|
|
} else {
|
|
$sicmd eval [lindex $test 1]
|
|
}
|
|
}
|
|
}
|
|
|
|
# init call trace list
|
|
reset_mock_trace
|
|
# build test environment
|
|
create_mockvfs dg-test-vfs
|
|
create_test_interpreter dg-test-1 {
|
|
copy_procs {
|
|
dg-format-linenum dg-get-options dg-process-target
|
|
dg-prms-id dg-options dg-do
|
|
dg-error dg-warning dg-bogus dg-build
|
|
dg-excess-errors dg-output dg-final
|
|
dg-init dg-runtest dg-test dg-finish
|
|
dg-trim-dirname
|
|
grep mock-dg-test mock-dg-prune
|
|
}
|
|
link_procs { verbose }
|
|
shim_procs { runtest_file_p }
|
|
attach_vfs { dg-test-vfs }
|
|
link_channels { stdout }
|
|
copy_vars {
|
|
dg-do-what-default dg-interpreter-batch-mode dg-linenum-format
|
|
srcdir subdir
|
|
}
|
|
vars {
|
|
tool mock
|
|
target_triplet mock-target-one
|
|
runtests { dg.test {} }
|
|
}
|
|
mocks {
|
|
# minor test shims
|
|
prune_warnings { text } { $text }
|
|
isnative { } { 0 }
|
|
unknown { args } { [error "unknown $args"] }
|
|
# results collection
|
|
pass { message } { 0 }
|
|
fail { message } { 0 }
|
|
xpass { message } { 0 }
|
|
xfail { message } { 0 }
|
|
kpass { bugid message } { 0 }
|
|
kfail { bugid message } { 0 }
|
|
unresolved { message } { 0 }
|
|
unsupported { message } { 0 }
|
|
untested { message } { 0 }
|
|
}
|
|
}
|
|
|
|
foreach {type token line} {
|
|
pass error {%E foo { dg-error "foo" "simple error" }}
|
|
fail error {% foo { dg-error "foo" "simple error" }}
|
|
pass warning {%W foo { dg-warning "foo" "simple warning" }}
|
|
fail warning {% foo { dg-warning "foo" "simple warning" }}
|
|
pass bogus {% foo { dg-bogus "foo" "bogus message" }}
|
|
fail bogus {%W foo { dg-bogus "foo" "bogus message" }}
|
|
pass build {% foo { dg-build "foo" "build failure" }}
|
|
fail build {%E foo { dg-build "foo" "build failure" }}
|
|
pass excess {% foo}
|
|
fail excess {%E extra}
|
|
} {
|
|
create_mock_file dg-test-vfs "dg/basic-${type}-${token}" \
|
|
"# test file for dg.exp\n$line\n"
|
|
regsub -- {\{ dg-} $line "\n\n&" line
|
|
regsub -- { \}\Z} $line " {target *-*-*} 2&" line
|
|
if { $token ne "build" && $token ne "excess" } {
|
|
create_mock_file dg-test-vfs "dg/linum-${type}-${token}" \
|
|
"#test file for dg.exp\n$line\n"
|
|
}
|
|
regsub -- {\n\n} $line "" line
|
|
regsub -- {{target [-*]+} *[[:digit:]]*} $line \
|
|
"{xfail mock-target-one}" line
|
|
if { $token ne "excess" } {
|
|
create_mock_file dg-test-vfs "dg/basic-here-x${type}-${token}" \
|
|
"#test file for dg.exp\n$line\n"
|
|
regsub -- {xfail mock-target-one} $line "xfail mock-target-two" line
|
|
create_mock_file dg-test-vfs "dg/basic-there-x${type}-${token}" \
|
|
"#test file for dg.exp\n$line\n"
|
|
}
|
|
}
|
|
|
|
create_mock_file dg-test-vfs \
|
|
dg/skip-target {
|
|
# test file for dg.exp
|
|
{ dg-do compile { target fake-target-null } }
|
|
#E bogus error
|
|
} \
|
|
dg/skip-cross-target {
|
|
# test file for dg.exp
|
|
{ dg-do compile { target native } }
|
|
#E bogus error
|
|
}
|
|
|
|
foreach {result} { unresolved unsupported untested } {
|
|
create_mock_file dg-test-vfs "dg/pskip-${result}" \
|
|
"#test file for dg.exp\n%O --${result}: skip by prune--\n"
|
|
}
|
|
|
|
dg-test-1 eval {proc send_log { text } { puts $text }}
|
|
|
|
dg-test-1 eval dg-init
|
|
foreach { type token message } {
|
|
pass error { test for errors, line 2 }
|
|
fail error { test for errors, line 2 }
|
|
pass warning { test for warnings, line 2 }
|
|
fail warning { test for warnings, line 2 }
|
|
pass bogus { test for bogus message }
|
|
fail bogus { test for bogus message }
|
|
pass build { test for build failure }
|
|
fail build { test for build failure }
|
|
pass excess { test for excess errors }
|
|
fail excess { test for excess errors }
|
|
} {
|
|
set check_calls {
|
|
xpass ! {} xfail ! {} kpass ! {} kfail ! {}
|
|
unresolved ! {} unsupported ! {} untested ! {}
|
|
}
|
|
set check_xcalls {
|
|
pass C 1 fail ! {} kpass ! {} kfail ! {}
|
|
unresolved ! {} unsupported ! {} untested ! {}
|
|
}
|
|
switch -glob -- ${type}:${token} {
|
|
pass:excess { lappend check_calls fail ! {} pass C 1 }
|
|
fail:excess { lappend check_calls pass ! {} fail C 1 }
|
|
pass:* {
|
|
lappend check_calls fail ! {} pass C 2
|
|
lappend check_xcalls xfail ! {} xpass C 1
|
|
}
|
|
fail:* {
|
|
lappend check_calls fail C 1 pass C 1
|
|
lappend check_xcalls xfail C 1 xpass ! {}
|
|
}
|
|
}
|
|
if { $message ne "" } {
|
|
lappend check_calls $type 0 [list 1 ".*[string trim ${message}].*"]
|
|
lappend check_xcalls x$type 0 [list 1 ".*[string trim ${message}].*"]
|
|
}
|
|
if { $token ne "excess" } {
|
|
lappend check_calls pass
|
|
switch -- ${type} {
|
|
pass { lappend check_calls 1 }
|
|
fail { lappend check_calls 0 }
|
|
}
|
|
lappend check_calls { 1 {.*test for excess errors.*} }
|
|
lappend check_xcalls pass 0 { 1 {.*test for excess errors.*} }
|
|
}
|
|
test_proc_with_mocks "test with dg/basic-${type}-${token}" dg-test-1 \
|
|
[list dg-runtest dg/basic-${type}-${token} "" ""] \
|
|
check_calls $check_calls
|
|
if { $token ne "excess" } {
|
|
test_proc_with_mocks "test with dg/basic-here-x${type}-${token}" dg-test-1 \
|
|
[list dg-runtest dg/basic-here-x${type}-${token} "" ""] \
|
|
check_calls $check_xcalls
|
|
test_proc_with_mocks "test with dg/basic-there-x${type}-${token}" dg-test-1 \
|
|
[list dg-runtest dg/basic-there-x${type}-${token} "" ""] \
|
|
check_calls $check_calls
|
|
}
|
|
if { $token ne "build" && $token ne "excess" } {
|
|
test_proc_with_mocks "test with dg/linum-${type}-${token}" dg-test-1 \
|
|
[list dg-runtest dg/linum-${type}-${token} "" ""] \
|
|
check_calls $check_calls
|
|
}
|
|
}
|
|
eval_tests dg-test-1 {
|
|
{ "test with dg/skip-target"
|
|
{ dg-runtest dg/skip-target "" "" }
|
|
check_calls {
|
|
pass ! {} fail ! {} xpass ! {} xfail ! {} kpass ! {} kfail ! {}
|
|
unresolved ! {} unsupported C 1 untested ! {}
|
|
unsupported 0 { 1 {.*dg/skip-target.*} }
|
|
}
|
|
}
|
|
{ "test with dg/skip-cross-target"
|
|
{ dg-runtest dg/skip-cross-target "" "" }
|
|
check_calls {
|
|
pass ! {} fail ! {} xpass ! {} xfail ! {} kpass ! {} kfail ! {}
|
|
unresolved ! {} unsupported C 1 untested ! {}
|
|
unsupported 0 { 1 {.*dg/skip-cross-target.*} }
|
|
}
|
|
}
|
|
}
|
|
foreach {result} { unresolved unsupported untested } {
|
|
set check_calls {
|
|
pass ! {} fail ! {} xpass ! {} xfail ! {} kpass ! {} kfail ! {}
|
|
}
|
|
switch -- $result {
|
|
unresolved {
|
|
lappend check_calls unresolved C 1 unsupported ! {} untested ! {}
|
|
}
|
|
unsupported {
|
|
lappend check_calls unresolved ! {} unsupported C 1 untested ! {}
|
|
}
|
|
untested {
|
|
lappend check_calls unresolved ! {} unsupported ! {} untested C 1
|
|
}
|
|
}
|
|
lappend check_calls $result 0 { 1 {.*skip by prune.*} }
|
|
test_proc_with_mocks "test with dg/pskip-${result}" dg-test-1 \
|
|
[list dg-runtest dg/pskip-${result} "" ""] \
|
|
check_calls $check_calls
|
|
}
|
|
dg-test-1 eval dg-finish
|
|
|
|
|
|
puts "END dg.test"
|
|
|