gdb/testsuite/gdb.chill/tests2.exp

   1 # Copyright (C) 1992, 1995 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 2 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, write to the Free Software
  15 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  16
  17 # Please email any bugs, comments, and/or additions to this file to:
  18 # bug-gdb@prep.ai.mit.edu
  19
  20 if $tracelevel then {
  21         strace $tracelevel
  22 }
  23
  24 set prms_id 0
  25 set bug_id 0
  26
  27 # Set the current language to chill.  This counts as a test.  If it
  28 # fails, then we skip the other tests.
  29
  30 proc set_lang_chill {} {
  31     global prompt
  32     global binfile objdir subdir
  33
  34     if ![file exists $objdir/$subdir/$binfile] then {
  35         return 0
  36     }
  37     verbose "loading file '$objdir/$subdir/$binfile'"
  38     gdb_load $objdir/$subdir/$binfile
  39
  40     send "set language chill\n"
  41     expect {
  42         -re ".*$prompt $" {}
  43         timeout { fail "set language chill (timeout)" ; return 0 }
  44     }
  45
  46     send "show language\n"
  47     expect {
  48         -re ".* source language is \"chill\".*$prompt $" {
  49             pass "set language to \"chill\""
  50             send "break dummyfunc\n"
  51             expect {
  52                 -re ".*$prompt $" {
  53                     send "run\n"
  54                     expect -re ".*$prompt $" {}
  55                     return 1
  56                 }
  57                 timeout {
  58                     fail "can't set breakpoint (timeout)"
  59                     return 0
  60                 }
  61             }
  62         }
  63         -re ".*$prompt $" {
  64             fail "setting language to \"chill\""
  65             return 0
  66         }
  67         timeout {
  68             fail "can't show language (timeout)"
  69             return 0
  70         }
  71     }
  72 }
  73
  74 # Testing printing of a specific value.  Increment passcount for
  75 # success or issue fail message for failure.  In both cases, return
  76 # a 1 to indicate that more tests can proceed.  However a timeout
  77 # is a serious error, generates a special fail message, and causes
  78 # a 0 to be returned to indicate that more tests are likely to fail
  79 # as well.
  80 #
  81 # Args are:
  82 #
  83 #       First one is string to send to gdb
  84 #       Second one is string to match gdb result to
  85 #       Third one is an optional message to be printed
  86
  87 proc test_print_accept { args } {
  88     global prompt
  89     global passcount
  90     global verbose
  91
  92     if [llength $args]==3 then {
  93         set message [lindex $args 2]
  94     } else {
  95         set message [lindex $args 0]
  96     }
  97     set sendthis [lindex $args 0]
  98     set expectthis [lindex $args 1]
  99     if $verbose>2 then {
 100         send_user "Sending \"$sendthis\" to gdb\n"
 101         send_user "Looking to match \"$expectthis\"\n"
 102         send_user "Message is \"$message\"\n"
 103     }
 104     send "$sendthis\n"
 105     expect {
 106         -re ".* = $expectthis\r\n$prompt $" {
 107             incr passcount
 108             return 1
 109         }
 110         -re ".*$prompt $" {
 111             if ![string match "" $message] then {
 112                 fail "$sendthis ($message)"
 113             } else {
 114                 fail "$sendthis"
 115             }
 116             return 1
 117         }
 118         timeout {
 119             fail "$sendthis (timeout)"
 120             return 0
 121         }
 122     }
 123 }
 124
 125 # Testing printing of a specific value.  Increment passcount for
 126 # success or issue fail message for failure.  In both cases, return
 127 # a 1 to indicate that more tests can proceed.  However a timeout
 128 # is a serious error, generates a special fail message, and causes
 129 # a 0 to be returned to indicate that more tests are likely to fail
 130 # as well.
 131
 132 proc test_print_reject { args } {
 133     global prompt
 134     global passcount
 135     global verbose
 136
 137     if [llength $args]==2 then {
 138         set expectthis [lindex $args 1]
 139     } else {
 140         set expectthis "should never match this bogus string"
 141     }
 142     set sendthis [lindex $args 0]
 143     if $verbose>2 then {
 144         send_user "Sending \"$sendthis\" to gdb\n"
 145         send_user "Looking to match \"$expectthis\"\n"
 146     }
 147     send "$sendthis\n"
 148     expect {
 149         -re ".*A .* in expression.*\\.*$prompt $" {
 150             incr passcount
 151             return 1
 152         }
 153         -re ".*Junk after end of expression.*$prompt $" {
 154             incr passcount
 155             return 1
 156         }
 157         -re ".*No symbol table is loaded.*$prompt $" {
 158             incr passcount
 159             return 1
 160         }
 161         -re ".*$expectthis.*$prompt $" {
 162             incr passcount
 163             return 1
 164         }
 165         -re ".*$prompt $" {
 166             fail "$sendthis not properly rejected"
 167             return 1
 168         }
 169         timeout {
 170             fail "$sendthis (timeout)"
 171             return 0
 172         }
 173     }
 174 }
 175
 176 # checks if structure was accessed correctly
 177 proc test_write { args } {
 178     global prompt
 179     global passcount
 180
 181     if [llength $args]==5 then {
 182         set message [lindex $args 4]
 183         set extended [lindex $args 3]
 184         set matchval [lindex $args 2]
 185     } elseif [llength $args]==4 then {
 186         set message [lindex $args 3]
 187         set matchval [lindex $args 2]
 188         set extended ""
 189     } elseif [llength $args]==3 then {
 190         set message [lindex $args 2]
 191         set extended ""
 192     } else {
 193         warning "test ($args) write called with wrong number of arguments"
 194         return
 195     }
 196
 197     set location [lindex $args 0]
 198     set value [lindex $args 1]
 199     if ![info exists matchval] then {
 200         set matchval $value
 201     }
 202     verbose "loc: $location, val: $value, msg: $message, ext: $extended, match: $matchval"
 203
 204     verbose "setting var $value..."
 205     send "set var $location.m$extended := $value\n"
 206     expect -re ".*$prompt $" {}
 207     test_print_accept "print $location" \
 208         "\[\[\]\\.p1: 2863311530, \\.m: $matchval, \\.p2: 1431655765\[\]\]" \
 209         "$message"
 210 }
 211
 212 # test write access from gdb (setvar x:=y) from gdb
 213 proc write_access { } {
 214     global passcount
 215
 216     set passcount 0
 217     verbose "testing write access to locations"
 218
 219     # discrete modes
 220     test_write b1 127 "byte write 1"
 221     test_write b1 -128 "byte write 2"
 222     test_write b1 0 "byte write 3"
 223     test_write ub1 255 "ubyte write 1"
 224     test_write ub1 0 "ubyte write 2"
 225     test_write ub1 42 "ubyte write 3"
 226     test_write i1 32767 "int write 1"
 227     test_write i1 -32768 "int write 2"
 228     test_write i1 0 "int write 3"
 229     test_write ui1 65535 "uint write 1"
 230     test_write ui1 0 "uint write 2"
 231     test_write ui1 123 "uint write 3"
 232     test_write l1 2147483647 "long write 1"
 233     test_write l1 -2147483648 "long write 2"
 234     test_write l1 0 "long write 3"
 235     test_write ul1 4294967295 "ulong write 1"
 236     test_write ul1 0 "ulong write 2"
 237     test_write ul1 1000000 "ulong write 3"
 238     test_write bo1 FALSE "bool write 1"
 239     test_write bo1 TRUE "bool write 2"
 240     test_write c1 \"1234\" "char write 1"
 241     test_write c2 \"1234567\" "char write 2"
 242     test_write c3 \"654321\" "char write 3"
 243     test_write c4 C'65' 'e' "char write 4"
 244     test_write bi1 B'10100101' "bitstring write 1"
 245     test_write bi2 B'0101001010' "bitstring write 2"
 246     test_write se1 a "set write 1"
 247     test_write se1 h "set write 2"
 248     # The following two use numbered sets with too-large values.
 249     setup_xfail "*-*-*"
 250     test_write nse1 nb "numbered set write 1"
 251     setup_xfail "*-*-*"
 252     test_write nse1 nc "numbered set write 2"
 253     test_write r1 127 "range write 1"
 254     test_write r2 32767 "range write 2"
 255     test_write r3 2147483647 "range write 3"
 256
 257     # powerset modes
 258     test_write p1 {[pa:ph]} {\[pa:ph\]} "powerset write 1"
 259     test_write p1 {[pa, pc:pf, ph]} {\[pa, pc:pf, ph\]} "powerset write 2"
 260     test_write p1 {[pa, pc, pe, pg]} {\[pa, pc, pe, pg\]} "powerset write 3"
 261     test_write p1 {[]} {\[\]} "powerset write 4"
 262     test_write p2 {[1:32]} {\[1:32\]} "powerset write 5"
 263     test_write p2 {[1, 3:30, 32]} {\[1, 3:30, 32\]} "powerset write 6"
 264     test_write p2 {[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31]} {\[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31\]} \
 265         "powerset write 7"
 266     test_write p2 {[]} {\[\]} "powerset write 8"
 267
 268 # Fixme: this should be rejected by gnuchill
 269 #    test_write p3 {[-2147483648:2147483647]} {\[-2147483648:2147483647\]} \
 270 #       "powerset write 9"
 271 #    test_write p3 {[-2147483648, -1000000:1000000, 2147483647]} \
 272 #       {\[-2147483648, -1000000:1000000, 2147483647\]} \
 273 #       "powerset write 10"
 274 #    test_write p3 {[-99, -97, -95, 1001, 1003, 1005]} \
 275 #       {\[-99, -97, -95, 1001, 1003, 1005\]} "powerset write 11"
 276 #    test_write p3 {[]} {\[\]} "powerset write 12"
 277
 278     # reference modes
 279     test_write ref1 ->ref1 {H'[0-9a-fA-F]+} "reference write 1"
 280     test_write ref2 ->b1 {H'[0-9a-fA-F]+} "reference write 2"
 281     test_write ref1 NULL "reference write 3"
 282     test_write ref2 NULL "reference write 4"
 283
 284     # procedure modes
 285     test_write pr1 NULL "procefure write 1"
 286     # FIXME: remove when NULL is understood
 287     test_write pr1 0 NULL "procefure write 2"
 288     test_write pr1 dummyfunc {H'[0-9a-fA-F]+ <dummyfunc>} "procedure write 3"
 289
 290     # timing modes, FIXME when callbacks to timefunctions are implemented
 291     #test_write ti1 abstime(1970, 3, 12, 10, 43, 0) {} "time write 1"
 292     #test_write ti2 <set somehow a duration>
 293     xfail "timing modes not implemented yet"
 294
 295     # real modes
 296     # This ones
 297     test_write re1 42.03 {42.0[0-9]*} "real write 1"
 298     test_write re1 0 "real write 2"
 299     test_write re1 "1e+38" {1e\+38|1\.0[0-9]*e\+38|9\.9[0-9]*e\+37} \
 300         "real write 3"
 301     test_write re1 "1e+39" Infinity "real write 4"
 302     test_write re2 42.03 {42.0[0-9]*} "real write 5"
 303     test_write re2 0 "real write 6"
 304     test_write re2 "1e+308" {1e\+308} "real write 7"
 305     test_write re2 "1e+309" Infinity "real write 8"
 306
 307     # array modes
 308     test_write arrl1 {[(1:3): [(1:2): -128]]} {\[\(1:3\): \[\(1:2\): -128\]\]}\
 309         "array write 1"
 310     test_write arrl1 {[(1:3): [(1:2): 0]]} {\[\(1:3\): \[\(1:2\): 0\]\]}\
 311         "array write 2"
 312     test_write arrl1 {[(1): [(1:2): 127], (2): [(1:2): -128], (3): [(1:2): 127]]} {\[\(1\): \[\(1:2\): 127\], \(2\): \[\(1:2\): -128\], \(3\): \[\(1:2\): 127\]\]}\
 313         "array write 3"
 314      test_write arrl1 {[(1:3): [(1:2): 0]]} {\[\(1:3\): \[\(1:2\): 0\]\]}\
 315         "array write 4"
 316      setup_xfail "*-*-*"
 317      # Bogus test case - type mismatch?
 318      test_write arrl1 {[(1): 127, (2): -128]} "array write 5"
 319      test_write arrl1 {[(1:3): [(1:2): 0]]} {\[\(1:3\): \[\(1:2\): 0\]\]}\
 320         "array write 6"
 321
 322     # structure modes
 323     test_write strul1 {[.a: -32768, .b: 32767, .ch: "ZZZZ"]} \
 324         {\[\.a: -32768, \.b: 32767, \.ch: \"ZZZZ\"\]} \
 325         "structure write 1"
 326     test_write strul1 {[.a: 0, .b: 0, .ch: "0000"]} \
 327         {\[\.a: 0, \.b: 0, \.ch: \"0000\"\]} \
 328         "structure write 2"
 329     test_write strul1 -32768 {\[\.a: -32768, \.b: 0, \.ch: \"0000\"\]} \
 330         {.a} "structure write 3"
 331     test_write strul1 {[.a: 0, .b: 0, .ch: "0000"]} \
 332         {\[\.a: 0, \.b: 0, \.ch: \"0000\"\]} \
 333         "structure write 4"
 334     test_write strul1 -32768 {\[\.a: 0, \.b: -32768, \.ch: \"0000\"\]} \
 335         {.b} "structure write 5"
 336     test_write strul1 {[.a: 0, .b: 0, .ch: "0000"]} \
 337         {\[\.a: 0, \.b: 0, \.ch: \"0000\"\]} \
 338         "structure write 6"
 339     test_write strul1 \"HUGO\" {\[\.a: 0, \.b: 0, \.ch: \"HUGO\"\]} \
 340         {.ch} "structure write 7"
 341
 342     if $passcount then {
 343         pass "$passcount correct write access tests"
 344     }
 345 }
 346
 347 # Start with a fresh gdb.
 348
 349 set binfile "tests2.exe"
 350 global passcount
 351
 352 gdb_exit
 353 gdb_start
 354 gdb_reinitialize_dir $srcdir/$subdir
 355
 356 send "set print sevenbit-strings\n" ; expect -re ".*$prompt $"
 357
 358 if [set_lang_chill] then {
 359     write_access
 360 } else {
 361     warning "$test_name tests suppressed."
 362 }