[thirdparty/gcc.git] / gcc / testsuite / lib / gnat.exp

# Copyright (C) 2006, 2007, 2008, 2009, 2010 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/>.

# This file was written by James A. Morrison (ja2morri@uwaterloo.ca)
# based on gcc.exp written by Rob Savoye (rob@cygnus.com).

# This file is loaded by the tool init file (eg: unix.exp).  It provides
# default definitions for gnat_start, etc. and other supporting cast members.

# These globals are used if no compiler arguments are provided.
# They are also used by the various testsuites to define the environment:
# where to find stdio.h, libc.a, etc.

load_lib libgloss.exp
load_lib prune.exp
load_lib gcc-defs.exp
load_lib gcc.exp
load_lib timeout.exp

#
# GNAT_UNDER_TEST is the compiler under test.
#

#
# default_gnat_version -- extract and print the version number of the compiler
#

proc default_gnat_version { } {
    global GNAT_UNDER_TEST

    gnat_init

    # ignore any arguments after the command
    set compiler [lindex $GNAT_UNDER_TEST 0]

    if ![is_remote host] {
	set compiler_name [which $compiler]
    } else {
	set compiler_name $compiler
    }

    # verify that the compiler exists
    if { $compiler_name != 0 } then {
	set tmp [remote_exec host "$compiler -v"]
	set status [lindex $tmp 0]
	set output [lindex $tmp 1]
	regexp " version \[^\n\r\]*" $output version
	if { $status == 0 && [info exists version] } then {
	    clone_output "$compiler_name $version\n"
	} else {
	    clone_output "Couldn't determine version of $compiler_name: $output\n"
	}
    } else {
	# compiler does not exist (this should have already been detected)
	warning "$compiler does not exist"
    }
}

# gnat_init -- called at the start of each .exp script.
#
# There currently isn't much to do, but always using it allows us to
# make some enhancements without having to go back and rewrite the scripts.
#

set gnat_initialized 0

proc gnat_init { args } {
    global rootme
    global tmpdir
    global libdir
    global gluefile wrap_flags
    global gnat_initialized
    global GNAT_UNDER_TEST
    global TOOL_EXECUTABLE
    global gnat_libgcc_s_path
    global gnat_target_current

    set gnat_target_current ""

    if { $gnat_initialized == 1 } { return }

    if ![info exists GNAT_UNDER_TEST] then {
	if [info exists TOOL_EXECUTABLE] {
	    set GNAT_UNDER_TEST "$TOOL_EXECUTABLE"
	} else {
	    set GNAT_UNDER_TEST "[local_find_gnatmake]"
	}
    }

    if ![info exists tmpdir] then {
	set tmpdir /tmp
    }

    set gnat_libgcc_s_path "${rootme}"
    # Leave this here since Ada should support multilibs at some point.
    set compiler [lindex $GNAT_UNDER_TEST 0]
#    if { [is_remote host] == 0 && [which $compiler] != 0 } {
#	foreach i "[exec $compiler --print-multi-lib]" {
#	    set mldir ""
#	    regexp -- "\[a-z0-9=/\.-\]*;" $i mldir
#	    set mldir [string trimright $mldir "\;@"]
#	    if { "$mldir" == "." } {
#		continue
#	    }
#	    if { [llength [glob -nocomplain ${rootme}/${mldir}/libgcc_s*.so.*]] >= 1 } {
#		append gnat_libgcc_s_path ":${rootme}/${mldir}"
#	    }
#	}
#    }
}

