rsalz@uunet.uu.net (Rich Salz) (03/28/90)
Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu>
Posting-number: Volume 21, Issue 62
Archive-name: p2c/part17
#! /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 17 (of 32)."
# Contents: src/funcs.c.3
# Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:39 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/funcs.c.3' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'src/funcs.c.3'\"
else
echo shar: Extracting \"'src/funcs.c.3'\" \(42271 characters\)
sed "s/^X//" >'src/funcs.c.3' <<'END_OF_FILE'
X ex2 = p_expr(tp_str255);
X skipcloseparen();
X return makestmt_assign(ex, makeexpr_concat(copyexpr(ex), ex2, 0));
X}
X
X
X
XStatic Stmt *proc_strdelete()
X{
X Meaning *tvar = NULL, *tvari;
X Expr *ex, *ex2, *ex3, *ex4, *exi, *exn;
X Stmt *sp;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X exi = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X exn = p_expr(tp_integer);
X } else
X exn = makeexpr_long(1);
X skipcloseparen();
X if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
X sp = NULL;
X else {
X tvari = makestmttempvar(tp_int, name_TEMP);
X sp = makestmt_assign(makeexpr_var(tvari), exi);
X exi = makeexpr_var(tvari);
X }
X ex3 = bumpstring(copyexpr(ex), copyexpr(exi), 1);
X ex4 = bumpstring(copyexpr(ex), makeexpr_plus(exi, exn), 1);
X if (strcpyleft) {
X ex2 = ex3;
X } else {
X tvar = makestmttempvar(tp_str255, name_STRING);
X ex2 = makeexpr_var(tvar);
X }
X sp = makestmt_seq(sp, makestmt_assign(ex2, ex4));
X if (!strcpyleft)
X sp = makestmt_seq(sp, makestmt_assign(ex3, makeexpr_var(tvar)));
X return sp;
X}
X
X
X
XStatic Stmt *proc_strinsert()
X{
X Meaning *tvari;
X Expr *exs, *exd, *exi;
X Stmt *sp;
X
X if (!skipopenparen())
X return NULL;
X exs = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X exd = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X exi = p_expr(tp_integer);
X skipcloseparen();
X#if 0
X if (checkconst(exi, 1)) {
X freeexpr(exi);
X return makestmt_assign(exd,
X makeexpr_concat(exs, copyexpr(exd)));
X }
X#endif
X if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
X sp = NULL;
X else {
X tvari = makestmttempvar(tp_int, name_TEMP);
X sp = makestmt_assign(makeexpr_var(tvari), exi);
X exi = makeexpr_var(tvari);
X }
X exd = bumpstring(exd, exi, 1);
X sp = makestmt_seq(sp, makestmt_assign(exd,
X makeexpr_concat(exs, copyexpr(exd), 0)));
X return sp;
X}
X
X
X
XStatic Stmt *proc_strmove()
X{
X Expr *exlen, *exs, *exsi, *exd, *exdi;
X
X if (!skipopenparen())
X return NULL;
X exlen = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X exs = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X exsi = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X exd = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X exdi = p_expr(tp_integer);
X skipcloseparen();
X exsi = makeexpr_arglong(exsi, 0);
X exdi = makeexpr_arglong(exdi, 0);
X return makestmt_call(makeexpr_bicall_5(strmovename, tp_str255,
X exlen, exs, exsi, exd, exdi));
X}
X
X
X
XStatic Expr *func_strlen(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("strlen", tp_int, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_strltrim(ex)
XExpr *ex;
X{
X return makeexpr_assign(makeexpr_hat(ex->args[0], 0),
X makeexpr_bicall_1(strltrimname, tp_str255, ex->args[1]));
X}
X
X
X
XStatic Expr *func_strmax(ex)
XExpr *ex;
X{
X return strmax_func(grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_strpos(ex)
XExpr *ex;
X{
X char *cp;
X
X if (!switch_strpos)
X swapexprs(ex->args[0], ex->args[1]);
X cp = strposname;
X if (!*cp) {
X note("STRPOS function used [201]");
X cp = "STRPOS";
X }
X return makeexpr_bicall_3(cp, tp_int,
X ex->args[0],
X ex->args[1],
X makeexpr_long(1));
X}
X
X
X
XStatic Expr *func_strrpt(ex)
XExpr *ex;
X{
X if (ex->args[1]->kind == EK_CONST &&
X ex->args[1]->val.i == 1 && ex->args[1]->val.s[0] == ' ') {
X return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
X makeexpr_string("%*s"),
X makeexpr_longcast(ex->args[2], 0),
X makeexpr_string(""));
X } else
X return makeexpr_bicall_3(strrptname, tp_strptr, ex->args[0], ex->args[1],
X makeexpr_arglong(ex->args[2], 0));
X}
X
X
X
XStatic Expr *func_strrtrim(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1(strrtrimname, tp_strptr,
X makeexpr_assign(makeexpr_hat(ex->args[0], 0),
X ex->args[1]));
X}
X
X
X
XStatic Expr *func_succ()
X{
X Expr *ex;
X
X if (wneedtok(TOK_LPAR)) {
X ex = p_ord_expr();
X skipcloseparen();
X } else
X ex = p_ord_expr();
X#if 1
X ex = makeexpr_inc(ex, makeexpr_long(1));
X#else
X ex = makeexpr_cast(makeexpr_plus(ex, makeexpr_long(1)), ex->val.type);
X#endif
X return ex;
X}
X
X
X
XStatic Expr *func_sqr()
X{
X return makeexpr_sqr(p_parexpr(tp_integer), 0);
X}
X
X
X
XStatic Expr *func_sqrt(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("sqrt", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_swap(ex)
XExpr *ex;
X{
X char *cp;
X
X ex = grabarg(ex, 0);
X cp = swapname;
X if (!*cp) {
X note("SWAP function was used [202]");
X cp = "SWAP";
X }
X return makeexpr_bicall_1(swapname, tp_int, ex);
X}
X
X
X
XStatic Expr *func_tan(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("tan", tp_longreal, grabarg(ex, 0));
X}
X
X
XStatic Expr *func_tanh(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("tanh", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_trunc(ex)
XExpr *ex;
X{
X return makeexpr_actcast(grabarg(ex, 0), tp_integer);
X}
X
X
X
XStatic Expr *func_utrunc(ex)
XExpr *ex;
X{
X return makeexpr_actcast(grabarg(ex, 0), tp_unsigned);
X}
X
X
X
XStatic Expr *func_uand()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_unsigned);
X if (skipcomma()) {
X ex = makeexpr_bin(EK_BAND, ex->val.type, ex, p_expr(tp_unsigned));
X skipcloseparen();
X }
X return ex;
X}
X
X
X
XStatic Expr *func_udec()
X{
X return handle_vax_hex(NULL, "u", 0);
X}
X
X
X
XStatic Expr *func_unot()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_unsigned);
X ex = makeexpr_un(EK_BNOT, ex->val.type, ex);
X skipcloseparen();
X return ex;
X}
X
X
X
XStatic Expr *func_uor()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_unsigned);
X if (skipcomma()) {
X ex = makeexpr_bin(EK_BOR, ex->val.type, ex, p_expr(tp_unsigned));
X skipcloseparen();
X }
X return ex;
X}
X
X
X
XStatic Expr *func_upcase(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("toupper", tp_char, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_upper()
X{
X Expr *ex;
X Value val;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (curtok == TOK_COMMA) {
X gettok();
X val = p_constant(tp_integer);
X if (!val.type || val.i != 1)
X note("UPPER(v,n) not supported for n>1 [190]");
X }
X skipcloseparen();
X return copyexpr(ex->val.type->indextype->smax);
X}
X
X
X
XStatic Expr *func_uxor()
X{
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_unsigned);
X if (skipcomma()) {
X ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, p_expr(tp_unsigned));
X skipcloseparen();
X }
X return ex;
X}
X
X
X
XStatic Expr *func_val_modula()
X{
X Expr *ex;
X Type *tp;
X
X if (!skipopenparen())
X return NULL;
X tp = p_type(NULL);
X if (!skipcomma())
X return NULL;
X ex = p_expr(tp);
X skipcloseparen();
X return pascaltypecast(tp, ex);
X}
X
X
X
XStatic Stmt *proc_val_turbo()
X{
X Expr *ex, *vex, *code, *fmt;
X
X if (!skipopenparen())
X return NULL;
X ex = gentle_cast(p_expr(tp_str255), tp_str255);
X if (!skipcomma())
X return NULL;
X vex = p_expr(NULL);
X if (curtok == TOK_COMMA) {
X gettok();
X code = gentle_cast(p_expr(tp_integer), tp_integer);
X } else
X code = NULL;
X skipcloseparen();
X if (vex->val.type->kind == TK_REAL)
X fmt = makeexpr_string("%lg");
X else if (exprlongness(vex) > 0)
X fmt = makeexpr_string("%ld");
X else
X fmt = makeexpr_string("%d");
X ex = makeexpr_bicall_3("sscanf", tp_int,
X ex, fmt, makeexpr_addr(vex));
X if (code) {
X ex = makeexpr_rel(EK_EQ, ex, makeexpr_long(0));
X return makestmt_assign(code, makeexpr_ord(ex));
X } else
X return makestmt_call(ex);
X}
X
X
X
X
X
X
X
XStatic Expr *writestrelement(ex, wid, vex, code, needboth)
XExpr *ex, *wid, *vex;
Xint code, needboth;
X{
X if (formatstrings && needboth) {
X return makeexpr_bicall_5("sprintf", tp_str255, vex,
X makeexpr_string(format_d("%%*.*%c", code)),
X copyexpr(wid),
X wid,
X ex);
X } else {
X return makeexpr_bicall_4("sprintf", tp_str255, vex,
X makeexpr_string(format_d("%%*%c", code)),
X wid,
X ex);
X }
X}
X
X
X
XStatic char *makeenumnames(tp)
XType *tp;
X{
X Strlist *sp;
X char *name;
X Meaning *mp;
X int saveindent;
X
X for (sp = enumnames; sp && sp->value != (long)tp; sp = sp->next) ;
X if (!sp) {
X if (tp->meaning)
X name = format_s(name_ENUM, tp->meaning->name);
X else
X name = format_s(name_ENUM, format_d("_%d", ++enumnamecount));
X sp = strlist_insert(&enumnames, name);
X sp->value = (long)tp;
X outsection(2);
X output(format_s("Static %s *", charname));
X output(sp->s);
X output("[] = {\n");
X saveindent = outindent;
X moreindent(tabsize);
X moreindent(structinitindent);
X for (mp = tp->fbase; mp; mp = mp->xnext) {
X output(makeCstring(mp->sym->name, strlen(mp->sym->name)));
X if (mp->xnext)
X output(",\002 ");
X }
X outindent = saveindent;
X output("\n} ;\n");
X outsection(2);
X }
X return sp->s;
X}
X
X
X
X
X
X/* This function must return a "tempsprintf" */
X
XExpr *writeelement(ex, wid, prec, base)
XExpr *ex, *wid, *prec;
Xint base;
X{
X Expr *vex, *ex1, *ex2;
X Meaning *tvar;
X char *fmtcode;
X Type *type;
X
X ex = makeexpr_charcast(ex);
X if (ex->val.type->kind == TK_POINTER) {
X ex = makeexpr_hat(ex, 0); /* convert char *'s to strings */
X intwarning("writeelement", "got a char * instead of a string [214]");
X }
X if ((ex->val.type->kind == TK_STRING && !wid) ||
X (ord_type(ex->val.type)->kind == TK_CHAR && (!wid || checkconst(wid, 1)))) {
X return makeexpr_sprintfify(ex);
X }
X tvar = makestmttempvar(tp_str255, name_STRING);
X vex = makeexpr_var(tvar);
X if (wid)
X wid = makeexpr_longcast(wid, 0);
X if (prec)
X prec = makeexpr_longcast(prec, 0);
X#if 0
X if (wid && (wid->kind == EK_CONST && wid->val.i < 0 ||
X checkconst(wid, -1))) {
X freeexpr(wid); /* P-system uses write(x:-1) to mean write(x) */
X wid = NULL;
X }
X if (prec && (prec->kind == EK_CONST && prec->val.i < 0 ||
X checkconst(prec, -1))) {
X freeexpr(prec);
X prec = NULL;
X }
X#endif
X switch (ord_type(ex->val.type)->kind) {
X
X case TK_INTEGER:
X if (!wid) {
X if (integerwidth < 0)
X integerwidth = (which_lang == LANG_TURBO) ? 1 : 12;
X wid = makeexpr_long(integerwidth);
X }
X type = findbasetype(ex->val.type, 0);
X if (base == 16)
X fmtcode = "x";
X else if (base == 8)
X fmtcode = "o";
X else if ((possiblesigns(wid) & (1|4)) == 1) {
X wid = makeexpr_neg(wid);
X fmtcode = "x";
X } else if (type == tp_unsigned ||
X type == tp_uint ||
X (type == tp_ushort && sizeof_int < 32))
X fmtcode = "u";
X else
X fmtcode = "d";
X ex = makeexpr_forcelongness(ex);
X if (checkconst(wid, 0) || checkconst(wid, 1)) {
X ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
X makeexpr_string(format_ss("%%%s%s",
X (exprlongness(ex) > 0) ? "l" : "",
X fmtcode)),
X ex);
X } else {
X ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
X makeexpr_string(format_ss("%%*%s%s",
X (exprlongness(ex) > 0) ? "l" : "",
X fmtcode)),
X wid,
X ex);
X }
X break;
X
X case TK_CHAR:
X ex = writestrelement(ex, wid, vex, 'c',
X (wid->kind != EK_CONST || wid->val.i < 1));
X break;
X
X case TK_BOOLEAN:
X if (!wid) {
X ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
X makeexpr_string("%s"),
X makeexpr_cond(ex,
X makeexpr_string(" TRUE"),
X makeexpr_string("FALSE")));
X } else if (checkconst(wid, 1)) {
X ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
X makeexpr_string("%c"),
X makeexpr_cond(ex,
X makeexpr_char('T'),
X makeexpr_char('F')));
X } else {
X ex = writestrelement(makeexpr_cond(ex,
X makeexpr_string("TRUE"),
X makeexpr_string("FALSE")),
X wid, vex, 's',
X (wid->kind != EK_CONST || wid->val.i < 5));
X }
X break;
X
X case TK_ENUM:
X ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
X makeexpr_string("%s"),
X makeexpr_index(makeexpr_name(makeenumnames(ex->val.type),
X tp_strptr),
X ex, NULL));
X break;
X
X case TK_REAL:
X if (!wid)
X wid = makeexpr_long(realwidth);
X if (prec && (possiblesigns(prec) & (1|4)) != 1) {
X ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
X makeexpr_string("%*.*f"),
X wid,
X prec,
X ex);
X } else {
X if (prec)
X prec = makeexpr_neg(prec);
X else
X prec = makeexpr_minus(copyexpr(wid),
X makeexpr_long(7));
X if (prec->kind == EK_CONST) {
X if (prec->val.i <= 0)
X prec = makeexpr_long(1);
X } else {
X prec = makeexpr_bicall_2("P_max", tp_integer, prec,
X makeexpr_long(1));
X }
X if (wid->kind == EK_CONST && wid->val.i > 21) {
X ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
X makeexpr_string("%*.*E"),
X wid,
X prec,
X ex);
X#if 0
X } else if (checkconst(wid, 7)) {
X ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
X makeexpr_string("%E"),
X ex);
X#endif
X } else {
X ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
X makeexpr_string("% .*E"),
X prec,
X ex);
X }
X }
X break;
X
X case TK_STRING:
X ex = writestrelement(ex, wid, vex, 's', 1);
X break;
X
X case TK_ARRAY: /* assume packed array of char */
X ord_range_expr(ex->val.type->indextype, &ex1, &ex2);
X ex1 = makeexpr_plus(makeexpr_minus(copyexpr(ex2),
X copyexpr(ex1)),
X makeexpr_long(1));
X ex1 = makeexpr_longcast(ex1, 0);
X fmtcode = "%.*s";
X if (!wid) {
X wid = ex1;
X } else {
X if (isliteralconst(wid, NULL) == 2 &&
X isliteralconst(ex1, NULL) == 2) {
X if (wid->val.i > ex1->val.i) {
X fmtcode = format_ds("%*s%%.*s",
X wid->val.i - ex1->val.i, "");
X wid = ex1;
X }
X } else
X note("Format for packed-array-of-char will work only if width < length [321]");
X }
X ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
X makeexpr_string(fmtcode),
X wid,
X makeexpr_addr(ex));
X break;
X
X default:
X note("Element has wrong type for WRITE statement [196]");
X ex = makeexpr_bicall_2("sprintf", tp_str255, vex, makeexpr_string("<meef>"));
X break;
X
X }
X return ex;
X}
X
X
X
XStatic Stmt *handlewrite_text(fex, ex, iswriteln)
XExpr *fex, *ex;
Xint iswriteln;
X{
X Expr *print, *wid, *prec;
X unsigned char *ucp;
X int i, done, base;
X
X print = NULL;
X for (;;) {
X wid = NULL;
X prec = NULL;
X base = 10;
X if (curtok == TOK_COLON && iswriteln >= 0) {
X gettok();
X wid = p_expr(tp_integer);
X if (curtok == TOK_COLON) {
X gettok();
X prec = p_expr(tp_integer);
X }
X }
X if (curtok == TOK_IDENT &&
X !strcicmp(curtokbuf, "OCT")) {
X base = 8;
X gettok();
X } else if (curtok == TOK_IDENT &&
X !strcicmp(curtokbuf, "HEX")) {
X base = 16;
X gettok();
X }
X ex = writeelement(ex, wid, prec, base);
X print = makeexpr_concat(print, cleansprintf(ex), 1);
X if (curtok == TOK_COMMA && iswriteln >= 0) {
X gettok();
X ex = p_expr(NULL);
X } else
X break;
X }
X if (fex->val.type->kind != TK_STRING) { /* not strwrite */
X switch (iswriteln) {
X case 1:
X case -1:
X print = makeexpr_concat(print, makeexpr_string("\n"), 1);
X break;
X case 2:
X case -2:
X print = makeexpr_concat(print, makeexpr_string("\r"), 1);
X break;
X }
X if (isvar(fex, mp_output)) {
X ucp = (unsigned char *)print->args[1]->val.s;
X for (i = 0; i < print->args[1]->val.i; i++) {
X if (ucp[i] >= 128 && ucp[i] < 144) {
X note("WRITE statement contains color/attribute characters [203]");
X break;
X }
X }
X }
X if ((i = sprintflength(print, 0)) > 0 && print->nargs == 2 && printfonly != 1) {
X print = makeexpr_unsprintfify(print);
X done = 1;
X if (isvar(fex, mp_output)) {
X if (i == 1) {
X print = makeexpr_bicall_1("putchar", tp_int,
X makeexpr_charcast(print));
X } else {
X if (printfonly == 0) {
X if (print->val.s[print->val.i-1] == '\n') {
X print->val.s[--(print->val.i)] = 0;
X print = makeexpr_bicall_1("puts", tp_int, print);
X } else {
X print = makeexpr_bicall_2("fputs", tp_int,
X print,
X copyexpr(fex));
X }
X } else {
X print = makeexpr_sprintfify(print);
X done = 0;
X }
X }
X } else {
X if (i == 1) {
X print = makeexpr_bicall_2("putc", tp_int,
X makeexpr_charcast(print),
X copyexpr(fex));
X } else if (printfonly == 0) {
X print = makeexpr_bicall_2("fputs", tp_int,
X print,
X copyexpr(fex));
X } else {
X print = makeexpr_sprintfify(print);
X done = 0;
X }
X }
X } else
X done = 0;
X if (!done) {
X canceltempvar(istempvar(print->args[0]));
X if (checkstring(print->args[1], "%s") && printfonly != 1) {
X print = makeexpr_bicall_2("fputs", tp_int,
X grabarg(print, 2),
X copyexpr(fex));
X } else if (checkstring(print->args[1], "%c") && printfonly != 1 &&
X !nosideeffects(print->args[2], 0)) {
X print = makeexpr_bicall_2("fputc", tp_int,
X grabarg(print, 2),
X copyexpr(fex));
X } else if (isvar(fex, mp_output)) {
X if (checkstring(print->args[1], "%s\n") && printfonly != 1) {
X print = makeexpr_bicall_1("puts", tp_int, grabarg(print, 2));
X } else if (checkstring(print->args[1], "%c") && printfonly != 1) {
X print = makeexpr_bicall_1("putchar", tp_int, grabarg(print, 2));
X } else {
X strchange(&print->val.s, "printf");
X delfreearg(&print, 0);
X print->val.type = tp_int;
X }
X } else {
X if (checkstring(print->args[1], "%c") && printfonly != 1) {
X print = makeexpr_bicall_2("putc", tp_int,
X grabarg(print, 2),
X copyexpr(fex));
X } else {
X strchange(&print->val.s, "fprintf");
X freeexpr(print->args[0]);
X print->args[0] = copyexpr(fex);
X print->val.type = tp_int;
X }
X }
X }
X if (FCheck(checkfilewrite)) {
X print = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_GE, print, makeexpr_long(0)),
X makeexpr_name(filewriteerrorname, tp_int));
X }
X }
X return makestmt_call(print);
X}
X
X
X
XStatic Stmt *handlewrite_bin(fex, ex)
XExpr *fex, *ex;
X{
X Type *basetype;
X Stmt *sp;
X Expr *tvardef = NULL;
X Meaning *tvar = NULL;
X
X sp = NULL;
X basetype = fex->val.type->basetype->basetype;
X for (;;) {
X if (!expr_has_address(ex) || ex->val.type != basetype) {
X if (!tvar)
X tvar = makestmttempvar(basetype, name_TEMP);
X if (!tvardef || !exprsame(tvardef, ex, 1)) {
X freeexpr(tvardef);
X tvardef = copyexpr(ex);
X sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(tvar),
X ex));
X } else
X freeexpr(ex);
X ex = makeexpr_var(tvar);
X }
X ex = makeexpr_bicall_4("fwrite", tp_integer, makeexpr_addr(ex),
X makeexpr_sizeof(makeexpr_type(basetype), 0),
X makeexpr_long(1),
X copyexpr(fex));
X if (FCheck(checkfilewrite)) {
X ex = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
X makeexpr_name(filewriteerrorname, tp_int));
X }
X sp = makestmt_seq(sp, makestmt_call(ex));
X if (curtok == TOK_COMMA) {
X gettok();
X ex = p_expr(NULL);
X } else
X break;
X }
X freeexpr(tvardef);
X return sp;
X}
X
X
X
XStatic Stmt *proc_write()
X{
X Expr *fex, *ex;
X Stmt *sp;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(NULL);
X if (isfiletype(ex->val.type) && wneedtok(TOK_COMMA)) {
X fex = ex;
X ex = p_expr(NULL);
X } else {
X fex = makeexpr_var(mp_output);
X }
X if (fex->val.type == tp_text)
X sp = handlewrite_text(fex, ex, 0);
X else
X sp = handlewrite_bin(fex, ex);
X skipcloseparen();
X return wrapopencheck(sp, fex);
X}
X
X
X
XStatic Stmt *handle_modula_write(fmt)
Xchar *fmt;
X{
X Expr *ex, *wid;
X
X if (!skipopenparen())
X return NULL;
X ex = makeexpr_forcelongness(p_expr(NULL));
X if (skipcomma())
X wid = p_expr(tp_integer);
X else
X wid = makeexpr_long(1);
X if (checkconst(wid, 0) || checkconst(wid, 1))
X ex = makeexpr_bicall_2("printf", tp_str255,
X makeexpr_string(format_ss("%%%s%s",
X (exprlongness(ex) > 0) ? "l" : "",
X fmt)),
X ex);
X else
X ex = makeexpr_bicall_3("printf", tp_str255,
X makeexpr_string(format_ss("%%*%s%s",
X (exprlongness(ex) > 0) ? "l" : "",
X fmt)),
X makeexpr_arglong(wid, 0),
X ex);
X skipcloseparen();
X return makestmt_call(ex);
X}
X
X
XStatic Stmt *proc_writecard()
X{
X return handle_modula_write("u");
X}
X
X
XStatic Stmt *proc_writeint()
X{
X return handle_modula_write("d");
X}
X
X
XStatic Stmt *proc_writehex()
X{
X return handle_modula_write("x");
X}
X
X
XStatic Stmt *proc_writeoct()
X{
X return handle_modula_write("o");
X}
X
X
XStatic Stmt *proc_writereal()
X{
X return handle_modula_write("f");
X}
X
X
X
XStatic Stmt *proc_writedir()
X{
X Expr *fex, *ex;
X Stmt *sp;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X ex = p_expr(tp_integer);
X sp = doseek(fex, ex);
X if (!skipcomma())
X return sp;
X sp = makestmt_seq(sp, handlewrite_bin(fex, p_expr(NULL)));
X skipcloseparen();
X return wrapopencheck(sp, fex);
X}
X
X
X
XStatic Stmt *handlewriteln(iswriteln)
Xint iswriteln;
X{
X Expr *fex, *ex;
X Stmt *sp;
X Meaning *deffile = mp_output;
X
X sp = NULL;
X if (iswriteln == 3) {
X iswriteln = 1;
X if (messagestderr)
X deffile = mp_stderr;
X }
X if (curtok != TOK_LPAR) {
X fex = makeexpr_var(deffile);
X if (iswriteln)
X sp = handlewrite_text(fex, makeexpr_string(""), -iswriteln);
X } else {
X gettok();
X ex = p_expr(NULL);
X if (isfiletype(ex->val.type)) {
X fex = ex;
X if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) {
X if (iswriteln)
X ex = makeexpr_string("");
X else
X ex = NULL;
X } else {
X ex = p_expr(NULL);
X }
X } else {
X fex = makeexpr_var(deffile);
X }
X if (ex)
X sp = handlewrite_text(fex, ex, iswriteln);
X skipcloseparen();
X }
X if (iswriteln == 0) {
X sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_1("fflush", tp_void,
X copyexpr(fex))));
X }
X return wrapopencheck(sp, fex);
X}
X
X
X
XStatic Stmt *proc_overprint()
X{
X return handlewriteln(2);
X}
X
X
X
XStatic Stmt *proc_prompt()
X{
X return handlewriteln(0);
X}
X
X
X
XStatic Stmt *proc_writeln()
X{
X return handlewriteln(1);
X}
X
X
XStatic Stmt *proc_message()
X{
X return handlewriteln(3);
X}
X
X
X
XStatic Stmt *proc_writev()
X{
X Expr *vex, *ex;
X Stmt *sp;
X Meaning *mp;
X
X if (!skipopenparen())
X return NULL;
X vex = p_expr(tp_str255);
X if (curtok == TOK_RPAR) {
X gettok();
X return makestmt_assign(vex, makeexpr_string(""));
X }
X if (!skipcomma())
X return NULL;
X sp = handlewrite_text(vex, p_expr(NULL), 0);
X skipcloseparen();
X ex = sp->exp1;
X if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
X (mp = istempvar(ex->args[0])) != NULL) {
X canceltempvar(mp);
X ex->args[0] = vex;
X } else
X sp->exp1 = makeexpr_assign(vex, ex);
X return sp;
X}
X
X
XStatic Stmt *proc_strwrite(mp_x, spbase)
XMeaning *mp_x;
XStmt *spbase;
X{
X Expr *vex, *exi, *exj, *ex;
X Stmt *sp;
X Meaning *mp;
X
X if (!skipopenparen())
X return NULL;
X vex = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X exi = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X exj = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X sp = handlewrite_text(vex, p_expr(NULL), 0);
X skipcloseparen();
X ex = sp->exp1;
X FREE(sp);
X if (checkconst(exi, 1)) {
X sp = spbase;
X while (sp && sp->next)
X sp = sp->next;
X if (sp && sp->kind == SK_ASSIGN && sp->exp1->kind == EK_ASSIGN &&
X (sp->exp1->args[0]->kind == EK_HAT ||
X sp->exp1->args[0]->kind == EK_INDEX) &&
X exprsame(sp->exp1->args[0]->args[0], vex, 1) &&
X checkconst(sp->exp1->args[1], 0)) {
X nukestmt(sp); /* remove preceding bogus setstrlen */
X }
X }
X if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
X (mp = istempvar(ex->args[0])) != NULL) {
X canceltempvar(mp);
X ex->args[0] = bumpstring(copyexpr(vex), exi, 1);
X sp = makestmt_call(ex);
X } else
X sp = makestmt_assign(bumpstring(copyexpr(vex), exi, 1), ex);
X if (fullstrwrite != 0) {
X sp = makestmt_seq(sp, makestmt_assign(exj,
X makeexpr_plus(makeexpr_bicall_1("strlen", tp_int, vex),
X makeexpr_long(1))));
X if (fullstrwrite == 1)
X note("FullStrWrite=1 not yet supported [204]");
X if (fullstrwrite == 2)
X note("STRWRITE was used [205]");
X } else {
X freeexpr(vex);
X }
X return mixassignments(sp, NULL);
X}
X
X
X
XStatic Stmt *proc_str_turbo()
X{
X Expr *ex, *wid, *prec;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(NULL);
X wid = NULL;
X prec = NULL;
X if (curtok == TOK_COLON) {
X gettok();
X wid = p_expr(tp_integer);
X if (curtok == TOK_COLON) {
X gettok();
X prec = p_expr(tp_integer);
X }
X }
X ex = writeelement(ex, wid, prec, 10);
X if (!skipcomma())
X return NULL;
X wid = p_expr(tp_str255);
X skipcloseparen();
X return makestmt_assign(wid, ex);
X}
X
X
X
XStatic Expr *func_xor()
X{
X Expr *ex, *ex2;
X Type *type;
X Meaning *tvar;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(NULL);
X if (!skipcomma())
X return ex;
X ex2 = p_expr(ex->val.type);
X skipcloseparen();
X if (ex->val.type->kind != TK_SET &&
X ex->val.type->kind != TK_SMALLSET) {
X ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2);
X } else {
X type = mixsets(&ex, &ex2);
X tvar = makestmttempvar(type, name_SET);
X ex = makeexpr_bicall_3(setxorname, type,
X makeexpr_var(tvar),
X ex, ex2);
X }
X return ex;
X}
X
X
X
X
X
X
X
Xvoid decl_builtins()
X{
X makespecialfunc( "ABS", func_abs);
X makespecialfunc( "ADDR", func_addr);
X if (!modula2)
X makespecialfunc( "ADDRESS", func_addr);
X makespecialfunc( "ADDTOPOINTER", func_addtopointer);
X makespecialfunc( "ADR", func_addr);
X makespecialfunc( "ASL", func_lsl);
X makespecialfunc( "ASR", func_asr);
X makespecialfunc( "BADDRESS", func_iaddress);
X makespecialfunc( "BAND", func_uand);
X makespecialfunc( "BIN", func_bin);
X makespecialfunc( "BITNEXT", func_bitnext);
X makespecialfunc( "BITSIZE", func_bitsize);
X makespecialfunc( "BITSIZEOF", func_bitsize);
Xmp_blockread_ucsd =
X makespecialfunc( "BLOCKREAD", func_blockread);
Xmp_blockwrite_ucsd =
X makespecialfunc( "BLOCKWRITE", func_blockwrite);
X makespecialfunc( "BNOT", func_unot);
X makespecialfunc( "BOR", func_uor);
X makespecialfunc( "BSL", func_bsl);
X makespecialfunc( "BSR", func_bsr);
X makespecialfunc( "BTST", func_btst);
X makespecialfunc( "BXOR", func_uxor);
X makespecialfunc( "BYTEREAD", func_byteread);
X makespecialfunc( "BYTEWRITE", func_bytewrite);
X makespecialfunc( "BYTE_OFFSET", func_byte_offset);
X makespecialfunc( "CHR", func_chr);
X makespecialfunc( "CONCAT", func_concat);
X makespecialfunc( "DBLE", func_float);
Xmp_dec_dec =
X makespecialfunc( "DEC", func_dec);
X makespecialfunc( "EOF", func_eof);
X makespecialfunc( "EOLN", func_eoln);
X makespecialfunc( "FCALL", func_fcall);
X makespecialfunc( "FILEPOS", func_filepos);
X makespecialfunc( "FILESIZE", func_filesize);
X makespecialfunc( "FLOAT", func_float);
X makespecialfunc( "HEX", func_hex);
X makespecialfunc( "HI", func_hi);
X makespecialfunc( "HIWORD", func_hiword);
X makespecialfunc( "HIWRD", func_hiword);
X makespecialfunc( "HIGH", func_high);
X makespecialfunc( "IADDRESS", func_iaddress);
X makespecialfunc( "INT", func_int);
X makespecialfunc( "LAND", func_uand);
X makespecialfunc( "LNOT", func_unot);
X makespecialfunc( "LO", func_lo);
X makespecialfunc( "LOOPHOLE", func_loophole);
X makespecialfunc( "LOR", func_uor);
X makespecialfunc( "LOWER", func_lower);
X makespecialfunc( "LOWORD", func_loword);
X makespecialfunc( "LOWRD", func_loword);
X makespecialfunc( "LSL", func_lsl);
X makespecialfunc( "LSR", func_lsr);
X makespecialfunc( "MAX", func_max);
X makespecialfunc( "MAXPOS", func_maxpos);
X makespecialfunc( "MIN", func_min);
X makespecialfunc( "NEXT", func_sizeof);
X makespecialfunc( "OCT", func_oct);
X makespecialfunc( "ORD", func_ord);
X makespecialfunc( "ORD4", func_ord4);
X makespecialfunc( "PI", func_pi);
X makespecialfunc( "POSITION", func_position);
X makespecialfunc( "PRED", func_pred);
X makespecialfunc( "QUAD", func_float);
X makespecialfunc( "RANDOM", func_random);
X makespecialfunc( "REF", func_addr);
X makespecialfunc( "SCAN", func_scan);
X makespecialfunc( "SEEKEOF", func_seekeof);
X makespecialfunc( "SEEKEOLN", func_seekeoln);
X makespecialfunc( "SIZE", func_sizeof);
X makespecialfunc( "SIZEOF", func_sizeof);
X makespecialfunc( "SNGL", func_sngl);
X makespecialfunc( "SQR", func_sqr);
X makespecialfunc( "STATUSV", func_statusv);
X makespecialfunc( "SUCC", func_succ);
X makespecialfunc( "TSIZE", func_sizeof);
X makespecialfunc( "UAND", func_uand);
X makespecialfunc( "UDEC", func_udec);
X makespecialfunc( "UINT", func_uint);
X makespecialfunc( "UNOT", func_unot);
X makespecialfunc( "UOR", func_uor);
X makespecialfunc( "UPPER", func_upper);
X makespecialfunc( "UXOR", func_uxor);
Xmp_val_modula =
X makespecialfunc( "VAL", func_val_modula);
X makespecialfunc( "WADDRESS", func_iaddress);
X makespecialfunc( "XOR", func_xor);
X
X makestandardfunc("ARCTAN", func_arctan);
X makestandardfunc("ARCTANH", func_arctanh);
X makestandardfunc("BINARY", func_binary);
X makestandardfunc("CAP", func_upcase);
X makestandardfunc("COPY", func_copy);
X makestandardfunc("COS", func_cos);
X makestandardfunc("COSH", func_cosh);
X makestandardfunc("EXP", func_exp);
X makestandardfunc("EXP10", func_pwroften);
X makestandardfunc("EXPO", func_expo);
X makestandardfunc("FRAC", func_frac);
X makestandardfunc("INDEX", func_strpos);
X makestandardfunc("LASTPOS", NULL);
X makestandardfunc("LINEPOS", NULL);
X makestandardfunc("LENGTH", func_strlen);
X makestandardfunc("LN", func_ln);
X makestandardfunc("LOG", func_log);
X makestandardfunc("LOG10", func_log);
X makestandardfunc("MAXAVAIL", func_maxavail);
X makestandardfunc("MEMAVAIL", func_memavail);
X makestandardfunc("OCTAL", func_octal);
X makestandardfunc("ODD", func_odd);
X makestandardfunc("PAD", func_pad);
X makestandardfunc("PARAMCOUNT", func_paramcount);
X makestandardfunc("PARAMSTR", func_paramstr);
X makestandardfunc("POS", func_pos);
X makestandardfunc("PTR", func_ptr);
X makestandardfunc("PWROFTEN", func_pwroften);
X makestandardfunc("ROUND", func_round);
X makestandardfunc("SCANEQ", func_scaneq);
X makestandardfunc("SCANNE", func_scanne);
X makestandardfunc("SIN", func_sin);
X makestandardfunc("SINH", func_sinh);
X makestandardfunc("SQRT", func_sqrt);
Xmp_str_hp =
X makestandardfunc("STR", func_str_hp);
X makestandardfunc("STRLEN", func_strlen);
X makestandardfunc("STRLTRIM", func_strltrim);
X makestandardfunc("STRMAX", func_strmax);
X makestandardfunc("STRPOS", func_strpos);
X makestandardfunc("STRRPT", func_strrpt);
X makestandardfunc("STRRTRIM", func_strrtrim);
X makestandardfunc("SUBSTR", func_str_hp);
X makestandardfunc("SWAP", func_swap);
X makestandardfunc("TAN", func_tan);
X makestandardfunc("TANH", func_tanh);
X makestandardfunc("TRUNC", func_trunc);
X makestandardfunc("UPCASE", func_upcase);
X makestandardfunc("UROUND", func_uround);
X makestandardfunc("UTRUNC", func_utrunc);
X
X makespecialproc( "APPEND", proc_append);
X makespecialproc( "ARGV", proc_argv);
X makespecialproc( "ASSERT", proc_assert);
X makespecialproc( "ASSIGN", proc_assign);
X makespecialproc( "BCLR", proc_bclr);
Xmp_blockread_turbo =
X makespecialproc( "BLOCKREAD_TURBO", proc_blockread);
Xmp_blockwrite_turbo =
X makespecialproc( "BLOCKWRITE_TURBO", proc_blockwrite);
X makespecialproc( "BREAK", proc_flush);
X makespecialproc( "BSET", proc_bset);
X makespecialproc( "CALL", proc_call);
X makespecialproc( "CLOSE", proc_close);
X makespecialproc( "CONNECT", proc_assign);
X makespecialproc( "CYCLE", proc_cycle);
Xmp_dec_turbo =
X makespecialproc( "DEC_TURBO", proc_dec);
X makespecialproc( "DISPOSE", proc_dispose);
X makespecialproc( "ESCAPE", proc_escape);
X makespecialproc( "EXCL", proc_excl);
X makespecialproc( "EXIT", proc_exit);
X makespecialproc( "FILLCHAR", proc_fillchar);
X makespecialproc( "FLUSH", proc_flush);
X makespecialproc( "GET", proc_get);
X makespecialproc( "HALT", proc_escape);
X makespecialproc( "INC", proc_inc);
X makespecialproc( "INCL", proc_incl);
X makespecialproc( "LEAVE", proc_leave);
X makespecialproc( "LOCATE", proc_seek);
X makespecialproc( "MESSAGE", proc_message);
X makespecialproc( "MOVE_FAST", proc_move_fast);
X makespecialproc( "MOVE_L_TO_R", proc_move_fast);
X makespecialproc( "MOVE_R_TO_L", proc_move_fast);
X makespecialproc( "NEW", proc_new);
X if (which_lang != LANG_VAX)
X makespecialproc( "OPEN", proc_open);
X makespecialproc( "OVERPRINT", proc_overprint);
X makespecialproc( "PACK", NULL);
X makespecialproc( "PAGE", proc_page);
X makespecialproc( "PUT", proc_put);
X makespecialproc( "PROMPT", proc_prompt);
X makespecialproc( "RANDOMIZE", proc_randomize);
X makespecialproc( "READ", proc_read);
X makespecialproc( "READDIR", proc_readdir);
X makespecialproc( "READLN", proc_readln);
X makespecialproc( "READV", proc_readv);
X makespecialproc( "RESET", proc_reset);
X makespecialproc( "REWRITE", proc_rewrite);
X makespecialproc( "SEEK", proc_seek);
X makespecialproc( "SETSTRLEN", proc_setstrlen);
X makespecialproc( "SETTEXTBUF", proc_settextbuf);
Xmp_str_turbo =
X makespecialproc( "STR_TURBO", proc_str_turbo);
X makespecialproc( "STRAPPEND", proc_strappend);
X makespecialproc( "STRDELETE", proc_strdelete);
X makespecialproc( "STRINSERT", proc_strinsert);
X makespecialproc( "STRMOVE", proc_strmove);
X makespecialproc( "STRREAD", proc_strread);
X makespecialproc( "STRWRITE", proc_strwrite);
X makespecialproc( "UNPACK", NULL);
X makespecialproc( "WRITE", proc_write);
X makespecialproc( "WRITEDIR", proc_writedir);
X makespecialproc( "WRITELN", proc_writeln);
X makespecialproc( "WRITEV", proc_writev);
Xmp_val_turbo =
X makespecialproc( "VAL_TURBO", proc_val_turbo);
X
X makestandardproc("DELETE", proc_delete);
X makestandardproc("FREEMEM", proc_freemem);
X makestandardproc("GETMEM", proc_getmem);
X makestandardproc("GOTOXY", proc_gotoxy);
X makestandardproc("INSERT", proc_insert);
X makestandardproc("MARK", NULL);
X makestandardproc("MOVE", proc_move);
X makestandardproc("MOVELEFT", proc_move);
X makestandardproc("MOVERIGHT", proc_move);
X makestandardproc("RELEASE", NULL);
X
X makespecialvar( "MEM", var_mem);
X makespecialvar( "MEMW", var_memw);
X makespecialvar( "MEML", var_meml);
X makespecialvar( "PORT", var_port);
X makespecialvar( "PORTW", var_portw);
X
X /* Modula-2 standard I/O procedures (case-sensitive!) */
X makespecialproc( "Read", proc_read);
X makespecialproc( "ReadCard", proc_read);
X makespecialproc( "ReadInt", proc_read);
X makespecialproc( "ReadReal", proc_read);
X makespecialproc( "ReadString", proc_read);
X makespecialproc( "Write", proc_write);
X makespecialproc( "WriteCard", proc_writecard);
X makespecialproc( "WriteHex", proc_writehex);
X makespecialproc( "WriteInt", proc_writeint);
X makespecialproc( "WriteOct", proc_writeoct);
X makespecialproc( "WriteLn", proc_writeln);
X makespecialproc( "WriteReal", proc_writereal);
X makespecialproc( "WriteString", proc_write);
X}
X
X
X
X
X/* End. */
X
X
X
END_OF_FILE
if test 42271 -ne `wc -c <'src/funcs.c.3'`; then
echo shar: \"'src/funcs.c.3'\" unpacked with wrong size!
fi
# end of 'src/funcs.c.3'
fi
echo shar: End of archive 17 \(of 32\).
cp /dev/null ark17isdone
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.