1# Copyright (C) 2005-2018 Free Software Foundation, Inc. 2 3# This program is free software; you can redistribute it and/or modify 4# it under the terms of the GNU General Public License as published by 5# the Free Software Foundation; either version 3 of the License, or 6# (at your option) any later version. 7# 8# This program is distributed in the hope that it will be useful, 9# but WITHOUT ANY WARRANTY; without even the implied warranty of 10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11# GNU General Public License for more details. 12# 13# You should have received a copy of the GNU General Public License 14# along with GCC; see the file COPYING3. If not see 15# <http://www.gnu.org/licenses/>. 16 17# DejaGnu test driver around Mike Cowlishaw's testsuite for decimal 18# decimal arithmetic ("decTest"). See: 19# <http://www2.hursley.ibm.com/decimal/dectest.html>. 20# 21# Contributed by Ben Elliston <bje@au.ibm.com>. 22 23set DEC_TORTURE_OPTIONS [list {} -O1 -O2 -O3 -Os -msoft-float] 24 25proc target-specific-flags {} { 26 set result "-frounding-math " 27 return $result 28} 29 30# Load support procs (borrow these from c-torture). 31load_lib c-torture.exp 32load_lib target-supports.exp 33load_lib torture-options.exp 34 35# Skip these tests for targets that don't support this extension. 36if { ![check_effective_target_dfp] } { 37 return 38} 39 40# The list format is [coefficient, max-exponent, min-exponent]. 41set properties(_Decimal32) [list 7 96 -95] 42set properties(_Decimal64) [list 16 384 -383] 43set properties(_Decimal128) [list 34 6144 -6143] 44 45# Operations implemented by the compiler. 46set operators(add) {+} 47set operators(compare) {==} 48set operators(divide) {/} 49set operators(multiply) {*} 50set operators(subtract) {-} 51set operators(minus) {-} 52set operators(plus) {+} 53set operators(apply) {} 54 55# Operations imlemented by the library. 56set libfuncs(abs) fabsl 57set libfuncs(squareroot) sqrtl 58set libfuncs(max) fmaxl 59set libfuncs(min) fminl 60set libfuncs(quantize) quantize 61set libfuncs(samequantum) samequantum 62set libfuncs(power) powl 63set libfuncs(toSci) unknown 64set libfuncs(tosci) unknown 65set libfuncs(toEng) unknown 66set libfuncs(toeng) unknown 67set libfuncs(divideint) unknown 68set libfuncs(rescale) unknown 69set libfuncs(remainder) unknown 70set libfuncs(remaindernear) unknown 71set libfuncs(normalize) unknown 72set libfuncs(tointegral) unknown 73set libfuncs(trim) unknown 74 75# Run all of the tests listed in TESTCASES by invoking df-run-test on 76# each. Skip tests that not included by the user invoking runtest 77# with the foo.exp=test.c syntax. 78 79proc dfp-run-tests { testcases } { 80 global runtests 81 foreach test $testcases { 82 # If we're only testing specific files and this isn't one of 83 # them, skip it. 84 if ![runtest_file_p $runtests $test] continue 85 dfp-run-test $test 86 } 87} 88 89# Run a single test case named by TESTCASE. 90# Called for each test by dfp-run-tests. 91 92proc dfp-run-test { testcase } { 93 set fd [open $testcase r] 94 while {[gets $fd line] != -1} { 95 switch -regexp -- $line { 96 {^[ \t]*--.*$} { 97 # Ignore comments. 98 } 99 {^[ \t]*$} { 100 # Ignore blank lines. 101 } 102 {^[ \t]*[^:]*:[^:]*} { 103 regsub -- {[ \t]*--.*$} $line {} line 104 process-directive $line 105 } 106 default { 107 process-test-case $testcase $line 108 } 109 } 110 } 111 close $fd 112} 113 114# Return the appropriate constant from <fenv.h> for MODE. 115 116proc c-rounding-mode { mode } { 117 switch [string tolower $mode] { 118 "floor" { return 0 } # FE_DEC_DOWNWARD 119 "half_even" { return 1 } # FE_DEC_TONEARESTFROMZERO 120 "half_up" { return 2 } # FE_DEC_TONEAREST 121 "down" { return 3 } # FE_DEC_TOWARDZERO 122 "ceiling" { return 4 } # FE_DEC_UPWARD 123 } 124 error "unsupported rounding mode ($mode)" 125} 126 127# Return a string of C code that forms the preamble to perform the 128# test named ID. 129 130proc c-test-preamble { id } { 131 append result "/* Machine generated test case for $id */\n" 132 append result "\n" 133 append result "\#include <assert.h>\n" 134 append result "\#include <fenv.h>\n" 135 append result "\#include <math.h>\n" 136 append result "\n" 137 append result "int main ()\n" 138 append result "\{" 139 return $result 140} 141 142# Return a string of C code that forms the postable to the test named ID. 143 144proc c-test-postamble { id } { 145 return "\}" 146} 147 148# Generate a C unary expression that applies OPERATION to OP. 149 150proc c-unary-expression {operation op} { 151 global operators 152 global libfuncs 153 if [catch {set result "$operators($operation) $op"}] { 154 # If operation isn't in the operators or libfuncs arrays, 155 # we'll throw an error. That's what we want. 156 # FIXME: append d32, etc. here. 157 set result "$libfuncs($operation) ($op)" 158 } 159 return $result 160} 161 162# Generate a C binary expression that applies OPERATION to OP1 and OP2. 163 164proc c-binary-expression {operation op1 op2} { 165 global operators 166 global libfuncs 167 if [catch {set result "$op1 $operators($operation) $op2"}] { 168 # If operation isn't in the operators or libfuncs arrays, 169 # we'll throw an error. That's what we want. 170 set result "$libfuncs($operation) ($op1, $op2)" 171 } 172 return $result 173} 174 175# Return the most appropriate C type (_Decimal32, etc) for this test. 176 177proc c-decimal-type { } { 178 global directives 179 if [catch {set precision $directives(precision)}] { 180 set precision "_Decimal128" 181 } 182 if { $precision == 7 } { 183 set result "_Decimal32" 184 } elseif {$precision == 16} { 185 set result "_Decimal64" 186 } elseif {$precision == 34} { 187 set result "_Decimal128" 188 } else { 189 error "Unsupported precision" 190 } 191 return $result 192} 193 194# Return the size of the most appropriate C type, in bytes. 195 196proc c-sizeof-decimal-type { } { 197 switch [c-decimal-type] { 198 "_Decimal32" { return 4 } 199 "_Decimal64" { return 8 } 200 "_Decimal128" { return 16 } 201 } 202 error "Unsupported precision" 203} 204 205# Return the right literal suffix for CTYPE. 206 207proc c-type-suffix { ctype } { 208 switch $ctype { 209 "_Decimal32" { return "df" } 210 "_Decimal64" { return "dd" } 211 "_Decimal128" { return "dl" } 212 "float" { return "f" } 213 "long double" { return "l" } 214 } 215 return "" 216} 217 218proc nan-p { operand } { 219 if {[string match "NaN*" $operand] || [string match "-NaN*" $operand]} { 220 return 1 221 } else { 222 return 0 223 } 224} 225 226proc infinity-p { operand } { 227 if {[string match "Inf*" $operand] || [string match "-Inf*" $operand]} { 228 return 1 229 } else { 230 return 0 231 } 232} 233 234proc isnan-builtin-name { } { 235 set bits [expr [c-sizeof-decimal-type] * 8] 236 return "__builtin_isnand$bits" 237} 238 239proc isinf-builtin-name { } { 240 set bits [expr [c-sizeof-decimal-type] * 8] 241 return "__builtin_isinfd$bits" 242} 243 244# Return a string that declares a C union containing the decimal type 245# and an unsigned char array of the right size. 246 247proc c-union-decl { } { 248 append result " union {\n" 249 append result " [c-decimal-type] d;\n" 250 append result " unsigned char bytes\[[c-sizeof-decimal-type]\];\n" 251 append result " } u;" 252 return $result 253} 254 255proc transform-hex-constant {value} { 256 regsub \# $value {} value 257 regsub -all (\.\.) $value {0x\1, } bytes 258 return [list $bytes] 259} 260 261# Create a C program file (named using ID) containing a test for a 262# binary OPERATION on OP1 and OP2 that expects RESULT and CONDITIONS. 263 264proc make-c-test {testcase id operation result conditions op1 {op2 "NONE"}} { 265 global directives 266 set filename ${id}.c 267 set outfd [open $filename w] 268 269 puts $outfd [c-test-preamble $id] 270 puts $outfd [c-union-decl] 271 if {[string compare $result ?] != 0} { 272 if {[string index $result 0] == "\#"} { 273 puts $outfd " static unsigned char compare\[[c-sizeof-decimal-type]\] = [transform-hex-constant $result];" 274 } 275 } 276 if {[string compare $op2 NONE] == 0} { 277 if {[string index $op1 0] == "\#"} { 278 puts $outfd " static unsigned char fill\[[c-sizeof-decimal-type]\] = [transform-hex-constant $op1];" 279 } 280 } 281 282 puts $outfd "" 283 puts $outfd " /* FIXME: Set rounding mode with fesetround() once in libc. */" 284 puts $outfd " __dfp_set_round ([c-rounding-mode $directives(rounding)]);" 285 puts $outfd "" 286 287 # Build the expression to be tested. 288 if {[string compare $op2 NONE] == 0} { 289 if {[string index $op1 0] == "\#"} { 290 puts $outfd " memcpy (u.bytes, fill, [c-sizeof-decimal-type]);" 291 } else { 292 puts $outfd " u.d = [c-unary-expression $operation [c-operand $op1]];" 293 } 294 } else { 295 puts $outfd " u.d = [c-binary-expression $operation [c-operand $op1] [c-operand $op2]];" 296 } 297 298 # Test the result. 299 if {[string compare $result ?] != 0} { 300 # Not an undefined result .. 301 if {[string index $result 0] == "\#"} { 302 # Handle hex comparisons. 303 puts $outfd " return memcmp (u.bytes, compare, [c-sizeof-decimal-type]);" 304 } elseif {[nan-p $result]} { 305 puts $outfd " return ![isnan-builtin-name] (u.d);" 306 } elseif {[infinity-p $result]} { 307 puts $outfd " return ![isinf-builtin-name] (u.d);" 308 } else { 309 # Ordinary values. 310 puts $outfd " return !(u.d == [c-operand $result]);" 311 } 312 } else { 313 puts $outfd " return 0;" 314 } 315 316 puts $outfd [c-test-postamble $id] 317 close $outfd 318 return $filename 319} 320 321# Is the test supported for this target? 322 323proc supported-p { id op } { 324 global directives 325 global libfuncs 326 327 # Ops that are unsupported. Many of these tests fail because they 328 # do not tolerate the C front-end rounding the value of floating 329 # point literals to suit the type of the constant. Otherwise, by 330 # treating the `apply' operator like C assignment, some of them do 331 # pass. 332 switch -- $op { 333 apply { return 0 } 334 } 335 336 # Ditto for the following miscellaneous tests. 337 switch $id { 338 addx1130 { return 0 } 339 addx1131 { return 0 } 340 addx1132 { return 0 } 341 addx1133 { return 0 } 342 addx1134 { return 0 } 343 addx1135 { return 0 } 344 addx1136 { return 0 } 345 addx1138 { return 0 } 346 addx1139 { return 0 } 347 addx1140 { return 0 } 348 addx1141 { return 0 } 349 addx1142 { return 0 } 350 addx1151 { return 0 } 351 addx1152 { return 0 } 352 addx1153 { return 0 } 353 addx1154 { return 0 } 354 addx1160 { return 0 } 355 addx690 { return 0 } 356 mulx263 { return 0 } 357 subx947 { return 0 } 358 } 359 360 if [info exist libfuncs($op)] { 361 # No library support for now. 362 return 0 363 } 364 if [catch {c-rounding-mode $directives(rounding)}] { 365 # Unsupported rounding mode. 366 return 0 367 } 368 if [catch {c-decimal-type}] { 369 # Unsupported precision. 370 return 0 371 } 372 return 1 373} 374 375# Break LINE into a list of tokens. Be sensitive to quoting. 376# There has to be a better way to do this :-| 377 378proc tokenize { line } { 379 set quoting 0 380 set tokens [list] 381 382 foreach char [split $line {}] { 383 if {!$quoting} { 384 if { [info exists token] && $char == " " } { 385 if {[string compare "$token" "--"] == 0} { 386 # Only comments remain. 387 return $tokens 388 } 389 lappend tokens $token 390 unset token 391 } else { 392 if {![info exists token] && $char == "'" } { 393 set quoting 1 394 } else { 395 if { $char != " " } { 396 append token $char 397 } 398 } 399 } 400 } else { 401 # Quoting. 402 if { $char == "'" } { 403 set quoting 0 404 if [info exists token] { 405 lappend tokens $token 406 unset token 407 } else { 408 lappend tokens {} 409 } 410 } else { 411 append token $char 412 } 413 } 414 } 415 # Flush any residual token. 416 if {[info exists token] && [string compare $token "--"]} { 417 lappend tokens $token 418 } 419 return $tokens 420} 421 422# Process a directive in LINE. 423 424proc process-directive { line } { 425 global directives 426 set keyword [string tolower [string trim [lindex [split $line :] 0]]] 427 set value [string tolower [string trim [lindex [split $line :] 1]]] 428 set directives($keyword) $value 429} 430 431# Produce a C99-valid floating point literal. 432 433proc c-operand {operand} { 434 set bits [expr 8 * [c-sizeof-decimal-type]] 435 436 switch -glob -- $operand { 437 "Inf*" { return "__builtin_infd${bits} ()" } 438 "-Inf*" { return "- __builtin_infd${bits} ()" } 439 "NaN*" { return "__builtin_nand${bits} (\"\")" } 440 "-NaN*" { return "- __builtin_nand${bits} (\"\")" } 441 "sNaN*" { return "__builtin_nand${bits} (\"\")" } 442 "-sNaN*" { return "- __builtin_nand${bits} (\"\")" } 443 } 444 445 if {[string first . $operand] < 0 && \ 446 [string first E $operand] < 0 && \ 447 [string first e $operand] < 0} { 448 append operand . 449 } 450 set suffix [c-type-suffix [c-decimal-type]] 451 return [append operand $suffix] 452} 453 454# Process an arithmetic test in LINE from TESTCASE. 455 456proc process-test-case { testcase line } { 457 set testfile [file tail $testcase] 458 459 # Compress multiple spaces down to one. 460 regsub -all { *} $line { } line 461 462 set args [tokenize $line] 463 if {[llength $args] < 5} { 464 error "Skipping invalid test: $line" 465 return 466 } 467 468 set id [string trim [lindex $args 0]] 469 set operation [string trim [lindex $args 1]] 470 set operand1 [string trim [lindex $args 2]] 471 472 if { [string compare [lindex $args 3] -> ] == 0 } { 473 # Unary operation. 474 set operand2 NONE 475 set result_index 4 476 set cond_index 5 477 } else { 478 # Binary operation. 479 set operand2 [string trim [lindex $args 3]] 480 if { [string compare [lindex $args 4] -> ] != 0 } { 481 warning "Skipping invalid test: $line" 482 return 483 } 484 set result_index 5 485 set cond_index 6 486 } 487 488 set result [string trim [lindex $args $result_index]] 489 set conditions [list] 490 for { set i $cond_index } { $i < [llength $args] } { incr i } { 491 lappend conditions [string tolower [lindex $args $i]] 492 } 493 494 # If this test is unsupported, say so. 495 if ![supported-p $id $operation] { 496 unsupported "$testfile ($id)" 497 return 498 } 499 500 if {[string compare $operand1 \#] == 0 || \ 501 [string compare $operand2 \#] == 0} { 502 unsupported "$testfile ($id), null reference" 503 return 504 } 505 506 # Construct a C program and then compile/execute it on the target. 507 # Grab some stuff from the c-torture.exp test driver for this. 508 509 set cprog [make-c-test $testfile $id $operation $result $conditions $operand1 $operand2] 510 c-torture-execute $cprog [target-specific-flags] 511} 512 513### Script mainline: 514 515if [catch {set testdir $env(DECTEST)}] { 516 # If $DECTEST is unset, skip this test driver altogether. 517 return 518} 519 520torture-init 521set-torture-options $DEC_TORTURE_OPTIONS 522 523note "Using tests in $testdir" 524dfp-run-tests [lsort [glob -nocomplain $testdir/*.decTest]] 525unset testdir 526 527torture-finish 528