1# Copyright (C) 2012-2019 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# Test using the DMD testsuite.
18# Load support procs.
19load_lib gdc-dg.exp
20
21#
22# Convert DMD arguments to GDC equivalent
23#
24
25proc gdc-convert-args { args } {
26    set out ""
27
28    foreach arg [split [lindex $args 0] " "] {
29	# List of switches kept in ASCII collated order.
30	if [string match "-D" $arg] {
31	    lappend out "-fdoc"
32
33	} elseif { [regexp -- {^-I([\w+/-]+)} $arg pattern path] } {
34	    lappend out "-I$path"
35
36	} elseif { [regexp -- {^-J([\w+/-]+)} $arg pattern path] } {
37	    lappend out "-J$path"
38
39	} elseif [string match "-allinst" $arg] {
40	    lappend out "-fall-instantiations"
41
42	} elseif [string match "-betterC" $arg] {
43	    lappend out "-fno-druntime"
44
45	} elseif { [string match "-boundscheck" $arg]
46		 || [string match "-boundscheck=on" $arg] } {
47	    lappend out "-fbounds-check"
48
49	} elseif { [string match "-boundscheck=off" $arg]
50		   || [string match "-noboundscheck" $arg] } {
51	    lappend out "-fno-bounds-check"
52
53	} elseif [string match "-boundscheck=safeonly" $arg] {
54	    lappend out "-fbounds-check=safeonly"
55
56	} elseif [string match "-c" $arg] {
57	    lappend out "-c"
58
59	} elseif [string match "-d" $arg] {
60	    lappend out "-Wno-deprecated"
61
62	} elseif [string match "-de" $arg] {
63	    lappend out "-Wdeprecated"
64	    lappend out "-Werror"
65
66	} elseif [string match "-debug" $arg] {
67	    lappend out "-fdebug"
68
69	} elseif [regexp -- {^-debug=(\w+)} $arg pattern value] {
70	    lappend out "-fdebug=$value"
71
72	} elseif [string match "-dip1000" $arg] {
73	    lappend out "-ftransition=dip1000"
74
75	} elseif [string match "-dip25" $arg] {
76	    lappend out "-ftransition=dip25"
77
78	} elseif [string match "-dw" $arg] {
79	    lappend out "-Wdeprecated"
80	    lappend out "-Wno-error"
81
82	} elseif [string match "-fPIC" $arg] {
83	    lappend out "-fPIC"
84
85	} elseif { [string match "-g" $arg]
86		   || [string match "-gc" $arg] } {
87	    lappend out "-g"
88
89	} elseif [string match "-inline" $arg] {
90	    lappend out "-finline-functions"
91
92	} elseif [string match "-main" $arg] {
93	    lappend out "-fmain"
94
95	} elseif [regexp -- {^-mv=([\w+=./-]+)} $arg pattern value] {
96	    lappend out "-fmodule-file=$value"
97
98	} elseif [string match "-O" $arg] {
99	    lappend out "-O2"
100
101	} elseif [string match "-release" $arg] {
102	    lappend out "-frelease"
103
104	} elseif [regexp -- {^-transition=(\w+)} $arg pattern value] {
105	    lappend out "-ftransition=$value"
106
107	} elseif [string match "-unittest" $arg] {
108	    lappend out "-funittest"
109
110	} elseif [string match "-verrors=spec" $arg] {
111	    lappend out "-Wspeculative"
112
113	} elseif [regexp -- {^-verrors=(\d+)} $arg pattern num] {
114	    lappend out "-fmax-errors=$num"
115
116	} elseif [regexp -- {^-version=(\w+)} $arg pattern value] {
117	    lappend out "-fversion=$value"
118
119	} elseif [string match "-vtls" $arg] {
120	    lappend out "-ftransition=tls"
121
122	} elseif [string match "-w" $arg] {
123	    lappend out "-Wall"
124	    lappend out "-Werror"
125
126	} elseif [string match "-wi" $arg] {
127	    lappend out "-Wall"
128	    lappend out "-Wno-error"
129
130	} else {
131	    # print "Unhandled Argument: $arg"
132	}
133    }
134
135    return $out
136}
137
138proc gdc-copy-extra { base extra } {
139    # Split base, folder/file.
140    set type [file dirname $extra]
141
142    # print "Filename: $base - $extra"
143
144    set fdin [open $base/$extra r]
145    fconfigure $fdin -encoding binary
146
147    file mkdir $type
148    set fdout [open $extra w]
149    fconfigure $fdout -encoding binary
150
151    while { [gets $fdin copy_line] >= 0 } {
152	set out_line $copy_line
153	puts $fdout $out_line
154    }
155
156    close $fdin
157    close $fdout
158
159    # Remove file once test is finished.
160    upvar 2 cleanup_extra_files cleanups
161    lappend cleanups $extra
162
163    return $extra
164}
165
166#
167# Translate DMD test directives to dejagnu equivalent.
168#
169#   COMPILE_SEPARATELY: Not handled.
170#   EXECUTE_ARGS:	Parameters to add to the execution of the test.
171#   COMPILED_IMPORTS:	List of modules files that are imported by the main
172#			source file that should be included in compilation.
173#			Currently handled the same as EXTRA_SOURCES.
174#   EXTRA_SOURCES:	List of extra sources to build and link along with
175#			the test.
176#   EXTRA_FILES:	List of extra files to copy for the test runs.
177#   PERMUTE_ARGS:	The set of arguments to permute in multiple compiler
178#			invocations.  An empty set means only one permutation
179#			with no arguments.
180#   TEST_OUTPUT:	The output expected from the compilation.
181#   POST_SCRIPT:	Not handled.
182#   REQUIRED_ARGS:	Arguments to add to the compiler command line.
183#   DISABLED:		Not handled.
184#
185
186proc dmd2dg { base test } {
187    global DEFAULT_DFLAGS
188    global PERMUTE_ARGS
189    global GDC_EXECUTE_ARGS
190
191    set PERMUTE_ARGS $DEFAULT_DFLAGS
192    set GDC_EXECUTE_ARGS ""
193
194    set extra_sources ""
195    set extra_files ""
196
197    # Split base, folder/file.
198    set type [file dirname $test]
199    set name [file tail $test]
200
201    # print "Filename: $base - $test"
202
203    set fdin [open $base/$test r]
204    #fconfigure $fdin -encoding binary
205
206    file mkdir $type
207    set fdout [open $test w]
208    #fconfigure $fdout -encoding binary
209
210    while { [gets $fdin copy_line] >= 0 } {
211	set out_line $copy_line
212
213	if [regexp -- {COMPILE_SEPARATELY} $copy_line] {
214	    # COMPILE_SEPARATELY is not handled.
215	    regsub -- {COMPILE_SEPARATELY.*$} $copy_line "" out_line
216
217	} elseif [regexp -- {DISABLED} $copy_line] {
218	    # DISABLED is not handled.
219	    regsub -- {DISABLED.*$} $copy_line "" out_line
220
221	} elseif [regexp -- {POST_SCRIPT} $copy_line] {
222	    # POST_SCRIPT is not handled
223	    regsub -- {POST_SCRIPT.*$} $copy_line "" out_line
224
225	} elseif [regexp -- {PERMUTE_ARGS\s*:\s*(.*)} $copy_line match args] {
226	    # PERMUTE_ARGS is handled by gdc-do-test.
227	    set PERMUTE_ARGS [gdc-convert-args $args]
228	    regsub -- {PERMUTE_ARGS.*$} $copy_line "" out_line
229
230	} elseif [regexp -- {EXECUTE_ARGS\s*:\s*(.*)} $copy_line match args] {
231	    # EXECUTE_ARGS is handled by gdc_load.
232	    foreach arg $args {
233		lappend GDC_EXECUTE_ARGS $arg
234	    }
235	    regsub -- {EXECUTE_ARGS.*$} $copy_line "" out_line
236
237	} elseif [regexp -- {REQUIRED_ARGS\s*:\s*(.*)} $copy_line match args] {
238	    # Convert all listed arguments to from dmd to gdc-style.
239	    set new_option "{ dg-additional-options \"[gdc-convert-args $args]\" }"
240	    regsub -- {REQUIRED_ARGS.*$} $copy_line $new_option out_line
241
242	} elseif [regexp -- {EXTRA_SOURCES\s*:\s*(.*)} $copy_line match sources] {
243	    # EXTRA_SOURCES are appended to extra_sources list
244	    foreach srcfile $sources {
245		lappend extra_sources $srcfile
246	    }
247	    regsub -- {EXTRA_SOURCES.*$} $copy_line "" out_line
248
249	} elseif [regexp -- {EXTRA_CPP_SOURCES\s*:\s*(.*)} $copy_line match sources] {
250	    # EXTRA_CPP_SOURCES are appended to extra_sources list
251	    foreach srcfile $sources {
252		# C++ sources are found in the extra-files directory.
253		lappend extra_sources "extra-files/$srcfile"
254	    }
255	    regsub -- {EXTRA_CPP_SOURCES.*$} $copy_line "" out_line
256
257	} elseif [regexp -- {EXTRA_FILES\s*:\s*(.*)} $copy_line match files] {
258	    # EXTRA_FILES are appended to extra_files list
259	    foreach file $files {
260		lappend extra_files $file
261	    }
262	    regsub -- {EXTRA_FILES.*$} $copy_line "" out_line
263
264	} elseif [regexp -- {COMPILED_IMPORTS\s*:\s*(.*)} $copy_line match sources] {
265	    # COMPILED_IMPORTS are appended to extra_sources list
266	    foreach import $sources {
267		lappend extra_sources $import
268	    }
269	    regsub -- {COMPILED_IMPORTS.*$} $copy_line "" out_line
270
271	}
272
273	puts $fdout $out_line
274    }
275
276    # Now that all extra sources and files have been collected, copy them all
277    # to the testsuite build directory.
278    if { [llength $extra_sources] > 0 } {
279	foreach srcfile $extra_sources {
280	    gdc-copy-extra $base "$type/$srcfile"
281	}
282	set out_line "// { dg-additional-sources \"$extra_sources\" }"
283	puts $fdout $out_line
284    }
285
286    if { [llength $extra_files] > 0 } {
287	foreach file $extra_files {
288	    gdc-copy-extra $base "$type/$file"
289	}
290	set out_line "// { dg-additional-files \"$extra_files\" }"
291	puts $fdout $out_line
292    }
293
294    # Add specific options for test type
295
296    # DMD's testsuite is extremely verbose, compiler messages from constructs
297    # such as pragma(msg, ...) would otherwise cause tests to fail.
298    set out_line "// { dg-prune-output .* }"
299    puts $fdout $out_line
300
301    # Compilable files are successful if an output is generated.
302    # Fail compilable are successful if an output is not generated.
303    # Runnable must compile, link, and return 0 to be successful by default.
304    switch $type {
305	runnable {
306	    if ![isnative] {
307		set out_line "// { dg-final { output-exists } }"
308		puts $fdout $out_line
309	    }
310	}
311
312	compilable {
313	    set out_line "// { dg-final { output-exists } }"
314	    puts $fdout $out_line
315
316	    # Check that Ddoc tests also generate a html file.
317	    if [regexp -- "ddoc.*" $name] {
318		set ddocfile "[file rootname $name].html"
319		set out_line "// { dg-final { scan-file $ddocfile \"Generated by Ddoc from $test\" } }"
320		puts $fdout $out_line
321		# Cleanup extra generated files.
322		set out_line "// { dg-final { file delete $ddocfile } }"
323		puts $fdout $out_line
324	    }
325	}
326
327	fail_compilation {
328	    set out_line "// { dg-final { output-exists-not } }"
329	    puts $fdout $out_line
330	}
331    }
332
333    close $fdin
334    close $fdout
335
336    return $test
337}
338
339proc gdc-permute-options { options } {
340    set result { }
341    set n [expr 1<<[llength $options]]
342    for { set i 0 } { $i<$n } { incr i } {
343	set option ""
344	for { set j 0 } { $j<[llength $options] } { incr j } {
345	    if [expr $i & 1 << $j] {
346		append option [lindex $options $j]
347		append option " "
348	    }
349	}
350	lappend result $option
351
352    }
353    return $result
354}
355
356
357proc gdc-do-test { } {
358    global srcdir subdir
359    global dg-do-what-default
360    global verbose
361
362    # If a testcase doesn't have special options, use these.
363    global DEFAULT_DFLAGS
364    if ![info exists DEFAULT_DFLAGS] then {
365	set DEFAULT_DFLAGS "-g -O2 -frelease"
366	#set DEFAULT_DFLAGS "-O2"
367    }
368
369    # These are special options to use on testcase, and override DEFAULT_DFLAGS
370    global PERMUTE_ARGS
371
372    # Set if an extra option should be passed to link to shared druntime.
373    global SHARED_OPTION
374
375    # Additional arguments for gdc_load
376    global GDC_EXECUTE_ARGS
377
378    # Initialize `dg'.
379    dg-init
380
381    # Allow blank linkes in output for all of gdc.test.
382    global allow_blank_lines
383    set save_allow_blank_lines $allow_blank_lines
384    if { !$allow_blank_lines } {
385	set allow_blank_lines 2
386    }
387
388    # Create gdc.test link so test names include that subdir.
389    catch { file link $subdir . }
390
391    # Main loop.
392
393    # set verbose 1
394    # set dg-final-code ""
395    # Find all tests and pass to routine.
396    foreach test [lsort [find $srcdir/$subdir *]] {
397	regexp -- "(.*)/(.+)/(.+)\.(.+)$" $test match base dir name ext
398
399	# Skip invalid test directory
400	if { [lsearch "runnable compilable fail_compilation" $dir] == -1 } {
401	    continue
402	}
403
404	# Skip invalid test extensions
405	if { [lsearch "d" $ext] == -1 } {
406	    continue
407	}
408
409	# Convert to DG test.
410	set imports [format "-I%s/%s" $base $dir]
411	set cleanup_extra_files ""
412	# Include $subdir prefix so test names follow DejaGnu conventions.
413	set filename "$subdir/[dmd2dg $base $dir/$name.$ext]"
414
415	if { $dir == "runnable" } {
416	    append PERMUTE_ARGS " $SHARED_OPTION"
417	}
418	set options [gdc-permute-options [lsort -unique $PERMUTE_ARGS]]
419
420	switch $dir {
421	    runnable {
422		for { set i 0 } { $i<[llength $options] } { incr i } {
423		    set flags [lindex $options $i]
424		    if [isnative] {
425			set dg-do-what-default "run"
426		    } else {
427			set dg-do-what-default "link"
428		    }
429		    gdc-dg-runtest $filename $flags $imports
430		}
431	    }
432
433	    compilable {
434		for { set i 0 } { $i<[llength $options] } { incr i } {
435		    set flags [lindex $options $i]
436		    # Compilable test may require checking another kind of output file.
437		    if [regexp -- "ddoc.*" $name] {
438			set dg-do-what-default "compile"
439		    } else {
440			set dg-do-what-default "assemble"
441		    }
442		    gdc-dg-runtest $filename $flags $imports
443		}
444	    }
445
446	    fail_compilation {
447		for { set i 0 } { $i<[llength $options] } { incr i } {
448		    set flags [lindex $options $i]
449		    set dg-do-what-default "assemble"
450		    gdc-dg-runtest $filename $flags $imports
451		}
452	    }
453	}
454
455	# Cleanup test directory.
456	foreach srcfile $cleanup_extra_files {
457	    file delete $subdir/$srcfile
458	}
459	file delete $filename
460    }
461
462    set allow_blank_lines $save_allow_blank_lines
463
464    # All done.
465    dg-finish
466}
467
468gdc-do-test
469
470