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 static int yylex ();
  61
  62 /* The sign of the number being parsed. */
  63 int number_sign = 1;
  64
  65 /* The block that the module specified by the qualifer on an identifer is
  66    contained in, */
  67 struct block *modblock=0;
  68
  69 char *make_qualname();
  70
  71 /* #define      YYDEBUG 1 */
  72
  73 %}
  74
  75 /* Although the yacc "value" of an expression is not used,
  76    since the result is stored in the structure being created,
  77    other node types do have values.  */
  78
  79 %union
  80   {
  81     LONGEST lval;
  82     unsigned LONGEST ulval;
  83     double dval;
  84     struct symbol *sym;
  85     struct type *tval;
  86     struct stoken sval;
  87     int voidval;
  88     struct block *bval;
  89     enum exp_opcode opcode;
  90     struct internalvar *ivar;
  91
  92     struct type **tvec;
  93     int *ivec;
  94   }
  95
  96 %type <voidval> exp type_exp start set
  97 %type <voidval> variable
  98 %type <tval> type
  99 %type <bval> block
 100 %type <sym> fblock
 101
 102 %token <lval> INT HEX ERROR
 103 %token <ulval> UINT TRUE FALSE CHAR
 104 %token <dval> FLOAT
 105
 106 /* Both NAME and TYPENAME tokens represent symbols in the input,
 107    and both convey their data as strings.
 108    But a TYPENAME is a string that happens to be defined as a typedef
 109    or builtin type name (such as int or char)
 110    and a NAME is any other symbol.
 111
 112    Contexts where this distinction is not important can use the
 113    nonterminal "name", which matches either NAME or TYPENAME.  */
 114
 115 %token <sval> STRING
 116 %token <sval> NAME BLOCKNAME IDENT CONST VARNAME
 117 %token <sval> TYPENAME
 118
 119 %token SIZE CAP ORD HIGH ABS MIN MAX FLOAT_FUNC VAL CHR ODD TRUNC
 120 %token INC DEC INCL EXCL
 121
 122 /* The GDB scope operator */
 123 %token COLONCOLON
 124
 125 %token <lval> LAST REGNAME
 126
 127 %token <ivar> INTERNAL_VAR
 128
 129 /* M2 tokens */
 130 %left ','
 131 %left ABOVE_COMMA
 132 %nonassoc ASSIGN
 133 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
 134 %left OR
 135 %left AND '&'
 136 %left '@'
 137 %left '+' '-'
 138 %left '*' '/' DIV MOD
 139 %right UNARY
 140 %right '^' DOT '[' '('
 141 %right NOT '~'
 142 %left COLONCOLON QID
 143 /* This is not an actual token ; it is used for precedence.
 144 %right QID
 145 */
 146 %%
 147
 148 start   :       exp
 149         |       type_exp
 150         ;
 151
 152 type_exp:       type
 153                 { write_exp_elt_opcode(OP_TYPE);
 154                   write_exp_elt_type($1);
 155                   write_exp_elt_opcode(OP_TYPE);
 156                 }
 157         ;
 158
 159 /* Expressions */
 160
 161 exp     :       exp '^'   %prec UNARY
 162                         { write_exp_elt_opcode (UNOP_IND); }
 163
 164 exp     :       '-'
 165                         { number_sign = -1; }
 166                 exp    %prec UNARY
 167                         { number_sign = 1;
 168                           write_exp_elt_opcode (UNOP_NEG); }
 169         ;
 170
 171 exp     :       '+' exp    %prec UNARY
 172                 { write_exp_elt_opcode(UNOP_PLUS); }
 173         ;
 174
 175 exp     :       not_exp exp %prec UNARY
 176                         { write_exp_elt_opcode (UNOP_ZEROP); }
 177         ;
 178
 179 not_exp :       NOT
 180         |       '~'
 181         ;
 182
 183 exp     :       CAP '(' exp ')'
 184                         { write_exp_elt_opcode (UNOP_CAP); }
 185         ;
 186
 187 exp     :       ORD '(' exp ')'
 188                         { write_exp_elt_opcode (UNOP_ORD); }
 189         ;
 190
 191 exp     :       ABS '(' exp ')'
 192                         { write_exp_elt_opcode (UNOP_ABS); }
 193         ;
 194
 195 exp     :       HIGH '(' exp ')'
 196                         { write_exp_elt_opcode (UNOP_HIGH); }
 197         ;
 198
 199 exp     :       MIN '(' type ')'
 200                         { write_exp_elt_opcode (UNOP_MIN);
 201                           write_exp_elt_type ($3);
 202                           write_exp_elt_opcode (UNOP_MIN); }
 203         ;
 204
 205 exp     :       MAX '(' type ')'
 206                         { write_exp_elt_opcode (UNOP_MAX);
 207                           write_exp_elt_type ($3);
 208                           write_exp_elt_opcode (UNOP_MIN); }
 209         ;
 210
 211 exp     :       FLOAT_FUNC '(' exp ')'
 212                         { write_exp_elt_opcode (UNOP_FLOAT); }
 213         ;
 214
 215 exp     :       VAL '(' type ',' exp ')'
 216                         { write_exp_elt_opcode (BINOP_VAL);
 217                           write_exp_elt_type ($3);
 218                           write_exp_elt_opcode (BINOP_VAL); }
 219         ;
 220
 221 exp     :       CHR '(' exp ')'
 222                         { write_exp_elt_opcode (UNOP_CHR); }
 223         ;
 224
 225 exp     :       ODD '(' exp ')'
 226                         { write_exp_elt_opcode (UNOP_ODD); }
 227         ;
 228
 229 exp     :       TRUNC '(' exp ')'
 230                         { write_exp_elt_opcode (UNOP_TRUNC); }
 231         ;
 232
 233 exp     :       SIZE exp       %prec UNARY
 234                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 235         ;
 236
 237
 238 exp     :       INC '(' exp ')'
 239                         { write_exp_elt_opcode(UNOP_PREINCREMENT); }
 240         ;
 241
 242 exp     :       INC '(' exp ',' exp ')'
 243                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 244                           write_exp_elt_opcode(BINOP_ADD);
 245                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 246         ;
 247
 248 exp     :       DEC '(' exp ')'
 249                         { write_exp_elt_opcode(UNOP_PREDECREMENT);}
 250         ;
 251
 252 exp     :       DEC '(' exp ',' exp ')'
 253                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 254                           write_exp_elt_opcode(BINOP_SUB);
 255                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 256         ;
 257
 258 exp     :       exp DOT NAME
 259                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 260                           write_exp_string ($3);
 261                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 262         ;
 263
 264 exp     :       set
 265         ;
 266
 267 exp     :       exp IN set
 268                         { error("Sets are not implemented.");}
 269         ;
 270
 271 exp     :       INCL '(' exp ',' exp ')'
 272                         { error("Sets are not implemented.");}
 273         ;
 274
 275 exp     :       EXCL '(' exp ',' exp ')'
 276                         { error("Sets are not implemented.");}
 277
 278 set     :       '{' arglist '}'
 279                         { error("Sets are not implemented.");}
 280         |       type '{' arglist '}'
 281                         { error("Sets are not implemented.");}
 282         ;
 283
 284
 285 /* Modula-2 array subscript notation [a,b,c...] */
 286 exp     :       exp '['
 287                         /* This function just saves the number of arguments
 288                            that follow in the list.  It is *not* specific to
 289                            function types */
 290                         { start_arglist(); }
 291                 non_empty_arglist ']'  %prec DOT
 292                         { write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT);
 293                           write_exp_elt_longcst ((LONGEST) end_arglist());
 294                           write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT); }
 295         ;
 296
 297 exp     :       exp '('
 298                         /* This is to save the value of arglist_len
 299                            being accumulated by an outer function call.  */
 300                         { start_arglist (); }
 301                 arglist ')'     %prec DOT
 302                         { write_exp_elt_opcode (OP_FUNCALL);
 303                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 304                           write_exp_elt_opcode (OP_FUNCALL); }
 305         ;
 306
 307 arglist :
 308         ;
 309
 310 arglist :       exp
 311                         { arglist_len = 1; }
 312         ;
 313
 314 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 315                         { arglist_len++; }
 316         ;
 317
 318 non_empty_arglist
 319         :       exp
 320                         { arglist_len = 1; }
 321         ;
 322
 323 non_empty_arglist
 324         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 325                         { arglist_len++; }
 326         ;
 327
 328 /* GDB construct */
 329 exp     :       '{' type '}' exp  %prec UNARY
 330                         { write_exp_elt_opcode (UNOP_MEMVAL);
 331                           write_exp_elt_type ($2);
 332                           write_exp_elt_opcode (UNOP_MEMVAL); }
 333         ;
 334
 335 exp     :       type '(' exp ')' %prec UNARY
 336                         { write_exp_elt_opcode (UNOP_CAST);
 337                           write_exp_elt_type ($1);
 338                           write_exp_elt_opcode (UNOP_CAST); }
 339         ;
 340
 341 exp     :       '(' exp ')'
 342                         { }
 343         ;
 344
 345 /* Binary operators in order of decreasing precedence.  Note that some
 346    of these operators are overloaded!  (ie. sets) */
 347
 348 /* GDB construct */
 349 exp     :       exp '@' exp
 350                         { write_exp_elt_opcode (BINOP_REPEAT); }
 351         ;
 352
 353 exp     :       exp '*' exp
 354                         { write_exp_elt_opcode (BINOP_MUL); }
 355         ;
 356
 357 exp     :       exp '/' exp
 358                         { write_exp_elt_opcode (BINOP_DIV); }
 359         ;
 360
 361 exp     :       exp DIV exp
 362                         { write_exp_elt_opcode (BINOP_INTDIV); }
 363         ;
 364
 365 exp     :       exp MOD exp
 366                         { write_exp_elt_opcode (BINOP_REM); }
 367         ;
 368
 369 exp     :       exp '+' exp
 370                         { write_exp_elt_opcode (BINOP_ADD); }
 371         ;
 372
 373 exp     :       exp '-' exp
 374                         { write_exp_elt_opcode (BINOP_SUB); }
 375         ;
 376
 377 exp     :       exp '=' exp
 378                         { write_exp_elt_opcode (BINOP_EQUAL); }
 379         ;
 380
 381 exp     :       exp NOTEQUAL exp
 382                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 383         |       exp '#' exp
 384                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 385         ;
 386
 387 exp     :       exp LEQ exp
 388                         { write_exp_elt_opcode (BINOP_LEQ); }
 389         ;
 390
 391 exp     :       exp GEQ exp
 392                         { write_exp_elt_opcode (BINOP_GEQ); }
 393         ;
 394
 395 exp     :       exp '<' exp
 396                         { write_exp_elt_opcode (BINOP_LESS); }
 397         ;
 398
 399 exp     :       exp '>' exp
 400                         { write_exp_elt_opcode (BINOP_GTR); }
 401         ;
 402
 403 exp     :       exp AND exp
 404                         { write_exp_elt_opcode (BINOP_AND); }
 405         ;
 406
 407 exp     :       exp '&' exp
 408                         { write_exp_elt_opcode (BINOP_AND); }
 409         ;
 410
 411 exp     :       exp OR exp
 412                         { write_exp_elt_opcode (BINOP_OR); }
 413         ;
 414
 415 exp     :       exp ASSIGN exp
 416                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 417         ;
 418
 419
 420 /* Constants */
 421
 422 exp     :       TRUE
 423                         { write_exp_elt_opcode (OP_BOOL);
 424                           write_exp_elt_longcst ((LONGEST) $1);
 425                           write_exp_elt_opcode (OP_BOOL); }
 426         ;
 427
 428 exp     :       FALSE
 429                         { write_exp_elt_opcode (OP_BOOL);
 430                           write_exp_elt_longcst ((LONGEST) $1);
 431                           write_exp_elt_opcode (OP_BOOL); }
 432         ;
 433
 434 exp     :       INT
 435                         { write_exp_elt_opcode (OP_LONG);
 436                           write_exp_elt_type (builtin_type_m2_int);
 437                           write_exp_elt_longcst ((LONGEST) $1);
 438                           write_exp_elt_opcode (OP_LONG); }
 439         ;
 440
 441 exp     :       UINT
 442                         {
 443                           write_exp_elt_opcode (OP_LONG);
 444                           write_exp_elt_type (builtin_type_m2_card);
 445                           write_exp_elt_longcst ((LONGEST) $1);
 446                           write_exp_elt_opcode (OP_LONG);
 447                         }
 448         ;
 449
 450 exp     :       CHAR
 451                         { write_exp_elt_opcode (OP_LONG);
 452                           write_exp_elt_type (builtin_type_m2_char);
 453                           write_exp_elt_longcst ((LONGEST) $1);
 454                           write_exp_elt_opcode (OP_LONG); }
 455         ;
 456
 457
 458 exp     :       FLOAT
 459                         { write_exp_elt_opcode (OP_DOUBLE);
 460                           write_exp_elt_type (builtin_type_m2_real);
 461                           write_exp_elt_dblcst ($1);
 462                           write_exp_elt_opcode (OP_DOUBLE); }
 463         ;
 464
 465 exp     :       variable
 466         ;
 467
 468 /* The GDB internal variable $$, et al. */
 469 exp     :       LAST
 470                         { write_exp_elt_opcode (OP_LAST);
 471                           write_exp_elt_longcst ((LONGEST) $1);
 472                           write_exp_elt_opcode (OP_LAST); }
 473         ;
 474
 475 exp     :       REGNAME
 476                         { write_exp_elt_opcode (OP_REGISTER);
 477                           write_exp_elt_longcst ((LONGEST) $1);
 478                           write_exp_elt_opcode (OP_REGISTER); }
 479         ;
 480
 481 exp     :       SIZE '(' type ')'       %prec UNARY
 482                         { write_exp_elt_opcode (OP_LONG);
 483                           write_exp_elt_type (builtin_type_int);
 484                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 485                           write_exp_elt_opcode (OP_LONG); }
 486         ;
 487
 488 exp     :       STRING
 489                         { write_exp_elt_opcode (OP_M2_STRING);
 490                           write_exp_string ($1);
 491                           write_exp_elt_opcode (OP_M2_STRING); }
 492         ;
 493
 494 /* This will be used for extensions later.  Like adding modules. */
 495 block   :       fblock
 496                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 497         ;
 498
 499 fblock  :       BLOCKNAME
 500                         { struct symbol *sym
 501                             = lookup_symbol (copy_name ($1), expression_context_block,
 502                                              VAR_NAMESPACE, 0, NULL);
 503                           $$ = sym;}
 504         ;
 505
 506
 507 /* GDB scope operator */
 508 fblock  :       block COLONCOLON BLOCKNAME
 509                         { struct symbol *tem
 510                             = lookup_symbol (copy_name ($3), $1,
 511                                              VAR_NAMESPACE, 0, NULL);
 512                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 513                             error ("No function \"%s\" in specified context.",
 514                                    copy_name ($3));
 515                           $$ = tem;
 516                         }
 517         ;
 518
 519 /* Useful for assigning to PROCEDURE variables */
 520 variable:       fblock
 521                         { write_exp_elt_opcode(OP_VAR_VALUE);
 522                           write_exp_elt_sym ($1);
 523                           write_exp_elt_opcode (OP_VAR_VALUE); }
 524         ;
 525
 526 /* GDB internal ($foo) variable */
 527 variable:       INTERNAL_VAR
 528                         { write_exp_elt_opcode (OP_INTERNALVAR);
 529                           write_exp_elt_intern ($1);
 530                           write_exp_elt_opcode (OP_INTERNALVAR); }
 531         ;
 532
 533 /* GDB scope operator */
 534 variable:       block COLONCOLON NAME
 535                         { struct symbol *sym;
 536                           sym = lookup_symbol (copy_name ($3), $1,
 537                                                VAR_NAMESPACE, 0, NULL);
 538                           if (sym == 0)
 539                             error ("No symbol \"%s\" in specified context.",
 540                                    copy_name ($3));
 541
 542                           write_exp_elt_opcode (OP_VAR_VALUE);
 543                           write_exp_elt_sym (sym);
 544                           write_exp_elt_opcode (OP_VAR_VALUE); }
 545         ;
 546
 547 /* Base case for variables. */
 548 variable:       NAME
 549                         { struct symbol *sym;
 550                           int is_a_field_of_this;
 551
 552                           sym = lookup_symbol (copy_name ($1),
 553                                                expression_context_block,
 554                                                VAR_NAMESPACE,
 555                                                &is_a_field_of_this,
 556                                                NULL);
 557                           if (sym)
 558                             {
 559                               switch (sym->class)
 560                                 {
 561                                 case LOC_REGISTER:
 562                                 case LOC_ARG:
 563                                 case LOC_LOCAL:
 564                                   if (innermost_block == 0 ||
 565                                       contained_in (block_found,
 566                                                     innermost_block))
 567                                     innermost_block = block_found;
 568                                 }
 569                               write_exp_elt_opcode (OP_VAR_VALUE);
 570                               write_exp_elt_sym (sym);
 571                               write_exp_elt_opcode (OP_VAR_VALUE);
 572                             }
 573                           else
 574                             {
 575                               register int i;
 576                               register char *arg = copy_name ($1);
 577
 578                               for (i = 0; i < misc_function_count; i++)
 579                                 if (!strcmp (misc_function_vector[i].name, arg))
 580                                   break;
 581
 582                               if (i < misc_function_count)
 583                                 {
 584                                   enum misc_function_type mft =
 585                                     (enum misc_function_type)
 586                                       misc_function_vector[i].type;
 587
 588                                   write_exp_elt_opcode (OP_LONG);
 589                                   write_exp_elt_type (builtin_type_int);
 590                                   write_exp_elt_longcst ((LONGEST) misc_function_vector[i].address);
 591                                   write_exp_elt_opcode (OP_LONG);
 592                                   write_exp_elt_opcode (UNOP_MEMVAL);
 593                                   if (mft == mf_data || mft == mf_bss)
 594                                     write_exp_elt_type (builtin_type_int);
 595                                   else if (mft == mf_text)
 596                                     write_exp_elt_type (lookup_function_type (builtin_type_int));
 597                                   else
 598                                     write_exp_elt_type (builtin_type_char);
 599                                   write_exp_elt_opcode (UNOP_MEMVAL);
 600                                 }
 601                               else if (symtab_list == 0
 602                                        && partial_symtab_list == 0)
 603                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 604                               else
 605                                 error ("No symbol \"%s\" in current context.",
 606                                        copy_name ($1));
 607                             }
 608                         }
 609         ;
 610
 611 type
 612         :       TYPENAME
 613                         { $$ = lookup_typename (copy_name ($1),
 614                                                 expression_context_block, 0); }
 615
 616         ;
 617
 618 %%
 619
 620 #if 0  /* FIXME! */
 621 int
 622 overflow(a,b)
 623    long a,b;
 624 {
 625    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
 626 }
 627
 628 int
 629 uoverflow(a,b)
 630    unsigned long a,b;
 631 {
 632    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
 633 }
 634 #endif /* FIXME */
 635
 636 /* Take care of parsing a number (anything that starts with a digit).
 637    Set yylval and return the token type; update lexptr.
 638    LEN is the number of characters in it.  */
 639
 640 /*** Needs some error checking for the float case ***/
 641
 642 static int
 643 parse_number (olen)
 644      int olen;
 645 {
 646   register char *p = lexptr;
 647   register LONGEST n = 0;
 648   register LONGEST prevn = 0;
 649   register int c,i,ischar=0;
 650   register int base = input_radix;
 651   register int len = olen;
 652   char *err_copy;
 653   int unsigned_p = number_sign == 1 ? 1 : 0;
 654
 655   extern double atof ();
 656
 657   if(p[len-1] == 'H')
 658   {
 659      base = 16;
 660      len--;
 661   }
 662   else if(p[len-1] == 'C' || p[len-1] == 'B')
 663   {
 664      base = 8;
 665      ischar = p[len-1] == 'C';
 666      len--;
 667   }
 668
 669   /* Scan the number */
 670   for (c = 0; c < len; c++)
 671   {
 672     if (p[c] == '.' && base == 10)
 673       {
 674         /* It's a float since it contains a point.  */
 675         yylval.dval = atof (p);
 676         lexptr += len;
 677         return FLOAT;
 678       }
 679     if (p[c] == '.' && base != 10)
 680        error("Floating point numbers must be base 10.");
 681     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 682        error("Invalid digit \'%c\' in number.",p[c]);
 683  }
 684
 685   while (len-- > 0)
 686     {
 687       c = *p++;
 688       n *= base;
 689       if( base == 8 && (c == '8' || c == '9'))
 690          error("Invalid digit \'%c\' in octal number.",c);
 691       if (c >= '0' && c <= '9')
 692         i = c - '0';
 693       else
 694         {
 695           if (base == 16 && c >= 'A' && c <= 'F')
 696             i = c - 'A' + 10;
 697           else
 698              return ERROR;
 699         }
 700       n+=i;
 701       if(i >= base)
 702          return ERROR;
 703       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 704          unsigned_p=1;          /* Try something unsigned */
 705       /* Don't do the range check if n==i and i==0, since that special
 706          case will give an overflow error. */
 707       if(RANGE_CHECK && n!=i && i)
 708       {
 709          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 710             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 711             range_error("Overflow on numeric constant.");
 712       }
 713          prevn=n;
 714     }
 715
 716   lexptr = p;
 717   if(*p == 'B' || *p == 'C' || *p == 'H')
 718      lexptr++;                  /* Advance past B,C or H */
 719
 720   if (ischar)
 721   {
 722      yylval.ulval = n;
 723      return CHAR;
 724   }
 725   else if ( unsigned_p && number_sign == 1)
 726   {
 727      yylval.ulval = n;
 728      return UINT;
 729   }
 730   else if((unsigned_p && (n<0))) {
 731      range_error("Overflow on numeric constant -- number too large.");
 732      /* But, this can return if range_check == range_warn.  */
 733   }
 734   yylval.lval = n;
 735   return INT;
 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 ** const (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 const struct language_defn m2_language_defn = {
1173   "modula-2",
1174   language_m2,
1175   m2_builtin_types,
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 }