1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
|
# `dg' general purpose testcase driver.
# Copyright (C) 1994 - 2002, 2003 Free Software Foundation, Inc.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Please email any bugs, comments, and/or additions to this file to:
# bug-dejagnu@gnu.org
# This file was written by Doug Evans (dje@cygnus.com).
# This file is based on old-dejagnu.exp. It is intended to be more extensible
# without incurring the overhead that old-dejagnu.exp can. All test framework
# commands appear in the testcase as "{ dg-xxx args ... }". We pull them out
# with one grep, and then run the function(s) named by "dg-xxx". When running
# dg-xxx, the line number that it occurs on is always passed as the first
# argument. We also support different kinds of tools via callbacks.
#
# The currently supported options are:
#
# dg-prms-id N
# set prms_id to N
#
# dg-options "options ..." [{ target selector }]
# specify special options to pass to the tool (eg: compiler)
#
# dg-do do-what-keyword [{ target/xfail selector }]
# `do-what-keyword' is tool specific and is passed unchanged to
# ${tool}-dg-test. An example is gcc where `keyword' can be any of:
# preprocess|compile|assemble|link|run
# and will do one of: produce a .i, produce a .s, produce a .o,
# produce an a.out, or produce an a.out and run it (the default is
# compile).
#
# dg-error regexp comment [{ target/xfail selector } [{.|0|linenum}]]
# indicate an error message <regexp> is expected on this line
# (the test fails if it doesn't occur)
# Linenum=0 for general tool messages (eg: -V arg missing).
# "." means the current line.
#
# dg-warning regexp comment [{ target/xfail selector } [{.|0|linenum}]]
# indicate a warning message <regexp> is expected on this line
# (the test fails if it doesn't occur)
#
# dg-bogus regexp comment [{ target/xfail selector } [{.|0|linenum}]]
# indicate a bogus error message <regexp> use to occur here
# (the test fails if it does occur)
#
# dg-build regexp comment [{ target/xfail selector }]
# indicate the build use to fail for some reason
# (errors covered here include bad assembler generated, tool crashes,
# and link failures)
# (the test fails if it does occur)
#
# dg-excess-errors comment [{ target/xfail selector }]
# indicate excess errors are expected (any line)
# (this should only be used sparingly and temporarily)
#
# dg-output regexp [{ target selector }]
# indicate the expected output of the program is <regexp>
# (there may be multiple occurrences of this, they are concatenated)
#
# dg-final { tcl code }
# add some tcl code to be run at the end
# (there may be multiple occurrences of this, they are concatenated)
# (unbalanced braces must be \-escaped)
#
# "{ target selector }" is a list of expressions that determine whether the
# test succeeds or fails for a particular target, or in some cases whether the
# option applies for a particular target. If the case of `dg-do' it specifies
# whether the testcase is even attempted on the specified target.
#
# The target selector is always optional. The format is one of:
#
# { xfail *-*-* ... } - the test is expected to fail for the given targets
# { target *-*-* ... } - the option only applies to the given targets
#
# At least one target must be specified, use *-*-* for "all targets".
# At present it is not possible to specify both `xfail' and `target'.
# "native" may be used in place of "*-*-*".
#
# Example:
#
# [ ... some complicated code ... ]
# return a; /* { dg-build "fatal" "ran out of spill regs" { xfail i386-*-* } } */
#
# In this example, the compiler use to crash on the "return a;" for some
# target and that it still does crash on i386-*-*. Admittedly, this is a
# contrived example.
#
# ??? It might be possible to add additional optional arguments by having
# something like: { dg-error ".*syntax.*" "syntax error" { { foo 1 } ... } }
#
# Callbacks
#
# ${tool}-dg-test testfile do-what-keyword extra-flags
#
# Run the test, be it compiler, assembler, or whatever.
#
# ${tool}-dg-prune target_triplet text
#
# Optional callback to delete output from the tool that can occur
# even in successful ("pass") situations and interfere with output
# pattern matching. This also gives the tool an opportunity to review
# the output and check for any conditions which indicate an "untested"
# or "unresolved" state. An example is if a testcase is too big and
# fills all available ram (which can happen for 16 bit cpus). The
# result is either the pruned text or
# "::untested|unresolved|unsupported::message"
# (eg: "::unsupported::memory full").
#
# Notes:
# 1) All runnable testcases must return 0 from main() for success.
# You can't rely on getting any return code from target boards, and the
# `exec' command says a program fails if it returns non-zero.
#
# Language independence is (theoretically) achieved by:
#
# 1) Using global $tool to indicate the language (eg: gcc, g++, gas, etc.).
# This should only be used to look up other objects. We don't want to
# have to add code for each new language that is supported. If this is
# done right, no code needs to be added here for each new language.
#
# 2) Passing tool options in as arguments.
#
# Earlier versions of ${tool}_start (eg: gcc_start) would only take the name
# of the file to compile as an argument. Newer versions accept a list of
# one or two elements, the second being a string of *all* options to pass
# to the tool. We require this facility.
#
# 3) Callbacks.
#
# Try not to do anything else that makes life difficult.
#
# The normal way to write a testsuite is to have a .exp file containing:
#
# load_lib ${tool}-dg.exp
# dg-init
# dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/foo*]] ...
# dg-finish
# Global state variables.
# The defaults are for GCC.
# The default do-what keyword.
set dg-do-what-default compile
# When dg-interpreter-batch-mode is 1, no execution test or excess error
# tests are performed.
set dg-interpreter-batch-mode 0
# Line number format. This is how line numbers appear in program output.
set dg-linenum-format ":%d:"
proc dg-format-linenum { linenum } {
global dg-linenum-format
return [format ${dg-linenum-format} $linenum]
}
# Useful subroutines.
# dg-get-options -- pick out the dg-xxx options in a testcase
#
# PROG is the file name of the testcase.
# The result is a list of options found.
#
# Example: For the following testcase:
#
# /* { dg-prms-id 1234 } */
# int foo { return 0; } /* { dg-build fatal "some comment" } */
#
# we return:
#
# { dg-prms-id 1 1234 } { dg-build 2 fatal "some comment" }
proc dg-get-options { prog } {
set result ""
set tmp [grep $prog "{\[ \t\]\+dg-\[-a-z\]\+\[ \t\]\+.*\[ \t\]\+}" line]
if ![string match "" $tmp] {
foreach i $tmp {
#send_user "Found: $i\n"
# FIXME: When to use "+" and "\+" isn't clear.
# Seems to me it took awhile to get this to work.
regexp "(\[0-9\]\+)\[ \t\]\+{\[ \t\]+(dg-\[-a-z\]+)\[ \t\]\+(.*)\[ \t\]+}\[^\}\]*(\n|$)" $i i line cmd args
#send_user "Found: $cmd $line $args\n"
append result " { $cmd $line $args }"
}
}
#send_user "Returning: $result\n"
return $result
}
#
# Process optional xfail/target arguments
#
# SELECTOR is "xfail target-triplet-1 ..." or "target target-triplet-1 ..."
# `target-triplet' may be "native".
# For xfail, the result is "F" (expected to Fail) if the current target is
# affected, otherwise "P" (expected to Pass).
# For target, the result is "S" (target is Selected) if the target is selected,
# otherwise "N" (target is Not selected).
#
proc dg-process-target { selector } {
global target_triplet
set isnative [isnative]
set triplet_match 0
#send_user "dg-process-target: $selector\n"
set selector [string trim $selector]
if [regexp "^xfail " $selector] {
set what xfail
} elseif [regexp "^target " $selector] {
set what target
} else {
# The use of error here and in other dg-xxx utilities is intentional.
# dg-test will catch them and do the right thing.
error "syntax error in target selector \"$selector\""
}
# ??? This should work but it doesn't. tcl bug?
#if [regexp "^${what}(( \[^ \]+-\[^ \]+-\[^ \]+)|( native))+$" $selector tmp selector]
if [regexp "^${what}( \[^ \]+-\[^ \]+-\[^ \]+| native)+$" $selector] {
regsub "^${what} " $selector "" selector
#send_user "selector: $selector\n"
foreach triplet $selector {
if [string match $triplet $target_triplet] {
set triplet_match 1
} elseif { $isnative && $triplet == "native" } {
set triplet_match 1
}
}
} else {
error "syntax error in target selector \"$selector\""
}
if { $triplet_match } {
return [expr { $what == "xfail" ? "F" : "S" }]
} else {
return [expr { $what == "xfail" ? "P" : "N" }]
}
}
# Predefined user option handlers.
# The line number is always the first element.
# Note that each of these are varargs procs (they have an `args' argument).
# Tests for optional arguments are coded with ">=" to simplify adding new ones.
proc dg-prms-id { args } {
global prms_id ;# this is a testing framework variable
if { [llength $args] > 2 } {
error "[lindex $args 0]: too many arguments"
return
}
set prms_id [lindex $args 1]
}
#
# Set tool options
#
# Different options can be used for different targets by having multiple
# instances, selecting a different target each time. Since options are
# processed in order, put the default value first. Subsequent occurrences
# will override previous ones.
#
proc dg-options { args } {
upvar dg-extra-tool-flags extra-tool-flags
if { [llength $args] > 3 } {
error "[lindex $args 0]: too many arguments"
return
}
if { [llength $args] >= 3 } {
switch [dg-process-target [lindex $args 2]] {
"S" { set extra-tool-flags [lindex $args 1] }
"N" { }
"F" { error "[lindex $args 0]: `xfail' not allowed here" }
"P" { error "[lindex $args 0]: `xfail' not allowed here" }
}
} else {
set extra-tool-flags [lindex $args 1]
}
}
#
# Record what to do (compile/run/etc.)
#
# Multiple instances are supported (since we don't support target and xfail
# selectors on one line), though it doesn't make much sense to change the
# compile/assemble/link/run field. Nor does it make any sense to have
# multiple lines of target selectors (use one line).
#
proc dg-do { args } {
upvar dg-do-what do-what
if { [llength $args] > 3 } {
error "[lindex $args 0]: too many arguments"
return
}
set selected [lindex ${do-what} 1] ;# selected? (""/S/N)
set expected [lindex ${do-what} 2] ;# expected to pass/fail (P/F)
if { [llength $args] >= 3 } {
switch [dg-process-target [lindex $args 2]] {
"S" {
set selected "S"
}
"N" {
# Don't deselect a target if it's been explicitly selected,
# but indicate a specific target has been selected (so don't
# do this testcase if it's not appropriate for this target).
# The user really shouldn't have multiple lines of target
# selectors, but try to do the intuitive thing (multiple lines
# are OR'd together).
if { $selected != "S" } {
set selected "N"
}
}
"F" { set expected "F" }
"P" {
# There's nothing to do for "P". We don't want to clobber a
# previous xfail for this target.
}
}
} else {
# Note: A previous occurrence of `dg-do' with target/xfail selectors
# is a user mistake. We clobber previous values here.
set selected S
set expected P
}
switch [lindex $args 1] {
"preprocess" { }
"compile" { }
"assemble" { }
"link" { }
"run" { }
default {
error "[lindex $args 0]: syntax error"
}
}
set do-what [list [lindex $args 1] $selected $expected]
}
proc dg-error { args } {
upvar dg-messages messages
if { [llength $args] > 5 } {
error "[lindex $args 0]: too many arguments"
return
}
set xfail ""
if { [llength $args] >= 4 } {
switch [dg-process-target [lindex $args 3]] {
"F" { set xfail "X" }
"P" { set xfail "" }
"N" {
# If we get "N", this error doesn't apply to us so ignore it.
return
}
}
}
if { [llength $args] >= 5 } {
switch [lindex $args 4] {
"." { set line [dg-format-linenum [lindex $args 0]] }
"0" { set line "" }
"default" { set line [dg-format-linenum [lindex $args 4]] }
}
} else {
set line [dg-format-linenum [lindex $args 0]]
}
lappend messages [list $line "${xfail}ERROR" [lindex $args 1] [lindex $args 2]]
}
proc dg-warning { args } {
upvar dg-messages messages
if { [llength $args] > 5 } {
error "[lindex $args 0]: too many arguments"
return
}
set xfail ""
if { [llength $args] >= 4 } {
switch [dg-process-target [lindex $args 3]] {
"F" { set xfail "X" }
"P" { set xfail "" }
"N" {
# If we get "N", this warning doesn't apply to us so ignore it.
return
}
}
}
if { [llength $args] >= 5 } {
switch [lindex $args 4] {
"." { set line [dg-format-linenum [lindex $args 0]] }
"0" { set line "" }
"default" { set line [dg-format-linenum [lindex $args 4]] }
}
} else {
set line [dg-format-linenum [lindex $args 0]]
}
lappend messages [list $line "${xfail}WARNING" [lindex $args 1] [lindex $args 2]]
}
proc dg-bogus { args } {
upvar dg-messages messages
if { [llength $args] > 5 } {
error "[lindex $args 0]: too many arguments"
return
}
set xfail ""
if { [llength $args] >= 4 } {
switch [dg-process-target [lindex $args 3]] {
"F" { set xfail "X" }
"P" { set xfail "" }
"N" {
# If we get "N", this message doesn't apply to us so ignore it.
return
}
}
}
if { [llength $args] >= 5 } {
switch [lindex $args 4] {
"." { set line [dg-format-linenum [lindex $args 0]] }
"0" { set line "" }
"default" { set line [dg-format-linenum [lindex $args 4]] }
}
} else {
set line [dg-format-linenum [lindex $args 0]]
}
lappend messages [list $line "${xfail}BOGUS" [lindex $args 1] [lindex $args 2]]
}
proc dg-build { args } {
upvar dg-messages messages
if { [llength $args] > 4 } {
error "[lindex $args 0]: too many arguments"
return
}
set xfail ""
if { [ llength $args] >= 4 } {
switch [dg-process-target [lindex $args 3]] {
"F" { set xfail "X" }
"P" { set xfail "" }
"N" {
# If we get "N", this lossage doesn't apply to us so ignore it.
return
}
}
}
lappend messages [list [lindex $args 0] "${xfail}BUILD" [lindex $args 1] [lindex $args 2]]
}
proc dg-excess-errors { args } {
upvar dg-excess-errors-flag excess-errors-flag
if { [llength $args] > 3 } {
error "[lindex $args 0]: too many arguments"
return
}
if { [llength $args] >= 3 } {
switch [dg-process-target [lindex $args 2]] {
"F" { set excess-errors-flag 1 }
"S" { set excess-errors-flag 1 }
}
} else {
set excess-errors-flag 1
}
}
#
# Indicate expected program output
#
# We support multiple occurrences, but we do not implicitly insert newlines
# between them.
#
# Note that target boards don't all support this kind of thing so it's a good
# idea to specify the target all the time. If one or more targets are
# explicitly selected, the test won't be performed if we're not one of them
# (as long as we were never mentioned).
#
# If you have target dependent output and want to set an xfail for one or more
# of them, use { dg-output "" { xfail a-b-c ... } }. The "" won't contribute
# to the expected output.
#
proc dg-output { args } {
upvar dg-output-text output-text
if { [llength $args] > 3 } {
error "[lindex $args 0]: too many arguments"
return
}
# Allow target dependent output.
set expected [lindex ${output-text} 0]
if { [llength $args] >= 3 } {
switch [dg-process-target [lindex $args 2]] {
"N" { return }
"S" { }
"F" { set expected "F" }
# Don't override a previous xfail.
"P" { }
}
}
if { [llength ${output-text}] == 1 } {
# First occurrence.
set output-text [list $expected [lindex $args 1]]
} else {
set output-text [list $expected "[lindex ${output-text} 1][lindex $args 1]"]
}
}
proc dg-final { args } {
upvar dg-final-code final-code
if { [llength $args] > 2 } {
error "[lindex $args 0]: too many arguments"
return
}
#send_user "dg-final: $args\n"
append final-code "[lindex $args 1]\n"
}
#
# Set up our environment
#
# There currently isn't much to do, but always calling it allows us to add
# enhancements without having to update our callers.
# It must be run before calling `dg-test'.
proc dg-init { } {
}
# dg-runtest -- simple main loop useful to most testsuites
#
# FLAGS is a set of options to always pass.
# DEFAULT_EXTRA_FLAGS is a set of options to pass if the testcase doesn't
# specify any (with dg-option).
# ??? We're flipping between "flag" and "option" here.
proc dg-runtest { testcases flags default-extra-flags } {
global runtests
foreach testcase $testcases {
# If we're only testing specific files and this isn't one of them, skip it.
if ![runtest_file_p $runtests $testcase] {
continue
}
verbose "Testing [file tail [file dirname $testcase]]/[file tail $testcase]"
dg-test $testcase $flags ${default-extra-flags}
}
}
# dg-trim-dirname -- rip DIR_NAME out of FILE_NAME
#
# Syntax: dg-trim-dirname dir_name file_name
# We need to go through this contorsion in order to properly support
# directory-names which might have embedded regexp special characters.
proc dg-trim-dirname { dir_name file_name } {
set special_character "\[\?\+\-\.\(\)\$\|\]"
regsub -all $special_character $dir_name "\\\\&" dir_name
regsub "^$dir_name/?" $file_name "" file_name
return $file_name
}
# dg-test -- runs a new style DejaGnu test
#
# Syntax: dg-test [-keep-output] prog tool_flags default_extra_tool_flags
#
# PROG is the full path name of the file to pass to the tool (eg: compiler).
# TOOL_FLAGS is a set of options to always pass.
# DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none.
#proc dg-test { prog tool_flags default_extra_tool_flags } {
proc dg-test { args } {
global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format
global errorCode errorInfo
global tool
global srcdir ;# eg: /calvin/dje/build/gcc/./testsuite/
global host_triplet target_triplet
set keep 0
set i 0
if { [string index [lindex $args 0] 0] == "-" } {
for { set i 0 } { $i < [llength $args] } { incr i } {
if { [lindex $args $i] == "--" } {
incr i
break
} elseif { [lindex $args $i] == "-keep-output" } {
set keep 1
} elseif { [string index [lindex $args $i] 0] == "-" } {
clone_output "ERROR: dg-test: illegal argument: [lindex $args $i]"
return
} else {
break
}
}
}
if { $i + 3 != [llength $args] } {
clone_output "ERROR: dg-test: missing arguments in call"
return
}
set prog [lindex $args $i]
set tool_flags [lindex $args [expr $i + 1]]
set default_extra_tool_flags [lindex $args [expr $i + 2]]
set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*"
set name [dg-trim-dirname $srcdir $prog]
# If we couldn't rip $srcdir out of `prog' then just do the best we can.
# The point is to reduce the unnecessary noise in the logs. Don't strip
# out too much because different testcases with the same name can confuse
# `test-tool'.
if [string match "/*" $name] {
set name "[file tail [file dirname $prog]]/[file tail $prog]"
}
# We append the compilation flags, if any, to ensure that the test case
# names are unique.
if { "$tool_flags" != "" } {
set name "$name $tool_flags"
}
# Process any embedded dg options in the testcase.
# Use "" for the second element of dg-do-what so we can tell if it's been
# explicitly set to "S".
set dg-do-what [list ${dg-do-what-default} "" P]
set dg-excess-errors-flag 0
set dg-messages ""
set dg-extra-tool-flags $default_extra_tool_flags
set dg-final-code ""
# `dg-output-text' is a list of two elements: pass/fail and text.
# Leave second element off for now (indicates "don't perform test")
set dg-output-text "P"
# Define our own "special function" `unknown' so we catch spelling errors.
# But first rename the existing one so we can restore it afterwards.
catch {rename dg-save-unknown ""}
rename unknown dg-save-unknown
proc unknown { args } {
return -code error "unknown dg option: $args"
}
set tmp [dg-get-options $prog]
foreach op $tmp {
verbose "Processing option: $op" 3
set status [catch "$op" errmsg]
if { $status != 0 } {
if { 0 && [info exists errorInfo] } {
# This also prints a backtrace which will just confuse
# testcase writers, so it's disabled.
perror "$name: $errorInfo\n"
} else {
perror "$name: $errmsg for \"$op\"\n"
}
# ??? The call to unresolved here is necessary to clear `errcnt'.
# What we really need is a proc like perror that doesn't set errcnt.
# It should also set exit_status to 1.
unresolved "$name: $errmsg for \"$op\""
return
}
}
# Restore normal error handling.
rename unknown ""
rename dg-save-unknown unknown
# If we're not supposed to try this test on this target, we're done.
if { [lindex ${dg-do-what} 1] == "N" } {
unsupported "$name"
verbose "$name not supported on this target, skipping it" 3
return
}
# Run the tool and analyze the results.
# The result of ${tool}-dg-test is in a bit of flux.
# Currently it is the name of the output file (or "" if none).
# If we need more than this it will grow into a list of things.
# No intention is made (at this point) to preserve upward compatibility
# (though at some point we'll have to).
set results [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"];
set comp_output [lindex $results 0];
set output_file [lindex $results 1];
#send_user "\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n"
#send_user "\nold_dejagnu.exp: message = :$message:\n\n"
#send_user "\nold_dejagnu.exp: message length = [llength $message]\n\n"
foreach i ${dg-messages} {
verbose "Scanning for message: $i" 4
# Remove all error messages for the line [lindex $i 0]
# in the source file. If we find any, success!
set line [lindex $i 0]
set pattern [lindex $i 2]
set comment [lindex $i 3]
#send_user "Before:\n$comp_output\n"
if [regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] {
set comp_output [string trimleft $comp_output]
set ok pass
set uhoh fail
} else {
set ok fail
set uhoh pass
}
#send_user "After:\n$comp_output\n"
# $line will either be a formatted line number or a number all by
# itself. Delete the formatting.
scan $line ${dg-linenum-format} line
switch [lindex $i 1] {
"ERROR" {
$ok "$name $comment (test for errors, line $line)"
}
"XERROR" {
x$ok "$name $comment (test for errors, line $line)"
}
"WARNING" {
$ok "$name $comment (test for warnings, line $line)"
}
"XWARNING" {
x$ok "$name $comment (test for warnings, line $line)"
}
"BOGUS" {
$uhoh "$name $comment (test for bogus messages, line $line)"
}
"XBOGUS" {
x$uhoh "$name $comment (test for bogus messages, line $line)"
}
"BUILD" {
$uhoh "$name $comment (test for build failure, line $line)"
}
"XBUILD" {
x$uhoh "$name $comment (test for build failure, line $line)"
}
"EXEC" { }
"XEXEC" { }
}
#send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n"
}
#send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n"
# Remove messages from the tool that we can ignore.
#send_user "comp_output: $comp_output\n"
set comp_output [prune_warnings $comp_output]
if { [info proc ${tool}-dg-prune] != "" } {
set comp_output [${tool}-dg-prune $target_triplet $comp_output]
switch -glob $comp_output {
"::untested::*" {
regsub "::untested::" $comp_output "" message
untested "$name: $message"
return
}
"::unresolved::*" {
regsub "::unresolved::" $comp_output "" message
unresolved "$name: $message"
return
}
"::unsupported::*" {
regsub "::unsupported::" $comp_output "" message
unsupported "$name: $message"
return
}
}
}
# See if someone forgot to delete the extra lines.
regsub -all "\n+" $comp_output "\n" comp_output
regsub "^\n+" $comp_output "" comp_output
#send_user "comp_output: $comp_output\n"
# Don't do this if we're testing an interpreter.
# FIXME: why?
if { ${dg-interpreter-batch-mode} == 0 } {
# Catch excess errors (new bugs or incomplete testcases).
if ${dg-excess-errors-flag} {
setup_xfail "*-*-*"
}
if ![string match "" $comp_output] {
fail "$name (test for excess errors)"
send_log "Excess errors:\n$comp_output\n"
} else {
pass "$name (test for excess errors)"
}
}
# Run the executable image if asked to do so.
# FIXME: This is the only place where we assume a standard meaning to
# the `keyword' argument of dg-do. This could be cleaned up.
if { [lindex ${dg-do-what} 0] == "run" } {
if ![file exists $output_file] {
warning "$name compilation failed to produce executable"
} else {
set status -1
set result [${tool}_load $output_file]
set status [lindex $result 0];
set output [lindex $result 1];
#send_user "After exec, status: $status\n"
if { [lindex ${dg-do-what} 2] == "F" } {
setup_xfail "*-*-*"
}
if { "$status" == "pass" } {
pass "$name execution test"
verbose "Exec succeeded." 3
if { [llength ${dg-output-text}] > 1 } {
#send_user "${dg-output-text}\n"
if { [lindex ${dg-output-text} 0] == "F" } {
setup_xfail "*-*-*"
}
set texttmp [lindex ${dg-output-text} 1]
if { ![regexp $texttmp ${output}] } {
fail "$name output pattern test, is ${output}, should match $texttmp"
verbose "Failed test for output pattern $texttmp" 3
} else {
pass "$name output pattern test, $texttmp"
verbose "Passed test for output pattern $texttmp" 3
}
unset texttmp
}
} elseif { "$status" == "fail" } {
# It would be nice to get some info out of errorCode.
if [info exists errorCode] {
verbose "Exec failed, errorCode: $errorCode" 3
} else {
verbose "Exec failed, errorCode not defined!" 3
}
fail "$name execution test"
} else {
$status "$name execution test"
}
}
}
# Are there any further tests to perform?
# Note that if the program has special run-time requirements, running
# of the program can be delayed until here. Ditto for other situations.
# It would be a bit cumbersome though.
if ![string match ${dg-final-code} ""] {
regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code
# Note that the use of `args' here makes this a varargs proc.
proc dg-final-proc { args } ${dg-final-code}
verbose "Running dg-final tests." 3
verbose "dg-final-proc:\n[info body dg-final-proc]" 4
if [catch "dg-final-proc $prog" errmsg] {
perror "$name: error executing dg-final: $errmsg"
# ??? The call to unresolved here is necessary to clear `errcnt'.
# What we really need is a proc like perror that doesn't set errcnt.
# It should also set exit_status to 1.
unresolved "$name: error executing dg-final: $errmsg"
}
}
# Do some final clean up.
# When testing an interpreter, we don't compile something and leave an
# output file.
if { ! ${keep} && ${dg-interpreter-batch-mode} == 0 } {
catch "exec rm -f $output_file"
}
}
#
# Do any necessary cleanups
#
# This is called at the end to undo anything dg-init did (that needs undoing).
#
proc dg-finish { } {
# Reset this in case caller wonders whether s/he should.
global prms_id
set prms_id 0
# The framework doesn't like to see any error remnants, so remove them.
global errorInfo
if [info exists errorInfo] {
unset errorInfo
}
# If the tool has a "finish" routine, call it.
# There may be a bit of duplication (eg: resetting prms_id), leave it.
# Let's keep these procs robust.
global tool
if ![string match "" [info procs ${tool}_finish]] {
${tool}_finish
}
}
|