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

   1 # Copyright (C) 2008-2016 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 <gdb:value> math operations.
  18
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 proc test_value_numeric_ops {} {
  24     global gdb_prompt
  25
  26     gdb_scm_test_silent_cmd "gu (define i (make-value 5))" \
  27         "create first integer value"
  28     gdb_scm_test_silent_cmd "gu (define j (make-value 2))" \
  29         "create second integer value"
  30     gdb_test "gu (print (value-add i j))" \
  31         "= 7" "add two integer values"
  32     gdb_test "gu (raw-print (value-add i j))" \
  33         "= #<gdb:value 7>" "verify type of integer add result"
  34
  35     gdb_scm_test_silent_cmd "gu (define f (make-value  1.25))" \
  36         "create first double value"
  37     gdb_scm_test_silent_cmd "gu (define g (make-value 2.5))" \
  38         "create second double value"
  39     gdb_test "gu (print (value-add f g))" \
  40         "= 3.75" "add two double values"
  41     gdb_test "gu (raw-print (value-add f g))" \
  42         "= #<gdb:value 3.75>" "verify type of double add result"
  43
  44     gdb_test "gu (print (value-sub i j))" \
  45         "= 3" "subtract two integer values"
  46     gdb_test "gu (print (value-sub f g))" \
  47         "= -1.25" "subtract two double values"
  48
  49     gdb_test "gu (print (value-mul i j))" \
  50         "= 10" "multiply two integer values"
  51     gdb_test "gu (print (value-mul f g))" \
  52         "= 3.125" "multiply two double values"
  53
  54     gdb_test "gu (print (value-div i j))" \
  55         "= 2" "divide two integer values"
  56     gdb_test "gu (print (value-div f g))" \
  57         "= 0.5" "divide two double values"
  58     gdb_test "gu (print (value-rem i j))" \
  59         "= 1" "take remainder of two integer values"
  60     gdb_test "gu (print (value-mod i j))" \
  61         "= 1" "take modulus of two integer values"
  62
  63     gdb_test "gu (print (value-pow i j))" \
  64         "= 25" "integer value raised to the power of another integer value"
  65     gdb_test "gu (print (value-pow g j))" \
  66         "= 6.25" "double value raised to the power of integer value"
  67
  68     gdb_test "gu (print (value-neg i))" \
  69         "= -5" "negated integer value"
  70     gdb_test "gu (print (value-pos i))" \
  71         "= 5" "positive integer value"
  72     gdb_test "gu (print (value-neg f))" \
  73         "= -1.25" "negated double value"
  74     gdb_test "gu (print (value-pos f))" \
  75         "= 1.25" "positive double value"
  76     gdb_test "gu (print (value-abs (value-sub j i)))" \
  77         "= 3" "absolute of integer value"
  78     gdb_test "gu (print (value-abs (value-sub f g)))" \
  79         "= 1.25" "absolute of double value"
  80
  81     gdb_test "gu (print (value-lsh i j))" \
  82         "= 20" "left shift"
  83     gdb_test "gu (print (value-rsh i j))" \
  84         "= 1" "right shift"
  85
  86     gdb_test "gu (print (value-min i j))" \
  87         "= 2" "min"
  88     gdb_test "gu (print (value-max i j))" \
  89         "= 5" "max"
  90
  91     gdb_test "gu (print (value-lognot i))" \
  92         "= -6" "lognot"
  93     gdb_test "gu (print (value-logand i j))" \
  94         "= 0" "logand i j"
  95     gdb_test "gu (print (value-logand 5 1))" \
  96         "= 1" "logand 5 1"
  97     gdb_test "gu (print (value-logior i j))" \
  98         "= 7" "logior i j"
  99     gdb_test "gu (print (value-logior 5 1))" \
 100         "= 5" "logior 5 1"
 101     gdb_test "gu (print (value-logxor i j))" \
 102         "= 7" "logxor i j"
 103     gdb_test "gu (print (value-logxor 5 1))" \
 104         "= 4" "logxor 5 1"
 105
 106     # Test <gdb:value> mixed with Guile types.
 107
 108     gdb_test "gu (print (value-sub i 1))" \
 109         "= 4" "subtract integer value from guile integer"
 110     gdb_test "gu (raw-print (value-sub i 1))" \
 111         "#<gdb:value 4>" \
 112         "verify type of mixed integer subtraction result"
 113     gdb_test "gu (print (value-add f 1.5))" \
 114         "= 2.75" "add double value with guile float"
 115
 116     gdb_test "gu (print (value-sub 1 i))" \
 117         "= -4" "subtract guile integer from integer value"
 118     gdb_test "gu (print (value-add 1.5 f))" \
 119         "= 2.75" "add guile float with double value"
 120
 121     # Enum conversion test.
 122     gdb_test "print evalue" "= TWO"
 123     gdb_test "gu (print (value->integer (history-ref 0)))" "= 2"
 124
 125     # Test pointer arithmetic.
 126
 127     # First, obtain the pointers.
 128     gdb_test "print (void *) 2" ".*" ""
 129     gdb_test_no_output "gu (define a (history-ref 0))"
 130     gdb_test "print (void *) 5" ".*" ""
 131     gdb_test_no_output "gu (define b (history-ref 0))"
 132
 133     gdb_test "gu (print (value-add a 5))" \
 134         "= 0x7( <.*>)?" "add pointer value with guile integer"
 135     gdb_test "gu (print (value-sub b 2))" \
 136         "= 0x3( <.*>)?" "subtract guile integer from pointer value"
 137     gdb_test "gu (print (value-sub b a))" \
 138         "= 3" "subtract two pointer values"
 139
 140     # Test some invalid operations.
 141
 142     gdb_test_multiple "gu (print (value-add i '()))" "catch error in guile type conversion" {
 143         -re "Wrong type argument in position 2.*$gdb_prompt $" {pass "catch error in guile type conversion"}
 144         -re "= .*$gdb_prompt $"  {fail "catch error in guile type conversion"}
 145         -re "$gdb_prompt $"      {fail "catch error in guile type conversion"}
 146     }
 147
 148     gdb_test_multiple "gu (print (value-add i \"foo\"))" "catch throw of GDB error" {
 149         -re "Argument to arithmetic operation not a number or boolean.*$gdb_prompt $" {pass "catch throw of GDB error"}
 150         -re "= .*$gdb_prompt $"         {fail "catch throw of GDB error"}
 151         -re "$gdb_prompt $"             {fail "catch throw of GDB error"}
 152     }
 153 }
 154
 155 # Return the max signed int of size SIZE.
 156 # TCL 8.5 required here.  Use lookup table instead?
 157
 158 proc get_max_int { size } {
 159     return [expr "(1 << ($size - 1)) - 1"]
 160 }
 161
 162 # Return the min signed int of size SIZE.
 163 # TCL 8.5 required here.  Use lookup table instead?
 164
 165 proc get_min_int { size } {
 166     return [expr "-(1 << ($size - 1))"]
 167 }
 168
 169 # Return the max unsigned int of size SIZE.
 170 # TCL 8.5 required here.  Use lookup table instead?
 171
 172 proc get_max_uint { size } {
 173     return [expr "(1 << $size) - 1"]
 174 }
 175
 176 # Helper routine for test_value_numeric_ranges.
 177
 178 proc test_make_int_value { name size } {
 179     set max [get_max_int $size]
 180     set min [get_min_int $size]
 181     set umax [get_max_uint $size]
 182     gdb_test "gu (print (value-type (make-value $max)))" \
 183         "= $name" "test make-value $name $size max"
 184     gdb_test "gu (print (value-type (make-value $min)))" \
 185         "= $name" "test make-value $name $size min"
 186     gdb_test "gu (print (value-type (make-value $umax)))" \
 187         "= unsigned $name" "test make-value unsigned $name $size umax"
 188 }
 189
 190 # Helper routine for test_value_numeric_ranges.
 191
 192 proc test_make_typed_int_value { size } {
 193     set name "int$size"
 194     set uname "uint$size"
 195     set max [get_max_int $size]
 196     set min [get_min_int $size]
 197     set umax [get_max_uint $size]
 198
 199     gdb_test "gu (print (make-value $max #:type (arch-${name}-type arch)))" \
 200         "= $max" "test make-value $name $size max"
 201     gdb_test "gu (print (make-value $min #:type (arch-${name}-type arch)))" \
 202         "= $min" "test make-value $name $size min"
 203     gdb_test "gu (print (make-value $umax #:type (arch-${uname}-type arch)))" \
 204         "= $umax" "test make-value $uname $size umax"
 205
 206     gdb_test "gu (print (make-value (+ $max 1) #:type (arch-${name}-type arch)))" \
 207         "ERROR.*Out of range.*" "test make-value $name $size max+1"
 208     gdb_test "gu (print (make-value (- $min 1) #:type (arch-${name}-type arch)))" \
 209         "ERROR.*Out of range.*" "test make-value $name $size min-1"
 210     gdb_test "gu (print (make-value (+ $umax 1) #:type (arch-${uname}-type arch)))" \
 211         "ERROR.*Out of range.*" "test make-value $uname $size umax+1"
 212 }
 213
 214 proc test_value_numeric_ranges {} {
 215     # We can't assume anything about sizeof (int), etc. on the target.
 216     # Keep it simple for now, this will cover everything important for
 217     # the major targets.
 218     set int_size [get_sizeof "int" 0]
 219     set long_size [get_sizeof "long" 0]
 220     gdb_test_no_output "gu (define arch (current-arch))"
 221
 222     if { $int_size == 4 } {
 223         test_make_int_value int 32
 224     }
 225     if { $long_size == 8} {
 226         test_make_int_value long 64
 227     }
 228     gdb_test "gu (print (value-type (make-value (ash 1 64))))" \
 229         "ERROR:.*value not a number representable.*" \
 230         "test make-value, number too large"
 231
 232     foreach size { 8 16 32 } {
 233         test_make_typed_int_value $size
 234     }
 235     if { $long_size == 8 } {
 236         test_make_typed_int_value 64
 237     }
 238 }
 239
 240 proc test_value_boolean {} {
 241     # Note: Boolean values print as 0,1 because they are printed in the
 242     # current language (in this case C).
 243
 244     gdb_test "gu (print (make-value #t))" "= 1" "create boolean true"
 245     gdb_test "gu (print (make-value #f))" "= 0" "create boolean false"
 246
 247     gdb_test "gu (print (value-not (make-value #t)))" \
 248         "= 0" "not true"
 249     gdb_test "gu (print (value-not (make-value #f)))" \
 250         "= 1" "not false"
 251
 252     gdb_test "gu (raw-print (make-value #t))" \
 253         "#<gdb:value 1>" "verify type of boolean"
 254 }
 255
 256 proc test_value_compare {} {
 257     gdb_test "gu (print (value<? 1 1))" \
 258         "#f" "less than, equal"
 259     gdb_test "gu (print (value<? 1 2))" \
 260         "#t" "less than, less"
 261     gdb_test "gu (print (value<? 2 1))" \
 262         "#f" "less than, greater"
 263
 264     gdb_test "gu (print (value<=? 1 1))" \
 265         "#t" "less or equal, equal"
 266     gdb_test "gu (print (value<=? 1 2))" \
 267         "#t" "less or equal, less"
 268     gdb_test "gu (print (value<=? 2 1))" \
 269         "#f" "less or equal, greater"
 270
 271     gdb_test "gu (print (value=? 1 1))" \
 272         "#t" "equality"
 273     gdb_test "gu (print (value=? 1 2))" \
 274         "#f" "inequality"
 275     gdb_test "gu (print (value=? (make-value 1) 1.0))" \
 276         "#t" "equality of gdb:value with Guile value"
 277     gdb_test "gu (print (value=? (make-value 1) 2))" \
 278         "#f" "inequality of gdb:value with Guile value"
 279
 280     gdb_test "gu (print (value>? 1 1))" \
 281         "#f" "greater than, equal"
 282     gdb_test "gu (print (value>? 1 2))" \
 283         "#f" "greater than, less"
 284     gdb_test "gu (print (value>? 2 1))" \
 285         "#t" "greater than, greater"
 286
 287     gdb_test "gu (print (value>=? 1 1))" \
 288         "#t" "greater or equal, equal"
 289     gdb_test "gu (print (value>=? 1 2))" \
 290         "#f" "greater or equal, less"
 291     gdb_test "gu (print (value>=? 2 1))" \
 292         "#t" "greater or equal, greater"
 293 }
 294
 295 if {[prepare_for_testing $testfile.exp $testfile $srcfile {debug c}]} {
 296     return
 297 }
 298
 299 # Skip all tests if Guile scripting is not enabled.
 300 if { [skip_guile_tests] } { continue }
 301
 302 if ![gdb_guile_runto_main] {
 303    return
 304 }
 305
 306 test_value_numeric_ops
 307 test_value_numeric_ranges
 308 test_value_boolean
 309 test_value_compare