| # Copyright (C) 2012-2018 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 3 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 GCC; see the file COPYING3. If not see |
| # <http://www.gnu.org/licenses/>. |
| |
| # Test using the DMD testsuite. |
| # Load support procs. |
| load_lib gdc-dg.exp |
| |
| # |
| # Convert DMD arguments to GDC equivalent |
| # |
| |
| proc gdc-convert-args { args } { |
| set out "" |
| |
| foreach arg [split [lindex $args 0] " "] { |
| # List of switches kept in ASCII collated order. |
| if { [regexp -- {^-I([\w+/-]+)} $arg pattern path] } { |
| lappend out "-I$path" |
| |
| } elseif { [regexp -- {^-J([\w+/-]+)} $arg pattern path] } { |
| lappend out "-J$path" |
| |
| } elseif [string match "-allinst" $arg] { |
| lappend out "-fall-instantiations" |
| |
| } elseif { [string match "-boundscheck" $arg] |
| || [string match "-boundscheck=on" $arg] } { |
| lappend out "-fbounds-check" |
| |
| } elseif { [string match "-boundscheck=off" $arg] |
| || [string match "-noboundscheck" $arg] } { |
| lappend out "-fno-bounds-check" |
| |
| } elseif [string match "-boundscheck=safeonly" $arg] { |
| lappend out "-fbounds-check=safeonly" |
| |
| } elseif [string match "-c" $arg] { |
| lappend out "-c" |
| |
| } elseif [string match "-d" $arg] { |
| lappend out "-Wno-deprecated" |
| |
| } elseif [string match "-de" $arg] { |
| lappend out "-Wdeprecated" |
| lappend out "-Werror" |
| |
| } elseif [string match "-debug" $arg] { |
| lappend out "-fdebug" |
| |
| } elseif [regexp -- {^-debug=(\w+)} $arg pattern value] { |
| lappend out "-fdebug=$value" |
| |
| } elseif [string match "-dip1000" $arg] { |
| lappend out "-ftransition=dip1000" |
| |
| } elseif [string match "-dip25" $arg] { |
| lappend out "-ftransition=dip25" |
| |
| } elseif [string match "-dw" $arg] { |
| lappend out "-Wdeprecated" |
| lappend out "-Wno-error" |
| |
| } elseif [string match "-fPIC" $arg] { |
| lappend out "-fPIC" |
| |
| } elseif { [string match "-g" $arg] |
| || [string match "-gc" $arg] } { |
| lappend out "-g" |
| |
| } elseif [string match "-inline" $arg] { |
| lappend out "-finline-functions" |
| |
| } elseif [string match "-main" $arg] { |
| lappend out "-fmain" |
| |
| } elseif [regexp -- {^-mv=([\w+=./-]+)} $arg pattern value] { |
| lappend out "-fmodule-file=$value" |
| |
| } elseif [string match "-O" $arg] { |
| lappend out "-O2" |
| |
| } elseif [string match "-release" $arg] { |
| lappend out "-frelease" |
| |
| } elseif [regexp -- {^-transition=(\w+)} $arg pattern value] { |
| lappend out "-ftransition=$value" |
| |
| } elseif [string match "-unittest" $arg] { |
| lappend out "-funittest" |
| |
| } elseif [string match "-verrors=spec" $arg] { |
| lappend out "-Wspeculative" |
| |
| } elseif [regexp -- {^-verrors=(\d+)} $arg pattern num] { |
| lappend out "-fmax-errors=$num" |
| |
| } elseif [regexp -- {^-version=(\w+)} $arg pattern value] { |
| lappend out "-fversion=$value" |
| |
| } elseif [string match "-vtls" $arg] { |
| lappend out "-ftransition=tls" |
| |
| } elseif [string match "-w" $arg] { |
| lappend out "-Wall" |
| lappend out "-Werror" |
| |
| } elseif [string match "-wi" $arg] { |
| lappend out "-Wall" |
| lappend out "-Wno-error" |
| |
| } else { |
| # print "Unhandled Argument: $arg" |
| } |
| } |
| |
| return $out |
| } |
| |
| proc gdc-copy-extra { base extra } { |
| # Split base, folder/file. |
| set type [file dirname $extra] |
| |
| # print "Filename: $base - $extra" |
| |
| set fdin [open $base/$extra r] |
| fconfigure $fdin -encoding binary |
| |
| file mkdir $type |
| set fdout [open $extra w] |
| fconfigure $fdout -encoding binary |
| |
| while { [gets $fdin copy_line] >= 0 } { |
| set out_line $copy_line |
| puts $fdout $out_line |
| } |
| |
| close $fdin |
| close $fdout |
| |
| return $extra |
| } |
| |
| # |
| # Translate DMD test directives to dejagnu equivalent. |
| # |
| # COMPILE_SEPARATELY: Not handled. |
| # EXECUTE_ARGS: Parameters to add to the execution of the test. |
| # COMPILED_IMPORTS: List of modules files that are imported by the main |
| # source file that should be included in compilation. |
| # Currently handled the same as EXTRA_SOURCES. |
| # EXTRA_SOURCES: List of extra sources to build and link along with |
| # the test. |
| # EXTRA_FILES: List of extra files to copy for the test runs. |
| # PERMUTE_ARGS: The set of arguments to permute in multiple compiler |
| # invocations. An empty set means only one permutation |
| # with no arguments. |
| # TEST_OUTPUT: The output expected from the compilation. |
| # POST_SCRIPT: Not handled. |
| # REQUIRED_ARGS: Arguments to add to the compiler command line. |
| # DISABLED: Not handled. |
| # |
| |
| proc dmd2dg { base test } { |
| global DEFAULT_DFLAGS |
| global PERMUTE_ARGS |
| global GDC_EXECUTE_ARGS |
| |
| set PERMUTE_ARGS $DEFAULT_DFLAGS |
| set GDC_EXECUTE_ARGS "" |
| |
| # Split base, folder/file. |
| set type [file dirname $test] |
| |
| # print "Filename: $base - $test" |
| |
| set fdin [open $base/$test r] |
| #fconfigure $fdin -encoding binary |
| |
| file mkdir $type |
| set fdout [open $test w] |
| #fconfigure $fdout -encoding binary |
| |
| while { [gets $fdin copy_line] >= 0 } { |
| set out_line $copy_line |
| |
| if [regexp -- {COMPILE_SEPARATELY} $copy_line] { |
| # COMPILE_SEPARATELY is not handled. |
| regsub -- {COMPILE_SEPARATELY.*$} $copy_line "" out_line |
| |
| } elseif [regexp -- {DISABLED} $copy_line] { |
| # DISABLED is not handled. |
| regsub -- {DISABLED.*$} $copy_line "" out_line |
| |
| } elseif [regexp -- {POST_SCRIPT} $copy_line] { |
| # POST_SCRIPT is not handled |
| regsub -- {POST_SCRIPT.*$} $copy_line "" out_line |
| |
| } elseif [regexp -- {PERMUTE_ARGS\s*:\s*(.*)} $copy_line match args] { |
| # PERMUTE_ARGS is handled by gdc-do-test. |
| set PERMUTE_ARGS [gdc-convert-args $args] |
| regsub -- {PERMUTE_ARGS.*$} $copy_line "" out_line |
| |
| } elseif [regexp -- {EXECUTE_ARGS\s*:\s*(.*)} $copy_line match args] { |
| # EXECUTE_ARGS is handled by gdc_load. |
| foreach arg $args { |
| lappend GDC_EXECUTE_ARGS $arg |
| } |
| regsub -- {EXECUTE_ARGS.*$} $copy_line "" out_line |
| |
| } elseif [regexp -- {REQUIRED_ARGS\s*:\s*(.*)} $copy_line match args] { |
| # Convert all listed arguments to from dmd to gdc-style. |
| set new_option "{ dg-additional-options \"[gdc-convert-args $args]\" }" |
| regsub -- {REQUIRED_ARGS.*$} $copy_line $new_option out_line |
| |
| } elseif [regexp -- {EXTRA_SOURCES\s*:\s*(.*)} $copy_line match sources] { |
| # Copy all sources to the testsuite build directory. |
| foreach import $sources { |
| # print "Import: $base $type/$import" |
| gdc-copy-extra $base "$type/$import" |
| } |
| set new_option "{ dg-additional-sources \"$sources\" }" |
| regsub -- {EXTRA_SOURCES.*$} $copy_line $new_option out_line |
| |
| } elseif [regexp -- {EXTRA_CPP_SOURCES\s*:\s*(.*)} $copy_line match sources] { |
| # Copy all sources to the testsuite build directory. |
| foreach import $sources { |
| # print "Import: $base $type/$import" |
| gdc-copy-extra $base "$type/$import" |
| } |
| set new_option "{ dg-additional-sources \"$sources\" }" |
| regsub -- {EXTRA_CPP_SOURCES.*$} $copy_line $new_option out_line |
| |
| } elseif [regexp -- {EXTRA_FILES\s*:\s*(.*)} $copy_line match files] { |
| # Copy all files to the testsuite build directory. |
| foreach import $files { |
| # print "Import: $base $type/$import" |
| gdc-copy-extra $base "$type/$import" |
| } |
| set new_option "{ dg-additional-files \"$files\" }" |
| regsub -- {EXTRA_FILES.*$} $copy_line $new_option out_line |
| |
| } elseif [regexp -- {COMPILED_IMPORTS\s*:\s*(.*)} $copy_line match sources] { |
| # Copy all sources to the testsuite build directory. |
| foreach import $sources { |
| # print "Import: $base $type/$import" |
| gdc-copy-extra $base "$type/$import" |
| } |
| set new_option "{ dg-additional-sources \"$sources\" }" |
| regsub -- {COMPILED_IMPORTS.*$} $copy_line $new_option out_line |
| |
| } |
| |
| puts $fdout $out_line |
| } |
| |
| # Add specific options for test type |
| |
| # DMD's testsuite is extremely verbose, compiler messages from constructs |
| # such as pragma(msg, ...) would otherwise cause tests to fail. |
| set out_line "// { dg-prune-output .* }" |
| puts $fdout $out_line |
| |
| # Since GCC 6-20160131 blank lines are not allowed in the output by default. |
| dg-allow-blank-lines-in-output { 1 } |
| |
| # Compilable files are successful if an output is generated. |
| # Fail compilable are successful if an output is not generated. |
| # Runnable must compile, link, and return 0 to be successful by default. |
| switch [file dirname $test] { |
| runnable { |
| if ![isnative] { |
| set out_line "// { dg-final { output-exists } }" |
| puts $fdout $out_line |
| } |
| } |
| |
| compilable { |
| set out_line "// { dg-final { output-exists } }" |
| puts $fdout $out_line |
| } |
| |
| fail_compilation { |
| set out_line "// { dg-final { output-exists-not } }" |
| puts $fdout $out_line |
| } |
| } |
| |
| close $fdin |
| close $fdout |
| |
| return $test |
| } |
| |
| proc gdc-permute-options { options } { |
| set result { } |
| set n [expr 1<<[llength $options]] |
| for { set i 0 } { $i<$n } { incr i } { |
| set option "" |
| for { set j 0 } { $j<[llength $options] } { incr j } { |
| if [expr $i & 1 << $j] { |
| append option [lindex $options $j] |
| append option " " |
| } |
| } |
| lappend result $option |
| |
| } |
| return $result |
| } |
| |
| |
| proc gdc-do-test { } { |
| global srcdir subdir |
| global dg-do-what-default |
| global verbose |
| |
| # If a testcase doesn't have special options, use these. |
| global DEFAULT_DFLAGS |
| if ![info exists DEFAULT_DFLAGS] then { |
| set DEFAULT_DFLAGS "-g -O2 -frelease" |
| #set DEFAULT_DFLAGS "-O2" |
| } |
| |
| # These are special options to use on testcase, and override DEFAULT_DFLAGS |
| global PERMUTE_ARGS |
| |
| # Set if an extra option should be passed to link to shared druntime. |
| global SHARED_OPTION |
| |
| # Additional arguments for gdc_load |
| global GDC_EXECUTE_ARGS |
| |
| # Initialize `dg'. |
| dg-init |
| |
| # Main loop. |
| |
| # set verbose 1 |
| # set dg-final-code "" |
| # Find all tests and pass to routine. |
| foreach test [lsort [find $srcdir/$subdir *]] { |
| regexp -- "(.*)/(.+)/(.+)\.(.+)$" $test match base dir name ext |
| |
| # Skip invalid test directory |
| if { [lsearch "runnable compilable fail_compilation" $dir] == -1 } { |
| continue |
| } |
| |
| # Skip invalid test extensions |
| if { [lsearch "d" $ext] == -1 } { |
| continue |
| } |
| |
| # Convert to DG test. |
| set imports [format "-I%s/%s" $base $dir] |
| set filename [dmd2dg $base $dir/$name.$ext] |
| |
| if { $dir == "runnable" } { |
| append PERMUTE_ARGS " $SHARED_OPTION" |
| } |
| set options [gdc-permute-options $PERMUTE_ARGS] |
| |
| switch $dir { |
| runnable { |
| for { set i 0 } { $i<[llength $options] } { incr i } { |
| set flags [lindex $options $i] |
| if [isnative] { |
| set dg-do-what-default "run" |
| } else { |
| set dg-do-what-default "link" |
| } |
| gdc-dg-runtest $filename $flags $imports |
| } |
| } |
| |
| compilable { |
| for { set i 0 } { $i<[llength $options] } { incr i } { |
| set flags [lindex $options $i] |
| #set dg-do-what-default "compile" |
| set dg-do-what-default "assemble" |
| gdc-dg-runtest $filename $flags $imports |
| } |
| } |
| |
| fail_compilation { |
| for { set i 0 } { $i<[llength $options] } { incr i } { |
| set flags [lindex $options $i] |
| set dg-do-what-default "assemble" |
| gdc-dg-runtest $filename $flags $imports |
| } |
| } |
| } |
| |
| # Cleanup |
| #file delete $filename |
| } |
| |
| # All done. |
| dg-finish |
| } |
| |
| gdc-do-test |
| |
