# 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 -- {^\s*%([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"
    create_mock_file dg-test-vfs "dg/pr58065/pskip-${result}" \
	"#test file\n{ dg-error foo \"never produced\" }\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
    test_proc_with_mocks "test with dg/pr58065/pskip-${result}" dg-test-1 \
	[list dg-runtest dg/pr58065/pskip-${result} "" ""] \
	check_calls $check_calls
}
dg-test-1 eval dg-finish


puts "END dg.test"