v21i066: Pascal to C translator, Part21/32
Rich Salz
rsalz at uunet.uu.net
Thu Mar 29 23:48:39 AEST 1990
Submitted-by: Dave Gillespie <daveg at csvax.caltech.edu>
Posting-number: Volume 21, Issue 66
Archive-name: p2c/part21
#! /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 21 (of 32)."
# Contents: src/funcs.c.1
# Wrapped by rsalz at litchi.bbn.com on Mon Mar 26 14:29:44 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/funcs.c.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'src/funcs.c.1'\"
else
echo shar: Extracting \"'src/funcs.c.1'\" \(48548 characters\)
sed "s/^X//" >'src/funcs.c.1' <<'END_OF_FILE'
X/* "p2c", a Pascal to C translator.
X Copyright (C) 1989 David Gillespie.
X Author's address: daveg at 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_FUNCS_C
X#include "trans.h"
X
X
X
X
XStatic Strlist *enumnames;
XStatic int enumnamecount;
X
X
X
Xvoid setup_funcs()
X{
X enumnames = NULL;
X enumnamecount = 0;
X}
X
X
X
X
X
Xint isvar(ex, mp)
XExpr *ex;
XMeaning *mp;
X{
X return (ex->kind == EK_VAR && (Meaning *)ex->val.i == mp);
X}
X
X
X
X
Xchar *getstring(ex)
XExpr *ex;
X{
X ex = makeexpr_stringify(ex);
X if (ex->kind != EK_CONST || ex->val.type->kind != TK_STRING) {
X intwarning("getstring", "Not a string literal [206]");
X return "";
X }
X return ex->val.s;
X}
X
X
X
X
XExpr *p_parexpr(target)
XType *target;
X{
X Expr *ex;
X
X if (wneedtok(TOK_LPAR)) {
X ex = p_expr(target);
X if (!wneedtok(TOK_RPAR))
X skippasttotoken(TOK_RPAR, TOK_SEMI);
X } else
X ex = p_expr(target);
X return ex;
X}
X
X
X
XType *argbasetype(ex)
XExpr *ex;
X{
X if (ex->kind == EK_CAST)
X ex = ex->args[0];
X if (ex->val.type->kind == TK_POINTER)
X return ex->val.type->basetype;
X else
X return ex->val.type;
X}
X
X
X
XType *choosetype(t1, t2)
XType *t1, *t2;
X{
X if (t1 == tp_void ||
X (type_sizeof(t2, 1) && !type_sizeof(t1, 1)))
X return t2;
X else
X return t1;
X}
X
X
X
XExpr *convert_offset(type, ex2)
XType *type;
XExpr *ex2;
X{
X long size;
X int i;
X Value val;
X Expr *ex3;
X
X if (type->kind == TK_POINTER ||
X type->kind == TK_ARRAY ||
X type->kind == TK_SET ||
X type->kind == TK_STRING)
X type = type->basetype;
X size = type_sizeof(type, 1);
X if (size == 1)
X return ex2;
X val = eval_expr_pasc(ex2);
X if (val.type) {
X if (val.i == 0)
X return ex2;
X if (size && val.i % size == 0) {
X freeexpr(ex2);
X return makeexpr_long(val.i / size);
X }
X } else { /* look for terms like "n*sizeof(foo)" */
X while (ex2->kind == EK_CAST || ex2->kind == EK_ACTCAST)
X ex2 = ex2->args[0];
X if (ex2->kind == EK_TIMES) {
X for (i = 0; i < ex2->nargs; i++) {
X ex3 = convert_offset(type, ex2->args[i]);
X if (ex3) {
X ex2->args[i] = ex3;
X return resimplify(ex2);
X }
X }
X for (i = 0;
X i < ex2->nargs && ex2->args[i]->kind != EK_SIZEOF;
X i++) ;
X if (i < ex2->nargs) {
X if (ex2->args[i]->args[0]->val.type == type) {
X delfreearg(&ex2, i);
X if (ex2->nargs == 1)
X return ex2->args[0];
X else
X return ex2;
X }
X }
X } else if (ex2->kind == EK_PLUS) {
X ex3 = copyexpr(ex2);
X for (i = 0; i < ex2->nargs; i++) {
X ex3->args[i] = convert_offset(type, ex3->args[i]);
X if (!ex3->args[i]) {
X freeexpr(ex3);
X return NULL;
X }
X }
X freeexpr(ex2);
X return resimplify(ex3);
X } else if (ex2->kind == EK_SIZEOF) {
X if (ex2->args[0]->val.type == type) {
X freeexpr(ex2);
X return makeexpr_long(1);
X }
X } else if (ex2->kind == EK_NEG) {
X ex3 = convert_offset(type, ex2->args[0]);
X if (ex3)
X return makeexpr_neg(ex3);
X }
X }
X return NULL;
X}
X
X
X
XExpr *convert_size(type, ex, name)
XType *type;
XExpr *ex;
Xchar *name;
X{
X long size;
X Expr *ex2;
X int i, okay;
X Value val;
X
X if (debug>2) { fprintf(outf,"convert_size("); dumpexpr(ex); fprintf(outf,")\n"); }
X while (type->kind == TK_ARRAY || type->kind == TK_STRING)
X type = type->basetype;
X if (type == tp_void)
X return ex;
X size = type_sizeof(type, 1);
X if (size == 1)
X return ex;
X while (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
X ex = ex->args[0];
X switch (ex->kind) {
X
X case EK_TIMES:
X for (i = 0; i < ex->nargs; i++) {
X ex2 = convert_size(type, ex->args[i], NULL);
X if (ex2) {
X ex->args[i] = ex2;
X return resimplify(ex);
X }
X }
X break;
X
X case EK_PLUS:
X okay = 1;
X for (i = 0; i < ex->nargs; i++) {
X ex2 = convert_size(type, ex->args[i], NULL);
X if (ex2)
X ex->args[i] = ex2;
X else
X okay = 0;
X }
X ex = distribute_plus(ex);
X if ((ex->kind != EK_TIMES || !okay) && name)
X note(format_s("Suspicious mixture of sizes in %s [173]", name));
X return ex;
X
X case EK_SIZEOF:
X return ex;
X
X default:
X break;
X }
X val = eval_expr_pasc(ex);
X if (val.type) {
X if (val.i == 0)
X return ex;
X if (size && val.i % size == 0) {
X freeexpr(ex);
X return makeexpr_times(makeexpr_long(val.i / size),
X makeexpr_sizeof(makeexpr_type(type), 0));
X }
X }
X if (name) {
X note(format_s("Can't interpret size in %s [174]", name));
X return ex;
X } else
X return NULL;
X}
X
X
X
X
X
X
X
X
X
X
X
X
XStatic Expr *func_abs()
X{
X Expr *ex;
X Meaning *tvar;
X int lness;
X
X ex = p_parexpr(tp_integer);
X if (ex->val.type->kind == TK_REAL)
X return makeexpr_bicall_1("fabs", tp_longreal, ex);
X else {
X lness = exprlongness(ex);
X if (lness < 0)
X return makeexpr_bicall_1("abs", tp_int, ex);
X else if (lness > 0 && *absname) {
X if (ansiC > 0) {
X return makeexpr_bicall_1("labs", tp_integer, ex);
X } else if (*absname == '*' && (exprspeed(ex) >= 5 || !nosideeffects(ex, 0))) {
X tvar = makestmttempvar(tp_integer, name_TEMP);
X return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar),
X ex),
X makeexpr_bicall_1(absname, tp_integer,
X makeexpr_var(tvar)));
X } else {
X return makeexpr_bicall_1(absname, tp_integer, ex);
X }
X } else if (exprspeed(ex) < 5 && nosideeffects(ex, 0)) {
X return makeexpr_cond(makeexpr_rel(EK_LT, copyexpr(ex),
X makeexpr_long(0)),
X makeexpr_neg(copyexpr(ex)),
X ex);
X } else {
X tvar = makestmttempvar(tp_integer, name_TEMP);
X return makeexpr_cond(makeexpr_rel(EK_LT, makeexpr_assign(makeexpr_var(tvar),
X ex),
X makeexpr_long(0)),
X makeexpr_neg(makeexpr_var(tvar)),
X makeexpr_var(tvar));
X }
X }
X}
X
X
X
XStatic Expr *func_addr()
X{
X Expr *ex, *ex2, *ex3;
X Type *type, *tp2;
X int haspar;
X
X haspar = wneedtok(TOK_LPAR);
X ex = p_expr(tp_proc);
X if (curtok == TOK_COMMA) {
X gettok();
X ex2 = p_expr(tp_integer);
X ex3 = convert_offset(ex->val.type, ex2);
X if (checkconst(ex3, 0)) {
X ex = makeexpr_addrf(ex);
X } else {
X ex = makeexpr_addrf(ex);
X if (ex3) {
X ex = makeexpr_plus(ex, ex3);
X } else {
X note("Don't know how to reduce offset for ADDR [175]");
X type = makepointertype(tp_abyte);
X tp2 = ex->val.type;
X ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
X }
X }
X } else {
X if ((ex->val.type->kind != TK_PROCPTR &&
X ex->val.type->kind != TK_CPROCPTR) ||
X (ex->kind == EK_VAR &&
X ex->val.type == ((Meaning *)ex->val.i)->type))
X ex = makeexpr_addrf(ex);
X }
X if (haspar) {
X if (!wneedtok(TOK_RPAR))
X skippasttotoken(TOK_RPAR, TOK_SEMI);
X }
X return ex;
X}
X
X
XStatic Expr *func_iaddress()
X{
X return makeexpr_cast(func_addr(), tp_integer);
X}
X
X
X
XStatic Expr *func_addtopointer()
X{
X Expr *ex, *ex2, *ex3;
X Type *type, *tp2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_anyptr);
X if (skipcomma()) {
X ex2 = p_expr(tp_integer);
X } else
X ex2 = makeexpr_long(0);
X skipcloseparen();
X ex3 = convert_offset(ex->val.type, ex2);
X if (!checkconst(ex3, 0)) {
X if (ex3) {
X ex = makeexpr_plus(ex, ex3);
X } else {
X note("Don't know how to reduce offset for ADDTOPOINTER [175]");
X type = makepointertype(tp_abyte);
X tp2 = ex->val.type;
X ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
X }
X }
X return ex;
X}
X
X
X
XStmt *proc_assert()
X{
X Expr *ex;
X
X ex = p_parexpr(tp_boolean);
X return makestmt_call(makeexpr_bicall_1("assert", tp_void, ex));
X}
X
X
X
XStmt *wrapopencheck(sp, fex)
XStmt *sp;
XExpr *fex;
X{
X Stmt *sp2;
X
X if (FCheck(checkfileisopen) && !is_std_file(fex)) {
X sp2 = makestmt(SK_IF);
X sp2->exp1 = makeexpr_rel(EK_NE, fex, makeexpr_nil());
X sp2->stm1 = sp;
X if (iocheck_flag) {
X sp2->stm2 = makestmt_call(makeexpr_bicall_1(name_ESCIO, tp_integer,
X makeexpr_name(filenotopenname, tp_int)));
X } else {
X sp2->stm2 = makestmt_assign(makeexpr_var(mp_ioresult),
X makeexpr_name(filenotopenname, tp_int));
X }
X return sp2;
X } else {
X freeexpr(fex);
X return sp;
X }
X}
X
X
X
XStatic Expr *checkfilename(nex)
XExpr *nex;
X{
X Expr *ex;
X
X nex = makeexpr_stringcast(nex);
X if (nex->kind == EK_CONST && nex->val.type->kind == TK_STRING) {
X switch (which_lang) {
X
X case LANG_HP:
X if (!strncmp(nex->val.s, "#1:", 3) ||
X !strncmp(nex->val.s, "console:", 8) ||
X !strncmp(nex->val.s, "CONSOLE:", 8)) {
X freeexpr(nex);
X nex = makeexpr_string("/dev/tty");
X } else if (!strncmp(nex->val.s, "#2:", 3) ||
X !strncmp(nex->val.s, "systerm:", 8) ||
X !strncmp(nex->val.s, "SYSTERM:", 8)) {
X freeexpr(nex);
X nex = makeexpr_string("/dev/tty"); /* should do more? */
X } else if (!strncmp(nex->val.s, "#6:", 3) ||
X !strncmp(nex->val.s, "printer:", 8) ||
X !strncmp(nex->val.s, "PRINTER:", 8)) {
X note("Opening a file named PRINTER: [176]");
X } else if (my_strchr(nex->val.s, ':')) {
X note("Opening a file whose name contains a ':' [177]");
X }
X break;
X
X case LANG_TURBO:
X if (checkstring(nex, "con") ||
X checkstring(nex, "CON") ||
X checkstring(nex, "")) {
X freeexpr(nex);
X nex = makeexpr_string("/dev/tty");
X } else if (checkstring(nex, "nul") ||
X checkstring(nex, "NUL")) {
X freeexpr(nex);
X nex = makeexpr_string("/dev/null");
X } else if (checkstring(nex, "lpt1") ||
X checkstring(nex, "LPT1") ||
X checkstring(nex, "lpt2") ||
X checkstring(nex, "LPT2") ||
X checkstring(nex, "lpt3") ||
X checkstring(nex, "LPT3") ||
X checkstring(nex, "com1") ||
X checkstring(nex, "COM1") ||
X checkstring(nex, "com2") ||
X checkstring(nex, "COM2")) {
X note("Opening a DOS device file name [178]");
X }
X break;
X
X default:
X break;
X }
X } else {
X if (*filenamefilter && strcmp(filenamefilter, "0")) {
X ex = makeexpr_sizeof(copyexpr(nex), 0);
X nex = makeexpr_bicall_2(filenamefilter, tp_str255, nex, ex);
X } else
X nex = makeexpr_stringify(nex);
X }
X return nex;
X}
X
X
X
XStatic Stmt *assignfilename(fex, nex)
XExpr *fex, *nex;
X{
X Meaning *mp;
X
X mp = isfilevar(fex);
X if (mp && mp->namedfile) {
X freeexpr(fex);
X return makestmt_call(makeexpr_assign(makeexpr_name(format_s(name_FNVAR, mp->name),
X tp_str255),
X nex));
X } else {
X if (mp)
X warning("Don't know how to ASSIGN to a non-explicit file variable [207]");
X else
X note("Encountered an ASSIGN statement [179]");
X return makestmt_call(makeexpr_bicall_2("assign", tp_void, fex, nex));
X }
X}
X
X
X
XStatic Stmt *proc_assign()
X{
X Expr *fex, *nex;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X nex = checkfilename(p_expr(tp_str255));
X skipcloseparen();
X return assignfilename(fex, nex);
X}
X
X
X
XStatic Stmt *handleopen(code)
Xint code;
X{
X Stmt *sp, *spassign;
X Expr *fex, *nex, *ex;
X Meaning *fmp;
X int storefilename, needcheckopen = 1;
X char modebuf[5], *cp;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X fmp = isfilevar(fex);
X storefilename = (fmp && fmp->namedfile);
X spassign = NULL;
X if (curtok == TOK_COMMA) {
X gettok();
X ex = p_expr(tp_str255);
X } else
X ex = NULL;
X if (ex && (ex->val.type->kind == TK_STRING ||
X ex->val.type->kind == TK_ARRAY)) {
X nex = checkfilename(ex);
X if (storefilename) {
X spassign = assignfilename(copyexpr(fex), nex);
X nex = makeexpr_name(format_s(name_FNVAR, fmp->name), tp_str255);
X }
X if (curtok == TOK_COMMA) {
X gettok();
X ex = p_expr(tp_str255);
X } else
X ex = NULL;
X } else if (storefilename) {
X nex = makeexpr_name(format_s(name_FNVAR, fmp->name), tp_str255);
X } else {
X switch (code) {
X case 0:
X if (ex)
X note("Can't interpret name argument in RESET [180]");
X break;
X case 1:
X note("REWRITE does not specify a name [181]");
X break;
X case 2:
X note("OPEN does not specify a name [181]");
X break;
X case 3:
X note("APPEND does not specify a name [181]");
X break;
X }
X nex = NULL;
X }
X if (ex) {
X if (ord_type(ex->val.type)->kind == TK_INTEGER) {
X if (!checkconst(ex, 1))
X note("Ignoring block size in binary file [182]");
X freeexpr(ex);
X } else {
X if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
X cp = getstring(ex);
X if (strcicmp(cp, "SHARED"))
X note(format_s("Ignoring option string \"%s\" in open [183]", cp));
X } else
X note("Ignoring option string in open [183]");
X }
X }
X switch (code) {
X
X case 0: /* reset */
X strcpy(modebuf, "r");
X break;
X
X case 1: /* rewrite */
X strcpy(modebuf, "w");
X break;
X
X case 2: /* open */
X strcpy(modebuf, openmode);
X break;
X
X case 3: /* append */
X strcpy(modebuf, "a");
X break;
X
X }
X if (!*modebuf) {
X strcpy(modebuf, "r+");
X }
X if (readwriteopen == 2 ||
X (readwriteopen && fex->val.type != tp_text)) {
X if (!my_strchr(modebuf, '+'))
X strcat(modebuf, "+");
X }
X if (fex->val.type != tp_text && binarymode != 0) {
X if (binarymode == 1)
X strcat(modebuf, "b");
X else
X note("Opening a binary file [184]");
X }
X if (!nex && fmp &&
X !is_std_file(fex) &&
X (literalfilesflag == 1 ||
X strlist_cifind(literalfiles, fmp->name))) {
X nex = makeexpr_string(fmp->name);
X }
X if (!nex) {
X if (isvar(fex, mp_output)) {
X note("RESET/REWRITE ignored for file OUTPUT [319]");
X sp = NULL;
X } else {
X sp = makestmt_call(makeexpr_bicall_1("rewind", tp_void,
X copyexpr(fex)));
X if (code == 0 || is_std_file(fex)) {
X sp = wrapopencheck(sp, copyexpr(fex));
X needcheckopen = 0;
X } else
X sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex),
X makeexpr_nil()),
X sp,
X makestmt_assign(copyexpr(fex),
X makeexpr_bicall_0("tmpfile",
X tp_text)));
X }
X } else if (!strcmp(freopenname, "fclose") ||
X !strcmp(freopenname, "fopen")) {
X sp = makestmt_assign(copyexpr(fex),
X makeexpr_bicall_2("fopen", tp_text,
X copyexpr(nex),
X makeexpr_string(modebuf)));
X if (!strcmp(freopenname, "fclose")) {
X sp = makestmt_seq(makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
X makestmt_call(makeexpr_bicall_1("fclose", tp_void,
X copyexpr(fex))),
X NULL),
X sp);
X }
X } else {
X sp = makestmt_assign(copyexpr(fex),
X makeexpr_bicall_3((*freopenname) ? freopenname : "freopen",
X tp_text,
X copyexpr(nex),
X makeexpr_string(modebuf),
X copyexpr(fex)));
X if (!*freopenname) {
X sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
X sp,
X makestmt_assign(copyexpr(fex),
X makeexpr_bicall_2("fopen", tp_text,
X copyexpr(nex),
X makeexpr_string(modebuf))));
X }
X }
X if (code == 2 && !*openmode && nex) {
X sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(fex), makeexpr_nil()),
X makestmt_assign(copyexpr(fex),
X makeexpr_bicall_2("fopen", tp_text,
X copyexpr(nex),
X makeexpr_string("w+"))),
X NULL));
X }
X if (nex)
X freeexpr(nex);
X if (FCheck(checkfileopen) && needcheckopen) {
X sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
X makeexpr_name(filenotfoundname, tp_int))));
X }
X sp = makestmt_seq(spassign, sp);
X cp = (code == 0) ? resetbufname : setupbufname;
X if (*cp && fmp) /* (may be eaten later, if buffering isn't needed) */
X sp = makestmt_seq(sp,
X makestmt_call(
X makeexpr_bicall_2(cp, tp_void, fex,
X makeexpr_type(fex->val.type->basetype->basetype))));
X else
X freeexpr(fex);
X skipcloseparen();
X return sp;
X}
X
X
X
XStatic Stmt *proc_append()
X{
X return handleopen(3);
X}
X
X
X
XStatic Expr *func_arccos(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("acos", tp_longreal, grabarg(ex, 0));
X}
X
X
XStatic Expr *func_arcsin(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("asin", tp_longreal, grabarg(ex, 0));
X}
X
X
XStatic Expr *func_arctan(ex)
XExpr *ex;
X{
X ex = grabarg(ex, 0);
X if (atan2flag && ex->kind == EK_DIVIDE)
X return makeexpr_bicall_2("atan2", tp_longreal,
X ex->args[0], ex->args[1]);
X return makeexpr_bicall_1("atan", tp_longreal, ex);
X}
X
X
XStatic Expr *func_arctanh(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("atanh", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Stmt *proc_argv()
X{
X Expr *ex, *aex, *lex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (skipcomma()) {
X aex = p_expr(tp_str255);
X } else
X return NULL;
X skipcloseparen();
X lex = makeexpr_sizeof(copyexpr(aex), 0);
X aex = makeexpr_addrstr(aex);
X return makestmt_call(makeexpr_bicall_3("P_sun_argv", tp_void,
X aex, lex, makeexpr_arglong(ex, 0)));
X}
X
X
XStatic Expr *func_asr()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (skipcomma()) {
X if (signedshift == 0 || signedshift == 2) {
X ex = makeexpr_bicall_2("P_asr", ex->val.type, ex,
X p_expr(tp_unsigned));
X } else {
X ex = force_signed(ex);
X ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
X if (signedshift != 1)
X note("Assuming >> is an arithmetic shift [320]");
X }
X skipcloseparen();
X }
X return ex;
X}
X
X
XStatic Expr *func_lsl()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (skipcomma()) {
X ex = makeexpr_bin(EK_LSH, ex->val.type, ex, p_expr(tp_unsigned));
X skipcloseparen();
X }
X return ex;
X}
X
X
XStatic Expr *func_lsr()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (skipcomma()) {
X ex = force_unsigned(ex);
X ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
X skipcloseparen();
X }
X return ex;
X}
X
X
X
XStatic Expr *func_bin()
X{
X note("Using %b for binary printf format [185]");
X return handle_vax_hex(NULL, "b", 1);
X}
X
X
X
XStatic Expr *func_binary(ex)
XExpr *ex;
X{
X char *cp;
X
X ex = grabarg(ex, 0);
X if (ex->kind == EK_CONST) {
X cp = getstring(ex);
X ex = makeexpr_long(my_strtol(cp, NULL, 2));
X insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
X return ex;
X } else {
X return makeexpr_bicall_3("strtol", tp_integer,
X ex, makeexpr_nil(), makeexpr_long(2));
X }
X}
X
X
X
XStatic Expr *handle_bitsize(next)
Xint next;
X{
X Expr *ex;
X Type *type;
X int lpar;
X long psize;
X
X lpar = (curtok == TOK_LPAR);
X if (lpar)
X gettok();
X if (curtok == TOK_IDENT && curtokmeaning &&
X curtokmeaning->kind == MK_TYPE) {
X ex = makeexpr_type(curtokmeaning->type);
X gettok();
X } else
X ex = p_expr(NULL);
X type = ex->val.type;
X if (lpar)
X skipcloseparen();
X psize = 0;
X packedsize(NULL, &type, &psize, 0);
X if (psize > 0 && psize < 32 && next) {
X if (psize > 16)
X psize = 32;
X else if (psize > 8)
X psize = 16;
X else if (psize > 4)
X psize = 8;
X else if (psize > 2)
X psize = 4;
X else if (psize > 1)
X psize = 2;
X else
X psize = 1;
X }
X if (psize)
X return makeexpr_long(psize);
X else
X return makeexpr_times(makeexpr_sizeof(ex, 0),
X makeexpr_long(sizeof_char ? sizeof_char : 8));
X}
X
X
XStatic Expr *func_bitsize()
X{
X return handle_bitsize(0);
X}
X
X
XStatic Expr *func_bitnext()
X{
X return handle_bitsize(1);
X}
X
X
X
XStatic Expr *func_blockread()
X{
X Expr *ex, *ex2, *vex, *sex, *fex;
X Type *type;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X sex = p_expr(tp_integer);
X sex = doseek(copyexpr(fex),
X makeexpr_times(sex, makeexpr_long(512)))->exp1;
X } else
X sex = NULL;
X skipcloseparen();
X type = vex->val.type;
X ex = makeexpr_bicall_4("fread", tp_integer,
X makeexpr_addr(vex),
X makeexpr_long(512),
X convert_size(type, ex2, "BLOCKREAD"),
X copyexpr(fex));
X return makeexpr_comma(sex, ex);
X}
X
X
X
XStatic Expr *func_blockwrite()
X{
X Expr *ex, *ex2, *vex, *sex, *fex;
X Type *type;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X sex = p_expr(tp_integer);
X sex = doseek(copyexpr(fex),
X makeexpr_times(sex, makeexpr_long(512)))->exp1;
X } else
X sex = NULL;
X skipcloseparen();
X type = vex->val.type;
X ex = makeexpr_bicall_4("fwrite", tp_integer,
X makeexpr_addr(vex),
X makeexpr_long(512),
X convert_size(type, ex2, "BLOCKWRITE"),
X copyexpr(fex));
X return makeexpr_comma(sex, ex);
X}
X
X
X
X
XStatic Stmt *proc_blockread()
X{
X Expr *ex, *ex2, *vex, *rex, *fex;
X Type *type;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X rex = p_expr(tp_integer);
X } else
X rex = NULL;
X skipcloseparen();
X type = vex->val.type;
X if (rex) {
X ex = makeexpr_bicall_4("fread", tp_integer,
X makeexpr_addr(vex),
X makeexpr_long(1),
X convert_size(type, ex2, "BLOCKREAD"),
X copyexpr(fex));
X ex = makeexpr_assign(rex, ex);
X if (!iocheck_flag)
X ex = makeexpr_comma(ex,
X makeexpr_assign(makeexpr_var(mp_ioresult),
X makeexpr_long(0)));
X } else {
X ex = makeexpr_bicall_4("fread", tp_integer,
X makeexpr_addr(vex),
X convert_size(type, ex2, "BLOCKREAD"),
X makeexpr_long(1),
X copyexpr(fex));
X if (checkeof(fex)) {
X ex = makeexpr_bicall_2(name_SETIO, tp_void,
X makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
X makeexpr_name(endoffilename, tp_int));
X }
X }
X return wrapopencheck(makestmt_call(ex), fex);
X}
X
X
X
X
XStatic Stmt *proc_blockwrite()
X{
X Expr *ex, *ex2, *vex, *rex, *fex;
X Type *type;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X rex = p_expr(tp_integer);
X } else
X rex = NULL;
X skipcloseparen();
X type = vex->val.type;
X if (rex) {
X ex = makeexpr_bicall_4("fwrite", tp_integer,
X makeexpr_addr(vex),
X makeexpr_long(1),
X convert_size(type, ex2, "BLOCKWRITE"),
X copyexpr(fex));
X ex = makeexpr_assign(rex, ex);
X if (!iocheck_flag)
X ex = makeexpr_comma(ex,
X makeexpr_assign(makeexpr_var(mp_ioresult),
X makeexpr_long(0)));
X } else {
X ex = makeexpr_bicall_4("fwrite", tp_integer,
X makeexpr_addr(vex),
X convert_size(type, ex2, "BLOCKWRITE"),
X makeexpr_long(1),
X copyexpr(fex));
X if (FCheck(checkfilewrite)) {
X ex = makeexpr_bicall_2(name_SETIO, tp_void,
X makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
X makeexpr_name(filewriteerrorname, tp_int));
X }
X }
X return wrapopencheck(makestmt_call(ex), fex);
X}
X
X
X
XStatic Stmt *proc_bclr()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X skipcloseparen();
X return makestmt_assign(ex,
X makeexpr_bin(EK_BAND, ex->val.type,
X copyexpr(ex),
X makeexpr_un(EK_BNOT, ex->val.type,
X makeexpr_bin(EK_LSH, tp_integer,
X makeexpr_arglong(
X makeexpr_long(1), 1),
X ex2))));
X}
X
X
X
XStatic Stmt *proc_bset()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X skipcloseparen();
X return makestmt_assign(ex,
X makeexpr_bin(EK_BOR, ex->val.type,
X copyexpr(ex),
X makeexpr_bin(EK_LSH, tp_integer,
X makeexpr_arglong(
X makeexpr_long(1), 1),
X ex2)));
X}
X
X
X
XStatic Expr *func_bsl()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X skipcloseparen();
X return makeexpr_bin(EK_LSH, tp_integer, ex, ex2);
X}
X
X
X
XStatic Expr *func_bsr()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X skipcloseparen();
X return makeexpr_bin(EK_RSH, tp_integer, force_unsigned(ex), ex2);
X}
X
X
X
XStatic Expr *func_btst()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X skipcloseparen();
X return makeexpr_rel(EK_NE,
X makeexpr_bin(EK_BAND, tp_integer,
X ex,
X makeexpr_bin(EK_LSH, tp_integer,
X makeexpr_arglong(
X makeexpr_long(1), 1),
X ex2)),
X makeexpr_long(0));
X}
X
X
X
XStatic Expr *func_byteread()
X{
X Expr *ex, *ex2, *vex, *sex, *fex;
X Type *type;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X sex = p_expr(tp_integer);
X sex = doseek(copyexpr(fex), sex)->exp1;
X } else
X sex = NULL;
X skipcloseparen();
X type = vex->val.type;
X ex = makeexpr_bicall_4("fread", tp_integer,
X makeexpr_addr(vex),
X makeexpr_long(1),
X convert_size(type, ex2, "BYTEREAD"),
X copyexpr(fex));
X return makeexpr_comma(sex, ex);
X}
X
X
X
XStatic Expr *func_bytewrite()
X{
X Expr *ex, *ex2, *vex, *sex, *fex;
X Type *type;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X sex = p_expr(tp_integer);
X sex = doseek(copyexpr(fex), sex)->exp1;
X } else
X sex = NULL;
X skipcloseparen();
X type = vex->val.type;
X ex = makeexpr_bicall_4("fwrite", tp_integer,
X makeexpr_addr(vex),
X makeexpr_long(1),
X convert_size(type, ex2, "BYTEWRITE"),
X copyexpr(fex));
X return makeexpr_comma(sex, ex);
X}
X
X
X
XStatic Expr *func_byte_offset()
X{
X Type *tp;
X Meaning *mp;
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X tp = p_type(NULL);
X if (!skipcomma())
X return NULL;
X if (!wexpecttok(TOK_IDENT))
X return NULL;
X mp = curtoksym->fbase;
X while (mp && mp->rectype != tp)
X mp = mp->snext;
X if (!mp)
X ex = makeexpr_name(curtokcase, tp_integer);
X else
X ex = makeexpr_name(mp->name, tp_integer);
X gettok();
X skipcloseparen();
X return makeexpr_bicall_2("OFFSETOF", (size_t_long) ? tp_integer : tp_int,
X makeexpr_type(tp), ex);
X}
X
X
X
XStatic Stmt *proc_call()
X{
X Expr *ex, *ex2, *ex3;
X Type *type, *tp;
X Meaning *mp;
X
X if (!skipopenparen())
X return NULL;
X ex2 = p_expr(tp_proc);
X type = ex2->val.type;
X if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
X warning("CALL requires a procedure variable [208]");
X type = tp_proc;
X }
X ex = makeexpr(EK_SPCALL, 1);
X ex->val.type = tp_void;
X ex->args[0] = copyexpr(ex2);
X if (type->escale != 0)
X ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
X makepointertype(type->basetype));
X mp = type->basetype->fbase;
X if (mp) {
X if (wneedtok(TOK_COMMA))
X ex = p_funcarglist(ex, mp, 0, 0);
X }
X skipcloseparen();
X if (type->escale != 1 || hasstaticlinks == 2) {
X freeexpr(ex2);
X return makestmt_call(ex);
X }
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 = type->basetype->basetype;
X tp->fbase = type->basetype->fbase;
X tp->issigned = 1;
X ex3->args[0]->val.type = makepointertype(tp);
X return makestmt_if(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
X makestmt_call(ex3),
X makestmt_call(ex));
X}
X
X
X
XStatic Expr *func_chr()
X{
X Expr *ex;
X
X ex = p_expr(tp_integer);
X if ((exprlongness(ex) < 0 || ex->kind == EK_CAST) && ex->kind != EK_ACTCAST)
X ex->val.type = tp_char;
X else
X ex = makeexpr_cast(ex, tp_char);
X return ex;
X}
X
X
X
XStatic Stmt *proc_close()
X{
X Stmt *sp;
X Expr *fex, *ex;
X char *opt;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
X makestmt_call(makeexpr_bicall_1("fclose", tp_void,
X copyexpr(fex))),
X (FCheck(checkfileisopen))
X ? makestmt_call(
X makeexpr_bicall_1(name_ESCIO,
X tp_integer,
X makeexpr_name(filenotopenname,
X tp_int)))
X : NULL);
X if (curtok == TOK_COMMA) {
X gettok();
X opt = "";
X if (curtok == TOK_IDENT &&
X (!strcicmp(curtokbuf, "LOCK") ||
X !strcicmp(curtokbuf, "PURGE") ||
X !strcicmp(curtokbuf, "NORMAL") ||
X !strcicmp(curtokbuf, "CRUNCH"))) {
X opt = stralloc(curtokbuf);
X gettok();
X } else {
X ex = p_expr(tp_str255);
X if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING)
X opt = ex->val.s;
X }
X if (!strcicmp(opt, "PURGE")) {
X note("File is being closed with PURGE option [186]");
X }
X }
X sp = makestmt_seq(sp, makestmt_assign(fex, makeexpr_nil()));
X skipcloseparen();
X return sp;
X}
X
X
X
XStatic Expr *func_concat()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return makeexpr_string("oops");
X ex = p_expr(tp_str255);
X while (curtok == TOK_COMMA) {
X gettok();
X ex = makeexpr_concat(ex, p_expr(tp_str255), 0);
X }
X skipcloseparen();
X return ex;
X}
X
X
X
XStatic Expr *func_copy(ex)
XExpr *ex;
X{
X if (isliteralconst(ex->args[3], NULL) == 2 &&
X ex->args[3]->val.i >= stringceiling) {
X return makeexpr_bicall_3("sprintf", ex->val.type,
X ex->args[0],
X makeexpr_string("%s"),
X bumpstring(ex->args[1],
X makeexpr_unlongcast(ex->args[2]), 1));
X }
X if (checkconst(ex->args[2], 1)) {
X return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1],
X ex->args[2], ex->args[3]));
X }
X return makeexpr_bicall_4(strsubname, ex->val.type,
X ex->args[0],
X ex->args[1],
X makeexpr_arglong(ex->args[2], 0),
X makeexpr_arglong(ex->args[3], 0));
X}
X
X
X
XStatic Expr *func_cos(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("cos", tp_longreal, grabarg(ex, 0));
X}
X
X
XStatic Expr *func_cosh(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("cosh", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Stmt *proc_cycle()
X{
X return makestmt(SK_CONTINUE);
X}
X
X
X
XStatic Stmt *proc_dec()
X{
X Expr *vex, *ex;
X
X if (!skipopenparen())
X return NULL;
X vex = p_expr(NULL);
X if (curtok == TOK_COMMA) {
X gettok();
X ex = p_expr(tp_integer);
X } else
X ex = makeexpr_long(1);
X skipcloseparen();
X return makestmt_assign(vex, makeexpr_minus(copyexpr(vex), ex));
X}
X
X
X
XStatic Expr *func_dec()
X{
X return handle_vax_hex(NULL, "d", 0);
X}
X
X
X
XStatic Stmt *proc_delete(ex)
XExpr *ex;
X{
X if (ex->nargs == 1) /* Kludge for Oregon Software Pascal's delete(f) */
X return makestmt_call(makeexpr_bicall_1(strdeletename, tp_void, ex->args[0]));
X return makestmt_call(makeexpr_bicall_3(strdeletename, tp_void,
X ex->args[0],
X makeexpr_arglong(ex->args[1], 0),
X makeexpr_arglong(ex->args[2], 0)));
X}
X
X
X
Xvoid parse_special_variant(tp, buf)
XType *tp;
Xchar *buf;
X{
X char *cp;
X Expr *ex;
X
X if (!tp)
X intwarning("parse_special_variant", "tp == NULL");
X if (!tp || tp->meaning == NULL) {
X *buf = 0;
X if (curtok == TOK_COMMA) {
X skiptotoken(TOK_RPAR);
X }
X return;
X }
X strcpy(buf, tp->meaning->name);
X while (curtok == TOK_COMMA) {
X gettok();
X cp = buf + strlen(buf);
X *cp++ = '.';
X if (curtok == TOK_MINUS) {
X *cp++ = '-';
X gettok();
X }
X if (curtok == TOK_INTLIT ||
X curtok == TOK_HEXLIT ||
X curtok == TOK_OCTLIT) {
X sprintf(cp, "%ld", curtokint);
X gettok();
X } else if (curtok == TOK_HAT || curtok == TOK_STRLIT) {
X ex = makeexpr_charcast(accumulate_strlit());
X if (ex->kind == EK_CONST) {
X if (ex->val.i <= 32 || ex->val.i > 126 ||
X ex->val.i == '\'' || ex->val.i == '\\' ||
X ex->val.i == '=' || ex->val.i == '}')
X sprintf(cp, "%ld", ex->val.i);
X else
X strcpy(cp, makeCchar(ex->val.i));
X } else {
X *buf = 0;
X *cp = 0;
X }
X freeexpr(ex);
X } else {
X if (!wexpecttok(TOK_IDENT)) {
X skiptotoken(TOK_RPAR);
X return;
X }
X if (curtokmeaning)
X strcpy(cp, curtokmeaning->name);
X else
X strcpy(cp, curtokbuf);
X gettok();
X }
X }
X}
X
X
Xchar *find_special_variant(buf, spname, splist, need)
Xchar *buf, *spname;
XStrlist *splist;
Xint need;
X{
X Strlist *best = NULL;
X int len, bestlen = -1;
X char *cp, *cp2;
X
X if (!*buf)
X return NULL;
X while (splist) {
X cp = splist->s;
X cp2 = buf;
X while (*cp && toupper(*cp) == toupper(*cp2))
X cp++, cp2++;
X len = cp2 - buf;
X if (!*cp && (!*cp2 || *cp2 == '.') && len > bestlen) {
X best = splist;
X bestlen = len;
X }
X splist = splist->next;
X }
X if (bestlen != strlen(buf) && my_strchr(buf, '.')) {
X if ((need & 1) || bestlen >= 0) {
X if (need & 2)
X return NULL;
X if (spname)
X note(format_ss("No %s form known for %s [187]",
X spname, strupper(buf)));
X }
X }
X if (bestlen >= 0)
X return (char *)best->value;
X else
X return NULL;
X}
X
X
X
XStatic char *choose_free_func(ex)
XExpr *ex;
X{
X if (!*freename) {
X if (!*freervaluename)
X return "free";
X else
X return freervaluename;
X }
X if (!*freervaluename)
X return freervaluename;
X if (expr_is_lvalue(ex))
X return freename;
X else
X return freervaluename;
X}
X
X
XStatic Stmt *proc_dispose()
X{
X Expr *ex;
X Type *type;
X char *name, vbuf[1000];
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_anyptr);
X type = ex->val.type->basetype;
X parse_special_variant(type, vbuf);
X skipcloseparen();
X name = find_special_variant(vbuf, "SpecialFree", specialfrees, 0);
X if (!name)
X name = choose_free_func(ex);
X return makestmt_call(makeexpr_bicall_1(name, tp_void, ex));
X}
X
X
X
XStatic Expr *func_exp(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("exp", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_expo(ex)
XExpr *ex;
X{
X Meaning *tvar;
X
X tvar = makestmttempvar(tp_int, name_TEMP);
X return makeexpr_comma(makeexpr_bicall_2("frexp", tp_longreal,
X grabarg(ex, 0),
X makeexpr_addr(makeexpr_var(tvar))),
X makeexpr_var(tvar));
X}
X
X
X
Xint is_std_file(ex)
XExpr *ex;
X{
X return isvar(ex, mp_input) || isvar(ex, mp_output) ||
X isvar(ex, mp_stderr);
X}
X
X
X
XStatic Expr *iofunc(ex, code)
XExpr *ex;
Xint code;
X{
X Expr *ex2 = NULL, *ex3 = NULL;
X Meaning *tvar = NULL;
X
X if (FCheck(checkfileisopen) && !is_std_file(ex)) {
X if (exprspeed(ex) < 5 && nosideeffects(ex, 0)) {
X ex2 = copyexpr(ex);
X } else {
X ex3 = ex;
X tvar = makestmttempvar(ex->val.type, name_TEMP);
X ex2 = makeexpr_var(tvar);
X ex = makeexpr_var(tvar);
X }
X }
X switch (code) {
X
X case 0: /* eof */
X if (*eofname)
X ex = makeexpr_bicall_1(eofname, tp_boolean, ex);
X else
X ex = makeexpr_rel(EK_NE, makeexpr_bicall_1("feof", tp_int, ex),
X makeexpr_long(0));
X break;
X
X case 1: /* eoln */
X ex = makeexpr_bicall_1(eolnname, tp_boolean, ex);
X break;
X
X case 2: /* position or filepos */
X ex = makeexpr_bicall_1(fileposname, tp_integer, ex);
X break;
X
X case 3: /* maxpos or filesize */
X ex = makeexpr_bicall_1(maxposname, tp_integer, ex);
X break;
X
X }
X if (ex2) {
X ex = makeexpr_bicall_4("~CHKIO",
X (code == 0 || code == 1) ? tp_boolean : tp_integer,
X makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
X makeexpr_name("FileNotOpen", tp_int),
X ex, makeexpr_long(0));
X }
X if (ex3)
X ex = makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex3), ex);
X return ex;
X}
X
X
X
XStatic Expr *func_eof()
X{
X Expr *ex;
X
X if (curtok == TOK_LPAR)
X ex = p_parexpr(tp_text);
X else
X ex = makeexpr_var(mp_input);
X return iofunc(ex, 0);
X}
X
X
X
XStatic Expr *func_eoln()
X{
X Expr *ex;
X
X if (curtok == TOK_LPAR)
X ex = p_parexpr(tp_text);
X else
X ex = makeexpr_var(mp_input);
X return iofunc(ex, 1);
X}
X
X
X
XStatic Stmt *proc_escape()
X{
X Expr *ex;
X
X if (curtok == TOK_LPAR)
X ex = p_parexpr(tp_integer);
X else
X ex = makeexpr_long(0);
X return makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int,
X makeexpr_arglong(ex, 0)));
X}
X
X
X
XStatic Stmt *proc_excl()
X{
X Expr *vex, *ex;
X
X if (!skipopenparen())
X return NULL;
X vex = p_expr(NULL);
X if (!skipcomma())
X return NULL;
X ex = p_expr(vex->val.type->indextype);
X skipcloseparen();
X if (vex->val.type->kind == TK_SMALLSET)
X return makestmt_assign(vex, makeexpr_bin(EK_BAND, vex->val.type,
X copyexpr(vex),
X makeexpr_un(EK_BNOT, vex->val.type,
X makeexpr_bin(EK_LSH, vex->val.type,
X makeexpr_longcast(makeexpr_long(1), 1),
X ex))));
X else
X return makestmt_call(makeexpr_bicall_2(setremname, tp_void, vex,
X makeexpr_arglong(enum_to_int(ex), 0)));
X}
X
X
X
XStmt *proc_exit()
X{
X Stmt *sp;
X
X if (modula2) {
X return makestmt(SK_BREAK);
X }
X if (curtok == TOK_LPAR) {
X gettok();
X if (curtok == TOK_PROGRAM ||
X (curtok == TOK_IDENT && curtokmeaning->kind == MK_MODULE)) {
X gettok();
X skipcloseparen();
X return makestmt_call(makeexpr_bicall_1("exit", tp_void,
X makeexpr_long(0)));
X }
X if (curtok != TOK_IDENT || !curtokmeaning || curtokmeaning != curctx)
X note("Attempting to EXIT beyond this function [188]");
X gettok();
X skipcloseparen();
X }
X sp = makestmt(SK_RETURN);
X if (curctx->kind == MK_FUNCTION && curctx->isfunction) {
X sp->exp1 = makeexpr_var(curctx->cbase);
X curctx->cbase->refcount++;
X }
X return sp;
X}
X
X
X
XStatic Expr *file_iofunc(code, base)
Xint code;
Xlong base;
X{
X Expr *ex;
X Type *basetype;
X
X if (curtok == TOK_LPAR)
X ex = p_parexpr(tp_text);
X else
X ex = makeexpr_var(mp_input);
X if (!ex->val.type || !ex->val.type->basetype ||
X !ex->val.type->basetype->basetype)
X basetype = tp_char;
X else
X basetype = ex->val.type->basetype->basetype;
X return makeexpr_plus(makeexpr_div(iofunc(ex, code),
X makeexpr_sizeof(makeexpr_type(basetype), 0)),
X makeexpr_long(base));
X}
X
X
X
XStatic Expr *func_fcall()
X{
X Expr *ex, *ex2, *ex3;
X Type *type, *tp;
X Meaning *mp, *tvar = NULL;
X int firstarg = 0;
X
X if (!skipopenparen())
X return NULL;
X ex2 = p_expr(tp_proc);
X type = ex2->val.type;
X if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
X warning("FCALL requires a function variable [209]");
X type = tp_proc;
X }
X ex = makeexpr(EK_SPCALL, 1);
X ex->val.type = type->basetype->basetype;
X ex->args[0] = copyexpr(ex2);
X if (type->escale != 0)
X ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
X makepointertype(type->basetype));
X mp = type->basetype->fbase;
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 firstarg++;
X }
X if (mp) {
X if (wneedtok(TOK_COMMA))
X ex = p_funcarglist(ex, mp, 0, 0);
X }
X if (tvar)
X ex = makeexpr_hat(ex, 0); /* returns pointer to structured result */
X skipcloseparen();
X if (type->escale != 1 || hasstaticlinks == 2) {
X freeexpr(ex2);
X return ex;
X }
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 = type->basetype->basetype;
X tp->fbase = type->basetype->fbase;
X tp->issigned = 1;
X ex3->args[0]->val.type = makepointertype(tp);
X return makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
X ex3, ex);
X}
X
X
X
XStatic Expr *func_filepos()
X{
X return file_iofunc(2, seek_base);
X}
X
X
X
XStatic Expr *func_filesize()
X{
X return file_iofunc(3, 1L);
X}
X
X
X
XStatic Stmt *proc_fillchar()
X{
X Expr *vex, *ex, *cex;
X
X if (!skipopenparen())
X return NULL;
X vex = gentle_cast(makeexpr_addr(p_expr(NULL)), tp_anyptr);
X if (!skipcomma())
X return NULL;
X ex = convert_size(argbasetype(vex), p_expr(tp_integer), "FILLCHAR");
X if (!skipcomma())
X return NULL;
X cex = makeexpr_charcast(p_expr(tp_integer));
X skipcloseparen();
X return makestmt_call(makeexpr_bicall_3("memset", tp_void,
X vex,
X makeexpr_arglong(cex, 0),
X makeexpr_arglong(ex, (size_t_long != 0))));
X}
X
X
X
XStatic Expr *func_sngl()
X{
X Expr *ex;
X
X ex = p_parexpr(tp_real);
X return makeexpr_cast(ex, tp_real);
X}
X
X
X
XStatic Expr *func_float()
X{
X Expr *ex;
X
X ex = p_parexpr(tp_longreal);
X return makeexpr_cast(ex, tp_longreal);
X}
X
X
X
XStatic Stmt *proc_flush()
X{
X Expr *ex;
X Stmt *sp;
X
X ex = p_parexpr(tp_text);
X sp = makestmt_call(makeexpr_bicall_1("fflush", tp_void, ex));
X if (iocheck_flag)
X sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(mp_ioresult),
X makeexpr_long(0)));
X return sp;
X}
X
X
X
XStatic Expr *func_frac(ex)
XExpr *ex;
X{
X Meaning *tvar;
X
X tvar = makestmttempvar(tp_longreal, name_DUMMY);
X return makeexpr_bicall_2("modf", tp_longreal,
X grabarg(ex, 0),
X makeexpr_addr(makeexpr_var(tvar)));
X}
X
X
X
XStatic Stmt *proc_freemem(ex)
XExpr *ex;
X{
X Stmt *sp;
X Expr *vex;
X
X vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
X sp = makestmt_call(makeexpr_bicall_1(choose_free_func(vex),
X tp_void, copyexpr(vex)));
X if (alloczeronil) {
X sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
X sp, NULL);
X } else
X freeexpr(vex);
X return sp;
X}
X
X
X
XStatic Stmt *proc_get()
X{
X Expr *ex;
X Type *type;
X
X if (curtok == TOK_LPAR)
X ex = p_parexpr(tp_text);
X else
X ex = makeexpr_var(mp_input);
X requirefilebuffer(ex);
X type = ex->val.type;
X if (isfiletype(type) && *chargetname &&
X type->basetype->basetype->kind == TK_CHAR)
X return makestmt_call(makeexpr_bicall_1(chargetname, tp_void, ex));
X else if (isfiletype(type) && *arraygetname &&
X type->basetype->basetype->kind == TK_ARRAY)
X return makestmt_call(makeexpr_bicall_2(arraygetname, tp_void, ex,
X makeexpr_type(type->basetype->basetype)));
X else
END_OF_FILE
if test 48548 -ne `wc -c <'src/funcs.c.1'`; then
echo shar: \"'src/funcs.c.1'\" unpacked with wrong size!
fi
# end of 'src/funcs.c.1'
fi
echo shar: End of archive 21 \(of 32\).
cp /dev/null ark21isdone
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
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list