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