diff options
| -rw-r--r-- | gdb/ChangeLog | 81 | ||||
| -rw-r--r-- | gdb/ada-exp.y | 819 | ||||
| -rw-r--r-- | gdb/ada-lang.c | 768 | ||||
| -rw-r--r-- | gdb/ada-lang.h | 48 | ||||
| -rw-r--r-- | gdb/ada-lex.l | 433 |
5 files changed, 1545 insertions, 604 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index d7cd76a..cbcd017 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,5 +1,86 @@ 2006-01-02 Paul N. Hilfinger <hilfinger@adacore.com> + * ada-exp.y: Considerable reorganization to move functionality + from ada-lex.l to here, where it is logically more appropriate. + The original reason, however, was to prevent premature name + lookups for selector names in record aggregates. + (BLOCKNAME, TYPENAME, OBJECT_RENAMING): Remove; lexer now returns + NAME for all of these. + (VAR): New artificial token to clarify precedence rules. + (OTHERS): New lexeme. + (empty_stoken): New symbol. + (%union): Remove ssym, voidval. + (%type): Remove <voidval> type declarations. + (syntax definitions): Add aggregates. + Remove distinction between NAME, TYPENAME, BLOCKNAME, OBJECT_RENAMING. + Rename some non-terminals to be closer to reference manual usage. + Tighten up expression syntax to disallow certain non-Ada + constructions such as X and then Y or else Z. + (ada_parse): Remove initialization of left_block_context. + (write_var_from_name): Remove. + (write_var_or_type): New function, containing previous code from + defunct write_var_from_name and name_lookup. + (block_lookup): New function, moved from ada-lex.l + (select_possible_type_sym): New function, factored out of + name_lookup, which used to be in ada-lex.l. + (find_primitive_type): Ditto. + (chop_selector): Ditto. + (write_ambiguous_var): New function, factored out of defunct + write_var_from_name. + (write_selectors): New function. + (write_name_assoc): New function. + (write_exp_op_with_string): New function. + + * ada-lex.l (processId): Change interface to return stoken. + (tempbuf, resize_tempbuf, tempbuf_size, tempbuf_len): Remove. + (block_lookup, name_lookup): Remove. Functionality moved to + ada-exp.y. + (state IN_STRING): Remove. + (rules): Handle string escapes in processString. + Add 'others' token. + Return all NAMEs, BLOCKNAMEs, OBJECT_RENAMINGs, TYPENAMEs in + yylval.sval (as simple strings). + All name look-ups now handled in ada-exp.y. + Introduce "::" (COLONCOLON) token and return as separate token. + (processId): Change return convention. Comment. + Leave leading "'" in place. + (processString): New function. + (find_dot_all): Add note to comment. + Fix problem that allowed match only at the end. + + * ada-lang.c: Introduce aggregates. + (find_struct_field): Add new parameter to count fields skipped, and + allow other output parameters to be NULL. + (value_tag_from_contents_and_address, ada_value_struct_elt): Use + new find_struct_field. + (ada_index_struct_field, assign_aggregate, ada_is_array_type) + (num_visible_fields, ada_index_struct_field_1, ada_index_struct_field) + (num_component_specs, assign_component, assign_aggregate): + (aggregate_assign_from_choices,aggregate_assign_positional) + (aggregate_assign_others,add_component_interval): + New functions. + (ada_evaluate_subexp): Declare. + Add aggregate-related operators. + (ada_forward_operator_length): Declare. + (resolve_subexp): Add cases for new aggregate operators and OP_NAME. + Consolidate Ada operators, using ada_forward_operator_length. + (ada_search_struct_field): Search in forward order. + (ADA_OPERATORS): Add new aggregate operators. + (ada_operator_length, ada_op_name, ada_forward_operator_length) + (ada_dump_subexp_body, ada_print_subexp): Handle new aggregate + operators and OP_NAME. + (ada_type_of_array): Use longest_to_int. + (value_assign_to_component): New function. + (ada_forward_operator_length, ada_op_name, ada_dump_subexp_body): + Add OP_NAME case. + (ada_forward_operator_length, ada_dump_subexp_body): + Add OP_STRING case. + + * ada-lang.h (enum ada_operator): Add OP_AGGREGATE, OP_OTHERS, + OP_CHOICES, OP_DISCRETE_RANGE, OP_POSITIONAL. + +2006-01-02 Paul N. Hilfinger <hilfinger@adacore.com> + * ada-lang.c (process_raise_exception_name): Remove extraneous definition from unsubmitted code. diff --git a/gdb/ada-exp.y b/gdb/ada-exp.y index 4253eb8..c22083e 100644 --- a/gdb/ada-exp.y +++ b/gdb/ada-exp.y @@ -108,6 +108,8 @@ struct name_info { struct stoken stoken; }; +static struct stoken empty_stoken = { "", 0 }; + /* If expression is in the context of TYPE'(...), then TYPE, else * NULL. */ static struct type *type_qualifier; @@ -124,10 +126,18 @@ static void write_int (LONGEST, struct type *); static void write_object_renaming (struct block *, struct symbol *, int); -static void write_var_from_name (struct block *, struct name_info); +static struct type* write_var_or_type (struct block *, struct stoken); + +static void write_name_assoc (struct stoken); + +static void write_exp_op_with_string (enum exp_opcode, struct stoken); + +static struct block *block_lookup (struct block *, char *); static LONGEST convert_char_literal (struct type *, LONGEST); +static void write_ambiguous_var (struct block *, char *, int); + static struct type *type_int (void); static struct type *type_long (void); @@ -143,6 +153,7 @@ static struct type *type_long_double (void); static struct type *type_char (void); static struct type *type_system_address (void); + %} %union @@ -158,31 +169,18 @@ static struct type *type_system_address (void); } typed_val_float; struct type *tval; struct stoken sval; - struct name_info ssym; - int voidval; struct block *bval; struct internalvar *ivar; - } -%type <voidval> exp exp1 simple_exp start variable -%type <tval> type +%type <lval> positional_list component_groups component_associations +%type <lval> aggregate_component_list +%type <tval> var_or_type %token <typed_val> INT NULL_PTR CHARLIT %token <typed_val_float> FLOAT -%token <tval> TYPENAME -%token <bval> BLOCKNAME - -/* Both NAME and TYPENAME tokens represent symbols in the input, - and both convey their data as strings. - But a TYPENAME is a string that happens to be defined as a typedef - or builtin type name (such as int or char) - and a NAME is any other symbol. - Contexts where this distinction is not important can use the - nonterminal "name", which matches either NAME or TYPENAME. */ - -%token <sval> STRING -%token <ssym> NAME DOT_ID OBJECT_RENAMING +%token COLONCOLON +%token <sval> STRING NAME DOT_ID %type <bval> block %type <lval> arglist tick_arglist @@ -202,61 +200,77 @@ static struct type *type_system_address (void); %left UNARY %left '*' '/' MOD REM %right STARSTAR ABS NOT - /* The following are right-associative only so that reductions at this - precedence have lower precedence than '.' and '('. The syntax still - forces a.b.c, e.g., to be LEFT-associated. */ + +/* Artificial token to give NAME => ... and NAME | priority over reducing + NAME to <primary> and to give <primary>' priority over reducing <primary> + to <simple_exp>. */ +%nonassoc VAR + +%nonassoc ARROW '|' + %right TICK_ACCESS TICK_ADDRESS TICK_FIRST TICK_LAST TICK_LENGTH %right TICK_MAX TICK_MIN TICK_MODULUS %right TICK_POS TICK_RANGE TICK_SIZE TICK_TAG TICK_VAL + /* The following are right-associative only so that reductions at this + precedence have lower precedence than '.' and '('. The syntax still + forces a.b.c, e.g., to be LEFT-associated. */ %right '.' '(' '[' DOT_ID DOT_ALL -%token ARROW NEW +%token NEW OTHERS %% start : exp1 - | type { write_exp_elt_opcode (OP_TYPE); - write_exp_elt_type ($1); - write_exp_elt_opcode (OP_TYPE); } ; /* Expressions, including the sequencing operator. */ exp1 : exp | exp1 ';' exp { write_exp_elt_opcode (BINOP_COMMA); } + | primary ASSIGN exp /* Extension for convenience */ + { write_exp_elt_opcode (BINOP_ASSIGN); } ; /* Expressions, not including the sequencing operator. */ -simple_exp : simple_exp DOT_ALL +primary : primary DOT_ALL { write_exp_elt_opcode (UNOP_IND); } ; -simple_exp : simple_exp DOT_ID - { write_exp_elt_opcode (STRUCTOP_STRUCT); - write_exp_string ($2.stoken); - write_exp_elt_opcode (STRUCTOP_STRUCT); - } +primary : primary DOT_ID + { write_exp_op_with_string (STRUCTOP_STRUCT, $2); } ; -simple_exp : simple_exp '(' arglist ')' +primary : primary '(' arglist ')' { write_exp_elt_opcode (OP_FUNCALL); write_exp_elt_longcst ($3); write_exp_elt_opcode (OP_FUNCALL); } - ; - -simple_exp : type '(' exp ')' + | var_or_type '(' arglist ')' { - write_exp_elt_opcode (UNOP_CAST); - write_exp_elt_type ($1); - write_exp_elt_opcode (UNOP_CAST); + if ($1 != NULL) + { + if ($3 != 1) + error ("Illegal conversion"); + write_exp_elt_opcode (UNOP_CAST); + write_exp_elt_type ($1); + write_exp_elt_opcode (UNOP_CAST); + } + else + { + write_exp_elt_opcode (OP_FUNCALL); + write_exp_elt_longcst ($3); + write_exp_elt_opcode (OP_FUNCALL); + } } ; -simple_exp : type '\'' save_qualifier { type_qualifier = $1; } '(' exp ')' +primary : var_or_type '\'' save_qualifier { type_qualifier = $1; } + '(' exp ')' { + if ($1 == NULL) + error ("Type required for qualification"); write_exp_elt_opcode (UNOP_QUAL); write_exp_elt_type ($1); write_exp_elt_opcode (UNOP_QUAL); @@ -267,41 +281,61 @@ simple_exp : type '\'' save_qualifier { type_qualifier = $1; } '(' exp ')' save_qualifier : { $$ = type_qualifier; } ; -simple_exp : - simple_exp '(' exp DOTDOT exp ')' +primary : + primary '(' simple_exp DOTDOT simple_exp ')' { write_exp_elt_opcode (TERNOP_SLICE); } + | var_or_type '(' simple_exp DOTDOT simple_exp ')' + { if ($1 == NULL) + write_exp_elt_opcode (TERNOP_SLICE); + else + error ("Cannot slice a type"); + } ; -simple_exp : '(' exp1 ')' { } +primary : '(' exp1 ')' { } ; -simple_exp : variable +/* The following rule causes a conflict with the type conversion + var_or_type (exp) + To get around it, we give '(' higher priority and add bridge rules for + var_or_type (exp, exp, ...) + var_or_type (exp .. exp) + We also have the action for var_or_type(exp) generate a function call + when the first symbol does not denote a type. */ + +primary : var_or_type %prec VAR + { if ($1 != NULL) + { + write_exp_elt_opcode (OP_TYPE); + write_exp_elt_type ($1); + write_exp_elt_opcode (OP_TYPE); + } + } ; -simple_exp: SPECIAL_VARIABLE /* Various GDB extensions */ +primary : SPECIAL_VARIABLE /* Various GDB extensions */ { write_dollar_variable ($1); } ; -exp : simple_exp - ; +primary : aggregate + ; -exp : exp ASSIGN exp /* Extension for convenience */ - { write_exp_elt_opcode (BINOP_ASSIGN); } +simple_exp : primary ; -exp : '-' exp %prec UNARY +simple_exp : '-' simple_exp %prec UNARY { write_exp_elt_opcode (UNOP_NEG); } ; -exp : '+' exp %prec UNARY +simple_exp : '+' simple_exp %prec UNARY { write_exp_elt_opcode (UNOP_PLUS); } ; -exp : NOT exp %prec UNARY +simple_exp : NOT simple_exp %prec UNARY { write_exp_elt_opcode (UNOP_LOGICAL_NOT); } ; -exp : ABS exp %prec UNARY +simple_exp : ABS simple_exp %prec UNARY { write_exp_elt_opcode (UNOP_ABS); } ; @@ -310,17 +344,20 @@ arglist : { $$ = 0; } arglist : exp { $$ = 1; } - | any_name ARROW exp + | NAME ARROW exp { $$ = 1; } | arglist ',' exp { $$ = $1 + 1; } - | arglist ',' any_name ARROW exp + | arglist ',' NAME ARROW exp { $$ = $1 + 1; } ; -exp : '{' type '}' exp %prec '.' +simple_exp : '{' var_or_type '}' simple_exp %prec '.' /* GDB extension */ - { write_exp_elt_opcode (UNOP_MEMVAL); + { + if ($2 == NULL) + error ("Type required within braces in coercion"); + write_exp_elt_opcode (UNOP_MEMVAL); write_exp_elt_type ($2); write_exp_elt_opcode (UNOP_MEMVAL); } @@ -328,136 +365,175 @@ exp : '{' type '}' exp %prec '.' /* Binary operators in order of decreasing precedence. */ -exp : exp STARSTAR exp +simple_exp : simple_exp STARSTAR simple_exp { write_exp_elt_opcode (BINOP_EXP); } ; -exp : exp '*' exp +simple_exp : simple_exp '*' simple_exp { write_exp_elt_opcode (BINOP_MUL); } ; -exp : exp '/' exp +simple_exp : simple_exp '/' simple_exp { write_exp_elt_opcode (BINOP_DIV); } ; -exp : exp REM exp /* May need to be fixed to give correct Ada REM */ +simple_exp : simple_exp REM simple_exp /* May need to be fixed to give correct Ada REM */ { write_exp_elt_opcode (BINOP_REM); } ; -exp : exp MOD exp +simple_exp : simple_exp MOD simple_exp { write_exp_elt_opcode (BINOP_MOD); } ; -exp : exp '@' exp /* GDB extension */ +simple_exp : simple_exp '@' simple_exp /* GDB extension */ { write_exp_elt_opcode (BINOP_REPEAT); } ; -exp : exp '+' exp +simple_exp : simple_exp '+' simple_exp { write_exp_elt_opcode (BINOP_ADD); } ; -exp : exp '&' exp +simple_exp : simple_exp '&' simple_exp { write_exp_elt_opcode (BINOP_CONCAT); } ; -exp : exp '-' exp +simple_exp : simple_exp '-' simple_exp { write_exp_elt_opcode (BINOP_SUB); } ; -exp : exp '=' exp +relation : simple_exp + ; + +relation : simple_exp '=' simple_exp { write_exp_elt_opcode (BINOP_EQUAL); } ; -exp : exp NOTEQUAL exp +relation : simple_exp NOTEQUAL simple_exp { write_exp_elt_opcode (BINOP_NOTEQUAL); } ; -exp : exp LEQ exp +relation : simple_exp LEQ simple_exp { write_exp_elt_opcode (BINOP_LEQ); } ; -exp : exp IN exp DOTDOT exp +relation : simple_exp IN simple_exp DOTDOT simple_exp { write_exp_elt_opcode (TERNOP_IN_RANGE); } - | exp IN exp TICK_RANGE tick_arglist + | simple_exp IN primary TICK_RANGE tick_arglist { write_exp_elt_opcode (BINOP_IN_BOUNDS); write_exp_elt_longcst ((LONGEST) $5); write_exp_elt_opcode (BINOP_IN_BOUNDS); } - | exp IN TYPENAME %prec TICK_ACCESS - { write_exp_elt_opcode (UNOP_IN_RANGE); + | simple_exp IN var_or_type %prec TICK_ACCESS + { + if ($3 == NULL) + error ("Right operand of 'in' must be type"); + write_exp_elt_opcode (UNOP_IN_RANGE); write_exp_elt_type ($3); write_exp_elt_opcode (UNOP_IN_RANGE); } - | exp NOT IN exp DOTDOT exp + | simple_exp NOT IN simple_exp DOTDOT simple_exp { write_exp_elt_opcode (TERNOP_IN_RANGE); write_exp_elt_opcode (UNOP_LOGICAL_NOT); } - | exp NOT IN exp TICK_RANGE tick_arglist + | simple_exp NOT IN primary TICK_RANGE tick_arglist { write_exp_elt_opcode (BINOP_IN_BOUNDS); write_exp_elt_longcst ((LONGEST) $6); write_exp_elt_opcode (BINOP_IN_BOUNDS); write_exp_elt_opcode (UNOP_LOGICAL_NOT); } - | exp NOT IN TYPENAME %prec TICK_ACCESS - { write_exp_elt_opcode (UNOP_IN_RANGE); + | simple_exp NOT IN var_or_type %prec TICK_ACCESS + { + if ($4 == NULL) + error ("Right operand of 'in' must be type"); + write_exp_elt_opcode (UNOP_IN_RANGE); write_exp_elt_type ($4); write_exp_elt_opcode (UNOP_IN_RANGE); write_exp_elt_opcode (UNOP_LOGICAL_NOT); } ; -exp : exp GEQ exp +relation : simple_exp GEQ simple_exp { write_exp_elt_opcode (BINOP_GEQ); } ; -exp : exp '<' exp +relation : simple_exp '<' simple_exp { write_exp_elt_opcode (BINOP_LESS); } ; -exp : exp '>' exp +relation : simple_exp '>' simple_exp { write_exp_elt_opcode (BINOP_GTR); } ; -exp : exp _AND_ exp /* Fix for Ada elementwise AND. */ +exp : relation + | and_exp + | and_then_exp + | or_exp + | or_else_exp + | xor_exp + ; + +and_exp : + relation _AND_ relation { write_exp_elt_opcode (BINOP_BITWISE_AND); } - ; + | and_exp _AND_ relation + { write_exp_elt_opcode (BINOP_BITWISE_AND); } + ; -exp : exp _AND_ THEN exp %prec _AND_ +and_then_exp : + relation _AND_ THEN relation + { write_exp_elt_opcode (BINOP_LOGICAL_AND); } + | and_then_exp _AND_ THEN relation { write_exp_elt_opcode (BINOP_LOGICAL_AND); } ; -exp : exp OR exp /* Fix for Ada elementwise OR */ +or_exp : + relation OR relation { write_exp_elt_opcode (BINOP_BITWISE_IOR); } - ; + | or_exp OR relation + { write_exp_elt_opcode (BINOP_BITWISE_IOR); } + ; -exp : exp OR ELSE exp +or_else_exp : + relation OR ELSE relation + { write_exp_elt_opcode (BINOP_LOGICAL_OR); } + | or_else_exp OR ELSE relation { write_exp_elt_opcode (BINOP_LOGICAL_OR); } ; -exp : exp XOR exp /* Fix for Ada elementwise XOR */ +xor_exp : relation XOR relation + { write_exp_elt_opcode (BINOP_BITWISE_XOR); } + | xor_exp XOR relation { write_exp_elt_opcode (BINOP_BITWISE_XOR); } ; -simple_exp : simple_exp TICK_ACCESS +/* Primaries can denote types (OP_TYPE). In cases such as + primary TICK_ADDRESS, where a type would be illegal, it will be + caught when evaluate_subexp in ada-lang.c tries to evaluate the + primary, expecting a value. Precedence rules resolve the ambiguity + in NAME TICK_ACCESS in favor of shifting to form a var_or_type. A + construct such as aType'access'access will again cause an error when + aType'access evaluates to a type that evaluate_subexp attempts to + evaluate. */ +primary : primary TICK_ACCESS { write_exp_elt_opcode (UNOP_ADDR); } - | simple_exp TICK_ADDRESS + | primary TICK_ADDRESS { write_exp_elt_opcode (UNOP_ADDR); write_exp_elt_opcode (UNOP_CAST); write_exp_elt_type (type_system_address ()); write_exp_elt_opcode (UNOP_CAST); } - | simple_exp TICK_FIRST tick_arglist + | primary TICK_FIRST tick_arglist { write_int ($3, type_int ()); write_exp_elt_opcode (OP_ATR_FIRST); } - | simple_exp TICK_LAST tick_arglist + | primary TICK_LAST tick_arglist { write_int ($3, type_int ()); write_exp_elt_opcode (OP_ATR_LAST); } - | simple_exp TICK_LENGTH tick_arglist + | primary TICK_LENGTH tick_arglist { write_int ($3, type_int ()); write_exp_elt_opcode (OP_ATR_LENGTH); } - | simple_exp TICK_SIZE + | primary TICK_SIZE { write_exp_elt_opcode (OP_ATR_SIZE); } - | simple_exp TICK_TAG + | primary TICK_TAG { write_exp_elt_opcode (OP_ATR_TAG); } | opt_type_prefix TICK_MIN '(' exp ',' exp ')' { write_exp_elt_opcode (OP_ATR_MIN); } @@ -465,15 +541,6 @@ simple_exp : simple_exp TICK_ACCESS { write_exp_elt_opcode (OP_ATR_MAX); } | opt_type_prefix TICK_POS '(' exp ')' { write_exp_elt_opcode (OP_ATR_POS); } - | type_prefix TICK_FIRST tick_arglist - { write_int ($3, type_int ()); - write_exp_elt_opcode (OP_ATR_FIRST); } - | type_prefix TICK_LAST tick_arglist - { write_int ($3, type_int ()); - write_exp_elt_opcode (OP_ATR_LAST); } - | type_prefix TICK_LENGTH tick_arglist - { write_int ($3, type_int ()); - write_exp_elt_opcode (OP_ATR_LENGTH); } | type_prefix TICK_VAL '(' exp ')' { write_exp_elt_opcode (OP_ATR_VAL); } | type_prefix TICK_MODULUS @@ -487,8 +554,11 @@ tick_arglist : %prec '(' ; type_prefix : - TYPENAME - { write_exp_elt_opcode (OP_TYPE); + var_or_type + { + if ($1 == NULL) + error ("Prefix must be type"); + write_exp_elt_opcode (OP_TYPE); write_exp_elt_type ($1); write_exp_elt_opcode (OP_TYPE); } ; @@ -502,18 +572,18 @@ opt_type_prefix : ; -exp : INT +primary : INT { write_int ((LONGEST) $1.val, $1.type); } ; -exp : CHARLIT +primary : CHARLIT { write_int (convert_char_literal (type_qualifier, $1.val), (type_qualifier == NULL) ? $1.type : type_qualifier); } ; -exp : FLOAT +primary : FLOAT { write_exp_elt_opcode (OP_DOUBLE); write_exp_elt_type ($1.type); write_exp_elt_dblcst ($1.dval); @@ -521,61 +591,139 @@ exp : FLOAT } ; -exp : NULL_PTR +primary : NULL_PTR { write_int (0, type_int ()); } ; -exp : STRING +primary : STRING { - write_exp_elt_opcode (OP_STRING); - write_exp_string ($1); - write_exp_elt_opcode (OP_STRING); + write_exp_op_with_string (OP_STRING, $1); } ; -exp : NEW TYPENAME +primary : NEW NAME { error ("NEW not implemented."); } ; -variable: NAME { write_var_from_name (NULL, $1); } - | block NAME /* GDB extension */ - { write_var_from_name ($1, $2); } - | OBJECT_RENAMING - { write_object_renaming (NULL, $1.sym, - MAX_RENAMING_CHAIN_LENGTH); } - | block OBJECT_RENAMING - { write_object_renaming ($1, $2.sym, - MAX_RENAMING_CHAIN_LENGTH); } +var_or_type: NAME %prec VAR + { $$ = write_var_or_type (NULL, $1); } + | block NAME %prec VAR + { $$ = write_var_or_type ($1, $2); } + | NAME TICK_ACCESS + { + $$ = write_var_or_type (NULL, $1); + if ($$ == NULL) + write_exp_elt_opcode (UNOP_ADDR); + else + $$ = lookup_pointer_type ($$); + } + | block NAME TICK_ACCESS + { + $$ = write_var_or_type ($1, $2); + if ($$ == NULL) + write_exp_elt_opcode (UNOP_ADDR); + else + $$ = lookup_pointer_type ($$); + } ; -any_name : NAME { } - | TYPENAME { } - | OBJECT_RENAMING { } - ; +/* GDB extension */ +block : NAME COLONCOLON + { $$ = block_lookup (NULL, $1.ptr); } + | block NAME COLONCOLON + { $$ = block_lookup ($1, $2.ptr); } + ; -block : BLOCKNAME /* GDB extension */ - { $$ = $1; } - | block BLOCKNAME /* GDB extension */ - { $$ = $2; } +aggregate : + '(' aggregate_component_list ')' + { + write_exp_elt_opcode (OP_AGGREGATE); + write_exp_elt_longcst ($2); + write_exp_elt_opcode (OP_AGGREGATE); + } ; +aggregate_component_list : + component_groups { $$ = $1; } + | positional_list exp + { write_exp_elt_opcode (OP_POSITIONAL); + write_exp_elt_longcst ($1); + write_exp_elt_opcode (OP_POSITIONAL); + $$ = $1 + 1; + } + | positional_list component_groups + { $$ = $1 + $2; } + ; -type : TYPENAME { $$ = $1; } - | block TYPENAME { $$ = $2; } - | TYPENAME TICK_ACCESS - { $$ = lookup_pointer_type ($1); } - | block TYPENAME TICK_ACCESS - { $$ = lookup_pointer_type ($2); } - ; +positional_list : + exp ',' + { write_exp_elt_opcode (OP_POSITIONAL); + write_exp_elt_longcst (0); + write_exp_elt_opcode (OP_POSITIONAL); + $$ = 1; + } + | positional_list exp ',' + { write_exp_elt_opcode (OP_POSITIONAL); + write_exp_elt_longcst ($1); + write_exp_elt_opcode (OP_POSITIONAL); + $$ = $1 + 1; + } + ; + +component_groups: + others { $$ = 1; } + | component_group { $$ = 1; } + | component_group ',' component_groups + { $$ = $3 + 1; } + ; + +others : OTHERS ARROW exp + { write_exp_elt_opcode (OP_OTHERS); } + ; + +component_group : + component_associations + { + write_exp_elt_opcode (OP_CHOICES); + write_exp_elt_longcst ($1); + write_exp_elt_opcode (OP_CHOICES); + } + ; + +/* We use this somewhat obscure definition in order to handle NAME => and + NAME | differently from exp => and exp |. ARROW and '|' have a precedence + above that of the reduction of NAME to var_or_type. By delaying + decisions until after the => or '|', we convert the ambiguity to a + resolved shift/reduce conflict. */ +component_associations : + NAME ARROW + { write_name_assoc ($1); } + exp { $$ = 1; } + | simple_exp ARROW exp + { $$ = 1; } + | simple_exp DOTDOT simple_exp ARROW + { write_exp_elt_opcode (OP_DISCRETE_RANGE); + write_exp_op_with_string (OP_NAME, empty_stoken); + } + exp { $$ = 1; } + | NAME '|' + { write_name_assoc ($1); } + component_associations { $$ = $4 + 1; } + | simple_exp '|' + component_associations { $$ = $3 + 1; } + | simple_exp DOTDOT simple_exp '|' + { write_exp_elt_opcode (OP_DISCRETE_RANGE); } + component_associations { $$ = $6 + 1; } + ; /* Some extensions borrowed from C, for the benefit of those who find they can't get used to Ada notation in GDB. */ -exp : '*' exp %prec '.' +primary : '*' primary %prec '.' { write_exp_elt_opcode (UNOP_IND); } - | '&' exp %prec '.' + | '&' primary %prec '.' { write_exp_elt_opcode (UNOP_ADDR); } - | exp '[' exp ']' + | primary '[' exp ']' { write_exp_elt_opcode (BINOP_SUBSCRIPT); } ; @@ -610,7 +758,6 @@ int ada_parse (void) { lexer_init (yyin); /* (Re-)initialize lexer. */ - left_block_context = NULL; type_qualifier = NULL; obstack_free (&temp_parse_space, NULL); obstack_init (&temp_parse_space); @@ -672,42 +819,6 @@ write_var_from_sym (struct block *orig_left_context, write_exp_elt_opcode (OP_VAR_VALUE); } -/* Emit expression to access an instance of NAME in :: context - * ORIG_LEFT_CONTEXT. If no unique symbol for NAME has been found, - * output a dummy symbol (good to the next call of ada_parse) for NAME - * in the UNDEF_DOMAIN, for later resolution by ada_resolve. */ -static void -write_var_from_name (struct block *orig_left_context, - struct name_info name) -{ - if (name.msym != NULL) - { - write_exp_msymbol (name.msym, - lookup_function_type (type_int ()), - type_int ()); - } - else if (name.sym == NULL) - { - /* Multiple matches: record name and starting block for later - resolution by ada_resolve. */ - char *encoded_name = ada_encode (name.stoken.ptr); - struct symbol *sym = - obstack_alloc (&temp_parse_space, sizeof (struct symbol)); - memset (sym, 0, sizeof (struct symbol)); - SYMBOL_DOMAIN (sym) = UNDEF_DOMAIN; - SYMBOL_LINKAGE_NAME (sym) - = obsavestring (encoded_name, strlen (encoded_name), &temp_parse_space); - SYMBOL_LANGUAGE (sym) = language_ada; - - write_exp_elt_opcode (OP_VAR_VALUE); - write_exp_elt_block (name.block); - write_exp_elt_sym (sym); - write_exp_elt_opcode (OP_VAR_VALUE); - } - else - write_var_from_sym (orig_left_context, name.block, name.sym); -} - /* Write integer constant ARG of type TYPE. */ static void @@ -719,6 +830,15 @@ write_int (LONGEST arg, struct type *type) write_exp_elt_opcode (OP_LONG); } +/* Write an OPCODE, string, OPCODE sequence to the current expression. */ +static void +write_exp_op_with_string (enum exp_opcode opcode, struct stoken token) +{ + write_exp_elt_opcode (opcode); + write_exp_string (token); + write_exp_elt_opcode (opcode); +} + /* Emit expression corresponding to the renamed object designated by * the type RENAMING, which must be the referent of an object renaming * type, in the context of ORIG_LEFT_CONTEXT. MAX_DEPTH is the maximum @@ -857,9 +977,7 @@ write_object_renaming (struct block *orig_left_context, strncpy (field_name.ptr, suffix, end - suffix); field_name.ptr[end - suffix] = '\000'; suffix = end; - write_exp_elt_opcode (STRUCTOP_STRUCT); - write_exp_string (field_name); - write_exp_elt_opcode (STRUCTOP_STRUCT); + write_exp_op_with_string (STRUCTOP_STRUCT, field_name); break; } @@ -875,10 +993,348 @@ write_object_renaming (struct block *orig_left_context, SYMBOL_LINKAGE_NAME (renaming)); } +static struct block* +block_lookup (struct block *context, char *raw_name) +{ + char *name; + struct ada_symbol_info *syms; + int nsyms; + struct symtab *symtab; + + if (raw_name[0] == '\'') + { + raw_name += 1; + name = raw_name; + } + else + name = ada_encode (raw_name); + + nsyms = ada_lookup_symbol_list (name, context, VAR_DOMAIN, &syms); + if (context == NULL && + (nsyms == 0 || SYMBOL_CLASS (syms[0].sym) != LOC_BLOCK)) + symtab = lookup_symtab (name); + else + symtab = NULL; + + if (symtab != NULL) + return BLOCKVECTOR_BLOCK (BLOCKVECTOR (symtab), STATIC_BLOCK); + else if (nsyms == 0 || SYMBOL_CLASS (syms[0].sym) != LOC_BLOCK) + { + if (context == NULL) + error ("No file or function \"%s\".", raw_name); + else + error ("No function \"%s\" in specified context.", raw_name); + } + else + { + if (nsyms > 1) + warning ("Function name \"%s\" ambiguous here", raw_name); + return SYMBOL_BLOCK_VALUE (syms[0].sym); + } +} + +static struct symbol* +select_possible_type_sym (struct ada_symbol_info *syms, int nsyms) +{ + int i; + int preferred_index; + struct type *preferred_type; + + preferred_index = -1; preferred_type = NULL; + for (i = 0; i < nsyms; i += 1) + switch (SYMBOL_CLASS (syms[i].sym)) + { + case LOC_TYPEDEF: + if (ada_prefer_type (SYMBOL_TYPE (syms[i].sym), preferred_type)) + { + preferred_index = i; + preferred_type = SYMBOL_TYPE (syms[i].sym); + } + break; + case LOC_REGISTER: + case LOC_ARG: + case LOC_REF_ARG: + case LOC_REGPARM: + case LOC_REGPARM_ADDR: + case LOC_LOCAL: + case LOC_LOCAL_ARG: + case LOC_BASEREG: + case LOC_BASEREG_ARG: + case LOC_COMPUTED: + case LOC_COMPUTED_ARG: + return NULL; + default: + break; + } + if (preferred_type == NULL) + return NULL; + return syms[preferred_index].sym; +} + +static struct type* +find_primitive_type (char *name) +{ + struct type *type; + type = language_lookup_primitive_type_by_name (current_language, + current_gdbarch, + name); + if (type == NULL && strcmp ("system__address", name) == 0) + type = type_system_address (); + + if (type != NULL) + { + /* Check to see if we have a regular definition of this + type that just didn't happen to have been read yet. */ + int ntypes; + struct symbol *sym; + char *expanded_name = + (char *) alloca (strlen (name) + sizeof ("standard__")); + strcpy (expanded_name, "standard__"); + strcat (expanded_name, name); + sym = ada_lookup_symbol (expanded_name, NULL, VAR_DOMAIN, NULL, NULL); + if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF) + type = SYMBOL_TYPE (sym); + } + + return type; +} + +static int +chop_selector (char *name, int end) +{ + int i; + for (i = end - 1; i > 0; i -= 1) + if (name[i] == '.' || (name[i] == '_' && name[i+1] == '_')) + return i; + return -1; +} + +/* Given that SELS is a string of the form (<sep><identifier>)*, where + <sep> is '__' or '.', write the indicated sequence of + STRUCTOP_STRUCT expression operators. */ +static void +write_selectors (char *sels) +{ + while (*sels != '\0') + { + struct stoken field_name; + char *p; + while (*sels == '_' || *sels == '.') + sels += 1; + p = sels; + while (*sels != '\0' && *sels != '.' + && (sels[0] != '_' || sels[1] != '_')) + sels += 1; + field_name.length = sels - p; + field_name.ptr = p; + write_exp_op_with_string (STRUCTOP_STRUCT, field_name); + } +} + +/* Write a variable access (OP_VAR_VALUE) to ambiguous encoded name + NAME[0..LEN-1], in block context BLOCK, to be resolved later. Writes + a temporary symbol that is valid until the next call to ada_parse. + */ +static void +write_ambiguous_var (struct block *block, char *name, int len) +{ + struct symbol *sym = + obstack_alloc (&temp_parse_space, sizeof (struct symbol)); + memset (sym, 0, sizeof (struct symbol)); + SYMBOL_DOMAIN (sym) = UNDEF_DOMAIN; + SYMBOL_LINKAGE_NAME (sym) = obsavestring (name, len, &temp_parse_space); + SYMBOL_LANGUAGE (sym) = language_ada; + + write_exp_elt_opcode (OP_VAR_VALUE); + write_exp_elt_block (block); + write_exp_elt_sym (sym); + write_exp_elt_opcode (OP_VAR_VALUE); +} + + +/* Look up NAME0 (an unencoded identifier or dotted name) in BLOCK (or + expression_block_context if NULL). If it denotes a type, return + that type. Otherwise, write expression code to evaluate it as an + object and return NULL. In this second case, NAME0 will, in general, + have the form <name>(.<selector_name>)*, where <name> is an object + or renaming encoded in the debugging data. Calls error if no + prefix <name> matches a name in the debugging data (i.e., matches + either a complete name or, as a wild-card match, the final + identifier). */ + +static struct type* +write_var_or_type (struct block *block, struct stoken name0) +{ + int depth; + char *encoded_name; + int name_len; + + if (block == NULL) + block = expression_context_block; + + encoded_name = ada_encode (name0.ptr); + name_len = strlen (encoded_name); + encoded_name = obsavestring (encoded_name, name_len, &temp_parse_space); + for (depth = 0; depth < MAX_RENAMING_CHAIN_LENGTH; depth += 1) + { + int tail_index; + + tail_index = name_len; + while (tail_index > 0) + { + int nsyms; + struct ada_symbol_info *syms; + struct symbol *type_sym; + int terminator = encoded_name[tail_index]; + + encoded_name[tail_index] = '\0'; + nsyms = ada_lookup_symbol_list (encoded_name, block, + VAR_DOMAIN, &syms); + encoded_name[tail_index] = terminator; + + /* A single symbol may rename a package or object. */ + + if (nsyms == 1 && !ada_is_object_renaming (syms[0].sym)) + { + struct symbol *renaming_sym = + ada_find_renaming_symbol (SYMBOL_LINKAGE_NAME (syms[0].sym), + syms[0].block); + + if (renaming_sym != NULL) + syms[0].sym = renaming_sym; + } + + type_sym = select_possible_type_sym (syms, nsyms); + if (type_sym != NULL) + { + struct type *type = SYMBOL_TYPE (type_sym); + + if (TYPE_CODE (type) == TYPE_CODE_VOID) + error ("`%s' matches only void type name(s)", name0.ptr); + else if (ada_is_object_renaming (type_sym)) + { + write_object_renaming (block, type_sym, + MAX_RENAMING_CHAIN_LENGTH); + write_selectors (encoded_name + tail_index); + return NULL; + } + else if (ada_renaming_type (SYMBOL_TYPE (type_sym)) != NULL) + { + int result; + char *renaming = ada_simple_renamed_entity (type_sym); + int renaming_len = strlen (renaming); + + char *new_name + = obstack_alloc (&temp_parse_space, + renaming_len + name_len - tail_index + + 1); + strcpy (new_name, renaming); + xfree (renaming); + strcpy (new_name + renaming_len, encoded_name + tail_index); + encoded_name = new_name; + name_len = renaming_len + name_len - tail_index; + goto TryAfterRenaming; + } + else if (tail_index == name_len) + return type; + else + error ("Illegal attempt to select from type: \"%s\".", name0.ptr); + } + else if (tail_index == name_len && nsyms == 0) + { + struct type *type = find_primitive_type (encoded_name); + + if (type != NULL) + return type; + } + + if (nsyms == 1) + { + write_var_from_sym (block, syms[0].block, syms[0].sym); + write_selectors (encoded_name + tail_index); + return NULL; + } + else if (nsyms == 0) + { + int i; + struct minimal_symbol *msym + = ada_lookup_simple_minsym (encoded_name); + if (msym != NULL) + { + write_exp_msymbol (msym, lookup_function_type (type_int ()), + type_int ()); + /* Maybe cause error here rather than later? FIXME? */ + write_selectors (encoded_name + tail_index); + return NULL; + } + + if (tail_index == name_len + && strncmp (encoded_name, "standard__", + sizeof ("standard__") - 1) == 0) + error ("No definition of \"%s\" found.", name0.ptr); + + tail_index = chop_selector (encoded_name, tail_index); + } + else + { + write_ambiguous_var (block, encoded_name, tail_index); + write_selectors (encoded_name + tail_index); + return NULL; + } + } + + if (!have_full_symbols () && !have_partial_symbols () && block == NULL) + error ("No symbol table is loaded. Use the \"file\" command."); + if (block == expression_context_block) + error ("No definition of \"%s\" in current context.", name0.ptr); + else + error ("No definition of \"%s\" in specified context.", name0.ptr); + + TryAfterRenaming: ; + } + + error ("Could not find renamed symbol \"%s\"", name0.ptr); + +} + +/* Write a left side of a component association (e.g., NAME in NAME => + exp). If NAME has the form of a selected component, write it as an + ordinary expression. If it is a simple variable that unambiguously + corresponds to exactly one symbol that does not denote a type or an + object renaming, also write it normally as an OP_VAR_VALUE. + Otherwise, write it as an OP_NAME. + + Unfortunately, we don't know at this point whether NAME is supposed + to denote a record component name or the value of an array index. + Therefore, it is not appropriate to disambiguate an ambiguous name + as we normally would, nor to replace a renaming with its referent. + As a result, in the (one hopes) rare case that one writes an + aggregate such as (R => 42) where R renames an object or is an + ambiguous name, one must write instead ((R) => 42). */ + +static void +write_name_assoc (struct stoken name) +{ + if (strchr (name.ptr, '.') == NULL) + { + struct ada_symbol_info *syms; + int nsyms = ada_lookup_symbol_list (name.ptr, expression_context_block, + VAR_DOMAIN, &syms); + if (nsyms != 1 || SYMBOL_CLASS (syms[0].sym) == LOC_TYPEDEF) + write_exp_op_with_string (OP_NAME, name); + else + write_var_from_sym (NULL, syms[0].block, syms[0].sym); + } + else + if (write_var_or_type (NULL, name) != NULL) + error ("Illegal use of type."); +} + /* Convert the character literal whose ASCII value would be VAL to the appropriate value of type TYPE, if there is a translation. Otherwise return VAL. Hence, in an enumeration type ('A', 'B'), the literal 'A' (VAL == 65), returns 0. */ + static LONGEST convert_char_literal (struct type *type, LONGEST val) { @@ -962,4 +1418,3 @@ _initialize_ada_exp (void) struct stoken (*dummy_string_to_ada_operator) (struct stoken) = string_to_operator; - diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c index 4f62c2e..0eb572a 100644 --- a/gdb/ada-lang.c +++ b/gdb/ada-lang.c @@ -185,6 +185,8 @@ static struct value *decode_packed_array (struct value *); static struct value *value_subscript_packed (struct value *, int, struct value **); +static void move_bits (gdb_byte *, int, const gdb_byte *, int, int); + static struct value *coerce_unspec_val_to_type (struct value *, struct type *); @@ -216,7 +218,7 @@ static struct value *ada_value_primitive_field (struct value *, int, int, struct type *); static int find_struct_field (char *, struct type *, int, - struct type **, int *, int *, int *); + struct type **, int *, int *, int *, int *); static struct value *ada_to_fixed_value_create (struct type *, CORE_ADDR, struct value *); @@ -235,6 +237,37 @@ static void ada_language_arch_info (struct gdbarch *, struct language_arch_info *); static void check_size (const struct type *); + +static struct value *ada_index_struct_field (int, struct value *, int, + struct type *); + +static struct value *assign_aggregate (struct value *, struct value *, + struct expression *, int *, enum noside); + +static void aggregate_assign_from_choices (struct value *, struct value *, + struct expression *, + int *, LONGEST *, int *, + int, LONGEST, LONGEST); + +static void aggregate_assign_positional (struct value *, struct value *, + struct expression *, + int *, LONGEST *, int *, int, + LONGEST, LONGEST); + + +static void aggregate_assign_others (struct value *, struct value *, + struct expression *, + int *, LONGEST *, int, LONGEST, LONGEST); + + +static void add_component_interval (LONGEST, LONGEST, LONGEST *, int *, int); + + +static struct value *ada_evaluate_subexp (struct type *, struct expression *, + int *, enum noside); + +static void ada_forward_operator_length (struct expression *, int, int *, + int *); @@ -1485,6 +1518,19 @@ ada_is_direct_array_type (struct type *type) || ada_is_array_descriptor_type (type)); } +/* Non-zero iff TYPE represents any kind of array in Ada, or a pointer + * to one. */ + +int +ada_is_array_type (struct type *type) +{ + while (type != NULL + && (TYPE_CODE (type) == TYPE_CODE_PTR + || TYPE_CODE (type) == TYPE_CODE_REF)) + type = TYPE_TARGET_TYPE (type); + return ada_is_direct_array_type (type); +} + /* Non-zero iff TYPE is a simple array type or pointer to one. */ int @@ -2099,11 +2145,17 @@ ada_value_assign (struct value *toval, struct value *fromval) struct type *type = value_type (toval); int bits = value_bitsize (toval); + toval = ada_coerce_ref (toval); + fromval = ada_coerce_ref (fromval); + + if (ada_is_direct_array_type (value_type (toval))) + toval = ada_coerce_to_simple_array (toval); + if (ada_is_direct_array_type (value_type (fromval))) + fromval = ada_coerce_to_simple_array (fromval); + if (!deprecated_value_modifiable (toval)) error (_("Left operand of assignment is not a modifiable lvalue.")); - toval = coerce_ref (toval); - if (VALUE_LVAL (toval) == lval_memory && bits > 0 && (TYPE_CODE (type) == TYPE_CODE_FLT @@ -2113,11 +2165,12 @@ ada_value_assign (struct value *toval, struct value *fromval) + bits + HOST_CHAR_BIT - 1) / HOST_CHAR_BIT; char *buffer = (char *) alloca (len); struct value *val; + CORE_ADDR to_addr = VALUE_ADDRESS (toval) + value_offset (toval); if (TYPE_CODE (type) == TYPE_CODE_FLT) fromval = value_cast (type, fromval); - read_memory (VALUE_ADDRESS (toval) + value_offset (toval), buffer, len); + read_memory (to_addr, buffer, len); if (BITS_BIG_ENDIAN) move_bits (buffer, value_bitpos (toval), value_contents (fromval), @@ -2126,9 +2179,10 @@ ada_value_assign (struct value *toval, struct value *fromval) else move_bits (buffer, value_bitpos (toval), value_contents (fromval), 0, bits); - write_memory (VALUE_ADDRESS (toval) + value_offset (toval), buffer, - len); - + write_memory (to_addr, buffer, len); + if (deprecated_memory_changed_hook) + deprecated_memory_changed_hook (to_addr, len); + val = value_copy (toval); memcpy (value_contents_raw (val), value_contents (fromval), TYPE_LENGTH (type)); @@ -2141,6 +2195,41 @@ ada_value_assign (struct value *toval, struct value *fromval) } +/* Given that COMPONENT is a memory lvalue that is part of the lvalue + * CONTAINER, assign the contents of VAL to COMPONENTS's place in + * CONTAINER. Modifies the VALUE_CONTENTS of CONTAINER only, not + * COMPONENT, and not the inferior's memory. The current contents + * of COMPONENT are ignored. */ +static void +value_assign_to_component (struct value *container, struct value *component, + struct value *val) +{ + LONGEST offset_in_container = + (LONGEST) (VALUE_ADDRESS (component) + value_offset (component) + - VALUE_ADDRESS (container) - value_offset (container)); + int bit_offset_in_container = + value_bitpos (component) - value_bitpos (container); + int bits; + + val = value_cast (value_type (component), val); + + if (value_bitsize (component) == 0) + bits = TARGET_CHAR_BIT * TYPE_LENGTH (value_type (component)); + else + bits = value_bitsize (component); + + if (BITS_BIG_ENDIAN) + move_bits (value_contents_writeable (container) + offset_in_container, + value_bitpos (container) + bit_offset_in_container, + value_contents (val), + TYPE_LENGTH (value_type (component)) * TARGET_CHAR_BIT - bits, + bits); + else + move_bits (value_contents_writeable (container) + offset_in_container, + value_bitpos (container) + bit_offset_in_container, + value_contents (val), 0, bits); +} + /* The value of the element of array ARR at the ARITY indices given in IND. ARR may be either a simple array, GNAT array descriptor, or pointer thereto. */ @@ -2522,12 +2611,14 @@ resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, enum exp_opcode op = (*expp)->elts[pc].opcode; struct value **argvec; /* Vector of operand types (alloca'ed). */ int nargs; /* Number of operands. */ + int oplen; argvec = NULL; nargs = 0; exp = *expp; - /* Pass one: resolve operands, saving their types and updating *pos. */ + /* Pass one: resolve operands, saving their types and updating *pos, + if needed. */ switch (op) { case OP_FUNCALL: @@ -2542,39 +2633,37 @@ resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, nargs = longest_to_int (exp->elts[pc + 1].longconst); break; - case UNOP_QUAL: - *pos += 3; - resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type); - break; - case UNOP_ADDR: *pos += 1; resolve_subexp (expp, pos, 0, NULL); break; - case OP_ATR_MODULUS: - *pos += 4; + case UNOP_QUAL: + *pos += 3; + resolve_subexp (expp, pos, 1, exp->elts[pc + 1].type); break; + case OP_ATR_MODULUS: case OP_ATR_SIZE: case OP_ATR_TAG: - *pos += 1; - nargs = 1; - break; - case OP_ATR_FIRST: case OP_ATR_LAST: case OP_ATR_LENGTH: case OP_ATR_POS: case OP_ATR_VAL: - *pos += 1; - nargs = 2; - break; - case OP_ATR_MIN: case OP_ATR_MAX: - *pos += 1; - nargs = 3; + case TERNOP_IN_RANGE: + case BINOP_IN_BOUNDS: + case UNOP_IN_RANGE: + case OP_AGGREGATE: + case OP_OTHERS: + case OP_CHOICES: + case OP_POSITIONAL: + case OP_DISCRETE_RANGE: + case OP_NAME: + ada_forward_operator_length (exp, pc, &oplen, &nargs); + *pos += oplen; break; case BINOP_ASSIGN: @@ -2591,7 +2680,6 @@ resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, } case UNOP_CAST: - case UNOP_IN_RANGE: *pos += 3; nargs = 1; break; @@ -2620,9 +2708,6 @@ resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, case BINOP_REPEAT: case BINOP_SUBSCRIPT: case BINOP_COMMA: - *pos += 1; - nargs = 2; - break; case UNOP_NEG: case UNOP_PLUS: @@ -2657,21 +2742,12 @@ resolve_subexp (struct expression **expp, int *pos, int deprocedure_p, nargs = 1; break; - case OP_STRING: - (*pos) += 3 - + BYTES_TO_EXP_ELEM (longest_to_int (exp->elts[pc + 1].longconst) - + 1); - break; - case TERNOP_SLICE: - case TERNOP_IN_RANGE: *pos += 1; nargs = 3; break; - case BINOP_IN_BOUNDS: - *pos += 3; - nargs = 2; + case OP_STRING: break; default: @@ -3555,6 +3631,7 @@ ada_simple_renamed_entity (struct symbol *sym) result[len] = '\000'; return result; } + /* Evaluation: Function Calls */ @@ -5158,7 +5235,7 @@ value_tag_from_contents_and_address (struct type *type, int tag_byte_offset, dummy1, dummy2; struct type *tag_type; if (find_struct_field ("_tag", type, 0, &tag_type, &tag_byte_offset, - &dummy1, &dummy2)) + NULL, NULL, NULL)) { const gdb_byte *valaddr1 = ((valaddr == NULL) ? NULL @@ -5527,25 +5604,41 @@ ada_value_primitive_field (struct value *arg1, int offset, int fieldno, return value_primitive_field (arg1, offset, fieldno, arg_type); } -/* Find field with name NAME in object of type TYPE. If found, return 1 - after setting *FIELD_TYPE_P to the field's type, *BYTE_OFFSET_P to - OFFSET + the byte offset of the field within an object of that type, - *BIT_OFFSET_P to the bit offset modulo byte size of the field, and - *BIT_SIZE_P to its size in bits if the field is packed, and 0 otherwise. - Looks inside wrappers for the field. Returns 0 if field not - found. */ +/* Find field with name NAME in object of type TYPE. If found, + set the following for each argument that is non-null: + - *FIELD_TYPE_P to the field's type; + - *BYTE_OFFSET_P to OFFSET + the byte offset of the field within + an object of that type; + - *BIT_OFFSET_P to the bit offset modulo byte size of the field; + - *BIT_SIZE_P to its size in bits if the field is packed, and + 0 otherwise; + If INDEX_P is non-null, increment *INDEX_P by the number of source-visible + fields up to but not including the desired field, or by the total + number of fields if not found. A NULL value of NAME never + matches; the function just counts visible fields in this case. + + Returns 1 if found, 0 otherwise. */ + static int find_struct_field (char *name, struct type *type, int offset, struct type **field_type_p, - int *byte_offset_p, int *bit_offset_p, int *bit_size_p) + int *byte_offset_p, int *bit_offset_p, int *bit_size_p, + int *index_p) { int i; type = ada_check_typedef (type); - *field_type_p = NULL; - *byte_offset_p = *bit_offset_p = *bit_size_p = 0; - for (i = TYPE_NFIELDS (type) - 1; i >= 0; i -= 1) + if (field_type_p != NULL) + *field_type_p = NULL; + if (byte_offset_p != NULL) + *byte_offset_p; + if (bit_offset_p != NULL) + *bit_offset_p = 0; + if (bit_size_p != NULL) + *bit_size_p = 0; + + for (i = 0; i < TYPE_NFIELDS (type); i += 1) { int bit_pos = TYPE_FIELD_BITPOS (type, i); int fld_offset = offset + bit_pos / 8; @@ -5554,42 +5647,60 @@ find_struct_field (char *name, struct type *type, int offset, if (t_field_name == NULL) continue; - else if (field_name_match (t_field_name, name)) + else if (name != NULL && field_name_match (t_field_name, name)) { int bit_size = TYPE_FIELD_BITSIZE (type, i); - *field_type_p = TYPE_FIELD_TYPE (type, i); - *byte_offset_p = fld_offset; - *bit_offset_p = bit_pos % 8; - *bit_size_p = bit_size; + if (field_type_p != NULL) + *field_type_p = TYPE_FIELD_TYPE (type, i); + if (byte_offset_p != NULL) + *byte_offset_p = fld_offset; + if (bit_offset_p != NULL) + *bit_offset_p = bit_pos % 8; + if (bit_size_p != NULL) + *bit_size_p = bit_size; return 1; } else if (ada_is_wrapper_field (type, i)) { - if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset, - field_type_p, byte_offset_p, bit_offset_p, - bit_size_p)) + if (find_struct_field (name, TYPE_FIELD_TYPE (type, i), fld_offset, + field_type_p, byte_offset_p, bit_offset_p, + bit_size_p, index_p)) return 1; } else if (ada_is_variant_part (type, i)) { + /* PNH: Wait. Do we ever execute this section, or is ARG always of + fixed type?? */ int j; - struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i)); + struct type *field_type + = ada_check_typedef (TYPE_FIELD_TYPE (type, i)); - for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1) + for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) { if (find_struct_field (name, TYPE_FIELD_TYPE (field_type, j), fld_offset + TYPE_FIELD_BITPOS (field_type, j) / 8, field_type_p, byte_offset_p, - bit_offset_p, bit_size_p)) + bit_offset_p, bit_size_p, index_p)) return 1; } } + else if (index_p != NULL) + *index_p += 1; } return 0; } +/* Number of user-visible fields in record type TYPE. */ +static int +num_visible_fields (struct type *type) +{ + int n; + n = 0; + find_struct_field (NULL, type, 0, NULL, NULL, NULL, NULL, &n); + return n; +} /* Look for a field NAME in ARG. Adjust the address of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE. @@ -5604,7 +5715,7 @@ ada_search_struct_field (char *name, struct value *arg, int offset, int i; type = ada_check_typedef (type); - for (i = TYPE_NFIELDS (type) - 1; i >= 0; i -= 1) + for (i = 0; i < TYPE_NFIELDS (type); i += 1) { char *t_field_name = TYPE_FIELD_NAME (type, i); @@ -5626,11 +5737,12 @@ ada_search_struct_field (char *name, struct value *arg, int offset, else if (ada_is_variant_part (type, i)) { + /* PNH: Do we ever get here? See find_struct_field. */ int j; struct type *field_type = ada_check_typedef (TYPE_FIELD_TYPE (type, i)); int var_offset = offset + TYPE_FIELD_BITPOS (type, i) / 8; - for (j = TYPE_NFIELDS (field_type) - 1; j >= 0; j -= 1) + for (j = 0; j < TYPE_NFIELDS (field_type); j += 1) { struct value *v = ada_search_struct_field /* Force line break. */ (name, arg, @@ -5644,6 +5756,62 @@ ada_search_struct_field (char *name, struct value *arg, int offset, return NULL; } +static struct value *ada_index_struct_field_1 (int *, struct value *, + int, struct type *); + + +/* Return field #INDEX in ARG, where the index is that returned by + * find_struct_field through its INDEX_P argument. Adjust the address + * of ARG by OFFSET bytes, and search in it assuming it has (class) type TYPE. + * If found, return value, else return NULL. */ + +static struct value * +ada_index_struct_field (int index, struct value *arg, int offset, + struct type *type) +{ + return ada_index_struct_field_1 (&index, arg, offset, type); +} + + +/* Auxiliary function for ada_index_struct_field. Like + * ada_index_struct_field, but takes index from *INDEX_P and modifies + * *INDEX_P. */ + +static struct value * +ada_index_struct_field_1 (int *index_p, struct value *arg, int offset, + struct type *type) +{ + int i; + type = ada_check_typedef (type); + + for (i = 0; i < TYPE_NFIELDS (type); i += 1) + { + if (TYPE_FIELD_NAME (type, i) == NULL) + continue; + else if (ada_is_wrapper_field (type, i)) + { + struct value *v = /* Do not let indent join lines here. */ + ada_index_struct_field_1 (index_p, arg, + offset + TYPE_FIELD_BITPOS (type, i) / 8, + TYPE_FIELD_TYPE (type, i)); + if (v != NULL) + return v; + } + + else if (ada_is_variant_part (type, i)) + { + /* PNH: Do we ever get here? See ada_search_struct_field, + find_struct_field. */ + error (_("Cannot assign this kind of variant record")); + } + else if (*index_p == 0) + return ada_value_primitive_field (arg, offset, i, type); + else + *index_p -= 1; + } + return NULL; +} + /* Given ARG, a value of type (pointer or reference to a)* structure/union, extract the component named NAME from the ultimate target structure/union and return it as a value with its @@ -5732,7 +5900,7 @@ ada_value_struct_elt (struct value *arg, char *name, char *err) t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL); if (find_struct_field (name, t1, 0, &field_type, &byte_offset, &bit_offset, - &bit_size)) + &bit_size, NULL)) { if (bit_size != 0) { @@ -7357,7 +7525,329 @@ ada_value_equal (struct value *arg1, struct value *arg2) return value_equal (arg1, arg2); } -struct value * +/* Total number of component associations in the aggregate starting at + index PC in EXP. Assumes that index PC is the start of an + OP_AGGREGATE. */ + +static int +num_component_specs (struct expression *exp, int pc) +{ + int n, m, i; + m = exp->elts[pc + 1].longconst; + pc += 3; + n = 0; + for (i = 0; i < m; i += 1) + { + switch (exp->elts[pc].opcode) + { + default: + n += 1; + break; + case OP_CHOICES: + n += exp->elts[pc + 1].longconst; + break; + } + ada_evaluate_subexp (NULL, exp, &pc, EVAL_SKIP); + } + return n; +} + +/* Assign the result of evaluating EXP starting at *POS to the INDEXth + component of LHS (a simple array or a record), updating *POS past + the expression, assuming that LHS is contained in CONTAINER. Does + not modify the inferior's memory, nor does it modify LHS (unless + LHS == CONTAINER). */ + +static void +assign_component (struct value *container, struct value *lhs, LONGEST index, + struct expression *exp, int *pos) +{ + struct value *mark = value_mark (); + struct value *elt; + if (TYPE_CODE (value_type (lhs)) == TYPE_CODE_ARRAY) + { + struct value *index_val = value_from_longest (builtin_type_int, index); + elt = unwrap_value (ada_value_subscript (lhs, 1, &index_val)); + } + else + { + elt = ada_index_struct_field (index, lhs, 0, value_type (lhs)); + elt = ada_to_fixed_value (unwrap_value (elt)); + } + + if (exp->elts[*pos].opcode == OP_AGGREGATE) + assign_aggregate (container, elt, exp, pos, EVAL_NORMAL); + else + value_assign_to_component (container, elt, + ada_evaluate_subexp (NULL, exp, pos, + EVAL_NORMAL)); + + value_free_to_mark (mark); +} + +/* Assuming that LHS represents an lvalue having a record or array + type, and EXP->ELTS[*POS] is an OP_AGGREGATE, evaluate an assignment + of that aggregate's value to LHS, advancing *POS past the + aggregate. NOSIDE is as for evaluate_subexp. CONTAINER is an + lvalue containing LHS (possibly LHS itself). Does not modify + the inferior's memory, nor does it modify the contents of + LHS (unless == CONTAINER). Returns the modified CONTAINER. */ + +static struct value * +assign_aggregate (struct value *container, + struct value *lhs, struct expression *exp, + int *pos, enum noside noside) +{ + struct type *lhs_type; + int n = exp->elts[*pos+1].longconst; + LONGEST low_index, high_index; + int num_specs; + LONGEST *indices; + int max_indices, num_indices; + int is_array_aggregate; + int i; + struct value *mark = value_mark (); + + *pos += 3; + if (noside != EVAL_NORMAL) + { + int i; + for (i = 0; i < n; i += 1) + ada_evaluate_subexp (NULL, exp, pos, noside); + return container; + } + + container = ada_coerce_ref (container); + if (ada_is_direct_array_type (value_type (container))) + container = ada_coerce_to_simple_array (container); + lhs = ada_coerce_ref (lhs); + if (!deprecated_value_modifiable (lhs)) + error (_("Left operand of assignment is not a modifiable lvalue.")); + + lhs_type = value_type (lhs); + if (ada_is_direct_array_type (lhs_type)) + { + lhs = ada_coerce_to_simple_array (lhs); + lhs_type = value_type (lhs); + low_index = TYPE_ARRAY_LOWER_BOUND_VALUE (lhs_type); + high_index = TYPE_ARRAY_UPPER_BOUND_VALUE (lhs_type); + is_array_aggregate = 1; + } + else if (TYPE_CODE (lhs_type) == TYPE_CODE_STRUCT) + { + low_index = 0; + high_index = num_visible_fields (lhs_type) - 1; + is_array_aggregate = 0; + } + else + error (_("Left-hand side must be array or record.")); + + num_specs = num_component_specs (exp, *pos - 3); + max_indices = 4 * num_specs + 4; + indices = alloca (max_indices * sizeof (indices[0])); + indices[0] = indices[1] = low_index - 1; + indices[2] = indices[3] = high_index + 1; + num_indices = 4; + + for (i = 0; i < n; i += 1) + { + switch (exp->elts[*pos].opcode) + { + case OP_CHOICES: + aggregate_assign_from_choices (container, lhs, exp, pos, indices, + &num_indices, max_indices, + low_index, high_index); + break; + case OP_POSITIONAL: + aggregate_assign_positional (container, lhs, exp, pos, indices, + &num_indices, max_indices, + low_index, high_index); + break; + case OP_OTHERS: + if (i != n-1) + error (_("Misplaced 'others' clause")); + aggregate_assign_others (container, lhs, exp, pos, indices, + num_indices, low_index, high_index); + break; + default: + error (_("Internal error: bad aggregate clause")); + } + } + + return container; +} + +/* Assign into the component of LHS indexed by the OP_POSITIONAL + construct at *POS, updating *POS past the construct, given that + the positions are relative to lower bound LOW, where HIGH is the + upper bound. Record the position in INDICES[0 .. MAX_INDICES-1] + updating *NUM_INDICES as needed. CONTAINER is as for + assign_aggregate. */ +static void +aggregate_assign_positional (struct value *container, + struct value *lhs, struct expression *exp, + int *pos, LONGEST *indices, int *num_indices, + int max_indices, LONGEST low, LONGEST high) +{ + LONGEST ind = longest_to_int (exp->elts[*pos + 1].longconst) + low; + + if (ind - 1 == high) + warning ("Extra components in aggregate ignored."); + if (ind <= high) + { + add_component_interval (ind, ind, indices, num_indices, max_indices); + *pos += 3; + assign_component (container, lhs, ind, exp, pos); + } + else + ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); +} + +/* Assign into the components of LHS indexed by the OP_CHOICES + construct at *POS, updating *POS past the construct, given that + the allowable indices are LOW..HIGH. Record the indices assigned + to in INDICES[0 .. MAX_INDICES-1], updating *NUM_INDICES as + needed. CONTAINER is as for assign_aggregate. */ +static void +aggregate_assign_from_choices (struct value *container, + struct value *lhs, struct expression *exp, + int *pos, LONGEST *indices, int *num_indices, + int max_indices, LONGEST low, LONGEST high) +{ + int j; + int n_choices = longest_to_int (exp->elts[*pos+1].longconst); + int choice_pos, expr_pc; + int is_array = ada_is_direct_array_type (value_type (lhs)); + + choice_pos = *pos += 3; + + for (j = 0; j < n_choices; j += 1) + ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); + expr_pc = *pos; + ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); + + for (j = 0; j < n_choices; j += 1) + { + LONGEST lower, upper; + enum exp_opcode op = exp->elts[choice_pos].opcode; + if (op == OP_DISCRETE_RANGE) + { + choice_pos += 1; + lower = value_as_long (ada_evaluate_subexp (NULL, exp, pos, + EVAL_NORMAL)); + upper = value_as_long (ada_evaluate_subexp (NULL, exp, pos, + EVAL_NORMAL)); + } + else if (is_array) + { + lower = value_as_long (ada_evaluate_subexp (NULL, exp, &choice_pos, + EVAL_NORMAL)); + upper = lower; + } + else + { + int ind; + char *name; + switch (op) + { + case OP_NAME: + name = &exp->elts[choice_pos + 2].string; + break; + case OP_VAR_VALUE: + name = SYMBOL_NATURAL_NAME (exp->elts[choice_pos + 2].symbol); + break; + default: + error (_("Invalid record component association.")); + } + ada_evaluate_subexp (NULL, exp, &choice_pos, EVAL_SKIP); + ind = 0; + if (! find_struct_field (name, value_type (lhs), 0, + NULL, NULL, NULL, NULL, &ind)) + error (_("Unknown component name: %s."), name); + lower = upper = ind; + } + + if (lower <= upper && (lower < low || upper > high)) + error (_("Index in component association out of bounds.")); + + add_component_interval (lower, upper, indices, num_indices, + max_indices); + while (lower <= upper) + { + int pos1; + pos1 = expr_pc; + assign_component (container, lhs, lower, exp, &pos1); + lower += 1; + } + } +} + +/* Assign the value of the expression in the OP_OTHERS construct in + EXP at *POS into the components of LHS indexed from LOW .. HIGH that + have not been previously assigned. The index intervals already assigned + are in INDICES[0 .. NUM_INDICES-1]. Updates *POS to after the + OP_OTHERS clause. CONTAINER is as for assign_aggregate*/ +static void +aggregate_assign_others (struct value *container, + struct value *lhs, struct expression *exp, + int *pos, LONGEST *indices, int num_indices, + LONGEST low, LONGEST high) +{ + int i; + int expr_pc = *pos+1; + + for (i = 0; i < num_indices - 2; i += 2) + { + LONGEST ind; + for (ind = indices[i + 1] + 1; ind < indices[i + 2]; ind += 1) + { + int pos; + pos = expr_pc; + assign_component (container, lhs, ind, exp, &pos); + } + } + ada_evaluate_subexp (NULL, exp, pos, EVAL_SKIP); +} + +/* Add the interval [LOW .. HIGH] to the sorted set of intervals + [ INDICES[0] .. INDICES[1] ],..., [ INDICES[*SIZE-2] .. INDICES[*SIZE-1] ], + modifying *SIZE as needed. It is an error if *SIZE exceeds + MAX_SIZE. The resulting intervals do not overlap. */ +static void +add_component_interval (LONGEST low, LONGEST high, + LONGEST* indices, int *size, int max_size) +{ + int i, j; + for (i = 0; i < *size; i += 2) { + if (high >= indices[i] && low <= indices[i + 1]) + { + int kh; + for (kh = i + 2; kh < *size; kh += 2) + if (high < indices[kh]) + break; + if (low < indices[i]) + indices[i] = low; + indices[i + 1] = indices[kh - 1]; + if (high > indices[i + 1]) + indices[i + 1] = high; + memcpy (indices + i + 2, indices + kh, *size - kh); + *size -= kh - i - 2; + return; + } + else if (high < indices[i]) + break; + } + + if (*size == max_size) + error (_("Internal error: miscounted aggregate components.")); + *size += 2; + for (j = *size-1; j >= i+2; j -= 1) + indices[j] = indices[j - 2]; + indices[i] = low; + indices[i + 1] = high; +} + +static struct value * ada_evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos, enum noside noside) { @@ -7366,7 +7856,7 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp, int pc; struct value *arg1 = NULL, *arg2 = NULL, *arg3; struct type *type; - int nargs; + int nargs, oplen; struct value **argvec; pc = *pos; @@ -7430,6 +7920,13 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp, case BINOP_ASSIGN: arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); + if (exp->elts[*pos].opcode == OP_AGGREGATE) + { + arg1 = assign_aggregate (arg1, arg1, exp, pos, noside); + if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) + return arg1; + return ada_value_assign (arg1, arg1); + } arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS) return arg1; @@ -7527,7 +8024,7 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp, else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN) /* Only encountered when an unresolved symbol occurs in a context other than a function call, in which case, it is - illegal. */ + invalid. */ error (_("Unexpected unresolved symbol, %s, during evaluation"), SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol)); else if (noside == EVAL_AVOID_SIDE_EFFECTS) @@ -8099,6 +8596,30 @@ always returns true")); return allocate_value (builtin_type_void); else error (_("Attempt to use a type name as an expression")); + + case OP_AGGREGATE: + case OP_CHOICES: + case OP_OTHERS: + case OP_DISCRETE_RANGE: + case OP_POSITIONAL: + case OP_NAME: + if (noside == EVAL_NORMAL) + switch (op) + { + case OP_NAME: + error (_("Undefined name, ambiguous name, or renaming used in " + "component association: %s."), &exp->elts[pc+2].string); + case OP_AGGREGATE: + error (_("Aggregates only allowed on the right of an assignment")); + default: + internal_error (__FILE__, __LINE__, "aggregate apparently mangled"); + } + + ada_forward_operator_length (exp, pc, &oplen, &nargs); + *pos += oplen - 1; + for (tem = 0; tem < nargs; tem += 1) + ada_evaluate_subexp (NULL, exp, pos, noside); + goto nosideret; } nosideret: @@ -8490,7 +9011,10 @@ ada_modulus (struct type * type) OP_DEFN (OP_ATR_TAG, 1, 1, 0) \ OP_DEFN (OP_ATR_VAL, 1, 2, 0) \ OP_DEFN (UNOP_QUAL, 3, 1, 0) \ - OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) + OP_DEFN (UNOP_IN_RANGE, 3, 1, 0) \ + OP_DEFN (OP_OTHERS, 1, 1, 0) \ + OP_DEFN (OP_POSITIONAL, 3, 1, 0) \ + OP_DEFN (OP_DISCRETE_RANGE, 1, 2, 0) static void ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp) @@ -8505,6 +9029,16 @@ ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp) case op: *oplenp = len; *argsp = args; break; ADA_OPERATORS; #undef OP_DEFN + + case OP_AGGREGATE: + *oplenp = 3; + *argsp = longest_to_int (exp->elts[pc - 2].longconst); + break; + + case OP_CHOICES: + *oplenp = 3; + *argsp = longest_to_int (exp->elts[pc - 2].longconst) + 1; + break; } } @@ -8515,15 +9049,23 @@ ada_op_name (enum exp_opcode opcode) { default: return op_name_standard (opcode); + #define OP_DEFN(op, len, args, binop) case op: return #op; ADA_OPERATORS; #undef OP_DEFN + + case OP_AGGREGATE: + return "OP_AGGREGATE"; + case OP_CHOICES: + return "OP_CHOICES"; + case OP_NAME: + return "OP_NAME"; } } /* As for operator_length, but assumes PC is pointing at the first element of the operator, and gives meaningful results only for the - Ada-specific operators. */ + Ada-specific operators, returning 0 for *OPLENP and *ARGSP otherwise. */ static void ada_forward_operator_length (struct expression *exp, int pc, @@ -8534,10 +9076,30 @@ ada_forward_operator_length (struct expression *exp, int pc, default: *oplenp = *argsp = 0; break; + #define OP_DEFN(op, len, args, binop) \ case op: *oplenp = len; *argsp = args; break; ADA_OPERATORS; #undef OP_DEFN + + case OP_AGGREGATE: + *oplenp = 3; + *argsp = longest_to_int (exp->elts[pc + 1].longconst); + break; + + case OP_CHOICES: + *oplenp = 3; + *argsp = longest_to_int (exp->elts[pc + 1].longconst) + 1; + break; + + case OP_STRING: + case OP_NAME: + { + int len = longest_to_int (exp->elts[pc + 1].longconst); + *oplenp = 4 + BYTES_TO_EXP_ELEM (len + 1); + *argsp = 0; + break; + } } } @@ -8577,11 +9139,28 @@ ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt) fprintf_filtered (stream, ")"); break; case BINOP_IN_BOUNDS: - fprintf_filtered (stream, " (%d)", (int) exp->elts[pc + 2].longconst); + fprintf_filtered (stream, " (%d)", + longest_to_int (exp->elts[pc + 2].longconst)); break; case TERNOP_IN_RANGE: break; + case OP_AGGREGATE: + case OP_OTHERS: + case OP_DISCRETE_RANGE: + case OP_POSITIONAL: + case OP_CHOICES: + break; + + case OP_NAME: + case OP_STRING: + { + char *name = &exp->elts[elt + 2].string; + int len = longest_to_int (exp->elts[elt + 1].longconst); + fprintf_filtered (stream, "Text: `%.*s'", len, name); + break; + } + default: return dump_subexp_body_standard (exp, stream, elt); } @@ -8599,26 +9178,26 @@ static void ada_print_subexp (struct expression *exp, int *pos, struct ui_file *stream, enum precedence prec) { - int oplen, nargs; + int oplen, nargs, i; int pc = *pos; enum exp_opcode op = exp->elts[pc].opcode; ada_forward_operator_length (exp, pc, &oplen, &nargs); + *pos += oplen; switch (op) { default: + *pos -= oplen; print_subexp_standard (exp, pos, stream, prec); return; case OP_VAR_VALUE: - *pos += oplen; fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream); return; case BINOP_IN_BOUNDS: /* XXX: sprint_subexp */ - *pos += oplen; print_subexp (exp, pos, stream, PREC_SUFFIX); fputs_filtered (" in ", stream); print_subexp (exp, pos, stream, PREC_SUFFIX); @@ -8629,7 +9208,6 @@ ada_print_subexp (struct expression *exp, int *pos, return; case TERNOP_IN_RANGE: - *pos += oplen; if (prec >= PREC_EQUAL) fputs_filtered ("(", stream); /* XXX: sprint_subexp */ @@ -8653,7 +9231,6 @@ ada_print_subexp (struct expression *exp, int *pos, case OP_ATR_SIZE: case OP_ATR_TAG: case OP_ATR_VAL: - *pos += oplen; if (exp->elts[*pos].opcode == OP_TYPE) { if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID) @@ -8676,7 +9253,6 @@ ada_print_subexp (struct expression *exp, int *pos, return; case UNOP_QUAL: - *pos += oplen; type_print (exp->elts[pc + 1].type, "", stream, 0); fputs_filtered ("'(", stream); print_subexp (exp, pos, stream, PREC_PREFIX); @@ -8684,12 +9260,48 @@ ada_print_subexp (struct expression *exp, int *pos, return; case UNOP_IN_RANGE: - *pos += oplen; /* XXX: sprint_subexp */ print_subexp (exp, pos, stream, PREC_SUFFIX); fputs_filtered (" in ", stream); LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0); return; + + case OP_DISCRETE_RANGE: + print_subexp (exp, pos, stream, PREC_SUFFIX); + fputs_filtered ("..", stream); + print_subexp (exp, pos, stream, PREC_SUFFIX); + return; + + case OP_OTHERS: + fputs_filtered ("others => ", stream); + print_subexp (exp, pos, stream, PREC_SUFFIX); + return; + + case OP_CHOICES: + for (i = 0; i < nargs-1; i += 1) + { + if (i > 0) + fputs_filtered ("|", stream); + print_subexp (exp, pos, stream, PREC_SUFFIX); + } + fputs_filtered (" => ", stream); + print_subexp (exp, pos, stream, PREC_SUFFIX); + return; + + case OP_POSITIONAL: + print_subexp (exp, pos, stream, PREC_SUFFIX); + return; + + case OP_AGGREGATE: + fputs_filtered ("(", stream); + for (i = 0; i < nargs; i += 1) + { + if (i > 0) + fputs_filtered (", ", stream); + print_subexp (exp, pos, stream, PREC_SUFFIX); + } + fputs_filtered (")", stream); + return; } } diff --git a/gdb/ada-lang.h b/gdb/ada-lang.h index 65c2e93..a2114a8 100644 --- a/gdb/ada-lang.h +++ b/gdb/ada-lang.h @@ -115,6 +115,54 @@ enum ada_operator type TYPE (typically a subrange). */ UNOP_IN_RANGE, + /* An aggregate. A single immediate operand, N>0, gives + the number of component specifications that follow. The + immediate operand is followed by a second OP_AGGREGATE. + Next come N component specifications. A component + specification is either an OP_OTHERS (others=>...), an + OP_CHOICES (for named associations), or other expression (for + positional aggregates only). Aggregates currently + occur only as the right sides of assignments. */ + OP_AGGREGATE, + + /* An others clause. Followed by a single expression. */ + OP_OTHERS, + + /* An aggregate component association. A single immediate operand, N, + gives the number of choices that follow. This is followed by a second + OP_CHOICES operator. Next come N operands, each of which is an + expression, an OP_DISCRETE_RANGE, or an OP_NAME---the latter + for a simple name that must be a record component name and does + not correspond to a single existing symbol. After the N choice + indicators comes an expression giving the value. + + In an aggregate such as (X => E1, ...), where X is a simple + name, X could syntactically be either a component_selector_name + or an expression used as a discrete_choice, depending on the + aggregate's type context. Since this is not known at parsing + time, we don't attempt to disambiguate X if it has multiple + definitions, but instead supply an OP_NAME. If X has a single + definition, we represent it with an OP_VAR_VALUE, even though + it may turn out to be within a record aggregate. Aggregate + evaluation can use either OP_NAMEs or OP_VAR_VALUEs to get a + record field name, and can evaluate OP_VAR_VALUE normally to + get its value as an expression. Unfortunately, we lose out in + cases where X has multiple meanings and is part of an array + aggregate. I hope these are not common enough to annoy users, + who can work around the problem in any case by putting + parentheses around X. */ + OP_CHOICES, + + /* A positional aggregate component association. The operator is + followed by a single integer indicating the position in the + aggregate (0-based), followed by a second OP_POSITIONAL. Next + follows a single expression giving the component value. */ + OP_POSITIONAL, + + /* A range of values. Followed by two expressions giving the + upper and lower bounds of the range. */ + OP_DISCRETE_RANGE, + /* End marker */ OP_ADA_LAST }; diff --git a/gdb/ada-lex.l b/gdb/ada-lex.l index cf6ea6c..f8746ec 100644 --- a/gdb/ada-lex.l +++ b/gdb/ada-lex.l @@ -50,9 +50,10 @@ POSEXP (e"+"?{NUM10}) /* Temporary staging for numeric literals. */ static char numbuf[NUMERAL_WIDTH]; static void canonicalizeNumeral (char *s1, const char *); +static struct stoken processString (const char*, int); static int processInt (const char *, const char *, const char *); static int processReal (const char *); -static int processId (const char *, int); +static struct stoken processId (const char *, int); static int processAttribute (const char *); static int find_dot_all (const char *); @@ -70,24 +71,13 @@ static int find_dot_all (const char *); lexptr += 1; \ } -static char *tempbuf = NULL; -static int tempbufsize = 0; -static int tempbuf_len; -static struct block *left_block_context; - -static void resize_tempbuf (unsigned int); - -static void block_lookup (char *, char *); - -static int name_lookup (char *, char *, int *, int); - static int find_dot_all (const char *); %} %option case-insensitive interactive nodefault -%s IN_STRING BEFORE_QUAL_QUOTE +%s BEFORE_QUAL_QUOTE %% @@ -155,37 +145,15 @@ static int find_dot_all (const char *); return CHARLIT; } -<INITIAL>\" { - tempbuf_len = 0; - BEGIN IN_STRING; - } - -<IN_STRING>{GRAPHIC}*\" { - resize_tempbuf (yyleng+tempbuf_len); - strncpy (tempbuf+tempbuf_len, yytext, yyleng-1); - tempbuf_len += yyleng-1; - yylval.sval.ptr = tempbuf; - yylval.sval.length = tempbuf_len; - BEGIN INITIAL; +\"({GRAPHIC}|"[\""({HEXDIG}{2}|\")"\"]")*\" { + yylval.sval = processString (yytext+1, yyleng-2); return STRING; } -<IN_STRING>{GRAPHIC}*"[\""{HEXDIG}{2}"\"]" { - int n; - resize_tempbuf (yyleng-5+tempbuf_len+1); - strncpy (tempbuf+tempbuf_len, yytext, yyleng-6); - sscanf(yytext+yyleng-4, "%2x", &n); - tempbuf[yyleng-6+tempbuf_len] = (char) n; - tempbuf_len += yyleng-5; +\" { + error ("ill-formed or non-terminated string literal"); } -<IN_STRING>{GRAPHIC}*"[\"\"\"]" { - int n; - resize_tempbuf (yyleng-4+tempbuf_len+1); - strncpy (tempbuf+tempbuf_len, yytext, yyleng-6); - tempbuf[yyleng-5+tempbuf_len] = '"'; - tempbuf_len += yyleng-4; - } if { while (*lexptr != 'i' && *lexptr != 'I') @@ -205,6 +173,7 @@ new { return NEW; } not { return NOT; } null { return NULL_PTR; } or { return OR; } +others { return OTHERS; } rem { return REM; } then { return THEN; } xor { return XOR; } @@ -254,62 +223,34 @@ xor { return XOR; } "."{WHITE}*all { return DOT_ALL; } "."{WHITE}*{ID} { - processId (yytext+1, yyleng-1); + yylval.sval = processId (yytext+1, yyleng-1); return DOT_ID; } {ID}({WHITE}*"."{WHITE}*({ID}|\"{OPER}\"))*(" "*"'")? { int all_posn = find_dot_all (yytext); - int token_type, segments, k; - int quote_follows; if (all_posn == -1 && yytext[yyleng-1] == '\'') { - quote_follows = 1; - do { - yyless (yyleng-1); - } while (yytext[yyleng-1] == ' '); + BEGIN BEFORE_QUAL_QUOTE; + yyless (yyleng-1); } - else - quote_follows = 0; - - if (all_posn >= 0) + else if (all_posn >= 0) yyless (all_posn); - processId(yytext, yyleng); - segments = name_lookup (ada_encode (yylval.ssym.stoken.ptr), - yylval.ssym.stoken.ptr, - &token_type, - MAX_RENAMING_CHAIN_LENGTH); - left_block_context = NULL; - for (k = yyleng; segments > 0 && k > 0; k -= 1) - { - if (yytext[k-1] == '.') - segments -= 1; - quote_follows = 0; - } - if (k <= 0) - error ("confused by name %s", yytext); - yyless (k); - if (quote_follows) - BEGIN BEFORE_QUAL_QUOTE; - return token_type; - } + yylval.sval = processId (yytext, yyleng); + return NAME; + } - /* GDB EXPRESSION CONSTRUCTS */ + /* GDB EXPRESSION CONSTRUCTS */ "'"[^']+"'"{WHITE}*:: { - processId(yytext, yyleng-2); - block_lookup (yylval.ssym.stoken.ptr, yylval.ssym.stoken.ptr); - return BLOCKNAME; + yyless (yyleng - 2); + yylval.sval = processId (yytext, yyleng); + return NAME; } -{ID}({WHITE}*"."{WHITE}*({ID}|\"{OPER}\"))*{WHITE}*:: { - processId(yytext, yyleng-2); - block_lookup (ada_encode (yylval.ssym.stoken.ptr), - yylval.ssym.stoken.ptr); - return BLOCKNAME; - } +"::" { return COLONCOLON; } [{}@] { return yytext[0]; } @@ -329,7 +270,8 @@ xor { return XOR; } #include <ctype.h> #include "gdb_string.h" -/* Initialize the lexer for processing new expression */ +/* Initialize the lexer for processing new expression. */ + void lexer_init (FILE *inp) { @@ -338,18 +280,6 @@ lexer_init (FILE *inp) } -/* Make sure that tempbuf points at an array at least N characters long. */ - -static void -resize_tempbuf (unsigned int n) -{ - if (tempbufsize < n) - { - tempbufsize = (n+63) & ~63; - tempbuf = xrealloc (tempbuf, tempbufsize); - } -} - /* Copy S2 to S1, removing all underscores, and downcasing all letters. */ static void @@ -392,6 +322,7 @@ digit_to_int (unsigned char c) } /* As for strtoul, but for ULONGEST results. */ + ULONGEST strtoulst (const char *num, const char **trailer, int base) { @@ -427,13 +358,12 @@ strtoulst (const char *num, const char **trailer, int base) return result + ((ULONGEST) high_part << HIGH_BYTE_POSN); } - - /* Interprets the prefix of NUM that consists of digits of the given BASE as an integer of that BASE, with the string EXP as an exponent. Puts value in yylval, and returns INT, if the string is valid. Causes an error if the number is improperly formated. BASE, if NULL, defaults - to "10", and EXP to "1". The EXP does not contain a leading 'e' or 'E'. */ + to "10", and EXP to "1". The EXP does not contain a leading 'e' or 'E'. + */ static int processInt (const char *base0, const char *num0, const char *exp0) @@ -532,11 +462,27 @@ processReal (const char *num0) return FLOAT; } -static int + +/* Store a canonicalized version of NAME0[0..LEN-1] in yylval.ssym. The + resulting string is valid until the next call to ada_parse. It differs + from NAME0 in that: + + Characters between '...' or <...> are transfered verbatim to + yylval.ssym. + + <, >, and trailing "'" characters in quoted sequences are removed + (a leading quote is preserved to indicate that the name is not to be + GNAT-encoded). + + Unquoted whitespace is removed. + + Unquoted alphabetic characters are mapped to lower case. + Result is returned as a struct stoken, but for convenience, the string + is also null-terminated. Result string valid until the next call of + ada_parse. + */ +static struct stoken processId (const char *name0, int len) { char *name = obstack_alloc (&temp_parse_space, len + 11); int i0, i; + struct stoken result; while (len > 0 && isspace (name0[len-1])) len -= 1; @@ -558,12 +504,12 @@ processId (const char *name0, int len) i0 += 1; break; case '\'': - i0 += 1; - while (i0 < len && name0[i0] != '\'') + do { name[i] = name0[i0]; i += 1; i0 += 1; } + while (i0 < len && name0[i0] != '\''); i0 += 1; break; case '<': @@ -579,259 +525,58 @@ processId (const char *name0, int len) } name[i] = '\000'; - yylval.ssym.sym = NULL; - yylval.ssym.stoken.ptr = name; - yylval.ssym.stoken.length = i; - return NAME; + result.ptr = name; + result.length = i; + return result; } -static void -block_lookup (char *name, char *err_name) -{ - struct ada_symbol_info *syms; - int nsyms; - struct symtab *symtab; - nsyms = ada_lookup_symbol_list (name, left_block_context, - VAR_DOMAIN, &syms); - if (left_block_context == NULL && - (nsyms == 0 || SYMBOL_CLASS (syms[0].sym) != LOC_BLOCK)) - symtab = lookup_symtab (name); - else - symtab = NULL; +/* Return TEXT[0..LEN-1], a string literal without surrounding quotes, + with special hex character notations replaced with characters. + Result valid until the next call to ada_parse. */ - if (symtab != NULL) - left_block_context = yylval.bval = - BLOCKVECTOR_BLOCK (BLOCKVECTOR (symtab), STATIC_BLOCK); - else if (nsyms == 0 || SYMBOL_CLASS (syms[0].sym) != LOC_BLOCK) - { - if (left_block_context == NULL) - error ("No file or function \"%s\".", err_name); - else - error ("No function \"%s\" in specified context.", err_name); - } - else - { - left_block_context = yylval.bval = SYMBOL_BLOCK_VALUE (syms[0].sym); - if (nsyms > 1) - warning ("Function name \"%s\" ambiguous here", err_name); - } -} - -/* Look up NAME0 (assumed to be encoded) as a name in VAR_DOMAIN, - setting *TOKEN_TYPE to NAME or TYPENAME, depending on what is - found. Try first the entire name, then the name without the last - segment (i.e., after the last .id), etc., and return the number of - segments that had to be removed to get a match. Try only the full - name if it starts with "standard__". Calls error if no - matches are found, using ERR_NAME in any error message. When - exactly one symbol match is found, it is placed in yylval. When - the symbol is a renaming, follow at most DEPTH steps to find the - ultimate definition; cause error if depth exceeded. */ - -static int -name_lookup (char *name0, char *err_name, int *token_type, int depth) +static struct stoken +processString (const char *text, int len) { - struct ada_symbol_info *syms; - struct type *type; - int len0 = strlen (name0); - char *name = obsavestring (name0, len0, &temp_parse_space); - int nsyms; - int segments; - - if (depth <= 0) - error ("Could not find renamed symbol \"%s\"", err_name); - - yylval.ssym.stoken.ptr = name; - yylval.ssym.stoken.length = strlen (name); - for (segments = 0; ; segments += 1) + const char *p; + char *q; + const char *lim = text + len; + struct stoken result; + + q = result.ptr = obstack_alloc (&temp_parse_space, len); + p = text; + while (p < lim) { - struct type *preferred_type; - int i, preferred_index; - - if (left_block_context == NULL) - nsyms = ada_lookup_symbol_list (name, expression_context_block, - VAR_DOMAIN, &syms); - else - nsyms = ada_lookup_symbol_list (name, left_block_context, - VAR_DOMAIN, &syms); - - - /* Check for a type renaming. */ - - if (nsyms == 1 && !ada_is_object_renaming (syms[0].sym)) - { - struct symbol *renaming_sym = - ada_find_renaming_symbol (SYMBOL_LINKAGE_NAME (syms[0].sym), - syms[0].block); - - if (renaming_sym != NULL) - syms[0].sym = renaming_sym; - } - - /* Check for a type definition. */ - - /* Look for a symbol that doesn't denote void. This is (I think) a */ - /* temporary kludge to get around problems in GNAT output. */ - preferred_index = -1; preferred_type = NULL; - for (i = 0; i < nsyms; i += 1) - switch (SYMBOL_CLASS (syms[i].sym)) - { - case LOC_TYPEDEF: - if (ada_prefer_type (SYMBOL_TYPE (syms[i].sym), preferred_type)) - { - preferred_index = i; - preferred_type = SYMBOL_TYPE (syms[i].sym); - } - break; - case LOC_REGISTER: - case LOC_ARG: - case LOC_REF_ARG: - case LOC_REGPARM: - case LOC_REGPARM_ADDR: - case LOC_LOCAL: - case LOC_LOCAL_ARG: - case LOC_BASEREG: - case LOC_BASEREG_ARG: - case LOC_COMPUTED: - case LOC_COMPUTED_ARG: - goto NotType; - default: - break; - } - if (preferred_type != NULL) - { - if (TYPE_CODE (preferred_type) == TYPE_CODE_VOID) - error ("`%s' matches only void type name(s)", - ada_decode (name)); - else if (ada_is_object_renaming (syms[preferred_index].sym)) - { - yylval.ssym.sym = syms[preferred_index].sym; - *token_type = OBJECT_RENAMING; - return segments; - } - else if (ada_renaming_type (SYMBOL_TYPE (syms[preferred_index].sym)) - != NULL) - { - int result; - char *renaming - = ada_simple_renamed_entity (syms[preferred_index].sym); - char *new_name - = (char *) obstack_alloc (&temp_parse_space, - strlen (renaming) + len0 - - yylval.ssym.stoken.length + 1); - strcpy (new_name, renaming); - xfree (renaming); - strcat (new_name, name0 + yylval.ssym.stoken.length); - result = name_lookup (new_name, err_name, token_type, depth - 1); - if (result > segments) - error ("Confused by renamed symbol."); - return result; - } - else if (segments == 0) - { - yylval.tval = preferred_type; - *token_type = TYPENAME; - return 0; - } - } - - if (segments == 0) - { - type = language_lookup_primitive_type_by_name (current_language, - current_gdbarch, - name); - if (type == NULL && strcmp ("system__address", name) == 0) - type = type_system_address (); - if (type != NULL) - { - /* First check to see if we have a regular definition of this - type that just didn't happen to have been read yet. */ - int ntypes; - struct symbol *sym; - char *expanded_name = - (char *) alloca (strlen (name) + sizeof ("standard__")); - strcpy (expanded_name, "standard__"); - strcat (expanded_name, name); - sym = ada_lookup_symbol (expanded_name, NULL, - VAR_DOMAIN, NULL, NULL); - if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF) - type = SYMBOL_TYPE (sym); - - yylval.tval = type; - *token_type = TYPENAME; - return 0; - } - } - - NotType: - if (nsyms == 1) - { - *token_type = NAME; - yylval.ssym.sym = syms[0].sym; - yylval.ssym.msym = NULL; - yylval.ssym.block = syms[0].block; - return segments; - } - else if (nsyms == 0) { - int i; - yylval.ssym.msym = ada_lookup_simple_minsym (name); - if (yylval.ssym.msym != NULL) - { - yylval.ssym.sym = NULL; - yylval.ssym.block = NULL; - *token_type = NAME; - return segments; - } - - if (segments == 0 - && strncmp (name, "standard__", sizeof ("standard__") - 1) == 0) - error ("No definition of \"%s\" found.", err_name); - - for (i = yylval.ssym.stoken.length - 1; i > 0; i -= 1) - { - if (name[i] == '.') - { - name[i] = '\0'; - yylval.ssym.stoken.length = i; - break; - } - else if (name[i] == '_' && name[i-1] == '_') - { - i -= 1; - name[i] = '\0'; - yylval.ssym.stoken.length = i; - break; - } - } - if (i <= 0) - { - if (!have_full_symbols () && !have_partial_symbols () - && left_block_context == NULL) - error ("No symbol table is loaded. Use the \"file\" command."); - if (left_block_context == NULL) - error ("No definition of \"%s\" in current context.", - err_name); - else - error ("No definition of \"%s\" in specified context.", - err_name); - } - } - else - { - *token_type = NAME; - yylval.ssym.sym = NULL; - yylval.ssym.msym = NULL; - if (left_block_context == NULL) - yylval.ssym.block = expression_context_block; - else - yylval.ssym.block = left_block_context; - return segments; - } - } + if (p[0] == '[' && p[1] == '"' && p+2 < lim) + { + if (p[2] == '"') /* "...["""]... */ + { + *q = '"'; + p += 4; + } + else + { + int chr; + sscanf (p+2, "%2x", &chr); + *q = (char) chr; + p += 5; + } + } + else + *q = *p; + q += 1; + p += 1; + } + result.length = q - result.ptr; + return result; } /* Returns the position within STR of the '.' in a - '.{WHITE}*all' component of a dotted name, or -1 if there is none. */ + '.{WHITE}*all' component of a dotted name, or -1 if there is none. + Note: we actually don't need this routine, since 'all' can never be an + Ada identifier. Thus, looking up foo.all or foo.all.x as a name + must fail, and will eventually be interpreted as (foo).all or + (foo).all.x. However, this does avoid an extraneous lookup. */ + static int find_dot_all (const char *str) { @@ -844,7 +589,7 @@ find_dot_all (const char *str) do i += 1; while (isspace (str[i])); - if (strcmp (str+i, "all") == 0 + if (strncmp (str+i, "all", 3) == 0 && ! isalnum (str[i+3]) && str[i+3] != '_') return i0; } |