From: Tom Tromey Date: Mon, 15 Mar 2021 12:23:12 +0000 (-0600) Subject: Implement Ada operator overloading X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c04da66c264162e6efc37686c0e4ee46c5b048ab;p=binutils-gdb.git Implement Ada operator overloading In the expression rewrite, I neglected to carry over support for Ada operator overloading. It turns out that there were no tests for this in-tree. This patch adds support for operator overloading, and adds the missing test. gdb/ChangeLog 2021-03-15 Tom Tromey * ada-lang.c (numeric_type_p, integer_type_p): Return true for fixed-point. * ada-exp.y (maybe_overload): New function. (ada_wrap_overload): New function. (ada_un_wrap2, ada_wrap2, ada_wrap_op): Use maybe_overload. (exp1, simple_exp, relation, and_exp, and_then_exp, or_exp) (or_else_exp, xor_exp, primary): Update. gdb/testsuite/ChangeLog 2021-03-15 Tom Tromey * gdb.ada/operator_call/twovecs.ads: New file. * gdb.ada/operator_call/twovecs.adb: New file. * gdb.ada/operator_call/opcall.adb: New file. * gdb.ada/operator_call.exp: New file. --- diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 3033d11387d..a5580fde4d6 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,13 @@ +2021-03-15 Tom Tromey + + * ada-lang.c (numeric_type_p, integer_type_p): Return true for + fixed-point. + * ada-exp.y (maybe_overload): New function. + (ada_wrap_overload): New function. + (ada_un_wrap2, ada_wrap2, ada_wrap_op): Use maybe_overload. + (exp1, simple_exp, relation, and_exp, and_then_exp, or_exp) + (or_else_exp, xor_exp, primary): Update. + 2021-03-15 Tom Tromey PR ada/27545: diff --git a/gdb/ada-exp.y b/gdb/ada-exp.y index 4300907685c..e8ffb8e1040 100644 --- a/gdb/ada-exp.y +++ b/gdb/ada-exp.y @@ -166,17 +166,77 @@ ada_addrof (struct type *type = nullptr) pstate->push (std::move (wrapped)); } +/* Handle operator overloading. Either returns a function all + operation wrapping the arguments, or it returns null, leaving the + caller to construct the appropriate operation. If RHS is null, a + unary operator is assumed. */ +static operation_up +maybe_overload (enum exp_opcode op, operation_up &lhs, operation_up &rhs) +{ + struct value *args[2]; + + int nargs = 1; + args[0] = lhs->evaluate (nullptr, pstate->expout.get (), + EVAL_AVOID_SIDE_EFFECTS); + if (rhs == nullptr) + args[1] = nullptr; + else + { + args[1] = rhs->evaluate (nullptr, pstate->expout.get (), + EVAL_AVOID_SIDE_EFFECTS); + ++nargs; + } + + block_symbol fn = ada_find_operator_symbol (op, pstate->parse_completion, + nargs, args); + if (fn.symbol == nullptr) + return {}; + + if (symbol_read_needs_frame (fn.symbol)) + pstate->block_tracker->update (fn.block, INNERMOST_BLOCK_FOR_SYMBOLS); + operation_up callee + = make_operation (fn.symbol, fn.block); + + std::vector argvec; + argvec.push_back (std::move (lhs)); + if (rhs != nullptr) + argvec.push_back (std::move (rhs)); + return make_operation (std::move (callee), + std::move (argvec)); +} + +/* Like parser_state::wrap, but use ada_pop to pop the value, and + handle unary overloading. */ +template +void +ada_wrap_overload (enum exp_opcode op) +{ + operation_up arg = ada_pop (); + operation_up empty; + + operation_up call = maybe_overload (op, arg, empty); + if (call == nullptr) + call = make_operation (std::move (arg)); + pstate->push (std::move (call)); +} + /* A variant of parser_state::wrap2 that uses ada_pop to pop both operands, and then pushes a new Ada-wrapped operation of the template type T. */ template void -ada_un_wrap2 () +ada_un_wrap2 (enum exp_opcode op) { operation_up rhs = ada_pop (); operation_up lhs = ada_pop (); - operation_up wrapped = make_operation (std::move (lhs), std::move (rhs)); - pstate->push_new (std::move (wrapped)); + + operation_up wrapped = maybe_overload (op, lhs, rhs); + if (wrapped == nullptr) + { + wrapped = make_operation (std::move (lhs), std::move (rhs)); + wrapped = make_operation (std::move (wrapped)); + } + pstate->push (std::move (wrapped)); } /* A variant of parser_state::wrap2 that uses ada_pop to pop both @@ -184,11 +244,14 @@ ada_un_wrap2 () used. */ template void -ada_wrap2 () +ada_wrap2 (enum exp_opcode op) { operation_up rhs = ada_pop (); operation_up lhs = ada_pop (); - pstate->push_new (std::move (lhs), std::move (rhs)); + operation_up call = maybe_overload (op, lhs, rhs); + if (call == nullptr) + call = make_operation (std::move (lhs), std::move (rhs)); + pstate->push (std::move (call)); } /* A variant of parser_state::wrap2 that uses ada_pop to pop both @@ -200,7 +263,10 @@ ada_wrap_op (enum exp_opcode op) { operation_up rhs = ada_pop (); operation_up lhs = ada_pop (); - pstate->push_new (op, std::move (lhs), std::move (rhs)); + operation_up call = maybe_overload (op, lhs, rhs); + if (call == nullptr) + call = make_operation (op, std::move (lhs), std::move (rhs)); + pstate->push (std::move (call)); } /* Pop three operands using ada_pop, then construct a new ternary @@ -411,7 +477,7 @@ start : exp1 /* Expressions, including the sequencing operator. */ exp1 : exp | exp1 ';' exp - { ada_wrap2 (); } + { ada_wrap2 (BINOP_COMMA); } | primary ASSIGN exp /* Extension for convenience */ { operation_up rhs = pstate->pop (); @@ -515,21 +581,32 @@ simple_exp : primary ; simple_exp : '-' simple_exp %prec UNARY - { ada_wrap (); } + { ada_wrap_overload (UNOP_NEG); } ; simple_exp : '+' simple_exp %prec UNARY { - /* No need to do anything. */ + operation_up arg = ada_pop (); + operation_up empty; + + /* We only need to handle the overloading + case here, not anything else. */ + operation_up call = maybe_overload (UNOP_PLUS, arg, + empty); + if (call != nullptr) + pstate->push (std::move (call)); } ; simple_exp : NOT simple_exp %prec UNARY - { ada_wrap (); } + { + ada_wrap_overload + (UNOP_LOGICAL_NOT); + } ; simple_exp : ABS simple_exp %prec UNARY - { ada_wrap (); } + { ada_wrap_overload (UNOP_ABS); } ; arglist : { $$ = 0; } @@ -559,27 +636,27 @@ primary : '{' var_or_type '}' primary %prec '.' /* Binary operators in order of decreasing precedence. */ simple_exp : simple_exp STARSTAR simple_exp - { ada_wrap2 (); } + { ada_wrap2 (BINOP_EXP); } ; simple_exp : simple_exp '*' simple_exp - { ada_wrap2 (); } + { ada_wrap2 (BINOP_MUL); } ; simple_exp : simple_exp '/' simple_exp - { ada_wrap2 (); } + { ada_wrap2 (BINOP_DIV); } ; simple_exp : simple_exp REM simple_exp /* May need to be fixed to give correct Ada REM */ - { ada_wrap2 (); } + { ada_wrap2 (BINOP_REM); } ; simple_exp : simple_exp MOD simple_exp - { ada_wrap2 (); } + { ada_wrap2 (BINOP_MOD); } ; simple_exp : simple_exp '@' simple_exp /* GDB extension */ - { ada_wrap2 (); } + { ada_wrap2 (BINOP_REPEAT); } ; simple_exp : simple_exp '+' simple_exp @@ -587,7 +664,7 @@ simple_exp : simple_exp '+' simple_exp ; simple_exp : simple_exp '&' simple_exp - { ada_wrap2 (); } + { ada_wrap2 (BINOP_CONCAT); } ; simple_exp : simple_exp '-' simple_exp @@ -606,7 +683,7 @@ relation : simple_exp NOTEQUAL simple_exp ; relation : simple_exp LEQ simple_exp - { ada_un_wrap2 (); } + { ada_un_wrap2 (BINOP_LEQ); } ; relation : simple_exp IN simple_exp DOTDOT simple_exp @@ -649,15 +726,15 @@ relation : simple_exp IN simple_exp DOTDOT simple_exp ; relation : simple_exp GEQ simple_exp - { ada_un_wrap2 (); } + { ada_un_wrap2 (BINOP_GEQ); } ; relation : simple_exp '<' simple_exp - { ada_un_wrap2 (); } + { ada_un_wrap2 (BINOP_LESS); } ; relation : simple_exp '>' simple_exp - { ada_un_wrap2 (); } + { ada_un_wrap2 (BINOP_GTR); } ; exp : relation @@ -670,36 +747,44 @@ exp : relation and_exp : relation _AND_ relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_BITWISE_AND); } | and_exp _AND_ relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_BITWISE_AND); } ; and_then_exp : relation _AND_ THEN relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_LOGICAL_AND); } | and_then_exp _AND_ THEN relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_LOGICAL_AND); } ; or_exp : relation OR relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_BITWISE_IOR); } | or_exp OR relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_BITWISE_IOR); } ; or_else_exp : relation OR ELSE relation - { ada_wrap2 (); } + { ada_wrap2 (BINOP_LOGICAL_OR); } | or_else_exp OR ELSE relation - { ada_wrap2 (); } + { ada_wrap2 (BINOP_LOGICAL_OR); } ; xor_exp : relation XOR relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_BITWISE_XOR); } | xor_exp XOR relation - { ada_wrap2 (); } + { ada_wrap2 + (BINOP_BITWISE_XOR); } ; /* Primaries can denote types (OP_TYPE). In cases such as @@ -737,9 +822,9 @@ primary : primary TICK_ACCESS | primary TICK_TAG { ada_wrap (); } | opt_type_prefix TICK_MIN '(' exp ',' exp ')' - { ada_wrap2 (); } + { ada_wrap2 (BINOP_MIN); } | opt_type_prefix TICK_MAX '(' exp ',' exp ')' - { ada_wrap2 (); } + { ada_wrap2 (BINOP_MAX); } | opt_type_prefix TICK_POS '(' exp ')' { ada_wrap (); } | type_prefix TICK_VAL '(' exp ')' @@ -970,7 +1055,7 @@ primary : '*' primary %prec '.' { ada_addrof (); } | primary '[' exp ']' { - ada_wrap2 (); + ada_wrap2 (BINOP_SUBSCRIPT); ada_wrap (); } ; diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c index 07958e7934e..a74f5408484 100644 --- a/gdb/ada-lang.c +++ b/gdb/ada-lang.c @@ -3690,6 +3690,7 @@ numeric_type_p (struct type *type) { case TYPE_CODE_INT: case TYPE_CODE_FLT: + case TYPE_CODE_FIXED_POINT: return 1; case TYPE_CODE_RANGE: return (type == TYPE_TARGET_TYPE (type) @@ -3737,6 +3738,7 @@ scalar_type_p (struct type *type) case TYPE_CODE_RANGE: case TYPE_CODE_ENUM: case TYPE_CODE_FLT: + case TYPE_CODE_FIXED_POINT: return 1; default: return 0; diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 7df84af72fc..728405e9606 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2021-03-15 Tom Tromey + + * gdb.ada/operator_call/twovecs.ads: New file. + * gdb.ada/operator_call/twovecs.adb: New file. + * gdb.ada/operator_call/opcall.adb: New file. + * gdb.ada/operator_call.exp: New file. + 2021-03-15 Tom Tromey * gdb.ada/enums_overload/enums_overload_main.adb: New file. diff --git a/gdb/testsuite/gdb.ada/operator_call.exp b/gdb/testsuite/gdb.ada/operator_call.exp new file mode 100644 index 00000000000..4a35c5c6000 --- /dev/null +++ b/gdb/testsuite/gdb.ada/operator_call.exp @@ -0,0 +1,115 @@ +# Copyright 2021 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 . + +load_lib "ada.exp" + +if { [skip_ada_tests] } { return -1 } + +standard_ada_testfile opcall + +if {[gdb_compile_ada "${srcfile}" "${binfile}" executable {debug}] != ""} { + return -1 +} + +clean_restart ${testfile} + +set bp_location [gdb_get_line_number "STOP" ${testdir}/opcall.adb] +runto "opcall.adb:$bp_location" + +gdb_test "print p" " = \\(x => 4, y => 5\\)" + +proc test_with_menu {command result} { + global expect_out + + set rxcmd [string_to_regexp $command] + + set num {} + send_gdb "$command\n" + gdb_expect 30 { + -re "^$rxcmd\r\n" { + exp_continue + } + -re "Multiple matches for \[^\r\n\]*\r\n" { + exp_continue + } + -re "^\\\[(\[0-9\]+)\\\] twovecs\\.*\[^\r\n\]*\r\n" { + set num $expect_out(1,string) + exp_continue + } + -re "^\\\[\[0-9\]+\\\] \[^\r\n\]*\r\n" { + # Any other match, we don't want. + exp_continue + } + -re "^> " { + if {$num == ""} { + fail $command + set num 0 + } + send_gdb "$num\n" + exp_continue + } + -re "^\[0-9\]+\r\n" { + # The number we just sent, ignore. + exp_continue + } + -re "\\\$\[0-9\]+ = (\[^\r\n\]+)\r\n" { + if {[regexp $result $expect_out(1,string)]} { + pass $command + } else { + fail $command + } + } + timeout { + fail "$command (timeout)" + } + } +} + +test_with_menu "print p + p" "\\(x => 8, y => 10\\)" +test_with_menu "print p - p" "\\(x => 0, y => 0\\)" +test_with_menu "print p * p" "\\(x => 16, y => 25\\)" +test_with_menu "print p / p" "\\(x => 1, y => 1\\)" + +# See the code to understand the weird numbers here. +test_with_menu "print p mod p" "\\(x => 17, y => 18\\)" +test_with_menu "print p rem p" "\\(x => 38, y => 39\\)" +test_with_menu "print p ** p" "\\(x => 84, y => 105\\)" + +test_with_menu "print p < p" "false" +test_with_menu "print p < p2" "true" +test_with_menu "print p <= p" "true" +test_with_menu "print p <= p2" "true" +test_with_menu "print p > p" "false" +test_with_menu "print p2 > p" "true" +test_with_menu "print p >= p" "true" +test_with_menu "print p2 >= p" "true" +test_with_menu "print p = p" "true" +test_with_menu "print p = p2" "false" +test_with_menu "print p /= p" "false" +test_with_menu "print p /= p2" "true" + +test_with_menu "print p and p2" "\\(x => 4, y => 4\\)" +test_with_menu "print p or p2" "\\(x => 12, y => 13\\)" +test_with_menu "print p xor p2" "\\(x => 8, y => 9\\)" + +# See the code to understand the weird numbers here. +test_with_menu "print p & p" "\\(x => 44, y => 55\\)" + +test_with_menu "print -p" "\\(x => 65532, y => 65531\\)" +test_with_menu "print abs(-p)" "\\(x => 65532, y => 65531\\)" +test_with_menu "print not(p)" "\\(x => 65531, y => 65530\\)" + +# See the code to understand the weird numbers here. +test_with_menu "print +(p)" "\\(x => 5, y => 4\\)" diff --git a/gdb/testsuite/gdb.ada/operator_call/opcall.adb b/gdb/testsuite/gdb.ada/operator_call/opcall.adb new file mode 100644 index 00000000000..3b0de905fc7 --- /dev/null +++ b/gdb/testsuite/gdb.ada/operator_call/opcall.adb @@ -0,0 +1,25 @@ +-- Copyright 2021 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 . + +with Twovecs; use Twovecs; + +procedure Opcall is + P : Twovec; + P2 : Twovec; +begin + P := Pt (4, 5); + P2 := Pt (12, 12); + Do_Nothing (P); -- STOP +end Opcall; diff --git a/gdb/testsuite/gdb.ada/operator_call/twovecs.adb b/gdb/testsuite/gdb.ada/operator_call/twovecs.adb new file mode 100644 index 00000000000..477e1934dc5 --- /dev/null +++ b/gdb/testsuite/gdb.ada/operator_call/twovecs.adb @@ -0,0 +1,133 @@ +-- Copyright 2021 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 . + +package body Twovecs is + + function Pt (X, Y : My_Integer) return Twovec is + begin + return Twovec'(X, Y); + end Pt; + + function "+" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X + P1.X, P0.Y + P1.Y); + end "+"; + + function "-" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X - P1.X, P0.Y - P1.Y); + end "-"; + + function "*" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X * P1.X, P0.Y * P1.Y); + end "*"; + + function "/" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X / P1.X, P0.Y / P1.Y); + end "/"; + + function "mod" (P0, P1 : Twovec) return Twovec is + begin + -- Make sure we get a different answer than "-". + return Twovec' (17, 18); + end "mod"; + + function "rem" (P0, P1 : Twovec) return Twovec is + begin + -- Make sure we get a different answer than "-". + return Twovec' (38, 39); + end "rem"; + + function "**" (P0, P1 : Twovec) return Twovec is + begin + -- It just has to do something recognizable. + return Twovec' (20 * P0.X + P1.X, 20 * P0.Y + P1.Y); + end "**"; + + function "<" (P0, P1 : Twovec) return Boolean is + begin + return P0.X < P1.X and then P0.Y < P1.Y; + end "<"; + + function "<=" (P0, P1 : Twovec) return Boolean is + begin + return P0.X <= P1.X and then P0.Y <= P1.Y; + end "<="; + + function ">" (P0, P1 : Twovec) return Boolean is + begin + return P0.X > P1.X and then P0.Y > P1.Y; + end ">"; + + function ">=" (P0, P1 : Twovec) return Boolean is + begin + return P0.X >= P1.X and then P0.Y >= P1.Y; + end ">="; + + function "=" (P0, P1 : Twovec) return Boolean is + begin + return P0.X = P1.X and then P0.Y = P1.Y; + end "="; + + function "and" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X and P1.X, P0.Y and P1.Y); + end "and"; + + function "or" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X or P1.X, P0.Y or P1.Y); + end "or"; + + function "xor" (P0, P1 : Twovec) return Twovec is + begin + return Twovec' (P0.X xor P1.X, P0.Y xor P1.Y); + end "xor"; + + function "&" (P0, P1 : Twovec) return Twovec is + begin + -- It just has to do something recognizable. + return Twovec' (10 * P0.X + P1.X, 10 * P0.Y + P1.Y); + end "&"; + + function "abs" (P0 : Twovec) return Twovec is + begin + return Twovec' (abs (P0.X), abs (P0.Y)); + end "abs"; + + function "not" (P0 : Twovec) return Twovec is + begin + return Twovec' (not (P0.X), not (P0.Y)); + end "not"; + + function "+" (P0 : Twovec) return Twovec is + begin + -- It just has to do something recognizable. + return Twovec' (+ (P0.Y), + (P0.X)); + end "+"; + + function "-" (P0 : Twovec) return Twovec is + begin + return Twovec' (- (P0.X), - (P0.Y)); + end "-"; + + procedure Do_Nothing (P : Twovec) is + begin + null; + end Do_Nothing; + +end Twovecs; diff --git a/gdb/testsuite/gdb.ada/operator_call/twovecs.ads b/gdb/testsuite/gdb.ada/operator_call/twovecs.ads new file mode 100644 index 00000000000..098261c012c --- /dev/null +++ b/gdb/testsuite/gdb.ada/operator_call/twovecs.ads @@ -0,0 +1,55 @@ +-- Copyright 2021 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 . + +package Twovecs is + type My_Integer is mod 2**16 ; + + type Twovec is private; + + function Pt (X, Y : My_Integer) return Twovec; + + function "+" (P0, P1 : Twovec) return Twovec; + function "-" (P0, P1 : Twovec) return Twovec; + function "*" (P0, P1 : Twovec) return Twovec; + function "/" (P0, P1 : Twovec) return Twovec; + function "mod" (P0, P1 : Twovec) return Twovec; + function "rem" (P0, P1 : Twovec) return Twovec; + function "**" (P0, P1 : Twovec) return Twovec; + + function "<" (P0, P1 : Twovec) return Boolean; + function "<=" (P0, P1 : Twovec) return Boolean; + function ">" (P0, P1 : Twovec) return Boolean; + function ">=" (P0, P1 : Twovec) return Boolean; + function "=" (P0, P1 : Twovec) return Boolean; + + function "and" (P0, P1 : Twovec) return Twovec; + function "or" (P0, P1 : Twovec) return Twovec; + function "xor" (P0, P1 : Twovec) return Twovec; + function "&" (P0, P1 : Twovec) return Twovec; + + function "abs" (P0 : Twovec) return Twovec; + function "not" (P0 : Twovec) return Twovec; + function "+" (P0 : Twovec) return Twovec; + function "-" (P0 : Twovec) return Twovec; + + procedure Do_Nothing (P : Twovec); + +private + + type Twovec is record + X, Y : My_Integer; + end record; + +end Twovecs;