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