# This testcase is part of GDB, the GNU debugger.

# Copyright 1996, 1997, 1999, 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, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  

# Please email any bugs, comments, and/or additions to this file to:
# bug-gdb@prep.ai.mit.edu

if $tracelevel then {
	strace $tracelevel
}

set prms_id 0
set bug_id 0

# Some targets can't call functions, so don't even bother with this
# test.

if [target_info exists gdb,cannot_call_functions] {
    setup_xfail "*-*-*" 2416
    fail "This target can not call functions"
    continue
}

set testfile "structs"
set srcfile ${testfile}.c
set binfile ${objdir}/${subdir}/${testfile}

# Create and source the file that provides information about the
# compiler used to compile the test case.

if [get_compiler_info ${binfile}] {
    return -1;
}

# Compile a variant of structs.c with TYPES specifying the type of
# each of the first [llength $types] elements of all structures.

proc start_structs_test { types } {
    global testfile
    global srcfile
    global binfile
    global objdir
    global subdir
    global srcdir

    # Create the additional flags
    set flags "debug"
    set name ""
    set n 0
    for {set n 0} {$n<[llength ${types}]} {incr n} {
	set m [I2A ${n}]
	set t [lindex ${types} $n]
	lappend flags "additional_flags=-Dt${m}=${t}"
	append name "-" "$t"
    }

    set binfile ${objdir}/${subdir}/${testfile}${name}
    if  { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable "${flags}"] != "" } {
	# built the second test case since we can't use prototypes
	warning "Prototypes not supported, rebuilding with -DNO_PROTOTYPES"
	if  { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable "${flags} additional_flags=-DNO_PROTOTYPES"] != "" } {
	    gdb_suppress_entire_file "Testcase compile failed, so all tests in this file will automatically fail."
	}
    }

    # Start with a fresh gdb.
    gdb_start
    gdb_reinitialize_dir $srcdir/$subdir
    gdb_load ${binfile}

    # Make certain that the output is consistent
    gdb_test "set print sevenbit-strings" "" "set print sevenbit-strings - ${types}"
    gdb_test "set print address off" ""      "set print address off - ${types}"
    gdb_test "set width 0" ""                "set width 0 - ${types}"

    # Advance to main
    if { ![runto_main] } then {
	gdb_suppress_tests;
    }

    # check that at the struct containing all the relevant types is correct
    set foo_t "type = struct struct[llength ${types}] {"
    for {set n 0} {$n<[llength ${types}]} {incr n} {
	append foo_t {[\r\n ]+} [lindex ${types} $n] " " [i2a $n] ";"
    }
    append foo_t {[\r\n ]+} "}"
    gdb_test "ptype foo[llength ${types}]" "${foo_t}" "${foo_t} - ${types}"
}

# The expected value for funN, LN and fooN.  First element is empty to
# make indexing easier.

proc foo { n } {
    return [lindex {
	"{}"
	"{a = 49 '1'}"
	"{a = 97 'a', b = 50 '2'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4', e = 101 'e', f = 54 '6'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5', f = 102 'f', g = 55 '7'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4', e = 101 'e', f = 54 '6', g = 103 'g', h = 56 '8'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5', f = 102 'f', g = 55 '7', h = 104 'h', i = 57 '9'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4', e = 101 'e', f = 54 '6', g = 103 'g', h = 56 '8', i = 105 'i', j = 65 'A'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5', f = 102 'f', g = 55 '7', h = 104 'h', i = 57 '9', j = 106 'j', k = 66 'B'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4', e = 101 'e', f = 54 '6', g = 103 'g', h = 56 '8', i = 105 'i', j = 65 'A', k = 107 'k', l = 67 'C'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5', f = 102 'f', g = 55 '7', h = 104 'h', i = 57 '9', j = 106 'j', k = 66 'B', l = 108 'l', m = 68 'D'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4', e = 101 'e', f = 54 '6', g = 103 'g', h = 56 '8', i = 105 'i', j = 65 'A', k = 107 'k', l = 67 'C', m = 109 'm', n = 69 'E'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5', f = 102 'f', g = 55 '7', h = 104 'h', i = 57 '9', j = 106 'j', k = 66 'B', l = 108 'l', m = 68 'D', n = 110 'n', o = 70 'F'}"
	"{a = 97 'a', b = 50 '2', c = 99 'c', d = 52 '4', e = 101 'e', f = 54 '6', g = 103 'g', h = 56 '8', i = 105 'i', j = 65 'A', k = 107 'k', l = 67 'C', m = 109 'm', n = 69 'E', o = 111 'o', p = 71 'G'}"
	"{a = 49 '1', b = 98 'b', c = 51 '3', d = 100 'd', e = 53 '5', f = 102 'f', g = 55 '7', h = 104 'h', i = 57 '9', j = 106 'j', k = 66 'B', l = 108 'l', m = 68 'D', n = 110 'n', o = 70 'F', p = 112 'p', q = 72 'H'}"
    } $n]
}

