gdb/testsuite/gdb.fortran/types.exp

   1 # Copyright (C) 1994 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 # This file was adapted from Chill tests by Stan Shebs (shebs@cygnus.com).
  21
  22 if $tracelevel then {
  23         strace $tracelevel
  24 }
  25
  26 set prms_id 0
  27 set bug_id 0
  28
  29 # Set the current language to fortran.  This counts as a test.  If it
  30 # fails, then we skip the other tests.
  31
  32 proc set_lang_fortran {} {
  33     global prompt
  34
  35     send "set language fortran\n"
  36     expect {
  37         -re ".*$prompt $" {}
  38         timeout { fail "set language fortran (timeout)" ; return 0 }
  39     }
  40
  41     send "show language\n"
  42     expect {
  43         -re ".* source language is \"fortran\".*$prompt $" {
  44             pass "set language to \"fortran\""
  45             return 1
  46         }
  47         -re ".*$prompt $" {
  48             fail "setting language to \"fortran\""
  49             return 0
  50         }
  51         timeout {
  52             fail "can't show language (timeout)"
  53             return 0
  54         }
  55     }
  56 }
  57
  58 # Testing printing of a specific value.  Increment passcount for
  59 # success or issue fail message for failure.  In both cases, return
  60 # a 1 to indicate that more tests can proceed.  However a timeout
  61 # is a serious error, generates a special fail message, and causes
  62 # a 0 to be returned to indicate that more tests are likely to fail
  63 # as well.
  64 #
  65 # Args are:
  66 #
  67 #       First one is string to send to gdb
  68 #       Second one is string to match gdb result to
  69 #       Third one is an optional message to be printed
  70
  71 proc test_print_accept { args } {
  72     global prompt
  73     global passcount
  74     global verbose
  75
  76     if [llength $args]==3 then {
  77         set message [lindex $args 2]
  78     } else {
  79         set message [lindex $args 0]
  80     }
  81     set sendthis [lindex $args 0]
  82     set expectthis [lindex $args 1]
  83     if $verbose>2 then {
  84         send_user "Sending \"$sendthis\" to gdb\n"
  85         send_user "Looking to match \"$expectthis\"\n"
  86         send_user "Message is \"$message\"\n"
  87     }
  88     send "$sendthis\n"
  89     expect {
  90         -re ".* = $expectthis\r\n$prompt $" {
  91             incr passcount
  92             return 1
  93         }
  94         -re ".*$prompt $" {
  95             if ![string match "" $message] then {
  96                 fail "$sendthis ($message)"
  97             } else {
  98                 fail "$sendthis"
  99             }
 100             return 1
 101         }
 102         timeout {
 103             fail "$sendthis (timeout)"
 104             return 0
 105         }
 106     }
 107 }
 108
 109 # Testing printing of a specific value.  Increment passcount for
 110 # success or issue fail message for failure.  In both cases, return
 111 # a 1 to indicate that more tests can proceed.  However a timeout
 112 # is a serious error, generates a special fail message, and causes
 113 # a 0 to be returned to indicate that more tests are likely to fail
 114 # as well.
 115
 116 proc test_print_reject { args } {
 117     global prompt
 118     global passcount
 119     global verbose
 120
 121     if [llength $args]==2 then {
 122         set expectthis [lindex $args 1]
 123     } else {
 124         set expectthis "should never match this bogus string"
 125     }
 126     set sendthis [lindex $args 0]
 127     if $verbose>2 then {
 128         send_user "Sending \"$sendthis\" to gdb\n"
 129         send_user "Looking to match \"$expectthis\"\n"
 130     }
 131     send "$sendthis\n"
 132     expect {
 133         -re ".*A .* in expression.*\\.*$prompt $" {
 134             incr passcount
 135             return 1
 136         }
 137         -re ".*Junk after end of expression.*$prompt $" {
 138             incr passcount
 139             return 1
 140         }
 141         -re ".*No symbol table is loaded.*$prompt $" {
 142             incr passcount
 143             return 1
 144         }
 145         -re ".*$expectthis.*$prompt $" {
 146             incr passcount
 147             return 1
 148         }
 149         -re ".*$prompt $" {
 150             fail "$sendthis not properly rejected"
 151             return 1
 152         }
 153         timeout {
 154             fail "$sendthis (timeout)"
 155             return 0
 156         }
 157     }
 158 }
 159
 160 proc test_integer_literal_types_accepted {} {
 161     global prompt
 162     global passcount
 163
 164     set passcount 0
 165
 166     # Test various decimal values.
 167
 168     test_print_accept "pt 123" "integer"
 169
 170     if $passcount then {
 171         pass "$passcount correct integer literal types printed"
 172     }
 173 }
 174
 175 proc test_character_literal_types_accepted {} {
 176     global prompt
 177     global passcount
 178
 179     set passcount 0
 180
 181     # Test various character values.
 182
 183     test_print_accept "pt 'a'" "character*1"
 184
 185     if $passcount then {
 186         pass "$passcount correct character literal types printed"
 187     }
 188 }
 189
 190 proc test_integer_literal_types_rejected {} {
 191     global prompt
 192     global passcount
 193
 194     set passcount 0
 195
 196     test_print_reject "pt _"
 197
 198     if $passcount then {
 199         pass "$passcount incorrect integer literal types rejected"
 200     }
 201 }
 202
 203 proc test_logical_literal_types_accepted {} {
 204     global prompt
 205     global passcount
 206
 207     set passcount 0
 208
 209     # Test the only possible values for a logical, TRUE and FALSE.
 210
 211     test_print_accept "pt .TRUE." "logical*2"
 212     test_print_accept "pt .FALSE." "logical*2"
 213
 214     if $passcount then {
 215         pass "$passcount correct logical literal types printed"
 216     }
 217 }
 218
 219 proc test_float_literal_types_accepted {} {
 220     global prompt
 221     global passcount
 222
 223     set passcount 0
 224
 225     # Test various floating point formats
 226
 227     test_print_accept "pt .44" "real*8"
 228     test_print_accept "pt 44.0" "real*8"
 229     test_print_accept "pt 10D20" "1"
 230     test_print_accept "pt 10D20" "0"
 231     test_print_accept "pt 10d20" "1"
 232     test_print_accept "pt 10d20" "0"
 233     test_print_accept "pt 10E20" "real*8"
 234     test_print_accept "pt 10E20" "real*8"
 235     test_print_accept "pt 10e20" "real*8"
 236     test_print_accept "pt 10e20" "real*8"
 237
 238     if $passcount then {
 239         pass "$passcount correct float literal comparisons"
 240     }
 241 }
 242
 243 # Start with a fresh gdb.
 244
 245 gdb_exit
 246 gdb_start
 247 gdb_reinitialize_dir $srcdir/$subdir
 248
 249 send "set print sevenbit-strings\n" ; expect -re ".*$prompt $"
 250
 251 if [set_lang_fortran] then {
 252     test_integer_literal_types_accepted
 253     test_integer_literal_types_rejected
 254     test_logical_literal_types_accepted
 255     test_character_literal_types_accepted
 256     test_float_literal_types_accepted
 257 } else {
 258     warning "$test_name tests suppressed."
 259 }