rsalz@uunet.uu.net (Rich Salz) (03/29/90)
Submitted-by: Dave Gillespie <daveg@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@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@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@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.