gdb/ada-exp.y

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