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