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