Subversion Repositories or1k

# GDB Testsuite Support for Insight.

#

# Copyright 2001 Red Hat, Inc.

#

# This program is free software; you can redistribute it and/or modify it

# under the terms of the GNU General Public License (GPL) 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.

# Initializes the display for gdbtk testing.

# Returns 1 if tests should run, 0 otherwise.

proc gdbtk_initialize_display {} {

  global _using_windows

  # This is hacky, but, we don't have much choice. When running

  # expect under Windows, tcl_platform(platform) is "unix".

  if {![info exists _using_windows]} {

    set _using_windows [expr {![catch {exec cygpath --help}]}]

  }

  if {![_gdbtk_xvfb_init]} {

    if {$_using_windows} {

      untested "No GDB_DISPLAY -- skipping tests"

    } else {

      untested "No GDB_DISPLAY or Xvfb -- skipping tests"

    }

    return 0

  }

  return 1

}

# From dejagnu:

# srcdir = testsuite src dir (e.g., devo/gdb/testsuite)

# objdir = testsuite obj dir (e.g., gdb/testsuite)

# subdir = subdir of testsuite (e.g., gdb.gdbtk)

#

# To gdbtk:

# env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs)

# env(SRCDIR)=directory containing the test code (e.g., *.test)

# env(OBJDIR)=directory which contains any executables

#            (e.g., gdb/testsuite/gdb.gdbtk)

proc gdbtk_start {test} {

  global verbose

  global GDB

  global GDBFLAGS

  global env srcdir subdir objdir

  gdb_stop_suppressing_tests;

  # Need to convert ::GDB to use (-)?insight...

  if {[regsub {gdb$} $GDB insight newGDB]} {

    set INSIGHT $newGDB

  } else {

    perror "Cannot find Insight executable"

    exit 1

  }

  verbose "Starting $INSIGHT -nx -q --tclcommand=$test"

  set real_test [which $test]

  if {$real_test == 0} {

    perror "$test is not found"

    exit 1

  }

  if {![is_remote host]} {

    if { [which $INSIGHT] == 0 } {

      perror "$INSIGHT does not exist."

      exit 1

    }

  }

  set wd [pwd]

  # Find absolute path to test

  set test [to_tcl_path -abs $test]

  # Set some environment variables

  cd $srcdir

  set abs_srcdir [pwd]

  set env(DEFS) [to_tcl_path -abs [file join $abs_srcdir $subdir defs]]

  cd $wd

  cd [file join $objdir $subdir]

  set env(OBJDIR) [pwd]

  cd $wd

  # Set info about target into env

  _gdbtk_export_target_info

  set env(SRCDIR) $abs_srcdir

  set env(GDBTK_VERBOSE) 1

  set env(GDBTK_LOGFILE) [to_tcl_path [file join $objdir gdb.log]]

  set err [catch {exec $INSIGHT -nx -q --tclcommand=$test} res]

  if { $err } {

    perror "Execing $INSIGHT failed: $res"

    append res "\nERROR gdb-crash"

  }

  return $res

}

# Start xvfb when using it.

# The precedence is:

#   1. If GDB_DISPLAY is set (and not ""), use it

#   2. If Xvfb exists, use it (not on cygwin)

#   3. Skip tests

proc _gdbtk_xvfb_init {} {

  global env spawn_id _xvfb_spawn_id _using_windows

  if {[info exists env(GDB_DISPLAY)]} {

    if {$env(GDB_DISPLAY) != ""} {

      set env(DISPLAY) $env(GDB_DISPLAY)

    } else {

      # Suppress tests

      return 0

    }

  } elseif {!$_using_windows && [which Xvfb] != 0} {

    set screen ":[getpid]"

    set pid [spawn  Xvfb $screen -ac]

    set _xvfb_spawn_id $spawn_id

    set env(DISPLAY) localhost$screen

  } else {

    # No Xvfb found -- skip test

    return 0

  }

  return 1

}

# Kill xvfb

proc _gdbtk_xvfb_exit {} {

  global objdir subdir env _xvfb_spawn_id

  if {[info exists _xvfb_spawn_id]} {

    exec kill [exp_pid -i $_xvfb_spawn_id]

    wait -i $_xvfb_spawn_id

  }

}

# help proc for setting tcl-style paths from unix-style paths

