Subversion Repositories or1k

# Simulator dejagnu utilities.

# Communicate simulator path from sim_init to sim_version.
# For some reason [board_info target sim] doesn't work in sim_version.
# [Presumubly because the target has been "popped" by then.  Odd though.]
set sim_path "unknown-run"

# Initialize the testrun.
# Required by dejagnu.

proc sim_init { args } {
    global sim_path
    set sim_path [board_info target sim]
    # Need to return an empty string (copied from GAS).
    return ""
}

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

proc sim_version {} {
    global sim_path
    set version 0.5
    clone_output "$sim_path $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 output: $result"
    }
    return $result
}

# Run a program on the simulator.
# Required by dejagnu (at least ${tool}_run used to be).
#
# SIM_OPTS are options for the simulator.
# PROG_OPTS are options passed to the simulated program.
# At present REDIR must be "" or "> foo".
# OPTIONS is a list of options internal to this routine.
# This is modelled after target_compile.  We want to be able to add new
# options without having to update all our users.
# Currently:
#       env(foo)=val    - set environment variable foo to val for this run
#       timeout=val     - set the timeout to val for this run
#
# 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 prog_opts redir options } {
    global SIMFLAGS

    # Set the default value of the timeout.
    # 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.
    }

    # Initial the environment we pass to the testcase.
    set testcase_env ""

    # Process OPTIONS ...
    foreach o $options {
        if [regexp {^env\((.*)\)=(.*)} $o full var val] {
            set testcase_env "$testcase_env $var=$val"
        } elseif [regexp {^timeout=(.*)} $o full val] {
            set testcase_timeout $val
        }
        
    }
        
    verbose "testcase timeout is set to $testcase_timeout" 1

    set sim [board_info target sim]

    if [is_remote host] {
        set prog [remote_download host $prog]
        if { $prog == "" } {
            error "download failed"
            return -1;
        }
    }

    set board [target_info name]
    if [board_info $board exists sim,options] {
        set always_opts [board_info $board sim,options]
    } else {
        set always_opts ""
    }

    # FIXME: this works for UNIX only
    if { "$testcase_env" != "" } {
        set sim "env $testcase_env $sim"
    }

    send_log "$sim $always_opts $SIMFLAGS $sim_opts $prog $prog_opts\n"

    if { "$redir" == "" } {
        remote_spawn host "$sim $always_opts $SIMFLAGS $sim_opts $prog $prog_opts"
    } else {
        remote_spawn host "$sim $always_opts $SIMFLAGS $sim_opts $prog $prog_opts $redir" writeonly
    }
    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

    if [is_remote host] {
        # clean up after ourselves.
        remote_file host delete $prog
    }

    # ??? 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]
}

# Run testcase NAME.
# NAME is either a fully specified file name, or just the file name in which
# case $srcdir/$subdir will be prepended.
# REQUESTED_MACHS is a list of machines to run the testcase on.  If NAME isn't
# for the specified machine(s), it is ignored.
# Typically REQUESTED_MACHS contains just one element, it is up to the caller
# to iterate over the desired machine variants.
#
# The file can contain options in the form "# option(mach list): value".
# Possibilities:
# mach: [all | machine names]
# as[(mach-list)]: <assembler options>
# ld[(mach-list)]: <linker options>
# sim[(mach-list)]: <simulator options>
# output[(mach-list)]: program output pattern to match with string-match
# xerror[(mach-list)]: program is expected to return with a "failure" exit code
# If `output' is not specified, the program must output "pass" if !xerror or
# "fail" if xerror.
# The parens in "optname()" are optional if the specification is for all machs.

proc run_sim_test { name requested_machs } {
    global subdir srcdir
    global 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) {}
    set opts(timeout) {}
    set opts(xerror) "no"

    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) == "" } {
        if { "$opts(xerror)" == "no" } {
            set opts(output) "pass\n"
        } else {
            set opts(output) "fail\n"
        }
    }
    # Change \n sequences to newline chars.
    regsub -all "\\\\n" $opts(output) "\n" opts(output)

    set testcase_machs $opts(mach)
    if { "$testcase_machs" == "all" } {
        set testcase_machs $requested_machs
    }

    foreach mach $testcase_machs {
        if { [lsearch $requested_machs $mach] < 0 } {
            verbose -log "Skipping $mach version of $name, not requested."
            continue
        }

        verbose -log "Testing $name on machine $mach."

        if ![info exists opts(as,$mach)] {
            set opts(as,$mach) $opts(as)
        }

        set comp_output [target_assemble $sourcefile ${name}.o "$opts(as,$mach) -I$srcdir/$subdir"]

        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)
        }

        set comp_output [target_link ${name}.o ${name}.x "$opts(ld,$mach)"]

        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)
        }

        # Build the options argument.
        set options ""
        if { "$opts(timeout)" != "" } {
            set options "$options timeout=$opts(timeout)"
        }

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

        if { "$status" == "pass" } {
            if { "$opts(xerror)" == "no" } {
                if [string match $opts(output) $output] {
                    pass "$mach $testname"
                } else {
                    verbose -log "output:  $output" 3
                    verbose -log "pattern: $opts(output)" 3
                    fail "$mach $testname"
                }
            } else {
                verbose -log "`pass' return code when expecting failure" 3
                fail "$mach $testname"
            }
        } elseif { "$status" == "fail" } {
            if { "$opts(xerror)" == "no" } {
                fail "$mach $testname"
            } else {
                if [string match $opts(output) $output] {
                    pass "$mach $testname"
                } else {
                    verbose -log "output:  $output" 3
                    verbose -log "pattern: $opts(output)" 3
                    fail "$mach $testname"
                }
            }
        } else {
            $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
}