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