# pass "-abs" to make it an absolute path

proc to_tcl_path {unix_path {arg {}}} {

  global _using_windows

  if {[string compare $unix_path "-abs"] == 0} {

    set unix_path $arg

    set wd [pwd]

    cd [file dirname $unix_path]

    set dirname [pwd]

    set unix_name [file join $dirname [file tail $unix_path]]

    cd $wd

  }

  if {$_using_windows} {

    set unix_path [exec cygpath -aw $unix_path]

    set unix_path [join [split $unix_path \\] /]

  }

  return $unix_path

}

# Set information about the target into the environment

# variable TARGET_INFO. This array will contain a list

# of commands that are necessary to run a target.

#

# This is mostly devined from how dejagnu works, what

# procs are defined, and analyzing unix.exp, monitor.exp,

# and sim.exp.

#

# Array elements exported:

# Index   Meaning

# -----   -------

# init    list of target/board initialization commands

# target  target command for target/board

# load    load command for target/board

# run     run command for target_board

proc _gdbtk_export_target_info {} {

  global env

  # Figure out what "target class" the testsuite is using,

  # i.e., sim, monitor, native

  if {[string compare [info proc gdb_target_monitor] gdb_target_monitor] == 0} {

    # Using a monitor/remote target

    set target monitor

  } elseif {[string compare [info proc gdb_target_sim] gdb_target_sim] == 0} {

    # Using a simulator target

    set target simulator

  } elseif {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} {

    # Using sid

    set target sid

  } else {

    # Assume native

    set target native

  }

  # Now setup the array to be exported.

  set info(init) {}

  set info(target) {}

  set info(load) {}

  set info(run) {}

  switch $target {

    simulator {

      set opts "[target_info gdb,target_sim_options]"

      set info(target) "target sim $opts"

      set info(load) "load"

      set info(run) "run"

    }

    monitor {

      # Setup options for the connection

      if {[target_info exists baud]} {

        lappend info(init) "set remotebaud [target_info baud]"

      }

      if {[target_info exists binarydownload]} {

        lappend info(init) "set remotebinarydownload [target_info binarydownload]"

      }

      if {[target_info exists disable_x_packet]} {

        lappend info(init) "set remote X-packet disable"

      }

      if {[target_info exists disable_z_packet]} {

        lappend info(init) "set remote Z-packet disable"

      }

      # Get target name and connection info

      if {[target_info exists gdb_protocol]} {

        set targetname "[target_info gdb_protocol]"

      } else {

        set targetname "not_specified"

      }

      if {[target_info exists gdb_serial]} {

        set serialport "[target_info gdb_serial]"

      } elseif {[target_info exists netport]} {

        set serialport "[target_info netport]"

      } else {

        set serialport "[target_info serial]"

      }

      set info(target) "target $targetname $serialport"

      set info(load) "load"

      set info(run) "continue"

    }

    sid {

      # We must start sid first, since Insight won't have a clue

      # about how to do this.

      sid_start

      set info(target) "target [target_info gdb_protocol] [target_info netport]"

      set info(load) "load"

      set info(run) "continue"

    }

    native {

      set info(run) "run"

    }

  }

  # Export the array to the environment

  set env(TARGET_INFO) [array get info]

}

# gdbtk tests call this function to print out the results of the

# tests. The argument is a proper list of lists of the form:

# {status name description msg}. All of these things typically

# come from the testsuite harness.

proc gdbtk_analyze_results {results} {

  foreach test $results {

    set status [lindex $test 0]

    set name [lindex $test 1]

    set description [lindex $test 2]

    set msg [lindex $test 3]

    switch $status {

      PASS {

        pass "$description ($name)"

      }

      FAIL {

        fail "$description ($name)"

      }

      ERROR {

        perror "$name"

      }

      XFAIL {

        xfail "$description ($name)"

      }

      XPASS {

        xpass "$description ($name)"

      }

    }

  }

}

proc gdbtk_done {{results {}}} {

  global _xvfb_spawn_id

  gdbtk_analyze_results $results

  # Kill off xvfb if using it

  if {[info exists _xvfb_spawn_id]} {

    _gdbtk_xvfb_exit

  }

  # Yich. If we're using sid, we must kill it

  if {[string compare [info proc gdb_target_sid] gdb_target_sid] == 0} {

    sid_exit

  }

}