gdb/testsuite/gdb.guile/scm-progspace.exp

   1 # Copyright (C) 2010-2014 Free Software Foundation, Inc.
   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
   5 # the Free Software Foundation; either version 3 of the License, or
   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
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 # This file is part of the GDB testsuite.
  17 # It tests the program space support in Guile.
  18
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 if {[build_executable $testfile.exp $testfile $srcfile debug] == -1} {
  24     return -1
  25 }
  26
  27 # Start with a fresh gdb.
  28
  29 gdb_exit
  30 gdb_start
  31 gdb_reinitialize_dir $srcdir/$subdir
  32
  33 # Skip all tests if Guile scripting is not enabled.
  34 if { [skip_guile_tests] } { continue }
  35
  36 gdb_install_guile_utils
  37 gdb_install_guile_module
  38
  39 proc print_current_progspace { filename_regexp smob_filename_regexp } {
  40     gdb_test "gu (print (progspace-filename (current-progspace)))" \
  41         "= $filename_regexp" "current progspace filename"
  42     gdb_test "gu (print (progspaces))" \
  43         "= \\(#<gdb:progspace $smob_filename_regexp>\\)"
  44 }
  45
  46 gdb_test "gu (print (progspace? 42))" "= #f"
  47 gdb_test "gu (print (progspace? (current-progspace)))" "= #t"
  48
  49 with_test_prefix "at start" {
  50     print_current_progspace "#f" "{no symfile}"
  51 }
  52
  53 gdb_load ${binfile}
  54
  55 with_test_prefix "program loaded" {
  56     print_current_progspace ".*$testfile" ".*$testfile"
  57     gdb_test_no_output "gu (define progspace (current-progspace))"
  58     gdb_test "gu (print (progspace-valid? progspace))" "= #t"
  59     gdb_test "gu (print (progspace-filename progspace))" "= .*$testfile"
  60     gdb_test "gu (print (list? (progspace-objfiles progspace)))" "= #t"
  61 }
  62
  63 # Verify we keep the same progspace when the program is unloaded.
  64
  65 gdb_unload
  66 with_test_prefix "program unloaded" {
  67     print_current_progspace "#f" "{no symfile}"
  68     gdb_test "gu (print (eq? progspace (current-progspace)))" "= #t"
  69 }
  70
  71 # Verify the progspace is garbage collected ok.
  72 # Note that when a program is unloaded, the associated progspace doesn't get
  73 # deleted.  We need to, for example, delete an inferior to get the progspace
  74 # to go away.
  75
  76 gdb_test "add-inferior" "Added inferior 2" "Create new inferior"
  77 gdb_test "inferior 2" ".*" "Switch to new inferior"
  78 gdb_test_no_output "remove-inferiors 1" "Remove first inferior"
  79
  80 with_test_prefix "inferior removed" {
  81     gdb_test "gu (print (progspace-valid? progspace))" "= #f"
  82     gdb_test "gu (print (progspace-filename progspace))" \
  83         "ERROR:.*Invalid object.*"
  84     gdb_test "gu (print (progspace-objfiles progspace))" \
  85         "ERROR:.*Invalid object.*"
  86     print_current_progspace "#f" "{no symfile}"
  87 }
  88
  89 # garbage-collects can trigger segvs if we've messed up somewhere.
  90
  91 gdb_test_no_output "gu (gc)"
  92 gdb_test "gu (print progspace)" "= #<gdb:progspace {invalid}>"