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