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