OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gcc.misc-tests/] [dectest.exp] - Blame information for rev 690

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 690 jeremybenn
# Copyright 2005, 2006, 2007, 2008 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
# .
16
 
17
# DejaGnu test driver around Mike Cowlishaw's testsuite for decimal
18
# decimal arithmetic ("decTest").  See:
19
#    .
20
#
21
# Contributed by Ben Elliston .
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  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 \n"
134
    append result "\#include \n"
135
    append result "\#include \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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.