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