gdb/ada-exp.y

   1 /* YACC parser for Ada expressions, for GDB.
   2    Copyright (C) 1986, 1989, 1990, 1991, 1993, 1994, 1997, 2000, 2003,
   3    2004 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 /* If expression is in the context of TYPE'(...), then TYPE, else
 112  * NULL.  */
 113 static struct type *type_qualifier;
 114
 115 int yyparse (void);
 116
 117 static int yylex (void);
 118
 119 void yyerror (char *);
 120
 121 static struct stoken string_to_operator (struct stoken);
 122
 123 static void write_int (LONGEST, struct type *);
 124
 125 static void write_object_renaming (struct block *, struct symbol *, int);
 126
 127 static void write_var_from_name (struct block *, struct name_info);
 128
 129 static LONGEST convert_char_literal (struct type *, LONGEST);
 130
 131 static struct type *type_int (void);
 132
 133 static struct type *type_long (void);
 134
 135 static struct type *type_long_long (void);
 136
 137 static struct type *type_float (void);
 138
 139 static struct type *type_double (void);
 140
 141 static struct type *type_long_double (void);
 142
 143 static struct type *type_char (void);
 144
 145 static struct type *type_system_address (void);
 146 %}
 147
 148 %union
 149   {
 150     LONGEST lval;
 151     struct {
 152       LONGEST val;
 153       struct type *type;
 154     } typed_val;
 155     struct {
 156       DOUBLEST dval;
 157       struct type *type;
 158     } typed_val_float;
 159     struct type *tval;
 160     struct stoken sval;
 161     struct name_info ssym;
 162     int voidval;
 163     struct block *bval;
 164     struct internalvar *ivar;
 165
 166   }
 167
 168 %type <voidval> exp exp1 simple_exp start variable
 169 %type <tval> type
 170
 171 %token <typed_val> INT NULL_PTR CHARLIT
 172 %token <typed_val_float> FLOAT
 173 %token <tval> TYPENAME
 174 %token <bval> BLOCKNAME
 175
 176 /* Both NAME and TYPENAME tokens represent symbols in the input,
 177    and both convey their data as strings.
 178    But a TYPENAME is a string that happens to be defined as a typedef
 179    or builtin type name (such as int or char)
 180    and a NAME is any other symbol.
 181    Contexts where this distinction is not important can use the
 182    nonterminal "name", which matches either NAME or TYPENAME.  */
 183
 184 %token <sval> STRING
 185 %token <ssym> NAME DOT_ID OBJECT_RENAMING
 186 %type <bval> block
 187 %type <lval> arglist tick_arglist
 188
 189 %type <tval> save_qualifier
 190
 191 %token DOT_ALL
 192
 193 /* Special type cases, put in to allow the parser to distinguish different
 194    legal basetypes.  */
 195 %token <sval> SPECIAL_VARIABLE
 196
 197 %nonassoc ASSIGN
 198 %left _AND_ OR XOR THEN ELSE
 199 %left '=' NOTEQUAL '<' '>' LEQ GEQ IN DOTDOT
 200 %left '@'
 201 %left '+' '-' '&'
 202 %left UNARY
 203 %left '*' '/' MOD REM
 204 %right STARSTAR ABS NOT
 205  /* The following are right-associative only so that reductions at this
 206     precedence have lower precedence than '.' and '('.  The syntax still
 207     forces a.b.c, e.g., to be LEFT-associated.  */
 208 %right TICK_ACCESS TICK_ADDRESS TICK_FIRST TICK_LAST TICK_LENGTH
 209 %right TICK_MAX TICK_MIN TICK_MODULUS
 210 %right TICK_POS TICK_RANGE TICK_SIZE TICK_TAG TICK_VAL
 211 %right '.' '(' '[' DOT_ID DOT_ALL
 212
 213 %token ARROW NEW
 214
 215 \f
 216 %%
 217
 218 start   :       exp1
 219         |       type    { write_exp_elt_opcode (OP_TYPE);
 220                           write_exp_elt_type ($1);
 221                           write_exp_elt_opcode (OP_TYPE); }
 222         ;
 223
 224 /* Expressions, including the sequencing operator.  */
 225 exp1    :       exp
 226         |       exp1 ';' exp
 227                         { write_exp_elt_opcode (BINOP_COMMA); }
 228         ;
 229
 230 /* Expressions, not including the sequencing operator.  */
 231 simple_exp :    simple_exp DOT_ALL
 232                         { write_exp_elt_opcode (UNOP_IND); }
 233         ;
 234
 235 simple_exp :    simple_exp DOT_ID
 236                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 237                           write_exp_string ($2.stoken);
 238                           write_exp_elt_opcode (STRUCTOP_STRUCT);
 239                           }
 240         ;
 241
 242 simple_exp :    simple_exp '(' arglist ')'
 243                         {
 244                           write_exp_elt_opcode (OP_FUNCALL);
 245                           write_exp_elt_longcst ($3);
 246                           write_exp_elt_opcode (OP_FUNCALL);
 247                         }
 248         ;
 249
 250 simple_exp :    type '(' exp ')'
 251                         {
 252                           write_exp_elt_opcode (UNOP_CAST);
 253                           write_exp_elt_type ($1);
 254                           write_exp_elt_opcode (UNOP_CAST);
 255                         }
 256         ;
 257
 258 simple_exp :    type '\'' save_qualifier { type_qualifier = $1; } '(' exp ')'
 259                         {
 260                           write_exp_elt_opcode (UNOP_QUAL);
 261                           write_exp_elt_type ($1);
 262                           write_exp_elt_opcode (UNOP_QUAL);
 263                           type_qualifier = $3;
 264                         }
 265         ;
 266
 267 save_qualifier :        { $$ = type_qualifier; }
 268         ;
 269
 270 simple_exp :
 271                 simple_exp '(' exp DOTDOT exp ')'
 272                         { write_exp_elt_opcode (TERNOP_SLICE); }
 273         ;
 274
 275 simple_exp :    '(' exp1 ')'    { }
 276         ;
 277
 278 simple_exp :    variable
 279         ;
 280
 281 simple_exp:     SPECIAL_VARIABLE /* Various GDB extensions */
 282                         { write_dollar_variable ($1); }
 283         ;
 284
 285 exp     :       simple_exp
 286         ;
 287
 288 exp     :       exp ASSIGN exp   /* Extension for convenience */
 289                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 290         ;
 291
 292 exp     :       '-' exp    %prec UNARY
 293                         { write_exp_elt_opcode (UNOP_NEG); }
 294         ;
 295
 296 exp     :       '+' exp    %prec UNARY
 297                         { write_exp_elt_opcode (UNOP_PLUS); }
 298         ;
 299
 300 exp     :       NOT exp    %prec UNARY
 301                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 302         ;
 303
 304 exp     :       ABS exp    %prec UNARY
 305                         { write_exp_elt_opcode (UNOP_ABS); }
 306         ;
 307
 308 arglist :               { $$ = 0; }
 309         ;
 310
 311 arglist :       exp
 312                         { $$ = 1; }
 313         |       any_name ARROW exp
 314                         { $$ = 1; }
 315         |       arglist ',' exp
 316                         { $$ = $1 + 1; }
 317         |       arglist ',' any_name ARROW exp
 318                         { $$ = $1 + 1; }
 319         ;
 320
 321 exp     :       '{' type '}' exp  %prec '.'
 322                 /* GDB extension */
 323                         { write_exp_elt_opcode (UNOP_MEMVAL);
 324                           write_exp_elt_type ($2);
 325                           write_exp_elt_opcode (UNOP_MEMVAL);
 326                         }
 327         ;
 328
 329 /* Binary operators in order of decreasing precedence.  */
 330
 331 exp     :       exp STARSTAR exp
 332                         { write_exp_elt_opcode (BINOP_EXP); }
 333         ;
 334
 335 exp     :       exp '*' exp
 336                         { write_exp_elt_opcode (BINOP_MUL); }
 337         ;
 338
 339 exp     :       exp '/' exp
 340                         { write_exp_elt_opcode (BINOP_DIV); }
 341         ;
 342
 343 exp     :       exp REM exp /* May need to be fixed to give correct Ada REM */
 344                         { write_exp_elt_opcode (BINOP_REM); }
 345         ;
 346
 347 exp     :       exp MOD exp
 348                         { write_exp_elt_opcode (BINOP_MOD); }
 349         ;
 350
 351 exp     :       exp '@' exp     /* GDB extension */
 352                         { write_exp_elt_opcode (BINOP_REPEAT); }
 353         ;
 354
 355 exp     :       exp '+' exp
 356                         { write_exp_elt_opcode (BINOP_ADD); }
 357         ;
 358
 359 exp     :       exp '&' exp
 360                         { write_exp_elt_opcode (BINOP_CONCAT); }
 361         ;
 362
 363 exp     :       exp '-' exp
 364                         { write_exp_elt_opcode (BINOP_SUB); }
 365         ;
 366
 367 exp     :       exp '=' exp
 368                         { write_exp_elt_opcode (BINOP_EQUAL); }
 369         ;
 370
 371 exp     :       exp NOTEQUAL exp
 372                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 373         ;
 374
 375 exp     :       exp LEQ exp
 376                         { write_exp_elt_opcode (BINOP_LEQ); }
 377         ;
 378
 379 exp     :       exp IN exp DOTDOT exp
 380                         { write_exp_elt_opcode (TERNOP_IN_RANGE); }
 381         |       exp IN exp TICK_RANGE tick_arglist
 382                         { write_exp_elt_opcode (BINOP_IN_BOUNDS);
 383                           write_exp_elt_longcst ((LONGEST) $5);
 384                           write_exp_elt_opcode (BINOP_IN_BOUNDS);
 385                         }
 386         |       exp IN TYPENAME         %prec TICK_ACCESS
 387                         { write_exp_elt_opcode (UNOP_IN_RANGE);
 388                           write_exp_elt_type ($3);
 389                           write_exp_elt_opcode (UNOP_IN_RANGE);
 390                         }
 391         |       exp NOT IN exp DOTDOT exp
 392                         { write_exp_elt_opcode (TERNOP_IN_RANGE);
 393                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 394                         }
 395         |       exp NOT IN exp TICK_RANGE tick_arglist
 396                         { write_exp_elt_opcode (BINOP_IN_BOUNDS);
 397                           write_exp_elt_longcst ((LONGEST) $6);
 398                           write_exp_elt_opcode (BINOP_IN_BOUNDS);
 399                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 400                         }
 401         |       exp NOT IN TYPENAME     %prec TICK_ACCESS
 402                         { write_exp_elt_opcode (UNOP_IN_RANGE);
 403                           write_exp_elt_type ($4);
 404                           write_exp_elt_opcode (UNOP_IN_RANGE);
 405                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 406                         }
 407         ;
 408
 409 exp     :       exp GEQ exp
 410                         { write_exp_elt_opcode (BINOP_GEQ); }
 411         ;
 412
 413 exp     :       exp '<' exp
 414                         { write_exp_elt_opcode (BINOP_LESS); }
 415         ;
 416
 417 exp     :       exp '>' exp
 418                         { write_exp_elt_opcode (BINOP_GTR); }
 419         ;
 420
 421 exp     :       exp _AND_ exp  /* Fix for Ada elementwise AND.  */
 422                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 423         ;
 424
 425 exp     :       exp _AND_ THEN exp      %prec _AND_
 426                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 427         ;
 428
 429 exp     :       exp OR exp     /* Fix for Ada elementwise OR */
 430                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 431         ;
 432
 433 exp     :       exp OR ELSE exp
 434                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 435         ;
 436
 437 exp     :       exp XOR exp    /* Fix for Ada elementwise XOR */
 438                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 439         ;
 440
 441 simple_exp :    simple_exp TICK_ACCESS
 442                         { write_exp_elt_opcode (UNOP_ADDR); }
 443         |       simple_exp TICK_ADDRESS
 444                         { write_exp_elt_opcode (UNOP_ADDR);
 445                           write_exp_elt_opcode (UNOP_CAST);
 446                           write_exp_elt_type (type_system_address ());
 447                           write_exp_elt_opcode (UNOP_CAST);
 448                         }
 449         |       simple_exp TICK_FIRST tick_arglist
 450                         { write_int ($3, type_int ());
 451                           write_exp_elt_opcode (OP_ATR_FIRST); }
 452         |       simple_exp TICK_LAST tick_arglist
 453                         { write_int ($3, type_int ());
 454                           write_exp_elt_opcode (OP_ATR_LAST); }
 455         |       simple_exp TICK_LENGTH tick_arglist
 456                         { write_int ($3, type_int ());
 457                           write_exp_elt_opcode (OP_ATR_LENGTH); }
 458         |       simple_exp TICK_SIZE
 459                         { write_exp_elt_opcode (OP_ATR_SIZE); }
 460         |       simple_exp TICK_TAG
 461                         { write_exp_elt_opcode (OP_ATR_TAG); }
 462         |       opt_type_prefix TICK_MIN '(' exp ',' exp ')'
 463                         { write_exp_elt_opcode (OP_ATR_MIN); }
 464         |       opt_type_prefix TICK_MAX '(' exp ',' exp ')'
 465                         { write_exp_elt_opcode (OP_ATR_MAX); }
 466         |       opt_type_prefix TICK_POS '(' exp ')'
 467                         { write_exp_elt_opcode (OP_ATR_POS); }
 468         |       type_prefix TICK_FIRST tick_arglist
 469                         { write_int ($3, type_int ());
 470                           write_exp_elt_opcode (OP_ATR_FIRST); }
 471         |       type_prefix TICK_LAST tick_arglist
 472                         { write_int ($3, type_int ());
 473                           write_exp_elt_opcode (OP_ATR_LAST); }
 474         |       type_prefix TICK_LENGTH tick_arglist
 475                         { write_int ($3, type_int ());
 476                           write_exp_elt_opcode (OP_ATR_LENGTH); }
 477         |       type_prefix TICK_VAL '(' exp ')'
 478                         { write_exp_elt_opcode (OP_ATR_VAL); }
 479         |       type_prefix TICK_MODULUS
 480                         { write_exp_elt_opcode (OP_ATR_MODULUS); }
 481         ;
 482
 483 tick_arglist :                  %prec '('
 484                         { $$ = 1; }
 485         |       '(' INT ')'
 486                         { $$ = $2.val; }
 487         ;
 488
 489 type_prefix :
 490                 TYPENAME
 491                         { write_exp_elt_opcode (OP_TYPE);
 492                           write_exp_elt_type ($1);
 493                           write_exp_elt_opcode (OP_TYPE); }
 494         ;
 495
 496 opt_type_prefix :
 497                 type_prefix
 498         |       /* EMPTY */
 499                         { write_exp_elt_opcode (OP_TYPE);
 500                           write_exp_elt_type (builtin_type_void);
 501                           write_exp_elt_opcode (OP_TYPE); }
 502         ;
 503
 504
 505 exp     :       INT
 506                         { write_int ((LONGEST) $1.val, $1.type); }
 507         ;
 508
 509 exp     :       CHARLIT
 510                   { write_int (convert_char_literal (type_qualifier, $1.val),
 511                                (type_qualifier == NULL)
 512                                ? $1.type : type_qualifier);
 513                   }
 514         ;
 515
 516 exp     :       FLOAT
 517                         { write_exp_elt_opcode (OP_DOUBLE);
 518                           write_exp_elt_type ($1.type);
 519                           write_exp_elt_dblcst ($1.dval);
 520                           write_exp_elt_opcode (OP_DOUBLE);
 521                         }
 522         ;
 523
 524 exp     :       NULL_PTR
 525                         { write_int (0, type_int ()); }
 526         ;
 527
 528 exp     :       STRING
 529                         {
 530                           write_exp_elt_opcode (OP_STRING);
 531                           write_exp_string ($1);
 532                           write_exp_elt_opcode (OP_STRING);
 533                         }
 534         ;
 535
 536 exp     :       NEW TYPENAME
 537                         { error ("NEW not implemented."); }
 538         ;
 539
 540 variable:       NAME            { write_var_from_name (NULL, $1); }
 541         |       block NAME      /* GDB extension */
 542                                 { write_var_from_name ($1, $2); }
 543         |       OBJECT_RENAMING
 544                     { write_object_renaming (NULL, $1.sym,
 545                                              MAX_RENAMING_CHAIN_LENGTH); }
 546         |       block OBJECT_RENAMING
 547                     { write_object_renaming ($1, $2.sym,
 548                                              MAX_RENAMING_CHAIN_LENGTH); }
 549         ;
 550
 551 any_name :      NAME            { }
 552         |       TYPENAME        { }
 553         |       OBJECT_RENAMING { }
 554         ;
 555
 556 block   :       BLOCKNAME  /* GDB extension */
 557                         { $$ = $1; }
 558         |       block BLOCKNAME /* GDB extension */
 559                         { $$ = $2; }
 560         ;
 561
 562
 563 type    :       TYPENAME        { $$ = $1; }
 564         |       block TYPENAME  { $$ = $2; }
 565         |       TYPENAME TICK_ACCESS
 566                                 { $$ = lookup_pointer_type ($1); }
 567         |       block TYPENAME TICK_ACCESS
 568                                 { $$ = lookup_pointer_type ($2); }
 569         ;
 570
 571 /* Some extensions borrowed from C, for the benefit of those who find they
 572    can't get used to Ada notation in GDB.  */
 573
 574 exp     :       '*' exp         %prec '.'
 575                         { write_exp_elt_opcode (UNOP_IND); }
 576         |       '&' exp         %prec '.'
 577                         { write_exp_elt_opcode (UNOP_ADDR); }
 578         |       exp '[' exp ']'
 579                         { write_exp_elt_opcode (BINOP_SUBSCRIPT); }
 580         ;
 581
 582 %%
 583
 584 /* yylex defined in ada-lex.c: Reads one token, getting characters */
 585 /* through lexptr.  */
 586
 587 /* Remap normal flex interface names (yylex) as well as gratuitiously */
 588 /* global symbol names, so we can have multiple flex-generated parsers */
 589 /* in gdb.  */
 590
 591 /* (See note above on previous definitions for YACC.) */
 592
 593 #define yy_create_buffer ada_yy_create_buffer
 594 #define yy_delete_buffer ada_yy_delete_buffer
 595 #define yy_init_buffer ada_yy_init_buffer
 596 #define yy_load_buffer_state ada_yy_load_buffer_state
 597 #define yy_switch_to_buffer ada_yy_switch_to_buffer
 598 #define yyrestart ada_yyrestart
 599 #define yytext ada_yytext
 600 #define yywrap ada_yywrap
 601
 602 static struct obstack temp_parse_space;
 603
 604 /* The following kludge was found necessary to prevent conflicts between */
 605 /* defs.h and non-standard stdlib.h files.  */
 606 #define qsort __qsort__dummy
 607 #include "ada-lex.c"
 608
 609 int
 610 ada_parse (void)
 611 {
 612   lexer_init (yyin);            /* (Re-)initialize lexer.  */
 613   left_block_context = NULL;
 614   type_qualifier = NULL;
 615   obstack_free (&temp_parse_space, NULL);
 616   obstack_init (&temp_parse_space);
 617
 618   return _ada_parse ();
 619 }
 620
 621 void
 622 yyerror (char *msg)
 623 {
 624   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
 625 }
 626
 627 /* The operator name corresponding to operator symbol STRING (adds
 628    quotes and maps to lower-case).  Destroys the previous contents of
 629    the array pointed to by STRING.ptr.  Error if STRING does not match
 630    a valid Ada operator.  Assumes that STRING.ptr points to a
 631    null-terminated string and that, if STRING is a valid operator
 632    symbol, the array pointed to by STRING.ptr contains at least
 633    STRING.length+3 characters.  */
 634
 635 static struct stoken
 636 string_to_operator (struct stoken string)
 637 {
 638   int i;
 639
 640   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
 641     {
 642       if (string.length == strlen (ada_opname_table[i].decoded)-2
 643           && strncasecmp (string.ptr, ada_opname_table[i].decoded+1,
 644                           string.length) == 0)
 645         {
 646           strncpy (string.ptr, ada_opname_table[i].decoded,
 647                    string.length+2);
 648           string.length += 2;
 649           return string;
 650         }
 651     }
 652   error ("Invalid operator symbol `%s'", string.ptr);
 653 }
 654
 655 /* Emit expression to access an instance of SYM, in block BLOCK (if
 656  * non-NULL), and with :: qualification ORIG_LEFT_CONTEXT.  */
 657 static void
 658 write_var_from_sym (struct block *orig_left_context,
 659                     struct block *block,
 660                     struct symbol *sym)
 661 {
 662   if (orig_left_context == NULL && symbol_read_needs_frame (sym))
 663     {
 664       if (innermost_block == 0
 665           || contained_in (block, innermost_block))
 666         innermost_block = block;
 667     }
 668
 669   write_exp_elt_opcode (OP_VAR_VALUE);
 670   write_exp_elt_block (block);
 671   write_exp_elt_sym (sym);
 672   write_exp_elt_opcode (OP_VAR_VALUE);
 673 }
 674
 675 /* Emit expression to access an instance of NAME in :: context
 676  * ORIG_LEFT_CONTEXT.  If no unique symbol for NAME has been found,
 677  * output a dummy symbol (good to the next call of ada_parse) for NAME
 678  * in the UNDEF_DOMAIN, for later resolution by ada_resolve.  */
 679 static void
 680 write_var_from_name (struct block *orig_left_context,
 681                      struct name_info name)
 682 {
 683   if (name.msym != NULL)
 684     {
 685       write_exp_msymbol (name.msym,
 686                          lookup_function_type (type_int ()),
 687                          type_int ());
 688     }
 689   else if (name.sym == NULL)
 690     {
 691       /* Multiple matches: record name and starting block for later
 692          resolution by ada_resolve.  */
 693       char *encoded_name = ada_encode (name.stoken.ptr);
 694       struct symbol *sym =
 695         obstack_alloc (&temp_parse_space, sizeof (struct symbol));
 696       memset (sym, 0, sizeof (struct symbol));
 697       SYMBOL_DOMAIN (sym) = UNDEF_DOMAIN;
 698       SYMBOL_LINKAGE_NAME (sym)
 699         = obsavestring (encoded_name, strlen (encoded_name), &temp_parse_space);
 700       SYMBOL_LANGUAGE (sym) = language_ada;
 701
 702       write_exp_elt_opcode (OP_VAR_VALUE);
 703       write_exp_elt_block (name.block);
 704       write_exp_elt_sym (sym);
 705       write_exp_elt_opcode (OP_VAR_VALUE);
 706     }
 707   else
 708     write_var_from_sym (orig_left_context, name.block, name.sym);
 709 }
 710
 711 /* Write integer constant ARG of type TYPE.  */
 712
 713 static void
 714 write_int (LONGEST arg, struct type *type)
 715 {
 716   write_exp_elt_opcode (OP_LONG);
 717   write_exp_elt_type (type);
 718   write_exp_elt_longcst (arg);
 719   write_exp_elt_opcode (OP_LONG);
 720 }
 721
 722 /* Emit expression corresponding to the renamed object designated by
 723  * the type RENAMING, which must be the referent of an object renaming
 724  * type, in the context of ORIG_LEFT_CONTEXT.  MAX_DEPTH is the maximum
 725  * number of cascaded renamings to allow.  */
 726 static void
 727 write_object_renaming (struct block *orig_left_context,
 728                        struct symbol *renaming, int max_depth)
 729 {
 730   const char *qualification = SYMBOL_LINKAGE_NAME (renaming);
 731   const char *simple_tail;
 732   const char *expr = TYPE_FIELD_NAME (SYMBOL_TYPE (renaming), 0);
 733   const char *suffix;
 734   char *name;
 735   struct symbol *sym;
 736   enum { SIMPLE_INDEX, LOWER_BOUND, UPPER_BOUND } slice_state;
 737
 738   if (max_depth <= 0)
 739     error ("Could not find renamed symbol");
 740
 741   /* if orig_left_context is null, then use the currently selected
 742      block; otherwise we might fail our symbol lookup below.  */
 743   if (orig_left_context == NULL)
 744     orig_left_context = get_selected_block (NULL);
 745
 746   for (simple_tail = qualification + strlen (qualification);
 747        simple_tail != qualification; simple_tail -= 1)
 748     {
 749       if (*simple_tail == '.')
 750         {
 751           simple_tail += 1;
 752           break;
 753         }
 754       else if (strncmp (simple_tail, "__", 2) == 0)
 755         {
 756           simple_tail += 2;
 757           break;
 758         }
 759     }
 760
 761   suffix = strstr (expr, "___XE");
 762   if (suffix == NULL)
 763     goto BadEncoding;
 764
 765   name = (char *) obstack_alloc (&temp_parse_space, suffix - expr + 1);
 766   strncpy (name, expr, suffix-expr);
 767   name[suffix-expr] = '\000';
 768   sym = lookup_symbol (name, orig_left_context, VAR_DOMAIN, 0, NULL);
 769   if (sym == NULL)
 770     error ("Could not find renamed variable: %s", ada_decode (name));
 771   if (ada_is_object_renaming (sym))
 772     write_object_renaming (orig_left_context, sym, max_depth-1);
 773   else
 774     write_var_from_sym (orig_left_context, block_found, sym);
 775
 776   suffix += 5;
 777   slice_state = SIMPLE_INDEX;
 778   while (*suffix == 'X')
 779     {
 780       suffix += 1;
 781
 782       switch (*suffix) {
 783       case 'A':
 784         suffix += 1;
 785         write_exp_elt_opcode (UNOP_IND);
 786         break;
 787       case 'L':
 788         slice_state = LOWER_BOUND;
 789       case 'S':
 790         suffix += 1;
 791         if (isdigit (*suffix))
 792           {
 793             char *next;
 794             long val = strtol (suffix, &next, 10);
 795             if (next == suffix)
 796               goto BadEncoding;
 797             suffix = next;
 798             write_exp_elt_opcode (OP_LONG);
 799             write_exp_elt_type (type_int ());
 800             write_exp_elt_longcst ((LONGEST) val);
 801             write_exp_elt_opcode (OP_LONG);
 802           }
 803         else
 804           {
 805             const char *end;
 806             char *index_name;
 807             int index_len;
 808             struct symbol *index_sym;
 809
 810             end = strchr (suffix, 'X');
 811             if (end == NULL)
 812               end = suffix + strlen (suffix);
 813
 814             index_len = simple_tail - qualification + 2 + (suffix - end) + 1;
 815             index_name
 816               = (char *) obstack_alloc (&temp_parse_space, index_len);
 817             memset (index_name, '\000', index_len);
 818             strncpy (index_name, qualification, simple_tail - qualification);
 819             index_name[simple_tail - qualification] = '\000';
 820             strncat (index_name, suffix, suffix-end);
 821             suffix = end;
 822
 823             index_sym =
 824               lookup_symbol (index_name, NULL, VAR_DOMAIN, 0, NULL);
 825             if (index_sym == NULL)
 826               error ("Could not find %s", index_name);
 827             write_var_from_sym (NULL, block_found, sym);
 828           }
 829         if (slice_state == SIMPLE_INDEX)
 830           {
 831             write_exp_elt_opcode (OP_FUNCALL);
 832             write_exp_elt_longcst ((LONGEST) 1);
 833             write_exp_elt_opcode (OP_FUNCALL);
 834           }
 835         else if (slice_state == LOWER_BOUND)
 836           slice_state = UPPER_BOUND;
 837         else if (slice_state == UPPER_BOUND)
 838           {
 839             write_exp_elt_opcode (TERNOP_SLICE);
 840             slice_state = SIMPLE_INDEX;
 841           }
 842         break;
 843
 844       case 'R':
 845         {
 846           struct stoken field_name;
 847           const char *end;
 848           suffix += 1;
 849
 850           if (slice_state != SIMPLE_INDEX)
 851             goto BadEncoding;
 852           end = strchr (suffix, 'X');
 853           if (end == NULL)
 854             end = suffix + strlen (suffix);
 855           field_name.length = end - suffix;
 856           field_name.ptr = xmalloc (end - suffix + 1);
 857           strncpy (field_name.ptr, suffix, end - suffix);
 858           field_name.ptr[end - suffix] = '\000';
 859           suffix = end;
 860           write_exp_elt_opcode (STRUCTOP_STRUCT);
 861           write_exp_string (field_name);
 862           write_exp_elt_opcode (STRUCTOP_STRUCT);
 863           break;
 864         }
 865
 866       default:
 867         goto BadEncoding;
 868       }
 869     }
 870   if (slice_state == SIMPLE_INDEX)
 871     return;
 872
 873  BadEncoding:
 874   error ("Internal error in encoding of renaming declaration: %s",
 875          SYMBOL_LINKAGE_NAME (renaming));
 876 }
 877
 878 /* Convert the character literal whose ASCII value would be VAL to the
 879    appropriate value of type TYPE, if there is a translation.
 880    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
 881    the literal 'A' (VAL == 65), returns 0.  */
 882 static LONGEST
 883 convert_char_literal (struct type *type, LONGEST val)
 884 {
 885   char name[7];
 886   int f;
 887
 888   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM)
 889     return val;
 890   sprintf (name, "QU%02x", (int) val);
 891   for (f = 0; f < TYPE_NFIELDS (type); f += 1)
 892     {
 893       if (strcmp (name, TYPE_FIELD_NAME (type, f)) == 0)
 894         return TYPE_FIELD_BITPOS (type, f);
 895     }
 896   return val;
 897 }
 898
 899 static struct type *
 900 type_int (void)
 901 {
 902   return builtin_type (current_gdbarch)->builtin_int;
 903 }
 904
 905 static struct type *
 906 type_long (void)
 907 {
 908   return builtin_type (current_gdbarch)->builtin_long;
 909 }
 910
 911 static struct type *
 912 type_long_long (void)
 913 {
 914   return builtin_type (current_gdbarch)->builtin_long_long;
 915 }
 916
 917 static struct type *
 918 type_float (void)
 919 {
 920   return builtin_type (current_gdbarch)->builtin_float;
 921 }
 922
 923 static struct type *
 924 type_double (void)
 925 {
 926   return builtin_type (current_gdbarch)->builtin_double;
 927 }
 928
 929 static struct type *
 930 type_long_double (void)
 931 {
 932   return builtin_type (current_gdbarch)->builtin_long_double;
 933 }
 934
 935 static struct type *
 936 type_char (void)
 937 {
 938   return language_string_char_type (current_language, current_gdbarch);
 939 }
 940
 941 static struct type *
 942 type_system_address (void)
 943 {
 944   struct type *type
 945     = language_lookup_primitive_type_by_name (current_language,
 946                                               current_gdbarch,
 947                                               "system__address");
 948   return  type != NULL ? type : lookup_pointer_type (builtin_type_void);
 949 }
 950
 951 void
 952 _initialize_ada_exp (void)
 953 {
 954   obstack_init (&temp_parse_space);
 955 }
 956
 957 /* FIXME: hilfingr/2004-10-05: Hack to remove warning.  The function
 958    string_to_operator is supposed to be used for cases where one
 959    calls an operator function with prefix notation, as in
 960    "+" (a, b), but at some point, this code seems to have gone
 961    missing. */
 962
 963 struct stoken (*dummy_string_to_ada_operator) (struct stoken)
 964      = string_to_operator;
 965