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