/* $Id$ */ /* Language dependant support; this one is for Pascal */ #include #include #include #include #include "position.h" #include "class.h" #include "langdep.h" #include "Lpars.h" #include "idf.h" #include "token.h" #include "expr.h" #include "tree.h" #include "operator.h" #include "misc.h" extern FILE *db_out, *db_in; extern double atof(); extern long atol(); static int print_string(), print_char(), get_number(), getname(), get_token(), getstring(), print_op(), binop_prio(), unop_prio(), fix_bin_to_pref(); static long array_elsize(); static struct langdep pascal = { 1, "%ld", "0%lo", "0x%lx", "%lu", "0x%lx", "%.14g", "[", "]", "(", ")", "[", "]", print_string, print_char, array_elsize, binop_prio, unop_prio, getstring, getname, get_number, get_token, print_op, fix_bin_to_pref }; struct langdep *pascal_dep = &pascal; static print_char(c) int c; { c &= 0377; fprintf(db_out, (c >= 040 && c < 0177) ? "'%c'" : "chr(%d)", c); } static print_string(f, s, len) FILE *f; char *s; int len; { register char *str = s; putc('\'', f); while (*str && len > 0) { putc(*str, f); if (*str++ == '\'') putc('\'', f); len--; } putc('\'', f); } extern long int_size; static long array_elsize(size) long size; { if (! (int_size % size)) return size; if (! (size % int_size)) return size; return ((size + int_size - 1) / int_size) * int_size; } static int unop_prio(op) int op; { switch(op) { case E_NOT: return 8; case E_MIN: case E_PLUS: return 6; } return 1; } static int binop_prio(op) int op; { switch(op) { case E_SELECT: return 9; case E_ARRAY: return 9; case E_AND: case E_MUL: case E_DIV: case E_MOD: return 7; case E_PLUS: case E_MIN: case E_OR: return 6; case E_IN: case E_EQUAL: case E_NOTEQUAL: case E_LTEQUAL: case E_GTEQUAL: case E_LT: case E_GT: return 5; } return 1; } static int get_number(ch) register int ch; { char buf[512+1]; register char *np = &buf[0]; int real_mode = 0; while (is_dig(ch)) { if (np < &buf[512]) *np++ = ch; ch = getc(db_in); } if (ch == '.') { real_mode = 1; if (np < &buf[512]) *np++ = '.'; ch = getc(db_in); while (is_dig(ch)) { /* Fractional part */ if (np < &buf[512]) *np++ = ch; ch = getc(db_in); } } if (ch == 'E' || ch == 'e') { /* Scale factor */ real_mode = 1; if (np < &buf[512]) *np++ = ch; ch = getc(db_in); if (ch == '+' || ch == '-') { /* Signed scalefactor */ if (np < &buf[512]) *np++ = ch; ch = getc(db_in); } if (is_dig(ch)) { do { if (np < &buf[512]) *np++ = ch; ch = getc(db_in); } while (is_dig(ch)); } else { error("bad scale factor"); } } *np++ = '\0'; ungetc(ch, db_in); if (np >= &buf[512]) { if (! real_mode) { tok.ival = 0; error("constant too long"); } else { tok.fval = 0.0; error("real constant too long"); } } else if (! real_mode) { tok.ival = atol(buf); return INTEGER; } tok.fval = atof(buf); return REAL; } static int getname(c) register int c; { char buf[512+1]; register char *p = &buf[0]; register struct idf *id; do { if (isupper(c)) c = tolower(c); if (p - buf < 512) *p++ = c; c = getc(db_in); } while (in_idf(c)); ungetc(c, db_in); *p = 0; /* now recognize and, div, in, mod, not, or */ switch(buf[0]) { case 'a': if (strcmp(buf, "and") == 0) { tok.ival = E_AND; return BIN_OP; } break; case 'd': if (strcmp(buf, "div") == 0) { tok.ival = E_DIV; return BIN_OP; } break; case 'i': if (strcmp(buf, "in") == 0) { tok.ival = E_IN; return BIN_OP; } break; case 'm': if (strcmp(buf, "mod") == 0) { tok.ival = E_MOD; return BIN_OP; } break; case 'n': if (strcmp(buf, "not") == 0) { tok.ival = E_NOT; return PREF_OP; } break; case 'o': if (strcmp(buf, "or") == 0) { tok.ival = E_OR; return BIN_OP; } break; } id = str2idf(buf, 1); tok.idf = id; tok.str = id->id_text; return id->id_reserved ? id->id_reserved : NAME; } static int get_token(c) register int c; { switch(c) { case '[': tok.ival = E_ARRAY; /* fall through */ case '(': case ')': case ']': case '`': case '{': case '}': case ':': case ',': case '\\': return c; case '.': tok.ival = E_SELECT; return SEL_OP; case '+': tok.ival = E_PLUS; return PREF_OR_BIN_OP; case '-': tok.ival = E_MIN; return PREF_OR_BIN_OP; case '*': tok.ival = E_MUL; return BIN_OP; case '/': tok.ival = E_DIV; return BIN_OP; case '=': tok.ival = E_EQUAL; return BIN_OP; case '<': c = getc(db_in); if (c == '>') { tok.ival = E_NOTEQUAL; return BIN_OP; } if (c == '=') { tok.ival = E_LTEQUAL; return BIN_OP; } ungetc(c, db_in); tok.ival = E_LT; return BIN_OP; case '>': c = getc(db_in); if (c == '=') { tok.ival = E_GTEQUAL; return BIN_OP; } ungetc(c, db_in); tok.ival = E_GT; return BIN_OP; case '^': tok.ival = E_DEREF; return POST_OP; default: error((c >= 040 && c < 0177) ? "%s'%c'" : "%s'\\0%o'", "illegal character ", c); return LLlex(); } } static int getstring(c) int c; { register int ch; char buf[512]; register int len = 0; for (;;) { ch = getc(db_in); if (ch == c) { ch = getc(db_in); if (ch != c) { ungetc(ch, db_in); break; } } if (ch == '\n') { error("newline in string"); ungetc(ch, db_in); break; } buf[len++] = ch; } buf[len++] = 0; tok.str = Salloc(buf, (unsigned) len); return STRING; } static print_op(f, p) FILE *f; p_tree p; { switch(p->t_oper) { case OP_UNOP: switch(p->t_whichoper) { case E_MIN: fputs("-", f); print_node(f, p->t_args[0], 0); break; case E_PLUS: fputs("+", f); print_node(f, p->t_args[0], 0); break; case E_NOT: fputs(" not ", f); print_node(f, p->t_args[0], 0); break; case E_DEREF: print_node(f, p->t_args[0], 0); fputs("^", f); break; } break; case OP_BINOP: if (p->t_whichoper == E_ARRAY) { print_node(f, p->t_args[0], 0); fputs("[", f); print_node(f, p->t_args[1], 0); fputs("]", f); break; } if (p->t_whichoper == E_SELECT) { print_node(f, p->t_args[0], 0); fputs(".", f); print_node(f, p->t_args[1], 0); break; } fputs("(", f); print_node(f, p->t_args[0], 0); switch(p->t_whichoper) { case E_AND: fputs(" and ", f); break; case E_OR: fputs(" or ", f); break; case E_DIV: fputs("/", f); break; case E_MOD: fputs(" mod ", f); break; case E_IN: fputs(" in ", f); break; case E_PLUS: fputs("+", f); break; case E_MIN: fputs("-", f); break; case E_MUL: fputs("*", f); break; case E_EQUAL: fputs("=", f); break; case E_NOTEQUAL: fputs("<>", f); break; case E_LTEQUAL: fputs("<=", f); break; case E_GTEQUAL: fputs(">=", f); break; case E_LT: fputs("<", f); break; case E_GT: fputs(">", f); break; } print_node(f, p->t_args[1], 0); fputs(")", f); break; } } static fix_bin_to_pref() { /* No problems of this kind in Pascal */ }