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