gcc/testsuite/gcc.misc-tests/dectest.exp

   1 # Copyright (C) 2005-2021 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
  23 set DEC_TORTURE_OPTIONS [list {} -O1 -O2 -O3 -Os -msoft-float]
  24
  25 proc target-specific-flags {} {
  26   set result "-frounding-math "
  27   return $result
  28 }
  29
  30 # Load support procs (borrow these from c-torture).
  31 load_lib c-torture.exp
  32 load_lib target-supports.exp
  33 load_lib torture-options.exp
  34
  35 # Skip these tests for targets that don't support this extension.
  36 if { ![check_effective_target_dfp] } {
  37     return
  38 }
  39
  40 # The list format is [coefficient, max-exponent, min-exponent].
  41 set properties(_Decimal32) [list 7 96 -95]
  42 set properties(_Decimal64) [list 16 384 -383]
  43 set properties(_Decimal128) [list 34 6144 -6143]
  44
  45 # Operations implemented by the compiler.
  46 set operators(add) {+}
  47 set operators(compare) {==}
  48 set operators(divide) {/}
  49 set operators(multiply) {*}
  50 set operators(subtract) {-}
  51 set operators(minus) {-}
  52 set operators(plus) {+}
  53 set operators(apply) {}
  54
  55 # Operations imlemented by the library.
  56 set libfuncs(abs) fabsl
  57 set libfuncs(squareroot) sqrtl
  58 set libfuncs(max) fmaxl
  59 set libfuncs(min) fminl
  60 set libfuncs(quantize) quantize
  61 set libfuncs(samequantum) samequantum
  62 set libfuncs(power) powl
  63 set libfuncs(toSci) unknown
  64 set libfuncs(tosci) unknown
  65 set libfuncs(toEng) unknown
  66 set libfuncs(toeng) unknown
  67 set libfuncs(divideint) unknown
  68 set libfuncs(rescale) unknown
  69 set libfuncs(remainder) unknown
  70 set libfuncs(remaindernear) unknown
  71 set libfuncs(normalize) unknown
  72 set libfuncs(tointegral) unknown
  73 set 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
  79 proc 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
  92 proc 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
 116 proc 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
 130 proc 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
 144 proc c-test-postamble { id } {
 145     return "\}"
 146 }
 147
 148 # Generate a C unary expression that applies OPERATION to OP.
 149
 150 proc 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
 164 proc 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
 177 proc 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
 196 proc 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
 207 proc 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
 218 proc nan-p { operand } {
 219     if {[string match "NaN*" $operand] || [string match "-NaN*" $operand]} {
 220         return 1
 221     } else {
 222         return 0
 223     }
 224 }
 225
 226 proc infinity-p { operand } {
 227     if {[string match "Inf*" $operand] || [string match "-Inf*" $operand]} {
 228         return 1
 229     } else {
 230         return 0
 231     }
 232 }
 233
 234 proc isnan-builtin-name { } {
 235     set bits [expr [c-sizeof-decimal-type] * 8]
 236     return "__builtin_isnand$bits"
 237 }
 238
 239 proc 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
 247 proc 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
 255 proc 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
 264 proc 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
 323 proc 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
 378 proc 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
 424 proc 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
 433 proc 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
 456 proc 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
 515 if [catch {set testdir $env(DECTEST)}] {
 516     # If $DECTEST is unset, skip this test driver altogether.
 517     return
 518 }
 519
 520 torture-init
 521 set-torture-options $DEC_TORTURE_OPTIONS
 522
 523 note "Using tests in $testdir"
 524 dfp-run-tests [lsort [glob -nocomplain $testdir/*.decTest]]
 525 unset testdir
 526
 527 torture-finish