gdb/m2-exp.y

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