[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 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

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