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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [gcc.misc-tests/] [dectest.exp] - Blame information for rev 867

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
# 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
# .
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 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  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 \n"
133
    append result "\#include \n"
134
    append result "\#include \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

powered by: WebSVN 2.1.0

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