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