gdb/m2-exp.y

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