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

# Copyright (C) 2009-2020 Free Software Foundation, Inc.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 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.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# This file is part of the GDB testsuite.
# It tests the mechanism of exposing types to Guile.

load_lib gdb-guile.exp

standard_testfile

if [get_compiler_info c++] {
    return -1
}

# Build inferior to language specification.

proc build_inferior {exefile lang} {
    global srcdir subdir srcfile

    if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
	untested "failed to compile in $lang mode"
	return -1
    }
    return 0
}

# Restart GDB.
# The result is the same as gdb_guile_runto_main.

proc restart_gdb {exefile} {
    global srcdir subdir

    gdb_exit
    gdb_start
    gdb_reinitialize_dir $srcdir/$subdir
    gdb_load ${exefile}

    if { [skip_guile_tests] } {
	return 0
    }

    if ![gdb_guile_runto_main] {
	return 0
    }
    gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
	"load iterator module"

    return 1
}

# Set breakpoint and run to that breakpoint.

proc runto_bp {bp} {
    gdb_breakpoint [gdb_get_line_number $bp]
    gdb_continue_to_breakpoint $bp
}

proc test_fields {lang} {
    with_test_prefix "test_fields" {
	global gdb_prompt

	# fields of a typedef should still return the underlying field list
	gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \
	    "= 2" "$lang typedef field list"

	if {$lang == "c++"} {
	    # Test usage with a class.
	    gdb_scm_test_silent_cmd "print c" "print value (c)"
	    gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \
		"get value (c) from history"
	    gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \
		"get fields from c type"
	    gdb_test "guile (print (length fields))" \
		"= 2" "check number of fields of c"
	    gdb_test "guile (print (field-name (car fields)))" \
		"= c" "check class field c name"
	    gdb_test "guile (print (field-name (cadr fields)))" \
		"= d" "check class field d name"
	}

	# Test normal fields usage in structs.
	gdb_scm_test_silent_cmd "print st" "print value (st)"
	gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
	    "get value (st) from history"
	gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \
	    "get st-type"
	gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \
	    "get fields from st.type"
	gdb_test "guile (print (length fields))" \
	    "= 2" "check number of fields (st)"
	gdb_test "guile (print (field-name (car fields)))" \
	    "= a" "check structure field a name"
	gdb_test "guile (print (field-name (cadr fields)))" \
	    "= b" "check structure field b name"
	gdb_test "guile (print (field-name (type-field st-type \"a\")))" \
	    "= a" "check fields lookup by name"

	# Test has-field?
	gdb_test "guile (print (type-has-field? st-type \"b\"))" \
	    "= #t" "check existent field"
	gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \
	    "= #f" "check non-existent field"

	# Test Guile mapping behavior of gdb:type for structs/classes.
	gdb_test "guile (print (type-num-fields (value-type st)))" \
	    "= 2" "check number of fields (st) with type-num-fields"
	gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \
	    "create field iterator"
	gdb_test "guile (print (iterator-map field-bitpos fi))" \
	    "= \\(0 32\\)" "check field iterator"

	# Test rejection of mapping operations on scalar types.
	gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \
	    "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \
	    "check field iterator on bad type"

	# Test type-array.
	gdb_scm_test_silent_cmd "print ar" "print value (ar)"
	gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
	    "get value (ar) from history"
	gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \
	    "define ar0"
	gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \
	    "= \\{1, 2\\}" "cast to array with one argument"
	gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \
	    "= \\{1, 2\\}" "cast to array with two arguments"

	# Test type-vector.
	# Note: vectors cast differently than arrays.  Here ar[0] is replicated
	# for the size of the vector.
	gdb_scm_test_silent_cmd "print vec_data_1" "print value (vec_data_1)"
	gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \
	    "get value (vec_data_1) from history"

	gdb_scm_test_silent_cmd "print vec_data_2" "print value (vec_data_2)"
	gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \
	    "get value (vec_data_2) from history"

	gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
	    "set vec1"
	gdb_test "guile (print vec1)" \
	    "= \\{1, 1\\}" "cast to vector with one argument"
	gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \
	    "set vec2"
	gdb_test "guile (print vec2)" \
	    "= \\{1, 1\\}" "cast to vector with two arguments"
	gdb_test "guile (print (value=? vec1 vec2))" \
	    "= #t"
	gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
	    "set vec3"
	gdb_test "guile (print (value=? vec1 vec3))" \
	    "= #f"
    }
}

