gdb/ada-exp.y

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