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