proc test_equality {lang} {
    with_test_prefix "test_equality" {
	gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
	    "get st"
	gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
	    "get ar"
	gdb_test "guile (print (eq? (value-type st) (value-type st)))" \
	    "= #t" "test type eq? on equal types"
	gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \
	    "= #f" "test type eq? on not-equal types"
	gdb_test "guile (print (equal? (value-type st) (value-type st)))" \
	    "= #t" "test type eq? on equal types"
	gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
	    "= #f" "test type eq? on not-equal types"

	if {$lang == "c++"} {
	    gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
		"get c"
	    gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
		"get d"
	    gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \
		"= #t" "test c++ type eq? on equal types"
	    gdb_test "guile (print (eq? (value-type c) (value-type d)))" \
		"= #f" "test c++ type eq? on not-equal types"
	    gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \
		"= #t" "test c++ type equal? on equal types"
	    gdb_test "guile (print (equal? (value-type c) (value-type d)))" \
		"= #f" "test c++ type equal? on not-equal types"
	}
    }
}

proc test_enums {} {
    with_test_prefix "test_enum" {
	gdb_scm_test_silent_cmd "print e" "print value (e)"
	gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \
	    "get value (e) from history"
	gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \
	    "extract type fields from e"
	gdb_test "guile (print (length fields))" \
	    "= 3" "check the number of enum fields"
	gdb_test "guile (print (field-name (car fields)))" \
	    "= v1" "check enum field\[0\] name"
	gdb_test "guile (print (field-name (cadr fields)))" \
	    "= v2" "check enum field\[1\]name"

	# Ditto but by mapping operations.
	gdb_test "guile (print (type-num-fields (value-type e)))" \
	    "= 3" "check the number of enum values"
	gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \
	    "= v1" "check enum field lookup by name (v1)"
	gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \
	    "= v3" "check enum field lookup by name (v3)"
	gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \
	    "\\(0 1 2\\)" "check enum fields iteration"
    }
}

proc test_base_class {} {
    with_test_prefix "test_base_class" {
	gdb_scm_test_silent_cmd "print d" "print value (d)"
	gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \
	    "get value (d) from history"
	gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \
	    "extract type fields from d"
	gdb_test "guile (print (length fields))" \
	    "= 3" "check the number of fields"
	gdb_test "guile (print (field-baseclass? (car fields)))" \
	    "= #t" "check base class (fields\[0\])"
	gdb_test "guile (print (field-baseclass? (cadr fields)))" \
	    "= #f" "check base class (fields\[1\])"
    }
}

proc test_range {} {
    with_test_prefix "test_range" {
	with_test_prefix "on ranged value" {
	    # Test a valid range request.
	    gdb_scm_test_silent_cmd "print ar" "print value (ar)"
	    gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
		"get value (ar) from history"
	    gdb_test "guile (print (length (type-range (value-type ar))))" \
		"= 2" "check correct tuple length"
	    gdb_test "guile (print (type-range (value-type ar)))" \
		"= \\(0 1\\)" "check range"
	}

	with_test_prefix "on unranged value" {
	    # Test where a range does not exist.
	    gdb_scm_test_silent_cmd "print st" "print value (st)"
	    gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
		"get value (st) from history"
	    gdb_test "guile (print (type-range (value-type st)))" \
		"ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \
		"check range for non ranged type"
	}
    }
}

# Perform C Tests.

if { [build_inferior "${binfile}" "c"] < 0 } {
    return
}
if ![restart_gdb "${binfile}"] {
    return
}

with_test_prefix "lang_c" {
    runto_bp "break to inspect struct and array."
    test_fields "c"
    test_equality "c"
    test_enums
}

# Perform C++ Tests.

if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
    return
}
if ![restart_gdb "${binfile}-cxx"] {
    return
}

with_test_prefix "lang_cpp" {
    runto_bp "break to inspect struct and array."
    test_fields "c++"
    test_base_class
    test_range
    test_equality "c++"
    test_enums
}