547 lines
8.2 KiB
C
547 lines
8.2 KiB
C
/* $Header$ */
|
|
|
|
/* Language dependant support; this one is for Modula-2 */
|
|
|
|
#include <stdio.h>
|
|
#include <alloc.h>
|
|
#include <assert.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();
|
|
|
|
static int
|
|
print_string(),
|
|
print_char(),
|
|
get_number(),
|
|
get_name(),
|
|
get_token(),
|
|
get_string(),
|
|
print_op(),
|
|
binop_prio(),
|
|
unop_prio(),
|
|
fix_bin_to_pref();
|
|
|
|
static long
|
|
array_elsize();
|
|
|
|
static struct langdep m2 = {
|
|
1,
|
|
|
|
"%ld",
|
|
"%loB",
|
|
"%lXH",
|
|
"%lu",
|
|
"%lXH",
|
|
"%G",
|
|
|
|
"[",
|
|
"]",
|
|
"(",
|
|
")",
|
|
"{",
|
|
"}",
|
|
|
|
print_string,
|
|
print_char,
|
|
array_elsize,
|
|
binop_prio,
|
|
unop_prio,
|
|
get_string,
|
|
get_name,
|
|
get_number,
|
|
get_token,
|
|
print_op,
|
|
fix_bin_to_pref
|
|
};
|
|
|
|
struct langdep *m2_dep = &m2;
|
|
|
|
static int
|
|
print_char(c)
|
|
int c;
|
|
{
|
|
fprintf(db_out, (c >= 040 && c < 0177) ? "'%c'" : "%oC", c);
|
|
}
|
|
|
|
static int
|
|
print_string(s, len)
|
|
char *s;
|
|
int len;
|
|
{
|
|
register char *str = s;
|
|
int delim = '\'';
|
|
|
|
while (*str) {
|
|
if (*str++ == '\'') delim = '"';
|
|
}
|
|
fprintf(db_out, "%c%.*s%c", delim, len, s, delim);
|
|
}
|
|
|
|
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 5;
|
|
case E_MIN:
|
|
case E_PLUS:
|
|
return 3;
|
|
case E_SELECT:
|
|
return 9;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
static int
|
|
binop_prio(op)
|
|
int op;
|
|
{
|
|
switch(op) {
|
|
case E_AND:
|
|
case E_MUL:
|
|
case E_DIV:
|
|
case E_MOD:
|
|
return 4;
|
|
|
|
case E_PLUS:
|
|
case E_MIN:
|
|
case E_OR:
|
|
return 3;
|
|
|
|
case E_IN:
|
|
case E_EQUAL:
|
|
case E_NOTEQUAL:
|
|
case E_LTEQUAL:
|
|
case E_GTEQUAL:
|
|
case E_LT:
|
|
case E_GT:
|
|
return 2;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
static int
|
|
get_number(ch)
|
|
register int ch;
|
|
{
|
|
/* The problem arising with the "parsing" of a number
|
|
is that we don't know the base in advance so we
|
|
have to read the number with the help of a rather
|
|
complex finite automaton.
|
|
*/
|
|
enum statetp {Oct,Hex,Dec,OctEndOrHex,End,Real};
|
|
register enum statetp state;
|
|
char buf[512+1];
|
|
register int base = 10;
|
|
register char *np = &buf[0];
|
|
|
|
*np++ = ch;
|
|
state = is_oct(ch) ? Oct : Dec;
|
|
ch = getc(db_in);
|
|
for (;;) {
|
|
switch(state) {
|
|
case Oct:
|
|
while (is_oct(ch)) {
|
|
if (np < &buf[512]) *np++ = ch;
|
|
ch = getc(db_in);
|
|
}
|
|
if (ch == 'B' || ch == 'C') {
|
|
state = OctEndOrHex;
|
|
break;
|
|
}
|
|
/* Fall Through */
|
|
case Dec:
|
|
base = 10;
|
|
while (is_dig(ch)) {
|
|
if (np < &buf[512]) {
|
|
*np++ = ch;
|
|
}
|
|
ch = getc(db_in);
|
|
}
|
|
if (is_hex(ch)) state = Hex;
|
|
else if (ch == '.') state = Real;
|
|
else {
|
|
state = End;
|
|
if (ch == 'H') base = 16;
|
|
else ungetc(ch, db_in);
|
|
}
|
|
break;
|
|
|
|
case Hex:
|
|
while (is_hex(ch)) {
|
|
if (np < &buf[512]) *np++ = ch;
|
|
ch = getc(db_in);
|
|
}
|
|
base = 16;
|
|
state = End;
|
|
if (ch != 'H') {
|
|
error("H expected after hex number");
|
|
ungetc(ch, db_in);
|
|
}
|
|
break;
|
|
|
|
case OctEndOrHex:
|
|
if (np < &buf[512]) *np++ = ch;
|
|
ch = getc(db_in);
|
|
if (ch == 'H') {
|
|
base = 16;
|
|
state = End;
|
|
break;
|
|
}
|
|
if (is_hex(ch)) {
|
|
state = Hex;
|
|
break;
|
|
}
|
|
ungetc(ch, db_in);
|
|
ch = *--np;
|
|
*np++ = '\0';
|
|
/* Fall through */
|
|
|
|
case End:
|
|
*np = '\0';
|
|
if (np >= &buf[512]) {
|
|
tok.ival = 1;
|
|
error("constant too long");
|
|
}
|
|
else {
|
|
np = &buf[0];
|
|
while (*np == '0') np++;
|
|
tok.ival = 0;
|
|
while (*np) {
|
|
int c;
|
|
|
|
if (is_dig(*np)) {
|
|
c = *np++ - '0';
|
|
}
|
|
else {
|
|
c = *np++ - 'A' + 10;
|
|
}
|
|
tok.ival *= base;
|
|
tok.ival += c;
|
|
}
|
|
}
|
|
return INTEGER;
|
|
}
|
|
if (state == Real) break;
|
|
}
|
|
|
|
/* a real real constant */
|
|
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') {
|
|
/* Scale factor
|
|
*/
|
|
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]) {
|
|
tok.fval = 0.0;
|
|
error("real constant too long");
|
|
}
|
|
else tok.fval = atof(buf);
|
|
return REAL;
|
|
}
|
|
|
|
static int
|
|
get_name(c)
|
|
register int c;
|
|
{
|
|
char buf[512+1];
|
|
register char *p = &buf[0];
|
|
register struct idf *id;
|
|
|
|
do {
|
|
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 '(':
|
|
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_AND;
|
|
return BIN_OP;
|
|
case '|':
|
|
tok.ival = E_OR;
|
|
return BIN_OP;
|
|
case '=':
|
|
tok.ival = E_EQUAL;
|
|
return BIN_OP;
|
|
case '#':
|
|
tok.ival = E_NOTEQUAL;
|
|
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;
|
|
case '~':
|
|
tok.ival = E_NOT;
|
|
return PREF_OP;
|
|
default:
|
|
error("illegal character 0%o", c);
|
|
return LLlex();
|
|
}
|
|
}
|
|
|
|
static int
|
|
get_string(c)
|
|
int c;
|
|
{
|
|
register int ch;
|
|
char buf[512];
|
|
register int len = 0;
|
|
|
|
while (ch = getc(db_in), ch != c) {
|
|
if (ch == '\n') {
|
|
error("newline in string");
|
|
break;
|
|
}
|
|
buf[len++] = ch;
|
|
}
|
|
buf[len++] = 0;
|
|
tok.str = Salloc(buf, (unsigned) len);
|
|
return STRING;
|
|
}
|
|
|
|
static int
|
|
print_op(p)
|
|
p_tree p;
|
|
{
|
|
switch(p->t_oper) {
|
|
case OP_UNOP:
|
|
switch(p->t_whichoper) {
|
|
case E_MIN:
|
|
fputs("-", db_out);
|
|
print_node(p->t_args[0], 0);
|
|
break;
|
|
case E_PLUS:
|
|
fputs("+", db_out);
|
|
print_node(p->t_args[0], 0);
|
|
break;
|
|
case E_NOT:
|
|
fputs("~", db_out);
|
|
print_node(p->t_args[0], 0);
|
|
break;
|
|
case E_DEREF:
|
|
print_node(p->t_args[0], 0);
|
|
fputs("^", db_out);
|
|
break;
|
|
}
|
|
break;
|
|
case OP_BINOP:
|
|
if (p->t_whichoper == E_ARRAY) {
|
|
print_node(p->t_args[0], 0);
|
|
fputs("[", db_out);
|
|
print_node(p->t_args[1], 0);
|
|
fputs("]", db_out);
|
|
break;
|
|
}
|
|
if (p->t_whichoper == E_SELECT) {
|
|
print_node(p->t_args[0], 0);
|
|
fputs(".", db_out);
|
|
print_node(p->t_args[1], 0);
|
|
break;
|
|
}
|
|
fputs("(", db_out);
|
|
print_node(p->t_args[0], 0);
|
|
switch(p->t_whichoper) {
|
|
case E_AND:
|
|
fputs("&", db_out);
|
|
break;
|
|
case E_OR:
|
|
fputs("|", db_out);
|
|
break;
|
|
case E_DIV:
|
|
fputs("/", db_out);
|
|
break;
|
|
case E_MOD:
|
|
fputs(" MOD ", db_out);
|
|
break;
|
|
case E_IN:
|
|
fputs(" IN ", db_out);
|
|
break;
|
|
case E_PLUS:
|
|
fputs("+", db_out);
|
|
break;
|
|
case E_MIN:
|
|
fputs("-", db_out);
|
|
break;
|
|
case E_MUL:
|
|
fputs("*", db_out);
|
|
break;
|
|
case E_EQUAL:
|
|
fputs("=", db_out);
|
|
break;
|
|
case E_NOTEQUAL:
|
|
fputs("#", db_out);
|
|
break;
|
|
case E_LTEQUAL:
|
|
fputs("<=", db_out);
|
|
break;
|
|
case E_GTEQUAL:
|
|
fputs(">=", db_out);
|
|
break;
|
|
case E_LT:
|
|
fputs("<", db_out);
|
|
break;
|
|
case E_GT:
|
|
fputs(">", db_out);
|
|
break;
|
|
}
|
|
print_node(p->t_args[1], 0);
|
|
fputs(")", db_out);
|
|
break;
|
|
}
|
|
}
|
|
|
|
static int
|
|
fix_bin_to_pref()
|
|
{
|
|
/* No problems of this kind in Modula-2 */
|
|
}
|