gdb/ada-exp.y

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