gdb/m2-exp.y

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