home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Club Amiga de Montreal - CAM
/
CAM_CD_1.iso
/
files
/
379a.lha
/
p2c1_13a
/
src
/
src.zoo
/
expr1.c
< prev
next >
Wrap
C/C++ Source or Header
|
1990-03-11
|
22KB
|
1,003 lines
/* "p2c", a Pascal to C translator.
Copyright (C) 1989 David Gillespie.
Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation (any version).
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
#define PROTO_EXPR1_C
#include "trans.h"
void free_value(val)
Value *val;
{
if (!val || !val->type)
return;
switch (val->type->kind) {
case TK_STRING:
case TK_REAL:
case TK_ARRAY:
case TK_RECORD:
case TK_SET:
if (val->s)
FREE(val->s);
break;
default:
break;
}
}
Value copyvalue(val)
Value val;
{
char *cp;
switch (val.type->kind) {
case TK_STRING:
case TK_SET:
if (val.s) {
cp = ALLOC(val.i+1, char, literals);
memcpy(cp, val.s, val.i);
cp[val.i] = 0;
val.s = cp;
}
break;
case TK_REAL:
case TK_ARRAY:
case TK_RECORD:
if (val.s)
val.s = stralloc(val.s);
break;
default:
break;
}
return val;
}
int valuesame(a, b)
Value a, b;
{
if (a.type != b.type)
return 0;
switch (a.type->kind) {
case TK_INTEGER:
case TK_CHAR:
case TK_BOOLEAN:
case TK_ENUM:
case TK_SMALLSET:
case TK_SMALLARRAY:
return (a.i == b.i);
case TK_STRING:
case TK_SET:
return (a.i == b.i && !memcmp(a.s, b.s, a.i));
case TK_REAL:
case TK_ARRAY:
case TK_RECORD:
return (!strcmp(a.s, b.s));
default:
return 1;
}
}
char *value_name(val, intfmt, islong)
Value val;
char *intfmt;
int islong;
{
Meaning *mp;
Type *type = val.type;
if (type->kind == TK_SUBR)
type = type->basetype;
switch (type->kind) {
case TK_INTEGER:
case TK_SMALLSET:
case TK_SMALLARRAY:
if (!intfmt)
intfmt = "%ld";
if (*intfmt == '\'') {
if (val.i >= -'~' && val.i <= -' ') {
intfmt = format_s("-%s", intfmt);
val.i = -val.i;
}
if (val.i < ' ' || val.i > '~' || islong)
intfmt = "%ld";
}
if (islong)
intfmt = format_s("%sL", intfmt);
return format_d(intfmt, val.i);
case TK_REAL:
return val.s;
case TK_ARRAY: /* obsolete */
case TK_RECORD: /* obsolete */
return val.s;
case TK_STRING:
return makeCstring(val.s, val.i);
case TK_BOOLEAN:
if (!intfmt)
if (val.i == 1 && *name_TRUE &&
strcmp(name_TRUE, "1") && !islong)
intfmt = name_TRUE;
else if (val.i == 0 && *name_FALSE &&
strcmp(name_FALSE, "0") && !islong)
intfmt = name_FALSE;
else
intfmt = "%ld";
if (islong)
intfmt = format_s("%sL", intfmt);
return format_d(intfmt, val.i);
case TK_CHAR:
if (islong)
return format_d("%ldL", val.i);
else if ((val.i < 0 || val.i > 127) && highcharints)
return format_d("%ld", val.i);
else
return makeCchar(val.i);
case TK_POINTER:
return (*name_NULL) ? name_NULL : "NULL";
case TK_ENUM:
mp = val.type->fbase;
while (mp && mp->val.i != val.i)
mp = mp->xnext;
if (!mp) {
intwarning("value_name", "bad enum value [152]");
return format_d("%ld", val.i);
}
return mp->name;
default:
intwarning("value_name", format_s("bad type for constant: %s [153]",
typekindname(type->kind)));
return "<spam>";
}
}
Value value_cast(val, type)
Value val;
Type *type;
{
char buf[20];
if (type->kind == TK_SUBR)
type = type->basetype;
if (val.type == type)
return val;
if (type && val.type) {
switch (type->kind) {
case TK_REAL:
if (ord_type(val.type)->kind == TK_INTEGER) {
sprintf(buf, "%d.0", val.i);
val.s = stralloc(buf);
val.type = tp_real;
return val;
}
break;
case TK_CHAR:
if (val.type->kind == TK_STRING) {
if (val.i != 1)
if (val.i > 0)
warning("Char constant with more than one character [154]");
else
warning("Empty char constant [155]");
val.i = val.s[0] & 0xff;
val.s = NULL;
val.type = tp_char;
return val;
}
case TK_POINTER:
if (val.type == tp_anyptr && castnull != 1) {
val.type = type;
return val;
}
default:
break;
}
}
val.type = NULL;
return val;
}
Type *ord_type(tp)
Type *tp;
{
if (!tp) {
warning("Expected a constant [127]");
return tp_integer;
}
switch (tp->kind) {
case TK_SUBR:
tp = tp->basetype;
break;
case TK_STRING:
if (!CHECKORDEXPR(tp->indextype->smax, 1))
tp = tp_char;
break;
default:
break;
}
return tp;
}
int long_type(tp)
Type *tp;
{
switch (tp->kind) {
case TK_INTEGER:
return (tp != tp_int && tp != tp_uint && tp != tp_sint);
case TK_SUBR:
return (findbasetype(tp, 0) == tp_integer);
default:
return 0;
}
}
Value make_ord(type, i)
Type *type;
long i;
{
Value val;
if (type->kind == TK_ENUM)
type = findbasetype(type, 0);
if (type->kind == TK_SUBR)
type = type->basetype;
val.type = type;
val.i = i;
val.s = NULL;
return val;
}
long ord_value(val)
Value val;
{
switch (val.type->kind) {
case TK_INTEGER:
case TK_ENUM:
case TK_CHAR:
case TK_BOOLEAN:
return val.i;
case TK_STRING:
if (val.i == 1)
return val.s[0] & 0xff;
/* fall through */
default:
warning("Expected an ordinal type [156]");
return 0;
}
}
void ord_range_expr(type, smin, smax)
Type *type;
Expr **smin, **smax;
{
if (!type) {
warning("Expected a constant [127]");
type = tp_integer;
}
if (type->kind == TK_STRING)
type = tp_char;
switch (type->kind) {
case TK_SUBR:
case TK_INTEGER:
case TK_ENUM:
case TK_CHAR:
case TK_BOOLEAN:
if (smin) *smin = type->smin;
if (smax) *smax = type->smax;
break;
default:
warning("Expected an ordinal type [156]");
if (smin) *smin = makeexpr_long(0);
if (smax) *smax = makeexpr_long(1);
break;
}
}
int ord_range(type, smin, smax)
Type *type;
long *smin, *smax;
{
Expr *emin, *emax;
Value vmin, vmax;
ord_range_expr(type, &emin, &emax);
if (smin) {
vmin = eval_expr(emin);
if (!vmin.type)
return 0;
}
if (smax) {
vmax = eval_expr(emax);
if (!vmax.type)
return 0;
}
if (smin) *smin = ord_value(vmin);
if (smax) *smax = ord_value(vmax);
return 1;
}
void freeexpr(ex)
register Expr *ex;
{
register int i;
if (ex) {
for (i = 0; i < ex->nargs; i++)
freeexpr(ex->args[i]);
switch (ex->kind) {
case EK_CONST:
case EK_LONGCONST:
free_value(&ex->val);
break;
case EK_DOT:
case EK_NAME:
case EK_BICALL:
if (ex->val.s)
FREE(ex->val.s);
break;
default:
break;
}
FREE(ex);
}
}
Expr *makeexpr(kind, n)
enum exprkind kind;
int n;
{
Expr *ex;
ex = ALLOCV(sizeof(Expr) + (n-1)*sizeof(Expr *), Expr, exprs);
ex->val.i = 0;
ex->val.s = NULL;
ex->kind = kind;
ex->nargs = n;
return ex;
}
Expr *makeexpr_un(kind, type, arg1)
enum exprkind kind;
Type *type;
Expr *arg1;
{
Expr *ex;
ex = makeexpr(kind, 1);
ex->val.type = type;
ex->args[0] = arg1;
if (debug>2) { fprintf(outf,"makeexpr_un returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_bin(kind, type, arg1, arg2)
enum exprkind kind;
Type *type;
Expr *arg1, *arg2;
{
Expr *ex;
ex = makeexpr(kind, 2);
ex->val.type = type;
ex->args[0] = arg1;
ex->args[1] = arg2;
if (debug>2) { fprintf(outf,"makeexpr_bin returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_val(val)
Value val;
{
Expr *ex;
if (val.type->kind == TK_INTEGER &&
(val.i < -32767 || val.i > 32767) &&
sizeof_int < 32)
ex = makeexpr(EK_LONGCONST, 0);
else
ex = makeexpr(EK_CONST, 0);
ex->val = val;
if (debug>2) { fprintf(outf,"makeexpr_val returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_char(c)
int c;
{
return makeexpr_val(make_ord(tp_char, c));
}
Expr *makeexpr_long(i)
long i;
{
return makeexpr_val(make_ord(tp_integer, i));
}
Expr *makeexpr_real(r)
char *r;
{
Value val;
val.type = tp_real;
val.i = 0;
val.s = stralloc(r);
return makeexpr_val(val);
}
Expr *makeexpr_lstring(msg, len)
char *msg;
int len;
{
Value val;
val.type = tp_str255;
val.i = len;
val.s = ALLOC(len+1, char, literals);
memcpy(val.s, msg, len);
val.s[len] = 0;
return makeexpr_val(val);
}
Expr *makeexpr_string(msg)
char *msg;
{
Value val;
val.type = tp_str255;
val.i = strlen(msg);
val.s = stralloc(msg);
return makeexpr_val(val);
}
int checkstring(ex, msg)
Expr *ex;
char *msg;
{
if (!ex || ex->val.type->kind != TK_STRING || ex->kind != EK_CONST)
return 0;
if (ex->val.i != strlen(msg))
return 0;
return memcmp(ex->val.s, msg, ex->val.i) == 0;
}
Expr *makeexpr_var(mp)
Meaning *mp;
{
Expr *ex;
ex = makeexpr(EK_VAR, 0);
ex->val.i = (long) mp;
ex->val.type = mp->type;
if (debug>2) { fprintf(outf,"makeexpr_var returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_name(name, type)
char *name;
Type *type;
{
Expr *ex;
ex = makeexpr(EK_NAME, 0);
ex->val.s = stralloc(name);
ex->val.type = type;
if (debug>2) { fprintf(outf,"makeexpr_name returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_setbits()
{
if (*name_SETBITS)
return makeexpr_name(name_SETBITS, tp_integer);
else
return makeexpr_long(setbits);
}
/* Note: BICALL's to the following functions should obey the ANSI standard. */
/* Non-ANSI transformations occur while writing the expression. */
/* char *sprintf(buf, fmt, ...) [returns buf] */
/* void *memcpy(dest, src, size) [returns dest] */
Expr *makeexpr_bicall_0(name, type)
char *name;
Type *type;
{
Expr *ex;
if (!name || !*name) {
intwarning("makeexpr_bicall_0", "Required name of built-in procedure is missing [157]");
name = "MissingProc";
}
ex = makeexpr(EK_BICALL, 0);
ex->val.s = stralloc(name);
ex->val.type = type;
if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_bicall_1(name, type, arg1)
char *name;
Type *type;
Expr *arg1;
{
Expr *ex;
if (!name || !*name) {
intwarning("makeexpr_bicall_1", "Required name of built-in procedure is missing [157]");
name = "MissingProc";
}
ex = makeexpr(EK_BICALL, 1);
ex->val.s = stralloc(name);
ex->val.type = type;
ex->args[0] = arg1;
if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_bicall_2(name, type, arg1, arg2)
char *name;
Type *type;
Expr *arg1, *arg2;
{
Expr *ex;
if (!name || !*name) {
intwarning("makeexpr_bicall_2", "Required name of built-in procedure is missing [157]");
name = "MissingProc";
}
ex = makeexpr(EK_BICALL, 2);
if (!strcmp(name, "~SETIO"))
name = (iocheck_flag) ? "~~SETIO" : name_SETIO;
ex->val.s = stralloc(name);
ex->val.type = type;
ex->args[0] = arg1;
ex->args[1] = arg2;
if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_bicall_3(name, type, arg1, arg2, arg3)
char *name;
Type *type;
Expr *arg1, *arg2, *arg3;
{
Expr *ex;
if (!name || !*name) {
intwarning("makeexpr_bicall_3", "Required name of built-in procedure is missing [157]");
name = "MissingProc";
}
ex = makeexpr(EK_BICALL, 3);
ex->val.s = stralloc(name);
ex->val.type = type;
ex->args[0] = arg1;
ex->args[1] = arg2;
ex->args[2] = arg3;
if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_bicall_4(name, type, arg1, arg2, arg3, arg4)
char *name;
Type *type;
Expr *arg1, *arg2, *arg3, *arg4;
{
Expr *ex;
if (!name || !*name) {
intwarning("makeexpr_bicall_4", "Required name of built-in procedure is missing [157]");
name = "MissingProc";
}
ex = makeexpr(EK_BICALL, 4);
if (!strcmp(name, "~CHKIO"))
name = (iocheck_flag) ? "~~CHKIO" : name_CHKIO;
ex->val.s = stralloc(name);
ex->val.type = type;
ex->args[0] = arg1;
ex->args[1] = arg2;
ex->args[2] = arg3;
ex->args[3] = arg4;
if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *makeexpr_bicall_5(name, type, arg1, arg2, arg3, arg4, arg5)
char *name;
Type *type;
Expr *arg1, *arg2, *arg3, *arg4, *arg5;
{
Expr *ex;
if (!name || !*name) {
intwarning("makeexpr_bicall_5", "Required name of built-in procedure is missing [157]");
name = "MissingProc";
}
ex = makeexpr(EK_BICALL, 5);
ex->val.s = stralloc(name);
ex->val.type = type;
ex->args[0] = arg1;
ex->args[1] = arg2;
ex->args[2] = arg3;
ex->args[3] = arg4;
ex->args[4] = arg5;
if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
return ex;
}
Expr *copyexpr(ex)
register Expr *ex;
{
register int i;
register Expr *ex2;
if (ex) {
ex2 = makeexpr(ex->kind, ex->nargs);
for (i = 0; i < ex->nargs; i++)
ex2->args[i] = copyexpr(ex->args[i]);
switch (ex->kind) {
case EK_CONST:
case EK_LONGCONST:
ex2->val = copyvalue(ex->val);
break;
case EK_DOT:
case EK_NAME:
case EK_BICALL:
ex2->val.type = ex->val.type;
ex2->val.i = ex->val.i;
if (ex->val.s)
ex2->val.s = stralloc(ex->val.s);
break;
default:
ex2->val = ex->val;
break;
}
return ex2;
} else
return NULL;
}
int exprsame(a, b, strict)
register Expr *a, *b;
int strict;
{
register int i;
if (!a)
return (!b);
if (!b)
return 0;
if (a->val.type != b->val.type && strict != 2) {
if (strict ||
!((a->val.type->kind == TK_POINTER &&
a->val.type->basetype == b->val.type) ||
(b->val.type->kind == TK_POINTER &&
b->val.type->basetype == a->val.type)))
return 0;
}
if (a->kind != b->kind || a->nargs != b->nargs)
return 0;
switch (a->kind) {
case EK_CONST:
case EK_LONGCONST:
if (!valuesame(a->val, b->val))
return 0;
break;
case EK_BICALL:
case EK_NAME:
if (strcmp(a->val.s, b->val.s))
return 0;
break;
case EK_VAR:
case EK_FUNCTION:
case EK_CTX:
case EK_MACARG:
if (a->val.i != b->val.i)
return 0;
break;
case EK_DOT:
if (a->val.i != b->val.i ||
(!a->val.i && strcmp(a->val.s, b->val.s)))
return 0;
break;
default:
break;
}
i = a->nargs;
while (--i >= 0)
if (!exprsame(a->args[i], b->args[i], (strict == 2) ? 1 : strict))
return 0;
return 1;
}
int exprequiv(a, b)
register Expr *a, *b;
{
register int i, j, k;
enum exprkind kind2;
if (!a)
return (!b);
if (!b)
return 0;
switch (a->kind) {
case EK_PLUS:
case EK_TIMES:
case EK_BAND:
case EK_BOR:
case EK_BXOR:
case EK_EQ:
case EK_NE:
if (b->kind != a->kind || b->nargs != a->nargs ||
b->val.type != a->val.type)
return 0;
if (a->nargs > 3)
break;
for (i = 0; i < b->nargs; i++) {
if (exprequiv(a->args[0], b->args[i])) {
for (j = 0; j < b->nargs; j++) {
if (j != i &&
exprequiv(a->args[1], b->args[i])) {
if (a->nargs == 2)
return 1;
for (k = 0; k < b->nargs; k++) {
if (k != i && k != j &&
exprequiv(a->args[2], b->args[k]))
return 1;
}
}
}
}
}
break;
case EK_LT:
case EK_GT:
case EK_LE:
case EK_GE:
switch (a->kind) {
case EK_LT: kind2 = EK_GT; break;
case EK_GT: kind2 = EK_LT; break;
case EK_LE: kind2 = EK_GE; break;
default: kind2 = EK_LE; break;
}
if (b->kind != kind2 || b->val.type != a->val.type)
break;
if (exprequiv(a->args[0], b->args[1]) &&
exprequiv(a->args[1], b->args[0])) {
return 1;
}
break;
case EK_CONST:
case EK_LONGCONST:
case EK_BICALL:
case EK_NAME:
case EK_VAR:
case EK_FUNCTION:
case EK_CTX:
case EK_DOT:
return exprsame(a, b, 0);
default:
break;
}
if (b->kind != a->kind || b->nargs != a->nargs ||
b->val.type != a->val.type)
return 0;
i = a->nargs;
while (--i >= 0)
if (!exprequiv(a->args[i], b->args[i]))
return 0;
return 1;
}
void deletearg(ex, n)
Expr **ex;
register int n;
{
register Expr *ex1 = *ex, *ex2;
register int i;
if (debug>2) { fprintf(outf,"deletearg("); dumpexpr(*ex); fprintf(outf,", %d)\n", n); }
if (n < 0 || n >= (*ex)->nargs) {
intwarning("deletearg", "argument number out of range [158]");
return;
}
ex2 = makeexpr(ex1->kind, ex1->nargs-1);
ex2->val = ex1->val;
for (i = 0; i < n; i++)
ex2->args[i] = ex1->args[i];
for (; i < ex2->nargs; i++)
ex2->args[i] = ex1->args[i+1];
*ex = ex2;
FREE(ex1);
if (debug>2) { fprintf(outf,"deletearg returns "); dumpexpr(*ex); fprintf(outf,"\n"); }
}
void insertarg(ex, n, arg)
Expr **ex;
Expr *arg;
register int n;
{
register Expr *ex1 = *ex, *ex2;
register int i;
if (debug>2) { fprintf(outf,"insertarg("); dumpexpr(*ex); fprintf(outf,", %d)\n", n); }
if (n < 0 || n > (*ex)->nargs) {
intwarning("insertarg", "argument number out of range [159]");
return;
}
ex2 = makeexpr(ex1->kind, ex1->nargs+1);
ex2->val = ex1->val;
for (i = 0; i < n; i++)
ex2->args[i] = ex1->args[i];
ex2->args[n] = arg;
for (; i < ex1->nargs; i++)
ex2->args[i+1] = ex1->args[i];
*ex = ex2;
FREE(ex1);
if (debug>2) { fprintf(outf,"insertarg returns "); dumpexpr(*ex); fprintf(outf,"\n"); }
}
Expr *grabarg(ex, n)
Expr *ex;
int n;
{
Expr *ex2;
if (n < 0 || n >= ex->nargs) {
intwarning("grabarg", "argument number out of range [160]");
return ex;
}
ex2 = ex->args[n];
ex->args[n] = makeexpr_long(0); /* placeholder */
freeexpr(ex);
return ex2;
}
void delsimparg(ep, n)
Expr **ep;
int n;
{
if (n < 0 || n >= (*ep)->nargs) {
intwarning("delsimparg", "argument number out of range [161]");
return;
}
deletearg(ep, n);
switch ((*ep)->kind) {
case EK_PLUS:
case EK_TIMES:
case EK_COMMA:
if ((*ep)->nargs == 1)
*ep = grabarg(*ep, 0);
break;
default:
break;
}
}