Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/unix/volume21/p2c/part26

Text File | 1990-04-05 | 53KB | 2,163 lines

Subject:  v21i071:  Pascal to C translator, Part26/32
Newsgroups: comp.sources.unix
Approved: [e-mail]
X-Checksum-Snefru: 95f33dbd 13fb533c e65aa499 96605c04

Submitted-by: Dave Gillespie <[e-mail]>
Posting-number: Volume 21, Issue 71
Archive-name: p2c/part26

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 26 (of 32)."
# Contents:  src/expr.c.1
# Wrapped by [e-mail] on Mon Mar 26 14:29:48 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/expr.c.1' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/expr.c.1'\"
else
echo shar: Extracting \"'src/expr.c.1'\" \(48982 characters\)
sed "s/^X//" >'src/expr.c.1' <<'END_OF_FILE'
X/* "p2c", a Pascal to C translator.
X   Copyright (C) 1989 David Gillespie.
X   Author's address: [e-mail]; 256-80 Caltech/Pasadena CA 91125.
X
XThis program is free software; you can redistribute it and/or modify
Xit under the terms of the GNU General Public License as published by
Xthe Free Software Foundation (any version).
X
XThis program is distributed in the hope that it will be useful,
Xbut WITHOUT ANY WARRANTY; without even the implied warranty of
XMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
XGNU General Public License for more details.
X
XYou should have received a copy of the GNU General Public License
Xalong with this program; see the file COPYING.  If not, write to
Xthe Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
X
X
X
X#define PROTO_EXPR_C
X#include "trans.h"
X
X
X
X
X
Xvoid free_value(val)
XValue *val;
X{
X    if (!val || !val->type)
X    return;
X    switch (val->type->kind) {
X
X        case TK_STRING:
X        case TK_REAL:
X        case TK_ARRAY:
X        case TK_RECORD:
X        case TK_SET:
X            if (val->s)
X                FREE(val->s);
X            break;
X
X    default:
X        break;
X    }
X}
X
X
XValue copyvalue(val)
XValue val;
X{
X    char *cp;
X
X    switch (val.type->kind) {
X
X        case TK_STRING:
X        case TK_SET:
X            if (val.s) {
X                cp = ALLOC(val.i+1, char, literals);
X                memcpy(cp, val.s, val.i);
X        cp[val.i] = 0;
X                val.s = cp;
X            }
X            break;
X
X        case TK_REAL:
X        case TK_ARRAY:
X        case TK_RECORD:
X            if (val.s)
X                val.s = stralloc(val.s);
X            break;
X
X    default:
X        break;
X    }
X    return val;
X}
X
X
Xint valuesame(a, b)
XValue a, b;
X{
X    if (a.type != b.type)
X        return 0;
X    switch (a.type->kind) {
X
X        case TK_INTEGER:
X        case TK_CHAR:
X        case TK_BOOLEAN:
X        case TK_ENUM:
X        case TK_SMALLSET:
X        case TK_SMALLARRAY:
X            return (a.i == b.i);
X
X        case TK_STRING:
X        case TK_SET:
X            return (a.i == b.i && !memcmp(a.s, b.s, a.i));
X
X        case TK_REAL:
X        case TK_ARRAY:
X        case TK_RECORD:
X            return (!strcmp(a.s, b.s));
X
X        default:
X            return 1;
X    }
X}
X
X
X
Xchar *value_name(val, intfmt, islong)
XValue val;
Xchar *intfmt;
Xint islong;
X{
X    Meaning *mp;
X    Type *type = val.type;
X
X    if (type->kind == TK_SUBR)
X    type = type->basetype;
X    switch (type->kind) {
X
X        case TK_INTEGER:
X        case TK_SMALLSET:
X        case TK_SMALLARRAY:
X            if (!intfmt)
X        intfmt = "%ld";
X        if (*intfmt == '\'') {
X        if (val.i >= -'~' && val.i <= -' ') {
X            intfmt = format_s("-%s", intfmt);
X            val.i = -val.i;
X        }
X        if (val.i < ' ' || val.i > '~' || islong)
X            intfmt = "%ld";
X        }
X            if (islong)
X                intfmt = format_s("%sL", intfmt);
X            return format_d(intfmt, val.i);
X
X        case TK_REAL:
X            return val.s;
X
X        case TK_ARRAY:    /* obsolete */
X        case TK_RECORD:   /* obsolete */
X            return val.s;
X
X        case TK_STRING:
X            return makeCstring(val.s, val.i);
X
X        case TK_BOOLEAN:
X            if (!intfmt)
X                if (val.i == 1 && *name_TRUE &&
X            strcmp(name_TRUE, "1") && !islong)
X                    intfmt = name_TRUE;
X                else if (val.i == 0 && *name_FALSE &&
X             strcmp(name_FALSE, "0") && !islong)
X                    intfmt = name_FALSE;
X                else
X                    intfmt = "%ld";
X            if (islong)
X                intfmt = format_s("%sL", intfmt);
X            return format_d(intfmt, val.i);
X
X        case TK_CHAR:
X            if (islong)
X                return format_d("%ldL", val.i);
X        else if ((val.i < 0 || val.i > 127) && highcharints)
X        return format_d("%ld", val.i);
X            else
X                return makeCchar(val.i);
X
X        case TK_POINTER:
X            return (*name_NULL) ? name_NULL : "NULL";
X
X        case TK_ENUM:
X            mp = val.type->fbase;
X            while (mp && mp->val.i != val.i)
X                mp = mp->xnext;
X            if (!mp) {
X                intwarning("value_name", "bad enum value [152]");
X                return format_d("%ld", val.i);
X            }
X            return mp->name;
X
X        default:
X            intwarning("value_name", format_s("bad type for constant: %s [153]",
X                                              typekindname(type->kind)));
X            return "<spam>";
X    }
X}
X
X
X
X
XValue value_cast(val, type)
XValue val;
XType *type;
X{
X    char buf[20];
X
X    if (type->kind == TK_SUBR)
X        type = type->basetype;
X    if (val.type == type)
X        return val;
X    if (type && val.type) {
X        switch (type->kind) {
X
X            case TK_REAL:
X                if (ord_type(val.type)->kind == TK_INTEGER) {
X                    sprintf(buf, "%d.0", val.i);
X                    val.s = stralloc(buf);
X                    val.type = tp_real;
X                    return val;
X                }
X                break;
X
X            case TK_CHAR:
X                if (val.type->kind == TK_STRING) {
X                    if (val.i != 1)
X                        if (val.i > 0)
X                            warning("Char constant with more than one character [154]");
X                        else
X                            warning("Empty char constant [155]");
X                    val.i = val.s[0] & 0xff;
X                    val.s = NULL;
X                    val.type = tp_char;
X                    return val;
X                }
X
X            case TK_POINTER:
X                if (val.type == tp_anyptr && castnull != 1) {
X                    val.type = type;
X                    return val;
X                }
X
X        default:
X        break;
X        }
X    }
X    val.type = NULL;
X    return val;
X}
X
X
X
XType *ord_type(tp)
XType *tp;
X{
X    if (!tp) {
X        warning("Expected a constant [127]");
X        return tp_integer;
X    }
X    switch (tp->kind) {
X
X        case TK_SUBR:
X            tp = tp->basetype;
X            break;
X
X        case TK_STRING:
X            if (!CHECKORDEXPR(tp->indextype->smax, 1))
X                tp = tp_char;
X            break;
X
X    default:
X        break;
X
X    }
X    return tp;
X}
X
X
X
Xint long_type(tp)
XType *tp;
X{
X    switch (tp->kind) {
X
X        case TK_INTEGER:
X            return (tp != tp_int && tp != tp_uint && tp != tp_sint);
X
X        case TK_SUBR:
X            return (findbasetype(tp, 0) == tp_integer);
X
X        default:
X            return 0;
X    }
X}
X
X
X
XValue make_ord(type, i)
XType *type;
Xlong i;
X{
X    Value val;
X
X    if (type->kind == TK_ENUM)
X        type = findbasetype(type, 0);
X    if (type->kind == TK_SUBR)
X        type = type->basetype;
X    val.type = type;
X    val.i = i;
X    val.s = NULL;
X    return val;
X}
X
X
X
Xlong ord_value(val)
XValue val;
X{
X    switch (val.type->kind) {
X
X        case TK_INTEGER:
X        case TK_ENUM:
X        case TK_CHAR:
X        case TK_BOOLEAN:
X            return val.i;
X
X        case TK_STRING:
X            if (val.i == 1)
X                return val.s[0] & 0xff;
X
X        /* fall through */
X        default:
X            warning("Expected an ordinal type [156]");
X            return 0;
X    }
X}
X
X
X
Xvoid ord_range_expr(type, smin, smax)
XType *type;
XExpr **smin, **smax;
X{
X    if (!type) {
X        warning("Expected a constant [127]");
X        type = tp_integer;
X    }
X    if (type->kind == TK_STRING)
X        type = tp_char;
X    switch (type->kind) {
X
X        case TK_SUBR:
X        case TK_INTEGER:
X        case TK_ENUM:
X        case TK_CHAR:
X        case TK_BOOLEAN:
X            if (smin) *smin = type->smin;
X            if (smax) *smax = type->smax;
X            break;
X
X        default:
X            warning("Expected an ordinal type [156]");
X            if (smin) *smin = makeexpr_long(0);
X            if (smax) *smax = makeexpr_long(1);
X            break;
X    }
X}
X
X
Xint ord_range(type, smin, smax)
XType *type;
Xlong *smin, *smax;
X{
X    Expr *emin, *emax;
X    Value vmin, vmax;
X
X    ord_range_expr(type, &emin, &emax);
X    if (smin) {
X        vmin = eval_expr(emin);
X        if (!vmin.type)
X            return 0;
X    }
X    if (smax) {
X        vmax = eval_expr(emax);
X        if (!vmax.type)
X            return 0;
X    }
X    if (smin) *smin = ord_value(vmin);
X    if (smax) *smax = ord_value(vmax);
X    return 1;
X}
X
X
X
X
X
X
X
Xvoid freeexpr(ex)
Xregister Expr *ex;
X{
X    register int i;
X
X    if (ex) {
X        for (i = 0; i < ex->nargs; i++)
X            freeexpr(ex->args[i]);
X        switch (ex->kind) {
X
X            case EK_CONST:
X            case EK_LONGCONST:
X                free_value(&ex->val);
X                break;
X
X            case EK_DOT:
X            case EK_NAME:
X            case EK_BICALL:
X                if (ex->val.s)
X                    FREE(ex->val.s);
X                break;
X
X        default:
X        break;
X        }
X        FREE(ex);
X    }
X}
X
X
X
X
XExpr *makeexpr(kind, n)
Xenum exprkind kind;
Xint n;
X{
X    Expr *ex;
X
X    ex = ALLOCV(sizeof(Expr) + (n-1)*sizeof(Expr *), Expr, exprs);
X    ex->val.i = 0;
X    ex->val.s = NULL;
X    ex->kind = kind;
X    ex->nargs = n;
X    return ex;
X}
X
X
XExpr *makeexpr_un(kind, type, arg1)
Xenum exprkind kind;
XType *type;
XExpr *arg1;
X{
X    Expr *ex;
X
X    ex = makeexpr(kind, 1);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    if (debug>2) { fprintf(outf,"makeexpr_un returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
XExpr *makeexpr_bin(kind, type, arg1, arg2)
Xenum exprkind kind;
XType *type;
XExpr *arg1, *arg2;
X{
X    Expr *ex;
X
X    ex = makeexpr(kind, 2);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    ex->args[1] = arg2;
X    if (debug>2) { fprintf(outf,"makeexpr_bin returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
X
XExpr *makeexpr_val(val)
XValue val;
X{
X    Expr *ex;
X
X    if (val.type->kind == TK_INTEGER &&
X        (val.i < -32767 || val.i > 32767) &&
X        sizeof_int < 32)
X        ex = makeexpr(EK_LONGCONST, 0);
X    else
X        ex = makeexpr(EK_CONST, 0);
X    ex->val = val;
X    if (debug>2) { fprintf(outf,"makeexpr_val returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
X
XExpr *makeexpr_char(c)
Xint c;
X{
X    return makeexpr_val(make_ord(tp_char, c));
X}
X
X
XExpr *makeexpr_long(i)
Xlong i;
X{
X    return makeexpr_val(make_ord(tp_integer, i));
X}
X
X
XExpr *makeexpr_real(r)
Xchar *r;
X{
X    Value val;
X
X    val.type = tp_real;
X    val.i = 0;
X    val.s = stralloc(r);
X    return makeexpr_val(val);
X}
X
X
XExpr *makeexpr_lstring(msg, len)
Xchar *msg;
Xint len;
X{
X    Value val;
X
X    val.type = tp_str255;
X    val.i = len;
X    val.s = ALLOC(len+1, char, literals);
X    memcpy(val.s, msg, len);
X    val.s[len] = 0;
X    return makeexpr_val(val);
X}
X
X
XExpr *makeexpr_string(msg)
Xchar *msg;
X{
X    Value val;
X
X    val.type = tp_str255;
X    val.i = strlen(msg);
X    val.s = stralloc(msg);
X    return makeexpr_val(val);
X}
X
X
Xint checkstring(ex, msg)
XExpr *ex;
Xchar *msg;
X{
X    if (!ex || ex->val.type->kind != TK_STRING || ex->kind != EK_CONST)
X        return 0;
X    if (ex->val.i != strlen(msg))
X        return 0;
X    return memcmp(ex->val.s, msg, ex->val.i) == 0;
X}
X
X
X
XExpr *makeexpr_var(mp)
XMeaning *mp;
X{
X    Expr *ex;
X
X    ex = makeexpr(EK_VAR, 0);
X    ex->val.i = (long) mp;
X    ex->val.type = mp->type;
X    if (debug>2) { fprintf(outf,"makeexpr_var returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
X
XExpr *makeexpr_name(name, type)
Xchar *name;
XType *type;
X{
X    Expr *ex;
X
X    ex = makeexpr(EK_NAME, 0);
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    if (debug>2) { fprintf(outf,"makeexpr_name returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
X
XExpr *makeexpr_setbits()
X{
X    if (*name_SETBITS)
X        return makeexpr_name(name_SETBITS, tp_integer);
X    else
X        return makeexpr_long(setbits);
X}
X
X
X
X/* Note: BICALL's to the following functions should obey the ANSI standard. */
X/*       Non-ANSI transformations occur while writing the expression. */
X/*              char *sprintf(buf, fmt, ...)   [returns buf]  */
X/*              void *memcpy(dest, src, size)  [returns dest] */
X
XExpr *makeexpr_bicall_0(name, type)
Xchar *name;
XType *type;
X{
X    Expr *ex;
X
X    if (!name || !*name) {
X        intwarning("makeexpr_bicall_0", "Required name of built-in procedure is missing [157]");
X        name = "MissingProc";
X    }
X    ex = makeexpr(EK_BICALL, 0);
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
XExpr *makeexpr_bicall_1(name, type, arg1)
Xchar *name;
XType *type;
XExpr *arg1;
X{
X    Expr *ex;
X
X    if (!name || !*name) {
X        intwarning("makeexpr_bicall_1", "Required name of built-in procedure is missing [157]");
X        name = "MissingProc";
X    }
X    ex = makeexpr(EK_BICALL, 1);
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
XExpr *makeexpr_bicall_2(name, type, arg1, arg2)
Xchar *name;
XType *type;
XExpr *arg1, *arg2;
X{
X    Expr *ex;
X
X    if (!name || !*name) {
X        intwarning("makeexpr_bicall_2", "Required name of built-in procedure is missing [157]");
X        name = "MissingProc";
X    }
X    ex = makeexpr(EK_BICALL, 2);
X    if (!strcmp(name, "~SETIO"))
X        name = (iocheck_flag) ? "~~SETIO" : name_SETIO;
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    ex->args[1] = arg2;
X    if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
XExpr *makeexpr_bicall_3(name, type, arg1, arg2, arg3)
Xchar *name;
XType *type;
XExpr *arg1, *arg2, *arg3;
X{
X    Expr *ex;
X
X    if (!name || !*name) {
X        intwarning("makeexpr_bicall_3", "Required name of built-in procedure is missing [157]");
X        name = "MissingProc";
X    }
X    ex = makeexpr(EK_BICALL, 3);
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    ex->args[1] = arg2;
X    ex->args[2] = arg3;
X    if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
XExpr *makeexpr_bicall_4(name, type, arg1, arg2, arg3, arg4)
Xchar *name;
XType *type;
XExpr *arg1, *arg2, *arg3, *arg4;
X{
X    Expr *ex;
X
X    if (!name || !*name) {
X        intwarning("makeexpr_bicall_4", "Required name of built-in procedure is missing [157]");
X        name = "MissingProc";
X    }
X    ex = makeexpr(EK_BICALL, 4);
X    if (!strcmp(name, "~CHKIO"))
X        name = (iocheck_flag) ? "~~CHKIO" : name_CHKIO;
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    ex->args[1] = arg2;
X    ex->args[2] = arg3;
X    ex->args[3] = arg4;
X    if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
XExpr *makeexpr_bicall_5(name, type, arg1, arg2, arg3, arg4, arg5)
Xchar *name;
XType *type;
XExpr *arg1, *arg2, *arg3, *arg4, *arg5;
X{
X    Expr *ex;
X
X    if (!name || !*name) {
X        intwarning("makeexpr_bicall_5", "Required name of built-in procedure is missing [157]");
X        name = "MissingProc";
X    }
X    ex = makeexpr(EK_BICALL, 5);
X    ex->val.s = stralloc(name);
X    ex->val.type = type;
X    ex->args[0] = arg1;
X    ex->args[1] = arg2;
X    ex->args[2] = arg3;
X    ex->args[3] = arg4;
X    ex->args[4] = arg5;
X    if (debug>2) { fprintf(outf,"makeexpr_bicall returns "); dumpexpr(ex); fprintf(outf,"\n"); }
X    return ex;
X}
X
X
X
X
XExpr *copyexpr(ex)
Xregister Expr *ex;
X{
X    register int i;
X    register Expr *ex2;
X
X    if (ex) {
X        ex2 = makeexpr(ex->kind, ex->nargs);
X        for (i = 0; i < ex->nargs; i++)
X            ex2->args[i] = copyexpr(ex->args[i]);
X        switch (ex->kind) {
X
X            case EK_CONST:
X            case EK_LONGCONST:
X                ex2->val = copyvalue(ex->val);
X                break;
X
X            case EK_DOT:
X            case EK_NAME:
X            case EK_BICALL:
X                ex2->val.type = ex->val.type;
X                ex2->val.i = ex->val.i;
X                if (ex->val.s)
X                    ex2->val.s = stralloc(ex->val.s);
X                break;
X
X            default:
X                ex2->val = ex->val;
X                break;
X        }
X        return ex2;
X    } else
X        return NULL;
X}
X
X
X
Xint exprsame(a, b, strict)
Xregister Expr *a, *b;
Xint strict;
X{
X    register int i;
X
X    if (!a)
X        return (!b);
X    if (!b)
X        return 0;
X    if (a->val.type != b->val.type && strict != 2) {
X        if (strict ||
X        !((a->val.type->kind == TK_POINTER &&
X           a->val.type->basetype == b->val.type) ||
X          (b->val.type->kind == TK_POINTER &&
X           b->val.type->basetype == a->val.type)))
X        return 0;
X    }
X    if (a->kind != b->kind || a->nargs != b->nargs)
X        return 0;
X    switch (a->kind) {
X
X        case EK_CONST:
X        case EK_LONGCONST:
X            if (!valuesame(a->val, b->val))
X                return 0;
X            break;
X
X        case EK_BICALL:
X        case EK_NAME:
X            if (strcmp(a->val.s, b->val.s))
X                return 0;
X            break;
X
X        case EK_VAR:
X        case EK_FUNCTION:
X        case EK_CTX:
X        case EK_MACARG:
X            if (a->val.i != b->val.i)
X                return 0;
X            break;
X
X        case EK_DOT:
X            if (a->val.i != b->val.i ||
X                (!a->val.i && strcmp(a->val.s, b->val.s)))
X                return 0;
X            break;
X
X    default:
X        break;
X    }
X    i = a->nargs;
X    while (--i >= 0)
X        if (!exprsame(a->args[i], b->args[i], (strict == 2) ? 1 : strict))
X            return 0;
X    return 1;
X}
X
X
X
Xint exprequiv(a, b)
Xregister Expr *a, *b;
X{
X    register int i, j, k;
X    enum exprkind kind2;
X
X    if (!a)
X        return (!b);
X    if (!b)
X        return 0;
X    switch (a->kind) {
X
X        case EK_PLUS:
X        case EK_TIMES:
X        case EK_BAND:
X        case EK_BOR:
X        case EK_BXOR:
X        case EK_EQ:
X        case EK_NE:
X            if (b->kind != a->kind || b->nargs != a->nargs ||
X                b->val.type != a->val.type)
X                return 0;
X            if (a->nargs > 3)
X                break;
X            for (i = 0; i < b->nargs; i++) {
X                if (exprequiv(a->args[0], b->args[i])) {
X                    for (j = 0; j < b->nargs; j++) {
X                        if (j != i &&
X                            exprequiv(a->args[1], b->args[i])) {
X                            if (a->nargs == 2)
X                                return 1;
X                            for (k = 0; k < b->nargs; k++) {
X                                if (k != i && k != j &&
X                                    exprequiv(a->args[2], b->args[k]))
X                                    return 1;
X                            }
X                        }
X                    }
X                }
X            }
X            break;
X
X        case EK_LT:
X        case EK_GT:
X        case EK_LE:
X        case EK_GE:
X            switch (a->kind) {
X                case EK_LT:  kind2 = EK_GT; break;
X                case EK_GT:  kind2 = EK_LT; break;
X                case EK_LE:  kind2 = EK_GE; break;
X                default:     kind2 = EK_LE; break;
X            }
X            if (b->kind != kind2 || b->val.type != a->val.type)
X                break;
X            if (exprequiv(a->args[0], b->args[1]) &&
X                exprequiv(a->args[1], b->args[0])) {
X                return 1;
X            }
X            break;
X
X        case EK_CONST:
X        case EK_LONGCONST:
X        case EK_BICALL:
X        case EK_NAME:
X        case EK_VAR:
X        case EK_FUNCTION:
X        case EK_CTX:
X        case EK_DOT:
X            return exprsame(a, b, 0);
X
X    default:
X        break;
X    }
X    if (b->kind != a->kind || b->nargs != a->nargs ||
X        b->val.type != a->val.type)
X        return 0;
X    i = a->nargs;
X    while (--i >= 0)
X        if (!exprequiv(a->args[i], b->args[i]))
X            return 0;
X    return 1;
X}
X
X
X
Xvoid deletearg(ex, n)
XExpr **ex;
Xregister int n;
X{
X    register Expr *ex1 = *ex, *ex2;
X    register int i;
X
X    if (debug>2) { fprintf(outf,"deletearg("); dumpexpr(*ex); fprintf(outf,", %d)\n", n); }
X    if (n < 0 || n >= (*ex)->nargs) {
X        intwarning("deletearg", "argument number out of range [158]");
X        return;
X    }
X    ex2 = makeexpr(ex1->kind, ex1->nargs-1);
X    ex2->val = ex1->val;
X    for (i = 0; i < n; i++)
X        ex2->args[i] = ex1->args[i];
X    for (; i < ex2->nargs; i++)
X        ex2->args[i] = ex1->args[i+1];
X    *ex = ex2;
X    FREE(ex1);
X    if (debug>2) { fprintf(outf,"deletearg returns "); dumpexpr(*ex); fprintf(outf,"\n"); }
X}
X
X
X
Xvoid insertarg(ex, n, arg)
XExpr **ex;
XExpr *arg;
Xregister int n;
X{
X    register Expr *ex1 = *ex, *ex2;
X    register int i;
X
X    if (debug>2) { fprintf(outf,"insertarg("); dumpexpr(*ex); fprintf(outf,", %d)\n", n); }
X    if (n < 0 || n > (*ex)->nargs) {
X        intwarning("insertarg", "argument number out of range [159]");
X        return;
X    }
X    ex2 = makeexpr(ex1->kind, ex1->nargs+1);
X    ex2->val = ex1->val;
X    for (i = 0; i < n; i++)
X        ex2->args[i] = ex1->args[i];
X    ex2->args[n] = arg;
X    for (; i < ex1->nargs; i++)
X        ex2->args[i+1] = ex1->args[i];
X    *ex = ex2;
X    FREE(ex1);
X    if (debug>2) { fprintf(outf,"insertarg returns "); dumpexpr(*ex); fprintf(outf,"\n"); }
X}
X
X
X
XExpr *grabarg(ex, n)
XExpr *ex;
Xint n;
X{
X    Expr *ex2;
X
X    if (n < 0 || n >= ex->nargs) {
X        intwarning("grabarg", "argument number out of range [160]");
X        return ex;
X    }
X    ex2 = ex->args[n];
X    ex->args[n] = makeexpr_long(0);   /* placeholder */
X    freeexpr(ex);
X    return ex2;
X}
X
X
X
Xvoid delsimparg(ep, n)
XExpr **ep;
Xint n;
X{
X    if (n < 0 || n >= (*ep)->nargs) {
X        intwarning("delsimparg", "argument number out of range [161]");
X        return;
X    }
X    deletearg(ep, n);
X    switch ((*ep)->kind) {
X
X        case EK_PLUS:
X        case EK_TIMES:
X        case EK_COMMA:
X            if ((*ep)->nargs == 1)
X                *ep = grabarg(*ep, 0);
X            break;
X
X    default:
X        break;
X
X    }
X}
X
X
X
X
XExpr *resimplify(ex)
XExpr *ex;
X{
X    Expr *ex2;
X    Type *type;
X    int i;
X
X    if (debug>2) { fprintf(outf,"resimplify("); dumpexpr(ex); fprintf(outf,")\n"); }
X    if (!ex)
X        return NULL;
X    type = ex->val.type;
X    switch (ex->kind) {
X
X        case EK_PLUS:
X            ex2 = ex->args[0];
X            for (i = 1; i < ex->nargs; i++)
X                ex2 = makeexpr_plus(ex2, ex->args[i]);
X            FREE(ex);
X            return ex2;
X
X        case EK_TIMES:
X            ex2 = ex->args[0];
X            for (i = 1; i < ex->nargs; i++)
X                ex2 = makeexpr_times(ex2, ex->args[i]);
X            FREE(ex);
X            return ex2;
X
X        case EK_NEG:
X            ex = makeexpr_neg(grabarg(ex, 0));
X            ex->val.type = type;
X            return ex;
X
X        case EK_NOT:
X            ex = makeexpr_not(grabarg(ex, 0));
X            ex->val.type = type;
X            return ex;
X
X        case EK_HAT:
X            ex = makeexpr_hat(grabarg(ex, 0), 0);
X        if (ex->kind == EK_HAT)
X        ex->val.type = type;
X            return ex;
X
X        case EK_ADDR:
X            ex = makeexpr_addr(grabarg(ex, 0));
X            ex->val.type = type;
X            return ex;
X
X    case EK_ASSIGN:
X        ex2 = makeexpr_assign(ex->args[0], ex->args[1]);
X        FREE(ex);
X        return ex2;
X
X    default:
X        break;
X    }
X    return ex;
X}
X
X
X
X
X
X
Xint realzero(s)
Xregister char *s;
X{
X    if (*s == '-') s++;
X    while (*s == '0' || *s == '.') s++;
X    return (!isdigit(*s));
X}
X
X
Xint checkconst(ex, val)
XExpr *ex;
Xlong val;
X{
X    Meaning *mp;
X    Value exval;
X
X    if (!ex)
X        return 0;
X    if (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
X        ex = ex->args[0];
X    if (ex->kind == EK_CONST || ex->kind == EK_LONGCONST)
X        exval = ex->val;
X    else if (ex->kind == EK_VAR &&
X             (mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
X             foldconsts != 0)
X        exval = mp->val;
X    else
X        return 0;
X    switch (exval.type->kind) {
X
X        case TK_BOOLEAN:
X        case TK_INTEGER:
X        case TK_CHAR:
X        case TK_ENUM:
X        case TK_SUBR:
X        case TK_SMALLSET:
X        case TK_SMALLARRAY:
X            return exval.i == val;
X
X        case TK_POINTER:
X        case TK_STRING:
X            return (val == 0 && exval.i == 0);
X
X        case TK_REAL:
X            return (val == 0 && realzero(exval.s));
X
X    default:
X        return 0;
X    }
X}
X
X
X
Xint isliteralconst(ex, valp)
XExpr *ex;
XValue *valp;
X{
X    Meaning *mp;
X
X    if (ex) {
X        switch (ex->kind) {
X
X            case EK_CONST:
X            case EK_LONGCONST:
X                if (valp)
X                    *valp = ex->val;
X                return 2;
X
X            case EK_VAR:
X                mp = (Meaning *)ex->val.i;
X                if (mp->kind == MK_CONST) {
X                    if (valp) {
X                        if (foldconsts == 0)
X                            valp->type = NULL;
X                        else
X                            *valp = mp->val;
X                    }
X                    return 1;
X                }
X                break;
X
X        default:
X        break;
X        }
X    }
X    if (valp)
X        valp->type = NULL;
X    return 0;
X}
X
X
X
Xint isconstexpr(ex, valp)
XExpr *ex;
Xlong *valp;
X{
X    Value exval;
X
X    if (debug>2) { fprintf(outf,"isconstexpr("); dumpexpr(ex); fprintf(outf,")\n"); }
X    exval = eval_expr(ex);
X    if (exval.type) {
X        if (valp)
X            *valp = exval.i;
X        return 1;
X    } else
X        return 0;
X}
X
X
X
Xint isconstantexpr(ex)
XExpr *ex;
X{
X    Meaning *mp;
X    int i;
X
X    switch (ex->kind) {
X
X        case EK_CONST:
X        case EK_LONGCONST:
X        case EK_SIZEOF:
X            return 1;
X
X        case EK_ADDR:
X            if (ex->args[0]->kind == EK_VAR) {
X                mp = (Meaning *)ex->val.i;
X                return (!mp->ctx || mp->ctx->kind == MK_MODULE);
X            }
X            return 0;
X
X        case EK_VAR:
X            mp = (Meaning *)ex->val.i;
X            return (mp->kind == MK_CONST);
X
X        case EK_BICALL:
X        case EK_FUNCTION:
X            if (!deterministic_func(ex))
X                return 0;
X
X        /* fall through */
X        case EK_EQ:
X        case EK_NE:
X        case EK_LT:
X        case EK_GT:
X        case EK_LE:
X        case EK_GE:
X        case EK_PLUS:
X        case EK_NEG:
X        case EK_TIMES:
X        case EK_DIVIDE:
X        case EK_DIV:
X        case EK_MOD:
X        case EK_AND:
X        case EK_OR:
X        case EK_NOT:
X        case EK_BAND:
X        case EK_BOR:
X        case EK_BXOR:
X        case EK_BNOT:
X        case EK_LSH:
X        case EK_RSH:
X        case EK_CAST:
X        case EK_ACTCAST:
X        case EK_COND:
X            for (i = 0; i < ex->nargs; i++) {
X                if (!isconstantexpr(ex->args[i]))
X                    return 0;
X            }
X            return 1;
X
X        case EK_COMMA:
X            return isconstantexpr(ex->args[ex->nargs-1]);
X
X    default:
X        return 0;
X    }
X}
X
X
X
X
X
XStatic Expr *docast(a, type)
XExpr *a;
XType *type;
X{
X    Value val;
X    Meaning *mp;
X    int i;
X    Expr *ex;
X
X    if (a->val.type->kind == TK_SMALLSET && type->kind == TK_SET) {
X        mp = makestmttempvar(type, name_SET);
X        return makeexpr_bicall_2(setexpandname, type,
X                                 makeexpr_var(mp),
X                                 makeexpr_arglong(a, 1));
X    } else if (a->val.type->kind == TK_SET && type->kind == TK_SMALLSET) {
X        return packset(a, type);
X    }
X    switch (a->kind) {
X
X        case EK_VAR:
X            mp = (Meaning *) a->val.i;
X            if (mp->kind == MK_CONST) {
X                if (mp->val.type->kind == TK_STRING && type->kind == TK_CHAR) {
X                    val = value_cast(mp->val, type);
X                    a->kind = EK_CONST;
X                    a->val = val;
X                    return a;
X                }
X            }
X            break;
X
X        case EK_CONST:
X        case EK_LONGCONST:
X            val = value_cast(a->val, type);
X            if (val.type) {
X                a->val = val;
X                return a;
X            }
X            break;
X
X        case EK_PLUS:
X        case EK_NEG:
X        case EK_TIMES:
X            if (type->kind == TK_REAL) {
X                for (i = 0; i < a->nargs; i++) {
X                    ex = docast(a->args[i], type);
X                    if (ex) {
X                        a->args[i] = ex;
X                        a->val.type = type;
X                        return a;
X                    }
X                }
X            }
X            break;
X
X    default:
X        break;
X    }
X    return NULL;
X}
X
X
X
X/* Make an "active" cast, i.e., one that performs an explicit operation */
XExpr *makeexpr_actcast(a, type)
XExpr *a;
XType *type;
X{
X    if (debug>2) { fprintf(outf,"makeexpr_actcast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
X
X    if (similartypes(a->val.type, type)) {
X        a->val.type = type;
X        return a;
X    }
X    return makeexpr_un(EK_ACTCAST, type, a);
X}
X
X
X
XExpr *makeexpr_cast(a, type)
XExpr *a;
XType *type;
X{
X    Expr *ex;
X
X    if (debug>2) { fprintf(outf,"makeexpr_cast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
X    if (a->val.type == type)
X        return a;
X    ex = docast(a, type);
X    if (ex)
X        return ex;
X    if (a->kind == EK_CAST &&
X        a->args[0]->val.type->kind == TK_POINTER &&
X        similartypes(type, a->args[0]->val.type)) {
X        a = grabarg(a, 0);
X        a->val.type = type;
X        return a;
X    }
X    if ((a->kind == EK_CAST &&
X         ((a->val.type->kind == TK_POINTER && type->kind == TK_POINTER) ||
X          (ord_type(a->val.type)->kind == TK_INTEGER && ord_type(type)->kind == TK_INTEGER))) ||
X        similartypes(type, a->val.type)) {
X        a->val.type = type;
X        return a;
X    }
X    return makeexpr_un(EK_CAST, type, a);
X}
X
X
X
XExpr *gentle_cast(a, type)
XExpr *a;
XType *type;
X{
X    Expr *ex;
X    Type *btype;
X    long smin, smax;
X
X    if (debug>2) { fprintf(outf,"gentle_cast("); dumpexpr(a); fprintf(outf,", "); dumptypename(type, 1); fprintf(outf,")\n"); }
X    if (!type) {
X    intwarning("gentle_cast", "type == NULL");
X    return a;
X    }
X    if (a->val.type->kind == TK_POINTER && type->kind == TK_POINTER) {
X        if (voidstar && (type == tp_anyptr || a->val.type == tp_anyptr)) {
X            if (type == tp_anyptr && a->kind == EK_CAST &&
X                a->args[0]->val.type->kind == TK_POINTER)
X                return a->args[0];    /* remove explicit cast since casting implicitly */
X            return a;                 /* casting to/from "void *" */
X        }
X        return makeexpr_cast(a, type);
X    }
X    if (type->kind == TK_STRING)
X        return makeexpr_stringify(a);
X    if (type->kind == TK_ARRAY && a->val.type->kind == TK_STRING &&
X        a->kind == EK_CONST && ord_range(type->indextype, &smin, &smax)) {
X        smax = smax - smin + 1;
X        if (a->val.i > smax) {
X            warning("Too many characters for packed array of char [162]");
X        } else if (a->val.i < smax) {
X            ex = makeexpr_lstring(a->val.s, smax);
X            while (smax > a->val.i)
X                ex->val.s[--smax] = ' ';
X            freeexpr(a);
X            return ex;
X        }
X    }
X    btype = (type->kind == TK_SUBR) ? type->basetype : type;
X    if ((a->kind == EK_CAST || a->kind == EK_ACTCAST) &&
X        btype->kind == TK_INTEGER &&
X        ord_type(a->val.type)->kind == TK_INTEGER)
X        return makeexpr_longcast(a, long_type(type));
X    if (a->val.type == btype)
X        return a;
X    ex = docast(a, btype);
X    if (ex)
X        return ex;
X    if (btype->kind == TK_CHAR && a->val.type->kind == TK_STRING)
X        return makeexpr_hat(a, 0);
X    return a;
X}
X
X
X
XExpr *makeexpr_charcast(ex)
XExpr *ex;
X{
X    Meaning *mp;
X
X    if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING &&
X        ex->val.i == 1) {
X        ex->val.type = tp_char;
X        ex->val.i = ex->val.s[0] & 0xff;
X        ex->val.s = NULL;
X    }
X    if (ex->kind == EK_VAR &&
X    (mp = (Meaning *)ex->val.i)->kind == MK_CONST &&
X    mp->val.type->kind == TK_STRING &&
X    mp->val.i == 1) {
X      ex->kind = EK_CONST;
X      ex->val.type = tp_char;
X      ex->val.i = mp->val.s[0] & 0xff;
X      ex->val.s = NULL;
X    }
X    return ex;
X}
X
X
X
XExpr *makeexpr_stringcast(ex)
XExpr *ex;
X{
X    char ch;
X
X    if (ex->kind == EK_CONST && ord_type(ex->val.type)->kind == TK_CHAR) {
X        ch = ex->val.i;
X        freeexpr(ex);
X        ex = makeexpr_lstring(&ch, 1);
X    }
X    return ex;
X}
X
X
X
X
X
X/* 0/1 = force to int/long, 2/3 = check if int/long */
X
XStatic Expr *dolongcast(a, tolong)
XExpr *a;
Xint tolong;
X{
X    Meaning *mp;
X    Expr *ex;
X    Type *type;
X    int i;
X
X    switch (a->kind) {
X
X        case EK_DOT:
X            if (!a->val.i) {
X                if (long_type(a->val.type) == (tolong&1))
X                    return a;
X                break;
X            }
X
X        /* fall through */
X        case EK_VAR:
X            mp = (Meaning *)a->val.i;
X            if (mp->kind == MK_FIELD && mp->val.i) {
X                if (mp->val.i <= ((sizeof_int > 0) ? sizeof_int : 16) &&
X                    !(tolong&1))
X                    return a;
X            } else if (mp->kind == MK_VAR ||
X                       mp->kind == MK_VARREF ||
X                       mp->kind == MK_PARAM ||
X                       mp->kind == MK_VARPARAM ||
X                       mp->kind == MK_FIELD) {
X                if (long_type(mp->type) == (tolong&1))
X                    return a;
X            }
X            break;
X
X        case EK_FUNCTION:
X            mp = (Meaning *)a->val.i;
X            if (long_type(mp->type->basetype) == (tolong&1))
X                return a;
X            break;
X
X        case EK_BICALL:
X            if (!strcmp(a->val.s, signextname) && *signextname) {
X                i = 0;
X                goto unary;
X            }
X        if (!strcmp(a->val.s, "strlen"))
X        goto size_t_case;
X            /* fall through */
X
X        case EK_HAT:      /* get true type from a->val.type */
X        case EK_INDEX:
X        case EK_SPCALL:
X        case EK_NAME:
X            if (long_type(a->val.type) == (tolong&1))
X                return a;
X            break;
X
X        case EK_ASSIGN:   /* destination determines type, */
X        case EK_POSTINC:  /*  but must not be changed */
X        case EK_POSTDEC:
X            return dolongcast(a->args[0], tolong|2);
X
X        case EK_CAST:
X            if (ord_type(a->val.type)->kind == TK_INTEGER &&
X                 long_type(a->val.type) == (tolong&1))
X                return a;
X            if (tolong == 0) {
X                a->val.type = tp_int;
X                return a;
X            } else if (tolong == 1) {
X                a->val.type = tp_integer;
X                return a;
X            }
X            break;
X
X        case EK_ACTCAST:
X            if (ord_type(a->val.type)->kind == TK_INTEGER &&
X                 long_type(a->val.type) == (tolong&1))
X                return a;
X            break;
X
X        case EK_CONST:
X            type = ord_type(a->val.type);
X            if (type->kind == TK_INTEGER || type->kind == TK_SMALLSET) {
X                if (tolong == 1)
X                    a->kind = EK_LONGCONST;
X                if (tolong != 3)
X                    return a;
X            }
X            break;
X
X        case EK_LONGCONST:
X            if (tolong == 0) {
X                if (a->val.i >= -32767 && a->val.i <= 32767)
X                    a->kind = EK_CONST;
X                else
X                    return NULL;
X            }
X            if (tolong != 2)
X                return a;
X            break;
X
X        case EK_SIZEOF:
X    size_t_case:
X            if (size_t_long > 0 && tolong&1)
X                return a;
X            if (size_t_long == 0 && !(tolong&1))
X                return a;
X            break;
X
X        case EK_PLUS:     /* usual arithmetic conversions apply */
X        case EK_TIMES:
X        case EK_DIV:
X        case EK_MOD:
X        case EK_BAND:
X        case EK_BOR:
X        case EK_BXOR:
X        case EK_COND:
X            i = (a->kind == EK_COND) ? 1 : 0;
X            if (tolong&1) {
X                for (; i < a->nargs; i++) {
X                    ex = dolongcast(a->args[i], tolong);
X                    if (ex) {
X                        a->args[i] = ex;
X                        return a;
X                    }
X                }
X            } else {
X                for (; i < a->nargs; i++) {
X                    if (!dolongcast(a->args[i], tolong))
X                        return NULL;
X                }
X                return a;
X            }
X            break;
X
X        case EK_BNOT:     /* single argument defines result type */
X        case EK_NEG:
X        case EK_LSH:
X        case EK_RSH:
X        case EK_COMMA:
X            i = (a->kind == EK_COMMA) ? a->nargs-1 : 0;
Xunary:
X            if (tolong&1) {
X                ex = dolongcast(a->args[i], tolong);
X                if (ex) {
X                    a->args[i] = ex;
X                    return a;
X                }
X            } else {
X                if (dolongcast(a->args[i], tolong))
X                    return a;
X            }
X            break;
X
X        case EK_AND:  /* operators which always return int */
X        case EK_OR:
X        case EK_EQ:
X        case EK_NE:
X        case EK_LT:
X        case EK_GT:
X        case EK_LE:
X        case EK_GE:
X            if (tolong&1)
X                break;
X            return a;
X
X    default:
X        break;
X    }
X    return NULL;
X}
X
X
X/* Return -1 if short int or plain int, 1 if long, 0 if can't tell */
Xint exprlongness(ex)
XExpr *ex;
X{
X    if (sizeof_int >= 32)
X        return -1;
X    return (dolongcast(ex, 3) != NULL) -
X           (dolongcast(ex, 2) != NULL);
X}
X
X
XExpr *makeexpr_longcast(a, tolong)
XExpr *a;
Xint tolong;
X{
X    Expr *ex;
X    Type *type;
X
X    if (sizeof_int >= 32)
X        return a;
X    type = ord_type(a->val.type);
X    if (type->kind != TK_INTEGER && type->kind != TK_SMALLSET)
X        return a;
X    a = makeexpr_unlongcast(a);
X    if (tolong) {
X        ex = dolongcast(a, 1);
X    } else {
X        ex = dolongcast(copyexpr(a), 0);
X        if (ex) {
X            if (!dolongcast(ex, 2)) {
X                freeexpr(ex);
X                ex = NULL;
X            }
X        }
X    }
X    if (ex)
X        return ex;
X    return makeexpr_un(EK_CAST, (tolong) ? tp_integer : tp_int, a);
X}
X
X
XExpr *makeexpr_arglong(a, tolong)
XExpr *a;
Xint tolong;
X{
X    int cast = castlongargs;
X    if (cast < 0)
X    cast = castargs;
X    if (cast > 0 || (cast < 0 && prototypes == 0)) {
X    return makeexpr_longcast(a, tolong);
X    }
X    return a;
X}
X
X
X
XExpr *makeexpr_unlongcast(a)
XExpr *a;
X{
X    switch (a->kind) {
X
X        case EK_LONGCONST:
X            if (a->val.i >= -32767 && a->val.i <= 32767)
X                a->kind = EK_CONST;
X            break;
X
X        case EK_CAST:
X            if ((a->val.type == tp_integer ||
X                 a->val.type == tp_int) &&
X                ord_type(a->args[0]->val.type)->kind == TK_INTEGER) {
X                a = grabarg(a, 0);
X            }
X            break;
X
X        default:
X        break;
X
X    }
X    return a;
X}
X
X
X
XExpr *makeexpr_forcelongness(a)    /* force a to have a definite longness */
XExpr *a;
X{
X    Expr *ex;
X
X    ex = makeexpr_unlongcast(copyexpr(a));
X    if (exprlongness(ex)) {
X        freeexpr(a);
X        return ex;
X    }
X    freeexpr(ex);
X    if (exprlongness(a) == 0)
X        return makeexpr_longcast(a, 1);
X    else
X        return a;
X}
X
X
X
XExpr *makeexpr_ord(ex)
XExpr *ex;
X{
X    ex = makeexpr_charcast(ex);
X    switch (ord_type(ex->val.type)->kind) {
X
X        case TK_ENUM:
X            return makeexpr_cast(ex, tp_int);
X
X        case TK_CHAR:
X            if (ex->kind == EK_CONST &&
X                (ex->val.i >= 32 && ex->val.i < 127)) {
X                insertarg(&ex, 0, makeexpr_name("'%lc'", tp_integer));
X            }
X            ex->val.type = tp_int;
X            return ex;
X
X        case TK_BOOLEAN:
X            ex->val.type = tp_int;
X            return ex;
X
X        case TK_POINTER:
X            return makeexpr_cast(ex, tp_integer);
X
X        default:
X            return ex;
X    }
X}
X
X
X
X
X/* Tell whether an expression "looks" negative */
Xint expr_looks_neg(ex)
XExpr *ex;
X{
X    int i;
X
X    switch (ex->kind) {
X
X        case EK_NEG:
X            return 1;
X
X        case EK_CONST:
X        case EK_LONGCONST:
X            switch (ord_type(ex->val.type)->kind) {
X                case TK_INTEGER:
X                case TK_CHAR:
X                    return (ex->val.i < 0);
X                case TK_REAL:
X                    return (ex->val.s && ex->val.s[0] == '-');
X                default:
X                    return 0;
X            }
X
X        case EK_TIMES:
X        case EK_DIVIDE:
X            for (i = 0; i < ex->nargs; i++) {
X                if (expr_looks_neg(ex->args[i]))
X                    return 1;
X            }
X            return 0;
X
X        case EK_CAST:
X            return expr_looks_neg(ex->args[0]);
X
X        default:
X            return 0;
X    }
X}
X
X
X
X/* Tell whether an expression is probably negative */
Xint expr_is_neg(ex)
XExpr *ex;
X{
X    int i;
X
X    i = possiblesigns(ex) & (1|4);
X    if (i == 1)
X    return 1;    /* if expression really is negative! */
X    if (i == 4)
X    return 0;    /* if expression is definitely positive. */
X    return expr_looks_neg(ex);
X}
X
X
X
Xint expr_neg_cost(a)
XExpr *a;
X{
X    int i, c;
X
X    switch (a->kind) {
X
X        case EK_CONST:
X        case EK_LONGCONST:
X            switch (ord_type(a->val.type)->kind) {
X                case TK_INTEGER:
X                case TK_CHAR:
X                case TK_REAL:
X                    return 0;
X        default:
X            return 1;
X            }
X
X        case EK_NEG:
X            return -1;
X
X        case EK_TIMES:
X        case EK_DIVIDE:
X            for (i = 0; i < a->nargs; i++) {
X                c = expr_neg_cost(a->args[i]);
X                if (c <= 0)
X                    return c;
X            }
X            return 1;
X
X        case EK_PLUS:
X            for (i = 0; i < a->nargs; i++) {
X                if (expr_looks_neg(a->args[i]))
X                    return 0;
X            }
X            return 1;
X
X        default:
X            return 1;
X    }
X}
X
X
X
XExpr *enum_to_int(a)
XExpr *a;
X{
X    if (ord_type(a->val.type)->kind == TK_ENUM) {
X        if (a->kind == EK_CAST &&
X             ord_type(a->args[0]->val.type)->kind == TK_INTEGER)
X            return grabarg(a, 0);
X        else
X            return makeexpr_cast(a, tp_integer);
X    } else
X        return a;
X}
X
X
X
XExpr *neg_inside_sum(a)
XExpr *a;
X{
X    int i;
X
X    for (i = 0; i < a->nargs; i++)
X        a->args[i] = makeexpr_neg(a->args[i]);
X    return a;
X}
X
X
X
XExpr *makeexpr_neg(a)
XExpr *a;
X{
X    int i;
X
X    if (debug>2) { fprintf(outf,"makeexpr_neg("); dumpexpr(a); fprintf(outf,")\n"); }
X    a = enum_to_int(a);
X    switch (a->kind) {
X
X        case EK_CONST:
X        case EK_LONGCONST:
X            switch (ord_type(a->val.type)->kind) {
X
X                case TK_INTEGER:
X                case TK_CHAR:
X                    if (a->val.i == MININT)
X                        valrange();
X                    else
X                        a->val.i = - a->val.i;
X                    return a;
X
X                case TK_REAL:
X                    if (!realzero(a->val.s)) {
X                        if (a->val.s[0] == '-')
X                            strchange(&a->val.s, a->val.s+1);
X                        else
X                            strchange(&a->val.s, format_s("-%s", a->val.s));
X                    }
X                    return a;
X
X        default:
X            break;
X            }
X            break;
X
X        case EK_PLUS:
X            if (expr_neg_cost(a) <= 0)
X                return neg_inside_sum(a);
X            break;
X
X        case EK_TIMES:
X        case EK_DIVIDE:
X            for (i = 0; i < a->nargs; i++) {
X                if (expr_neg_cost(a->args[i]) <= 0) {
X                    a->args[i] = makeexpr_neg(a->args[i]);
X                    return a;
X                }
X            }
X            break;
X
X        case EK_CAST:
X            if (a->val.type != tp_unsigned &&
X                 a->val.type != tp_uint &&
X                 a->val.type != tp_ushort &&
X                 a->val.type != tp_ubyte &&
X                 a->args[0]->val.type != tp_unsigned &&
X                 a->args[0]->val.type != tp_uint &&
X                 a->args[0]->val.type != tp_ushort &&
X                 a->args[0]->val.type != tp_ubyte &&
X                 expr_looks_neg(a->args[0])) {
X                a->args[0] = makeexpr_neg(a->args[0]);
X                return a;
X            }
X            break;
X
X        case EK_NEG:
X            return grabarg(a, 0);
X
X    default:
X        break;
X    }
X    return makeexpr_un(EK_NEG, promote_type(a->val.type), a);
X}
X
X
X
X
X#define ISCONST(kind) ((kind)==EK_CONST || (kind)==EK_LONGCONST)
X#define MOVCONST(ex) (ISCONST((ex)->kind) && (ex)->val.type->kind != TK_STRING)
X#define COMMUTATIVE (kind != EK_COMMA && type->kind != TK_REAL)
X
XType *true_type(ex)
XExpr *ex;
X{
X    Meaning *mp;
X    Type *type, *tp;
X
X    while (ex->kind == EK_CAST)
X    ex = ex->args[0];
X    type = ex->val.type;
X    if (ex->kind == EK_VAR || ex->kind == EK_FUNCTION || ex->kind == EK_DOT) {
X    mp = (Meaning *)ex->val.i;
X    if (mp && mp->type && mp->type->kind != TK_VOID)
X        type = mp->type;
X    }
X    if (ex->kind == EK_INDEX) {
X    tp = true_type(ex->args[0]);
X    if ((tp->kind == TK_ARRAY || tp->kind == TK_SMALLARRAY ||
X         tp->kind == TK_STRING) &&
X        tp->basetype && tp->basetype->kind != TK_VOID)
X        type = tp->basetype;
X    }
X    if (type->kind == TK_SUBR)
X    type = findbasetype(type, 0);
X    return type;
X}
X
Xint ischartype(ex)
XExpr *ex;
X{
X    if (ord_type(ex->val.type)->kind == TK_CHAR)
X    return 1;
X    if (true_type(ex)->kind == TK_CHAR)
X    return 1;
X    if (ISCONST(ex->kind) && ex->nargs > 0 &&
X    ex->args[0]->kind == EK_NAME &&
X    ex->args[0]->val.s[0] == '\'')
X    return 1;
X    return 0;
X}
X
XStatic Expr *commute(a, b, kind)
XExpr *a, *b;
Xenum exprkind kind;
X{
X    int i, di;
X    Type *type;
X
X    if (debug>2) { fprintf(outf,"commute("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
X#if 1
X    type = promote_type_bin(a->val.type, b->val.type);
X#else
X    type = a->val.type;
X    if (b->val.type->kind == TK_REAL)
X        type = b->val.type;
X#endif
X    if (MOVCONST(a) && !MOVCONST(b) && COMMUTATIVE)
X        swapexprs(a, b);                /* put constant last */
X    if (a->kind == kind) {
X        di = (MOVCONST(a->args[a->nargs-1]) && COMMUTATIVE) ? -1 : 0;
X        if (b->kind == kind) {
X            for (i = 0; i < b->nargs; i++)
X                insertarg(&a, a->nargs + di, b->args[i]);
X            FREE(b);
X        } else
X            insertarg(&a, a->nargs + di, b);
X        a->val.type = type;
X    } else if (b->kind == kind) {
X        if (MOVCONST(a) && COMMUTATIVE)
X            insertarg(&b, b->nargs, a);
X        else
X            insertarg(&b, 0, a);
X        a = b;
X        a->val.type = type;
X    } else {
X        a = makeexpr_bin(kind, type, a, b);
X    }
X    if (debug>2) { fprintf(outf,"commute returns "); dumpexpr(a); fprintf(outf,"\n"); }
X    return a;
X}
X
X
XExpr *makeexpr_plus(a, b)
XExpr *a, *b;
X{
X    int i, j, k;
X    Type *type;
X
X    if (debug>2) { fprintf(outf,"makeexpr_plus("); dumpexpr(a); fprintf(outf,", "); dumpexpr(b); fprintf(outf,")\n"); }
X    if (!a)
X        return b;
X    if (!b)
X        return a;
X    if (a->kind == EK_NEG && a->args[0]->kind == EK_PLUS)
X        a = neg_inside_sum(grabarg(a, 0));
X    if (b->kind == EK_NEG && b->args[0]->kind == EK_PLUS)
X        b = neg_inside_sum(grabarg(b, 0));
X    a = commute(enum_to_int(a), enum_to_int(b), EK_PLUS);
X    type = NULL;
X    for (i = 0; i < a->nargs; i++) {
X        if (ord_type(a->args[i]->val.type)->kind == TK_CHAR ||
X            a->args[i]->val.type->kind == TK_POINTER ||
X            a->args[i]->val.type->kind == TK_STRING) {   /* for string literals */
X            if (type == ord_type(a->args[i]->val.type))
X                type = tp_integer;   /* 'z'-'a' and p1-p2 are integers */
X            else
X                type = ord_type(a->args[i]->val.type);
X        }
X    }
X    if (type)
X        a->val.type = type;
X    for (i = 0; i < a->nargs && !ISCONST(a->args[i]->kind); i++) ;
X    if (i < a->nargs-1) {
X        for (j = i+1; j < a->nargs; j++) {
X            if (ISCONST(a->args[j]->kind)) {
X                if ((ord_type(a->args[i]->val.type) == ord_type(a->args[j]->val.type) ||
X             ord_type(a->args[i]->val.type)->kind == TK_INTEGER ||
X             ord_type(a->args[j]->val.type)->kind == TK_INTEGER) &&
X            (!ischartype(a->args[i]) || !ischartype(a->args[j])) &&
X                    (a->args[i]->val.type->kind != TK_REAL &&
X                     a->args[i]->val.type->kind != TK_STRING &&
X                     a->args[j]->val.type->kind != TK_REAL &&
X                     a->args[j]->val.type->kind != TK_STRING)) {
X                    a->args[i]->val.i += a->args[j]->val.i;
X                    delfreearg(&a, j);
X                    j--;
X                } else if (a->args[i]->val.type->kind == TK_STRING &&
X                           ord_type(a->args[j]->val.type)->kind == TK_INTEGER &&
X                           a->args[j]->val.i < 0 &&
X                           a->args[j]->val.i >= -stringleaders) {
X                    /* strictly speaking, the following is illegal pointer arithmetic */
X                    a->args[i] = makeexpr_lstring(a->args[i]->val.s + a->args[j]->val.i,
END_OF_FILE
if test 48982 -ne `wc -c <'src/expr.c.1'`; then
    echo shar: \"'src/expr.c.1'\" unpacked with wrong size!
fi
# end of 'src/expr.c.1'
fi
echo shar: End of archive 26 \(of 32\).
cp /dev/null ark26isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 32 archives.
    echo "Now see PACKNOTES and the README"
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0