proc gnat_target_compile { source dest type options } {
    global rootme
    global tmpdir
    global gluefile wrap_flags
    global srcdir
    global GNAT_UNDER_TEST
    global TOOL_OPTIONS
    global ld_library_path
    global gnat_libgcc_s_path
    global gnat_target_current

    # dg-require-effective-target tests must be compiled as C.
    if [ string match "*.c" $source ] then {
	return [gcc_target_compile $source $dest $type $options]
    }

    # If we detect a change of target, we need to recompute both
    # GNAT_UNDER_TEST and the appropriate RTS.
    if { $gnat_target_current!="[current_target_name]" } {
	set gnat_target_current "[current_target_name]"
	if [info exists TOOL_OPTIONS] {
	    set rtsdir "[get_multilibs ${TOOL_OPTIONS}]/libada"
	} else {
	    set rtsdir "[get_multilibs]/libada"
	}
	if [info exists TOOL_EXECUTABLE] {
	    set GNAT_UNDER_TEST "$TOOL_EXECUTABLE"
	} else {
	    set GNAT_UNDER_TEST "[local_find_gnatmake]"
	}
        set GNAT_UNDER_TEST "$GNAT_UNDER_TEST --RTS=$rtsdir"

	# gnatlink looks for system.ads itself and has no --RTS option, so
	# specify via environment
	setenv ADA_INCLUDE_PATH "$rtsdir/adainclude"
	setenv ADA_OBJECTS_PATH "$rtsdir/adainclude"
    }

    set ld_library_path ".:${gnat_libgcc_s_path}"
    lappend options "compiler=$GNAT_UNDER_TEST -q -f"
    lappend options "timeout=[timeout_value]"

    if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } {
	lappend options "libs=${gluefile}"
	lappend options "ldflags=$wrap_flags"
    }

    # TOOL_OPTIONS must come first, so that it doesn't override testcase
    # specific options.
    if [info exists TOOL_OPTIONS] {
	set options [concat "additional_flags=$TOOL_OPTIONS" $options]
    }

    # If we have built libada along with the compiler, point the test harness
    # at it (and associated headers).

#    set sourcename [string range $source 0 [expr [string length $source] - 5]]
#    set dest ""

    return [target_compile $source $dest $type $options]
}

#
# gnat_pass -- utility to record a testcase passed
#

proc gnat_pass { testcase cflags } {
    if { "$cflags" == "" } {
	pass "$testcase"
    } else {
	pass "$testcase, $cflags"
    }
}

#
# gnat_fail -- utility to record a testcase failed
#

proc gnat_fail { testcase cflags } {
    if { "$cflags" == "" } {
	fail "$testcase"
    } else {
	fail "$testcase, $cflags"
    }
}

#
# gnat_finish -- called at the end of every .exp script that calls gnat_init
#
# The purpose of this proc is to hide all quirks of the testing environment
# from the testsuites.  It also exists to undo anything that gnat_init did
# (that needs undoing).
#

proc gnat_finish { } {
    # The testing harness apparently requires this.
    global errorInfo

    if [info exists errorInfo] then {
	unset errorInfo
    }

    # Might as well reset these (keeps our caller from wondering whether
    # s/he has to or not).
    global prms_id bug_id
    set prms_id 0
    set bug_id 0
}

proc gnat_exit { } {
    global gluefile

    if [info exists gluefile] {
	file_on_build delete $gluefile
	unset gluefile
    }
}

# Prune messages from GNAT that aren't useful.

proc prune_gnat_output { text } {
    #send_user "Before:$text\n"
    regsub -all "(^|\n)\[^\n\]*: In (function|method) \[^\n\]*" $text "" text
    regsub -all "(^|\n)\[^\n\]*: At top level:\[^\n\]*" $text "" text

    # prune the output from gnatmake.
    regsub -all "(^|\n)\[^\n\]*gnatmake: [^\n\]*" $text "" text

    # It would be nice to avoid passing anything to gnat that would cause it to
    # issue these messages (since ignoring them seems like a hack on our part),
    # but that's too difficult in the general case.  For example, sometimes
    # you need to use -B to point gnat at crt0.o, but there are some targets
    # that don't have crt0.o.
    regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text
    regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text

    #send_user "After:$text\n"

    return $text
}

# find_gnatmake for some version of DejaGnu will hardcode a -I...rts/ada flag
# which prevent multilib from working, so define a new one.

proc local_find_gnatmake {} {
    global tool_root_dir

    if ![is_remote host] {
        set file [lookfor_file $tool_root_dir gnatmake]
        if { $file == "" } {
    	set file [lookfor_file $tool_root_dir gcc/gnatmake]
        }
        if { $file != "" } {
    	set root [file dirname $file]
	# Need to pass full --GCC, including multilib flags, to gnatlink,
	# otherwise gcc from PATH is invoked.
	set dest [target_info name]
	set gnatlink_gcc "--GCC=$root/xgcc -B$root [board_info $dest multilib_flags]"
	# Escape blanks to get them through DejaGnu's exec machinery.
	regsub -all {\s} "$gnatlink_gcc" {\\&} gnatlink_gcc
    	set CC "$file --GCC=$root/xgcc --GNATBIND=$root/gnatbind --GNATLINK=$root/gnatlink -cargs -B$root -largs $gnatlink_gcc -margs";
        } else {
    	set CC [transform gnatmake]
        }
    } else {
        set CC [transform gnatmake]
    }
    return $CC
}