proc i2a { n } {
    return [string range "abcdefghijklmnopqrstuvwxyz" $n $n]
}

proc I2A { n } {
    return [string toupper [i2a $n]]
}

# Mark the listed tuples as known failures.  It expects strings of the
# form <tuple>[/[xk]fail].

proc setup_fails { fails bug } {
    foreach f $fails {
	set tuple [split $f /]
	switch [lindex $tuple 1] {
	    kfail { setup_kfail [lindex $tuple 0] $bug }
	    xfail { setup_xfail [lindex $tuple 0] $bug }
	    default { setup_kfail [lindex $tuple 0] $bug }
	}
    }
}

# Check that GDB can always extract a struct-return value from an
# inferior function call.  Since GDB always knows the location of an
# inferior function call's return value these should never fail

# Implemented by calling the parameterless function "fun$N" and then
# examining the return value printed by GDB.

proc call_struct_func { types n fails } {
    global gdb_prompt
    set test "call fun${n} - ${types}"
    set result [foo ${n}]

    # Call fun${n}, checking the printed return value.
    send_gdb "p/c fun${n}()\n"
    gdb_expect {
        -re "$result\[\r\n\]+$gdb_prompt $" {
            pass "${test}"
        }
        -re "$gdb_prompt $" {
	    # "Return value of a struct return function lost"
	    setup_fails $fails gdb/1443
            fail "${test}"
        }
        timeout {
            fail "${test} (timeout)"
        }
    }
}

# Check that GDB can always pass a structure to an inferior function.
# This test can never fail.

# Implemented by calling the one parameter function "Fun$N" which
# stores its parameter in the global variable "L$N".  GDB then
# examining that global to confirm that the value is as expected.

proc pass_struct_func { types n fails } {
    set test "pass foo${n} - ${types}"

    gdb_test "call Fun${n}(foo${n})" "" "call Fun${n}(foo${n}); ${test}"
    # "Return value of a struct return function lost"
    setup_fails $fails gdb/1443
    gdb_test "p/c L${n}" [foo ${n}] "p/c L${n}; ${test}"
}

# Check that GDB can correctly force the return of a function that has
# a struct result.  Dependant on the ABI, it may, or may not be
# possible to make this work.

# The relevant code looks like "L{n} = fun{n}()".  The test forces
# "fun{n}" to "return" with an explicit value.  Since that code
# snippet will store the the returned value in "L{n}", its possible to
# confirm that things work by examining "L{n}".

proc return_struct_func { types n fails } {
    global gdb_prompt
    set test "return in fun${n} - ${types}"
    
    # Get into a call of fun${n}
    gdb_test "advance fun${n}" \
	    "fun${n} .*\[\r\n\]+\[0-9\].*return foo${n}.*" \
	    "advance fun${n}; ${test}"

    # Now force a return.  Be careful to only produce one PASS/FAIL.
    send_gdb "return foo${n}\n"
    gdb_expect {
	-re  "Make fun${n} return now.*y or n. $" {
	    send_gdb "y\n"
	    gdb_expect {
		-re "L${n} *= fun${n}.*${gdb_prompt} $" {
		    # Need to step off the function call
		    gdb_test "next" "L.* *= fun.*" "${test}"
		}
		-re "${gdb_prompt} $" {
		    pass "${test}"
		}
		timeout {
		    fail "${test} (timeout)"
		}
	    }
	}
    }

    # Finally check that the value returned ended up in "L${n}".
    setup_fails ${fails} gdb/1444
    gdb_test "p/c L${n}" " = [foo ${n}]" "${test}"
}

# Check that GDB can always finish a struct-return function.
# Dependant on the ABI GDB may or may not be able to find the value
# returned by that function.

# The relevant code snippet is "L{n} = fun{n}()".  The program is
# allowed to get into a call to "fun{n}" and that function is then
# finished.  The returned value that GDB prints is then checked.

