gdb/p-exp.y

   1 /* YACC parser for Pascal expressions, for GDB.
   2    Copyright (C) 2000-2017 Free Software Foundation, Inc.
   3
   4    This file is part of GDB.
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published by
   8    the Free Software Foundation; either version 3 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  18
  19 /* This file is derived from c-exp.y */
  20
  21 /* Parse a Pascal 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    Note that 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 /* Known bugs or limitations:
  39     - pascal string operations are not supported at all.
  40     - there are some problems with boolean types.
  41     - Pascal type hexadecimal constants are not supported
  42       because they conflict with the internal variables format.
  43    Probably also lots of other problems, less well defined PM.  */
  44 %{
  45
  46 #include "defs.h"
  47 #include <ctype.h>
  48 #include "expression.h"
  49 #include "value.h"
  50 #include "parser-defs.h"
  51 #include "language.h"
  52 #include "p-lang.h"
  53 #include "bfd.h" /* Required by objfiles.h.  */
  54 #include "symfile.h" /* Required by objfiles.h.  */
  55 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols.  */
  56 #include "block.h"
  57 #include "completer.h"
  58
  59 #define parse_type(ps) builtin_type (parse_gdbarch (ps))
  60
  61 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
  62    etc).  */
  63 #define GDB_YY_REMAP_PREFIX pascal_
  64 #include "yy-remap.h"
  65
  66 /* The state of the parser, used internally when we are parsing the
  67    expression.  */
  68
  69 static struct parser_state *pstate = NULL;
  70
  71 int yyparse (void);
  72
  73 static int yylex (void);
  74
  75 void yyerror (const char *);
  76
  77 static char *uptok (const char *, int);
  78 %}
  79
  80 /* Although the yacc "value" of an expression is not used,
  81    since the result is stored in the structure being created,
  82    other node types do have values.  */
  83
  84 %union
  85   {
  86     LONGEST lval;
  87     struct {
  88       LONGEST val;
  89       struct type *type;
  90     } typed_val_int;
  91     struct {
  92       DOUBLEST dval;
  93       struct type *type;
  94     } typed_val_float;
  95     struct symbol *sym;
  96     struct type *tval;
  97     struct stoken sval;
  98     struct ttype tsym;
  99     struct symtoken ssym;
 100     int voidval;
 101     const struct block *bval;
 102     enum exp_opcode opcode;
 103     struct internalvar *ivar;
 104
 105     struct type **tvec;
 106     int *ivec;
 107   }
 108
 109 %{
 110 /* YYSTYPE gets defined by %union */
 111 static int parse_number (struct parser_state *,
 112                          const char *, int, int, YYSTYPE *);
 113
 114 static struct type *current_type;
 115 static struct internalvar *intvar;
 116 static int leftdiv_is_integer;
 117 static void push_current_type (void);
 118 static void pop_current_type (void);
 119 static int search_field;
 120 %}
 121
 122 %type <voidval> exp exp1 type_exp start normal_start variable qualified_name
 123 %type <tval> type typebase
 124 /* %type <bval> block */
 125
 126 /* Fancy type parsing.  */
 127 %type <tval> ptype
 128
 129 %token <typed_val_int> INT
 130 %token <typed_val_float> FLOAT
 131
 132 /* Both NAME and TYPENAME tokens represent symbols in the input,
 133    and both convey their data as strings.
 134    But a TYPENAME is a string that happens to be defined as a typedef
 135    or builtin type name (such as int or char)
 136    and a NAME is any other symbol.
 137    Contexts where this distinction is not important can use the
 138    nonterminal "name", which matches either NAME or TYPENAME.  */
 139
 140 %token <sval> STRING
 141 %token <sval> FIELDNAME
 142 %token <voidval> COMPLETE
 143 %token <ssym> NAME /* BLOCKNAME defined below to give it higher precedence.  */
 144 %token <tsym> TYPENAME
 145 %type <sval> name
 146 %type <ssym> name_not_typename
 147
 148 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
 149    but which would parse as a valid number in the current input radix.
 150    E.g. "c" when input_radix==16.  Depending on the parse, it will be
 151    turned into a name or into a number.  */
 152
 153 %token <ssym> NAME_OR_INT
 154
 155 %token STRUCT CLASS SIZEOF COLONCOLON
 156 %token ERROR
 157
 158 /* Special type cases, put in to allow the parser to distinguish different
 159    legal basetypes.  */
 160
 161 %token <voidval> VARIABLE
 162
 163
 164 /* Object pascal */
 165 %token THIS
 166 %token <lval> TRUEKEYWORD FALSEKEYWORD
 167
 168 %left ','
 169 %left ABOVE_COMMA
 170 %right ASSIGN
 171 %left NOT
 172 %left OR
 173 %left XOR
 174 %left ANDAND
 175 %left '=' NOTEQUAL
 176 %left '<' '>' LEQ GEQ
 177 %left LSH RSH DIV MOD
 178 %left '@'
 179 %left '+' '-'
 180 %left '*' '/'
 181 %right UNARY INCREMENT DECREMENT
 182 %right ARROW '.' '[' '('
 183 %left '^'
 184 %token <ssym> BLOCKNAME
 185 %type <bval> block
 186 %left COLONCOLON
 187
 188 \f
 189 %%
 190
 191 start   :       { current_type = NULL;
 192                   intvar = NULL;
 193                   search_field = 0;
 194                   leftdiv_is_integer = 0;
 195                 }
 196                 normal_start {}
 197         ;
 198
 199 normal_start    :
 200                 exp1
 201         |       type_exp
 202         ;
 203
 204 type_exp:       type
 205                         { write_exp_elt_opcode (pstate, OP_TYPE);
 206                           write_exp_elt_type (pstate, $1);
 207                           write_exp_elt_opcode (pstate, OP_TYPE);
 208                           current_type = $1; } ;
 209
 210 /* Expressions, including the comma operator.  */
 211 exp1    :       exp
 212         |       exp1 ',' exp
 213                         { write_exp_elt_opcode (pstate, BINOP_COMMA); }
 214         ;
 215
 216 /* Expressions, not including the comma operator.  */
 217 exp     :       exp '^'   %prec UNARY
 218                         { write_exp_elt_opcode (pstate, UNOP_IND);
 219                           if (current_type)
 220                             current_type = TYPE_TARGET_TYPE (current_type); }
 221         ;
 222
 223 exp     :       '@' exp    %prec UNARY
 224                         { write_exp_elt_opcode (pstate, UNOP_ADDR);
 225                           if (current_type)
 226                             current_type = TYPE_POINTER_TYPE (current_type); }
 227         ;
 228
 229 exp     :       '-' exp    %prec UNARY
 230                         { write_exp_elt_opcode (pstate, UNOP_NEG); }
 231         ;
 232
 233 exp     :       NOT exp    %prec UNARY
 234                         { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
 235         ;
 236
 237 exp     :       INCREMENT '(' exp ')'   %prec UNARY
 238                         { write_exp_elt_opcode (pstate, UNOP_PREINCREMENT); }
 239         ;
 240
 241 exp     :       DECREMENT  '(' exp ')'   %prec UNARY
 242                         { write_exp_elt_opcode (pstate, UNOP_PREDECREMENT); }
 243         ;
 244
 245
 246 field_exp       :       exp '.' %prec UNARY
 247                         { search_field = 1; }
 248         ;
 249
 250 exp     :       field_exp FIELDNAME
 251                         { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 252                           write_exp_string (pstate, $2);
 253                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 254                           search_field = 0;
 255                           if (current_type)
 256                             {
 257                               while (TYPE_CODE (current_type)
 258                                      == TYPE_CODE_PTR)
 259                                 current_type =
 260                                   TYPE_TARGET_TYPE (current_type);
 261                               current_type = lookup_struct_elt_type (
 262                                 current_type, $2.ptr, 0);
 263                             }
 264                          }
 265         ;
 266
 267
 268 exp     :       field_exp name
 269                         { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 270                           write_exp_string (pstate, $2);
 271                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 272                           search_field = 0;
 273                           if (current_type)
 274                             {
 275                               while (TYPE_CODE (current_type)
 276                                      == TYPE_CODE_PTR)
 277                                 current_type =
 278                                   TYPE_TARGET_TYPE (current_type);
 279                               current_type = lookup_struct_elt_type (
 280                                 current_type, $2.ptr, 0);
 281                             }
 282                         }
 283         ;
 284 exp     :       field_exp  name COMPLETE
 285                         { mark_struct_expression (pstate);
 286                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 287                           write_exp_string (pstate, $2);
 288                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
 289         ;
 290 exp     :       field_exp COMPLETE
 291                         { struct stoken s;
 292                           mark_struct_expression (pstate);
 293                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 294                           s.ptr = "";
 295                           s.length = 0;
 296                           write_exp_string (pstate, s);
 297                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
 298         ;
 299
 300 exp     :       exp '['
 301                         /* We need to save the current_type value.  */
 302                         { const char *arrayname;
 303                           int arrayfieldindex;
 304                           arrayfieldindex = is_pascal_string_type (
 305                                 current_type, NULL, NULL,
 306                                 NULL, NULL, &arrayname);
 307                           if (arrayfieldindex)
 308                             {
 309                               struct stoken stringsval;
 310                               char *buf;
 311
 312                               buf = (char *) alloca (strlen (arrayname) + 1);
 313                               stringsval.ptr = buf;
 314                               stringsval.length = strlen (arrayname);
 315                               strcpy (buf, arrayname);
 316                               current_type = TYPE_FIELD_TYPE (current_type,
 317                                 arrayfieldindex - 1);
 318                               write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 319                               write_exp_string (pstate, stringsval);
 320                               write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 321                             }
 322                           push_current_type ();  }
 323                 exp1 ']'
 324                         { pop_current_type ();
 325                           write_exp_elt_opcode (pstate, BINOP_SUBSCRIPT);
 326                           if (current_type)
 327                             current_type = TYPE_TARGET_TYPE (current_type); }
 328         ;
 329
 330 exp     :       exp '('
 331                         /* This is to save the value of arglist_len
 332                            being accumulated by an outer function call.  */
 333                         { push_current_type ();
 334                           start_arglist (); }
 335                 arglist ')'     %prec ARROW
 336                         { write_exp_elt_opcode (pstate, OP_FUNCALL);
 337                           write_exp_elt_longcst (pstate,
 338                                                  (LONGEST) end_arglist ());
 339                           write_exp_elt_opcode (pstate, OP_FUNCALL);
 340                           pop_current_type ();
 341                           if (current_type)
 342                             current_type = TYPE_TARGET_TYPE (current_type);
 343                         }
 344         ;
 345
 346 arglist :
 347          | exp
 348                         { arglist_len = 1; }
 349          | arglist ',' exp   %prec ABOVE_COMMA
 350                         { arglist_len++; }
 351         ;
 352
 353 exp     :       type '(' exp ')' %prec UNARY
 354                         { if (current_type)
 355                             {
 356                               /* Allow automatic dereference of classes.  */
 357                               if ((TYPE_CODE (current_type) == TYPE_CODE_PTR)
 358                                   && (TYPE_CODE (TYPE_TARGET_TYPE (current_type)) == TYPE_CODE_STRUCT)
 359                                   && (TYPE_CODE ($1) == TYPE_CODE_STRUCT))
 360                                 write_exp_elt_opcode (pstate, UNOP_IND);
 361                             }
 362                           write_exp_elt_opcode (pstate, UNOP_CAST);
 363                           write_exp_elt_type (pstate, $1);
 364                           write_exp_elt_opcode (pstate, UNOP_CAST);
 365                           current_type = $1; }
 366         ;
 367
 368 exp     :       '(' exp1 ')'
 369                         { }
 370         ;
 371
 372 /* Binary operators in order of decreasing precedence.  */
 373
 374 exp     :       exp '*' exp
 375                         { write_exp_elt_opcode (pstate, BINOP_MUL); }
 376         ;
 377
 378 exp     :       exp '/' {
 379                           if (current_type && is_integral_type (current_type))
 380                             leftdiv_is_integer = 1;
 381                         }
 382                 exp
 383                         {
 384                           if (leftdiv_is_integer && current_type
 385                               && is_integral_type (current_type))
 386                             {
 387                               write_exp_elt_opcode (pstate, UNOP_CAST);
 388                               write_exp_elt_type (pstate,
 389                                                   parse_type (pstate)
 390                                                   ->builtin_long_double);
 391                               current_type
 392                                 = parse_type (pstate)->builtin_long_double;
 393                               write_exp_elt_opcode (pstate, UNOP_CAST);
 394                               leftdiv_is_integer = 0;
 395                             }
 396
 397                           write_exp_elt_opcode (pstate, BINOP_DIV);
 398                         }
 399         ;
 400
 401 exp     :       exp DIV exp
 402                         { write_exp_elt_opcode (pstate, BINOP_INTDIV); }
 403         ;
 404
 405 exp     :       exp MOD exp
 406                         { write_exp_elt_opcode (pstate, BINOP_REM); }
 407         ;
 408
 409 exp     :       exp '+' exp
 410                         { write_exp_elt_opcode (pstate, BINOP_ADD); }
 411         ;
 412
 413 exp     :       exp '-' exp
 414                         { write_exp_elt_opcode (pstate, BINOP_SUB); }
 415         ;
 416
 417 exp     :       exp LSH exp
 418                         { write_exp_elt_opcode (pstate, BINOP_LSH); }
 419         ;
 420
 421 exp     :       exp RSH exp
 422                         { write_exp_elt_opcode (pstate, BINOP_RSH); }
 423         ;
 424
 425 exp     :       exp '=' exp
 426                         { write_exp_elt_opcode (pstate, BINOP_EQUAL);
 427                           current_type = parse_type (pstate)->builtin_bool;
 428                         }
 429         ;
 430
 431 exp     :       exp NOTEQUAL exp
 432                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL);
 433                           current_type = parse_type (pstate)->builtin_bool;
 434                         }
 435         ;
 436
 437 exp     :       exp LEQ exp
 438                         { write_exp_elt_opcode (pstate, BINOP_LEQ);
 439                           current_type = parse_type (pstate)->builtin_bool;
 440                         }
 441         ;
 442
 443 exp     :       exp GEQ exp
 444                         { write_exp_elt_opcode (pstate, BINOP_GEQ);
 445                           current_type = parse_type (pstate)->builtin_bool;
 446                         }
 447         ;
 448
 449 exp     :       exp '<' exp
 450                         { write_exp_elt_opcode (pstate, BINOP_LESS);
 451                           current_type = parse_type (pstate)->builtin_bool;
 452                         }
 453         ;
 454
 455 exp     :       exp '>' exp
 456                         { write_exp_elt_opcode (pstate, BINOP_GTR);
 457                           current_type = parse_type (pstate)->builtin_bool;
 458                         }
 459         ;
 460
 461 exp     :       exp ANDAND exp
 462                         { write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
 463         ;
 464
 465 exp     :       exp XOR exp
 466                         { write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
 467         ;
 468
 469 exp     :       exp OR exp
 470                         { write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
 471         ;
 472
 473 exp     :       exp ASSIGN exp
 474                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
 475         ;
 476
 477 exp     :       TRUEKEYWORD
 478                         { write_exp_elt_opcode (pstate, OP_BOOL);
 479                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 480                           current_type = parse_type (pstate)->builtin_bool;
 481                           write_exp_elt_opcode (pstate, OP_BOOL); }
 482         ;
 483
 484 exp     :       FALSEKEYWORD
 485                         { write_exp_elt_opcode (pstate, OP_BOOL);
 486                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 487                           current_type = parse_type (pstate)->builtin_bool;
 488                           write_exp_elt_opcode (pstate, OP_BOOL); }
 489         ;
 490
 491 exp     :       INT
 492                         { write_exp_elt_opcode (pstate, OP_LONG);
 493                           write_exp_elt_type (pstate, $1.type);
 494                           current_type = $1.type;
 495                           write_exp_elt_longcst (pstate, (LONGEST)($1.val));
 496                           write_exp_elt_opcode (pstate, OP_LONG); }
 497         ;
 498
 499 exp     :       NAME_OR_INT
 500                         { YYSTYPE val;
 501                           parse_number (pstate, $1.stoken.ptr,
 502                                         $1.stoken.length, 0, &val);
 503                           write_exp_elt_opcode (pstate, OP_LONG);
 504                           write_exp_elt_type (pstate, val.typed_val_int.type);
 505                           current_type = val.typed_val_int.type;
 506                           write_exp_elt_longcst (pstate, (LONGEST)
 507                                                  val.typed_val_int.val);
 508                           write_exp_elt_opcode (pstate, OP_LONG);
 509                         }
 510         ;
 511
 512
 513 exp     :       FLOAT
 514                         { write_exp_elt_opcode (pstate, OP_DOUBLE);
 515                           write_exp_elt_type (pstate, $1.type);
 516                           current_type = $1.type;
 517                           write_exp_elt_dblcst (pstate, $1.dval);
 518                           write_exp_elt_opcode (pstate, OP_DOUBLE); }
 519         ;
 520
 521 exp     :       variable
 522         ;
 523
 524 exp     :       VARIABLE
 525                         /* Already written by write_dollar_variable.
 526                            Handle current_type.  */
 527                         {  if (intvar) {
 528                              struct value * val, * mark;
 529
 530                              mark = value_mark ();
 531                              val = value_of_internalvar (parse_gdbarch (pstate),
 532                                                          intvar);
 533                              current_type = value_type (val);
 534                              value_release_to_mark (mark);
 535                            }
 536                         }
 537         ;
 538
 539 exp     :       SIZEOF '(' type ')'     %prec UNARY
 540                         { write_exp_elt_opcode (pstate, OP_LONG);
 541                           write_exp_elt_type (pstate,
 542                                             parse_type (pstate)->builtin_int);
 543                           current_type = parse_type (pstate)->builtin_int;
 544                           $3 = check_typedef ($3);
 545                           write_exp_elt_longcst (pstate,
 546                                                  (LONGEST) TYPE_LENGTH ($3));
 547                           write_exp_elt_opcode (pstate, OP_LONG); }
 548         ;
 549
 550 exp     :       SIZEOF  '(' exp ')'      %prec UNARY
 551                         { write_exp_elt_opcode (pstate, UNOP_SIZEOF);
 552                           current_type = parse_type (pstate)->builtin_int; }
 553
 554 exp     :       STRING
 555                         { /* C strings are converted into array constants with
 556                              an explicit null byte added at the end.  Thus
 557                              the array upper bound is the string length.
 558                              There is no such thing in C as a completely empty
 559                              string.  */
 560                           const char *sp = $1.ptr; int count = $1.length;
 561
 562                           while (count-- > 0)
 563                             {
 564                               write_exp_elt_opcode (pstate, OP_LONG);
 565                               write_exp_elt_type (pstate,
 566                                                   parse_type (pstate)
 567                                                   ->builtin_char);
 568                               write_exp_elt_longcst (pstate,
 569                                                      (LONGEST) (*sp++));
 570                               write_exp_elt_opcode (pstate, OP_LONG);
 571                             }
 572                           write_exp_elt_opcode (pstate, OP_LONG);
 573                           write_exp_elt_type (pstate,
 574                                               parse_type (pstate)
 575                                               ->builtin_char);
 576                           write_exp_elt_longcst (pstate, (LONGEST)'\0');
 577                           write_exp_elt_opcode (pstate, OP_LONG);
 578                           write_exp_elt_opcode (pstate, OP_ARRAY);
 579                           write_exp_elt_longcst (pstate, (LONGEST) 0);
 580                           write_exp_elt_longcst (pstate,
 581                                                  (LONGEST) ($1.length));
 582                           write_exp_elt_opcode (pstate, OP_ARRAY); }
 583         ;
 584
 585 /* Object pascal  */
 586 exp     :       THIS
 587                         {
 588                           struct value * this_val;
 589                           struct type * this_type;
 590                           write_exp_elt_opcode (pstate, OP_THIS);
 591                           write_exp_elt_opcode (pstate, OP_THIS);
 592                           /* We need type of this.  */
 593                           this_val
 594                             = value_of_this_silent (parse_language (pstate));
 595                           if (this_val)
 596                             this_type = value_type (this_val);
 597                           else
 598                             this_type = NULL;
 599                           if (this_type)
 600                             {
 601                               if (TYPE_CODE (this_type) == TYPE_CODE_PTR)
 602                                 {
 603                                   this_type = TYPE_TARGET_TYPE (this_type);
 604                                   write_exp_elt_opcode (pstate, UNOP_IND);
 605                                 }
 606                             }
 607
 608                           current_type = this_type;
 609                         }
 610         ;
 611
 612 /* end of object pascal.  */
 613
 614 block   :       BLOCKNAME
 615                         {
 616                           if ($1.sym.symbol != 0)
 617                               $$ = SYMBOL_BLOCK_VALUE ($1.sym.symbol);
 618                           else
 619                             {
 620                               struct symtab *tem =
 621                                   lookup_symtab (copy_name ($1.stoken));
 622                               if (tem)
 623                                 $$ = BLOCKVECTOR_BLOCK (SYMTAB_BLOCKVECTOR (tem),
 624                                                         STATIC_BLOCK);
 625                               else
 626                                 error (_("No file or function \"%s\"."),
 627                                        copy_name ($1.stoken));
 628                             }
 629                         }
 630         ;
 631
 632 block   :       block COLONCOLON name
 633                         { struct symbol *tem
 634                             = lookup_symbol (copy_name ($3), $1,
 635                                              VAR_DOMAIN, NULL).symbol;
 636
 637                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 638                             error (_("No function \"%s\" in specified context."),
 639                                    copy_name ($3));
 640                           $$ = SYMBOL_BLOCK_VALUE (tem); }
 641         ;
 642
 643 variable:       block COLONCOLON name
 644                         { struct block_symbol sym;
 645
 646                           sym = lookup_symbol (copy_name ($3), $1,
 647                                                VAR_DOMAIN, NULL);
 648                           if (sym.symbol == 0)
 649                             error (_("No symbol \"%s\" in specified context."),
 650                                    copy_name ($3));
 651
 652                           write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 653                           write_exp_elt_block (pstate, sym.block);
 654                           write_exp_elt_sym (pstate, sym.symbol);
 655                           write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
 656         ;
 657
 658 qualified_name: typebase COLONCOLON name
 659                         {
 660                           struct type *type = $1;
 661
 662                           if (TYPE_CODE (type) != TYPE_CODE_STRUCT
 663                               && TYPE_CODE (type) != TYPE_CODE_UNION)
 664                             error (_("`%s' is not defined as an aggregate type."),
 665                                    TYPE_NAME (type));
 666
 667                           write_exp_elt_opcode (pstate, OP_SCOPE);
 668                           write_exp_elt_type (pstate, type);
 669                           write_exp_string (pstate, $3);
 670                           write_exp_elt_opcode (pstate, OP_SCOPE);
 671                         }
 672         ;
 673
 674 variable:       qualified_name
 675         |       COLONCOLON name
 676                         {
 677                           char *name = copy_name ($2);
 678                           struct symbol *sym;
 679                           struct bound_minimal_symbol msymbol;
 680
 681                           sym =
 682                             lookup_symbol (name, (const struct block *) NULL,
 683                                            VAR_DOMAIN, NULL).symbol;
 684                           if (sym)
 685                             {
 686                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 687                               write_exp_elt_block (pstate, NULL);
 688                               write_exp_elt_sym (pstate, sym);
 689                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 690                               break;
 691                             }
 692
 693                           msymbol = lookup_bound_minimal_symbol (name);
 694                           if (msymbol.minsym != NULL)
 695                             write_exp_msymbol (pstate, msymbol);
 696                           else if (!have_full_symbols ()
 697                                    && !have_partial_symbols ())
 698                             error (_("No symbol table is loaded.  "
 699                                    "Use the \"file\" command."));
 700                           else
 701                             error (_("No symbol \"%s\" in current context."),
 702                                    name);
 703                         }
 704         ;
 705
 706 variable:       name_not_typename
 707                         { struct block_symbol sym = $1.sym;
 708
 709                           if (sym.symbol)
 710                             {
 711                               if (symbol_read_needs_frame (sym.symbol))
 712                                 {
 713                                   if (innermost_block == 0
 714                                       || contained_in (sym.block,
 715                                                        innermost_block))
 716                                     innermost_block = sym.block;
 717                                 }
 718
 719                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 720                               write_exp_elt_block (pstate, sym.block);
 721                               write_exp_elt_sym (pstate, sym.symbol);
 722                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 723                               current_type = sym.symbol->type; }
 724                           else if ($1.is_a_field_of_this)
 725                             {
 726                               struct value * this_val;
 727                               struct type * this_type;
 728                               /* Object pascal: it hangs off of `this'.  Must
 729                                  not inadvertently convert from a method call
 730                                  to data ref.  */
 731                               if (innermost_block == 0
 732                                   || contained_in (sym.block,
 733                                                    innermost_block))
 734                                 innermost_block = sym.block;
 735                               write_exp_elt_opcode (pstate, OP_THIS);
 736                               write_exp_elt_opcode (pstate, OP_THIS);
 737                               write_exp_elt_opcode (pstate, STRUCTOP_PTR);
 738                               write_exp_string (pstate, $1.stoken);
 739                               write_exp_elt_opcode (pstate, STRUCTOP_PTR);
 740                               /* We need type of this.  */
 741                               this_val
 742                                 = value_of_this_silent (parse_language (pstate));
 743                               if (this_val)
 744                                 this_type = value_type (this_val);
 745                               else
 746                                 this_type = NULL;
 747                               if (this_type)
 748                                 current_type = lookup_struct_elt_type (
 749                                   this_type,
 750                                   copy_name ($1.stoken), 0);
 751                               else
 752                                 current_type = NULL;
 753                             }
 754                           else
 755                             {
 756                               struct bound_minimal_symbol msymbol;
 757                               char *arg = copy_name ($1.stoken);
 758
 759                               msymbol =
 760                                 lookup_bound_minimal_symbol (arg);
 761                               if (msymbol.minsym != NULL)
 762                                 write_exp_msymbol (pstate, msymbol);
 763                               else if (!have_full_symbols ()
 764                                        && !have_partial_symbols ())
 765                                 error (_("No symbol table is loaded.  "
 766                                        "Use the \"file\" command."));
 767                               else
 768                                 error (_("No symbol \"%s\" in current context."),
 769                                        copy_name ($1.stoken));
 770                             }
 771                         }
 772         ;
 773
 774
 775 ptype   :       typebase
 776         ;
 777
 778 /* We used to try to recognize more pointer to member types here, but
 779    that didn't work (shift/reduce conflicts meant that these rules never
 780    got executed).  The problem is that
 781      int (foo::bar::baz::bizzle)
 782    is a function type but
 783      int (foo::bar::baz::bizzle::*)
 784    is a pointer to member type.  Stroustrup loses again!  */
 785
 786 type    :       ptype
 787         ;
 788
 789 typebase  /* Implements (approximately): (type-qualifier)* type-specifier */
 790         :       '^' typebase
 791                         { $$ = lookup_pointer_type ($2); }
 792         |       TYPENAME
 793                         { $$ = $1.type; }
 794         |       STRUCT name
 795                         { $$ = lookup_struct (copy_name ($2),
 796                                               expression_context_block); }
 797         |       CLASS name
 798                         { $$ = lookup_struct (copy_name ($2),
 799                                               expression_context_block); }
 800         /* "const" and "volatile" are curently ignored.  A type qualifier
 801            after the type is handled in the ptype rule.  I think these could
 802            be too.  */
 803         ;
 804
 805 name    :       NAME { $$ = $1.stoken; }
 806         |       BLOCKNAME { $$ = $1.stoken; }
 807         |       TYPENAME { $$ = $1.stoken; }
 808         |       NAME_OR_INT  { $$ = $1.stoken; }
 809         ;
 810
 811 name_not_typename :     NAME
 812         |       BLOCKNAME
 813 /* These would be useful if name_not_typename was useful, but it is just
 814    a fake for "variable", so these cause reduce/reduce conflicts because
 815    the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
 816    =exp) or just an exp.  If name_not_typename was ever used in an lvalue
 817    context where only a name could occur, this might be useful.
 818         |       NAME_OR_INT
 819  */
 820         ;
 821
 822 %%
 823
 824 /* Take care of parsing a number (anything that starts with a digit).
 825    Set yylval and return the token type; update lexptr.
 826    LEN is the number of characters in it.  */
 827
 828 /*** Needs some error checking for the float case ***/
 829
 830 static int
 831 parse_number (struct parser_state *par_state,
 832               const char *p, int len, int parsed_float, YYSTYPE *putithere)
 833 {
 834   /* FIXME: Shouldn't these be unsigned?  We don't deal with negative values
 835      here, and we do kind of silly things like cast to unsigned.  */
 836   LONGEST n = 0;
 837   LONGEST prevn = 0;
 838   ULONGEST un;
 839
 840   int i = 0;
 841   int c;
 842   int base = input_radix;
 843   int unsigned_p = 0;
 844
 845   /* Number of "L" suffixes encountered.  */
 846   int long_p = 0;
 847
 848   /* We have found a "L" or "U" suffix.  */
 849   int found_suffix = 0;
 850
 851   ULONGEST high_bit;
 852   struct type *signed_type;
 853   struct type *unsigned_type;
 854
 855   if (parsed_float)
 856     {
 857       if (! parse_c_float (parse_gdbarch (par_state), p, len,
 858                            &putithere->typed_val_float.dval,
 859                            &putithere->typed_val_float.type))
 860         return ERROR;
 861       return FLOAT;
 862     }
 863
 864   /* Handle base-switching prefixes 0x, 0t, 0d, 0.  */
 865   if (p[0] == '0')
 866     switch (p[1])
 867       {
 868       case 'x':
 869       case 'X':
 870         if (len >= 3)
 871           {
 872             p += 2;
 873             base = 16;
 874             len -= 2;
 875           }
 876         break;
 877
 878       case 't':
 879       case 'T':
 880       case 'd':
 881       case 'D':
 882         if (len >= 3)
 883           {
 884             p += 2;
 885             base = 10;
 886             len -= 2;
 887           }
 888         break;
 889
 890       default:
 891         base = 8;
 892         break;
 893       }
 894
 895   while (len-- > 0)
 896     {
 897       c = *p++;
 898       if (c >= 'A' && c <= 'Z')
 899         c += 'a' - 'A';
 900       if (c != 'l' && c != 'u')
 901         n *= base;
 902       if (c >= '0' && c <= '9')
 903         {
 904           if (found_suffix)
 905             return ERROR;
 906           n += i = c - '0';
 907         }
 908       else
 909         {
 910           if (base > 10 && c >= 'a' && c <= 'f')
 911             {
 912               if (found_suffix)
 913                 return ERROR;
 914               n += i = c - 'a' + 10;
 915             }
 916           else if (c == 'l')
 917             {
 918               ++long_p;
 919               found_suffix = 1;
 920             }
 921           else if (c == 'u')
 922             {
 923               unsigned_p = 1;
 924               found_suffix = 1;
 925             }
 926           else
 927             return ERROR;       /* Char not a digit */
 928         }
 929       if (i >= base)
 930         return ERROR;           /* Invalid digit in this base.  */
 931
 932       /* Portably test for overflow (only works for nonzero values, so make
 933          a second check for zero).  FIXME: Can't we just make n and prevn
 934          unsigned and avoid this?  */
 935       if (c != 'l' && c != 'u' && (prevn >= n) && n != 0)
 936         unsigned_p = 1;         /* Try something unsigned.  */
 937
 938       /* Portably test for unsigned overflow.
 939          FIXME: This check is wrong; for example it doesn't find overflow
 940          on 0x123456789 when LONGEST is 32 bits.  */
 941       if (c != 'l' && c != 'u' && n != 0)
 942         {
 943           if ((unsigned_p && (ULONGEST) prevn >= (ULONGEST) n))
 944             error (_("Numeric constant too large."));
 945         }
 946       prevn = n;
 947     }
 948
 949   /* An integer constant is an int, a long, or a long long.  An L
 950      suffix forces it to be long; an LL suffix forces it to be long
 951      long.  If not forced to a larger size, it gets the first type of
 952      the above that it fits in.  To figure out whether it fits, we
 953      shift it right and see whether anything remains.  Note that we
 954      can't shift sizeof (LONGEST) * HOST_CHAR_BIT bits or more in one
 955      operation, because many compilers will warn about such a shift
 956      (which always produces a zero result).  Sometimes gdbarch_int_bit
 957      or gdbarch_long_bit will be that big, sometimes not.  To deal with
 958      the case where it is we just always shift the value more than
 959      once, with fewer bits each time.  */
 960
 961   un = (ULONGEST)n >> 2;
 962   if (long_p == 0
 963       && (un >> (gdbarch_int_bit (parse_gdbarch (par_state)) - 2)) == 0)
 964     {
 965       high_bit
 966         = ((ULONGEST)1) << (gdbarch_int_bit (parse_gdbarch (par_state)) - 1);
 967
 968       /* A large decimal (not hex or octal) constant (between INT_MAX
 969          and UINT_MAX) is a long or unsigned long, according to ANSI,
 970          never an unsigned int, but this code treats it as unsigned
 971          int.  This probably should be fixed.  GCC gives a warning on
 972          such constants.  */
 973
 974       unsigned_type = parse_type (par_state)->builtin_unsigned_int;
 975       signed_type = parse_type (par_state)->builtin_int;
 976     }
 977   else if (long_p <= 1
 978            && (un >> (gdbarch_long_bit (parse_gdbarch (par_state)) - 2)) == 0)
 979     {
 980       high_bit
 981         = ((ULONGEST)1) << (gdbarch_long_bit (parse_gdbarch (par_state)) - 1);
 982       unsigned_type = parse_type (par_state)->builtin_unsigned_long;
 983       signed_type = parse_type (par_state)->builtin_long;
 984     }
 985   else
 986     {
 987       int shift;
 988       if (sizeof (ULONGEST) * HOST_CHAR_BIT
 989           < gdbarch_long_long_bit (parse_gdbarch (par_state)))
 990         /* A long long does not fit in a LONGEST.  */
 991         shift = (sizeof (ULONGEST) * HOST_CHAR_BIT - 1);
 992       else
 993         shift = (gdbarch_long_long_bit (parse_gdbarch (par_state)) - 1);
 994       high_bit = (ULONGEST) 1 << shift;
 995       unsigned_type = parse_type (par_state)->builtin_unsigned_long_long;
 996       signed_type = parse_type (par_state)->builtin_long_long;
 997     }
 998
 999    putithere->typed_val_int.val = n;
1000
1001    /* If the high bit of the worked out type is set then this number
1002       has to be unsigned.  */
1003
1004    if (unsigned_p || (n & high_bit))
1005      {
1006        putithere->typed_val_int.type = unsigned_type;
1007      }
1008    else
1009      {
1010        putithere->typed_val_int.type = signed_type;
1011      }
1012
1013    return INT;
1014 }
1015
1016
1017 struct type_push
1018 {
1019   struct type *stored;
1020   struct type_push *next;
1021 };
1022
1023 static struct type_push *tp_top = NULL;
1024
1025 static void
1026 push_current_type (void)
1027 {
1028   struct type_push *tpnew;
1029   tpnew = (struct type_push *) malloc (sizeof (struct type_push));
1030   tpnew->next = tp_top;
1031   tpnew->stored = current_type;
1032   current_type = NULL;
1033   tp_top = tpnew;
1034 }
1035
1036 static void
1037 pop_current_type (void)
1038 {
1039   struct type_push *tp = tp_top;
1040   if (tp)
1041     {
1042       current_type = tp->stored;
1043       tp_top = tp->next;
1044       free (tp);
1045     }
1046 }
1047
1048 struct token
1049 {
1050   const char *oper;
1051   int token;
1052   enum exp_opcode opcode;
1053 };
1054
1055 static const struct token tokentab3[] =
1056   {
1057     {"shr", RSH, BINOP_END},
1058     {"shl", LSH, BINOP_END},
1059     {"and", ANDAND, BINOP_END},
1060     {"div", DIV, BINOP_END},
1061     {"not", NOT, BINOP_END},
1062     {"mod", MOD, BINOP_END},
1063     {"inc", INCREMENT, BINOP_END},
1064     {"dec", DECREMENT, BINOP_END},
1065     {"xor", XOR, BINOP_END}
1066   };
1067
1068 static const struct token tokentab2[] =
1069   {
1070     {"or", OR, BINOP_END},
1071     {"<>", NOTEQUAL, BINOP_END},
1072     {"<=", LEQ, BINOP_END},
1073     {">=", GEQ, BINOP_END},
1074     {":=", ASSIGN, BINOP_END},
1075     {"::", COLONCOLON, BINOP_END} };
1076
1077 /* Allocate uppercased var: */
1078 /* make an uppercased copy of tokstart.  */
1079 static char *
1080 uptok (const char *tokstart, int namelen)
1081 {
1082   int i;
1083   char *uptokstart = (char *)malloc(namelen+1);
1084   for (i = 0;i <= namelen;i++)
1085     {
1086       if ((tokstart[i]>='a' && tokstart[i]<='z'))
1087         uptokstart[i] = tokstart[i]-('a'-'A');
1088       else
1089         uptokstart[i] = tokstart[i];
1090     }
1091   uptokstart[namelen]='\0';
1092   return uptokstart;
1093 }
1094
1095 /* Read one token, getting characters through lexptr.  */
1096
1097 static int
1098 yylex (void)
1099 {
1100   int c;
1101   int namelen;
1102   unsigned int i;
1103   const char *tokstart;
1104   char *uptokstart;
1105   const char *tokptr;
1106   int explen, tempbufindex;
1107   static char *tempbuf;
1108   static int tempbufsize;
1109
1110  retry:
1111
1112   prev_lexptr = lexptr;
1113
1114   tokstart = lexptr;
1115   explen = strlen (lexptr);
1116
1117   /* See if it is a special token of length 3.  */
1118   if (explen > 2)
1119     for (i = 0; i < sizeof (tokentab3) / sizeof (tokentab3[0]); i++)
1120       if (strncasecmp (tokstart, tokentab3[i].oper, 3) == 0
1121           && (!isalpha (tokentab3[i].oper[0]) || explen == 3
1122               || (!isalpha (tokstart[3])
1123                   && !isdigit (tokstart[3]) && tokstart[3] != '_')))
1124         {
1125           lexptr += 3;
1126           yylval.opcode = tokentab3[i].opcode;
1127           return tokentab3[i].token;
1128         }
1129
1130   /* See if it is a special token of length 2.  */
1131   if (explen > 1)
1132   for (i = 0; i < sizeof (tokentab2) / sizeof (tokentab2[0]); i++)
1133       if (strncasecmp (tokstart, tokentab2[i].oper, 2) == 0
1134           && (!isalpha (tokentab2[i].oper[0]) || explen == 2
1135               || (!isalpha (tokstart[2])
1136                   && !isdigit (tokstart[2]) && tokstart[2] != '_')))
1137         {
1138           lexptr += 2;
1139           yylval.opcode = tokentab2[i].opcode;
1140           return tokentab2[i].token;
1141         }
1142
1143   switch (c = *tokstart)
1144     {
1145     case 0:
1146       if (search_field && parse_completion)
1147         return COMPLETE;
1148       else
1149        return 0;
1150
1151     case ' ':
1152     case '\t':
1153     case '\n':
1154       lexptr++;
1155       goto retry;
1156
1157     case '\'':
1158       /* We either have a character constant ('0' or '\177' for example)
1159          or we have a quoted symbol reference ('foo(int,int)' in object pascal
1160          for example).  */
1161       lexptr++;
1162       c = *lexptr++;
1163       if (c == '\\')
1164         c = parse_escape (parse_gdbarch (pstate), &lexptr);
1165       else if (c == '\'')
1166         error (_("Empty character constant."));
1167
1168       yylval.typed_val_int.val = c;
1169       yylval.typed_val_int.type = parse_type (pstate)->builtin_char;
1170
1171       c = *lexptr++;
1172       if (c != '\'')
1173         {
1174           namelen = skip_quoted (tokstart) - tokstart;
1175           if (namelen > 2)
1176             {
1177               lexptr = tokstart + namelen;
1178               if (lexptr[-1] != '\'')
1179                 error (_("Unmatched single quote."));
1180               namelen -= 2;
1181               tokstart++;
1182               uptokstart = uptok(tokstart,namelen);
1183               goto tryname;
1184             }
1185           error (_("Invalid character constant."));
1186         }
1187       return INT;
1188
1189     case '(':
1190       paren_depth++;
1191       lexptr++;
1192       return c;
1193
1194     case ')':
1195       if (paren_depth == 0)
1196         return 0;
1197       paren_depth--;
1198       lexptr++;
1199       return c;
1200
1201     case ',':
1202       if (comma_terminates && paren_depth == 0)
1203         return 0;
1204       lexptr++;
1205       return c;
1206
1207     case '.':
1208       /* Might be a floating point number.  */
1209       if (lexptr[1] < '0' || lexptr[1] > '9')
1210         {
1211           goto symbol;          /* Nope, must be a symbol.  */
1212         }
1213
1214       /* FALL THRU into number case.  */
1215
1216     case '0':
1217     case '1':
1218     case '2':
1219     case '3':
1220     case '4':
1221     case '5':
1222     case '6':
1223     case '7':
1224     case '8':
1225     case '9':
1226       {
1227         /* It's a number.  */
1228         int got_dot = 0, got_e = 0, toktype;
1229         const char *p = tokstart;
1230         int hex = input_radix > 10;
1231
1232         if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1233           {
1234             p += 2;
1235             hex = 1;
1236           }
1237         else if (c == '0' && (p[1]=='t' || p[1]=='T'
1238                               || p[1]=='d' || p[1]=='D'))
1239           {
1240             p += 2;
1241             hex = 0;
1242           }
1243
1244         for (;; ++p)
1245           {
1246             /* This test includes !hex because 'e' is a valid hex digit
1247                and thus does not indicate a floating point number when
1248                the radix is hex.  */
1249             if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1250               got_dot = got_e = 1;
1251             /* This test does not include !hex, because a '.' always indicates
1252                a decimal floating point number regardless of the radix.  */
1253             else if (!got_dot && *p == '.')
1254               got_dot = 1;
1255             else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
1256                      && (*p == '-' || *p == '+'))
1257               /* This is the sign of the exponent, not the end of the
1258                  number.  */
1259               continue;
1260             /* We will take any letters or digits.  parse_number will
1261                complain if past the radix, or if L or U are not final.  */
1262             else if ((*p < '0' || *p > '9')
1263                      && ((*p < 'a' || *p > 'z')
1264                                   && (*p < 'A' || *p > 'Z')))
1265               break;
1266           }
1267         toktype = parse_number (pstate, tokstart,
1268                                 p - tokstart, got_dot | got_e, &yylval);
1269         if (toktype == ERROR)
1270           {
1271             char *err_copy = (char *) alloca (p - tokstart + 1);
1272
1273             memcpy (err_copy, tokstart, p - tokstart);
1274             err_copy[p - tokstart] = 0;
1275             error (_("Invalid number \"%s\"."), err_copy);
1276           }
1277         lexptr = p;
1278         return toktype;
1279       }
1280
1281     case '+':
1282     case '-':
1283     case '*':
1284     case '/':
1285     case '|':
1286     case '&':
1287     case '^':
1288     case '~':
1289     case '!':
1290     case '@':
1291     case '<':
1292     case '>':
1293     case '[':
1294     case ']':
1295     case '?':
1296     case ':':
1297     case '=':
1298     case '{':
1299     case '}':
1300     symbol:
1301       lexptr++;
1302       return c;
1303
1304     case '"':
1305
1306       /* Build the gdb internal form of the input string in tempbuf,
1307          translating any standard C escape forms seen.  Note that the
1308          buffer is null byte terminated *only* for the convenience of
1309          debugging gdb itself and printing the buffer contents when
1310          the buffer contains no embedded nulls.  Gdb does not depend
1311          upon the buffer being null byte terminated, it uses the length
1312          string instead.  This allows gdb to handle C strings (as well
1313          as strings in other languages) with embedded null bytes.  */
1314
1315       tokptr = ++tokstart;
1316       tempbufindex = 0;
1317
1318       do {
1319         /* Grow the static temp buffer if necessary, including allocating
1320            the first one on demand.  */
1321         if (tempbufindex + 1 >= tempbufsize)
1322           {
1323             tempbuf = (char *) realloc (tempbuf, tempbufsize += 64);
1324           }
1325
1326         switch (*tokptr)
1327           {
1328           case '\0':
1329           case '"':
1330             /* Do nothing, loop will terminate.  */
1331             break;
1332           case '\\':
1333             ++tokptr;
1334             c = parse_escape (parse_gdbarch (pstate), &tokptr);
1335             if (c == -1)
1336               {
1337                 continue;
1338               }
1339             tempbuf[tempbufindex++] = c;
1340             break;
1341           default:
1342             tempbuf[tempbufindex++] = *tokptr++;
1343             break;
1344           }
1345       } while ((*tokptr != '"') && (*tokptr != '\0'));
1346       if (*tokptr++ != '"')
1347         {
1348           error (_("Unterminated string in expression."));
1349         }
1350       tempbuf[tempbufindex] = '\0';     /* See note above.  */
1351       yylval.sval.ptr = tempbuf;
1352       yylval.sval.length = tempbufindex;
1353       lexptr = tokptr;
1354       return (STRING);
1355     }
1356
1357   if (!(c == '_' || c == '$'
1358         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1359     /* We must have come across a bad character (e.g. ';').  */
1360     error (_("Invalid character '%c' in expression."), c);
1361
1362   /* It's a name.  See how long it is.  */
1363   namelen = 0;
1364   for (c = tokstart[namelen];
1365        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1366         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c == '<');)
1367     {
1368       /* Template parameter lists are part of the name.
1369          FIXME: This mishandles `print $a<4&&$a>3'.  */
1370       if (c == '<')
1371         {
1372           int i = namelen;
1373           int nesting_level = 1;
1374           while (tokstart[++i])
1375             {
1376               if (tokstart[i] == '<')
1377                 nesting_level++;
1378               else if (tokstart[i] == '>')
1379                 {
1380                   if (--nesting_level == 0)
1381                     break;
1382                 }
1383             }
1384           if (tokstart[i] == '>')
1385             namelen = i;
1386           else
1387             break;
1388         }
1389
1390       /* do NOT uppercase internals because of registers !!!  */
1391       c = tokstart[++namelen];
1392     }
1393
1394   uptokstart = uptok(tokstart,namelen);
1395
1396   /* The token "if" terminates the expression and is NOT
1397      removed from the input stream.  */
1398   if (namelen == 2 && uptokstart[0] == 'I' && uptokstart[1] == 'F')
1399     {
1400       free (uptokstart);
1401       return 0;
1402     }
1403
1404   lexptr += namelen;
1405
1406   tryname:
1407
1408   /* Catch specific keywords.  Should be done with a data structure.  */
1409   switch (namelen)
1410     {
1411     case 6:
1412       if (strcmp (uptokstart, "OBJECT") == 0)
1413         {
1414           free (uptokstart);
1415           return CLASS;
1416         }
1417       if (strcmp (uptokstart, "RECORD") == 0)
1418         {
1419           free (uptokstart);
1420           return STRUCT;
1421         }
1422       if (strcmp (uptokstart, "SIZEOF") == 0)
1423         {
1424           free (uptokstart);
1425           return SIZEOF;
1426         }
1427       break;
1428     case 5:
1429       if (strcmp (uptokstart, "CLASS") == 0)
1430         {
1431           free (uptokstart);
1432           return CLASS;
1433         }
1434       if (strcmp (uptokstart, "FALSE") == 0)
1435         {
1436           yylval.lval = 0;
1437           free (uptokstart);
1438           return FALSEKEYWORD;
1439         }
1440       break;
1441     case 4:
1442       if (strcmp (uptokstart, "TRUE") == 0)
1443         {
1444           yylval.lval = 1;
1445           free (uptokstart);
1446           return TRUEKEYWORD;
1447         }
1448       if (strcmp (uptokstart, "SELF") == 0)
1449         {
1450           /* Here we search for 'this' like
1451              inserted in FPC stabs debug info.  */
1452           static const char this_name[] = "this";
1453
1454           if (lookup_symbol (this_name, expression_context_block,
1455                              VAR_DOMAIN, NULL).symbol)
1456             {
1457               free (uptokstart);
1458               return THIS;
1459             }
1460         }
1461       break;
1462     default:
1463       break;
1464     }
1465
1466   yylval.sval.ptr = tokstart;
1467   yylval.sval.length = namelen;
1468
1469   if (*tokstart == '$')
1470     {
1471       char *tmp;
1472
1473       /* $ is the normal prefix for pascal hexadecimal values
1474         but this conflicts with the GDB use for debugger variables
1475         so in expression to enter hexadecimal values
1476         we still need to use C syntax with 0xff  */
1477       write_dollar_variable (pstate, yylval.sval);
1478       tmp = (char *) alloca (namelen + 1);
1479       memcpy (tmp, tokstart, namelen);
1480       tmp[namelen] = '\0';
1481       intvar = lookup_only_internalvar (tmp + 1);
1482       free (uptokstart);
1483       return VARIABLE;
1484     }
1485
1486   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1487      functions or symtabs.  If this is not so, then ...
1488      Use token-type TYPENAME for symbols that happen to be defined
1489      currently as names of types; NAME for other symbols.
1490      The caller is not constrained to care about the distinction.  */
1491   {
1492     char *tmp = copy_name (yylval.sval);
1493     struct symbol *sym;
1494     struct field_of_this_result is_a_field_of_this;
1495     int is_a_field = 0;
1496     int hextype;
1497
1498     is_a_field_of_this.type = NULL;
1499     if (search_field && current_type)
1500       is_a_field = (lookup_struct_elt_type (current_type, tmp, 1) != NULL);
1501     if (is_a_field)
1502       sym = NULL;
1503     else
1504       sym = lookup_symbol (tmp, expression_context_block,
1505                            VAR_DOMAIN, &is_a_field_of_this).symbol;
1506     /* second chance uppercased (as Free Pascal does).  */
1507     if (!sym && is_a_field_of_this.type == NULL && !is_a_field)
1508       {
1509        for (i = 0; i <= namelen; i++)
1510          {
1511            if ((tmp[i] >= 'a' && tmp[i] <= 'z'))
1512              tmp[i] -= ('a'-'A');
1513          }
1514        if (search_field && current_type)
1515          is_a_field = (lookup_struct_elt_type (current_type, tmp, 1) != NULL);
1516        if (is_a_field)
1517          sym = NULL;
1518        else
1519          sym = lookup_symbol (tmp, expression_context_block,
1520                               VAR_DOMAIN, &is_a_field_of_this).symbol;
1521       }
1522     /* Third chance Capitalized (as GPC does).  */
1523     if (!sym && is_a_field_of_this.type == NULL && !is_a_field)
1524       {
1525        for (i = 0; i <= namelen; i++)
1526          {
1527            if (i == 0)
1528              {
1529               if ((tmp[i] >= 'a' && tmp[i] <= 'z'))
1530                 tmp[i] -= ('a'-'A');
1531              }
1532            else
1533            if ((tmp[i] >= 'A' && tmp[i] <= 'Z'))
1534              tmp[i] -= ('A'-'a');
1535           }
1536        if (search_field && current_type)
1537          is_a_field = (lookup_struct_elt_type (current_type, tmp, 1) != NULL);
1538        if (is_a_field)
1539          sym = NULL;
1540        else
1541          sym = lookup_symbol (tmp, expression_context_block,
1542                               VAR_DOMAIN, &is_a_field_of_this).symbol;
1543       }
1544
1545     if (is_a_field || (is_a_field_of_this.type != NULL))
1546       {
1547         tempbuf = (char *) realloc (tempbuf, namelen + 1);
1548         strncpy (tempbuf, tmp, namelen);
1549         tempbuf [namelen] = 0;
1550         yylval.sval.ptr = tempbuf;
1551         yylval.sval.length = namelen;
1552         yylval.ssym.sym.symbol = NULL;
1553         yylval.ssym.sym.block = NULL;
1554         free (uptokstart);
1555         yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1556         if (is_a_field)
1557           return FIELDNAME;
1558         else
1559           return NAME;
1560       }
1561     /* Call lookup_symtab, not lookup_partial_symtab, in case there are
1562        no psymtabs (coff, xcoff, or some future change to blow away the
1563        psymtabs once once symbols are read).  */
1564     if ((sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1565         || lookup_symtab (tmp))
1566       {
1567         yylval.ssym.sym.symbol = sym;
1568         yylval.ssym.sym.block = NULL;
1569         yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1570         free (uptokstart);
1571         return BLOCKNAME;
1572       }
1573     if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF)
1574         {
1575 #if 1
1576           /* Despite the following flaw, we need to keep this code enabled.
1577              Because we can get called from check_stub_method, if we don't
1578              handle nested types then it screws many operations in any
1579              program which uses nested types.  */
1580           /* In "A::x", if x is a member function of A and there happens
1581              to be a type (nested or not, since the stabs don't make that
1582              distinction) named x, then this code incorrectly thinks we
1583              are dealing with nested types rather than a member function.  */
1584
1585           const char *p;
1586           const char *namestart;
1587           struct symbol *best_sym;
1588
1589           /* Look ahead to detect nested types.  This probably should be
1590              done in the grammar, but trying seemed to introduce a lot
1591              of shift/reduce and reduce/reduce conflicts.  It's possible
1592              that it could be done, though.  Or perhaps a non-grammar, but
1593              less ad hoc, approach would work well.  */
1594
1595           /* Since we do not currently have any way of distinguishing
1596              a nested type from a non-nested one (the stabs don't tell
1597              us whether a type is nested), we just ignore the
1598              containing type.  */
1599
1600           p = lexptr;
1601           best_sym = sym;
1602           while (1)
1603             {
1604               /* Skip whitespace.  */
1605               while (*p == ' ' || *p == '\t' || *p == '\n')
1606                 ++p;
1607               if (*p == ':' && p[1] == ':')
1608                 {
1609                   /* Skip the `::'.  */
1610                   p += 2;
1611                   /* Skip whitespace.  */
1612                   while (*p == ' ' || *p == '\t' || *p == '\n')
1613                     ++p;
1614                   namestart = p;
1615                   while (*p == '_' || *p == '$' || (*p >= '0' && *p <= '9')
1616                          || (*p >= 'a' && *p <= 'z')
1617                          || (*p >= 'A' && *p <= 'Z'))
1618                     ++p;
1619                   if (p != namestart)
1620                     {
1621                       struct symbol *cur_sym;
1622                       /* As big as the whole rest of the expression, which is
1623                          at least big enough.  */
1624                       char *ncopy
1625                         = (char *) alloca (strlen (tmp) + strlen (namestart)
1626                                            + 3);
1627                       char *tmp1;
1628
1629                       tmp1 = ncopy;
1630                       memcpy (tmp1, tmp, strlen (tmp));
1631                       tmp1 += strlen (tmp);
1632                       memcpy (tmp1, "::", 2);
1633                       tmp1 += 2;
1634                       memcpy (tmp1, namestart, p - namestart);
1635                       tmp1[p - namestart] = '\0';
1636                       cur_sym = lookup_symbol (ncopy, expression_context_block,
1637                                                VAR_DOMAIN, NULL).symbol;
1638                       if (cur_sym)
1639                         {
1640                           if (SYMBOL_CLASS (cur_sym) == LOC_TYPEDEF)
1641                             {
1642                               best_sym = cur_sym;
1643                               lexptr = p;
1644                             }
1645                           else
1646                             break;
1647                         }
1648                       else
1649                         break;
1650                     }
1651                   else
1652                     break;
1653                 }
1654               else
1655                 break;
1656             }
1657
1658           yylval.tsym.type = SYMBOL_TYPE (best_sym);
1659 #else /* not 0 */
1660           yylval.tsym.type = SYMBOL_TYPE (sym);
1661 #endif /* not 0 */
1662           free (uptokstart);
1663           return TYPENAME;
1664         }
1665     yylval.tsym.type
1666       = language_lookup_primitive_type (parse_language (pstate),
1667                                         parse_gdbarch (pstate), tmp);
1668     if (yylval.tsym.type != NULL)
1669       {
1670         free (uptokstart);
1671         return TYPENAME;
1672       }
1673
1674     /* Input names that aren't symbols but ARE valid hex numbers,
1675        when the input radix permits them, can be names or numbers
1676        depending on the parse.  Note we support radixes > 16 here.  */
1677     if (!sym
1678         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1679             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1680       {
1681         YYSTYPE newlval;        /* Its value is ignored.  */
1682         hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1683         if (hextype == INT)
1684           {
1685             yylval.ssym.sym.symbol = sym;
1686             yylval.ssym.sym.block = NULL;
1687             yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1688             free (uptokstart);
1689             return NAME_OR_INT;
1690           }
1691       }
1692
1693     free(uptokstart);
1694     /* Any other kind of symbol.  */
1695     yylval.ssym.sym.symbol = sym;
1696     yylval.ssym.sym.block = NULL;
1697     return NAME;
1698   }
1699 }
1700
1701 int
1702 pascal_parse (struct parser_state *par_state)
1703 {
1704   int result;
1705   struct cleanup *c = make_cleanup_clear_parser_state (&pstate);
1706
1707   /* Setting up the parser state.  */
1708   gdb_assert (par_state != NULL);
1709   pstate = par_state;
1710
1711   result = yyparse ();
1712   do_cleanups (c);
1713   return result;
1714 }
1715
1716 void
1717 yyerror (const char *msg)
1718 {
1719   if (prev_lexptr)
1720     lexptr = prev_lexptr;
1721
1722   error (_("A %s in expression, near `%s'."), (msg ? msg : "error"), lexptr);
1723 }