util/grind/modula-2.c

   1 /* $Id: modula-2.c,v 1.13 1994/06/24 11:00:31 ceriel Exp $ */
   2
   3 /* Language dependant support; this one is for Modula-2 */
   4
   5 #include <stdio.h>
   6 #include <alloc.h>
   7 #include <assert.h>
   8
   9 #include "position.h"
  10 #include "class.h"
  11 #include "langdep.h"
  12 #include "Lpars.h"
  13 #include "idf.h"
  14 #include "token.h"
  15 #include "expr.h"
  16 #include "tree.h"
  17 #include "operator.h"
  18 #include "misc.h"
  19
  20 extern FILE *db_out, *db_in;
  21
  22 extern double
  23         atof();
  24
  25 static int
  26         print_string(),
  27         print_char(),
  28         get_number(),
  29         getname(),
  30         get_token(),
  31         getstring(),
  32         print_op(),
  33         binop_prio(),
  34         unop_prio(),
  35         fix_bin_to_pref();
  36
  37 static long
  38         array_elsize();
  39
  40 static struct langdep m2 = {
  41         1,
  42
  43         "%ld",
  44         "%loB",
  45         "%lXH",
  46         "%lu",
  47         "%lXH",
  48         "%.14G",
  49
  50         "[",
  51         "]",
  52         "(",
  53         ")",
  54         "{",
  55         "}",
  56
  57         print_string,
  58         print_char,
  59         array_elsize,
  60         binop_prio,
  61         unop_prio,
  62         getstring,
  63         getname,
  64         get_number,
  65         get_token,
  66         print_op,
  67         fix_bin_to_pref
  68 };
  69
  70 struct langdep *m2_dep = &m2;
  71
  72 static
  73 print_char(c)
  74   int   c;
  75 {
  76   c &= 0377;
  77   fprintf(db_out, (c >= 040 && c < 0177) ? "'%c'" : "%oC", c);
  78 }
  79
  80 static
  81 print_string(f, s, len)
  82   FILE  *f;
  83   char  *s;
  84   int   len;
  85 {
  86   register char *str = s;
  87   int delim = '\'';
  88
  89   while (*str) {
  90         if (*str++ == '\'') delim = '"';
  91   }
  92   fprintf(f, "%c%.*s%c", delim, len, s, delim);
  93 }
  94
  95 extern long     int_size;
  96
  97 static long
  98 array_elsize(size)
  99   long  size;
 100 {
 101   if (! (int_size % size)) return size;
 102   if (! (size % int_size)) return size;
 103   return ((size + int_size - 1) / int_size) * int_size;
 104 }
 105
 106 static int
 107 unop_prio(op)
 108   int   op;
 109 {
 110   switch(op) {
 111   case E_NOT:
 112         return 5;
 113   case E_MIN:
 114   case E_PLUS:
 115         return 3;
 116   }
 117   return 1;
 118 }
 119
 120 static int
 121 binop_prio(op)
 122   int   op;
 123 {
 124   switch(op) {
 125   case E_SELECT:
 126         return 9;
 127   case E_ARRAY:
 128         return 5;
 129   case E_AND:
 130   case E_MUL:
 131   case E_DIV:
 132   case E_MOD:
 133         return 4;
 134
 135   case E_PLUS:
 136   case E_MIN:
 137   case E_OR:
 138         return 3;
 139
 140   case E_IN:
 141   case E_EQUAL:
 142   case E_NOTEQUAL:
 143   case E_LTEQUAL:
 144   case E_GTEQUAL:
 145   case E_LT:
 146   case E_GT:
 147         return 2;
 148   }
 149   return 1;
 150 }
 151
 152 static int
 153 get_number(ch)
 154   register int  ch;
 155 {
 156   /*    The problem arising with the "parsing" of a number
 157         is that we don't know the base in advance so we
 158         have to read the number with the help of a rather
 159         complex finite automaton.
 160   */
 161   enum statetp {Oct,Hex,Dec,OctEndOrHex,End,Real};
 162   register enum statetp state;
 163   char buf[512+1];
 164   register int base = 10;
 165   register char *np = &buf[0];
 166
 167   *np++ = ch;
 168   state = is_oct(ch) ? Oct : Dec;
 169   ch = getc(db_in);
 170   for (;;) {
 171         switch(state) {
 172         case Oct:
 173                 while (is_oct(ch))      {
 174                         if (np < &buf[512]) *np++ = ch;
 175                         ch = getc(db_in);
 176                 }
 177                 if (ch == 'B' || ch == 'C') {
 178                         state = OctEndOrHex;
 179                         break;
 180                 }
 181                 /* Fall Through */
 182         case Dec:
 183                 base = 10;
 184                 while (is_dig(ch))      {
 185                         if (np < &buf[512]) {
 186                                 *np++ = ch;
 187                         }
 188                         ch = getc(db_in);
 189                 }
 190                 if (is_hex(ch)) state = Hex;
 191                 else if (ch == '.') state = Real;
 192                 else {
 193                         state = End;
 194                         if (ch == 'H') base = 16;
 195                         else ungetc(ch, db_in);
 196                 }
 197                 break;
 198
 199         case Hex:
 200                 while (is_hex(ch))      {
 201                         if (np < &buf[512]) *np++ = ch;
 202                         ch = getc(db_in);
 203                 }
 204                 base = 16;
 205                 state = End;
 206                 if (ch != 'H') {
 207                         error("H expected after hex number");
 208                         ungetc(ch, db_in);
 209                 }
 210                 break;
 211
 212         case OctEndOrHex:
 213                 if (np < &buf[512]) *np++ = ch;
 214                 ch = getc(db_in);
 215                 if (ch == 'H') {
 216                         base = 16;
 217                         state = End;
 218                         break;
 219                 }
 220                 if (is_hex(ch)) {
 221                         state = Hex;
 222                         break;
 223                 }
 224                 ungetc(ch, db_in);
 225                 ch = *--np;
 226                 *np++ = '\0';
 227                 /* Fall through */
 228
 229         case End:
 230                 *np = '\0';
 231                 if (np >= &buf[512]) {
 232                         tok.ival = 1;
 233                         error("constant too long");
 234                 }
 235                 else {
 236                         np = &buf[0];
 237                         while (*np == '0') np++;
 238                         tok.ival = 0;
 239                         while (*np) {
 240                                 int c;
 241
 242                                 if (is_dig(*np)) {
 243                                         c = *np++ - '0';
 244                                 }
 245                                 else {
 246                                         c = *np++ - 'A' + 10;
 247                                 }
 248                                 tok.ival *= base;
 249                                 tok.ival += c;
 250                         }
 251                 }
 252                 return INTEGER;
 253         }
 254         if (state == Real) break;
 255   }
 256
 257   /* a real real constant */
 258   if (np < &buf[512]) *np++ = '.';
 259
 260   ch = getc(db_in);
 261   while (is_dig(ch)) {
 262         /*      Fractional part
 263         */
 264         if (np < &buf[512]) *np++ = ch;
 265         ch = getc(db_in);
 266   }
 267
 268   if (ch == 'E') {
 269         /*      Scale factor
 270         */
 271         if (np < &buf[512]) *np++ = ch;
 272         ch = getc(db_in);
 273         if (ch == '+' || ch == '-') {
 274                 /*      Signed scalefactor
 275                 */
 276                 if (np < &buf[512]) *np++ = ch;
 277                 ch = getc(db_in);
 278         }
 279         if (is_dig(ch)) {
 280                 do {
 281                         if (np < &buf[512]) *np++ = ch;
 282                         ch = getc(db_in);
 283                 } while (is_dig(ch));
 284         }
 285         else {
 286                 error("bad scale factor");
 287         }
 288   }
 289
 290   *np++ = '\0';
 291   ungetc(ch, db_in);
 292
 293   if (np >= &buf[512]) {
 294         tok.fval = 0.0;
 295         error("real constant too long");
 296   }
 297   else  tok.fval = atof(buf);
 298   return REAL;
 299 }
 300
 301 static int
 302 getname(c)
 303   register int  c;
 304 {
 305   char  buf[512+1];
 306   register char *p = &buf[0];
 307   register struct idf *id;
 308
 309   do {
 310         if (p - buf < 512) *p++ = c;
 311         c = getc(db_in);
 312   } while (in_idf(c));
 313   ungetc(c, db_in);
 314   *p = 0;
 315   /* now recognize AND, DIV, IN, MOD, NOT, OR */
 316   switch(buf[0]) {
 317   case 'A':
 318         if (strcmp(buf, "AND") == 0) {
 319                 tok.ival = E_AND;
 320                 return BIN_OP;
 321         }
 322         break;
 323   case 'D':
 324         if (strcmp(buf, "DIV") == 0) {
 325                 tok.ival = E_DIV;
 326                 return BIN_OP;
 327         }
 328         break;
 329   case 'I':
 330         if (strcmp(buf, "IN") == 0) {
 331                 tok.ival = E_IN;
 332                 return BIN_OP;
 333         }
 334         break;
 335   case 'M':
 336         if (strcmp(buf, "MOD") == 0) {
 337                 tok.ival = E_MOD;
 338                 return BIN_OP;
 339         }
 340         break;
 341   case 'N':
 342         if (strcmp(buf, "NOT") == 0) {
 343                 tok.ival = E_NOT;
 344                 return PREF_OP;
 345         }
 346         break;
 347   case 'O':
 348         if (strcmp(buf, "OR") == 0) {
 349                 tok.ival = E_OR;
 350                 return BIN_OP;
 351         }
 352         break;
 353   }
 354   id = str2idf(buf, 1);
 355   tok.idf = id;
 356   tok.str = id->id_text;
 357   return id->id_reserved ? id->id_reserved : NAME;
 358 }
 359
 360 static int
 361 get_token(c)
 362   register int  c;
 363 {
 364   switch(c) {
 365   case '[':
 366         tok.ival = E_ARRAY;
 367         /* fall through */
 368   case '(':
 369   case ')':
 370   case ']':
 371   case '`':
 372   case '{':
 373   case '}':
 374   case ':':
 375   case ',':
 376   case '\\':
 377         return c;
 378
 379   case '.':
 380         tok.ival = E_SELECT;
 381         return SEL_OP;
 382   case '+':
 383         tok.ival = E_PLUS;
 384         return PREF_OR_BIN_OP;
 385   case '-':
 386         tok.ival = E_MIN;
 387         return PREF_OR_BIN_OP;
 388   case '*':
 389         tok.ival = E_MUL;
 390         return BIN_OP;
 391   case '/':
 392         tok.ival = E_DIV;
 393         return BIN_OP;
 394   case '&':
 395         tok.ival = E_AND;
 396         return BIN_OP;
 397   case '|':
 398         tok.ival = E_OR;
 399         return BIN_OP;
 400   case '=':
 401         tok.ival = E_EQUAL;
 402         return BIN_OP;
 403   case '#':
 404         tok.ival = E_NOTEQUAL;
 405         return BIN_OP;
 406   case '<':
 407         c = getc(db_in);
 408         if (c == '>') {
 409                 tok.ival = E_NOTEQUAL;
 410                 return BIN_OP;
 411         }
 412         if (c == '=') {
 413                 tok.ival = E_LTEQUAL;
 414                 return BIN_OP;
 415         }
 416         ungetc(c, db_in);
 417         tok.ival = E_LT;
 418         return BIN_OP;
 419   case '>':
 420         c = getc(db_in);
 421         if (c == '=') {
 422                 tok.ival = E_GTEQUAL;
 423                 return BIN_OP;
 424         }
 425         ungetc(c, db_in);
 426         tok.ival = E_GT;
 427         return BIN_OP;
 428   case '^':
 429         tok.ival = E_DEREF;
 430         return POST_OP;
 431   case '~':
 432         tok.ival = E_NOT;
 433         return PREF_OP;
 434   default:
 435         error((c >= 040 && c < 0177) ? "%s'%c'" : "%s'\\0%o'", "illegal character ", c);
 436         return LLlex();
 437   }
 438 }
 439
 440 static int
 441 getstring(c)
 442   int   c;
 443 {
 444   register int ch;
 445   char buf[512];
 446   register int len = 0;
 447
 448   while (ch = getc(db_in), ch != c) {
 449         if (ch == '\n') {
 450                 error("newline in string");
 451                 ungetc(ch, db_in);
 452                 break;
 453         }
 454         buf[len++] = ch;
 455   }
 456   buf[len++] = 0;
 457   tok.str = Salloc(buf, (unsigned) len);
 458   return STRING;
 459 }
 460
 461 static
 462 print_op(f, p)
 463   FILE          *f;
 464   p_tree        p;
 465 {
 466   switch(p->t_oper) {
 467   case OP_UNOP:
 468         switch(p->t_whichoper) {
 469         case E_MIN:
 470                 fputs("-", f);
 471                 print_node(f, p->t_args[0], 0);
 472                 break;
 473         case E_PLUS:
 474                 fputs("+", f);
 475                 print_node(f, p->t_args[0], 0);
 476                 break;
 477         case E_NOT:
 478                 fputs("~", f);
 479                 print_node(f, p->t_args[0], 0);
 480                 break;
 481         case E_DEREF:
 482                 print_node(f, p->t_args[0], 0);
 483                 fputs("^", f);
 484                 break;
 485         }
 486         break;
 487   case OP_BINOP:
 488         if (p->t_whichoper == E_ARRAY) {
 489                 print_node(f, p->t_args[0], 0);
 490                 fputs("[", f);
 491                 print_node(f, p->t_args[1], 0);
 492                 fputs("]", f);
 493                 break;
 494         }
 495         if (p->t_whichoper == E_SELECT) {
 496                 print_node(f, p->t_args[0], 0);
 497                 fputs(".", f);
 498                 print_node(f, p->t_args[1], 0);
 499                 break;
 500         }
 501         fputs("(", f);
 502         print_node(f, p->t_args[0], 0);
 503         switch(p->t_whichoper) {
 504         case E_AND:
 505                 fputs("&", f);
 506                 break;
 507         case E_OR:
 508                 fputs("|", f);
 509                 break;
 510         case E_DIV:
 511                 fputs("/", f);
 512                 break;
 513         case E_MOD:
 514                 fputs(" MOD ", f);
 515                 break;
 516         case E_IN:
 517                 fputs(" IN ", f);
 518                 break;
 519         case E_PLUS:
 520                 fputs("+", f);
 521                 break;
 522         case E_MIN:
 523                 fputs("-", f);
 524                 break;
 525         case E_MUL:
 526                 fputs("*", f);
 527                 break;
 528         case E_EQUAL:
 529                 fputs("=", f);
 530                 break;
 531         case E_NOTEQUAL:
 532                 fputs("#", f);
 533                 break;
 534         case E_LTEQUAL:
 535                 fputs("<=", f);
 536                 break;
 537         case E_GTEQUAL:
 538                 fputs(">=", f);
 539                 break;
 540         case E_LT:
 541                 fputs("<", f);
 542                 break;
 543         case E_GT:
 544                 fputs(">", f);
 545                 break;
 546         }
 547         print_node(f, p->t_args[1], 0);
 548         fputs(")", f);
 549         break;
 550   }
 551 }
 552
 553 static
 554 fix_bin_to_pref()
 555 {
 556   /* No problems of this kind in Modula-2 */
 557 }