util/grind/pascal.c

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