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 yylhs   m2_yylhs
  91 #define yylen   m2_yylen
  92 #define yydefred m2_yydefred
  93 #define yydgoto m2_yydgoto
  94 #define yysindex m2_yysindex
  95 #define yyrindex m2_yyrindex
  96 #define yygindex m2_yygindex
  97 #define yytable  m2_yytable
  98 #define yycheck  m2_yycheck
  99
 100 #ifndef YYDEBUG
 101 #define YYDEBUG 0               /* Default to no yydebug support */
 102 #endif
 103
 104 int yyparse (void);
 105
 106 static int yylex (void);
 107
 108 void yyerror (char *);
 109
 110 #if 0
 111 static char *make_qualname (char *, char *);
 112 #endif
 113
 114 static int parse_number (int);
 115
 116 /* The sign of the number being parsed. */
 117 static int number_sign = 1;
 118
 119 /* The block that the module specified by the qualifer on an identifer is
 120    contained in, */
 121 #if 0
 122 static struct block *modblock=0;
 123 #endif
 124
 125 %}
 126
 127 /* Although the yacc "value" of an expression is not used,
 128    since the result is stored in the structure being created,
 129    other node types do have values.  */
 130
 131 %union
 132   {
 133     LONGEST lval;
 134     ULONGEST ulval;
 135     DOUBLEST dval;
 136     struct symbol *sym;
 137     struct type *tval;
 138     struct stoken sval;
 139     int voidval;
 140     struct block *bval;
 141     enum exp_opcode opcode;
 142     struct internalvar *ivar;
 143
 144     struct type **tvec;
 145     int *ivec;
 146   }
 147
 148 %type <voidval> exp type_exp start set
 149 %type <voidval> variable
 150 %type <tval> type
 151 %type <bval> block
 152 %type <sym> fblock
 153
 154 %token <lval> INT HEX ERROR
 155 %token <ulval> UINT M2_TRUE M2_FALSE CHAR
 156 %token <dval> FLOAT
 157
 158 /* Both NAME and TYPENAME tokens represent symbols in the input,
 159    and both convey their data as strings.
 160    But a TYPENAME is a string that happens to be defined as a typedef
 161    or builtin type name (such as int or char)
 162    and a NAME is any other symbol.
 163
 164    Contexts where this distinction is not important can use the
 165    nonterminal "name", which matches either NAME or TYPENAME.  */
 166
 167 %token <sval> STRING
 168 %token <sval> NAME BLOCKNAME IDENT VARNAME
 169 %token <sval> TYPENAME
 170
 171 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
 172 %token INC DEC INCL EXCL
 173
 174 /* The GDB scope operator */
 175 %token COLONCOLON
 176
 177 %token <voidval> INTERNAL_VAR
 178
 179 /* M2 tokens */
 180 %left ','
 181 %left ABOVE_COMMA
 182 %nonassoc ASSIGN
 183 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
 184 %left OROR
 185 %left LOGICAL_AND '&'
 186 %left '@'
 187 %left '+' '-'
 188 %left '*' '/' DIV MOD
 189 %right UNARY
 190 %right '^' DOT '[' '('
 191 %right NOT '~'
 192 %left COLONCOLON QID
 193 /* This is not an actual token ; it is used for precedence.
 194 %right QID
 195 */
 196
 197 \f
 198 %%
 199
 200 start   :       exp
 201         |       type_exp
 202         ;
 203
 204 type_exp:       type
 205                 { write_exp_elt_opcode(OP_TYPE);
 206                   write_exp_elt_type($1);
 207                   write_exp_elt_opcode(OP_TYPE);
 208                 }
 209         ;
 210
 211 /* Expressions */
 212
 213 exp     :       exp '^'   %prec UNARY
 214                         { write_exp_elt_opcode (UNOP_IND); }
 215
 216 exp     :       '-'
 217                         { number_sign = -1; }
 218                 exp    %prec UNARY
 219                         { number_sign = 1;
 220                           write_exp_elt_opcode (UNOP_NEG); }
 221         ;
 222
 223 exp     :       '+' exp    %prec UNARY
 224                 { write_exp_elt_opcode(UNOP_PLUS); }
 225         ;
 226
 227 exp     :       not_exp exp %prec UNARY
 228                         { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }
 229         ;
 230
 231 not_exp :       NOT
 232         |       '~'
 233         ;
 234
 235 exp     :       CAP '(' exp ')'
 236                         { write_exp_elt_opcode (UNOP_CAP); }
 237         ;
 238
 239 exp     :       ORD '(' exp ')'
 240                         { write_exp_elt_opcode (UNOP_ORD); }
 241         ;
 242
 243 exp     :       ABS '(' exp ')'
 244                         { write_exp_elt_opcode (UNOP_ABS); }
 245         ;
 246
 247 exp     :       HIGH '(' exp ')'
 248                         { write_exp_elt_opcode (UNOP_HIGH); }
 249         ;
 250
 251 exp     :       MIN_FUNC '(' type ')'
 252                         { write_exp_elt_opcode (UNOP_MIN);
 253                           write_exp_elt_type ($3);
 254                           write_exp_elt_opcode (UNOP_MIN); }
 255         ;
 256
 257 exp     :       MAX_FUNC '(' type ')'
 258                         { write_exp_elt_opcode (UNOP_MAX);
 259                           write_exp_elt_type ($3);
 260                           write_exp_elt_opcode (UNOP_MIN); }
 261         ;
 262
 263 exp     :       FLOAT_FUNC '(' exp ')'
 264                         { write_exp_elt_opcode (UNOP_FLOAT); }
 265         ;
 266
 267 exp     :       VAL '(' type ',' exp ')'
 268                         { write_exp_elt_opcode (BINOP_VAL);
 269                           write_exp_elt_type ($3);
 270                           write_exp_elt_opcode (BINOP_VAL); }
 271         ;
 272
 273 exp     :       CHR '(' exp ')'
 274                         { write_exp_elt_opcode (UNOP_CHR); }
 275         ;
 276
 277 exp     :       ODD '(' exp ')'
 278                         { write_exp_elt_opcode (UNOP_ODD); }
 279         ;
 280
 281 exp     :       TRUNC '(' exp ')'
 282                         { write_exp_elt_opcode (UNOP_TRUNC); }
 283         ;
 284
 285 exp     :       SIZE exp       %prec UNARY
 286                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 287         ;
 288
 289
 290 exp     :       INC '(' exp ')'
 291                         { write_exp_elt_opcode(UNOP_PREINCREMENT); }
 292         ;
 293
 294 exp     :       INC '(' exp ',' exp ')'
 295                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 296                           write_exp_elt_opcode(BINOP_ADD);
 297                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 298         ;
 299
 300 exp     :       DEC '(' exp ')'
 301                         { write_exp_elt_opcode(UNOP_PREDECREMENT);}
 302         ;
 303
 304 exp     :       DEC '(' exp ',' exp ')'
 305                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 306                           write_exp_elt_opcode(BINOP_SUB);
 307                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 308         ;
 309
 310 exp     :       exp DOT NAME
 311                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 312                           write_exp_string ($3);
 313                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 314         ;
 315
 316 exp     :       set
 317         ;
 318
 319 exp     :       exp IN set
 320                         { error("Sets are not implemented.");}
 321         ;
 322
 323 exp     :       INCL '(' exp ',' exp ')'
 324                         { error("Sets are not implemented.");}
 325         ;
 326
 327 exp     :       EXCL '(' exp ',' exp ')'
 328                         { error("Sets are not implemented.");}
 329
 330 set     :       '{' arglist '}'
 331                         { error("Sets are not implemented.");}
 332         |       type '{' arglist '}'
 333                         { error("Sets are not implemented.");}
 334         ;
 335
 336
 337 /* Modula-2 array subscript notation [a,b,c...] */
 338 exp     :       exp '['
 339                         /* This function just saves the number of arguments
 340                            that follow in the list.  It is *not* specific to
 341                            function types */
 342                         { start_arglist(); }
 343                 non_empty_arglist ']'  %prec DOT
 344                         { write_exp_elt_opcode (MULTI_SUBSCRIPT);
 345                           write_exp_elt_longcst ((LONGEST) end_arglist());
 346                           write_exp_elt_opcode (MULTI_SUBSCRIPT); }
 347         ;
 348
 349 exp     :       exp '('
 350                         /* This is to save the value of arglist_len
 351                            being accumulated by an outer function call.  */
 352                         { start_arglist (); }
 353                 arglist ')'     %prec DOT
 354                         { write_exp_elt_opcode (OP_FUNCALL);
 355                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 356                           write_exp_elt_opcode (OP_FUNCALL); }
 357         ;
 358
 359 arglist :
 360         ;
 361
 362 arglist :       exp
 363                         { arglist_len = 1; }
 364         ;
 365
 366 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 367                         { arglist_len++; }
 368         ;
 369
 370 non_empty_arglist
 371         :       exp
 372                         { arglist_len = 1; }
 373         ;
 374
 375 non_empty_arglist
 376         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 377                         { arglist_len++; }
 378         ;
 379
 380 /* GDB construct */
 381 exp     :       '{' type '}' exp  %prec UNARY
 382                         { write_exp_elt_opcode (UNOP_MEMVAL);
 383                           write_exp_elt_type ($2);
 384                           write_exp_elt_opcode (UNOP_MEMVAL); }
 385         ;
 386
 387 exp     :       type '(' exp ')' %prec UNARY
 388                         { write_exp_elt_opcode (UNOP_CAST);
 389                           write_exp_elt_type ($1);
 390                           write_exp_elt_opcode (UNOP_CAST); }
 391         ;
 392
 393 exp     :       '(' exp ')'
 394                         { }
 395         ;
 396
 397 /* Binary operators in order of decreasing precedence.  Note that some
 398    of these operators are overloaded!  (ie. sets) */
 399
 400 /* GDB construct */
 401 exp     :       exp '@' exp
 402                         { write_exp_elt_opcode (BINOP_REPEAT); }
 403         ;
 404
 405 exp     :       exp '*' exp
 406                         { write_exp_elt_opcode (BINOP_MUL); }
 407         ;
 408
 409 exp     :       exp '/' exp
 410                         { write_exp_elt_opcode (BINOP_DIV); }
 411         ;
 412
 413 exp     :       exp DIV exp
 414                         { write_exp_elt_opcode (BINOP_INTDIV); }
 415         ;
 416
 417 exp     :       exp MOD exp
 418                         { write_exp_elt_opcode (BINOP_REM); }
 419         ;
 420
 421 exp     :       exp '+' exp
 422                         { write_exp_elt_opcode (BINOP_ADD); }
 423         ;
 424
 425 exp     :       exp '-' exp
 426                         { write_exp_elt_opcode (BINOP_SUB); }
 427         ;
 428
 429 exp     :       exp '=' exp
 430                         { write_exp_elt_opcode (BINOP_EQUAL); }
 431         ;
 432
 433 exp     :       exp NOTEQUAL exp
 434                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 435         |       exp '#' exp
 436                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 437         ;
 438
 439 exp     :       exp LEQ exp
 440                         { write_exp_elt_opcode (BINOP_LEQ); }
 441         ;
 442
 443 exp     :       exp GEQ exp
 444                         { write_exp_elt_opcode (BINOP_GEQ); }
 445         ;
 446
 447 exp     :       exp '<' exp
 448                         { write_exp_elt_opcode (BINOP_LESS); }
 449         ;
 450
 451 exp     :       exp '>' exp
 452                         { write_exp_elt_opcode (BINOP_GTR); }
 453         ;
 454
 455 exp     :       exp LOGICAL_AND exp
 456                         { write_exp_elt_opcode (BINOP_LOGICAL_AND); }
 457         ;
 458
 459 exp     :       exp OROR exp
 460                         { write_exp_elt_opcode (BINOP_LOGICAL_OR); }
 461         ;
 462
 463 exp     :       exp ASSIGN exp
 464                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 465         ;
 466
 467
 468 /* Constants */
 469
 470 exp     :       M2_TRUE
 471                         { write_exp_elt_opcode (OP_BOOL);
 472                           write_exp_elt_longcst ((LONGEST) $1);
 473                           write_exp_elt_opcode (OP_BOOL); }
 474         ;
 475
 476 exp     :       M2_FALSE
 477                         { write_exp_elt_opcode (OP_BOOL);
 478                           write_exp_elt_longcst ((LONGEST) $1);
 479                           write_exp_elt_opcode (OP_BOOL); }
 480         ;
 481
 482 exp     :       INT
 483                         { write_exp_elt_opcode (OP_LONG);
 484                           write_exp_elt_type (builtin_type_m2_int);
 485                           write_exp_elt_longcst ((LONGEST) $1);
 486                           write_exp_elt_opcode (OP_LONG); }
 487         ;
 488
 489 exp     :       UINT
 490                         {
 491                           write_exp_elt_opcode (OP_LONG);
 492                           write_exp_elt_type (builtin_type_m2_card);
 493                           write_exp_elt_longcst ((LONGEST) $1);
 494                           write_exp_elt_opcode (OP_LONG);
 495                         }
 496         ;
 497
 498 exp     :       CHAR
 499                         { write_exp_elt_opcode (OP_LONG);
 500                           write_exp_elt_type (builtin_type_m2_char);
 501                           write_exp_elt_longcst ((LONGEST) $1);
 502                           write_exp_elt_opcode (OP_LONG); }
 503         ;
 504
 505
 506 exp     :       FLOAT
 507                         { write_exp_elt_opcode (OP_DOUBLE);
 508                           write_exp_elt_type (builtin_type_m2_real);
 509                           write_exp_elt_dblcst ($1);
 510                           write_exp_elt_opcode (OP_DOUBLE); }
 511         ;
 512
 513 exp     :       variable
 514         ;
 515
 516 exp     :       SIZE '(' type ')'       %prec UNARY
 517                         { write_exp_elt_opcode (OP_LONG);
 518                           write_exp_elt_type (builtin_type_int);
 519                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 520                           write_exp_elt_opcode (OP_LONG); }
 521         ;
 522
 523 exp     :       STRING
 524                         { write_exp_elt_opcode (OP_M2_STRING);
 525                           write_exp_string ($1);
 526                           write_exp_elt_opcode (OP_M2_STRING); }
 527         ;
 528
 529 /* This will be used for extensions later.  Like adding modules. */
 530 block   :       fblock
 531                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 532         ;
 533
 534 fblock  :       BLOCKNAME
 535                         { struct symbol *sym
 536                             = lookup_symbol (copy_name ($1), expression_context_block,
 537                                              VAR_NAMESPACE, 0, NULL);
 538                           $$ = sym;}
 539         ;
 540
 541
 542 /* GDB scope operator */
 543 fblock  :       block COLONCOLON BLOCKNAME
 544                         { struct symbol *tem
 545                             = lookup_symbol (copy_name ($3), $1,
 546                                              VAR_NAMESPACE, 0, NULL);
 547                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 548                             error ("No function \"%s\" in specified context.",
 549                                    copy_name ($3));
 550                           $$ = tem;
 551                         }
 552         ;
 553
 554 /* Useful for assigning to PROCEDURE variables */
 555 variable:       fblock
 556                         { write_exp_elt_opcode(OP_VAR_VALUE);
 557                           write_exp_elt_block (NULL);
 558                           write_exp_elt_sym ($1);
 559                           write_exp_elt_opcode (OP_VAR_VALUE); }
 560         ;
 561
 562 /* GDB internal ($foo) variable */
 563 variable:       INTERNAL_VAR
 564         ;
 565
 566 /* GDB scope operator */
 567 variable:       block COLONCOLON NAME
 568                         { struct symbol *sym;
 569                           sym = lookup_symbol (copy_name ($3), $1,
 570                                                VAR_NAMESPACE, 0, NULL);
 571                           if (sym == 0)
 572                             error ("No symbol \"%s\" in specified context.",
 573                                    copy_name ($3));
 574
 575                           write_exp_elt_opcode (OP_VAR_VALUE);
 576                           /* block_found is set by lookup_symbol.  */
 577                           write_exp_elt_block (block_found);
 578                           write_exp_elt_sym (sym);
 579                           write_exp_elt_opcode (OP_VAR_VALUE); }
 580         ;
 581
 582 /* Base case for variables. */
 583 variable:       NAME
 584                         { struct symbol *sym;
 585                           int is_a_field_of_this;
 586
 587                           sym = lookup_symbol (copy_name ($1),
 588                                                expression_context_block,
 589                                                VAR_NAMESPACE,
 590                                                &is_a_field_of_this,
 591                                                NULL);
 592                           if (sym)
 593                             {
 594                               if (symbol_read_needs_frame (sym))
 595                                 {
 596                                   if (innermost_block == 0 ||
 597                                       contained_in (block_found,
 598                                                     innermost_block))
 599                                     innermost_block = block_found;
 600                                 }
 601
 602                               write_exp_elt_opcode (OP_VAR_VALUE);
 603                               /* We want to use the selected frame, not
 604                                  another more inner frame which happens to
 605                                  be in the same block.  */
 606                               write_exp_elt_block (NULL);
 607                               write_exp_elt_sym (sym);
 608                               write_exp_elt_opcode (OP_VAR_VALUE);
 609                             }
 610                           else
 611                             {
 612                               struct minimal_symbol *msymbol;
 613                               register char *arg = copy_name ($1);
 614
 615                               msymbol =
 616                                 lookup_minimal_symbol (arg, NULL, NULL);
 617                               if (msymbol != NULL)
 618                                 {
 619                                   write_exp_msymbol
 620                                     (msymbol,
 621                                      lookup_function_type (builtin_type_int),
 622                                      builtin_type_int);
 623                                 }
 624                               else if (!have_full_symbols () && !have_partial_symbols ())
 625                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 626                               else
 627                                 error ("No symbol \"%s\" in current context.",
 628                                        copy_name ($1));
 629                             }
 630                         }
 631         ;
 632
 633 type
 634         :       TYPENAME
 635                         { $$ = lookup_typename (copy_name ($1),
 636                                                 expression_context_block, 0); }
 637
 638         ;
 639
 640 %%
 641
 642 #if 0  /* FIXME! */
 643 int
 644 overflow(a,b)
 645    long a,b;
 646 {
 647    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
 648 }
 649
 650 int
 651 uoverflow(a,b)
 652    unsigned long a,b;
 653 {
 654    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
 655 }
 656 #endif /* FIXME */
 657
 658 /* Take care of parsing a number (anything that starts with a digit).
 659    Set yylval and return the token type; update lexptr.
 660    LEN is the number of characters in it.  */
 661
 662 /*** Needs some error checking for the float case ***/
 663
 664 static int
 665 parse_number (olen)
 666      int olen;
 667 {
 668   register char *p = lexptr;
 669   register LONGEST n = 0;
 670   register LONGEST prevn = 0;
 671   register int c,i,ischar=0;
 672   register int base = input_radix;
 673   register int len = olen;
 674   int unsigned_p = number_sign == 1 ? 1 : 0;
 675
 676   if(p[len-1] == 'H')
 677   {
 678      base = 16;
 679      len--;
 680   }
 681   else if(p[len-1] == 'C' || p[len-1] == 'B')
 682   {
 683      base = 8;
 684      ischar = p[len-1] == 'C';
 685      len--;
 686   }
 687
 688   /* Scan the number */
 689   for (c = 0; c < len; c++)
 690   {
 691     if (p[c] == '.' && base == 10)
 692       {
 693         /* It's a float since it contains a point.  */
 694         yylval.dval = atof (p);
 695         lexptr += len;
 696         return FLOAT;
 697       }
 698     if (p[c] == '.' && base != 10)
 699        error("Floating point numbers must be base 10.");
 700     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 701        error("Invalid digit \'%c\' in number.",p[c]);
 702  }
 703
 704   while (len-- > 0)
 705     {
 706       c = *p++;
 707       n *= base;
 708       if( base == 8 && (c == '8' || c == '9'))
 709          error("Invalid digit \'%c\' in octal number.",c);
 710       if (c >= '0' && c <= '9')
 711         i = c - '0';
 712       else
 713         {
 714           if (base == 16 && c >= 'A' && c <= 'F')
 715             i = c - 'A' + 10;
 716           else
 717              return ERROR;
 718         }
 719       n+=i;
 720       if(i >= base)
 721          return ERROR;
 722       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 723          unsigned_p=1;          /* Try something unsigned */
 724       /* Don't do the range check if n==i and i==0, since that special
 725          case will give an overflow error. */
 726       if(RANGE_CHECK && n!=i && i)
 727       {
 728          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 729             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 730             range_error("Overflow on numeric constant.");
 731       }
 732          prevn=n;
 733     }
 734
 735   lexptr = p;
 736   if(*p == 'B' || *p == 'C' || *p == 'H')
 737      lexptr++;                  /* Advance past B,C or H */
 738
 739   if (ischar)
 740   {
 741      yylval.ulval = n;
 742      return CHAR;
 743   }
 744   else if ( unsigned_p && number_sign == 1)
 745   {
 746      yylval.ulval = n;
 747      return UINT;
 748   }
 749   else if((unsigned_p && (n<0))) {
 750      range_error("Overflow on numeric constant -- number too large.");
 751      /* But, this can return if range_check == range_warn.  */
 752   }
 753   yylval.lval = n;
 754   return INT;
 755 }
 756
 757
 758 /* Some tokens */
 759
 760 static struct
 761 {
 762    char name[2];
 763    int token;
 764 } tokentab2[] =
 765 {
 766     { {'<', '>'},    NOTEQUAL   },
 767     { {':', '='},    ASSIGN     },
 768     { {'<', '='},    LEQ        },
 769     { {'>', '='},    GEQ        },
 770     { {':', ':'},    COLONCOLON },
 771
 772 };
 773
 774 /* Some specific keywords */
 775
 776 struct keyword {
 777    char keyw[10];
 778    int token;
 779 };
 780
 781 static struct keyword keytab[] =
 782 {
 783     {"OR" ,   OROR       },
 784     {"IN",    IN         },/* Note space after IN */
 785     {"AND",   LOGICAL_AND},
 786     {"ABS",   ABS        },
 787     {"CHR",   CHR        },
 788     {"DEC",   DEC        },
 789     {"NOT",   NOT        },
 790     {"DIV",   DIV        },
 791     {"INC",   INC        },
 792     {"MAX",   MAX_FUNC   },
 793     {"MIN",   MIN_FUNC   },
 794     {"MOD",   MOD        },
 795     {"ODD",   ODD        },
 796     {"CAP",   CAP        },
 797     {"ORD",   ORD        },
 798     {"VAL",   VAL        },
 799     {"EXCL",  EXCL       },
 800     {"HIGH",  HIGH       },
 801     {"INCL",  INCL       },
 802     {"SIZE",  SIZE       },
 803     {"FLOAT", FLOAT_FUNC },
 804     {"TRUNC", TRUNC      },
 805 };
 806
 807
 808 /* Read one token, getting characters through lexptr.  */
 809
 810 /* This is where we will check to make sure that the language and the operators used are
 811    compatible  */
 812
 813 static int
 814 yylex ()
 815 {
 816   register int c;
 817   register int namelen;
 818   register int i;
 819   register char *tokstart;
 820   register char quote;
 821
 822  retry:
 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(STREQN(tokentab2[i].name, tokstart, 2))
 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       register 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) && STREQN(tokstart,keytab[i].keyw,namelen))
 987            return keytab[i].token;
 988
 989   yylval.sval.ptr = tokstart;
 990   yylval.sval.length = namelen;
 991
 992   if (*tokstart == '$')
 993     {
 994       write_dollar_variable (yylval.sval);
 995       return INTERNAL_VAR;
 996     }
 997
 998   /* Use token-type BLOCKNAME for symbols that happen to be defined as
 999      functions.  If this is not so, then ...
1000      Use token-type TYPENAME for symbols that happen to be defined
1001      currently as names of types; NAME for other symbols.
1002      The caller is not constrained to care about the distinction.  */
1003  {
1004
1005
1006     char *tmp = copy_name (yylval.sval);
1007     struct symbol *sym;
1008
1009     if (lookup_partial_symtab (tmp))
1010       return BLOCKNAME;
1011     sym = lookup_symbol (tmp, expression_context_block,
1012                          VAR_NAMESPACE, 0, NULL);
1013     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1014       return BLOCKNAME;
1015     if (lookup_typename (copy_name (yylval.sval), expression_context_block, 1))
1016       return TYPENAME;
1017
1018     if(sym)
1019     {
1020        switch(sym->aclass)
1021        {
1022        case LOC_STATIC:
1023        case LOC_REGISTER:
1024        case LOC_ARG:
1025        case LOC_REF_ARG:
1026        case LOC_REGPARM:
1027        case LOC_REGPARM_ADDR:
1028        case LOC_LOCAL:
1029        case LOC_LOCAL_ARG:
1030        case LOC_BASEREG:
1031        case LOC_BASEREG_ARG:
1032        case LOC_CONST:
1033        case LOC_CONST_BYTES:
1034        case LOC_OPTIMIZED_OUT:
1035           return NAME;
1036
1037        case LOC_TYPEDEF:
1038           return TYPENAME;
1039
1040        case LOC_BLOCK:
1041           return BLOCKNAME;
1042
1043        case LOC_UNDEF:
1044           error("internal:  Undefined class in m2lex()");
1045
1046        case LOC_LABEL:
1047        case LOC_UNRESOLVED:
1048           error("internal:  Unforseen case in m2lex()");
1049
1050        default:
1051           error ("unhandled token in m2lex()");
1052           break;
1053        }
1054     }
1055     else
1056     {
1057        /* Built-in BOOLEAN type.  This is sort of a hack. */
1058        if(STREQN(tokstart,"TRUE",4))
1059        {
1060           yylval.ulval = 1;
1061           return M2_TRUE;
1062        }
1063        else if(STREQN(tokstart,"FALSE",5))
1064        {
1065           yylval.ulval = 0;
1066           return M2_FALSE;
1067        }
1068     }
1069
1070     /* Must be another type of name... */
1071     return NAME;
1072  }
1073 }
1074
1075 #if 0           /* Unused */
1076 static char *
1077 make_qualname(mod,ident)
1078    char *mod, *ident;
1079 {
1080    char *new = malloc(strlen(mod)+strlen(ident)+2);
1081
1082    strcpy(new,mod);
1083    strcat(new,".");
1084    strcat(new,ident);
1085    return new;
1086 }
1087 #endif  /* 0 */
1088
1089 void
1090 yyerror (msg)
1091      char *msg;
1092 {
1093   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1094 }