Handle relative line numbers in dg-{error,warning,bogus}

2017-05-31  Tom de Vries  <tom@codesourcery.com>

	* lib/dg.exp (dg-error, dg-warning, dg-bogus): Handle relative line
	numbers.
	* testsuite/runtest.all/dg.test: New test.

---
 lib/dg.exp                    |  65 +++++++++++++++++---------
 testsuite/runtest.all/dg.test | 103 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 147 insertions(+), 21 deletions(-)

diff --git a/lib/dg.exp b/lib/dg.exp
index 7a894cb..fb00382 100644
--- a/lib/dg.exp
+++ b/lib/dg.exp
@@ -43,17 +43,19 @@
 #	produce an a.out, or produce an a.out and run it (the default is
 #	'compile').
 #
-# dg-error regexp comment [{ target/xfail selector } [{.|0|linenum}]]
+# dg-error regexp comment [{ target/xfail selector } [{.|0|linenum|.[+-]n}]]
 #	indicate an error message <regexp> is expected on this line
 #	(the test fails if it doesn't occur)
 #	linenum=0 for general tool messages (eg: -V arg missing).
 #	"." means the current line.
+#	".[+-]n" means a relative line number, f.i. .-1 is the previous line,
+#	and .+1 is the next line.
 #
-# dg-warning regexp comment [{ target/xfail selector } [{.|0|linenum}]]
+# dg-warning regexp comment [{ target/xfail selector } [{.|0|linenum|.[+-]n}]]
 #	indicate a warning message <regexp> is expected on this line
 #	(the test fails if it doesn't occur)
 #
-# dg-bogus regexp comment [{ target/xfail selector } [{.|0|linenum}]]
+# dg-bogus regexp comment [{ target/xfail selector } [{.|0|linenum|.[+-]n}]]
 #	indicate a bogus error message <regexp> used to occur here
 #	(the test fails if it does occur)
 #
@@ -364,14 +366,21 @@ proc dg-error { args } {
 	}
     }
 
