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