gdb/ada-exp.y

   1 /* YACC parser for Ada expressions, for GDB.
   2    Copyright (C) 1986-2013 Free Software Foundation, Inc.
   3
   4    This file is part of GDB.
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published by
   8    the Free Software Foundation; either version 3 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  18
  19 /* Parse an Ada expression from text in a string,
  20    and return the result as a  struct expression  pointer.
  21    That structure contains arithmetic operations in reverse polish,
  22    with constants represented by operations that are followed by special data.
  23    See expression.h for the details of the format.
  24    What is important here is that it can be built up sequentially
  25    during the process of parsing; the lower levels of the tree always
  26    come first in the result.
  27
  28    malloc's and realloc's in this file are transformed to
  29    xmalloc and xrealloc respectively by the same sed command in the
  30    makefile that remaps any other malloc/realloc inserted by the parser
  31    generator.  Doing this with #defines and trying to control the interaction
  32    with include files (<malloc.h> and <stdlib.h> for example) just became
  33    too messy, particularly when such includes can be inserted at random
  34    times by the parser generator.  */
  35
  36 %{
  37
  38 #include "defs.h"
  39 #include "gdb_string.h"
  40 #include <ctype.h>
  41 #include "expression.h"
  42 #include "value.h"
  43 #include "parser-defs.h"
  44 #include "language.h"
  45 #include "ada-lang.h"
  46 #include "bfd.h" /* Required by objfiles.h.  */
  47 #include "symfile.h" /* Required by objfiles.h.  */
  48 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  49 #include "frame.h"
  50 #include "block.h"
  51
  52 #define parse_type builtin_type (parse_gdbarch)
  53
  54 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
  55    as well as gratuitiously global symbol names, so we can have multiple
  56    yacc generated parsers in gdb.  These are only the variables
  57    produced by yacc.  If other parser generators (bison, byacc, etc) produce
  58    additional global names that conflict at link time, then those parser
  59    generators need to be fixed instead of adding those names to this list.  */
  60
  61 /* NOTE: This is clumsy, especially since BISON and FLEX provide --prefix
  62    options.  I presume we are maintaining it to accommodate systems
  63    without BISON?  (PNH) */
  64
  65 #define yymaxdepth ada_maxdepth
  66 #define yyparse _ada_parse      /* ada_parse calls this after  initialization */
  67 #define yylex   ada_lex
  68 #define yyerror ada_error
  69 #define yylval  ada_lval
  70 #define yychar  ada_char
  71 #define yydebug ada_debug
  72 #define yypact  ada_pact
  73 #define yyr1    ada_r1
  74 #define yyr2    ada_r2
  75 #define yydef   ada_def
  76 #define yychk   ada_chk
  77 #define yypgo   ada_pgo
  78 #define yyact   ada_act
  79 #define yyexca  ada_exca
  80 #define yyerrflag ada_errflag
  81 #define yynerrs ada_nerrs
  82 #define yyps    ada_ps
  83 #define yypv    ada_pv
  84 #define yys     ada_s
  85 #define yy_yys  ada_yys
  86 #define yystate ada_state
  87 #define yytmp   ada_tmp
  88 #define yyv     ada_v
  89 #define yy_yyv  ada_yyv
  90 #define yyval   ada_val
  91 #define yylloc  ada_lloc
  92 #define yyreds  ada_reds                /* With YYDEBUG defined */
  93 #define yytoks  ada_toks                /* With YYDEBUG defined */
  94 #define yyname  ada_name                /* With YYDEBUG defined */
  95 #define yyrule  ada_rule                /* With YYDEBUG defined */
  96 #define yyss    ada_yyss
  97 #define yysslim ada_yysslim
  98 #define yyssp   ada_yyssp
  99 #define yystacksize ada_yystacksize
 100 #define yyvs    ada_yyvs
 101 #define yyvsp   ada_yyvsp
 102
 103 #ifndef YYDEBUG
 104 #define YYDEBUG 1               /* Default to yydebug support */
 105 #endif
 106
 107 #define YYFPRINTF parser_fprintf
 108
 109 struct name_info {
 110   struct symbol *sym;
 111   struct minimal_symbol *msym;
 112   struct block *block;
 113   struct stoken stoken;
 114 };
 115
 116 static struct stoken empty_stoken = { "", 0 };
 117
 118 /* If expression is in the context of TYPE'(...), then TYPE, else
 119  * NULL.  */
 120 static struct type *type_qualifier;
 121
 122 int yyparse (void);
 123
 124 static int yylex (void);
 125
 126 void yyerror (char *);
 127
 128 static void write_int (LONGEST, struct type *);
 129
 130 static void write_object_renaming (const struct block *, const char *, int,
 131                                    const char *, int);
 132
 133 static struct type* write_var_or_type (const struct block *, struct stoken);
 134
 135 static void write_name_assoc (struct stoken);
 136
 137 static void write_exp_op_with_string (enum exp_opcode, struct stoken);
 138
 139 static struct block *block_lookup (struct block *, const char *);
 140
 141 static LONGEST convert_char_literal (struct type *, LONGEST);
 142
 143 static void write_ambiguous_var (const struct block *, char *, int);
 144
 145 static struct type *type_int (void);
 146
 147 static struct type *type_long (void);
 148
 149 static struct type *type_long_long (void);
 150
 151 static struct type *type_float (void);
 152
 153 static struct type *type_double (void);
 154
 155 static struct type *type_long_double (void);
 156
 157 static struct type *type_char (void);
 158
 159 static struct type *type_boolean (void);
 160
 161 static struct type *type_system_address (void);
 162
 163 %}
 164
 165 %union
 166   {
 167     LONGEST lval;
 168     struct {
 169       LONGEST val;
 170       struct type *type;
 171     } typed_val;
 172     struct {
 173       DOUBLEST dval;
 174       struct type *type;
 175     } typed_val_float;
 176     struct type *tval;
 177     struct stoken sval;
 178     struct block *bval;
 179     struct internalvar *ivar;
 180   }
 181
 182 %type <lval> positional_list component_groups component_associations
 183 %type <lval> aggregate_component_list
 184 %type <tval> var_or_type
 185
 186 %token <typed_val> INT NULL_PTR CHARLIT
 187 %token <typed_val_float> FLOAT
 188 %token TRUEKEYWORD FALSEKEYWORD
 189 %token COLONCOLON
 190 %token <sval> STRING NAME DOT_ID
 191 %type <bval> block
 192 %type <lval> arglist tick_arglist
 193
 194 %type <tval> save_qualifier
 195
 196 %token DOT_ALL
 197
 198 /* Special type cases, put in to allow the parser to distinguish different
 199    legal basetypes.  */
 200 %token <sval> SPECIAL_VARIABLE
 201
 202 %nonassoc ASSIGN
 203 %left _AND_ OR XOR THEN ELSE
 204 %left '=' NOTEQUAL '<' '>' LEQ GEQ IN DOTDOT
 205 %left '@'
 206 %left '+' '-' '&'
 207 %left UNARY
 208 %left '*' '/' MOD REM
 209 %right STARSTAR ABS NOT
 210
 211 /* Artificial token to give NAME => ... and NAME | priority over reducing
 212    NAME to <primary> and to give <primary>' priority over reducing <primary>
 213    to <simple_exp>. */
 214 %nonassoc VAR
 215
 216 %nonassoc ARROW '|'
 217
 218 %right TICK_ACCESS TICK_ADDRESS TICK_FIRST TICK_LAST TICK_LENGTH
 219 %right TICK_MAX TICK_MIN TICK_MODULUS
 220 %right TICK_POS TICK_RANGE TICK_SIZE TICK_TAG TICK_VAL
 221  /* The following are right-associative only so that reductions at this
 222     precedence have lower precedence than '.' and '('.  The syntax still
 223     forces a.b.c, e.g., to be LEFT-associated.  */
 224 %right '.' '(' '[' DOT_ID DOT_ALL
 225
 226 %token NEW OTHERS
 227
 228 \f
 229 %%
 230
 231 start   :       exp1
 232         ;
 233
 234 /* Expressions, including the sequencing operator.  */
 235 exp1    :       exp
 236         |       exp1 ';' exp
 237                         { write_exp_elt_opcode (BINOP_COMMA); }
 238         |       primary ASSIGN exp   /* Extension for convenience */
 239                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 240         ;
 241
 242 /* Expressions, not including the sequencing operator.  */
 243 primary :       primary DOT_ALL
 244                         { write_exp_elt_opcode (UNOP_IND); }
 245         ;
 246
 247 primary :       primary DOT_ID
 248                         { write_exp_op_with_string (STRUCTOP_STRUCT, $2); }
 249         ;
 250
 251 primary :       primary '(' arglist ')'
 252                         {
 253                           write_exp_elt_opcode (OP_FUNCALL);
 254                           write_exp_elt_longcst ($3);
 255                           write_exp_elt_opcode (OP_FUNCALL);
 256                         }
 257         |       var_or_type '(' arglist ')'
 258                         {
 259                           if ($1 != NULL)
 260                             {
 261                               if ($3 != 1)
 262                                 error (_("Invalid conversion"));
 263                               write_exp_elt_opcode (UNOP_CAST);
 264                               write_exp_elt_type ($1);
 265                               write_exp_elt_opcode (UNOP_CAST);
 266                             }
 267                           else
 268                             {
 269                               write_exp_elt_opcode (OP_FUNCALL);
 270                               write_exp_elt_longcst ($3);
 271                               write_exp_elt_opcode (OP_FUNCALL);
 272                             }
 273                         }
 274         ;
 275
 276 primary :       var_or_type '\'' save_qualifier { type_qualifier = $1; }
 277                    '(' exp ')'
 278                         {
 279                           if ($1 == NULL)
 280                             error (_("Type required for qualification"));
 281                           write_exp_elt_opcode (UNOP_QUAL);
 282                           write_exp_elt_type ($1);
 283                           write_exp_elt_opcode (UNOP_QUAL);
 284                           type_qualifier = $3;
 285                         }
 286         ;
 287
 288 save_qualifier :        { $$ = type_qualifier; }
 289         ;
 290
 291 primary :
 292                 primary '(' simple_exp DOTDOT simple_exp ')'
 293                         { write_exp_elt_opcode (TERNOP_SLICE); }
 294         |       var_or_type '(' simple_exp DOTDOT simple_exp ')'
 295                         { if ($1 == NULL)
 296                             write_exp_elt_opcode (TERNOP_SLICE);
 297                           else
 298                             error (_("Cannot slice a type"));
 299                         }
 300         ;
 301
 302 primary :       '(' exp1 ')'    { }
 303         ;
 304
 305 /* The following rule causes a conflict with the type conversion
 306        var_or_type (exp)
 307    To get around it, we give '(' higher priority and add bridge rules for
 308        var_or_type (exp, exp, ...)
 309        var_or_type (exp .. exp)
 310    We also have the action for  var_or_type(exp) generate a function call
 311    when the first symbol does not denote a type. */
 312
 313 primary :       var_or_type     %prec VAR
 314                         { if ($1 != NULL)
 315                             {
 316                               write_exp_elt_opcode (OP_TYPE);
 317                               write_exp_elt_type ($1);
 318                               write_exp_elt_opcode (OP_TYPE);
 319                             }
 320                         }
 321         ;
 322
 323 primary :       SPECIAL_VARIABLE /* Various GDB extensions */
 324                         { write_dollar_variable ($1); }
 325         ;
 326
 327 primary :       aggregate
 328         ;
 329
 330 simple_exp :    primary
 331         ;
 332
 333 simple_exp :    '-' simple_exp    %prec UNARY
 334                         { write_exp_elt_opcode (UNOP_NEG); }
 335         ;
 336
 337 simple_exp :    '+' simple_exp    %prec UNARY
 338                         { write_exp_elt_opcode (UNOP_PLUS); }
 339         ;
 340
 341 simple_exp :    NOT simple_exp    %prec UNARY
 342                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 343         ;
 344
 345 simple_exp :    ABS simple_exp     %prec UNARY
 346                         { write_exp_elt_opcode (UNOP_ABS); }
 347         ;
 348
 349 arglist :               { $$ = 0; }
 350         ;
 351
 352 arglist :       exp
 353                         { $$ = 1; }
 354         |       NAME ARROW exp
 355                         { $$ = 1; }
 356         |       arglist ',' exp
 357                         { $$ = $1 + 1; }
 358         |       arglist ',' NAME ARROW exp
 359                         { $$ = $1 + 1; }
 360         ;
 361
 362 primary :       '{' var_or_type '}' primary  %prec '.'
 363                 /* GDB extension */
 364                         {
 365                           if ($2 == NULL)
 366                             error (_("Type required within braces in coercion"));
 367                           write_exp_elt_opcode (UNOP_MEMVAL);
 368                           write_exp_elt_type ($2);
 369                           write_exp_elt_opcode (UNOP_MEMVAL);
 370                         }
 371         ;
 372
 373 /* Binary operators in order of decreasing precedence.  */
 374
 375 simple_exp      :       simple_exp STARSTAR simple_exp
 376                         { write_exp_elt_opcode (BINOP_EXP); }
 377         ;
 378
 379 simple_exp      :       simple_exp '*' simple_exp
 380                         { write_exp_elt_opcode (BINOP_MUL); }
 381         ;
 382
 383 simple_exp      :       simple_exp '/' simple_exp
 384                         { write_exp_elt_opcode (BINOP_DIV); }
 385         ;
 386
 387 simple_exp      :       simple_exp REM simple_exp /* May need to be fixed to give correct Ada REM */
 388                         { write_exp_elt_opcode (BINOP_REM); }
 389         ;
 390
 391 simple_exp      :       simple_exp MOD simple_exp
 392                         { write_exp_elt_opcode (BINOP_MOD); }
 393         ;
 394
 395 simple_exp      :       simple_exp '@' simple_exp       /* GDB extension */
 396                         { write_exp_elt_opcode (BINOP_REPEAT); }
 397         ;
 398
 399 simple_exp      :       simple_exp '+' simple_exp
 400                         { write_exp_elt_opcode (BINOP_ADD); }
 401         ;
 402
 403 simple_exp      :       simple_exp '&' simple_exp
 404                         { write_exp_elt_opcode (BINOP_CONCAT); }
 405         ;
 406
 407 simple_exp      :       simple_exp '-' simple_exp
 408                         { write_exp_elt_opcode (BINOP_SUB); }
 409         ;
 410
 411 relation :      simple_exp
 412         ;
 413
 414 relation :      simple_exp '=' simple_exp
 415                         { write_exp_elt_opcode (BINOP_EQUAL); }
 416         ;
 417
 418 relation :      simple_exp NOTEQUAL simple_exp
 419                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 420         ;
 421
 422 relation :      simple_exp LEQ simple_exp
 423                         { write_exp_elt_opcode (BINOP_LEQ); }
 424         ;
 425
 426 relation :      simple_exp IN simple_exp DOTDOT simple_exp
 427                         { write_exp_elt_opcode (TERNOP_IN_RANGE); }
 428         |       simple_exp IN primary TICK_RANGE tick_arglist
 429                         { write_exp_elt_opcode (BINOP_IN_BOUNDS);
 430                           write_exp_elt_longcst ((LONGEST) $5);
 431                           write_exp_elt_opcode (BINOP_IN_BOUNDS);
 432                         }
 433         |       simple_exp IN var_or_type       %prec TICK_ACCESS
 434                         {
 435                           if ($3 == NULL)
 436                             error (_("Right operand of 'in' must be type"));
 437                           write_exp_elt_opcode (UNOP_IN_RANGE);
 438                           write_exp_elt_type ($3);
 439                           write_exp_elt_opcode (UNOP_IN_RANGE);
 440                         }
 441         |       simple_exp NOT IN simple_exp DOTDOT simple_exp
 442                         { write_exp_elt_opcode (TERNOP_IN_RANGE);
 443                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 444                         }
 445         |       simple_exp NOT IN primary TICK_RANGE tick_arglist
 446                         { write_exp_elt_opcode (BINOP_IN_BOUNDS);
 447                           write_exp_elt_longcst ((LONGEST) $6);
 448                           write_exp_elt_opcode (BINOP_IN_BOUNDS);
 449                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 450                         }
 451         |       simple_exp NOT IN var_or_type   %prec TICK_ACCESS
 452                         {
 453                           if ($4 == NULL)
 454                             error (_("Right operand of 'in' must be type"));
 455                           write_exp_elt_opcode (UNOP_IN_RANGE);
 456                           write_exp_elt_type ($4);
 457                           write_exp_elt_opcode (UNOP_IN_RANGE);
 458                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 459                         }
 460         ;
 461
 462 relation :      simple_exp GEQ simple_exp
 463                         { write_exp_elt_opcode (BINOP_GEQ); }
 464         ;
 465
 466 relation :      simple_exp '<' simple_exp
 467                         { write_exp_elt_opcode (BINOP_LESS); }
 468         ;
 469
 470 relation :      simple_exp '>' simple_exp
 471                         { write_exp_elt_opcode (BINOP_GTR); }
 472         ;
 473
 474 exp     :       relation
 475         |       and_exp
 476         |       and_then_exp
 477         |       or_exp
 478         |       or_else_exp
 479         |       xor_exp
 480         ;
 481
 482 and_exp :
 483                 relation _AND_ relation
 484                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 485         |       and_exp _AND_ relation
 486                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 487         ;
 488
 489 and_then_exp :
 490                relation _AND_ THEN relation
 491                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 492         |       and_then_exp _AND_ THEN relation
 493                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 494         ;
 495
 496 or_exp :
 497                 relation OR relation
 498                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 499         |       or_exp OR relation
 500                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 501         ;
 502
 503 or_else_exp :
 504                relation OR ELSE relation
 505                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 506         |      or_else_exp OR ELSE relation
 507                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 508         ;
 509
 510 xor_exp :       relation XOR relation
 511                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 512         |       xor_exp XOR relation
 513                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 514         ;
 515
 516 /* Primaries can denote types (OP_TYPE).  In cases such as
 517    primary TICK_ADDRESS, where a type would be invalid, it will be
 518    caught when evaluate_subexp in ada-lang.c tries to evaluate the
 519    primary, expecting a value.  Precedence rules resolve the ambiguity
 520    in NAME TICK_ACCESS in favor of shifting to form a var_or_type.  A
 521    construct such as aType'access'access will again cause an error when
 522    aType'access evaluates to a type that evaluate_subexp attempts to
 523    evaluate. */
 524 primary :       primary TICK_ACCESS
 525                         { write_exp_elt_opcode (UNOP_ADDR); }
 526         |       primary TICK_ADDRESS
 527                         { write_exp_elt_opcode (UNOP_ADDR);
 528                           write_exp_elt_opcode (UNOP_CAST);
 529                           write_exp_elt_type (type_system_address ());
 530                           write_exp_elt_opcode (UNOP_CAST);
 531                         }
 532         |       primary TICK_FIRST tick_arglist
 533                         { write_int ($3, type_int ());
 534                           write_exp_elt_opcode (OP_ATR_FIRST); }
 535         |       primary TICK_LAST tick_arglist
 536                         { write_int ($3, type_int ());
 537                           write_exp_elt_opcode (OP_ATR_LAST); }
 538         |       primary TICK_LENGTH tick_arglist
 539                         { write_int ($3, type_int ());
 540                           write_exp_elt_opcode (OP_ATR_LENGTH); }
 541         |       primary TICK_SIZE
 542                         { write_exp_elt_opcode (OP_ATR_SIZE); }
 543         |       primary TICK_TAG
 544                         { write_exp_elt_opcode (OP_ATR_TAG); }
 545         |       opt_type_prefix TICK_MIN '(' exp ',' exp ')'
 546                         { write_exp_elt_opcode (OP_ATR_MIN); }
 547         |       opt_type_prefix TICK_MAX '(' exp ',' exp ')'
 548                         { write_exp_elt_opcode (OP_ATR_MAX); }
 549         |       opt_type_prefix TICK_POS '(' exp ')'
 550                         { write_exp_elt_opcode (OP_ATR_POS); }
 551         |       type_prefix TICK_VAL '(' exp ')'
 552                         { write_exp_elt_opcode (OP_ATR_VAL); }
 553         |       type_prefix TICK_MODULUS
 554                         { write_exp_elt_opcode (OP_ATR_MODULUS); }
 555         ;
 556
 557 tick_arglist :                  %prec '('
 558                         { $$ = 1; }
 559         |       '(' INT ')'
 560                         { $$ = $2.val; }
 561         ;
 562
 563 type_prefix :
 564                 var_or_type
 565                         {
 566                           if ($1 == NULL)
 567                             error (_("Prefix must be type"));
 568                           write_exp_elt_opcode (OP_TYPE);
 569                           write_exp_elt_type ($1);
 570                           write_exp_elt_opcode (OP_TYPE); }
 571         ;
 572
 573 opt_type_prefix :
 574                 type_prefix
 575         |       /* EMPTY */
 576                         { write_exp_elt_opcode (OP_TYPE);
 577                           write_exp_elt_type (parse_type->builtin_void);
 578                           write_exp_elt_opcode (OP_TYPE); }
 579         ;
 580
 581
 582 primary :       INT
 583                         { write_int ((LONGEST) $1.val, $1.type); }
 584         ;
 585
 586 primary :       CHARLIT
 587                   { write_int (convert_char_literal (type_qualifier, $1.val),
 588                                (type_qualifier == NULL)
 589                                ? $1.type : type_qualifier);
 590                   }
 591         ;
 592
 593 primary :       FLOAT
 594                         { write_exp_elt_opcode (OP_DOUBLE);
 595                           write_exp_elt_type ($1.type);
 596                           write_exp_elt_dblcst ($1.dval);
 597                           write_exp_elt_opcode (OP_DOUBLE);
 598                         }
 599         ;
 600
 601 primary :       NULL_PTR
 602                         { write_int (0, type_int ()); }
 603         ;
 604
 605 primary :       STRING
 606                         {
 607                           write_exp_op_with_string (OP_STRING, $1);
 608                         }
 609         ;
 610
 611 primary :       TRUEKEYWORD
 612                         { write_int (1, type_boolean ()); }
 613         |       FALSEKEYWORD
 614                         { write_int (0, type_boolean ()); }
 615         ;
 616
 617 primary :       NEW NAME
 618                         { error (_("NEW not implemented.")); }
 619         ;
 620
 621 var_or_type:    NAME        %prec VAR
 622                                 { $$ = write_var_or_type (NULL, $1); }
 623         |       block NAME  %prec VAR
 624                                 { $$ = write_var_or_type ($1, $2); }
 625         |       NAME TICK_ACCESS
 626                         {
 627                           $$ = write_var_or_type (NULL, $1);
 628                           if ($$ == NULL)
 629                             write_exp_elt_opcode (UNOP_ADDR);
 630                           else
 631                             $$ = lookup_pointer_type ($$);
 632                         }
 633         |       block NAME TICK_ACCESS
 634                         {
 635                           $$ = write_var_or_type ($1, $2);
 636                           if ($$ == NULL)
 637                             write_exp_elt_opcode (UNOP_ADDR);
 638                           else
 639                             $$ = lookup_pointer_type ($$);
 640                         }
 641         ;
 642
 643 /* GDB extension */
 644 block   :       NAME COLONCOLON
 645                         { $$ = block_lookup (NULL, $1.ptr); }
 646         |       block NAME COLONCOLON
 647                         { $$ = block_lookup ($1, $2.ptr); }
 648         ;
 649
 650 aggregate :
 651                 '(' aggregate_component_list ')'
 652                         {
 653                           write_exp_elt_opcode (OP_AGGREGATE);
 654                           write_exp_elt_longcst ($2);
 655                           write_exp_elt_opcode (OP_AGGREGATE);
 656                         }
 657         ;
 658
 659 aggregate_component_list :
 660                 component_groups         { $$ = $1; }
 661         |       positional_list exp
 662                         { write_exp_elt_opcode (OP_POSITIONAL);
 663                           write_exp_elt_longcst ($1);
 664                           write_exp_elt_opcode (OP_POSITIONAL);
 665                           $$ = $1 + 1;
 666                         }
 667         |       positional_list component_groups
 668                                          { $$ = $1 + $2; }
 669         ;
 670
 671 positional_list :
 672                 exp ','
 673                         { write_exp_elt_opcode (OP_POSITIONAL);
 674                           write_exp_elt_longcst (0);
 675                           write_exp_elt_opcode (OP_POSITIONAL);
 676                           $$ = 1;
 677                         }
 678         |       positional_list exp ','
 679                         { write_exp_elt_opcode (OP_POSITIONAL);
 680                           write_exp_elt_longcst ($1);
 681                           write_exp_elt_opcode (OP_POSITIONAL);
 682                           $$ = $1 + 1;
 683                         }
 684         ;
 685
 686 component_groups:
 687                 others                   { $$ = 1; }
 688         |       component_group          { $$ = 1; }
 689         |       component_group ',' component_groups
 690                                          { $$ = $3 + 1; }
 691         ;
 692
 693 others  :       OTHERS ARROW exp
 694                         { write_exp_elt_opcode (OP_OTHERS); }
 695         ;
 696
 697 component_group :
 698                 component_associations
 699                         {
 700                           write_exp_elt_opcode (OP_CHOICES);
 701                           write_exp_elt_longcst ($1);
 702                           write_exp_elt_opcode (OP_CHOICES);
 703                         }
 704         ;
 705
 706 /* We use this somewhat obscure definition in order to handle NAME => and
 707    NAME | differently from exp => and exp |.  ARROW and '|' have a precedence
 708    above that of the reduction of NAME to var_or_type.  By delaying
 709    decisions until after the => or '|', we convert the ambiguity to a
 710    resolved shift/reduce conflict. */
 711 component_associations :
 712                 NAME ARROW
 713                         { write_name_assoc ($1); }
 714                     exp { $$ = 1; }
 715         |       simple_exp ARROW exp
 716                         { $$ = 1; }
 717         |       simple_exp DOTDOT simple_exp ARROW
 718                         { write_exp_elt_opcode (OP_DISCRETE_RANGE);
 719                           write_exp_op_with_string (OP_NAME, empty_stoken);
 720                         }
 721                     exp { $$ = 1; }
 722         |       NAME '|'
 723                         { write_name_assoc ($1); }
 724                     component_associations  { $$ = $4 + 1; }
 725         |       simple_exp '|'
 726                     component_associations  { $$ = $3 + 1; }
 727         |       simple_exp DOTDOT simple_exp '|'
 728                         { write_exp_elt_opcode (OP_DISCRETE_RANGE); }
 729                     component_associations  { $$ = $6 + 1; }
 730         ;
 731
 732 /* Some extensions borrowed from C, for the benefit of those who find they
 733    can't get used to Ada notation in GDB.  */
 734
 735 primary :       '*' primary             %prec '.'
 736                         { write_exp_elt_opcode (UNOP_IND); }
 737         |       '&' primary             %prec '.'
 738                         { write_exp_elt_opcode (UNOP_ADDR); }
 739         |       primary '[' exp ']'
 740                         { write_exp_elt_opcode (BINOP_SUBSCRIPT); }
 741         ;
 742
 743 %%
 744
 745 /* yylex defined in ada-lex.c: Reads one token, getting characters */
 746 /* through lexptr.  */
 747
 748 /* Remap normal flex interface names (yylex) as well as gratuitiously */
 749 /* global symbol names, so we can have multiple flex-generated parsers */
 750 /* in gdb.  */
 751
 752 /* (See note above on previous definitions for YACC.) */
 753
 754 #define yy_create_buffer ada_yy_create_buffer
 755 #define yy_delete_buffer ada_yy_delete_buffer
 756 #define yy_init_buffer ada_yy_init_buffer
 757 #define yy_load_buffer_state ada_yy_load_buffer_state
 758 #define yy_switch_to_buffer ada_yy_switch_to_buffer
 759 #define yyrestart ada_yyrestart
 760 #define yytext ada_yytext
 761 #define yywrap ada_yywrap
 762
 763 static struct obstack temp_parse_space;
 764
 765 /* The following kludge was found necessary to prevent conflicts between */
 766 /* defs.h and non-standard stdlib.h files.  */
 767 #define qsort __qsort__dummy
 768 #include "ada-lex.c"
 769
 770 int
 771 ada_parse (void)
 772 {
 773   lexer_init (yyin);            /* (Re-)initialize lexer.  */
 774   type_qualifier = NULL;
 775   obstack_free (&temp_parse_space, NULL);
 776   obstack_init (&temp_parse_space);
 777
 778   return _ada_parse ();
 779 }
 780
 781 void
 782 yyerror (char *msg)
 783 {
 784   error (_("Error in expression, near `%s'."), lexptr);
 785 }
 786
 787 /* Emit expression to access an instance of SYM, in block BLOCK (if
 788  * non-NULL), and with :: qualification ORIG_LEFT_CONTEXT.  */
 789 static void
 790 write_var_from_sym (const struct block *orig_left_context,
 791                     const struct block *block,
 792                     struct symbol *sym)
 793 {
 794   if (orig_left_context == NULL && symbol_read_needs_frame (sym))
 795     {
 796       if (innermost_block == 0
 797           || contained_in (block, innermost_block))
 798         innermost_block = block;
 799     }
 800
 801   write_exp_elt_opcode (OP_VAR_VALUE);
 802   write_exp_elt_block (block);
 803   write_exp_elt_sym (sym);
 804   write_exp_elt_opcode (OP_VAR_VALUE);
 805 }
 806
 807 /* Write integer or boolean constant ARG of type TYPE.  */
 808
 809 static void
 810 write_int (LONGEST arg, struct type *type)
 811 {
 812   write_exp_elt_opcode (OP_LONG);
 813   write_exp_elt_type (type);
 814   write_exp_elt_longcst (arg);
 815   write_exp_elt_opcode (OP_LONG);
 816 }
 817
 818 /* Write an OPCODE, string, OPCODE sequence to the current expression.  */
 819 static void
 820 write_exp_op_with_string (enum exp_opcode opcode, struct stoken token)
 821 {
 822   write_exp_elt_opcode (opcode);
 823   write_exp_string (token);
 824   write_exp_elt_opcode (opcode);
 825 }
 826
 827 /* Emit expression corresponding to the renamed object named
 828  * designated by RENAMED_ENTITY[0 .. RENAMED_ENTITY_LEN-1] in the
 829  * context of ORIG_LEFT_CONTEXT, to which is applied the operations
 830  * encoded by RENAMING_EXPR.  MAX_DEPTH is the maximum number of
 831  * cascaded renamings to allow.  If ORIG_LEFT_CONTEXT is null, it
 832  * defaults to the currently selected block. ORIG_SYMBOL is the
 833  * symbol that originally encoded the renaming.  It is needed only
 834  * because its prefix also qualifies any index variables used to index
 835  * or slice an array.  It should not be necessary once we go to the
 836  * new encoding entirely (FIXME pnh 7/20/2007).  */
 837
 838 static void
 839 write_object_renaming (const struct block *orig_left_context,
 840                        const char *renamed_entity, int renamed_entity_len,
 841                        const char *renaming_expr, int max_depth)
 842 {
 843   char *name;
 844   enum { SIMPLE_INDEX, LOWER_BOUND, UPPER_BOUND } slice_state;
 845   struct ada_symbol_info sym_info;
 846
 847   if (max_depth <= 0)
 848     error (_("Could not find renamed symbol"));
 849
 850   if (orig_left_context == NULL)
 851     orig_left_context = get_selected_block (NULL);
 852
 853   name = obstack_copy0 (&temp_parse_space, renamed_entity, renamed_entity_len);
 854   ada_lookup_encoded_symbol (name, orig_left_context, VAR_DOMAIN, &sym_info);
 855   if (sym_info.sym == NULL)
 856     error (_("Could not find renamed variable: %s"), ada_decode (name));
 857   else if (SYMBOL_CLASS (sym_info.sym) == LOC_TYPEDEF)
 858     /* We have a renaming of an old-style renaming symbol.  Don't
 859        trust the block information.  */
 860     sym_info.block = orig_left_context;
 861
 862   {
 863     const char *inner_renamed_entity;
 864     int inner_renamed_entity_len;
 865     const char *inner_renaming_expr;
 866
 867     switch (ada_parse_renaming (sym_info.sym, &inner_renamed_entity,
 868                                 &inner_renamed_entity_len,
 869                                 &inner_renaming_expr))
 870       {
 871       case ADA_NOT_RENAMING:
 872         write_var_from_sym (orig_left_context, sym_info.block, sym_info.sym);
 873         break;
 874       case ADA_OBJECT_RENAMING:
 875         write_object_renaming (sym_info.block,
 876                                inner_renamed_entity, inner_renamed_entity_len,
 877                                inner_renaming_expr, max_depth - 1);
 878         break;
 879       default:
 880         goto BadEncoding;
 881       }
 882   }
 883
 884   slice_state = SIMPLE_INDEX;
 885   while (*renaming_expr == 'X')
 886     {
 887       renaming_expr += 1;
 888
 889       switch (*renaming_expr) {
 890       case 'A':
 891         renaming_expr += 1;
 892         write_exp_elt_opcode (UNOP_IND);
 893         break;
 894       case 'L':
 895         slice_state = LOWER_BOUND;
 896         /* FALLTHROUGH */
 897       case 'S':
 898         renaming_expr += 1;
 899         if (isdigit (*renaming_expr))
 900           {
 901             char *next;
 902             long val = strtol (renaming_expr, &next, 10);
 903             if (next == renaming_expr)
 904               goto BadEncoding;
 905             renaming_expr = next;
 906             write_exp_elt_opcode (OP_LONG);
 907             write_exp_elt_type (type_int ());
 908             write_exp_elt_longcst ((LONGEST) val);
 909             write_exp_elt_opcode (OP_LONG);
 910           }
 911         else
 912           {
 913             const char *end;
 914             char *index_name;
 915             struct ada_symbol_info index_sym_info;
 916
 917             end = strchr (renaming_expr, 'X');
 918             if (end == NULL)
 919               end = renaming_expr + strlen (renaming_expr);
 920
 921             index_name =
 922               obstack_copy0 (&temp_parse_space, renaming_expr,
 923                              end - renaming_expr);
 924             renaming_expr = end;
 925
 926             ada_lookup_encoded_symbol (index_name, NULL, VAR_DOMAIN,
 927                                        &index_sym_info);
 928             if (index_sym_info.sym == NULL)
 929               error (_("Could not find %s"), index_name);
 930             else if (SYMBOL_CLASS (index_sym_info.sym) == LOC_TYPEDEF)
 931               /* Index is an old-style renaming symbol.  */
 932               index_sym_info.block = orig_left_context;
 933             write_var_from_sym (NULL, index_sym_info.block,
 934                                 index_sym_info.sym);
 935           }
 936         if (slice_state == SIMPLE_INDEX)
 937           {
 938             write_exp_elt_opcode (OP_FUNCALL);
 939             write_exp_elt_longcst ((LONGEST) 1);
 940             write_exp_elt_opcode (OP_FUNCALL);
 941           }
 942         else if (slice_state == LOWER_BOUND)
 943           slice_state = UPPER_BOUND;
 944         else if (slice_state == UPPER_BOUND)
 945           {
 946             write_exp_elt_opcode (TERNOP_SLICE);
 947             slice_state = SIMPLE_INDEX;
 948           }
 949         break;
 950
 951       case 'R':
 952         {
 953           struct stoken field_name;
 954           const char *end;
 955           char *buf;
 956
 957           renaming_expr += 1;
 958
 959           if (slice_state != SIMPLE_INDEX)
 960             goto BadEncoding;
 961           end = strchr (renaming_expr, 'X');
 962           if (end == NULL)
 963             end = renaming_expr + strlen (renaming_expr);
 964           field_name.length = end - renaming_expr;
 965           buf = malloc (end - renaming_expr + 1);
 966           field_name.ptr = buf;
 967           strncpy (buf, renaming_expr, end - renaming_expr);
 968           buf[end - renaming_expr] = '\000';
 969           renaming_expr = end;
 970           write_exp_op_with_string (STRUCTOP_STRUCT, field_name);
 971           break;
 972         }
 973
 974       default:
 975         goto BadEncoding;
 976       }
 977     }
 978   if (slice_state == SIMPLE_INDEX)
 979     return;
 980
 981  BadEncoding:
 982   error (_("Internal error in encoding of renaming declaration"));
 983 }
 984
 985 static struct block*
 986 block_lookup (struct block *context, const char *raw_name)
 987 {
 988   const char *name;
 989   struct ada_symbol_info *syms;
 990   int nsyms;
 991   struct symtab *symtab;
 992
 993   if (raw_name[0] == '\'')
 994     {
 995       raw_name += 1;
 996       name = raw_name;
 997     }
 998   else
 999     name = ada_encode (raw_name);
1000
1001   nsyms = ada_lookup_symbol_list (name, context, VAR_DOMAIN, &syms);
1002   if (context == NULL
1003       && (nsyms == 0 || SYMBOL_CLASS (syms[0].sym) != LOC_BLOCK))
1004     symtab = lookup_symtab (name);
1005   else
1006     symtab = NULL;
1007
1008   if (symtab != NULL)
1009     return BLOCKVECTOR_BLOCK (BLOCKVECTOR (symtab), STATIC_BLOCK);
1010   else if (nsyms == 0 || SYMBOL_CLASS (syms[0].sym) != LOC_BLOCK)
1011     {
1012       if (context == NULL)
1013         error (_("No file or function \"%s\"."), raw_name);
1014       else
1015         error (_("No function \"%s\" in specified context."), raw_name);
1016     }
1017   else
1018     {
1019       if (nsyms > 1)
1020         warning (_("Function name \"%s\" ambiguous here"), raw_name);
1021       return SYMBOL_BLOCK_VALUE (syms[0].sym);
1022     }
1023 }
1024
1025 static struct symbol*
1026 select_possible_type_sym (struct ada_symbol_info *syms, int nsyms)
1027 {
1028   int i;
1029   int preferred_index;
1030   struct type *preferred_type;
1031
1032   preferred_index = -1; preferred_type = NULL;
1033   for (i = 0; i < nsyms; i += 1)
1034     switch (SYMBOL_CLASS (syms[i].sym))
1035       {
1036       case LOC_TYPEDEF:
1037         if (ada_prefer_type (SYMBOL_TYPE (syms[i].sym), preferred_type))
1038           {
1039             preferred_index = i;
1040             preferred_type = SYMBOL_TYPE (syms[i].sym);
1041           }
1042         break;
1043       case LOC_REGISTER:
1044       case LOC_ARG:
1045       case LOC_REF_ARG:
1046       case LOC_REGPARM_ADDR:
1047       case LOC_LOCAL:
1048       case LOC_COMPUTED:
1049         return NULL;
1050       default:
1051         break;
1052       }
1053   if (preferred_type == NULL)
1054     return NULL;
1055   return syms[preferred_index].sym;
1056 }
1057
1058 static struct type*
1059 find_primitive_type (char *name)
1060 {
1061   struct type *type;
1062   type = language_lookup_primitive_type_by_name (parse_language,
1063                                                  parse_gdbarch,
1064                                                  name);
1065   if (type == NULL && strcmp ("system__address", name) == 0)
1066     type = type_system_address ();
1067
1068   if (type != NULL)
1069     {
1070       /* Check to see if we have a regular definition of this
1071          type that just didn't happen to have been read yet.  */
1072       struct symbol *sym;
1073       char *expanded_name =
1074         (char *) alloca (strlen (name) + sizeof ("standard__"));
1075       strcpy (expanded_name, "standard__");
1076       strcat (expanded_name, name);
1077       sym = ada_lookup_symbol (expanded_name, NULL, VAR_DOMAIN, NULL);
1078       if (sym != NULL && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1079         type = SYMBOL_TYPE (sym);
1080     }
1081
1082   return type;
1083 }
1084
1085 static int
1086 chop_selector (char *name, int end)
1087 {
1088   int i;
1089   for (i = end - 1; i > 0; i -= 1)
1090     if (name[i] == '.' || (name[i] == '_' && name[i+1] == '_'))
1091       return i;
1092   return -1;
1093 }
1094
1095 /* If NAME is a string beginning with a separator (either '__', or
1096    '.'), chop this separator and return the result; else, return
1097    NAME.  */
1098
1099 static char *
1100 chop_separator (char *name)
1101 {
1102   if (*name == '.')
1103    return name + 1;
1104
1105   if (name[0] == '_' && name[1] == '_')
1106     return name + 2;
1107
1108   return name;
1109 }
1110
1111 /* Given that SELS is a string of the form (<sep><identifier>)*, where
1112    <sep> is '__' or '.', write the indicated sequence of
1113    STRUCTOP_STRUCT expression operators. */
1114 static void
1115 write_selectors (char *sels)
1116 {
1117   while (*sels != '\0')
1118     {
1119       struct stoken field_name;
1120       char *p = chop_separator (sels);
1121       sels = p;
1122       while (*sels != '\0' && *sels != '.'
1123              && (sels[0] != '_' || sels[1] != '_'))
1124         sels += 1;
1125       field_name.length = sels - p;
1126       field_name.ptr = p;
1127       write_exp_op_with_string (STRUCTOP_STRUCT, field_name);
1128     }
1129 }
1130
1131 /* Write a variable access (OP_VAR_VALUE) to ambiguous encoded name
1132    NAME[0..LEN-1], in block context BLOCK, to be resolved later.  Writes
1133    a temporary symbol that is valid until the next call to ada_parse.
1134    */
1135 static void
1136 write_ambiguous_var (const struct block *block, char *name, int len)
1137 {
1138   struct symbol *sym =
1139     obstack_alloc (&temp_parse_space, sizeof (struct symbol));
1140   memset (sym, 0, sizeof (struct symbol));
1141   SYMBOL_DOMAIN (sym) = UNDEF_DOMAIN;
1142   SYMBOL_LINKAGE_NAME (sym) = obstack_copy0 (&temp_parse_space, name, len);
1143   SYMBOL_LANGUAGE (sym) = language_ada;
1144
1145   write_exp_elt_opcode (OP_VAR_VALUE);
1146   write_exp_elt_block (block);
1147   write_exp_elt_sym (sym);
1148   write_exp_elt_opcode (OP_VAR_VALUE);
1149 }
1150
1151 /* A convenient wrapper around ada_get_field_index that takes
1152    a non NUL-terminated FIELD_NAME0 and a FIELD_NAME_LEN instead
1153    of a NUL-terminated field name.  */
1154
1155 static int
1156 ada_nget_field_index (const struct type *type, const char *field_name0,
1157                       int field_name_len, int maybe_missing)
1158 {
1159   char *field_name = alloca ((field_name_len + 1) * sizeof (char));
1160
1161   strncpy (field_name, field_name0, field_name_len);
1162   field_name[field_name_len] = '\0';
1163   return ada_get_field_index (type, field_name, maybe_missing);
1164 }
1165
1166 /* If encoded_field_name is the name of a field inside symbol SYM,
1167    then return the type of that field.  Otherwise, return NULL.
1168
1169    This function is actually recursive, so if ENCODED_FIELD_NAME
1170    doesn't match one of the fields of our symbol, then try to see
1171    if ENCODED_FIELD_NAME could not be a succession of field names
1172    (in other words, the user entered an expression of the form
1173    TYPE_NAME.FIELD1.FIELD2.FIELD3), in which case we evaluate
1174    each field name sequentially to obtain the desired field type.
1175    In case of failure, we return NULL.  */
1176
1177 static struct type *
1178 get_symbol_field_type (struct symbol *sym, char *encoded_field_name)
1179 {
1180   char *field_name = encoded_field_name;
1181   char *subfield_name;
1182   struct type *type = SYMBOL_TYPE (sym);
1183   int fieldno;
1184
1185   if (type == NULL || field_name == NULL)
1186     return NULL;
1187   type = check_typedef (type);
1188
1189   while (field_name[0] != '\0')
1190     {
1191       field_name = chop_separator (field_name);
1192
1193       fieldno = ada_get_field_index (type, field_name, 1);
1194       if (fieldno >= 0)
1195         return TYPE_FIELD_TYPE (type, fieldno);
1196
1197       subfield_name = field_name;
1198       while (*subfield_name != '\0' && *subfield_name != '.'
1199              && (subfield_name[0] != '_' || subfield_name[1] != '_'))
1200         subfield_name += 1;
1201
1202       if (subfield_name[0] == '\0')
1203         return NULL;
1204
1205       fieldno = ada_nget_field_index (type, field_name,
1206                                       subfield_name - field_name, 1);
1207       if (fieldno < 0)
1208         return NULL;
1209
1210       type = TYPE_FIELD_TYPE (type, fieldno);
1211       field_name = subfield_name;
1212     }
1213
1214   return NULL;
1215 }
1216
1217 /* Look up NAME0 (an unencoded identifier or dotted name) in BLOCK (or
1218    expression_block_context if NULL).  If it denotes a type, return
1219    that type.  Otherwise, write expression code to evaluate it as an
1220    object and return NULL. In this second case, NAME0 will, in general,
1221    have the form <name>(.<selector_name>)*, where <name> is an object
1222    or renaming encoded in the debugging data.  Calls error if no
1223    prefix <name> matches a name in the debugging data (i.e., matches
1224    either a complete name or, as a wild-card match, the final
1225    identifier).  */
1226
1227 static struct type*
1228 write_var_or_type (const struct block *block, struct stoken name0)
1229 {
1230   int depth;
1231   char *encoded_name;
1232   int name_len;
1233
1234   if (block == NULL)
1235     block = expression_context_block;
1236
1237   encoded_name = ada_encode (name0.ptr);
1238   name_len = strlen (encoded_name);
1239   encoded_name = obstack_copy0 (&temp_parse_space, encoded_name, name_len);
1240   for (depth = 0; depth < MAX_RENAMING_CHAIN_LENGTH; depth += 1)
1241     {
1242       int tail_index;
1243
1244       tail_index = name_len;
1245       while (tail_index > 0)
1246         {
1247           int nsyms;
1248           struct ada_symbol_info *syms;
1249           struct symbol *type_sym;
1250           struct symbol *renaming_sym;
1251           const char* renaming;
1252           int renaming_len;
1253           const char* renaming_expr;
1254           int terminator = encoded_name[tail_index];
1255
1256           encoded_name[tail_index] = '\0';
1257           nsyms = ada_lookup_symbol_list (encoded_name, block,
1258                                           VAR_DOMAIN, &syms);
1259           encoded_name[tail_index] = terminator;
1260
1261           /* A single symbol may rename a package or object. */
1262
1263           /* This should go away when we move entirely to new version.
1264              FIXME pnh 7/20/2007. */
1265           if (nsyms == 1)
1266             {
1267               struct symbol *ren_sym =
1268                 ada_find_renaming_symbol (syms[0].sym, syms[0].block);
1269
1270               if (ren_sym != NULL)
1271                 syms[0].sym = ren_sym;
1272             }
1273
1274           type_sym = select_possible_type_sym (syms, nsyms);
1275
1276           if (type_sym != NULL)
1277             renaming_sym = type_sym;
1278           else if (nsyms == 1)
1279             renaming_sym = syms[0].sym;
1280           else
1281             renaming_sym = NULL;
1282
1283           switch (ada_parse_renaming (renaming_sym, &renaming,
1284                                       &renaming_len, &renaming_expr))
1285             {
1286             case ADA_NOT_RENAMING:
1287               break;
1288             case ADA_PACKAGE_RENAMING:
1289             case ADA_EXCEPTION_RENAMING:
1290             case ADA_SUBPROGRAM_RENAMING:
1291               {
1292                 char *new_name
1293                   = obstack_alloc (&temp_parse_space,
1294                                    renaming_len + name_len - tail_index + 1);
1295                 strncpy (new_name, renaming, renaming_len);
1296                 strcpy (new_name + renaming_len, encoded_name + tail_index);
1297                 encoded_name = new_name;
1298                 name_len = renaming_len + name_len - tail_index;
1299                 goto TryAfterRenaming;
1300               }
1301             case ADA_OBJECT_RENAMING:
1302               write_object_renaming (block, renaming, renaming_len,
1303                                      renaming_expr, MAX_RENAMING_CHAIN_LENGTH);
1304               write_selectors (encoded_name + tail_index);
1305               return NULL;
1306             default:
1307               internal_error (__FILE__, __LINE__,
1308                               _("impossible value from ada_parse_renaming"));
1309             }
1310
1311           if (type_sym != NULL)
1312             {
1313               struct type *field_type;
1314
1315               if (tail_index == name_len)
1316                 return SYMBOL_TYPE (type_sym);
1317
1318               /* We have some extraneous characters after the type name.
1319                  If this is an expression "TYPE_NAME.FIELD0.[...].FIELDN",
1320                  then try to get the type of FIELDN.  */
1321               field_type
1322                 = get_symbol_field_type (type_sym, encoded_name + tail_index);
1323               if (field_type != NULL)
1324                 return field_type;
1325               else
1326                 error (_("Invalid attempt to select from type: \"%s\"."),
1327                        name0.ptr);
1328             }
1329           else if (tail_index == name_len && nsyms == 0)
1330             {
1331               struct type *type = find_primitive_type (encoded_name);
1332
1333               if (type != NULL)
1334                 return type;
1335             }
1336
1337           if (nsyms == 1)
1338             {
1339               write_var_from_sym (block, syms[0].block, syms[0].sym);
1340               write_selectors (encoded_name + tail_index);
1341               return NULL;
1342             }
1343           else if (nsyms == 0)
1344             {
1345               struct bound_minimal_symbol msym
1346                 = ada_lookup_simple_minsym (encoded_name);
1347               if (msym.minsym != NULL)
1348                 {
1349                   write_exp_msymbol (msym);
1350                   /* Maybe cause error here rather than later? FIXME? */
1351                   write_selectors (encoded_name + tail_index);
1352                   return NULL;
1353                 }
1354
1355               if (tail_index == name_len
1356                   && strncmp (encoded_name, "standard__",
1357                               sizeof ("standard__") - 1) == 0)
1358                 error (_("No definition of \"%s\" found."), name0.ptr);
1359
1360               tail_index = chop_selector (encoded_name, tail_index);
1361             }
1362           else
1363             {
1364               write_ambiguous_var (block, encoded_name, tail_index);
1365               write_selectors (encoded_name + tail_index);
1366               return NULL;
1367             }
1368         }
1369
1370       if (!have_full_symbols () && !have_partial_symbols () && block == NULL)
1371         error (_("No symbol table is loaded.  Use the \"file\" command."));
1372       if (block == expression_context_block)
1373         error (_("No definition of \"%s\" in current context."), name0.ptr);
1374       else
1375         error (_("No definition of \"%s\" in specified context."), name0.ptr);
1376
1377     TryAfterRenaming: ;
1378     }
1379
1380   error (_("Could not find renamed symbol \"%s\""), name0.ptr);
1381
1382 }
1383
1384 /* Write a left side of a component association (e.g., NAME in NAME =>
1385    exp).  If NAME has the form of a selected component, write it as an
1386    ordinary expression.  If it is a simple variable that unambiguously
1387    corresponds to exactly one symbol that does not denote a type or an
1388    object renaming, also write it normally as an OP_VAR_VALUE.
1389    Otherwise, write it as an OP_NAME.
1390
1391    Unfortunately, we don't know at this point whether NAME is supposed
1392    to denote a record component name or the value of an array index.
1393    Therefore, it is not appropriate to disambiguate an ambiguous name
1394    as we normally would, nor to replace a renaming with its referent.
1395    As a result, in the (one hopes) rare case that one writes an
1396    aggregate such as (R => 42) where R renames an object or is an
1397    ambiguous name, one must write instead ((R) => 42). */
1398
1399 static void
1400 write_name_assoc (struct stoken name)
1401 {
1402   if (strchr (name.ptr, '.') == NULL)
1403     {
1404       struct ada_symbol_info *syms;
1405       int nsyms = ada_lookup_symbol_list (name.ptr, expression_context_block,
1406                                           VAR_DOMAIN, &syms);
1407       if (nsyms != 1 || SYMBOL_CLASS (syms[0].sym) == LOC_TYPEDEF)
1408         write_exp_op_with_string (OP_NAME, name);
1409       else
1410         write_var_from_sym (NULL, syms[0].block, syms[0].sym);
1411     }
1412   else
1413     if (write_var_or_type (NULL, name) != NULL)
1414       error (_("Invalid use of type."));
1415 }
1416
1417 /* Convert the character literal whose ASCII value would be VAL to the
1418    appropriate value of type TYPE, if there is a translation.
1419    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
1420    the literal 'A' (VAL == 65), returns 0.  */
1421
1422 static LONGEST
1423 convert_char_literal (struct type *type, LONGEST val)
1424 {
1425   char name[7];
1426   int f;
1427
1428   if (type == NULL)
1429     return val;
1430   type = check_typedef (type);
1431   if (TYPE_CODE (type) != TYPE_CODE_ENUM)
1432     return val;
1433
1434   xsnprintf (name, sizeof (name), "QU%02x", (int) val);
1435   for (f = 0; f < TYPE_NFIELDS (type); f += 1)
1436     {
1437       if (strcmp (name, TYPE_FIELD_NAME (type, f)) == 0)
1438         return TYPE_FIELD_ENUMVAL (type, f);
1439     }
1440   return val;
1441 }
1442
1443 static struct type *
1444 type_int (void)
1445 {
1446   return parse_type->builtin_int;
1447 }
1448
1449 static struct type *
1450 type_long (void)
1451 {
1452   return parse_type->builtin_long;
1453 }
1454
1455 static struct type *
1456 type_long_long (void)
1457 {
1458   return parse_type->builtin_long_long;
1459 }
1460
1461 static struct type *
1462 type_float (void)
1463 {
1464   return parse_type->builtin_float;
1465 }
1466
1467 static struct type *
1468 type_double (void)
1469 {
1470   return parse_type->builtin_double;
1471 }
1472
1473 static struct type *
1474 type_long_double (void)
1475 {
1476   return parse_type->builtin_long_double;
1477 }
1478
1479 static struct type *
1480 type_char (void)
1481 {
1482   return language_string_char_type (parse_language, parse_gdbarch);
1483 }
1484
1485 static struct type *
1486 type_boolean (void)
1487 {
1488   return parse_type->builtin_bool;
1489 }
1490
1491 static struct type *
1492 type_system_address (void)
1493 {
1494   struct type *type
1495     = language_lookup_primitive_type_by_name (parse_language,
1496                                               parse_gdbarch,
1497                                               "system__address");
1498   return  type != NULL ? type : parse_type->builtin_data_ptr;
1499 }
1500
1501 /* Provide a prototype to silence -Wmissing-prototypes.  */
1502 extern initialize_file_ftype _initialize_ada_exp;
1503
1504 void
1505 _initialize_ada_exp (void)
1506 {
1507   obstack_init (&temp_parse_space);
1508 }