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