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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  20
  21 /* Parse an Ada expression from text in a string,
  22    and return the result as a  struct expression  pointer.
  23    That structure contains arithmetic operations in reverse polish,
  24    with constants represented by operations that are followed by special data.
  25    See expression.h for the details of the format.
  26    What is important here is that it can be built up sequentially
  27    during the process of parsing; the lower levels of the tree always
  28    come first in the result.
  29
  30    malloc's and realloc's in this file are transformed to
  31    xmalloc and xrealloc respectively by the same sed command in the
  32    makefile that remaps any other malloc/realloc inserted by the parser
  33    generator.  Doing this with #defines and trying to control the interaction
  34    with include files (<malloc.h> and <stdlib.h> for example) just became
  35    too messy, particularly when such includes can be inserted at random
  36    times by the parser generator.  */
  37
  38 %{
  39
  40 #include "defs.h"
  41 #include "gdb_string.h"
  42 #include <ctype.h>
  43 #include "expression.h"
  44 #include "value.h"
  45 #include "parser-defs.h"
  46 #include "language.h"
  47 #include "ada-lang.h"
  48 #include "bfd.h" /* Required by objfiles.h.  */
  49 #include "symfile.h" /* Required by objfiles.h.  */
  50 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  51 #include "frame.h"
  52 #include "block.h"
  53
  54 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
  55    as well as gratuitiously global symbol names, so we can have multiple
  56    yacc generated parsers in gdb.  These are only the variables
  57    produced by yacc.  If other parser generators (bison, byacc, etc) produce
  58    additional global names that conflict at link time, then those parser
  59    generators need to be fixed instead of adding those names to this list.  */
  60
  61 /* NOTE: This is clumsy, especially since BISON and FLEX provide --prefix
  62    options.  I presume we are maintaining it to accommodate systems
  63    without BISON?  (PNH) */
  64
  65 #define yymaxdepth ada_maxdepth
  66 #define yyparse _ada_parse      /* ada_parse calls this after  initialization */
  67 #define yylex   ada_lex
  68 #define yyerror ada_error
  69 #define yylval  ada_lval
  70 #define yychar  ada_char
  71 #define yydebug ada_debug
  72 #define yypact  ada_pact
  73 #define yyr1    ada_r1
  74 #define yyr2    ada_r2
  75 #define yydef   ada_def
  76 #define yychk   ada_chk
  77 #define yypgo   ada_pgo
  78 #define yyact   ada_act
  79 #define yyexca  ada_exca
  80 #define yyerrflag ada_errflag
  81 #define yynerrs ada_nerrs
  82 #define yyps    ada_ps
  83 #define yypv    ada_pv
  84 #define yys     ada_s
  85 #define yy_yys  ada_yys
  86 #define yystate ada_state
  87 #define yytmp   ada_tmp
  88 #define yyv     ada_v
  89 #define yy_yyv  ada_yyv
  90 #define yyval   ada_val
  91 #define yylloc  ada_lloc
  92 #define yyreds  ada_reds                /* With YYDEBUG defined */
  93 #define yytoks  ada_toks                /* With YYDEBUG defined */
  94 #define yyname  ada_name                /* With YYDEBUG defined */
  95 #define yyrule  ada_rule                /* With YYDEBUG defined */
  96
  97 #ifndef YYDEBUG
  98 #define YYDEBUG 1               /* Default to yydebug support */
  99 #endif
 100
 101 #define YYFPRINTF parser_fprintf
 102
 103 struct name_info {
 104   struct symbol *sym;
 105   struct minimal_symbol *msym;
 106   struct block *block;
 107   struct stoken stoken;
 108 };
 109
 110 /* If expression is in the context of TYPE'(...), then TYPE, else
 111  * NULL.  */
 112 static struct type *type_qualifier;
 113
 114 int yyparse (void);
 115
 116 static int yylex (void);
 117
 118 void yyerror (char *);
 119
 120 static struct stoken string_to_operator (struct stoken);
 121
 122 static void write_int (LONGEST, struct type *);
 123
 124 static void write_object_renaming (struct block *, struct symbol *, int);
 125
 126 static void write_var_from_name (struct block *, struct name_info);
 127
 128 static LONGEST convert_char_literal (struct type *, LONGEST);
 129 %}
 130
 131 %union
 132   {
 133     LONGEST lval;
 134     struct {
 135       LONGEST val;
 136       struct type *type;
 137     } typed_val;
 138     struct {
 139       DOUBLEST dval;
 140       struct type *type;
 141     } typed_val_float;
 142     struct type *tval;
 143     struct stoken sval;
 144     struct name_info ssym;
 145     int voidval;
 146     struct block *bval;
 147     struct internalvar *ivar;
 148
 149   }
 150
 151 %type <voidval> exp exp1 simple_exp start variable
 152 %type <tval> type
 153
 154 %token <typed_val> INT NULL_PTR CHARLIT
 155 %token <typed_val_float> FLOAT
 156 %token <tval> TYPENAME
 157 %token <bval> BLOCKNAME
 158
 159 /* Both NAME and TYPENAME tokens represent symbols in the input,
 160    and both convey their data as strings.
 161    But a TYPENAME is a string that happens to be defined as a typedef
 162    or builtin type name (such as int or char)
 163    and a NAME is any other symbol.
 164    Contexts where this distinction is not important can use the
 165    nonterminal "name", which matches either NAME or TYPENAME.  */
 166
 167 %token <sval> STRING
 168 %token <ssym> NAME DOT_ID OBJECT_RENAMING
 169 %type <bval> block
 170 %type <lval> arglist tick_arglist
 171
 172 %type <tval> save_qualifier
 173
 174 %token DOT_ALL
 175
 176 /* Special type cases, put in to allow the parser to distinguish different
 177    legal basetypes.  */
 178 %token <sval> SPECIAL_VARIABLE
 179
 180 %nonassoc ASSIGN
 181 %left _AND_ OR XOR THEN ELSE
 182 %left '=' NOTEQUAL '<' '>' LEQ GEQ IN DOTDOT
 183 %left '@'
 184 %left '+' '-' '&'
 185 %left UNARY
 186 %left '*' '/' MOD REM
 187 %right STARSTAR ABS NOT
 188  /* The following are right-associative only so that reductions at this
 189     precedence have lower precedence than '.' and '('.  The syntax still
 190     forces a.b.c, e.g., to be LEFT-associated.  */
 191 %right TICK_ACCESS TICK_ADDRESS TICK_FIRST TICK_LAST TICK_LENGTH
 192 %right TICK_MAX TICK_MIN TICK_MODULUS
 193 %right TICK_POS TICK_RANGE TICK_SIZE TICK_TAG TICK_VAL
 194 %right '.' '(' '[' DOT_ID DOT_ALL
 195
 196 %token ARROW NEW
 197
 198 \f
 199 %%
 200
 201 start   :       exp1
 202         |       type    { write_exp_elt_opcode (OP_TYPE);
 203                           write_exp_elt_type ($1);
 204                           write_exp_elt_opcode (OP_TYPE); }
 205         ;
 206
 207 /* Expressions, including the sequencing operator.  */
 208 exp1    :       exp
 209         |       exp1 ';' exp
 210                         { write_exp_elt_opcode (BINOP_COMMA); }
 211         ;
 212
 213 /* Expressions, not including the sequencing operator.  */
 214 simple_exp :    simple_exp DOT_ALL
 215                         { write_exp_elt_opcode (UNOP_IND); }
 216         ;
 217
 218 simple_exp :    simple_exp DOT_ID
 219                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 220                           write_exp_string ($2.stoken);
 221                           write_exp_elt_opcode (STRUCTOP_STRUCT);
 222                           }
 223         ;
 224
 225 simple_exp :    simple_exp '(' arglist ')'
 226                         {
 227                           write_exp_elt_opcode (OP_FUNCALL);
 228                           write_exp_elt_longcst ($3);
 229                           write_exp_elt_opcode (OP_FUNCALL);
 230                         }
 231         ;
 232
 233 simple_exp :    type '(' exp ')'
 234                         {
 235                           write_exp_elt_opcode (UNOP_CAST);
 236                           write_exp_elt_type ($1);
 237                           write_exp_elt_opcode (UNOP_CAST);
 238                         }
 239         ;
 240
 241 simple_exp :    type '\'' save_qualifier { type_qualifier = $1; } '(' exp ')'
 242                         {
 243                           write_exp_elt_opcode (UNOP_QUAL);
 244                           write_exp_elt_type ($1);
 245                           write_exp_elt_opcode (UNOP_QUAL);
 246                           type_qualifier = $3;
 247                         }
 248         ;
 249
 250 save_qualifier :        { $$ = type_qualifier; }
 251         ;
 252
 253 simple_exp :
 254                 simple_exp '(' exp DOTDOT exp ')'
 255                         { write_exp_elt_opcode (TERNOP_SLICE); }
 256         ;
 257
 258 simple_exp :    '(' exp1 ')'    { }
 259         ;
 260
 261 simple_exp :    variable
 262         ;
 263
 264 simple_exp:     SPECIAL_VARIABLE /* Various GDB extensions */
 265                         { write_dollar_variable ($1); }
 266         ;
 267
 268 exp     :       simple_exp
 269         ;
 270
 271 exp     :       exp ASSIGN exp   /* Extension for convenience */
 272                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 273         ;
 274
 275 exp     :       '-' exp    %prec UNARY
 276                         { write_exp_elt_opcode (UNOP_NEG); }
 277         ;
 278
 279 exp     :       '+' exp    %prec UNARY
 280                         { write_exp_elt_opcode (UNOP_PLUS); }
 281         ;
 282
 283 exp     :       NOT exp    %prec UNARY
 284                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 285         ;
 286
 287 exp     :       ABS exp    %prec UNARY
 288                         { write_exp_elt_opcode (UNOP_ABS); }
 289         ;
 290
 291 arglist :               { $$ = 0; }
 292         ;
 293
 294 arglist :       exp
 295                         { $$ = 1; }
 296         |       any_name ARROW exp
 297                         { $$ = 1; }
 298         |       arglist ',' exp
 299                         { $$ = $1 + 1; }
 300         |       arglist ',' any_name ARROW exp
 301                         { $$ = $1 + 1; }
 302         ;
 303
 304 exp     :       '{' type '}' exp  %prec '.'
 305                 /* GDB extension */
 306                         { write_exp_elt_opcode (UNOP_MEMVAL);
 307                           write_exp_elt_type ($2);
 308                           write_exp_elt_opcode (UNOP_MEMVAL);
 309                         }
 310         ;
 311
 312 /* Binary operators in order of decreasing precedence.  */
 313
 314 exp     :       exp STARSTAR exp
 315                         { write_exp_elt_opcode (BINOP_EXP); }
 316         ;
 317
 318 exp     :       exp '*' exp
 319                         { write_exp_elt_opcode (BINOP_MUL); }
 320         ;
 321
 322 exp     :       exp '/' exp
 323                         { write_exp_elt_opcode (BINOP_DIV); }
 324         ;
 325
 326 exp     :       exp REM exp /* May need to be fixed to give correct Ada REM */
 327                         { write_exp_elt_opcode (BINOP_REM); }
 328         ;
 329
 330 exp     :       exp MOD exp
 331                         { write_exp_elt_opcode (BINOP_MOD); }
 332         ;
 333
 334 exp     :       exp '@' exp     /* GDB extension */
 335                         { write_exp_elt_opcode (BINOP_REPEAT); }
 336         ;
 337
 338 exp     :       exp '+' exp
 339                         { write_exp_elt_opcode (BINOP_ADD); }
 340         ;
 341
 342 exp     :       exp '&' exp
 343                         { write_exp_elt_opcode (BINOP_CONCAT); }
 344         ;
 345
 346 exp     :       exp '-' exp
 347                         { write_exp_elt_opcode (BINOP_SUB); }
 348         ;
 349
 350 exp     :       exp '=' exp
 351                         { write_exp_elt_opcode (BINOP_EQUAL); }
 352         ;
 353
 354 exp     :       exp NOTEQUAL exp
 355                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 356         ;
 357
 358 exp     :       exp LEQ exp
 359                         { write_exp_elt_opcode (BINOP_LEQ); }
 360         ;
 361
 362 exp     :       exp IN exp DOTDOT exp
 363                         { write_exp_elt_opcode (TERNOP_IN_RANGE); }
 364         |       exp IN exp TICK_RANGE tick_arglist
 365                         { write_exp_elt_opcode (BINOP_IN_BOUNDS);
 366                           write_exp_elt_longcst ((LONGEST) $5);
 367                           write_exp_elt_opcode (BINOP_IN_BOUNDS);
 368                         }
 369         |       exp IN TYPENAME         %prec TICK_ACCESS
 370                         { write_exp_elt_opcode (UNOP_IN_RANGE);
 371                           write_exp_elt_type ($3);
 372                           write_exp_elt_opcode (UNOP_IN_RANGE);
 373                         }
 374         |       exp NOT IN exp DOTDOT exp
 375                         { write_exp_elt_opcode (TERNOP_IN_RANGE);
 376                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 377                         }
 378         |       exp NOT IN exp TICK_RANGE tick_arglist
 379                         { write_exp_elt_opcode (BINOP_IN_BOUNDS);
 380                           write_exp_elt_longcst ((LONGEST) $6);
 381                           write_exp_elt_opcode (BINOP_IN_BOUNDS);
 382                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 383                         }
 384         |       exp NOT IN TYPENAME     %prec TICK_ACCESS
 385                         { write_exp_elt_opcode (UNOP_IN_RANGE);
 386                           write_exp_elt_type ($4);
 387                           write_exp_elt_opcode (UNOP_IN_RANGE);
 388                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 389                         }
 390         ;
 391
 392 exp     :       exp GEQ exp
 393                         { write_exp_elt_opcode (BINOP_GEQ); }
 394         ;
 395
 396 exp     :       exp '<' exp
 397                         { write_exp_elt_opcode (BINOP_LESS); }
 398         ;
 399
 400 exp     :       exp '>' exp
 401                         { write_exp_elt_opcode (BINOP_GTR); }
 402         ;
 403
 404 exp     :       exp _AND_ exp  /* Fix for Ada elementwise AND.  */
 405                         { write_exp_elt_opcode (BINOP_BITWISE_AND); }
 406         ;
 407
 408 exp     :       exp _AND_ THEN exp      %prec _AND_
 409                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 410         ;
 411
 412 exp     :       exp OR exp     /* Fix for Ada elementwise OR */
 413                         { write_exp_elt_opcode (BINOP_BITWISE_IOR); }
 414         ;
 415
 416 exp     :       exp OR ELSE exp
 417                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 418         ;
 419
 420 exp     :       exp XOR exp    /* Fix for Ada elementwise XOR */
 421                         { write_exp_elt_opcode (BINOP_BITWISE_XOR); }
 422         ;
 423
 424 simple_exp :    simple_exp TICK_ACCESS
 425                         { write_exp_elt_opcode (UNOP_ADDR); }
 426         |       simple_exp TICK_ADDRESS
 427                         { write_exp_elt_opcode (UNOP_ADDR);
 428                           write_exp_elt_opcode (UNOP_CAST);
 429                           write_exp_elt_type (builtin_type_ada_system_address);
 430                           write_exp_elt_opcode (UNOP_CAST);
 431                         }
 432         |       simple_exp TICK_FIRST tick_arglist
 433                         { write_int ($3, builtin_type_int);
 434                           write_exp_elt_opcode (OP_ATR_FIRST); }
 435         |       simple_exp TICK_LAST tick_arglist
 436                         { write_int ($3, builtin_type_int);
 437                           write_exp_elt_opcode (OP_ATR_LAST); }
 438         |       simple_exp TICK_LENGTH tick_arglist
 439                         { write_int ($3, builtin_type_int);
 440                           write_exp_elt_opcode (OP_ATR_LENGTH); }
 441         |       simple_exp TICK_SIZE
 442                         { write_exp_elt_opcode (OP_ATR_SIZE); }
 443         |       simple_exp TICK_TAG
 444                         { write_exp_elt_opcode (OP_ATR_TAG); }
 445         |       opt_type_prefix TICK_MIN '(' exp ',' exp ')'
 446                         { write_exp_elt_opcode (OP_ATR_MIN); }
 447         |       opt_type_prefix TICK_MAX '(' exp ',' exp ')'
 448                         { write_exp_elt_opcode (OP_ATR_MAX); }
 449         |       opt_type_prefix TICK_POS '(' exp ')'
 450                         { write_exp_elt_opcode (OP_ATR_POS); }
 451         |       type_prefix TICK_FIRST tick_arglist
 452                         { write_int ($3, builtin_type_int);
 453                           write_exp_elt_opcode (OP_ATR_FIRST); }
 454         |       type_prefix TICK_LAST tick_arglist
 455                         { write_int ($3, builtin_type_int);
 456                           write_exp_elt_opcode (OP_ATR_LAST); }
 457         |       type_prefix TICK_LENGTH tick_arglist
 458                         { write_int ($3, builtin_type_int);
 459                           write_exp_elt_opcode (OP_ATR_LENGTH); }
 460         |       type_prefix TICK_VAL '(' exp ')'
 461                         { write_exp_elt_opcode (OP_ATR_VAL); }
 462         |       type_prefix TICK_MODULUS
 463                         { write_exp_elt_opcode (OP_ATR_MODULUS); }
 464         ;
 465
 466 tick_arglist :                  %prec '('
 467                         { $$ = 1; }
 468         |       '(' INT ')'
 469                         { $$ = $2.val; }
 470         ;
 471
 472 type_prefix :
 473                 TYPENAME
 474                         { write_exp_elt_opcode (OP_TYPE);
 475                           write_exp_elt_type ($1);
 476                           write_exp_elt_opcode (OP_TYPE); }
 477         ;
 478
 479 opt_type_prefix :
 480                 type_prefix
 481         |       /* EMPTY */
 482                         { write_exp_elt_opcode (OP_TYPE);
 483                           write_exp_elt_type (builtin_type_void);
 484                           write_exp_elt_opcode (OP_TYPE); }
 485         ;
 486
 487
 488 exp     :       INT
 489                         { write_int ((LONGEST) $1.val, $1.type); }
 490         ;
 491
 492 exp     :       CHARLIT
 493                   { write_int (convert_char_literal (type_qualifier, $1.val),
 494                                (type_qualifier == NULL)
 495                                ? $1.type : type_qualifier);
 496                   }
 497         ;
 498
 499 exp     :       FLOAT
 500                         { write_exp_elt_opcode (OP_DOUBLE);
 501                           write_exp_elt_type ($1.type);
 502                           write_exp_elt_dblcst ($1.dval);
 503                           write_exp_elt_opcode (OP_DOUBLE);
 504                         }
 505         ;
 506
 507 exp     :       NULL_PTR
 508                         { write_int (0, builtin_type_int); }
 509         ;
 510
 511 exp     :       STRING
 512                         {
 513                           write_exp_elt_opcode (OP_STRING);
 514                           write_exp_string ($1);
 515                           write_exp_elt_opcode (OP_STRING);
 516                         }
 517         ;
 518
 519 exp     :       NEW TYPENAME
 520                         { error ("NEW not implemented."); }
 521         ;
 522
 523 variable:       NAME            { write_var_from_name (NULL, $1); }
 524         |       block NAME      /* GDB extension */
 525                                 { write_var_from_name ($1, $2); }
 526         |       OBJECT_RENAMING
 527                     { write_object_renaming (NULL, $1.sym,
 528                                              MAX_RENAMING_CHAIN_LENGTH); }
 529         |       block OBJECT_RENAMING
 530                     { write_object_renaming ($1, $2.sym,
 531                                              MAX_RENAMING_CHAIN_LENGTH); }
 532         ;
 533
 534 any_name :      NAME            { }
 535         |       TYPENAME        { }
 536         |       OBJECT_RENAMING { }
 537         ;
 538
 539 block   :       BLOCKNAME  /* GDB extension */
 540                         { $$ = $1; }
 541         |       block BLOCKNAME /* GDB extension */
 542                         { $$ = $2; }
 543         ;
 544
 545
 546 type    :       TYPENAME        { $$ = $1; }
 547         |       block TYPENAME  { $$ = $2; }
 548         |       TYPENAME TICK_ACCESS
 549                                 { $$ = lookup_pointer_type ($1); }
 550         |       block TYPENAME TICK_ACCESS
 551                                 { $$ = lookup_pointer_type ($2); }
 552         ;
 553
 554 /* Some extensions borrowed from C, for the benefit of those who find they
 555    can't get used to Ada notation in GDB.  */
 556
 557 exp     :       '*' exp         %prec '.'
 558                         { write_exp_elt_opcode (UNOP_IND); }
 559         |       '&' exp         %prec '.'
 560                         { write_exp_elt_opcode (UNOP_ADDR); }
 561         |       exp '[' exp ']'
 562                         { write_exp_elt_opcode (BINOP_SUBSCRIPT); }
 563         ;
 564
 565 %%
 566
 567 /* yylex defined in ada-lex.c: Reads one token, getting characters */
 568 /* through lexptr.  */
 569
 570 /* Remap normal flex interface names (yylex) as well as gratuitiously */
 571 /* global symbol names, so we can have multiple flex-generated parsers */
 572 /* in gdb.  */
 573
 574 /* (See note above on previous definitions for YACC.) */
 575
 576 #define yy_create_buffer ada_yy_create_buffer
 577 #define yy_delete_buffer ada_yy_delete_buffer
 578 #define yy_init_buffer ada_yy_init_buffer
 579 #define yy_load_buffer_state ada_yy_load_buffer_state
 580 #define yy_switch_to_buffer ada_yy_switch_to_buffer
 581 #define yyrestart ada_yyrestart
 582 #define yytext ada_yytext
 583 #define yywrap ada_yywrap
 584
 585 static struct obstack temp_parse_space;
 586
 587 /* The following kludge was found necessary to prevent conflicts between */
 588 /* defs.h and non-standard stdlib.h files.  */
 589 #define qsort __qsort__dummy
 590 #include "ada-lex.c"
 591
 592 int
 593 ada_parse (void)
 594 {
 595   lexer_init (yyin);            /* (Re-)initialize lexer.  */
 596   left_block_context = NULL;
 597   type_qualifier = NULL;
 598   obstack_free (&temp_parse_space, NULL);
 599   obstack_init (&temp_parse_space);
 600
 601   return _ada_parse ();
 602 }
 603
 604 void
 605 yyerror (char *msg)
 606 {
 607   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
 608 }
 609
 610 /* The operator name corresponding to operator symbol STRING (adds
 611    quotes and maps to lower-case).  Destroys the previous contents of
 612    the array pointed to by STRING.ptr.  Error if STRING does not match
 613    a valid Ada operator.  Assumes that STRING.ptr points to a
 614    null-terminated string and that, if STRING is a valid operator
 615    symbol, the array pointed to by STRING.ptr contains at least
 616    STRING.length+3 characters.  */
 617
 618 static struct stoken
 619 string_to_operator (struct stoken string)
 620 {
 621   int i;
 622
 623   for (i = 0; ada_opname_table[i].encoded != NULL; i += 1)
 624     {
 625       if (string.length == strlen (ada_opname_table[i].decoded)-2
 626           && strncasecmp (string.ptr, ada_opname_table[i].decoded+1,
 627                           string.length) == 0)
 628         {
 629           strncpy (string.ptr, ada_opname_table[i].decoded,
 630                    string.length+2);
 631           string.length += 2;
 632           return string;
 633         }
 634     }
 635   error ("Invalid operator symbol `%s'", string.ptr);
 636 }
 637
 638 /* Emit expression to access an instance of SYM, in block BLOCK (if
 639  * non-NULL), and with :: qualification ORIG_LEFT_CONTEXT.  */
 640 static void
 641 write_var_from_sym (struct block *orig_left_context,
 642                     struct block *block,
 643                     struct symbol *sym)
 644 {
 645   if (orig_left_context == NULL && symbol_read_needs_frame (sym))
 646     {
 647       if (innermost_block == 0 ||
 648           contained_in (block, innermost_block))
 649         innermost_block = block;
 650     }
 651
 652   write_exp_elt_opcode (OP_VAR_VALUE);
 653   write_exp_elt_block (block);
 654   write_exp_elt_sym (sym);
 655   write_exp_elt_opcode (OP_VAR_VALUE);
 656 }
 657
 658 /* Emit expression to access an instance of NAME in :: context
 659  * ORIG_LEFT_CONTEXT.  If no unique symbol for NAME has been found,
 660  * output a dummy symbol (good to the next call of ada_parse) for NAME
 661  * in the UNDEF_DOMAIN, for later resolution by ada_resolve.  */
 662 static void
 663 write_var_from_name (struct block *orig_left_context,
 664                      struct name_info name)
 665 {
 666   if (name.msym != NULL)
 667     {
 668       write_exp_msymbol (name.msym,
 669                          lookup_function_type (builtin_type_int),
 670                          builtin_type_int);
 671     }
 672   else if (name.sym == NULL)
 673     {
 674       /* Multiple matches: record name and starting block for later
 675          resolution by ada_resolve.  */
 676       char *encoded_name = ada_encode (name.stoken.ptr);
 677       struct symbol *sym =
 678         obstack_alloc (&temp_parse_space, sizeof (struct symbol));
 679       memset (sym, 0, sizeof (struct symbol));
 680       SYMBOL_DOMAIN (sym) = UNDEF_DOMAIN;
 681       SYMBOL_LINKAGE_NAME (sym)
 682         = obsavestring (encoded_name, strlen (encoded_name), &temp_parse_space);
 683       SYMBOL_LANGUAGE (sym) = language_ada;
 684
 685       write_exp_elt_opcode (OP_VAR_VALUE);
 686       write_exp_elt_block (name.block);
 687       write_exp_elt_sym (sym);
 688       write_exp_elt_opcode (OP_VAR_VALUE);
 689     }
 690   else
 691     write_var_from_sym (orig_left_context, name.block, name.sym);
 692 }
 693
 694 /* Write integer constant ARG of type TYPE.  */
 695
 696 static void
 697 write_int (LONGEST arg, struct type *type)
 698 {
 699   write_exp_elt_opcode (OP_LONG);
 700   write_exp_elt_type (type);
 701   write_exp_elt_longcst (arg);
 702   write_exp_elt_opcode (OP_LONG);
 703 }
 704
 705 /* Emit expression corresponding to the renamed object designated by
 706  * the type RENAMING, which must be the referent of an object renaming
 707  * type, in the context of ORIG_LEFT_CONTEXT.  MAX_DEPTH is the maximum
 708  * number of cascaded renamings to allow.  */
 709 static void
 710 write_object_renaming (struct block *orig_left_context,
 711                        struct symbol *renaming, int max_depth)
 712 {
 713   const char *qualification = SYMBOL_LINKAGE_NAME (renaming);
 714   const char *simple_tail;
 715   const char *expr = TYPE_FIELD_NAME (SYMBOL_TYPE (renaming), 0);
 716   const char *suffix;
 717   char *name;
 718   struct symbol *sym;
 719   enum { SIMPLE_INDEX, LOWER_BOUND, UPPER_BOUND } slice_state;
 720
 721   if (max_depth <= 0)
 722     error ("Could not find renamed symbol");
 723
 724   /* if orig_left_context is null, then use the currently selected
 725      block; otherwise we might fail our symbol lookup below.  */
 726   if (orig_left_context == NULL)
 727     orig_left_context = get_selected_block (NULL);
 728
 729   for (simple_tail = qualification + strlen (qualification);
 730        simple_tail != qualification; simple_tail -= 1)
 731     {
 732       if (*simple_tail == '.')
 733         {
 734           simple_tail += 1;
 735           break;
 736         }
 737       else if (strncmp (simple_tail, "__", 2) == 0)
 738         {
 739           simple_tail += 2;
 740           break;
 741         }
 742     }
 743
 744   suffix = strstr (expr, "___XE");
 745   if (suffix == NULL)
 746     goto BadEncoding;
 747
 748   name = (char *) obstack_alloc (&temp_parse_space, suffix - expr + 1);
 749   strncpy (name, expr, suffix-expr);
 750   name[suffix-expr] = '\000';
 751   sym = lookup_symbol (name, orig_left_context, VAR_DOMAIN, 0, NULL);
 752   if (sym == NULL)
 753     error ("Could not find renamed variable: %s", ada_decode (name));
 754   if (ada_is_object_renaming (sym))
 755     write_object_renaming (orig_left_context, sym, max_depth-1);
 756   else
 757     write_var_from_sym (orig_left_context, block_found, sym);
 758
 759   suffix += 5;
 760   slice_state = SIMPLE_INDEX;
 761   while (*suffix == 'X')
 762     {
 763       suffix += 1;
 764
 765       switch (*suffix) {
 766       case 'A':
 767         suffix += 1;
 768         write_exp_elt_opcode (UNOP_IND);
 769         break;
 770       case 'L':
 771         slice_state = LOWER_BOUND;
 772       case 'S':
 773         suffix += 1;
 774         if (isdigit (*suffix))
 775           {
 776             char *next;
 777             long val = strtol (suffix, &next, 10);
 778             if (next == suffix)
 779               goto BadEncoding;
 780             suffix = next;
 781             write_exp_elt_opcode (OP_LONG);
 782             write_exp_elt_type (builtin_type_ada_int);
 783             write_exp_elt_longcst ((LONGEST) val);
 784             write_exp_elt_opcode (OP_LONG);
 785           }
 786         else
 787           {
 788             const char *end;
 789             char *index_name;
 790             int index_len;
 791             struct symbol *index_sym;
 792
 793             end = strchr (suffix, 'X');
 794             if (end == NULL)
 795               end = suffix + strlen (suffix);
 796
 797             index_len = simple_tail - qualification + 2 + (suffix - end) + 1;
 798             index_name
 799               = (char *) obstack_alloc (&temp_parse_space, index_len);
 800             memset (index_name, '\000', index_len);
 801             strncpy (index_name, qualification, simple_tail - qualification);
 802             index_name[simple_tail - qualification] = '\000';
 803             strncat (index_name, suffix, suffix-end);
 804             suffix = end;
 805
 806             index_sym =
 807               lookup_symbol (index_name, NULL, VAR_DOMAIN, 0, NULL);
 808             if (index_sym == NULL)
 809               error ("Could not find %s", index_name);
 810             write_var_from_sym (NULL, block_found, sym);
 811           }
 812         if (slice_state == SIMPLE_INDEX)
 813           {
 814             write_exp_elt_opcode (OP_FUNCALL);
 815             write_exp_elt_longcst ((LONGEST) 1);
 816             write_exp_elt_opcode (OP_FUNCALL);
 817           }
 818         else if (slice_state == LOWER_BOUND)
 819           slice_state = UPPER_BOUND;
 820         else if (slice_state == UPPER_BOUND)
 821           {
 822             write_exp_elt_opcode (TERNOP_SLICE);
 823             slice_state = SIMPLE_INDEX;
 824           }
 825         break;
 826
 827       case 'R':
 828         {
 829           struct stoken field_name;
 830           const char *end;
 831           suffix += 1;
 832
 833           if (slice_state != SIMPLE_INDEX)
 834             goto BadEncoding;
 835           end = strchr (suffix, 'X');
 836           if (end == NULL)
 837             end = suffix + strlen (suffix);
 838           field_name.length = end - suffix;
 839           field_name.ptr = (char *) malloc (end - suffix + 1);
 840           strncpy (field_name.ptr, suffix, end - suffix);
 841           field_name.ptr[end - suffix] = '\000';
 842           suffix = end;
 843           write_exp_elt_opcode (STRUCTOP_STRUCT);
 844           write_exp_string (field_name);
 845           write_exp_elt_opcode (STRUCTOP_STRUCT);
 846           break;
 847         }
 848
 849       default:
 850         goto BadEncoding;
 851       }
 852     }
 853   if (slice_state == SIMPLE_INDEX)
 854     return;
 855
 856  BadEncoding:
 857   error ("Internal error in encoding of renaming declaration: %s",
 858          SYMBOL_LINKAGE_NAME (renaming));
 859 }
 860
 861 /* Convert the character literal whose ASCII value would be VAL to the
 862    appropriate value of type TYPE, if there is a translation.
 863    Otherwise return VAL.  Hence, in an enumeration type ('A', 'B'),
 864    the literal 'A' (VAL == 65), returns 0.  */
 865 static LONGEST
 866 convert_char_literal (struct type *type, LONGEST val)
 867 {
 868   char name[7];
 869   int f;
 870
 871   if (type == NULL || TYPE_CODE (type) != TYPE_CODE_ENUM)
 872     return val;
 873   sprintf (name, "QU%02x", (int) val);
 874   for (f = 0; f < TYPE_NFIELDS (type); f += 1)
 875     {
 876       if (strcmp (name, TYPE_FIELD_NAME (type, f)) == 0)
 877         return TYPE_FIELD_BITPOS (type, f);
 878     }
 879   return val;
 880 }
 881
 882 void
 883 _initialize_ada_exp (void)
 884 {
 885   obstack_init (&temp_parse_space);
 886 }