gdb/m2-exp.y

   1 /* YACC grammar for Modula-2 expressions, for GDB.
   2    Copyright (C) 1986-2020 Free Software Foundation, Inc.
   3    Generated from expread.y (now c-exp.y) and contributed by the Department
   4    of Computer Science at the State University of New York at Buffalo, 1991.
   5
   6    This file is part of GDB.
   7
   8    This program is free software; you can redistribute it and/or modify
   9    it under the terms of the GNU General Public License as published by
  10    the Free Software Foundation; either version 3 of the License, or
  11    (at your option) any later version.
  12
  13    This program is distributed in the hope that it will be useful,
  14    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16    GNU General Public License for more details.
  17
  18    You should have received a copy of the GNU General Public License
  19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21 /* Parse a Modula-2 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 %{
  39
  40 #include "defs.h"
  41 #include "expression.h"
  42 #include "language.h"
  43 #include "value.h"
  44 #include "parser-defs.h"
  45 #include "m2-lang.h"
  46 #include "bfd.h" /* Required by objfiles.h.  */
  47 #include "symfile.h" /* Required by objfiles.h.  */
  48 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  49 #include "block.h"
  50
  51 #define parse_type(ps) builtin_type (ps->gdbarch ())
  52 #define parse_m2_type(ps) builtin_m2_type (ps->gdbarch ())
  53
  54 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
  55    etc).  */
  56 #define GDB_YY_REMAP_PREFIX m2_
  57 #include "yy-remap.h"
  58
  59 /* The state of the parser, used internally when we are parsing the
  60    expression.  */
  61
  62 static struct parser_state *pstate = NULL;
  63
  64 int yyparse (void);
  65
  66 static int yylex (void);
  67
  68 static void yyerror (const char *);
  69
  70 static int parse_number (int);
  71
  72 /* The sign of the number being parsed.  */
  73 static int number_sign = 1;
  74
  75 %}
  76
  77 /* Although the yacc "value" of an expression is not used,
  78    since the result is stored in the structure being created,
  79    other node types do have values.  */
  80
  81 %union
  82   {
  83     LONGEST lval;
  84     ULONGEST ulval;
  85     gdb_byte val[16];
  86     struct symbol *sym;
  87     struct type *tval;
  88     struct stoken sval;
  89     int voidval;
  90     const struct block *bval;
  91     enum exp_opcode opcode;
  92     struct internalvar *ivar;
  93
  94     struct type **tvec;
  95     int *ivec;
  96   }
  97
  98 %type <voidval> exp type_exp start set
  99 %type <voidval> variable
 100 %type <tval> type
 101 %type <bval> block
 102 %type <sym> fblock
 103
 104 %token <lval> INT HEX ERROR
 105 %token <ulval> UINT M2_TRUE M2_FALSE CHAR
 106 %token <val> FLOAT
 107
 108 /* Both NAME and TYPENAME tokens represent symbols in the input,
 109    and both convey their data as strings.
 110    But a TYPENAME is a string that happens to be defined as a typedef
 111    or builtin type name (such as int or char)
 112    and a NAME is any other symbol.
 113
 114    Contexts where this distinction is not important can use the
 115    nonterminal "name", which matches either NAME or TYPENAME.  */
 116
 117 %token <sval> STRING
 118 %token <sval> NAME BLOCKNAME IDENT VARNAME
 119 %token <sval> TYPENAME
 120
 121 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
 122 %token TSIZE
 123 %token INC DEC INCL EXCL
 124
 125 /* The GDB scope operator */
 126 %token COLONCOLON
 127
 128 %token <voidval> DOLLAR_VARIABLE
 129
 130 /* M2 tokens */
 131 %left ','
 132 %left ABOVE_COMMA
 133 %nonassoc ASSIGN
 134 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
 135 %left OROR
 136 %left LOGICAL_AND '&'
 137 %left '@'
 138 %left '+' '-'
 139 %left '*' '/' DIV MOD
 140 %right UNARY
 141 %right '^' DOT '[' '('
 142 %right NOT '~'
 143 %left COLONCOLON QID
 144 /* This is not an actual token ; it is used for precedence.
 145 %right QID
 146 */
 147
 148 \f
 149 %%
 150
 151 start   :       exp
 152         |       type_exp
 153         ;
 154
 155 type_exp:       type
 156                 { write_exp_elt_opcode (pstate, OP_TYPE);
 157                   write_exp_elt_type (pstate, $1);
 158                   write_exp_elt_opcode (pstate, OP_TYPE);
 159                 }
 160         ;
 161
 162 /* Expressions */
 163
 164 exp     :       exp '^'   %prec UNARY
 165                         { write_exp_elt_opcode (pstate, UNOP_IND); }
 166         ;
 167
 168 exp     :       '-'
 169                         { number_sign = -1; }
 170                 exp    %prec UNARY
 171                         { number_sign = 1;
 172                           write_exp_elt_opcode (pstate, UNOP_NEG); }
 173         ;
 174
 175 exp     :       '+' exp    %prec UNARY
 176                 { write_exp_elt_opcode (pstate, UNOP_PLUS); }
 177         ;
 178
 179 exp     :       not_exp exp %prec UNARY
 180                         { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
 181         ;
 182
 183 not_exp :       NOT
 184         |       '~'
 185         ;
 186
 187 exp     :       CAP '(' exp ')'
 188                         { write_exp_elt_opcode (pstate, UNOP_CAP); }
 189         ;
 190
 191 exp     :       ORD '(' exp ')'
 192                         { write_exp_elt_opcode (pstate, UNOP_ORD); }
 193         ;
 194
 195 exp     :       ABS '(' exp ')'
 196                         { write_exp_elt_opcode (pstate, UNOP_ABS); }
 197         ;
 198
 199 exp     :       HIGH '(' exp ')'
 200                         { write_exp_elt_opcode (pstate, UNOP_HIGH); }
 201         ;
 202
 203 exp     :       MIN_FUNC '(' type ')'
 204                         { write_exp_elt_opcode (pstate, UNOP_MIN);
 205                           write_exp_elt_type (pstate, $3);
 206                           write_exp_elt_opcode (pstate, UNOP_MIN); }
 207         ;
 208
 209 exp     :       MAX_FUNC '(' type ')'
 210                         { write_exp_elt_opcode (pstate, UNOP_MAX);
 211                           write_exp_elt_type (pstate, $3);
 212                           write_exp_elt_opcode (pstate, UNOP_MAX); }
 213         ;
 214
 215 exp     :       FLOAT_FUNC '(' exp ')'
 216                         { write_exp_elt_opcode (pstate, UNOP_FLOAT); }
 217         ;
 218
 219 exp     :       VAL '(' type ',' exp ')'
 220                         { write_exp_elt_opcode (pstate, BINOP_VAL);
 221                           write_exp_elt_type (pstate, $3);
 222                           write_exp_elt_opcode (pstate, BINOP_VAL); }
 223         ;
 224
 225 exp     :       CHR '(' exp ')'
 226                         { write_exp_elt_opcode (pstate, UNOP_CHR); }
 227         ;
 228
 229 exp     :       ODD '(' exp ')'
 230                         { write_exp_elt_opcode (pstate, UNOP_ODD); }
 231         ;
 232
 233 exp     :       TRUNC '(' exp ')'
 234                         { write_exp_elt_opcode (pstate, UNOP_TRUNC); }
 235         ;
 236
 237 exp     :       TSIZE '(' exp ')'
 238                         { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
 239         ;
 240
 241 exp     :       SIZE exp       %prec UNARY
 242                         { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
 243         ;
 244
 245
 246 exp     :       INC '(' exp ')'
 247                         { write_exp_elt_opcode (pstate, UNOP_PREINCREMENT); }
 248         ;
 249
 250 exp     :       INC '(' exp ',' exp ')'
 251                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
 252                           write_exp_elt_opcode (pstate, BINOP_ADD);
 253                           write_exp_elt_opcode (pstate,
 254                                                 BINOP_ASSIGN_MODIFY); }
 255         ;
 256
 257 exp     :       DEC '(' exp ')'
 258                         { write_exp_elt_opcode (pstate, UNOP_PREDECREMENT);}
 259         ;
 260
 261 exp     :       DEC '(' exp ',' exp ')'
 262                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
 263                           write_exp_elt_opcode (pstate, BINOP_SUB);
 264                           write_exp_elt_opcode (pstate,
 265                                                 BINOP_ASSIGN_MODIFY); }
 266         ;
 267
 268 exp     :       exp DOT NAME
 269                         { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
 270                           write_exp_string (pstate, $3);
 271                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
 272         ;
 273
 274 exp     :       set
 275         ;
 276
 277 exp     :       exp IN set
 278                         { error (_("Sets are not implemented."));}
 279         ;
 280
 281 exp     :       INCL '(' exp ',' exp ')'
 282                         { error (_("Sets are not implemented."));}
 283         ;
 284
 285 exp     :       EXCL '(' exp ',' exp ')'
 286                         { error (_("Sets are not implemented."));}
 287         ;
 288
 289 set     :       '{' arglist '}'
 290                         { error (_("Sets are not implemented."));}
 291         |       type '{' arglist '}'
 292                         { error (_("Sets are not implemented."));}
 293         ;
 294
 295
 296 /* Modula-2 array subscript notation [a,b,c...].  */
 297 exp     :       exp '['
 298                         /* This function just saves the number of arguments
 299                            that follow in the list.  It is *not* specific to
 300                            function types */
 301                         { pstate->start_arglist(); }
 302                 non_empty_arglist ']'  %prec DOT
 303                         {
 304                           gdb_assert (pstate->arglist_len > 0);
 305                           write_exp_elt_opcode (pstate, MULTI_SUBSCRIPT);
 306                           write_exp_elt_longcst (pstate,
 307                                                  pstate->end_arglist());
 308                           write_exp_elt_opcode (pstate, MULTI_SUBSCRIPT);
 309                         }
 310         ;
 311
 312 exp     :       exp '('
 313                         /* This is to save the value of arglist_len
 314                            being accumulated by an outer function call.  */
 315                         { pstate->start_arglist (); }
 316                 arglist ')'     %prec DOT
 317                         { write_exp_elt_opcode (pstate, OP_FUNCALL);
 318                           write_exp_elt_longcst (pstate,
 319                                                  pstate->end_arglist ());
 320                           write_exp_elt_opcode (pstate, OP_FUNCALL); }
 321         ;
 322
 323 arglist :
 324         ;
 325
 326 arglist :       exp
 327                         { pstate->arglist_len = 1; }
 328         ;
 329
 330 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 331                         { pstate->arglist_len++; }
 332         ;
 333
 334 non_empty_arglist
 335         :       exp
 336                         { pstate->arglist_len = 1; }
 337         ;
 338
 339 non_empty_arglist
 340         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 341                         { pstate->arglist_len++; }
 342         ;
 343
 344 /* GDB construct */
 345 exp     :       '{' type '}' exp  %prec UNARY
 346                         { write_exp_elt_opcode (pstate, UNOP_MEMVAL);
 347                           write_exp_elt_type (pstate, $2);
 348                           write_exp_elt_opcode (pstate, UNOP_MEMVAL); }
 349         ;
 350
 351 exp     :       type '(' exp ')' %prec UNARY
 352                         { write_exp_elt_opcode (pstate, UNOP_CAST);
 353                           write_exp_elt_type (pstate, $1);
 354                           write_exp_elt_opcode (pstate, UNOP_CAST); }
 355         ;
 356
 357 exp     :       '(' exp ')'
 358                         { }
 359         ;
 360
 361 /* Binary operators in order of decreasing precedence.  Note that some
 362    of these operators are overloaded!  (ie. sets) */
 363
 364 /* GDB construct */
 365 exp     :       exp '@' exp
 366                         { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
 367         ;
 368
 369 exp     :       exp '*' exp
 370                         { write_exp_elt_opcode (pstate, BINOP_MUL); }
 371         ;
 372
 373 exp     :       exp '/' exp
 374                         { write_exp_elt_opcode (pstate, BINOP_DIV); }
 375         ;
 376
 377 exp     :       exp DIV exp
 378                         { write_exp_elt_opcode (pstate, BINOP_INTDIV); }
 379         ;
 380
 381 exp     :       exp MOD exp
 382                         { write_exp_elt_opcode (pstate, BINOP_REM); }
 383         ;
 384
 385 exp     :       exp '+' exp
 386                         { write_exp_elt_opcode (pstate, BINOP_ADD); }
 387         ;
 388
 389 exp     :       exp '-' exp
 390                         { write_exp_elt_opcode (pstate, BINOP_SUB); }
 391         ;
 392
 393 exp     :       exp '=' exp
 394                         { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
 395         ;
 396
 397 exp     :       exp NOTEQUAL exp
 398                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
 399         |       exp '#' exp
 400                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
 401         ;
 402
 403 exp     :       exp LEQ exp
 404                         { write_exp_elt_opcode (pstate, BINOP_LEQ); }
 405         ;
 406
 407 exp     :       exp GEQ exp
 408                         { write_exp_elt_opcode (pstate, BINOP_GEQ); }
 409         ;
 410
 411 exp     :       exp '<' exp
 412                         { write_exp_elt_opcode (pstate, BINOP_LESS); }
 413         ;
 414
 415 exp     :       exp '>' exp
 416                         { write_exp_elt_opcode (pstate, BINOP_GTR); }
 417         ;
 418
 419 exp     :       exp LOGICAL_AND exp
 420                         { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
 421         ;
 422
 423 exp     :       exp OROR exp
 424                         { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
 425         ;
 426
 427 exp     :       exp ASSIGN exp
 428                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
 429         ;
 430
 431
 432 /* Constants */
 433
 434 exp     :       M2_TRUE
 435                         { write_exp_elt_opcode (pstate, OP_BOOL);
 436                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 437                           write_exp_elt_opcode (pstate, OP_BOOL); }
 438         ;
 439
 440 exp     :       M2_FALSE
 441                         { write_exp_elt_opcode (pstate, OP_BOOL);
 442                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 443                           write_exp_elt_opcode (pstate, OP_BOOL); }
 444         ;
 445
 446 exp     :       INT
 447                         { write_exp_elt_opcode (pstate, OP_LONG);
 448                           write_exp_elt_type (pstate,
 449                                         parse_m2_type (pstate)->builtin_int);
 450                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 451                           write_exp_elt_opcode (pstate, OP_LONG); }
 452         ;
 453
 454 exp     :       UINT
 455                         {
 456                           write_exp_elt_opcode (pstate, OP_LONG);
 457                           write_exp_elt_type (pstate,
 458                                               parse_m2_type (pstate)
 459                                               ->builtin_card);
 460                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 461                           write_exp_elt_opcode (pstate, OP_LONG);
 462                         }
 463         ;
 464
 465 exp     :       CHAR
 466                         { write_exp_elt_opcode (pstate, OP_LONG);
 467                           write_exp_elt_type (pstate,
 468                                               parse_m2_type (pstate)
 469                                               ->builtin_char);
 470                           write_exp_elt_longcst (pstate, (LONGEST) $1);
 471                           write_exp_elt_opcode (pstate, OP_LONG); }
 472         ;
 473
 474
 475 exp     :       FLOAT
 476                         { write_exp_elt_opcode (pstate, OP_FLOAT);
 477                           write_exp_elt_type (pstate,
 478                                               parse_m2_type (pstate)
 479                                               ->builtin_real);
 480                           write_exp_elt_floatcst (pstate, $1);
 481                           write_exp_elt_opcode (pstate, OP_FLOAT); }
 482         ;
 483
 484 exp     :       variable
 485         ;
 486
 487 exp     :       SIZE '(' type ')'       %prec UNARY
 488                         { write_exp_elt_opcode (pstate, OP_LONG);
 489                           write_exp_elt_type (pstate,
 490                                             parse_type (pstate)->builtin_int);
 491                           write_exp_elt_longcst (pstate,
 492                                                  (LONGEST) TYPE_LENGTH ($3));
 493                           write_exp_elt_opcode (pstate, OP_LONG); }
 494         ;
 495
 496 exp     :       STRING
 497                         { write_exp_elt_opcode (pstate, OP_M2_STRING);
 498                           write_exp_string (pstate, $1);
 499                           write_exp_elt_opcode (pstate, OP_M2_STRING); }
 500         ;
 501
 502 /* This will be used for extensions later.  Like adding modules.  */
 503 block   :       fblock
 504                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 505         ;
 506
 507 fblock  :       BLOCKNAME
 508                         { struct symbol *sym
 509                             = lookup_symbol (copy_name ($1).c_str (),
 510                                              pstate->expression_context_block,
 511                                              VAR_DOMAIN, 0).symbol;
 512                           $$ = sym;}
 513         ;
 514
 515
 516 /* GDB scope operator */
 517 fblock  :       block COLONCOLON BLOCKNAME
 518                         { struct symbol *tem
 519                             = lookup_symbol (copy_name ($3).c_str (), $1,
 520                                              VAR_DOMAIN, 0).symbol;
 521                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 522                             error (_("No function \"%s\" in specified context."),
 523                                    copy_name ($3).c_str ());
 524                           $$ = tem;
 525                         }
 526         ;
 527
 528 /* Useful for assigning to PROCEDURE variables */
 529 variable:       fblock
 530                         { write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 531                           write_exp_elt_block (pstate, NULL);
 532                           write_exp_elt_sym (pstate, $1);
 533                           write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
 534         ;
 535
 536 /* GDB internal ($foo) variable */
 537 variable:       DOLLAR_VARIABLE
 538         ;
 539
 540 /* GDB scope operator */
 541 variable:       block COLONCOLON NAME
 542                         { struct block_symbol sym
 543                             = lookup_symbol (copy_name ($3).c_str (), $1,
 544                                              VAR_DOMAIN, 0);
 545
 546                           if (sym.symbol == 0)
 547                             error (_("No symbol \"%s\" in specified context."),
 548                                    copy_name ($3).c_str ());
 549                           if (symbol_read_needs_frame (sym.symbol))
 550                             pstate->block_tracker->update (sym);
 551
 552                           write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 553                           write_exp_elt_block (pstate, sym.block);
 554                           write_exp_elt_sym (pstate, sym.symbol);
 555                           write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
 556         ;
 557
 558 /* Base case for variables.  */
 559 variable:       NAME
 560                         { struct block_symbol sym;
 561                           struct field_of_this_result is_a_field_of_this;
 562
 563                           sym
 564                             = lookup_symbol (copy_name ($1).c_str (),
 565                                              pstate->expression_context_block,
 566                                              VAR_DOMAIN,
 567                                              &is_a_field_of_this);
 568
 569                           if (sym.symbol)
 570                             {
 571                               if (symbol_read_needs_frame (sym.symbol))
 572                                 pstate->block_tracker->update (sym);
 573
 574                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 575                               write_exp_elt_block (pstate, sym.block);
 576                               write_exp_elt_sym (pstate, sym.symbol);
 577                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
 578                             }
 579                           else
 580                             {
 581                               struct bound_minimal_symbol msymbol;
 582                               std::string arg = copy_name ($1);
 583
 584                               msymbol =
 585                                 lookup_bound_minimal_symbol (arg.c_str ());
 586                               if (msymbol.minsym != NULL)
 587                                 write_exp_msymbol (pstate, msymbol);
 588                               else if (!have_full_symbols () && !have_partial_symbols ())
 589                                 error (_("No symbol table is loaded.  Use the \"symbol-file\" command."));
 590                               else
 591                                 error (_("No symbol \"%s\" in current context."),
 592                                        arg.c_str ());
 593                             }
 594                         }
 595         ;
 596
 597 type
 598         :       TYPENAME
 599                         { $$
 600                             = lookup_typename (pstate->language (),
 601                                                copy_name ($1).c_str (),
 602                                                pstate->expression_context_block,
 603                                                0);
 604                         }
 605
 606         ;
 607
 608 %%
 609
 610 /* Take care of parsing a number (anything that starts with a digit).
 611    Set yylval and return the token type; update lexptr.
 612    LEN is the number of characters in it.  */
 613
 614 /*** Needs some error checking for the float case ***/
 615
 616 static int
 617 parse_number (int olen)
 618 {
 619   const char *p = pstate->lexptr;
 620   LONGEST n = 0;
 621   LONGEST prevn = 0;
 622   int c,i,ischar=0;
 623   int base = input_radix;
 624   int len = olen;
 625   int unsigned_p = number_sign == 1 ? 1 : 0;
 626
 627   if(p[len-1] == 'H')
 628   {
 629      base = 16;
 630      len--;
 631   }
 632   else if(p[len-1] == 'C' || p[len-1] == 'B')
 633   {
 634      base = 8;
 635      ischar = p[len-1] == 'C';
 636      len--;
 637   }
 638
 639   /* Scan the number */
 640   for (c = 0; c < len; c++)
 641   {
 642     if (p[c] == '.' && base == 10)
 643       {
 644         /* It's a float since it contains a point.  */
 645         if (!parse_float (p, len,
 646                           parse_m2_type (pstate)->builtin_real,
 647                           yylval.val))
 648           return ERROR;
 649
 650         pstate->lexptr += len;
 651         return FLOAT;
 652       }
 653     if (p[c] == '.' && base != 10)
 654        error (_("Floating point numbers must be base 10."));
 655     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 656        error (_("Invalid digit \'%c\' in number."),p[c]);
 657  }
 658
 659   while (len-- > 0)
 660     {
 661       c = *p++;
 662       n *= base;
 663       if( base == 8 && (c == '8' || c == '9'))
 664          error (_("Invalid digit \'%c\' in octal number."),c);
 665       if (c >= '0' && c <= '9')
 666         i = c - '0';
 667       else
 668         {
 669           if (base == 16 && c >= 'A' && c <= 'F')
 670             i = c - 'A' + 10;
 671           else
 672              return ERROR;
 673         }
 674       n+=i;
 675       if(i >= base)
 676          return ERROR;
 677       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 678          unsigned_p=1;          /* Try something unsigned */
 679       /* Don't do the range check if n==i and i==0, since that special
 680          case will give an overflow error.  */
 681       if(RANGE_CHECK && n!=i && i)
 682       {
 683          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 684             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 685             range_error (_("Overflow on numeric constant."));
 686       }
 687          prevn=n;
 688     }
 689
 690   pstate->lexptr = p;
 691   if(*p == 'B' || *p == 'C' || *p == 'H')
 692      pstate->lexptr++;                  /* Advance past B,C or H */
 693
 694   if (ischar)
 695   {
 696      yylval.ulval = n;
 697      return CHAR;
 698   }
 699   else if ( unsigned_p && number_sign == 1)
 700   {
 701      yylval.ulval = n;
 702      return UINT;
 703   }
 704   else if((unsigned_p && (n<0))) {
 705      range_error (_("Overflow on numeric constant -- number too large."));
 706      /* But, this can return if range_check == range_warn.  */
 707   }
 708   yylval.lval = n;
 709   return INT;
 710 }
 711
 712
 713 /* Some tokens */
 714
 715 static struct
 716 {
 717    char name[2];
 718    int token;
 719 } tokentab2[] =
 720 {
 721     { {'<', '>'},    NOTEQUAL   },
 722     { {':', '='},    ASSIGN     },
 723     { {'<', '='},    LEQ        },
 724     { {'>', '='},    GEQ        },
 725     { {':', ':'},    COLONCOLON },
 726
 727 };
 728
 729 /* Some specific keywords */
 730
 731 struct keyword {
 732    char keyw[10];
 733    int token;
 734 };
 735
 736 static struct keyword keytab[] =
 737 {
 738     {"OR" ,   OROR       },
 739     {"IN",    IN         },/* Note space after IN */
 740     {"AND",   LOGICAL_AND},
 741     {"ABS",   ABS        },
 742     {"CHR",   CHR        },
 743     {"DEC",   DEC        },
 744     {"NOT",   NOT        },
 745     {"DIV",   DIV        },
 746     {"INC",   INC        },
 747     {"MAX",   MAX_FUNC   },
 748     {"MIN",   MIN_FUNC   },
 749     {"MOD",   MOD        },
 750     {"ODD",   ODD        },
 751     {"CAP",   CAP        },
 752     {"ORD",   ORD        },
 753     {"VAL",   VAL        },
 754     {"EXCL",  EXCL       },
 755     {"HIGH",  HIGH       },
 756     {"INCL",  INCL       },
 757     {"SIZE",  SIZE       },
 758     {"FLOAT", FLOAT_FUNC },
 759     {"TRUNC", TRUNC      },
 760     {"TSIZE", SIZE       },
 761 };
 762
 763
 764 /* Depth of parentheses.  */
 765 static int paren_depth;
 766
 767 /* Read one token, getting characters through lexptr.  */
 768
 769 /* This is where we will check to make sure that the language and the
 770    operators used are compatible  */
 771
 772 static int
 773 yylex (void)
 774 {
 775   int c;
 776   int namelen;
 777   int i;
 778   const char *tokstart;
 779   char quote;
 780
 781  retry:
 782
 783   pstate->prev_lexptr = pstate->lexptr;
 784
 785   tokstart = pstate->lexptr;
 786
 787
 788   /* See if it is a special token of length 2 */
 789   for( i = 0 ; i < (int) (sizeof tokentab2 / sizeof tokentab2[0]) ; i++)
 790      if (strncmp (tokentab2[i].name, tokstart, 2) == 0)
 791      {
 792         pstate->lexptr += 2;
 793         return tokentab2[i].token;
 794      }
 795
 796   switch (c = *tokstart)
 797     {
 798     case 0:
 799       return 0;
 800
 801     case ' ':
 802     case '\t':
 803     case '\n':
 804       pstate->lexptr++;
 805       goto retry;
 806
 807     case '(':
 808       paren_depth++;
 809       pstate->lexptr++;
 810       return c;
 811
 812     case ')':
 813       if (paren_depth == 0)
 814         return 0;
 815       paren_depth--;
 816       pstate->lexptr++;
 817       return c;
 818
 819     case ',':
 820       if (pstate->comma_terminates && paren_depth == 0)
 821         return 0;
 822       pstate->lexptr++;
 823       return c;
 824
 825     case '.':
 826       /* Might be a floating point number.  */
 827       if (pstate->lexptr[1] >= '0' && pstate->lexptr[1] <= '9')
 828         break;                  /* Falls into number code.  */
 829       else
 830       {
 831          pstate->lexptr++;
 832          return DOT;
 833       }
 834
 835 /* These are character tokens that appear as-is in the YACC grammar */
 836     case '+':
 837     case '-':
 838     case '*':
 839     case '/':
 840     case '^':
 841     case '<':
 842     case '>':
 843     case '[':
 844     case ']':
 845     case '=':
 846     case '{':
 847     case '}':
 848     case '#':
 849     case '@':
 850     case '~':
 851     case '&':
 852       pstate->lexptr++;
 853       return c;
 854
 855     case '\'' :
 856     case '"':
 857       quote = c;
 858       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
 859         if (c == '\\')
 860           {
 861             c = tokstart[++namelen];
 862             if (c >= '0' && c <= '9')
 863               {
 864                 c = tokstart[++namelen];
 865                 if (c >= '0' && c <= '9')
 866                   c = tokstart[++namelen];
 867               }
 868           }
 869       if(c != quote)
 870          error (_("Unterminated string or character constant."));
 871       yylval.sval.ptr = tokstart + 1;
 872       yylval.sval.length = namelen - 1;
 873       pstate->lexptr += namelen + 1;
 874
 875       if(namelen == 2)          /* Single character */
 876       {
 877            yylval.ulval = tokstart[1];
 878            return CHAR;
 879       }
 880       else
 881          return STRING;
 882     }
 883
 884   /* Is it a number?  */
 885   /* Note:  We have already dealt with the case of the token '.'.
 886      See case '.' above.  */
 887   if ((c >= '0' && c <= '9'))
 888     {
 889       /* It's a number.  */
 890       int got_dot = 0, got_e = 0;
 891       const char *p = tokstart;
 892       int toktype;
 893
 894       for (++p ;; ++p)
 895         {
 896           if (!got_e && (*p == 'e' || *p == 'E'))
 897             got_dot = got_e = 1;
 898           else if (!got_dot && *p == '.')
 899             got_dot = 1;
 900           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
 901                    && (*p == '-' || *p == '+'))
 902             /* This is the sign of the exponent, not the end of the
 903                number.  */
 904             continue;
 905           else if ((*p < '0' || *p > '9') &&
 906                    (*p < 'A' || *p > 'F') &&
 907                    (*p != 'H'))  /* Modula-2 hexadecimal number */
 908             break;
 909         }
 910         toktype = parse_number (p - tokstart);
 911         if (toktype == ERROR)
 912           {
 913             char *err_copy = (char *) alloca (p - tokstart + 1);
 914
 915             memcpy (err_copy, tokstart, p - tokstart);
 916             err_copy[p - tokstart] = 0;
 917             error (_("Invalid number \"%s\"."), err_copy);
 918           }
 919         pstate->lexptr = p;
 920         return toktype;
 921     }
 922
 923   if (!(c == '_' || c == '$'
 924         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
 925     /* We must have come across a bad character (e.g. ';').  */
 926     error (_("Invalid character '%c' in expression."), c);
 927
 928   /* It's a name.  See how long it is.  */
 929   namelen = 0;
 930   for (c = tokstart[namelen];
 931        (c == '_' || c == '$' || (c >= '0' && c <= '9')
 932         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
 933        c = tokstart[++namelen])
 934     ;
 935
 936   /* The token "if" terminates the expression and is NOT
 937      removed from the input stream.  */
 938   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
 939     {
 940       return 0;
 941     }
 942
 943   pstate->lexptr += namelen;
 944
 945   /*  Lookup special keywords */
 946   for(i = 0 ; i < (int) (sizeof(keytab) / sizeof(keytab[0])) ; i++)
 947      if (namelen == strlen (keytab[i].keyw)
 948          && strncmp (tokstart, keytab[i].keyw, namelen) == 0)
 949            return keytab[i].token;
 950
 951   yylval.sval.ptr = tokstart;
 952   yylval.sval.length = namelen;
 953
 954   if (*tokstart == '$')
 955     {
 956       write_dollar_variable (pstate, yylval.sval);
 957       return DOLLAR_VARIABLE;
 958     }
 959
 960   /* Use token-type BLOCKNAME for symbols that happen to be defined as
 961      functions.  If this is not so, then ...
 962      Use token-type TYPENAME for symbols that happen to be defined
 963      currently as names of types; NAME for other symbols.
 964      The caller is not constrained to care about the distinction.  */
 965  {
 966     std::string tmp = copy_name (yylval.sval);
 967     struct symbol *sym;
 968
 969     if (lookup_symtab (tmp.c_str ()))
 970       return BLOCKNAME;
 971     sym = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
 972                          VAR_DOMAIN, 0).symbol;
 973     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
 974       return BLOCKNAME;
 975     if (lookup_typename (pstate->language (),
 976                          tmp.c_str (), pstate->expression_context_block, 1))
 977       return TYPENAME;
 978
 979     if(sym)
 980     {
 981       switch(SYMBOL_CLASS (sym))
 982        {
 983        case LOC_STATIC:
 984        case LOC_REGISTER:
 985        case LOC_ARG:
 986        case LOC_REF_ARG:
 987        case LOC_REGPARM_ADDR:
 988        case LOC_LOCAL:
 989        case LOC_CONST:
 990        case LOC_CONST_BYTES:
 991        case LOC_OPTIMIZED_OUT:
 992        case LOC_COMPUTED:
 993           return NAME;
 994
 995        case LOC_TYPEDEF:
 996           return TYPENAME;
 997
 998        case LOC_BLOCK:
 999           return BLOCKNAME;
1000
1001        case LOC_UNDEF:
1002           error (_("internal:  Undefined class in m2lex()"));
1003
1004        case LOC_LABEL:
1005        case LOC_UNRESOLVED:
1006           error (_("internal:  Unforseen case in m2lex()"));
1007
1008        default:
1009           error (_("unhandled token in m2lex()"));
1010           break;
1011        }
1012     }
1013     else
1014     {
1015        /* Built-in BOOLEAN type.  This is sort of a hack.  */
1016        if (strncmp (tokstart, "TRUE", 4) == 0)
1017        {
1018           yylval.ulval = 1;
1019           return M2_TRUE;
1020        }
1021        else if (strncmp (tokstart, "FALSE", 5) == 0)
1022        {
1023           yylval.ulval = 0;
1024           return M2_FALSE;
1025        }
1026     }
1027
1028     /* Must be another type of name...  */
1029     return NAME;
1030  }
1031 }
1032
1033 int
1034 m2_language::parser (struct parser_state *par_state) const
1035 {
1036   /* Setting up the parser state.  */
1037   scoped_restore pstate_restore = make_scoped_restore (&pstate);
1038   gdb_assert (par_state != NULL);
1039   pstate = par_state;
1040   paren_depth = 0;
1041
1042   return yyparse ();
1043 }
1044
1045 static void
1046 yyerror (const char *msg)
1047 {
1048   if (pstate->prev_lexptr)
1049     pstate->lexptr = pstate->prev_lexptr;
1050
1051   error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);
1052 }