gdb/m2-exp.y

   1 /* YACC grammar for Modula-2 expressions, for GDB.
   2    Copyright (C) 1986, 1989, 1990, 1991 Free Software Foundation, Inc.
   3    Generated from expread.y (now c-exp.y) and contributed by the Department
   4    of Computer Science at the State University of New York at Buffalo, 1991.
   5
   6 This file is part of GDB.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  21
  22 /* Parse a Modula-2 expression from text in a string,
  23    and return the result as a  struct expression  pointer.
  24    That structure contains arithmetic operations in reverse polish,
  25    with constants represented by operations that are followed by special data.
  26    See expression.h for the details of the format.
  27    What is important here is that it can be built up sequentially
  28    during the process of parsing; the lower levels of the tree always
  29    come first in the result.
  30
  31    Note that malloc's and realloc's in this file are transformed to
  32    xmalloc and xrealloc respectively by the same sed command in the
  33    makefile that remaps any other malloc/realloc inserted by the parser
  34    generator.  Doing this with #defines and trying to control the interaction
  35    with include files (<malloc.h> and <stdlib.h> for example) just became
  36    too messy, particularly when such includes can be inserted at random
  37    times by the parser generator. */
  38
  39 %{
  40
  41 #include "defs.h"
  42 #include "expression.h"
  43 #include "language.h"
  44 #include "value.h"
  45 #include "parser-defs.h"
  46 #include "m2-lang.h"
  47
  48 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
  49    as well as gratuitiously global symbol names, so we can have multiple
  50    yacc generated parsers in gdb.  Note that these are only the variables
  51    produced by yacc.  If other parser generators (bison, byacc, etc) produce
  52    additional global names that conflict at link time, then those parser
  53    generators need to be fixed instead of adding those names to this list. */
  54
  55 #define yymaxdepth m2_maxdepth
  56 #define yyparse m2_parse
  57 #define yylex   m2_lex
  58 #define yyerror m2_error
  59 #define yylval  m2_lval
  60 #define yychar  m2_char
  61 #define yycheck m2_yycheck
  62 #define yydebug m2_debug
  63 #define yydefred m2_yydefred
  64 #define yydgoto m2_yydgoto
  65 #define yygindex m2_yygindex
  66 #define yylen   m2_yylen
  67 #define yylhs   m2_yylhs
  68 #define yyrindex m2_yyrindex
  69 #define yysccsid m2_yysccsid
  70 #define yysindex m2_yysindex
  71 #define yypact  m2_pact
  72 #define yyr1    m2_r1
  73 #define yyr2    m2_r2
  74 #define yydef   m2_def
  75 #define yychk   m2_chk
  76 #define yypgo   m2_pgo
  77 #define yyact   m2_act
  78 #define yyexca  m2_exca
  79 #define yyerrflag m2_errflag
  80 #define yynerrs m2_nerrs
  81 #define yyps    m2_ps
  82 #define yypv    m2_pv
  83 #define yys     m2_s
  84 #define yyss    m2_yyss
  85 #define yyssp   m2_yyssp
  86 #define yy_yys  m2_yys
  87 #define yystate m2_state
  88 #define yytable m2_yytable
  89 #define yytmp   m2_tmp
  90 #define yyv     m2_v
  91 #define yyvs    m2_vs
  92 #define yyvss   m2_vss
  93 #define yy_yyv  m2_yyv
  94 #define yyval   m2_val
  95 #define yylloc  m2_lloc
  96 #define yyreds  m2_reds         /* With YYDEBUG defined */
  97 #define yytoks  m2_toks         /* With YYDEBUG defined */
  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_sym ($1);
 577                           write_exp_elt_opcode (OP_VAR_VALUE); }
 578         ;
 579
 580 /* GDB internal ($foo) variable */
 581 variable:       INTERNAL_VAR
 582                         { write_exp_elt_opcode (OP_INTERNALVAR);
 583                           write_exp_elt_intern ($1);
 584                           write_exp_elt_opcode (OP_INTERNALVAR); }
 585         ;
 586
 587 /* GDB scope operator */
 588 variable:       block COLONCOLON NAME
 589                         { struct symbol *sym;
 590                           sym = lookup_symbol (copy_name ($3), $1,
 591                                                VAR_NAMESPACE, 0, NULL);
 592                           if (sym == 0)
 593                             error ("No symbol \"%s\" in specified context.",
 594                                    copy_name ($3));
 595
 596                           write_exp_elt_opcode (OP_VAR_VALUE);
 597                           write_exp_elt_sym (sym);
 598                           write_exp_elt_opcode (OP_VAR_VALUE); }
 599         ;
 600
 601 /* Base case for variables. */
 602 variable:       NAME
 603                         { struct symbol *sym;
 604                           int is_a_field_of_this;
 605
 606                           sym = lookup_symbol (copy_name ($1),
 607                                                expression_context_block,
 608                                                VAR_NAMESPACE,
 609                                                &is_a_field_of_this,
 610                                                NULL);
 611                           if (sym)
 612                             {
 613                               switch (sym->class)
 614                                 {
 615                                 case LOC_REGISTER:
 616                                 case LOC_ARG:
 617                                 case LOC_LOCAL:
 618                                 case LOC_REF_ARG:
 619                                 case LOC_REGPARM:
 620                                 case LOC_LOCAL_ARG:
 621                                   if (innermost_block == 0 ||
 622                                       contained_in (block_found,
 623                                                     innermost_block))
 624                                     innermost_block = block_found;
 625                                   break;
 626
 627                                 case LOC_UNDEF:
 628                                 case LOC_CONST:
 629                                 case LOC_STATIC:
 630                                 case LOC_TYPEDEF:
 631                                 case LOC_LABEL: /* maybe should go above? */
 632                                 case LOC_BLOCK:
 633                                 case LOC_CONST_BYTES:
 634                                 case LOC_OPTIMIZED_OUT:
 635                                   /* These are listed so gcc -Wall will reveal
 636                                      un-handled cases.  */
 637                                   break;
 638                                 }
 639                               write_exp_elt_opcode (OP_VAR_VALUE);
 640                               write_exp_elt_sym (sym);
 641                               write_exp_elt_opcode (OP_VAR_VALUE);
 642                             }
 643                           else
 644                             {
 645                               struct minimal_symbol *msymbol;
 646                               register char *arg = copy_name ($1);
 647
 648                               msymbol = lookup_minimal_symbol (arg,
 649                                           (struct objfile *) NULL);
 650                               if (msymbol != NULL)
 651                                 {
 652                                   write_exp_elt_opcode (OP_LONG);
 653                                   write_exp_elt_type (builtin_type_int);
 654                                   write_exp_elt_longcst ((LONGEST) SYMBOL_VALUE_ADDRESS (msymbol));
 655                                   write_exp_elt_opcode (OP_LONG);
 656                                   write_exp_elt_opcode (UNOP_MEMVAL);
 657                                   if (msymbol -> type == mst_data ||
 658                                       msymbol -> type == mst_bss)
 659                                     write_exp_elt_type (builtin_type_int);
 660                                   else if (msymbol -> type == mst_text)
 661                                     write_exp_elt_type (lookup_function_type (builtin_type_int));
 662                                   else
 663                                     write_exp_elt_type (builtin_type_char);
 664                                   write_exp_elt_opcode (UNOP_MEMVAL);
 665                                 }
 666                               else if (!have_full_symbols () && !have_partial_symbols ())
 667                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 668                               else
 669                                 error ("No symbol \"%s\" in current context.",
 670                                        copy_name ($1));
 671                             }
 672                         }
 673         ;
 674
 675 type
 676         :       TYPENAME
 677                         { $$ = lookup_typename (copy_name ($1),
 678                                                 expression_context_block, 0); }
 679
 680         ;
 681
 682 %%
 683
 684 #if 0  /* FIXME! */
 685 int
 686 overflow(a,b)
 687    long a,b;
 688 {
 689    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
 690 }
 691
 692 int
 693 uoverflow(a,b)
 694    unsigned long a,b;
 695 {
 696    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
 697 }
 698 #endif /* FIXME */
 699
 700 /* Take care of parsing a number (anything that starts with a digit).
 701    Set yylval and return the token type; update lexptr.
 702    LEN is the number of characters in it.  */
 703
 704 /*** Needs some error checking for the float case ***/
 705
 706 static int
 707 parse_number (olen)
 708      int olen;
 709 {
 710   register char *p = lexptr;
 711   register LONGEST n = 0;
 712   register LONGEST prevn = 0;
 713   register int c,i,ischar=0;
 714   register int base = input_radix;
 715   register int len = olen;
 716   int unsigned_p = number_sign == 1 ? 1 : 0;
 717
 718   if(p[len-1] == 'H')
 719   {
 720      base = 16;
 721      len--;
 722   }
 723   else if(p[len-1] == 'C' || p[len-1] == 'B')
 724   {
 725      base = 8;
 726      ischar = p[len-1] == 'C';
 727      len--;
 728   }
 729
 730   /* Scan the number */
 731   for (c = 0; c < len; c++)
 732   {
 733     if (p[c] == '.' && base == 10)
 734       {
 735         /* It's a float since it contains a point.  */
 736         yylval.dval = atof (p);
 737         lexptr += len;
 738         return FLOAT;
 739       }
 740     if (p[c] == '.' && base != 10)
 741        error("Floating point numbers must be base 10.");
 742     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 743        error("Invalid digit \'%c\' in number.",p[c]);
 744  }
 745
 746   while (len-- > 0)
 747     {
 748       c = *p++;
 749       n *= base;
 750       if( base == 8 && (c == '8' || c == '9'))
 751          error("Invalid digit \'%c\' in octal number.",c);
 752       if (c >= '0' && c <= '9')
 753         i = c - '0';
 754       else
 755         {
 756           if (base == 16 && c >= 'A' && c <= 'F')
 757             i = c - 'A' + 10;
 758           else
 759              return ERROR;
 760         }
 761       n+=i;
 762       if(i >= base)
 763          return ERROR;
 764       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 765          unsigned_p=1;          /* Try something unsigned */
 766       /* Don't do the range check if n==i and i==0, since that special
 767          case will give an overflow error. */
 768       if(RANGE_CHECK && n!=i && i)
 769       {
 770          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 771             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 772             range_error("Overflow on numeric constant.");
 773       }
 774          prevn=n;
 775     }
 776
 777   lexptr = p;
 778   if(*p == 'B' || *p == 'C' || *p == 'H')
 779      lexptr++;                  /* Advance past B,C or H */
 780
 781   if (ischar)
 782   {
 783      yylval.ulval = n;
 784      return CHAR;
 785   }
 786   else if ( unsigned_p && number_sign == 1)
 787   {
 788      yylval.ulval = n;
 789      return UINT;
 790   }
 791   else if((unsigned_p && (n<0))) {
 792      range_error("Overflow on numeric constant -- number too large.");
 793      /* But, this can return if range_check == range_warn.  */
 794   }
 795   yylval.lval = n;
 796   return INT;
 797 }
 798
 799
 800 /* Some tokens */
 801
 802 static struct
 803 {
 804    char name[2];
 805    int token;
 806 } tokentab2[] =
 807 {
 808     { {'<', '>'},    NOTEQUAL   },
 809     { {':', '='},    ASSIGN     },
 810     { {'<', '='},    LEQ        },
 811     { {'>', '='},    GEQ        },
 812     { {':', ':'},    COLONCOLON },
 813
 814 };
 815
 816 /* Some specific keywords */
 817
 818 struct keyword {
 819    char keyw[10];
 820    int token;
 821 };
 822
 823 static struct keyword keytab[] =
 824 {
 825     {"OR" ,   OROR       },
 826     {"IN",    IN         },/* Note space after IN */
 827     {"AND",   LOGICAL_AND},
 828     {"ABS",   ABS        },
 829     {"CHR",   CHR        },
 830     {"DEC",   DEC        },
 831     {"NOT",   NOT        },
 832     {"DIV",   DIV        },
 833     {"INC",   INC        },
 834     {"MAX",   MAX_FUNC   },
 835     {"MIN",   MIN_FUNC   },
 836     {"MOD",   MOD        },
 837     {"ODD",   ODD        },
 838     {"CAP",   CAP        },
 839     {"ORD",   ORD        },
 840     {"VAL",   VAL        },
 841     {"EXCL",  EXCL       },
 842     {"HIGH",  HIGH       },
 843     {"INCL",  INCL       },
 844     {"SIZE",  SIZE       },
 845     {"FLOAT", FLOAT_FUNC },
 846     {"TRUNC", TRUNC      },
 847 };
 848
 849
 850 /* Read one token, getting characters through lexptr.  */
 851
 852 /* This is where we will check to make sure that the language and the operators used are
 853    compatible  */
 854
 855 static int
 856 yylex ()
 857 {
 858   register int c;
 859   register int namelen;
 860   register int i;
 861   register char *tokstart;
 862   register char quote;
 863
 864  retry:
 865
 866   tokstart = lexptr;
 867
 868
 869   /* See if it is a special token of length 2 */
 870   for( i = 0 ; i < sizeof tokentab2 / sizeof tokentab2[0] ; i++)
 871      if(STREQN(tokentab2[i].name, tokstart, 2))
 872      {
 873         lexptr += 2;
 874         return tokentab2[i].token;
 875      }
 876
 877   switch (c = *tokstart)
 878     {
 879     case 0:
 880       return 0;
 881
 882     case ' ':
 883     case '\t':
 884     case '\n':
 885       lexptr++;
 886       goto retry;
 887
 888     case '(':
 889       paren_depth++;
 890       lexptr++;
 891       return c;
 892
 893     case ')':
 894       if (paren_depth == 0)
 895         return 0;
 896       paren_depth--;
 897       lexptr++;
 898       return c;
 899
 900     case ',':
 901       if (comma_terminates && paren_depth == 0)
 902         return 0;
 903       lexptr++;
 904       return c;
 905
 906     case '.':
 907       /* Might be a floating point number.  */
 908       if (lexptr[1] >= '0' && lexptr[1] <= '9')
 909         break;                  /* Falls into number code.  */
 910       else
 911       {
 912          lexptr++;
 913          return DOT;
 914       }
 915
 916 /* These are character tokens that appear as-is in the YACC grammar */
 917     case '+':
 918     case '-':
 919     case '*':
 920     case '/':
 921     case '^':
 922     case '<':
 923     case '>':
 924     case '[':
 925     case ']':
 926     case '=':
 927     case '{':
 928     case '}':
 929     case '#':
 930     case '@':
 931     case '~':
 932     case '&':
 933       lexptr++;
 934       return c;
 935
 936     case '\'' :
 937     case '"':
 938       quote = c;
 939       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
 940         if (c == '\\')
 941           {
 942             c = tokstart[++namelen];
 943             if (c >= '0' && c <= '9')
 944               {
 945                 c = tokstart[++namelen];
 946                 if (c >= '0' && c <= '9')
 947                   c = tokstart[++namelen];
 948               }
 949           }
 950       if(c != quote)
 951          error("Unterminated string or character constant.");
 952       yylval.sval.ptr = tokstart + 1;
 953       yylval.sval.length = namelen - 1;
 954       lexptr += namelen + 1;
 955
 956       if(namelen == 2)          /* Single character */
 957       {
 958            yylval.ulval = tokstart[1];
 959            return CHAR;
 960       }
 961       else
 962          return STRING;
 963     }
 964
 965   /* Is it a number?  */
 966   /* Note:  We have already dealt with the case of the token '.'.
 967      See case '.' above.  */
 968   if ((c >= '0' && c <= '9'))
 969     {
 970       /* It's a number.  */
 971       int got_dot = 0, got_e = 0;
 972       register char *p = tokstart;
 973       int toktype;
 974
 975       for (++p ;; ++p)
 976         {
 977           if (!got_e && (*p == 'e' || *p == 'E'))
 978             got_dot = got_e = 1;
 979           else if (!got_dot && *p == '.')
 980             got_dot = 1;
 981           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
 982                    && (*p == '-' || *p == '+'))
 983             /* This is the sign of the exponent, not the end of the
 984                number.  */
 985             continue;
 986           else if ((*p < '0' || *p > '9') &&
 987                    (*p < 'A' || *p > 'F') &&
 988                    (*p != 'H'))  /* Modula-2 hexadecimal number */
 989             break;
 990         }
 991         toktype = parse_number (p - tokstart);
 992         if (toktype == ERROR)
 993           {
 994             char *err_copy = (char *) alloca (p - tokstart + 1);
 995
 996             memcpy (err_copy, tokstart, p - tokstart);
 997             err_copy[p - tokstart] = 0;
 998             error ("Invalid number \"%s\".", err_copy);
 999           }
1000         lexptr = p;
1001         return toktype;
1002     }
1003
1004   if (!(c == '_' || c == '$'
1005         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1006     /* We must have come across a bad character (e.g. ';').  */
1007     error ("Invalid character '%c' in expression.", c);
1008
1009   /* It's a name.  See how long it is.  */
1010   namelen = 0;
1011   for (c = tokstart[namelen];
1012        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1013         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1014        c = tokstart[++namelen])
1015     ;
1016
1017   /* The token "if" terminates the expression and is NOT
1018      removed from the input stream.  */
1019   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1020     {
1021       return 0;
1022     }
1023
1024   lexptr += namelen;
1025
1026   /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1)
1027      and $$digits (equivalent to $<-digits> if you could type that).
1028      Make token type LAST, and put the number (the digits) in yylval.  */
1029
1030   if (*tokstart == '$')
1031     {
1032       register int negate = 0;
1033       c = 1;
1034       /* Double dollar means negate the number and add -1 as well.
1035          Thus $$ alone means -1.  */
1036       if (namelen >= 2 && tokstart[1] == '$')
1037         {
1038           negate = 1;
1039           c = 2;
1040         }
1041       if (c == namelen)
1042         {
1043           /* Just dollars (one or two) */
1044           yylval.lval = - negate;
1045           return LAST;
1046         }
1047       /* Is the rest of the token digits?  */
1048       for (; c < namelen; c++)
1049         if (!(tokstart[c] >= '0' && tokstart[c] <= '9'))
1050           break;
1051       if (c == namelen)
1052         {
1053           yylval.lval = atoi (tokstart + 1 + negate);
1054           if (negate)
1055             yylval.lval = - yylval.lval;
1056           return LAST;
1057         }
1058     }
1059
1060   /* Handle tokens that refer to machine registers:
1061      $ followed by a register name.  */
1062
1063   if (*tokstart == '$') {
1064     for (c = 0; c < NUM_REGS; c++)
1065       if (namelen - 1 == strlen (reg_names[c])
1066           && STREQN (tokstart + 1, reg_names[c], namelen - 1))
1067         {
1068           yylval.lval = c;
1069           return REGNAME;
1070         }
1071     for (c = 0; c < num_std_regs; c++)
1072      if (namelen - 1 == strlen (std_regs[c].name)
1073          && STREQN (tokstart + 1, std_regs[c].name, namelen - 1))
1074        {
1075          yylval.lval = std_regs[c].regnum;
1076          return REGNAME;
1077        }
1078   }
1079
1080
1081   /*  Lookup special keywords */
1082   for(i = 0 ; i < sizeof(keytab) / sizeof(keytab[0]) ; i++)
1083      if(namelen == strlen(keytab[i].keyw) && STREQN(tokstart,keytab[i].keyw,namelen))
1084            return keytab[i].token;
1085
1086   yylval.sval.ptr = tokstart;
1087   yylval.sval.length = namelen;
1088
1089   /* Any other names starting in $ are debugger internal variables.  */
1090
1091   if (*tokstart == '$')
1092     {
1093       yylval.ivar = (struct internalvar *) lookup_internalvar (copy_name (yylval.sval) + 1);
1094       return INTERNAL_VAR;
1095     }
1096
1097
1098   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1099      functions.  If this is not so, then ...
1100      Use token-type TYPENAME for symbols that happen to be defined
1101      currently as names of types; NAME for other symbols.
1102      The caller is not constrained to care about the distinction.  */
1103  {
1104
1105
1106     char *tmp = copy_name (yylval.sval);
1107     struct symbol *sym;
1108
1109     if (lookup_partial_symtab (tmp))
1110       return BLOCKNAME;
1111     sym = lookup_symbol (tmp, expression_context_block,
1112                          VAR_NAMESPACE, 0, NULL);
1113     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1114       return BLOCKNAME;
1115     if (lookup_typename (copy_name (yylval.sval), expression_context_block, 1))
1116       return TYPENAME;
1117
1118     if(sym)
1119     {
1120        switch(sym->class)
1121        {
1122        case LOC_STATIC:
1123        case LOC_REGISTER:
1124        case LOC_ARG:
1125        case LOC_REF_ARG:
1126        case LOC_REGPARM:
1127        case LOC_LOCAL:
1128        case LOC_LOCAL_ARG:
1129        case LOC_CONST:
1130        case LOC_CONST_BYTES:
1131           return NAME;
1132
1133        case LOC_TYPEDEF:
1134           return TYPENAME;
1135
1136        case LOC_BLOCK:
1137           return BLOCKNAME;
1138
1139        case LOC_UNDEF:
1140           error("internal:  Undefined class in m2lex()");
1141
1142        case LOC_LABEL:
1143           error("internal:  Unforseen case in m2lex()");
1144        }
1145     }
1146     else
1147     {
1148        /* Built-in BOOLEAN type.  This is sort of a hack. */
1149        if(STREQN(tokstart,"TRUE",4))
1150        {
1151           yylval.ulval = 1;
1152           return M2_TRUE;
1153        }
1154        else if(STREQN(tokstart,"FALSE",5))
1155        {
1156           yylval.ulval = 0;
1157           return M2_FALSE;
1158        }
1159     }
1160
1161     /* Must be another type of name... */
1162     return NAME;
1163  }
1164 }
1165
1166 #if 0           /* Unused */
1167 static char *
1168 make_qualname(mod,ident)
1169    char *mod, *ident;
1170 {
1171    char *new = malloc(strlen(mod)+strlen(ident)+2);
1172
1173    strcpy(new,mod);
1174    strcat(new,".");
1175    strcat(new,ident);
1176    return new;
1177 }
1178 #endif  /* 0 */
1179
1180 void
1181 yyerror(msg)
1182      char *msg; /* unused */
1183 {
1184    printf("Parsing:  %s\n",lexptr);
1185    if (yychar < 256)
1186      error("Invalid syntax in expression near character '%c'.",yychar);
1187    else
1188      error("Invalid syntax in expression");
1189 }
1190