# If this is an older version of DejaGnu (without runtest_file_p),
# provide one and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
# This can be deleted after next DejaGnu release.

if { [info procs runtest_file_p] == "" } then {
    proc runtest_file_p { runtests testcase } {
	if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
	    if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
		return 1
	    } else {
		return 0
	    }
	}
	return 1
    }
}

# Provide a definition of this if missing (delete after next DejaGnu release).

if { [info procs prune_warnings] == "" } then {
    proc prune_warnings { text } {
	return $text
    }
}
Commit	Line	Data
576e4d82	1	# Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
663230c4 JM	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
cd976c16	5	# the Free Software Foundation; either version 3 of the License, or
663230c4 JM	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
cd976c16 NC	14	# along with GCC; see the file COPYING3. If not see
cd976c16 NC	15	# <http://www.gnu.org/licenses/>.
663230c4 JM	16
	17	# This file was written by James A. Morrison (ja2morri@uwaterloo.ca)
	18	# based on gcc.exp written by Rob Savoye (rob@cygnus.com).
	19
	20	# This file is loaded by the tool init file (eg: unix.exp). It provides
	21	# default definitions for gnat_start, etc. and other supporting cast members.
	22
	23	# These globals are used if no compiler arguments are provided.
	24	# They are also used by the various testsuites to define the environment:
	25	# where to find stdio.h, libc.a, etc.
	26
	27	load_lib libgloss.exp
	28	load_lib prune.exp
	29	load_lib gcc-defs.exp
