123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480 |
- /* $Id$ */
- /* Language dependant support; this one is for Pascal */
- #include <stdio.h>
- #include <alloc.h>
- #include <assert.h>
- #include <ctype.h>
- #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 */
- }
|