proc finish_struct_func { types n fails } {
    set test "finish in fun${n} - ${types}"

    # Get into "fun${n}()".
    gdb_test "advance fun${n}" \
	    "fun${n} .*\[\r\n\]+\[0-9\].*return foo${n}.*" \
	    "advance fun${n}; ${test}"

    # Finish that function, this puts the return value in a
    # convenience variable.
    gdb_test "finish" "" "finish; ${test}"

    # Finally, print the convenience variable in a consistent way.
    # "$" is the most recent history variable.
    setup_fails ${fails} gdb/1444
    gdb_test {print/c $} [foo ${n}] "${test}"
}

# Test GDB's struct-return code.

# TYPES lists the type of the first N elements of each struct variant
# that is to be tested.  TYPES also determines the number of elements
# in the first struct variant that will be tested.

# Structures with an increasing number of elements (the number of
# variants determined by CALLS (inferior function calls) and RETURNS
# (return command, finish command) are then tested.

proc test_structs { types calls returns } {

    # Now compile, start and run-to-main the program.
    start_structs_test ${types}

    # Check that GDB can call a function that returns a structure.
    for {set n 0} {$n<[llength $calls]} {incr n} {
	set fails [lindex $calls $n]
	set elements [expr [llength $types] + $n]
	call_struct_func ${types} $elements ${fails}
	pass_struct_func ${types} $elements ${fails}
    }

    # Check that GDB can correctly find a struct return value when a
    # function either finishes, or is explicitly returned.  Due to ABI
    # restrictions, it isn't always possible to exercise this test.

    # The above will have modified the L* globals, get
    # around this by calling zed which "Z" everything.
    gdb_test "call zed()" "" "zed return - ${types}"
    gdb_test "p/c L1" " = {a = 90 'Z'}" "zed return ok - ${types}"

    # Check that GDB can return a struct func
    for {set n 0} {$n<[llength $returns]} {incr n} {
	return_struct_func ${types} [expr [llength $types] + $n] [lindex $returns $n]
    }

    # The above will have modified the L* globals, get
    # around this by calling zed which "Z" everything.
    gdb_test "call zed()" "" "zed finish - ${types}"
    gdb_test "p/c L1" " = {a = 90 'Z'}" "zed finish ok - ${types}"

    # Check as many functions as possible
    for {set n 0} {$n<[llength $returns]} {incr n} {
	finish_struct_func ${types} [expr [llength $types] + $n] [lindex $returns $n]
    }

    gdb_stop_suppressing_tests;
}

# ABIs pass anything >8 or >16 bytes in memory but below that things
# randomly use register and/and structure conventions.  Check all
# possible sized char structs in that range.  But only a restricted
# range of the other types.

# On NetBSD, "unnatural" sized structs get returned in memory.

test_structs { tc } \
	{ {} {} {} {} {} {} {} {} {} {} {} {} {} {} {} {} {} } \
	{ {} {} { powerpc-*-netbsd*/xfail } {} { powerpc-*-netbsd*/xfail } { powerpc-*-netbsd*/xfail } { powerpc-*-netbsd*/xfail } {} }

test_structs { ts } \
	{ {} {} {} {} {} } \
	{ {} {} { powerpc-*-netbsd*/xfail } {} }
test_structs { ti } \
	{ {} {} {} } \
	{ {} {} }
test_structs { tl } \
	{ {} {} {} } \
	{ {} {} }
test_structs { tll } \
	{ {} {} } \
	{ {} }
test_structs { tf } \
	{ {} {} {} } \
	{ {} {} }
test_structs { td } \
	{ {} {} } \
	{ {} }
test_structs { tld } \
	{ {} } \
	{ {} }

test_structs { ts tc } \
	{ {} {} {} {} {} {} {} } \
	{ {} }
test_structs { ti tc } \
	{ {} {} {} {} {} } \
	{ {} }
test_structs { tl tc } \
	{ {} {} {} {} {} } \
	{ {} }
test_structs { tll tc } \
	{ {} } \
	{ }
test_structs { tf tc } \
	{ {} {} {} {} {} } \
	{ {} }
test_structs { td tc } \
	{ {} } \
	{ }
test_structs { tld tc } \
	{ {} } \
	{ }

test_structs { tc ts } \
	{ {} {} {} {} {} } \
	{ {} }
test_structs { tc ti } \
	{ {} {} {} } \
	{ {} }
test_structs { tc tl } \
	{ {} {} {} } \
	{ {} }
test_structs { tc tll } \
	{ {} } \
	{ }
test_structs { tc tf } \
	{ {} {} {} } \
	{ {} }
test_structs { tc td } \
	{ {} } \
	{ }
test_structs { tc tld } \
	{ {} } \
	{ }

return 0