old-cross-binutils/sim/testsuite/lib/sim-defs.exp

# Simulator dejagnu utilities.

# Print the version of the simulator being tested.
# Required by dejagnu.

proc sim_version {} {
    set version 0.5
    set program [board_info target sim]
    clone_output "$program $version\n"
}

# Cover function to target_compile.
# Copied from gdb_compile.

proc sim_compile { source dest type options } {
    set result [target_compile $source $dest $type $options]
    regsub "\[\r\n\]*$" "$result" "" result
    regsub "^\[\r\n\]*" "$result" "" result
    if { $result != "" } {
	clone_output "sim compile failed, $result"
    }
    return $result
}

# Run a program on the simulator.
# Required by dejagnu (at least ${tool}_run used to be).
# FIXME: What should we do with `redir'?
# The result is a list of two elements.
# The first is one of pass/fail/etc.
# The second is the program's output.
#
# This is different than the sim_load routine provided by
# dejagnu/config/sim.exp.  It's not clear how to pass arguments to the
# simulator (not the simulated program, the simulator) with sim_load.

proc sim_run { prog sim_opts redir } {
    global SIMFLAGS

    # FIXME: The timeout value we actually want is a function of
    # host, target, and testcase.
    set testcase_timeout [board_info target sim_time_limit]
    if { "$testcase_timeout" == "" } {
	set testcase_timeout [board_info host testcase_timeout]
    }
    if { "$testcase_timeout" == "" } {
	set testcase_timeout 240 ;# 240 same as in dejagnu/config/sim.exp.
    }

    set sim [board_info target sim]

    remote_spawn host "$sim $SIMFLAGS $sim_opts $prog"
    set result [remote_wait host $testcase_timeout]

    set return_code [lindex $result 0]
    set output [lindex $result 1]
    # Remove the \r part of "\r\n" so we don't break all the patterns
    # we want to match.
    regsub -all -- "\r" $output "" output

    # ??? Not sure the test for pass/fail is right.
    # We just care that the simulator ran correctly, not whether the simulated
    # program return 0 or non-zero from `main'.
    set status fail
    if { $return_code == 0 } {
	set status pass
    }

    return [list $status $output]
}

# Initialize the testrun.
# Required by dejagnu.

proc sim_init { args } {
    # Need to return an empty string (copied from GAS).
    return ""
}

# Run testcase NAME.
# NAME is either a fully specified file name, or just the file name in which
# case $srcdir/$subdir will be prepended.
# The file can contain options in the form "# option(mach list): value"
# Possibilities:
# mach(): machine names
# as(mach): <assembler options>
# ld(mach): <linker options>
# sim(mach): <simulator options>
# output(): program output pattern to match with string-match
# If `output' is not specified, the program must output "pass".

proc run_sim_test { name } {
    global subdir srcdir
    global AS ASFLAGS LD LDFLAGS SIMFLAGS
    global opts

    if [string match "*/*" $name] {
	set file $name
	set name [file tail $name]
    } else {
	set file "$srcdir/$subdir/$name"
    }

    set opt_array [slurp_options "${file}"]
    if { $opt_array == -1 } {
	unresolved $subdir/$name
	return
    }
    set opts(as) {}
    set opts(ld) {}
    set opts(sim) {}
    set opts(output) {}
    set opts(mach) {}

    foreach i $opt_array {
	set opt_name [lindex $i 0]
	set opt_machs [lindex $i 1]
	set opt_val [lindex $i 2]
	if ![info exists opts($opt_name)] {
	    perror "unknown option $opt_name in file $file"
	    unresolved $subdir/$name
	    return
	}
	foreach m $opt_machs {
	    set opts($opt_name,$m) $opt_val
	}
	if { "$opt_machs" == "" } {
	    set opts($opt_name) $opt_val
	}
    }

    set testname $name
    set sourcefile $file
    if { $opts(output) == "" } {
	set opts(output) "pass\n"
    }

    foreach mach $opts(mach) {
	verbose "Testing $name on $mach."

	if ![info exists opts(as,$mach)] {
	    set opts(as,$mach) $opts(as)
	}
	send_log "$AS $ASFLAGS $opts(as,$mach) -I$srcdir/$subdir -o ${name}.o $sourcefile\n"
	catch "exec $AS $ASFLAGS $opts(as,$mach) -I$srcdir/$subdir -o ${name}.o $sourcefile" comp_output

	if ![string match "" $comp_output] {
	    verbose -log "$comp_output" 3
	    fail "$mach $testname"
	    continue
	}

	if ![info exists opts(ld,$mach)] {
	    set opts(ld,$mach) $opts(ld)
	}
	send_log "$LD $LDFLAGS $opts(ld,$mach) -o ${name}.x ${name}.o\n"
	catch "exec $LD $LDFLAGS $opts(ld,$mach) -o ${name}.x ${name}.o" comp_output

	if ![string match "" $comp_output] {
	    verbose -log "$comp_output" 3
	    fail "$mach $testname"
	    continue
	}

	# If no machine specific options, default to the general version.
	if ![info exists opts(sim,$mach)] {
	    set opts(sim,$mach) $opts(sim)
	}

	set result [sim_run ${name}.x "$opts(sim,$mach)" ""]
	set status [lindex $result 0]
	set output [lindex $result 1]

	if { "$status" == "pass" } {
	    if ![string match $opts(output) $output] {
		verbose -log "output:  $output" 3
		verbose -log "pattern: $opts(output)" 3
	    }
	}

	$status "$mach $testname"
    }
}

# Subroutine of run_sim_test to process options in FILE.

proc slurp_options { file } {
    if [catch { set f [open $file r] } x] {
	#perror "couldn't open `$file': $x"
	perror "$x"
	return -1
    }
    set opt_array {}
    # whitespace expression
    set ws  {[ 	]*}
    set nws {[^ 	]*}
    # whitespace is ignored anywhere except within the options list;
    # option names are alphabetic only
    set pat "^#${ws}(\[a-zA-Z\]*)\\((.*)\\)$ws:${ws}(.*)$ws\$"
    # Allow comment as first line of file.
    set firstline 1
    while { [gets $f line] != -1 } {
	set line [string trim $line]
	# Whitespace here is space-tab.
	if [regexp $pat $line xxx opt_name opt_machs opt_val] {
	    # match!
	    lappend opt_array [list $opt_name $opt_machs $opt_val]
	} else {
	    if { ! $firstline } {
		break
	    }
	}
	set firstline 0
    }
    close $f
    return $opt_array
}