479 lines
6.9 KiB
C
479 lines
6.9 KiB
C
/* $Header$ */
|
|
|
|
/* 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"
|
|
|
|
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 */
|
|
}
|