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 %{
  32 #include <stdio.h>
  33 #include <string.h>
  34 #include "defs.h"
  35 #include "symtab.h"
  36 #include "gdbtypes.h"
  37 #include "frame.h"
  38 #include "expression.h"
  39 #include "language.h"
  40 #include "value.h"
  41 #include "parser-defs.h"
  42 #include "bfd.h"
  43 #include "symfile.h"
  44 #include "objfiles.h"
  45
  46 /* These MUST be included in any grammar file!!!! Please choose unique names!
  47    Note that this are a combined list of variables that can be produced
  48    by any one of bison, byacc, or yacc. */
  49 #define yymaxdepth m2_maxdepth
  50 #define yyparse m2_parse
  51 #define yylex   m2_lex
  52 #define yyerror m2_error
  53 #define yylval  m2_lval
  54 #define yychar  m2_char
  55 #define yydebug m2_debug
  56 #define yypact  m2_pact
  57 #define yyr1    m2_r1
  58 #define yyr2    m2_r2
  59 #define yydef   m2_def
  60 #define yychk   m2_chk
  61 #define yypgo   m2_pgo
  62 #define yyact   m2_act
  63 #define yyexca  m2_exca
  64 #define yyerrflag m2_errflag
  65 #define yynerrs m2_nerrs
  66 #define yyps    m2_ps
  67 #define yypv    m2_pv
  68 #define yys     m2_s
  69 #define yy_yys  m2_yys
  70 #define yystate m2_state
  71 #define yytmp   m2_tmp
  72 #define yyv     m2_v
  73 #define yy_yyv  m2_yyv
  74 #define yyval   m2_val
  75 #define yylloc  m2_lloc
  76 #define yyss    m2_yyss         /* byacc */
  77 #define yyssp   m2_yysp         /* byacc */
  78 #define yyvs    m2_yyvs         /* byacc */
  79 #define yyvsp   m2_yyvsp        /* byacc */
  80
  81 #if 0
  82 static char *
  83 make_qualname PARAMS ((char *, char *));
  84 #endif
  85
  86 static int
  87 parse_number PARAMS ((int));
  88
  89 static int
  90 yylex PARAMS ((void));
  91
  92 static void
  93 yyerror PARAMS ((char *));
  94
  95 int
  96 yyparse PARAMS ((void));
  97
  98 /* The sign of the number being parsed. */
  99 int number_sign = 1;
 100
 101 /* The block that the module specified by the qualifer on an identifer is
 102    contained in, */
 103 struct block *modblock=0;
 104
 105 /* #define      YYDEBUG 1 */
 106
 107 /* !@&%ing AIX defines these!  Prevent cpp complaints by undeffing them */
 108 #undef TRUE
 109 #undef FALSE
 110 %}
 111
 112 /* Although the yacc "value" of an expression is not used,
 113    since the result is stored in the structure being created,
 114    other node types do have values.  */
 115
 116 %union
 117   {
 118     LONGEST lval;
 119     unsigned LONGEST ulval;
 120     double dval;
 121     struct symbol *sym;
 122     struct type *tval;
 123     struct stoken sval;
 124     int voidval;
 125     struct block *bval;
 126     enum exp_opcode opcode;
 127     struct internalvar *ivar;
 128
 129     struct type **tvec;
 130     int *ivec;
 131   }
 132
 133 %type <voidval> exp type_exp start set
 134 %type <voidval> variable
 135 %type <tval> type
 136 %type <bval> block
 137 %type <sym> fblock
 138
 139 %token <lval> INT HEX ERROR
 140 %token <ulval> UINT TRUE FALSE CHAR
 141 %token <dval> FLOAT
 142
 143 /* Both NAME and TYPENAME tokens represent symbols in the input,
 144    and both convey their data as strings.
 145    But a TYPENAME is a string that happens to be defined as a typedef
 146    or builtin type name (such as int or char)
 147    and a NAME is any other symbol.
 148
 149    Contexts where this distinction is not important can use the
 150    nonterminal "name", which matches either NAME or TYPENAME.  */
 151
 152 %token <sval> STRING
 153 %token <sval> NAME BLOCKNAME IDENT VARNAME
 154 %token <sval> TYPENAME
 155
 156 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
 157 %token INC DEC INCL EXCL
 158
 159 /* The GDB scope operator */
 160 %token COLONCOLON
 161
 162 %token <lval> LAST REGNAME
 163
 164 %token <ivar> INTERNAL_VAR
 165
 166 /* M2 tokens */
 167 %left ','
 168 %left ABOVE_COMMA
 169 %nonassoc ASSIGN
 170 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
 171 %left OROR
 172 %left ANDAND '&'
 173 %left '@'
 174 %left '+' '-'
 175 %left '*' '/' DIV MOD
 176 %right UNARY
 177 %right '^' DOT '[' '('
 178 %right NOT '~'
 179 %left COLONCOLON QID
 180 /* This is not an actual token ; it is used for precedence.
 181 %right QID
 182 */
 183 %%
 184
 185 %{
 186 /* Ensure that if the generated parser contains any calls to malloc/realloc,
 187    that they get mapped to xmalloc/xrealloc.  We have to do this here
 188    rather than earlier in the file because this is the first point after
 189    the place where the SVR4 yacc includes <malloc.h>, and if we do it
 190    before that, then the remapped declarations in <malloc.h> will collide
 191    with the ones in "defs.h". */
 192
 193 #define malloc  xmalloc
 194 #define realloc xrealloc
 195 %}
 196
 197 start   :       exp
 198         |       type_exp
 199         ;
 200
 201 type_exp:       type
 202                 { write_exp_elt_opcode(OP_TYPE);
 203                   write_exp_elt_type($1);
 204                   write_exp_elt_opcode(OP_TYPE);
 205                 }
 206         ;
 207
 208 /* Expressions */
 209
 210 exp     :       exp '^'   %prec UNARY
 211                         { write_exp_elt_opcode (UNOP_IND); }
 212
 213 exp     :       '-'
 214                         { number_sign = -1; }
 215                 exp    %prec UNARY
 216                         { number_sign = 1;
 217                           write_exp_elt_opcode (UNOP_NEG); }
 218         ;
 219
 220 exp     :       '+' exp    %prec UNARY
 221                 { write_exp_elt_opcode(UNOP_PLUS); }
 222         ;
 223
 224 exp     :       not_exp exp %prec UNARY
 225                         { write_exp_elt_opcode (UNOP_ZEROP); }
 226         ;
 227
 228 not_exp :       NOT
 229         |       '~'
 230         ;
 231
 232 exp     :       CAP '(' exp ')'
 233                         { write_exp_elt_opcode (UNOP_CAP); }
 234         ;
 235
 236 exp     :       ORD '(' exp ')'
 237                         { write_exp_elt_opcode (UNOP_ORD); }
 238         ;
 239
 240 exp     :       ABS '(' exp ')'
 241                         { write_exp_elt_opcode (UNOP_ABS); }
 242         ;
 243
 244 exp     :       HIGH '(' exp ')'
 245                         { write_exp_elt_opcode (UNOP_HIGH); }
 246         ;
 247
 248 exp     :       MIN_FUNC '(' type ')'
 249                         { write_exp_elt_opcode (UNOP_MIN);
 250                           write_exp_elt_type ($3);
 251                           write_exp_elt_opcode (UNOP_MIN); }
 252         ;
 253
 254 exp     :       MAX_FUNC '(' type ')'
 255                         { write_exp_elt_opcode (UNOP_MAX);
 256                           write_exp_elt_type ($3);
 257                           write_exp_elt_opcode (UNOP_MIN); }
 258         ;
 259
 260 exp     :       FLOAT_FUNC '(' exp ')'
 261                         { write_exp_elt_opcode (UNOP_FLOAT); }
 262         ;
 263
 264 exp     :       VAL '(' type ',' exp ')'
 265                         { write_exp_elt_opcode (BINOP_VAL);
 266                           write_exp_elt_type ($3);
 267                           write_exp_elt_opcode (BINOP_VAL); }
 268         ;
 269
 270 exp     :       CHR '(' exp ')'
 271                         { write_exp_elt_opcode (UNOP_CHR); }
 272         ;
 273
 274 exp     :       ODD '(' exp ')'
 275                         { write_exp_elt_opcode (UNOP_ODD); }
 276         ;
 277
 278 exp     :       TRUNC '(' exp ')'
 279                         { write_exp_elt_opcode (UNOP_TRUNC); }
 280         ;
 281
 282 exp     :       SIZE exp       %prec UNARY
 283                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 284         ;
 285
 286
 287 exp     :       INC '(' exp ')'
 288                         { write_exp_elt_opcode(UNOP_PREINCREMENT); }
 289         ;
 290
 291 exp     :       INC '(' exp ',' exp ')'
 292                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 293                           write_exp_elt_opcode(BINOP_ADD);
 294                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 295         ;
 296
 297 exp     :       DEC '(' exp ')'
 298                         { write_exp_elt_opcode(UNOP_PREDECREMENT);}
 299         ;
 300
 301 exp     :       DEC '(' exp ',' exp ')'
 302                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 303                           write_exp_elt_opcode(BINOP_SUB);
 304                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 305         ;
 306
 307 exp     :       exp DOT NAME
 308                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 309                           write_exp_string ($3);
 310                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 311         ;
 312
 313 exp     :       set
 314         ;
 315
 316 exp     :       exp IN set
 317                         { error("Sets are not implemented.");}
 318         ;
 319
 320 exp     :       INCL '(' exp ',' exp ')'
 321                         { error("Sets are not implemented.");}
 322         ;
 323
 324 exp     :       EXCL '(' exp ',' exp ')'
 325                         { error("Sets are not implemented.");}
 326
 327 set     :       '{' arglist '}'
 328                         { error("Sets are not implemented.");}
 329         |       type '{' arglist '}'
 330                         { error("Sets are not implemented.");}
 331         ;
 332
 333
 334 /* Modula-2 array subscript notation [a,b,c...] */
 335 exp     :       exp '['
 336                         /* This function just saves the number of arguments
 337                            that follow in the list.  It is *not* specific to
 338                            function types */
 339                         { start_arglist(); }
 340                 non_empty_arglist ']'  %prec DOT
 341                         { write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT);
 342                           write_exp_elt_longcst ((LONGEST) end_arglist());
 343                           write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT); }
 344         ;
 345
 346 exp     :       exp '('
 347                         /* This is to save the value of arglist_len
 348                            being accumulated by an outer function call.  */
 349                         { start_arglist (); }
 350                 arglist ')'     %prec DOT
 351                         { write_exp_elt_opcode (OP_FUNCALL);
 352                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 353                           write_exp_elt_opcode (OP_FUNCALL); }
 354         ;
 355
 356 arglist :
 357         ;
 358
 359 arglist :       exp
 360                         { arglist_len = 1; }
 361         ;
 362
 363 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 364                         { arglist_len++; }
 365         ;
 366
 367 non_empty_arglist
 368         :       exp
 369                         { arglist_len = 1; }
 370         ;
 371
 372 non_empty_arglist
 373         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 374                         { arglist_len++; }
 375         ;
 376
 377 /* GDB construct */
 378 exp     :       '{' type '}' exp  %prec UNARY
 379                         { write_exp_elt_opcode (UNOP_MEMVAL);
 380                           write_exp_elt_type ($2);
 381                           write_exp_elt_opcode (UNOP_MEMVAL); }
 382         ;
 383
 384 exp     :       type '(' exp ')' %prec UNARY
 385                         { write_exp_elt_opcode (UNOP_CAST);
 386                           write_exp_elt_type ($1);
 387                           write_exp_elt_opcode (UNOP_CAST); }
 388         ;
 389
 390 exp     :       '(' exp ')'
 391                         { }
 392         ;
 393
 394 /* Binary operators in order of decreasing precedence.  Note that some
 395    of these operators are overloaded!  (ie. sets) */
 396
 397 /* GDB construct */
 398 exp     :       exp '@' exp
 399                         { write_exp_elt_opcode (BINOP_REPEAT); }
 400         ;
 401
 402 exp     :       exp '*' exp
 403                         { write_exp_elt_opcode (BINOP_MUL); }
 404         ;
 405
 406 exp     :       exp '/' exp
 407                         { write_exp_elt_opcode (BINOP_DIV); }
 408         ;
 409
 410 exp     :       exp DIV exp
 411                         { write_exp_elt_opcode (BINOP_INTDIV); }
 412         ;
 413
 414 exp     :       exp MOD exp
 415                         { write_exp_elt_opcode (BINOP_REM); }
 416         ;
 417
 418 exp     :       exp '+' exp
 419                         { write_exp_elt_opcode (BINOP_ADD); }
 420         ;
 421
 422 exp     :       exp '-' exp
 423                         { write_exp_elt_opcode (BINOP_SUB); }
 424         ;
 425
 426 exp     :       exp '=' exp
 427                         { write_exp_elt_opcode (BINOP_EQUAL); }
 428         ;
 429
 430 exp     :       exp NOTEQUAL exp
 431                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 432         |       exp '#' exp
 433                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 434         ;
 435
 436 exp     :       exp LEQ exp
 437                         { write_exp_elt_opcode (BINOP_LEQ); }
 438         ;
 439
 440 exp     :       exp GEQ exp
 441                         { write_exp_elt_opcode (BINOP_GEQ); }
 442         ;
 443
 444 exp     :       exp '<' exp
 445                         { write_exp_elt_opcode (BINOP_LESS); }
 446         ;
 447
 448 exp     :       exp '>' exp
 449                         { write_exp_elt_opcode (BINOP_GTR); }
 450         ;
 451
 452 exp     :       exp ANDAND exp
 453                         { write_exp_elt_opcode (BINOP_AND); }
 454         ;
 455
 456 exp     :       exp '&' exp
 457                         { write_exp_elt_opcode (BINOP_AND); }
 458         ;
 459
 460 exp     :       exp OROR exp
 461                         { write_exp_elt_opcode (BINOP_OR); }
 462         ;
 463
 464 exp     :       exp ASSIGN exp
 465                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 466         ;
 467
 468
 469 /* Constants */
 470
 471 exp     :       TRUE
 472                         { write_exp_elt_opcode (OP_BOOL);
 473                           write_exp_elt_longcst ((LONGEST) $1);
 474                           write_exp_elt_opcode (OP_BOOL); }
 475         ;
 476
 477 exp     :       FALSE
 478                         { write_exp_elt_opcode (OP_BOOL);
 479                           write_exp_elt_longcst ((LONGEST) $1);
 480                           write_exp_elt_opcode (OP_BOOL); }
 481         ;
 482
 483 exp     :       INT
 484                         { write_exp_elt_opcode (OP_LONG);
 485                           write_exp_elt_type (builtin_type_m2_int);
 486                           write_exp_elt_longcst ((LONGEST) $1);
 487                           write_exp_elt_opcode (OP_LONG); }
 488         ;
 489
 490 exp     :       UINT
 491                         {
 492                           write_exp_elt_opcode (OP_LONG);
 493                           write_exp_elt_type (builtin_type_m2_card);
 494                           write_exp_elt_longcst ((LONGEST) $1);
 495                           write_exp_elt_opcode (OP_LONG);
 496                         }
 497         ;
 498
 499 exp     :       CHAR
 500                         { write_exp_elt_opcode (OP_LONG);
 501                           write_exp_elt_type (builtin_type_m2_char);
 502                           write_exp_elt_longcst ((LONGEST) $1);
 503                           write_exp_elt_opcode (OP_LONG); }
 504         ;
 505
 506
 507 exp     :       FLOAT
 508                         { write_exp_elt_opcode (OP_DOUBLE);
 509                           write_exp_elt_type (builtin_type_m2_real);
 510                           write_exp_elt_dblcst ($1);
 511                           write_exp_elt_opcode (OP_DOUBLE); }
 512         ;
 513
 514 exp     :       variable
 515         ;
 516
 517 /* The GDB internal variable $$, et al. */
 518 exp     :       LAST
 519                         { write_exp_elt_opcode (OP_LAST);
 520                           write_exp_elt_longcst ((LONGEST) $1);
 521                           write_exp_elt_opcode (OP_LAST); }
 522         ;
 523
 524 exp     :       REGNAME
 525                         { write_exp_elt_opcode (OP_REGISTER);
 526                           write_exp_elt_longcst ((LONGEST) $1);
 527                           write_exp_elt_opcode (OP_REGISTER); }
 528         ;
 529
 530 exp     :       SIZE '(' type ')'       %prec UNARY
 531                         { write_exp_elt_opcode (OP_LONG);
 532                           write_exp_elt_type (builtin_type_int);
 533                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 534                           write_exp_elt_opcode (OP_LONG); }
 535         ;
 536
 537 exp     :       STRING
 538                         { write_exp_elt_opcode (OP_M2_STRING);
 539                           write_exp_string ($1);
 540                           write_exp_elt_opcode (OP_M2_STRING); }
 541         ;
 542
 543 /* This will be used for extensions later.  Like adding modules. */
 544 block   :       fblock
 545                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 546         ;
 547
 548 fblock  :       BLOCKNAME
 549                         { struct symbol *sym
 550                             = lookup_symbol (copy_name ($1), expression_context_block,
 551                                              VAR_NAMESPACE, 0, NULL);
 552                           $$ = sym;}
 553         ;
 554
 555
 556 /* GDB scope operator */
 557 fblock  :       block COLONCOLON BLOCKNAME
 558                         { struct symbol *tem
 559                             = lookup_symbol (copy_name ($3), $1,
 560                                              VAR_NAMESPACE, 0, NULL);
 561                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 562                             error ("No function \"%s\" in specified context.",
 563                                    copy_name ($3));
 564                           $$ = tem;
 565                         }
 566         ;
 567
 568 /* Useful for assigning to PROCEDURE variables */
 569 variable:       fblock
 570                         { write_exp_elt_opcode(OP_VAR_VALUE);
 571                           write_exp_elt_sym ($1);
 572                           write_exp_elt_opcode (OP_VAR_VALUE); }
 573         ;
 574
 575 /* GDB internal ($foo) variable */
 576 variable:       INTERNAL_VAR
 577                         { write_exp_elt_opcode (OP_INTERNALVAR);
 578                           write_exp_elt_intern ($1);
 579                           write_exp_elt_opcode (OP_INTERNALVAR); }
 580         ;
 581
 582 /* GDB scope operator */
 583 variable:       block COLONCOLON NAME
 584                         { struct symbol *sym;
 585                           sym = lookup_symbol (copy_name ($3), $1,
 586                                                VAR_NAMESPACE, 0, NULL);
 587                           if (sym == 0)
 588                             error ("No symbol \"%s\" in specified context.",
 589                                    copy_name ($3));
 590
 591                           write_exp_elt_opcode (OP_VAR_VALUE);
 592                           write_exp_elt_sym (sym);
 593                           write_exp_elt_opcode (OP_VAR_VALUE); }
 594         ;
 595
 596 /* Base case for variables. */
 597 variable:       NAME
 598                         { struct symbol *sym;
 599                           int is_a_field_of_this;
 600
 601                           sym = lookup_symbol (copy_name ($1),
 602                                                expression_context_block,
 603                                                VAR_NAMESPACE,
 604                                                &is_a_field_of_this,
 605                                                NULL);
 606                           if (sym)
 607                             {
 608                               switch (sym->class)
 609                                 {
 610                                 case LOC_REGISTER:
 611                                 case LOC_ARG:
 612                                 case LOC_LOCAL:
 613                                 case LOC_REF_ARG:
 614                                 case LOC_REGPARM:
 615                                 case LOC_LOCAL_ARG:
 616                                   if (innermost_block == 0 ||
 617                                       contained_in (block_found,
 618                                                     innermost_block))
 619                                     innermost_block = block_found;
 620                                   break;
 621
 622                                 case LOC_UNDEF:
 623                                 case LOC_CONST:
 624                                 case LOC_STATIC:
 625                                 case LOC_TYPEDEF:
 626                                 case LOC_LABEL: /* maybe should go above? */
 627                                 case LOC_BLOCK:
 628                                 case LOC_CONST_BYTES:
 629                                   /* These are listed so gcc -Wall will reveal
 630                                      un-handled cases.  */
 631                                   break;
 632                                 }
 633                               write_exp_elt_opcode (OP_VAR_VALUE);
 634                               write_exp_elt_sym (sym);
 635                               write_exp_elt_opcode (OP_VAR_VALUE);
 636                             }
 637                           else
 638                             {
 639                               struct minimal_symbol *msymbol;
 640                               register char *arg = copy_name ($1);
 641
 642                               msymbol = lookup_minimal_symbol (arg,
 643                                           (struct objfile *) NULL);
 644                               if (msymbol != NULL)
 645                                 {
 646                                   write_exp_elt_opcode (OP_LONG);
 647                                   write_exp_elt_type (builtin_type_int);
 648                                   write_exp_elt_longcst ((LONGEST) msymbol -> address);
 649                                   write_exp_elt_opcode (OP_LONG);
 650                                   write_exp_elt_opcode (UNOP_MEMVAL);
 651                                   if (msymbol -> type == mst_data ||
 652                                       msymbol -> type == mst_bss)
 653                                     write_exp_elt_type (builtin_type_int);
 654                                   else if (msymbol -> type == mst_text)
 655                                     write_exp_elt_type (lookup_function_type (builtin_type_int));
 656                                   else
 657                                     write_exp_elt_type (builtin_type_char);
 658                                   write_exp_elt_opcode (UNOP_MEMVAL);
 659                                 }
 660                               else if (!have_full_symbols () && !have_partial_symbols ())
 661                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 662                               else
 663                                 error ("No symbol \"%s\" in current context.",
 664                                        copy_name ($1));
 665                             }
 666                         }
 667         ;
 668
 669 type
 670         :       TYPENAME
 671                         { $$ = lookup_typename (copy_name ($1),
 672                                                 expression_context_block, 0); }
 673
 674         ;
 675
 676 %%
 677
 678 #if 0  /* FIXME! */
 679 int
 680 overflow(a,b)
 681    long a,b;
 682 {
 683    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
 684 }
 685
 686 int
 687 uoverflow(a,b)
 688    unsigned long a,b;
 689 {
 690    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
 691 }
 692 #endif /* FIXME */
 693
 694 /* Take care of parsing a number (anything that starts with a digit).
 695    Set yylval and return the token type; update lexptr.
 696    LEN is the number of characters in it.  */
 697
 698 /*** Needs some error checking for the float case ***/
 699
 700 static int
 701 parse_number (olen)
 702      int olen;
 703 {
 704   register char *p = lexptr;
 705   register LONGEST n = 0;
 706   register LONGEST prevn = 0;
 707   register int c,i,ischar=0;
 708   register int base = input_radix;
 709   register int len = olen;
 710   int unsigned_p = number_sign == 1 ? 1 : 0;
 711
 712   if(p[len-1] == 'H')
 713   {
 714      base = 16;
 715      len--;
 716   }
 717   else if(p[len-1] == 'C' || p[len-1] == 'B')
 718   {
 719      base = 8;
 720      ischar = p[len-1] == 'C';
 721      len--;
 722   }
 723
 724   /* Scan the number */
 725   for (c = 0; c < len; c++)
 726   {
 727     if (p[c] == '.' && base == 10)
 728       {
 729         /* It's a float since it contains a point.  */
 730         yylval.dval = atof (p);
 731         lexptr += len;
 732         return FLOAT;
 733       }
 734     if (p[c] == '.' && base != 10)
 735        error("Floating point numbers must be base 10.");
 736     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 737        error("Invalid digit \'%c\' in number.",p[c]);
 738  }
 739
 740   while (len-- > 0)
 741     {
 742       c = *p++;
 743       n *= base;
 744       if( base == 8 && (c == '8' || c == '9'))
 745          error("Invalid digit \'%c\' in octal number.",c);
 746       if (c >= '0' && c <= '9')
 747         i = c - '0';
 748       else
 749         {
 750           if (base == 16 && c >= 'A' && c <= 'F')
 751             i = c - 'A' + 10;
 752           else
 753              return ERROR;
 754         }
 755       n+=i;
 756       if(i >= base)
 757          return ERROR;
 758       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 759          unsigned_p=1;          /* Try something unsigned */
 760       /* Don't do the range check if n==i and i==0, since that special
 761          case will give an overflow error. */
 762       if(RANGE_CHECK && n!=i && i)
 763       {
 764          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 765             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 766             range_error("Overflow on numeric constant.");
 767       }
 768          prevn=n;
 769     }
 770
 771   lexptr = p;
 772   if(*p == 'B' || *p == 'C' || *p == 'H')
 773      lexptr++;                  /* Advance past B,C or H */
 774
 775   if (ischar)
 776   {
 777      yylval.ulval = n;
 778      return CHAR;
 779   }
 780   else if ( unsigned_p && number_sign == 1)
 781   {
 782      yylval.ulval = n;
 783      return UINT;
 784   }
 785   else if((unsigned_p && (n<0))) {
 786      range_error("Overflow on numeric constant -- number too large.");
 787      /* But, this can return if range_check == range_warn.  */
 788   }
 789   yylval.lval = n;
 790   return INT;
 791 }
 792
 793
 794 /* Some tokens */
 795
 796 static struct
 797 {
 798    char name[2];
 799    int token;
 800 } tokentab2[] =
 801 {
 802     { {'<', '>'},    NOTEQUAL   },
 803     { {':', '='},    ASSIGN     },
 804     { {'<', '='},    LEQ        },
 805     { {'>', '='},    GEQ        },
 806     { {':', ':'},    COLONCOLON },
 807
 808 };
 809
 810 /* Some specific keywords */
 811
 812 struct keyword {
 813    char keyw[10];
 814    int token;
 815 };
 816
 817 static struct keyword keytab[] =
 818 {
 819     {"OR" ,   OROR       },
 820     {"IN",    IN         },/* Note space after IN */
 821     {"AND",   ANDAND     },
 822     {"ABS",   ABS        },
 823     {"CHR",   CHR        },
 824     {"DEC",   DEC        },
 825     {"NOT",   NOT        },
 826     {"DIV",   DIV        },
 827     {"INC",   INC        },
 828     {"MAX",   MAX_FUNC   },
 829     {"MIN",   MIN_FUNC   },
 830     {"MOD",   MOD        },
 831     {"ODD",   ODD        },
 832     {"CAP",   CAP        },
 833     {"ORD",   ORD        },
 834     {"VAL",   VAL        },
 835     {"EXCL",  EXCL       },
 836     {"HIGH",  HIGH       },
 837     {"INCL",  INCL       },
 838     {"SIZE",  SIZE       },
 839     {"FLOAT", FLOAT_FUNC },
 840     {"TRUNC", TRUNC      },
 841 };
 842
 843
 844 /* Read one token, getting characters through lexptr.  */
 845
 846 /* This is where we will check to make sure that the language and the operators used are
 847    compatible  */
 848
 849 static int
 850 yylex ()
 851 {
 852   register int c;
 853   register int namelen;
 854   register int i;
 855   register char *tokstart;
 856   register char quote;
 857
 858  retry:
 859
 860   tokstart = lexptr;
 861
 862
 863   /* See if it is a special token of length 2 */
 864   for( i = 0 ; i < sizeof tokentab2 / sizeof tokentab2[0] ; i++)
 865      if(!strncmp(tokentab2[i].name, tokstart, 2))
 866      {
 867         lexptr += 2;
 868         return tokentab2[i].token;
 869      }
 870
 871   switch (c = *tokstart)
 872     {
 873     case 0:
 874       return 0;
 875
 876     case ' ':
 877     case '\t':
 878     case '\n':
 879       lexptr++;
 880       goto retry;
 881
 882     case '(':
 883       paren_depth++;
 884       lexptr++;
 885       return c;
 886
 887     case ')':
 888       if (paren_depth == 0)
 889         return 0;
 890       paren_depth--;
 891       lexptr++;
 892       return c;
 893
 894     case ',':
 895       if (comma_terminates && paren_depth == 0)
 896         return 0;
 897       lexptr++;
 898       return c;
 899
 900     case '.':
 901       /* Might be a floating point number.  */
 902       if (lexptr[1] >= '0' && lexptr[1] <= '9')
 903         break;                  /* Falls into number code.  */
 904       else
 905       {
 906          lexptr++;
 907          return DOT;
 908       }
 909
 910 /* These are character tokens that appear as-is in the YACC grammar */
 911     case '+':
 912     case '-':
 913     case '*':
 914     case '/':
 915     case '^':
 916     case '<':
 917     case '>':
 918     case '[':
 919     case ']':
 920     case '=':
 921     case '{':
 922     case '}':
 923     case '#':
 924     case '@':
 925     case '~':
 926     case '&':
 927       lexptr++;
 928       return c;
 929
 930     case '\'' :
 931     case '"':
 932       quote = c;
 933       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
 934         if (c == '\\')
 935           {
 936             c = tokstart[++namelen];
 937             if (c >= '0' && c <= '9')
 938               {
 939                 c = tokstart[++namelen];
 940                 if (c >= '0' && c <= '9')
 941                   c = tokstart[++namelen];
 942               }
 943           }
 944       if(c != quote)
 945          error("Unterminated string or character constant.");
 946       yylval.sval.ptr = tokstart + 1;
 947       yylval.sval.length = namelen - 1;
 948       lexptr += namelen + 1;
 949
 950       if(namelen == 2)          /* Single character */
 951       {
 952            yylval.ulval = tokstart[1];
 953            return CHAR;
 954       }
 955       else
 956          return STRING;
 957     }
 958
 959   /* Is it a number?  */
 960   /* Note:  We have already dealt with the case of the token '.'.
 961      See case '.' above.  */
 962   if ((c >= '0' && c <= '9'))
 963     {
 964       /* It's a number.  */
 965       int got_dot = 0, got_e = 0;
 966       register char *p = tokstart;
 967       int toktype;
 968
 969       for (++p ;; ++p)
 970         {
 971           if (!got_e && (*p == 'e' || *p == 'E'))
 972             got_dot = got_e = 1;
 973           else if (!got_dot && *p == '.')
 974             got_dot = 1;
 975           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
 976                    && (*p == '-' || *p == '+'))
 977             /* This is the sign of the exponent, not the end of the
 978                number.  */
 979             continue;
 980           else if ((*p < '0' || *p > '9') &&
 981                    (*p < 'A' || *p > 'F') &&
 982                    (*p != 'H'))  /* Modula-2 hexadecimal number */
 983             break;
 984         }
 985         toktype = parse_number (p - tokstart);
 986         if (toktype == ERROR)
 987           {
 988             char *err_copy = (char *) alloca (p - tokstart + 1);
 989
 990             memcpy (err_copy, tokstart, p - tokstart);
 991             err_copy[p - tokstart] = 0;
 992             error ("Invalid number \"%s\".", err_copy);
 993           }
 994         lexptr = p;
 995         return toktype;
 996     }
 997
 998   if (!(c == '_' || c == '$'
 999         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1000     /* We must have come across a bad character (e.g. ';').  */
1001     error ("Invalid character '%c' in expression.", c);
1002
1003   /* It's a name.  See how long it is.  */
1004   namelen = 0;
1005   for (c = tokstart[namelen];
1006        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1007         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1008        c = tokstart[++namelen])
1009     ;
1010
1011   /* The token "if" terminates the expression and is NOT
1012      removed from the input stream.  */
1013   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1014     {
1015       return 0;
1016     }
1017
1018   lexptr += namelen;
1019
1020   /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1)
1021      and $$digits (equivalent to $<-digits> if you could type that).
1022      Make token type LAST, and put the number (the digits) in yylval.  */
1023
1024   if (*tokstart == '$')
1025     {
1026       register int negate = 0;
1027       c = 1;
1028       /* Double dollar means negate the number and add -1 as well.
1029          Thus $$ alone means -1.  */
1030       if (namelen >= 2 && tokstart[1] == '$')
1031         {
1032           negate = 1;
1033           c = 2;
1034         }
1035       if (c == namelen)
1036         {
1037           /* Just dollars (one or two) */
1038           yylval.lval = - negate;
1039           return LAST;
1040         }
1041       /* Is the rest of the token digits?  */
1042       for (; c < namelen; c++)
1043         if (!(tokstart[c] >= '0' && tokstart[c] <= '9'))
1044           break;
1045       if (c == namelen)
1046         {
1047           yylval.lval = atoi (tokstart + 1 + negate);
1048           if (negate)
1049             yylval.lval = - yylval.lval;
1050           return LAST;
1051         }
1052     }
1053
1054   /* Handle tokens that refer to machine registers:
1055      $ followed by a register name.  */
1056
1057   if (*tokstart == '$') {
1058     for (c = 0; c < NUM_REGS; c++)
1059       if (namelen - 1 == strlen (reg_names[c])
1060           && !strncmp (tokstart + 1, reg_names[c], namelen - 1))
1061         {
1062           yylval.lval = c;
1063           return REGNAME;
1064         }
1065     for (c = 0; c < num_std_regs; c++)
1066      if (namelen - 1 == strlen (std_regs[c].name)
1067          && !strncmp (tokstart + 1, std_regs[c].name, namelen - 1))
1068        {
1069          yylval.lval = std_regs[c].regnum;
1070          return REGNAME;
1071        }
1072   }
1073
1074
1075   /*  Lookup special keywords */
1076   for(i = 0 ; i < sizeof(keytab) / sizeof(keytab[0]) ; i++)
1077      if(namelen == strlen(keytab[i].keyw) && !strncmp(tokstart,keytab[i].keyw,namelen))
1078            return keytab[i].token;
1079
1080   yylval.sval.ptr = tokstart;
1081   yylval.sval.length = namelen;
1082
1083   /* Any other names starting in $ are debugger internal variables.  */
1084
1085   if (*tokstart == '$')
1086     {
1087       yylval.ivar = (struct internalvar *) lookup_internalvar (copy_name (yylval.sval) + 1);
1088       return INTERNAL_VAR;
1089     }
1090
1091
1092   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1093      functions.  If this is not so, then ...
1094      Use token-type TYPENAME for symbols that happen to be defined
1095      currently as names of types; NAME for other symbols.
1096      The caller is not constrained to care about the distinction.  */
1097  {
1098
1099
1100     char *tmp = copy_name (yylval.sval);
1101     struct symbol *sym;
1102
1103     if (lookup_partial_symtab (tmp))
1104       return BLOCKNAME;
1105     sym = lookup_symbol (tmp, expression_context_block,
1106                          VAR_NAMESPACE, 0, NULL);
1107     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1108       return BLOCKNAME;
1109     if (lookup_typename (copy_name (yylval.sval), expression_context_block, 1))
1110       return TYPENAME;
1111
1112     if(sym)
1113     {
1114        switch(sym->class)
1115        {
1116        case LOC_STATIC:
1117        case LOC_REGISTER:
1118        case LOC_ARG:
1119        case LOC_REF_ARG:
1120        case LOC_REGPARM:
1121        case LOC_LOCAL:
1122        case LOC_LOCAL_ARG:
1123        case LOC_CONST:
1124        case LOC_CONST_BYTES:
1125           return NAME;
1126
1127        case LOC_TYPEDEF:
1128           return TYPENAME;
1129
1130        case LOC_BLOCK:
1131           return BLOCKNAME;
1132
1133        case LOC_UNDEF:
1134           error("internal:  Undefined class in m2lex()");
1135
1136        case LOC_LABEL:
1137           error("internal:  Unforseen case in m2lex()");
1138        }
1139     }
1140     else
1141     {
1142        /* Built-in BOOLEAN type.  This is sort of a hack. */
1143        if(!strncmp(tokstart,"TRUE",4))
1144        {
1145           yylval.ulval = 1;
1146           return TRUE;
1147        }
1148        else if(!strncmp(tokstart,"FALSE",5))
1149        {
1150           yylval.ulval = 0;
1151           return FALSE;
1152        }
1153     }
1154
1155     /* Must be another type of name... */
1156     return NAME;
1157  }
1158 }
1159
1160 #if 0           /* Unused */
1161 static char *
1162 make_qualname(mod,ident)
1163    char *mod, *ident;
1164 {
1165    char *new = xmalloc(strlen(mod)+strlen(ident)+2);
1166
1167    strcpy(new,mod);
1168    strcat(new,".");
1169    strcat(new,ident);
1170    return new;
1171 }
1172 #endif  /* 0 */
1173
1174 static void
1175 yyerror(msg)
1176      char *msg; /* unused */
1177 {
1178    printf("Parsing:  %s\n",lexptr);
1179    if (yychar < 256)
1180      error("Invalid syntax in expression near character '%c'.",yychar);
1181    else
1182      error("Invalid syntax in expression");
1183 }
1184 \f
1185 /* Table of operators and their precedences for printing expressions.  */
1186
1187 const static struct op_print m2_op_print_tab[] = {
1188     {"+",   BINOP_ADD, PREC_ADD, 0},
1189     {"+",   UNOP_PLUS, PREC_PREFIX, 0},
1190     {"-",   BINOP_SUB, PREC_ADD, 0},
1191     {"-",   UNOP_NEG, PREC_PREFIX, 0},
1192     {"*",   BINOP_MUL, PREC_MUL, 0},
1193     {"/",   BINOP_DIV, PREC_MUL, 0},
1194     {"DIV", BINOP_INTDIV, PREC_MUL, 0},
1195     {"MOD", BINOP_REM, PREC_MUL, 0},
1196     {":=",  BINOP_ASSIGN, PREC_ASSIGN, 1},
1197     {"OR",  BINOP_OR, PREC_OR, 0},
1198     {"AND", BINOP_AND, PREC_AND, 0},
1199     {"NOT", UNOP_ZEROP, PREC_PREFIX, 0},
1200     {"=",   BINOP_EQUAL, PREC_EQUAL, 0},
1201     {"<>",  BINOP_NOTEQUAL, PREC_EQUAL, 0},
1202     {"<=",  BINOP_LEQ, PREC_ORDER, 0},
1203     {">=",  BINOP_GEQ, PREC_ORDER, 0},
1204     {">",   BINOP_GTR, PREC_ORDER, 0},
1205     {"<",   BINOP_LESS, PREC_ORDER, 0},
1206     {"^",   UNOP_IND, PREC_PREFIX, 0},
1207     {"@",   BINOP_REPEAT, PREC_REPEAT, 0},
1208 };
1209 \f
1210 /* The built-in types of Modula-2.  */
1211
1212 struct type *builtin_type_m2_char;
1213 struct type *builtin_type_m2_int;
1214 struct type *builtin_type_m2_card;
1215 struct type *builtin_type_m2_real;
1216 struct type *builtin_type_m2_bool;
1217
1218 struct type ** const (m2_builtin_types[]) =
1219 {
1220   &builtin_type_m2_char,
1221   &builtin_type_m2_int,
1222   &builtin_type_m2_card,
1223   &builtin_type_m2_real,
1224   &builtin_type_m2_bool,
1225   0
1226 };
1227
1228 const struct language_defn m2_language_defn = {
1229   "modula-2",
1230   language_m2,
1231   m2_builtin_types,
1232   range_check_on,
1233   type_check_on,
1234   m2_parse,                     /* parser */
1235   m2_error,                     /* parser error function */
1236   &builtin_type_m2_int,         /* longest signed   integral type */
1237   &builtin_type_m2_card,                /* longest unsigned integral type */
1238   &builtin_type_m2_real,                /* longest floating point type */
1239   "0%XH", "0%", "XH",           /* Hex   format string, prefix, suffix */
1240   "%oB",  "%",  "oB",           /* Octal format string, prefix, suffix */
1241   m2_op_print_tab,              /* expression operators for printing */
1242   LANG_MAGIC
1243 };
1244
1245 /* Initialization for Modula-2 */
1246
1247 void
1248 _initialize_m2_exp ()
1249 {
1250   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
1251   builtin_type_m2_int =
1252     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
1253                0,
1254                "INTEGER", (struct objfile *) NULL);
1255   builtin_type_m2_card =
1256     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
1257                TYPE_FLAG_UNSIGNED,
1258                "CARDINAL", (struct objfile *) NULL);
1259   builtin_type_m2_real =
1260     init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
1261                0,
1262                "REAL", (struct objfile *) NULL);
1263   builtin_type_m2_char =
1264     init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
1265                TYPE_FLAG_UNSIGNED,
1266                "CHAR", (struct objfile *) NULL);
1267   builtin_type_m2_bool =
1268     init_type (TYPE_CODE_BOOL, TARGET_INT_BIT / TARGET_CHAR_BIT,
1269                TYPE_FLAG_UNSIGNED,
1270                "BOOLEAN", (struct objfile *) NULL);
1271
1272   TYPE_NFIELDS(builtin_type_m2_bool) = 2;
1273   TYPE_FIELDS(builtin_type_m2_bool) =
1274      (struct field *) malloc (sizeof (struct field) * 2);
1275   TYPE_FIELD_BITPOS(builtin_type_m2_bool,0) = 0;
1276   TYPE_FIELD_NAME(builtin_type_m2_bool,0) = (char *)malloc(6);
1277   strcpy(TYPE_FIELD_NAME(builtin_type_m2_bool,0),"FALSE");
1278   TYPE_FIELD_BITPOS(builtin_type_m2_bool,1) = 1;
1279   TYPE_FIELD_NAME(builtin_type_m2_bool,1) = (char *)malloc(5);
1280   strcpy(TYPE_FIELD_NAME(builtin_type_m2_bool,1),"TRUE");
1281
1282   add_language (&m2_language_defn);
1283 }