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

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