-    if { [llength $args] >= 5 } {
-	switch -- [lindex $args 4] {
-	    "." { set line [dg-format-linenum [lindex $args 0]] }
+    set currentnum [lindex $args 0]
+    set numspec [lindex $args 4]
+    if { [llength $args] < 5 } {
+	set line [dg-format-linenum $currentnum]
+    } elseif { [regsub "^\.\[+-\](\[0-9\]+)$" $numspec "\\1" relnum] } {
+	# Handle relative line specification, .+1 or .-1 etc.
+	set relop [string index $numspec 1]
+	set line [expr $currentnum $relop $relnum]
+	set line [dg-format-linenum $line]
+    } else {
+	switch -- $numspec {
+	    "." { set line [dg-format-linenum $currentnum] }
 	    "0" { set line "" }
-	    "default" { set line [dg-format-linenum [lindex $args 4]] }
+	    "default" { set line [dg-format-linenum $numspec] }
 	}
-    } else {
-	set line [dg-format-linenum [lindex $args 0]]
     }
 
     lappend messages [list $line "${xfail}ERROR" [lindex $args 1] [lindex $args 2]]
@@ -396,14 +405,21 @@ proc dg-warning { args } {
 	}
     }
 
-    if { [llength $args] >= 5 } {
-	switch -- [lindex $args 4] {
-	    "." { set line [dg-format-linenum [lindex $args 0]] }
+    set currentnum [lindex $args 0]
+    set numspec [lindex $args 4]
+    if { [llength $args] < 5 } {
+	set line [dg-format-linenum $currentnum]
+    } elseif { [regsub "^\.\[+-\](\[0-9\]+)$" $numspec "\\1" relnum] } {
+	# Handle relative line specification, .+1 or .-1 etc.
+	set relop [string index $numspec 1]
+	set line [expr $currentnum $relop $relnum]
+	set line [dg-format-linenum $line]
+    } else {
+	switch -- $numspec {
+	    "." { set line [dg-format-linenum $currentnum] }
 	    "0" { set line "" }
-	    "default" { set line [dg-format-linenum [lindex $args 4]] }
+	    "default" { set line [dg-format-linenum $numspec] }
 	}
-    } else {
-	set line [dg-format-linenum [lindex $args 0]]
     }
 
     lappend messages [list $line "${xfail}WARNING" [lindex $args 1] [lindex $args 2]]
@@ -428,14 +444,21 @@ proc dg-bogus { args } {
 	}
     }
 
-    if { [llength $args] >= 5 } {
-	switch -- [lindex $args 4] {
-	    "." { set line [dg-format-linenum [lindex $args 0]] }
+    set currentnum [lindex $args 0]
+    set numspec [lindex $args 4]
+    if { [llength $args] < 5 } {
+	set line [dg-format-linenum $currentnum]
+    } elseif { [regsub "^\.\[+-\](\[0-9\]+)$" $numspec "\\1" relnum] } {
+	# Handle relative line specification, .+1 or .-1 etc.
+	set relop [string index $numspec 1]
+	set line [expr $currentnum $relop $relnum]
+	set line [dg-format-linenum $line]
+    } else {
+	switch -- $numspec {
+	    "." { set line [dg-format-linenum $currentnum] }
 	    "0" { set line "" }
-	    "default" { set line [dg-format-linenum [lindex $args 4]] }
+	    "default" { set line [dg-format-linenum $numspec] }
 	}
-    } else {
-	set line [dg-format-linenum [lindex $args 0]]
     }
 
     lappend messages [list $line "${xfail}BOGUS" [lindex $args 1] [lindex $args 2]]
diff --git a/testsuite/runtest.all/dg.test b/testsuite/runtest.all/dg.test
new file mode 100644
index 0000000..df33eeb
--- /dev/null
+++ b/testsuite/runtest.all/dg.test
@@ -0,0 +1,103 @@
+set srcdir [lindex $argv 0]
+set subdir [lindex $argv 1]
+set objdir [lindex $argv 2]
+
+source "$srcdir/../lib/dg.exp"
+
+
+# Test functions
+
+# Run TEST, and check if RES was added to dg-messages
+proc do_test { test res } {
+    set dg-messages [list]
+    {*}$test
+    if { [llength ${dg-messages}] == 0 } {
+	puts "FAILED: [join $test] -- has empty dg-messages"
+	return
+    }
+    set msg [lindex ${dg-messages} 0]
+    if { $msg == $res } {
+	puts "PASSED: [join $test]"
+    } else {
+	puts "FAILED: [join $test] -- expected [join $res] -- got [join $msg]"
+    }
+}
+
+# Test line number format for directive DIR, and expect corresponding message
+# DIRMSG.
+proc do_test_lines { dir dirmsg } {
+    # No line number
+    do_test \
+	[list $dir 1 "bla" "comment"] \
+	[list :1: $dirmsg "bla" "comment"]
+
+    # Current line number
+    do_test \
+	[list $dir 1 "bla" "comment" "" .] \
+	[list :1: $dirmsg "bla" "comment"]
+
+    # Zero line number
+    do_test \
+	[list $dir 1 "bla" "comment" "" 0] \
+	[list "" $dirmsg "bla" "comment"]
+
+    # Absolute line number
+    do_test \
+	[list $dir 1 "bla" "comment" "" 1] \
+	[list :1: $dirmsg "bla" "comment"]
+
+    # Relative line number, negative
+    do_test \
+	[list $dir 2 "bla" "comment3" "" .-1] \
+	[list :1: $dirmsg "bla" "comment3"]
+
+    # Relative line number, positive
+    do_test \
+	[list $dir 1 "bla" "comment3" "" .+1] \
+	[list :2: $dirmsg "bla" "comment3"]
+}
+
+
+# Tests ignoring target/xfail selector
+
+# Test missing comment argument. This is not according to the advertised syntax,
+# but it has worked sofar, so users may have started to expect this behaviour.
+do_test \
+	[list dg-error 1 "bla"] \
+	[list :1: "ERROR" "bla" ""]
+do_test \
+	[list dg-warning 1 "bla"] \
+	[list :1: "WARNING" "bla" ""]
+do_test \
+	[list dg-bogus 1 "bla"] \
+	[list :1: "BOGUS" "bla" ""]
+
+
+# Tests with target selector enabled
+
+proc dg-process-target { selector } {
+    return "P"
+}
+
+# Test line number format
+do_test_lines dg-error "ERROR"
+do_test_lines dg-warning "WARNING"
+do_test_lines dg-bogus "BOGUS"
+
+
+# Tests with xfail selector enabled
+
+proc dg-process-target { selector } {
+    return "F"
+}
+
+# Test X prefix
+do_test \
+	[list dg-error 1 "bla" "comment" ""] \
+	[list :1: XERROR "bla" "comment"]
+do_test \
+	[list dg-warning 1 "bla" "comment" ""] \
+	[list :1: XWARNING "bla" "comment"]
+do_test \
+	[list dg-bogus 1 "bla" "comment" ""] \
+	[list :1: XBOGUS "bla" "comment"]
