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