Subject: v21i068: Pascal to C translator, Part23/32 Newsgroups: comp.sources.unix Approved: rsalz@uunet.UU.NET X-Checksum-Snefru: df15bdcd f4de8293 7de0746f 3c829fa9 Submitted-by: Dave Gillespie Posting-number: Volume 21, Issue 68 Archive-name: p2c/part23 #! /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 'src/pexpr.c.1' <<'END_OF_FILE' X/* "p2c", a Pascal to C translator. X Copyright (C) 1989 David Gillespie. X Author's address: daveg@csvax.caltech.edu; 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_PEXPR_C X#include "trans.h" X X X X XExpr *dots_n_hats(ex, target) XExpr *ex; XType *target; X{ X Expr *ex2, *ex3; X Type *tp, *tp2, *ot; X Meaning *mp, *tvar; X int bits, hassl; X X for (;;) { X if ((ex->val.type->kind == TK_PROCPTR || X ex->val.type->kind == TK_CPROCPTR) && X curtok != TOK_ASSIGN && X ((mp = (tp2 = ex->val.type)->basetype->fbase) == NULL || X (mp->isreturn && mp->xnext == NULL) || X curtok == TOK_LPAR) && X (tp2->basetype->basetype != tp_void || target == tp_void) && X (!target || (target->kind != TK_PROCPTR && X target->kind != TK_CPROCPTR))) { X hassl = tp2->escale; X ex2 = ex; X ex3 = copyexpr(ex2); X if (hassl != 0) X ex3 = makeexpr_cast(makeexpr_dotq(ex3, "proc", tp_anyptr), X makepointertype(tp2->basetype)); X ex = makeexpr_un(EK_SPCALL, tp2->basetype->basetype, ex3); X if (mp && mp->isreturn) { /* pointer to buffer for return value */ X tvar = makestmttempvar(ex->val.type->basetype, X (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP); X insertarg(&ex, 1, makeexpr_addr(makeexpr_var(tvar))); X mp = mp->xnext; X } X if (mp) { X if (wneedtok(TOK_LPAR)) { X ex = p_funcarglist(ex, mp, 0, 0); X skipcloseparen(); X } X } else if (curtok == TOK_LPAR) { X gettok(); X if (!wneedtok(TOK_RPAR)) X skippasttoken(TOK_RPAR); X } X if (hassl != 1 || hasstaticlinks == 2) { X freeexpr(ex2); X } else { X ex2 = makeexpr_dotq(ex2, "link", tp_anyptr), X ex3 = copyexpr(ex); X insertarg(&ex3, ex3->nargs, copyexpr(ex2)); X tp = maketype(TK_FUNCTION); X tp->basetype = tp2->basetype->basetype; X tp->fbase = tp2->basetype->fbase; X tp->issigned = 1; X ex3->args[0]->val.type = makepointertype(tp); X ex = makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()), X ex3, ex); X } X if (tp2->basetype->fbase && X tp2->basetype->fbase->isreturn && X tp2->basetype->fbase->kind == MK_VARPARAM) X ex = makeexpr_hat(ex, 0); /* returns pointer to structured result */ X continue; X } X switch (curtok) { X X case TOK_HAT: X case TOK_ADDR: X gettok(); X ex = makeexpr_hat(ex, 1); X break; X X case TOK_LBR: X do { X gettok(); X tp = ex->val.type; X if (tp->kind == TK_STRING) { X ex2 = p_expr(tp_integer); X if (checkconst(ex2, 0)) /* is it "s[0]"? */ X ex = makeexpr_bicall_1("strlen", tp_char, ex); X else X ex = makeexpr_index(ex, ex2, makeexpr_long(1)); X } else if (tp->kind == TK_ARRAY || X tp->kind == TK_SMALLARRAY) { X if (tp->smax) { X ord_range_expr(tp->indextype, &ex2, NULL); X ex2 = makeexpr_minus(p_ord_expr(), X copyexpr(ex2)); X if (!nodependencies(ex2, 0) && X *getbitsname == '*') { X mp = makestmttempvar(tp_integer, name_TEMP); X ex3 = makeexpr_assign(makeexpr_var(mp), ex2); X ex2 = makeexpr_var(mp); X } else X ex3 = NULL; X ex = makeexpr_bicall_3(getbitsname, tp_int, X ex, ex2, X makeexpr_long(tp->escale)); X if (tp->kind == TK_ARRAY) { X if (tp->basetype == tp_sshort) X bits = 4; X else X bits = 3; X insertarg(&ex, 3, makeexpr_long(bits)); X } X ex = makeexpr_comma(ex3, ex); X ot = ord_type(tp->smax->val.type); X if (ot->kind == TK_ENUM && ot->meaning && useenum) X ex = makeexpr_cast(ex, tp->smax->val.type); X ex->val.type = tp->smax->val.type; X } else { X ord_range_expr(ex->val.type->indextype, &ex2, NULL); X if (debug>2) { fprintf(outf, "ord_range_expr returns "); dumpexpr(ex2); fprintf(outf, "\n"); } X ex = makeexpr_index(ex, p_ord_expr(), X copyexpr(ex2)); X } X } else { X warning("Index on a non-array variable [287]"); X ex = makeexpr_bin(EK_INDEX, tp_integer, ex, p_expr(tp_integer)); X } X } while (curtok == TOK_COMMA); X if (!wneedtok(TOK_RBR)) X skippasttotoken(TOK_RBR, TOK_SEMI); X break; X X case TOK_DOT: X gettok(); X if (!wexpecttok(TOK_IDENT)) X break; X if (ex->val.type->kind == TK_STRING) { X if (!strcicmp(curtokbuf, "LENGTH")) { X ex = makeexpr_bicall_1("strlen", tp_int, ex); X } else if (!strcicmp(curtokbuf, "BODY")) { X /* nothing to do */ X } X gettok(); X break; X } X mp = curtoksym->fbase; X while (mp && mp->rectype != ex->val.type) X mp = mp->snext; X if (mp) X ex = makeexpr_dot(ex, mp); X else { X warning(format_s("No field called %s in that record [288]", curtokbuf)); X ex = makeexpr_dotq(ex, curtokcase, tp_integer); X } X gettok(); X break; X X case TOK_COLONCOLON: X gettok(); X if (wexpecttok(TOK_IDENT)) { X ex = pascaltypecast(curtokmeaning->type, ex); X gettok(); X } X break; X X default: X return ex; X } X } X} X X X XExpr *fake_dots_n_hats(ex) XExpr *ex; X{ X for (;;) { X switch (curtok) { X X case TOK_HAT: X case TOK_ADDR: X if (ex->val.type->kind == TK_POINTER) X ex = makeexpr_hat(ex, 0); X else { X ex->val.type = makepointertype(ex->val.type); X ex = makeexpr_un(EK_HAT, ex->val.type->basetype, ex); X } X gettok(); X break; X X case TOK_LBR: X do { X gettok(); X ex = makeexpr_bin(EK_INDEX, tp_integer, ex, p_expr(tp_integer)); X } while (curtok == TOK_COMMA); X if (!wneedtok(TOK_RBR)) X skippasttotoken(TOK_RBR, TOK_SEMI); X break; X X case TOK_DOT: X gettok(); X if (!wexpecttok(TOK_IDENT)) X break; X ex = makeexpr_dotq(ex, curtokcase, tp_integer); X gettok(); X break; X X case TOK_COLONCOLON: X gettok(); X if (wexpecttok(TOK_IDENT)) { X ex = pascaltypecast(curtokmeaning->type, ex); X gettok(); X } X break; X X default: X return ex; X } X } X} X X X XStatic void bindnames(ex) XExpr *ex; X{ X int i; X Symbol *sp; X Meaning *mp; X X if (ex->kind == EK_NAME) { X sp = findsymbol_opt(fixpascalname(ex->val.s)); X if (sp) { X mp = sp->mbase; X while (mp && !mp->isactive) X mp = mp->snext; X if (mp && !strcmp(mp->name, ex->val.s)) { X ex->kind = EK_VAR; X ex->val.i = (long)mp; X ex->val.type = mp->type; X } X } X } X i = ex->nargs; X while (--i >= 0) X bindnames(ex->args[i]); X} X X X Xvoid var_reference(mp) XMeaning *mp; X{ X Meaning *mp2; X X mp->refcount++; X if (mp->ctx && mp->ctx->kind == MK_FUNCTION && X mp->ctx->needvarstruct && X (mp->kind == MK_VAR || X mp->kind == MK_VARREF || X mp->kind == MK_VARMAC || X mp->kind == MK_PARAM || X mp->kind == MK_VARPARAM || X (mp->kind == MK_CONST && X (mp->type->kind == TK_ARRAY || X mp->type->kind == TK_RECORD)))) { X if (debug>1) { fprintf(outf, "varstruct'ing %s\n", mp->name); } X if (!mp->varstructflag) { X mp->varstructflag = 1; X if (mp->constdefn && /* move init code into function body */ X mp->kind != MK_VARMAC) { X mp2 = addmeaningafter(mp, curtoksym, MK_VAR); X curtoksym->mbase = mp2->snext; /* hide this fake variable */ X mp2->snext = mp; /* remember true variable */ X mp2->type = mp->type; X mp2->constdefn = mp->constdefn; X mp2->isforward = 1; /* declare it "static" */ X mp2->refcount++; /* so it won't be purged! */ X mp->constdefn = NULL; X mp->isforward = 0; X } X } X for (mp2 = curctx->ctx; mp2 != mp->ctx; mp2 = mp2->ctx) X mp2->varstructflag = 1; X mp2->varstructflag = 1; X } X} X X X XStatic Expr *p_variable(target) XType *target; X{ X Expr *ex, *ex2; X Meaning *mp; X Symbol *sym; X X if (curtok != TOK_IDENT) { X warning("Expected a variable [289]"); X return makeexpr_long(0); X } X if (!curtokmeaning) { X sym = curtoksym; X ex = makeexpr_name(curtokcase, tp_integer); X gettok(); X if (curtok == TOK_LPAR) { X ex = makeexpr_bicall_0(ex->val.s, tp_integer); X do { X gettok(); X insertarg(&ex, ex->nargs, p_expr(NULL)); X } while (curtok == TOK_COMMA || curtok == TOK_ASSIGN); X if (!wneedtok(TOK_RPAR)) X skippasttotoken(TOK_RPAR, TOK_SEMI); X } X if (!tryfuncmacro(&ex, NULL)) X undefsym(sym); X return fake_dots_n_hats(ex); X } X var_reference(curtokmeaning); X mp = curtokmeaning; X if (mp->kind == MK_FIELD) { X ex = makeexpr_dot(copyexpr(withexprs[curtokint]), mp); X } else if (mp->kind == MK_CONST && X mp->type->kind == TK_SET && X mp->constdefn) { X ex = copyexpr(mp->constdefn); X mp = makestmttempvar(ex->val.type, name_SET); X ex2 = makeexpr(EK_MACARG, 0); X ex2->val.type = ex->val.type; X ex = replaceexprexpr(ex, ex2, makeexpr_var(mp)); X freeexpr(ex2); X } else if (mp->kind == MK_CONST && X (mp == mp_false || X mp == mp_true || X mp->anyvarflag || X (foldconsts > 0 && X (mp->type->kind == TK_INTEGER || X mp->type->kind == TK_BOOLEAN || X mp->type->kind == TK_CHAR || X mp->type->kind == TK_ENUM || X mp->type->kind == TK_SUBR || X mp->type->kind == TK_REAL)) || X (foldstrconsts > 0 && X (mp->type->kind == TK_STRING)))) { X if (mp->constdefn) { X ex = copyexpr(mp->constdefn); X if (ex->val.type == tp_int) /* kludge! */ X ex->val.type = tp_integer; X } else X ex = makeexpr_val(copyvalue(mp->val)); X } else if (mp->kind == MK_VARPARAM || X mp->kind == MK_VARREF) { X ex = makeexpr_hat(makeexpr_var(mp), 0); X } else if (mp->kind == MK_VARMAC) { X ex = copyexpr(mp->constdefn); X bindnames(ex); X ex = gentle_cast(ex, mp->type); X ex->val.type = mp->type; X } else if (mp->kind == MK_SPVAR && mp->handler) { X gettok(); X ex = (*mp->handler)(mp); X return dots_n_hats(ex, target); X } else if (mp->kind == MK_VAR || X mp->kind == MK_CONST || X mp->kind == MK_PARAM) { X ex = makeexpr_var(mp); X } else { X symclass(mp->sym); X ex = makeexpr_name(mp->name, tp_integer); X } X gettok(); X return dots_n_hats(ex, target); X} X X X X XExpr *p_ord_expr() X{ X return makeexpr_charcast(p_expr(tp_integer)); X} X X X XStatic Expr *makesmallsetconst(bits, type) Xlong bits; XType *type; X{ X Expr *ex; X X ex = makeexpr_long(bits); X ex->val.type = type; X if (smallsetconst != 2) X insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer)); X return ex; X} X X X XExpr *packset(ex, type) XExpr *ex; XType *type; X{ X Meaning *mp; X Expr *ex2; X long max2; X X if (ex->kind == EK_BICALL) { X if (!strcmp(ex->val.s, setexpandname) && X (mp = istempvar(ex->args[0])) != NULL) { X canceltempvar(mp); X return grabarg(ex, 1); X } X if (!strcmp(ex->val.s, setunionname) && X (mp = istempvar(ex->args[0])) != NULL && X !exproccurs(ex->args[1], ex->args[0]) && X !exproccurs(ex->args[2], ex->args[0])) { X canceltempvar(mp); X return makeexpr_bin(EK_BOR, type, packset(ex->args[1], type), X packset(ex->args[2], type)); X } X if (!strcmp(ex->val.s, setaddname)) { X ex2 = makeexpr_bin(EK_LSH, type, X makeexpr_longcast(makeexpr_long(1), 1), X ex->args[1]); X ex = packset(ex->args[0], type); X if (checkconst(ex, 0)) X return ex2; X else X return makeexpr_bin(EK_BOR, type, ex, ex2); X } X if (!strcmp(ex->val.s, setaddrangename)) { X if (ord_range(type->indextype, NULL, &max2) && max2 == setbits-1) X note("Range construction was implemented by a subtraction which may overflow [278]"); X ex2 = makeexpr_minus(makeexpr_bin(EK_LSH, type, X makeexpr_longcast(makeexpr_long(1), 1), X makeexpr_plus(ex->args[2], X makeexpr_long(1))), X makeexpr_bin(EK_LSH, type, X makeexpr_longcast(makeexpr_long(1), 1), X ex->args[1])); X ex = packset(ex->args[0], type); X if (checkconst(ex, 0)) X return ex2; X else X return makeexpr_bin(EK_BOR, type, ex, ex2); X } X } X return makeexpr_bicall_1(setpackname, type, ex); X} X X X X#define MAXSETLIT 400 X XExpr *p_setfactor(type) XType *type; X{ X Expr *ex, *exmax = NULL, *ex2; X Expr *first[MAXSETLIT], *last[MAXSETLIT]; X char doneflag[MAXSETLIT]; X int i, j, num, donecount; X int isconst, guesstype = 0; X long maxv, max2; X Value val; X Type *tp; X Meaning *tvar; X X if (curtok == TOK_LBRACE) X gettok(); X else if (!wneedtok(TOK_LBR)) X return makeexpr_long(0); X if (curtok == TOK_RBR || curtok == TOK_RBRACE) { /* empty set */ X gettok(); X val.type = tp_smallset; X val.i = 0; X val.s = NULL; X return makeexpr_val(val); X } X if (!type) X guesstype = 1; X maxv = -1; X isconst = 1; X num = 0; X for (;;) { X if (num >= MAXSETLIT) { X warning(format_d("Too many elements in set literal; max=%d [290]", MAXSETLIT)); X ex = p_expr(type); X while (curtok != TOK_RBR && curtok != TOK_RBRACE) { X gettok(); X ex = p_expr(type); X } X break; X } X if (guesstype && num == 0) { X ex = p_ord_expr(); X type = ord_type(ex->val.type); X } else { X ex = p_expr(type); X } X first[num] = ex = gentle_cast(ex, type); X doneflag[num] = 0; X if (curtok == TOK_DOTS) { X val = eval_expr(ex); X if (val.type) { X if (val.i > maxv) { /* In case of [127..0] */ X maxv = val.i; X exmax = ex; X } X } else X isconst = 0; X gettok(); X last[num] = ex = gentle_cast(p_expr(type), type); X } else { X last[num] = NULL; X } X val = eval_expr(ex); X if (val.type) { X if (val.i > maxv) { X maxv = val.i; X exmax = ex; X } X } else { X isconst = 0; X maxv = LONG_MAX; X } X num++; X if (curtok == TOK_COMMA) X gettok(); X else X break; X } X if (curtok == TOK_RBRACE) X gettok(); X else if (!wneedtok(TOK_RBR)) X skippasttotoken(TOK_RBR, TOK_SEMI); X tp = ord_type(first[0]->val.type); X if (guesstype) { /* must determine type */ X if (!exmax || maxv == LONG_MAX) { X maxv = defaultsetsize-1; X if (ord_range(tp, NULL, &max2) && maxv > max2) X maxv = max2; X exmax = makeexpr_long(maxv); X } else X exmax = copyexpr(exmax); X if (!ord_range(tp, NULL, &max2) || maxv != max2) X tp = makesubrangetype(tp, makeexpr_long(0), exmax); X type = makesettype(tp); X } else X type = makesettype(type); X donecount = 0; X if (smallsetconst > 0) { X val.i = 0; X for (i = 0; i < num; i++) { X if (first[i]->kind == EK_CONST && first[i]->val.i < setbits && X (!last[i] || (last[i]->kind == EK_CONST && X last[i]->val.i >= 0 && X last[i]->val.i < setbits))) { X if (last[i]) { X for (j = first[i]->val.i; j <= last[i]->val.i; j++) X val.i |= 1<val.i; X doneflag[i] = 1; X donecount++; X } X } X } X if (donecount) { X ex = makesmallsetconst(val.i, tp_smallset); X } else X ex = NULL; X if (type->kind == TK_SMALLSET) { X for (i = 0; i < num; i++) { X if (!doneflag[i]) { X ex2 = makeexpr_bin(EK_LSH, type, X makeexpr_longcast(makeexpr_long(1), 1), X enum_to_int(first[i])); X if (last[i]) { X if (ord_range(type->indextype, NULL, &max2) && max2 == setbits-1) X note("Range construction was implemented by a subtraction which may overflow [278]"); X ex2 = makeexpr_minus(makeexpr_bin(EK_LSH, type, X makeexpr_longcast(makeexpr_long(1), 1), X makeexpr_plus(enum_to_int(last[i]), X makeexpr_long(1))), X ex2); X } X if (ex) X ex = makeexpr_bin(EK_BOR, type, makeexpr_longcast(ex, 1), ex2); X else X ex = ex2; X } X } X } else { X tvar = makestmttempvar(type, name_SET); X if (!ex) { X val.type = tp_smallset; X val.i = 0; X val.s = NULL; X ex = makeexpr_val(val); X } X ex = makeexpr_bicall_2(setexpandname, type, X makeexpr_var(tvar), makeexpr_arglong(ex, 1)); X for (i = 0; i < num; i++) { X if (!doneflag[i]) { X if (last[i]) X ex = makeexpr_bicall_3(setaddrangename, type, X ex, makeexpr_arglong(enum_to_int(first[i]), 0), X makeexpr_arglong(enum_to_int(last[i]), 0)); X else X ex = makeexpr_bicall_2(setaddname, type, X ex, makeexpr_arglong(enum_to_int(first[i]), 0)); X } X } X } X return ex; X} X X X X XExpr *p_funcarglist(ex, args, firstarg, ismacro) XExpr *ex; XMeaning *args; Xint firstarg, ismacro; X{ X Meaning *mp, *mp2, *arglist = args, *prevarg = NULL; X Expr *ex2; X int i, fi, fakenum = -1, castit, isconf, isnonpos = 0; X Type *tp, *tp2; X char *name; X X castit = castargs; X if (castit < 0) X castit = (prototypes == 0); X while (args) { X if (isnonpos) { X while (curtok == TOK_COMMA) X gettok(); X if (curtok == TOK_RPAR) { X args = arglist; X i = firstarg; X while (args) { X if (ex->nargs <= i) X insertarg(&ex, ex->nargs, NULL); X if (!ex->args[i]) { X if (args->constdefn) X ex->args[i] = copyexpr(args->constdefn); X else { X warning(format_s("Missing value for parameter %s [291]", X args->name)); X ex->args[i] = makeexpr_long(0); X } X } X args = args->xnext; X i++; X } X break; X } X } X if (args->isreturn || args->fakeparam) { X if (args->fakeparam) { X if (fakenum < 0) X fakenum = ex->nargs; X if (args->constdefn) X insertarg(&ex, ex->nargs, copyexpr(args->constdefn)); X else X insertarg(&ex, ex->nargs, makeexpr_long(0)); X } X args = args->xnext; /* return value parameter */ X continue; X } X if (curtok == TOK_RPAR) { X if (args->constdefn) { X insertarg(&ex, ex->nargs, copyexpr(args->constdefn)); X args = args->xnext; X continue; X } else { X if (ex->kind == EK_FUNCTION) { X name = ((Meaning *)ex->val.i)->name; X ex->kind = EK_BICALL; X ex->val.s = stralloc(name); X } else X name = "function"; X warning(format_s("Too few arguments for %s [292]", name)); X return ex; X } X } X if (curtok == TOK_COMMA) { X if (args->constdefn) X insertarg(&ex, ex->nargs, copyexpr(args->constdefn)); X else { X warning(format_s("Missing parameter %s [293]", args->name)); X insertarg(&ex, ex->nargs, makeexpr_long(0)); X } X gettok(); X args = args->xnext; X continue; X } X p_mech_spec(0); X if (curtok == TOK_IDENT) { X mp = arglist; X mp2 = NULL; X i = firstarg; X fi = -1; X while (mp && strcmp(curtokbuf, mp->sym->name)) { X if (mp->fakeparam) { X if (fi < 0) X fi = i; X } else X fi = -1; X i++; X mp2 = mp; X mp = mp->xnext; X } X if (mp && X (peeknextchar() == ':' || !curtokmeaning || isnonpos)) { X gettok(); X wneedtok(TOK_ASSIGN); X prevarg = mp2; X args = mp; X fakenum = fi; X isnonpos = 1; X } else X i = ex->nargs; X } else X i = ex->nargs; X while (ex->nargs <= i) X insertarg(&ex, ex->nargs, NULL); X if (ex->args[i]) X warning(format_s("Multiple values for parameter %s [294]", X args->name)); X tp = args->type; X ex2 = p_expr(tp); X if (args->kind == MK_VARPARAM) X tp = tp->basetype; X tp2 = ex2->val.type; X isconf = ((tp->kind == TK_ARRAY || X tp->kind == TK_STRING) && tp->structdefd); X switch (args->kind) { X X case MK_PARAM: X if (castit && tp->kind == TK_REAL && X ex2->val.type->kind != TK_REAL) X ex2 = makeexpr_cast(ex2, tp); X else if (ord_type(tp)->kind == TK_INTEGER && !ismacro) X ex2 = makeexpr_arglong(ex2, long_type(tp)); X else if (args->othername && args->rectype != tp && X tp->kind != TK_STRING && args->type == tp2) X ex2 = makeexpr_addr(ex2); X else X ex2 = gentle_cast(ex2, tp); X ex->args[i] = ex2; X break; X X case MK_VARPARAM: X if (args->type == tp_strptr && args->anyvarflag) { X ex->args[i] = strmax_func(ex2); X insertarg(&ex, ex->nargs-1, makeexpr_addr(ex2)); X if (isnonpos) X note("Non-positional conformant parameters may not work [279]"); X } else { /* regular VAR parameter */ X ex2 = makeexpr_addrf(ex2); X if (args->anyvarflag || X (tp->kind == TK_POINTER && tp2->kind == TK_POINTER && X (tp == tp_anyptr || tp2 == tp_anyptr))) { X if (!ismacro) X ex2 = makeexpr_cast(ex2, args->type); X } else { X if (tp2 != tp && !isconf && X (tp2->kind != TK_STRING || X tp->kind != TK_STRING)) X warning(format_s("Type mismatch in VAR parameter %s [295]", X args->name)); X } X ex->args[i] = ex2; X } X break; X X default: X intwarning("p_funcarglist", X format_s("Parameter type is %s [296]", X meaningkindname(args->kind))); X break; X } X if (isconf && /* conformant array or string */ X (!prevarg || prevarg->type != args->type)) { X while (tp->kind == TK_ARRAY && tp->structdefd) { X if (tp2->kind == TK_SMALLARRAY) { X warning("Trying to pass a small-array for a conformant array [297]"); X /* this has a chance of working... */ X ex->args[ex->nargs-1] = X makeexpr_addr(ex->args[ex->nargs-1]); X } else if (tp2->kind == TK_STRING) { X ex->args[fakenum++] = X makeexpr_arglong(makeexpr_long(1), integer16 == 0); X ex->args[fakenum++] = X makeexpr_arglong(strmax_func(ex->args[ex->nargs-1]), X integer16 == 0); X break; X } else if (tp2->kind != TK_ARRAY) { X warning("Type mismatch for conformant array [298]"); X break; X } X ex->args[fakenum++] = X makeexpr_arglong(copyexpr(tp2->indextype->smin), X integer16 == 0); X ex->args[fakenum++] = X makeexpr_arglong(copyexpr(tp2->indextype->smax), X integer16 == 0); X tp = tp->basetype; X tp2 = tp2->basetype; X } X if (tp->kind == TK_STRING && tp->structdefd) { X ex->args[fakenum] = X makeexpr_arglong(strmax_func(ex->args[ex->nargs-1]), X integer16 == 0); X } X } X fakenum = -1; X if (!isnonpos) { X prevarg = args; X args = args->xnext; X if (args) { X if (curtok != TOK_RPAR && !wneedtok(TOK_COMMA)) X skiptotoken2(TOK_RPAR, TOK_SEMI); X } X } X } X if (curtok == TOK_COMMA) { X if (ex->kind == EK_FUNCTION) { X name = ((Meaning *)ex->val.i)->name; X ex->kind = EK_BICALL; X ex->val.s = stralloc(name); X } else X name = "function"; X warning(format_s("Too many arguments for %s [299]", name)); X while (curtok == TOK_COMMA) { X gettok(); X insertarg(&ex, ex->nargs, p_expr(tp_integer)); X } X } X return ex; X} X X X XExpr *replacemacargs(ex, fex) XExpr *ex, *fex; X{ X int i; X Expr *ex2; X X for (i = 0; i < ex->nargs; i++) X ex->args[i] = replacemacargs(ex->args[i], fex); X if (ex->kind == EK_MACARG) { X if (ex->val.i <= fex->nargs) { X ex2 = copyexpr(fex->args[ex->val.i - 1]); X } else { X ex2 = makeexpr_name("", tp_integer); X note("FuncMacro specified more arguments than call [280]"); X } X freeexpr(ex); X return ex2; X } X return resimplify(ex); X} X X XExpr *p_noarglist(ex, mp, args) XExpr *ex; XMeaning *mp, *args; X{ X while (args && args->constdefn) { X insertarg(&ex, ex->nargs, copyexpr(args->constdefn)); X args = args->xnext; X } X if (args) { X warning(format_s("Expected an argument list for %s [300]", mp->name)); X ex->kind = EK_BICALL; X ex->val.s = stralloc(mp->name); X } X return ex; X} X X Xvoid func_reference(func) XMeaning *func; X{ X Meaning *mp; X X if (func->ctx && func->ctx != curctx &&func->ctx->kind == MK_FUNCTION && X func->ctx->varstructflag && !curctx->ctx->varstructflag) { X for (mp = curctx->ctx; mp != func->ctx; mp = mp->ctx) X mp->varstructflag = 1; X } X} X X XExpr *p_funccall(mp) XMeaning *mp; X{ X Meaning *mp2, *tvar; X Expr *ex, *ex2; X int firstarg = 0; X X func_reference(mp); X ex = makeexpr(EK_FUNCTION, 0); X ex->val.i = (long)mp; X ex->val.type = mp->type->basetype; X mp2 = mp->type->fbase; X if (mp2 && mp2->isreturn) { /* pointer to buffer for return value */ X tvar = makestmttempvar(ex->val.type->basetype, X (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP); X insertarg(&ex, 0, makeexpr_addr(makeexpr_var(tvar))); X mp2 = mp2->xnext; X firstarg++; X } X if (mp2 && curtok != TOK_LPAR) { X ex = p_noarglist(ex, mp, mp2); X } else if (curtok == TOK_LPAR) { X gettok(); X ex = p_funcarglist(ex, mp2, firstarg, (mp->constdefn != NULL)); X skipcloseparen(); X } X if (mp->constdefn) { X ex2 = replacemacargs(copyexpr(mp->constdefn), ex); X ex2 = gentle_cast(ex2, ex->val.type); X ex2->val.type = ex->val.type; X freeexpr(ex); X return ex2; X } X return ex; X} X X X X X X XExpr *accumulate_strlit() X{ X char buf[256], ch, *cp, *cp2; X int len, i, danger = 0; X X len = 0; X cp = buf; X for (;;) { X if (curtok == TOK_STRLIT) { X cp2 = curtokbuf; X i = curtokint; X while (--i >= 0) { X if (++len <= 255) { X ch = *cp++ = *cp2++; X if (ch & 128) X danger++; X } X } X } else if (curtok == TOK_HAT) { /* Turbo */ X i = getchartok() & 0x1f; X if (++len <= 255) X *cp++ = i; X } else if (curtok == TOK_LPAR) { /* VAX */ X Value val; X do { X gettok(); X val = p_constant(tp_integer); X if (++len <= 255) X *cp++ = val.i; X } while (curtok == TOK_COMMA); X skipcloseparen(); X continue; X } else X break; X gettok(); X } X if (len > 255) { X warning("String literal too long [301]"); X len = 255; X } X if (danger && X !(unsignedchar == 1 || X (unsignedchar != 0 && signedchars == 0))) X note(format_s("Character%s >= 128 encountered [281]", (danger > 1) ? "s" : "")); X return makeexpr_lstring(buf, len); X} X X X XExpr *pascaltypecast(type, ex2) XType *type; XExpr *ex2; X{ X if ((ex2->val.type->kind == TK_INTEGER || X ex2->val.type->kind == TK_CHAR || X ex2->val.type->kind == TK_BOOLEAN || X ex2->val.type->kind == TK_ENUM || X ex2->val.type->kind == TK_SUBR || X ex2->val.type->kind == TK_REAL || X ex2->val.type->kind == TK_POINTER || X ex2->val.type->kind == TK_STRING) && X (type->kind == TK_INTEGER || X type->kind == TK_CHAR || X type->kind == TK_BOOLEAN || X type->kind == TK_ENUM || X type->kind == TK_SUBR || X type->kind == TK_REAL || X type->kind == TK_POINTER)) { X if (type->kind == TK_POINTER || ex2->val.type->kind == TK_POINTER) X return makeexpr_un(EK_CAST, type, ex2); X else X return makeexpr_un(EK_ACTCAST, type, ex2); X } else { X return makeexpr_hat(makeexpr_cast(makeexpr_addr(ex2), X makepointertype(type)), 0); X } X} X X X X XStatic Expr *p_factor(target) XType *target; X{ X Expr *ex, *ex2; X Type *type; X Meaning *mp, *mp2; X X switch (curtok) { X X case TOK_INTLIT: X ex = makeexpr_long(curtokint); X gettok(); X return ex; X X case TOK_HEXLIT: X ex = makeexpr_long(curtokint); X insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer)); X gettok(); X return ex; X X case TOK_OCTLIT: X ex = makeexpr_long(curtokint); X insertarg(&ex, 0, makeexpr_name("%#lo", tp_integer)); X gettok(); X return ex; X X case TOK_MININT: X strcat(curtokbuf, ".0"); X X /* fall through */ X case TOK_REALLIT: X ex = makeexpr_real(curtokbuf); X gettok(); X return ex; X X case TOK_HAT: X case TOK_STRLIT: X ex = accumulate_strlit(); X return ex; X X case TOK_LPAR: X gettok(); X ex = p_expr(target); X skipcloseparen(); X return dots_n_hats(ex, target); X X case TOK_NOT: X case TOK_TWIDDLE: X gettok(); X ex = p_factor(tp_integer); X if (ord_type(ex->val.type)->kind == TK_INTEGER) X return makeexpr_un(EK_BNOT, tp_integer, ex); X else X return makeexpr_not(ex); X X case TOK_ADDR: X gettok(); X if (curtok == TOK_ADDR) { X gettok(); X ex = p_factor(tp_proc); X if (ex->val.type->kind == TK_PROCPTR && ex->kind == EK_COMMA) X return grabarg(grabarg(grabarg(ex, 0), 1), 0); X if (ex->val.type->kind != TK_CPROCPTR) X warning("@@ allowed only for procedure pointers [302]"); X return makeexpr_addrf(ex); X } X if (curtok == TOK_IDENT && 0 && /***/ X curtokmeaning && (curtokmeaning->kind == MK_FUNCTION || X curtokmeaning->kind == MK_SPECIAL)) { X if (curtokmeaning->ctx == nullctx) X warning(format_s("Can't take address of predefined object %s [303]", X curtokmeaning->name)); X ex = makeexpr_name(curtokmeaning->name, tp_anyptr); X gettok(); X } else { X ex = p_factor(tp_proc); X if (ex->val.type->kind == TK_PROCPTR) { X /* ex = makeexpr_dotq(ex, "proc", tp_anyptr); */ X } else if (ex->val.type->kind == TK_CPROCPTR) { X ex = makeexpr_cast(ex, tp_anyptr); X } else X ex = makeexpr_addrf(ex); X } X return ex; X X case TOK_LBR: X case TOK_LBRACE: X return p_setfactor(NULL); X X case TOK_NIL: X gettok(); X return makeexpr_nil(); X X case TOK_IF: /* nifty Pascal extension */ X gettok(); X ex = p_expr(tp_boolean); X wneedtok(TOK_THEN); X ex2 = p_expr(tp_integer); X if (wneedtok(TOK_ELSE)) X return makeexpr_cond(ex, ex2, p_factor(ex2->val.type)); X else X return makeexpr_cond(ex, ex2, makeexpr_long(0)); X X case TOK_IDENT: X mp = curtokmeaning; X switch ((mp) ? mp->kind : MK_VAR) { X X case MK_TYPE: X gettok(); X type = mp->type; X switch (curtok) { X X case TOK_LPAR: /* Turbo type cast */ X gettok(); X ex2 = p_expr(type); X ex = pascaltypecast(type, ex2); X skipcloseparen(); X return dots_n_hats(ex, target); X X case TOK_LBR: X case TOK_LBRACE: X switch (type->kind) { X X case TK_SET: X case TK_SMALLSET: X return p_setfactor(type->indextype); X X case TK_RECORD: X return p_constrecord(type, 0); X X case TK_ARRAY: X case TK_SMALLARRAY: X return p_constarray(type, 0); X X case TK_STRING: X return p_conststring(type, 0); X X default: X warning("Bad type for constructor [304]"); X skipparens(); X return makeexpr_name(mp->name, mp->type); X } X X default: X wexpected("an expression"); X return makeexpr_name(mp->name, mp->type); X } X X case MK_SPECIAL: X if (mp->handler && mp->isfunction && X (curtok == TOK_LPAR || !target || X (target->kind != TK_PROCPTR && X target->kind != TK_CPROCPTR))) { X gettok(); X if ((mp->sym->flags & LEAVEALONE) || mp->constdefn) { X ex = makeexpr_bicall_0(mp->name, tp_integer); X if (curtok == TOK_LPAR) { X do { X gettok(); X insertarg(&ex, ex->nargs, p_expr(NULL)); X } while (curtok == TOK_COMMA); X skipcloseparen(); X } X tryfuncmacro(&ex, mp); X return ex; X } X ex = (*mp->handler)(mp); X if (!ex) X ex = makeexpr_long(0); X return ex; X } else { X if (target->kind == TK_PROCPTR || X target->kind == TK_CPROCPTR) X note("Using a built-in procedure as a procedure pointer [316]"); X else X symclass(curtoksym); X gettok(); X return makeexpr_name(mp->name, tp_integer); X } X X case MK_FUNCTION: X mp->refcount++; X need_forward_decl(mp); X gettok(); X if (mp->isfunction && X (curtok == TOK_LPAR || !target || X (target->kind != TK_PROCPTR && X target->kind != TK_CPROCPTR))) { X ex = p_funccall(mp); X if (!mp->constdefn) { X if (mp->handler && !(mp->sym->flags & LEAVEALONE)) X ex = (*mp->handler)(ex); X } X if (mp->cbase->kind == MK_VARPARAM) { X ex = makeexpr_hat(ex, 0); /* returns pointer to structured result */ X } X return dots_n_hats(ex, target); X } else { X if (mp->handler && !(mp->sym->flags & LEAVEALONE)) X note("Using a built-in procedure as a procedure pointer [316]"); X if (target && target->kind == TK_CPROCPTR) { X type = maketype(TK_CPROCPTR); X type->basetype = mp->type; X type->escale = 0; X mp2 = makestmttempvar(type, name_TEMP); X ex = makeexpr_comma( X makeexpr_assign( X makeexpr_var(mp2), X makeexpr_name(mp->name, tp_text)), X makeexpr_var(mp2)); X if (mp->ctx->kind == MK_FUNCTION) X warning("Procedure pointer to nested procedure [305]"); X } else { X type = maketype(TK_PROCPTR); X type->basetype = mp->type; X type->escale = 1; X mp2 = makestmttempvar(type, name_TEMP); X ex = makeexpr_comma( X makeexpr_comma( X makeexpr_assign( X makeexpr_dotq(makeexpr_var(mp2), X "proc", X tp_anyptr), X makeexpr_name(mp->name, tp_text)), X /* handy pointer type */ X makeexpr_assign( X makeexpr_dotq(makeexpr_var(mp2), X "link", X tp_anyptr), X makeexpr_ctx(mp->ctx))), X makeexpr_var(mp2)); X } X return ex; X } X X default: X return p_variable(target); X } X X default: X wexpected("an expression"); X return makeexpr_long(0); X X } X} X X X X XStatic Expr *p_powterm(target) XType *target; X{ X Expr *ex = p_factor(target); X Expr *ex2; X int i, castit; X long v; X X if (curtok == TOK_STARSTAR) { X gettok(); X ex2 = p_powterm(target); X if (ex->val.type->kind == TK_REAL || X ex2->val.type->kind == TK_REAL) { X if (checkconst(ex2, 2)) { X ex = makeexpr_sqr(ex, 0); X } else if (checkconst(ex2, 3)) { X ex = makeexpr_sqr(ex, 1); X } else { X castit = castargs >= 0 ? castargs : (prototypes == 0); X if (ex->val.type->kind != TK_REAL && castit) X ex = makeexpr_cast(ex, tp_longreal); X if (ex2->val.type->kind != TK_REAL && castit) X ex2 = makeexpr_cast(ex2, tp_longreal); X ex = makeexpr_bicall_2("pow", tp_longreal, ex, ex2); X } X } else if (checkconst(ex, 2)) { X freeexpr(ex); X ex = makeexpr_bin(EK_LSH, tp_integer, X makeexpr_longcast(makeexpr_long(1), 1), ex2); X } else if (checkconst(ex, 0) || X checkconst(ex, 1) || X checkconst(ex2, 1)) { X freeexpr(ex2); X } else if (checkconst(ex2, 0)) { X freeexpr(ex); X freeexpr(ex2); X ex = makeexpr_long(1); X } else if (isliteralconst(ex, NULL) == 2 && X isliteralconst(ex2, NULL) == 2 && X ex2->val.i > 0) { X v = ex->val.i; X i = ex2->val.i; X while (--i > 0) X v *= ex->val.i; X freeexpr(ex); X freeexpr(ex2); X ex = makeexpr_long(v); X } else if (checkconst(ex2, 2)) { X ex = makeexpr_sqr(ex, 0); X } else if (checkconst(ex2, 3)) { X ex = makeexpr_sqr(ex, 1); X } else { X ex = makeexpr_bicall_2("ipow", tp_integer, X makeexpr_arglong(ex, 1), X makeexpr_arglong(ex2, 1)); X } X } X return ex; X} X X XStatic Expr *p_term(target) XType *target; X{ X Expr *ex = p_powterm(target); X Expr *ex2; X Type *type; X Meaning *tvar; X int useshort; X X for (;;) { X checkkeyword(TOK_SHL); X checkkeyword(TOK_SHR); X checkkeyword(TOK_REM); X switch (curtok) { X X case TOK_STAR: X gettok(); X if (ex->val.type->kind == TK_SET || X ex->val.type->kind == TK_SMALLSET) { X ex2 = p_powterm(ex->val.type); X type = mixsets(&ex, &ex2); X if (type->kind == TK_SMALLSET) { X ex = makeexpr_bin(EK_BAND, type, ex, ex2); X } else { X tvar = makestmttempvar(type, name_SET); X ex = makeexpr_bicall_3(setintname, type, X makeexpr_var(tvar), X ex, ex2); X } X } else X ex = makeexpr_times(ex, p_powterm(tp_integer)); X break; X X case TOK_SLASH: X gettok(); X if (ex->val.type->kind == TK_SET || X ex->val.type->kind == TK_SMALLSET) { X ex2 = p_powterm(ex->val.type); X type = mixsets(&ex, &ex2); X if (type->kind == TK_SMALLSET) { X ex = makeexpr_bin(EK_BXOR, type, ex, ex2); X } else { X tvar = makestmttempvar(type, name_SET); X ex = makeexpr_bicall_3(setxorname, type, X makeexpr_var(tvar), X ex, ex2); X } X } else X ex = makeexpr_divide(ex, p_powterm(tp_integer)); X break; X X case TOK_DIV: X gettok(); X ex = makeexpr_div(ex, p_powterm(tp_integer)); X break; X X case TOK_REM: X gettok(); X ex = makeexpr_rem(ex, p_powterm(tp_integer)); X break; X X case TOK_MOD: X gettok(); X ex = makeexpr_mod(ex, p_powterm(tp_integer)); X break; X X case TOK_AND: X case TOK_AMP: X useshort = (curtok == TOK_AMP); X gettok(); X ex2 = p_powterm(tp_integer); X if (ord_type(ex->val.type)->kind == TK_INTEGER) X ex = makeexpr_bin(EK_BAND, ex->val.type, ex, ex2); X else if (partial_eval_flag || useshort || X (shortopt && nosideeffects(ex2, 1))) X ex = makeexpr_and(ex, ex2); X else X ex = makeexpr_bin(EK_BAND, tp_boolean, ex, ex2); X break; X X case TOK_SHL: X gettok(); X ex = makeexpr_bin(EK_LSH, ex->val.type, ex, p_powterm(tp_integer)); X break; X X case TOK_SHR: X gettok(); X ex = force_unsigned(ex); X ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_powterm(tp_integer)); X break; X X default: X return ex; X } X } X} X X X XStatic Expr *p_sexpr(target) XType *target; X{ X Expr *ex, *ex2; X Type *type; X Meaning *tvar; X int useshort; X X switch (curtok) { X case TOK_MINUS: X gettok(); X if (curtok == TOK_MININT) { X gettok(); X ex = makeexpr_long(MININT); X break; X } X ex = makeexpr_neg(p_term(target)); X break; X case TOK_PLUS: X gettok(); X /* fall through */ X default: X ex = p_term(target); X break; X } X if (curtok == TOK_PLUS && X (ex->val.type->kind == TK_STRING || X ord_type(ex->val.type)->kind == TK_CHAR || X ex->val.type->kind == TK_ARRAY)) { X while (curtok == TOK_PLUS) { X gettok(); X ex = makeexpr_concat(ex, p_term(NULL), 0); X } X return ex; X } else { X for (;;) { X checkkeyword(TOK_XOR); X switch (curtok) { X X case TOK_PLUS: X gettok(); X if (ex->val.type->kind == TK_SET || X ex->val.type->kind == TK_SMALLSET) { X ex2 = p_term(ex->val.type); X type = mixsets(&ex, &ex2); X if (type->kind == TK_SMALLSET) { X ex = makeexpr_bin(EK_BOR, type, ex, ex2); X } else { X tvar = makestmttempvar(type, name_SET); X ex = makeexpr_bicall_3(setunionname, type, X makeexpr_var(tvar), X ex, ex2); X } X } else X ex = makeexpr_plus(ex, p_term(tp_integer)); X break; X X case TOK_MINUS: X gettok(); X if (ex->val.type->kind == TK_SET || X ex->val.type->kind == TK_SMALLSET) { X ex2 = p_term(tp_integer); X type = mixsets(&ex, &ex2); X if (type->kind == TK_SMALLSET) { X ex = makeexpr_bin(EK_BAND, type, ex, X makeexpr_un(EK_BNOT, type, ex2)); X } else { X tvar = makestmttempvar(type, name_SET); X ex = makeexpr_bicall_3(setdiffname, type, X makeexpr_var(tvar), ex, ex2); X } X } else X ex = makeexpr_minus(ex, p_term(tp_integer)); X break; X X case TOK_VBAR: X if (modula2) X return ex; X /* fall through */ X X case TOK_OR: X useshort = (curtok == TOK_VBAR); X gettok(); X ex2 = p_term(tp_integer); X if (ord_type(ex->val.type)->kind == TK_INTEGER) X ex = makeexpr_bin(EK_BOR, ex->val.type, ex, ex2); X else if (partial_eval_flag || useshort || X (shortopt && nosideeffects(ex2, 1))) X ex = makeexpr_or(ex, ex2); X else X ex = makeexpr_bin(EK_BOR, tp_boolean, ex, ex2); X break; X X case TOK_XOR: X gettok(); X ex2 = p_term(tp_integer); X ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2); X break; X X default: X return ex; X } X } X } X} X X X XExpr *p_expr(target) XType *target; X{ X Expr *ex = p_sexpr(target); X Expr *ex2, *ex3, *ex4; X Type *type; X Meaning *tvar; X long mask, smin, smax; X int i, j; X X switch (curtok) { X X case TOK_EQ: X gettok(); X return makeexpr_rel(EK_EQ, ex, p_sexpr(ex->val.type)); X X case TOK_NE: X gettok(); X return makeexpr_rel(EK_NE, ex, p_sexpr(ex->val.type)); X X case TOK_LT: X gettok(); X return makeexpr_rel(EK_LT, ex, p_sexpr(ex->val.type)); X X case TOK_GT: X gettok(); X return makeexpr_rel(EK_GT, ex, p_sexpr(ex->val.type)); X X case TOK_LE: X gettok(); X return makeexpr_rel(EK_LE, ex, p_sexpr(ex->val.type)); X X case TOK_GE: X gettok(); X return makeexpr_rel(EK_GE, ex, p_sexpr(ex->val.type)); X X case TOK_IN: X gettok(); X ex2 = p_sexpr(tp_smallset); X ex = gentle_cast(ex, ex2->val.type->indextype); X if (ex2->val.type->kind == TK_SMALLSET) { X if (!ord_range(ex->val.type, &smin, &smax)) { X smin = -1; X smax = setbits; X } X if (!nosideeffects(ex, 0)) { X tvar = makestmttempvar(ex->val.type, name_TEMP); X ex3 = makeexpr_assign(makeexpr_var(tvar), ex); END_OF_FILE if test 48768 -ne `wc -c <'src/pexpr.c.1'`; then echo shar: \"'src/pexpr.c.1'\" unpacked with wrong size! fi # end of 'src/pexpr.c.1' fi echo shar: End of archive 23 \(of 32\). cp /dev/null ark23isdone 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