gdb/m2-exp.y

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