gdb/ada-exp.y

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