3ffcc54f	30	load_lib gcc.exp
d4038ca2	31	load_lib timeout.exp
663230c4 JM	32
	33	#
	34	# GNAT_UNDER_TEST is the compiler under test.
	35	#
	36
	37	#
	38	# default_gnat_version -- extract and print the version number of the compiler
	39	#
	40
	41	proc default_gnat_version { } {
	42	global GNAT_UNDER_TEST
	43
	44	gnat_init
	45
	46	# ignore any arguments after the command
	47	set compiler [lindex $GNAT_UNDER_TEST 0]
	48
	49	if ![is_remote host] {
	50	set compiler_name [which $compiler]
	51	} else {
	52	set compiler_name $compiler
	53	}
	54
	55	# verify that the compiler exists
	56	if { $compiler_name != 0 } then {
	57	set tmp [remote_exec host "$compiler -v"]
	58	set status [lindex $tmp 0]
	59	set output [lindex $tmp 1]
	60	regexp " version \[^\n\r\]*" $output version
	61	if { $status == 0 && [info exists version] } then {
	62	clone_output "$compiler_name $version\n"
	63	} else {
	64	clone_output "Couldn't determine version of $compiler_name: $output\n"
	65	}
	66	} else {
	67	# compiler does not exist (this should have already been detected)
	68	warning "$compiler does not exist"
	69	}
	70	}
	71
	72	# gnat_init -- called at the start of each .exp script.
	73	#
	74	# There currently isn't much to do, but always using it allows us to
	75	# make some enhancements without having to go back and rewrite the scripts.
	76	#
	77
	78	set gnat_initialized 0
	79
	80	proc gnat_init { args } {
	81	global rootme
	82	global tmpdir
	83	global libdir
	84	global gluefile wrap_flags
	85	global gnat_initialized
	86	global GNAT_UNDER_TEST
	87	global TOOL_EXECUTABLE
	88	global gnat_libgcc_s_path
6d63ea75 LG	89	global gnat_target_current
	90
	91	set gnat_target_current ""
663230c4 JM	92
	93	if { $gnat_initialized == 1 } { return }
	94
	95	if ![info exists GNAT_UNDER_TEST] then {
	96	if [info exists TOOL_EXECUTABLE] {
6d63ea75	97	set GNAT_UNDER_TEST "$TOOL_EXECUTABLE"
663230c4	98	} else {
6d63ea75	99	set GNAT_UNDER_TEST "[local_find_gnatmake]"
663230c4 JM	100	}
	101	}
	102
	103	if ![info exists tmpdir] then {
	104	set tmpdir /tmp
	105	}
	106
	107	set gnat_libgcc_s_path "${rootme}"
	108	# Leave this here since Ada should support multilibs at some point.
	109	set compiler [lindex $GNAT_UNDER_TEST 0]
	110	# if { [is_remote host] == 0 && [which $compiler] != 0 } {
	111	# foreach i "[exec $compiler --print-multi-lib]" {
	112	# set mldir ""
	113	# regexp -- "\[a-z0-9=/\.-\]*;" $i mldir
	114	# set mldir [string trimright $mldir "\;@"]
	115	# if { "$mldir" == "." } {
	116	# continue
	117	# }
	118	# if { [llength [glob -nocomplain ${rootme}/${mldir}/libgcc_s.so.]] >= 1 } {
	119	# append gnat_libgcc_s_path ":${rootme}/${mldir}"
	120	# }
	121	# }
	122	# }
	123	}
	124
	125	proc gnat_target_compile { source dest type options } {
	126	global rootme
	127	global tmpdir
	128	global gluefile wrap_flags
	129	global srcdir
	130	global GNAT_UNDER_TEST
	131	global TOOL_OPTIONS
	132	global ld_library_path
	133	global gnat_libgcc_s_path
6d63ea75 LG	134	global gnat_target_current
6d63ea75 LG	135
3ffcc54f RO	136	# dg-require-effective-target tests must be compiled as C.
	137	if [ string match "*.c" $source ] then {
	138	return [gcc_target_compile $source $dest $type $options]
	139	}
	140
576e4d82 RO	141	# If we detect a change of target, we need to recompute both
576e4d82 RO	142	# GNAT_UNDER_TEST and the appropriate RTS.
6d63ea75 LG	143	if { $gnat_target_current!="[current_target_name]" } {
	144	set gnat_target_current "[current_target_name]"
	145	if [info exists TOOL_OPTIONS] {
576e4d82	146	set rtsdir "[get_multilibs ${TOOL_OPTIONS}]/libada"
6d63ea75	147	} else {
576e4d82	148	set rtsdir "[get_multilibs]/libada"
6d63ea75	149	}
576e4d82 RO	150	if [info exists TOOL_EXECUTABLE] {
	151	set GNAT_UNDER_TEST "$TOOL_EXECUTABLE"
	152	} else {
	153	set GNAT_UNDER_TEST "[local_find_gnatmake]"
	154	}
	155	set GNAT_UNDER_TEST "$GNAT_UNDER_TEST --RTS=$rtsdir"
	156
	157	# gnatlink looks for system.ads itself and has no --RTS option, so
	158	# specify via environment
	159	setenv ADA_INCLUDE_PATH "$rtsdir/adainclude"
	160	setenv ADA_OBJECTS_PATH "$rtsdir/adainclude"
6d63ea75	161	}
663230c4	162
33cde516	163	set ld_library_path ".:${gnat_libgcc_s_path}"
0028647e	164	lappend options "compiler=$GNAT_UNDER_TEST -q -f"
32ab0ba4	165	lappend options "timeout=[timeout_value]"
663230c4 JM	166
	167	if { [target_info needs_status_wrapper]!="" && [info exists gluefile] } {
	168	lappend options "libs=${gluefile}"
	169	lappend options "ldflags=$wrap_flags"
	170	}
	171
	172	# TOOL_OPTIONS must come first, so that it doesn't override testcase
	173	# specific options.
	174	if [info exists TOOL_OPTIONS] {
	175	set options [concat "additional_flags=$TOOL_OPTIONS" $options]
	176	}
	177
	178	# If we have built libada along with the compiler, point the test harness
	179	# at it (and associated headers).
	180
	181	# set sourcename [string range $source 0 [expr [string length $source] - 5]]
	182	# set dest ""
6d63ea75	183
663230c4 JM	184	return [target_compile $source $dest $type $options]
	185	}
	186
	187	#
	188	# gnat_pass -- utility to record a testcase passed
	189	#
	190
	191	proc gnat_pass { testcase cflags } {
	192	if { "$cflags" == "" } {
	193	pass "$testcase"
	194	} else {
	195	pass "$testcase, $cflags"
	196	}
	197	}
	198
	199	#
	200	# gnat_fail -- utility to record a testcase failed
	201	#
	202
	203	proc gnat_fail { testcase cflags } {
	204	if { "$cflags" == "" } {
	205	fail "$testcase"
	206	} else {
	207	fail "$testcase, $cflags"
	208	}
	209	}
	210
	211	#
	212	# gnat_finish -- called at the end of every .exp script that calls gnat_init
	213	#
	214	# The purpose of this proc is to hide all quirks of the testing environment
	215	# from the testsuites. It also exists to undo anything that gnat_init did
	216	# (that needs undoing).
	217	#
	218
	219	proc gnat_finish { } {
	220	# The testing harness apparently requires this.
	221	global errorInfo
	222
	223	if [info exists errorInfo] then {
	224	unset errorInfo
	225	}
	226
	227	# Might as well reset these (keeps our caller from wondering whether
	228	# s/he has to or not).
	229	global prms_id bug_id
	230	set prms_id 0
	231	set bug_id 0
	232	}
	233
	234	proc gnat_exit { } {
	235	global gluefile
	236
	237	if [info exists gluefile] {
	238	file_on_build delete $gluefile
	239	unset gluefile
	240	}
	241	}
	242
	243	# Prune messages from GNAT that aren't useful.
	244
	245	proc prune_gnat_output { text } {
	246	#send_user "Before:$text\n"
	247	regsub -all "(^\|\n)\[^\n\]: In (function\|method) \[^\n\]" $text "" text
248	regsub -all "(^\|\n)\[^\n\]: At top level:\[^\n\]" $text "" text
249
250	# prune the output from gnatmake.
251	regsub -all "(^\|\n)\[^\n\]gnatmake: [^\n\]" $text "" text
252
253	# It would be nice to avoid passing anything to gnat that would cause it to
254	# issue these messages (since ignoring them seems like a hack on our part),
255	# but that's too difficult in the general case. For example, sometimes
256	# you need to use -B to point gnat at crt0.o, but there are some targets
257	# that don't have crt0.o.
258	regsub -all "(^\|\n)\[^\n\]file path prefix \[^\n\] never used" $text "" text
259	regsub -all "(^\|\n)\[^\n\]*linker input file unused since linking not done" $text "" text
260
261	#send_user "After:$text\n"
262
263	return $text
264	}
265
6d63ea75 LG	266	# find_gnatmake for some version of DejaGnu will hardcode a -I...rts/ada flag
6d63ea75 LG	267	# which prevent multilib from working, so define a new one.
663230c4	268
6d63ea75 LG	269	proc local_find_gnatmake {} {
6d63ea75 LG	270	global tool_root_dir
743e3e4c	271
6d63ea75 LG	272	if ![is_remote host] {
	273	set file [lookfor_file $tool_root_dir gnatmake]
	274	if { $file == "" } {
	275	set file [lookfor_file $tool_root_dir gcc/gnatmake]
	276	}
	277	if { $file != "" } {
	278	set root [file dirname $file]
576e4d82 RO	279	# Need to pass full --GCC, including multilib flags, to gnatlink,
	280	# otherwise gcc from PATH is invoked.
	281	set dest [target_info name]
	282	set gnatlink_gcc "--GCC=$root/xgcc -B$root [board_info $dest multilib_flags]"
	283	# Escape blanks to get them through DejaGnu's exec machinery.
	284	regsub -all {\s} "$gnatlink_gcc" {\\&} gnatlink_gcc
	285	set CC "$file --GCC=$root/xgcc --GNATBIND=$root/gnatbind --GNATLINK=$root/gnatlink -cargs -B$root -largs $gnatlink_gcc -margs";
6d63ea75 LG	286	} else {
	287	set CC [transform gnatmake]
	288	}
	289	} else {
	290	set CC [transform gnatmake]
663230c4	291	}
6d63ea75	292	return $CC
663230c4 JM	293	}
	294
	295	# If this is an older version of DejaGnu (without runtest_file_p),
	296	# provide one and assume the old syntax: foo1.exp bar1.c foo2.exp bar2.c.
	297	# This can be deleted after next DejaGnu release.
	298
	299	if { [info procs runtest_file_p] == "" } then {
	300	proc runtest_file_p { runtests testcase } {
	301	if { $runtests != "" && [regexp "\[.\]\[cC\]" $runtests] } then {
	302	if { [lsearch $runtests [file tail $testcase]] >= 0 } then {
	303	return 1
	304	} else {
	305	return 0
	306	}
	307	}
	308	return 1
	309	}
	310	}
	311
	312	# Provide a definition of this if missing (delete after next DejaGnu release).
	313
	314	if { [info procs prune_warnings] == "" } then {
	315	proc prune_warnings { text } {
	316	return $text
	317	}
	318	}