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