v21i067: Pascal to C translator, Part22/32
Rich Salz
rsalz at uunet.uu.net
Thu Mar 29 23:48:47 AEST 1990
Submitted-by: Dave Gillespie <daveg at csvax.caltech.edu>
Posting-number: Volume 21, Issue 67
Archive-name: p2c/part22
#! /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 22 (of 32)."
# Contents: src/funcs.c.2
# Wrapped by rsalz at litchi.bbn.com on Mon Mar 26 14:29:45 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/funcs.c.2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'src/funcs.c.2'\"
else
echo shar: Extracting \"'src/funcs.c.2'\" \(48594 characters\)
sed "s/^X//" >'src/funcs.c.2' <<'END_OF_FILE'
X return makestmt_call(makeexpr_bicall_2(getname, tp_void, ex,
X makeexpr_type(type->basetype->basetype)));
X}
X
X
X
XStatic Stmt *proc_getmem(ex)
XExpr *ex;
X{
X Expr *vex, *ex2, *sz = NULL;
X Stmt *sp;
X
X vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
X ex2 = ex->args[1];
X if (vex->val.type->kind == TK_POINTER)
X ex2 = convert_size(vex->val.type->basetype, ex2, "GETMEM");
X if (alloczeronil)
X sz = copyexpr(ex2);
X ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
X sp = makestmt_assign(copyexpr(vex), ex2);
X if (malloccheck) {
X sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
X makestmt_call(makeexpr_bicall_0(name_OUTMEM, tp_int)),
X NULL));
X }
X if (sz && !isconstantexpr(sz)) {
X if (alloczeronil == 2)
X note("Called GETMEM with variable argument [189]");
X sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
X sp,
X makestmt_assign(vex, makeexpr_nil()));
X } else
X freeexpr(vex);
X return sp;
X}
X
X
X
XStatic Stmt *proc_gotoxy(ex)
XExpr *ex;
X{
X return makestmt_call(makeexpr_bicall_2("gotoxy", tp_void,
X makeexpr_arglong(ex->args[0], 0),
X makeexpr_arglong(ex->args[1], 0)));
X}
X
X
X
XStatic Expr *handle_vax_hex(ex, fmt, scale)
XExpr *ex;
Xchar *fmt;
Xint scale;
X{
X Expr *lex, *dex, *vex;
X Meaning *tvar;
X Type *tp;
X long smin, smax;
X int bits;
X
X if (!ex) {
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X }
X tp = true_type(ex);
X if (ord_range(tp, &smin, &smax))
X bits = typebits(smin, smax);
X else
X bits = 32;
X if (curtok == TOK_COMMA) {
X gettok();
X if (curtok != TOK_COMMA)
X lex = makeexpr_arglong(p_expr(tp_integer), 0);
X else
X lex = NULL;
X } else
X lex = NULL;
X if (!lex) {
X if (!scale)
X lex = makeexpr_long(11);
X else
X lex = makeexpr_long((bits+scale-1) / scale + 1);
X }
X if (curtok == TOK_COMMA) {
X gettok();
X dex = makeexpr_arglong(p_expr(tp_integer), 0);
X } else {
X if (!scale)
X dex = makeexpr_long(10);
X else
X dex = makeexpr_long((bits+scale-1) / scale);
X }
X if (lex->kind == EK_CONST && dex->kind == EK_CONST &&
X lex->val.i < dex->val.i)
X lex = NULL;
X skipcloseparen();
X tvar = makestmttempvar(tp_str255, name_STRING);
X vex = makeexpr_var(tvar);
X ex = makeexpr_forcelongness(ex);
X if (exprlongness(ex) > 0)
X fmt = format_s("l%s", fmt);
X if (checkconst(lex, 0) || checkconst(lex, 1))
X lex = NULL;
X if (checkconst(dex, 0) || checkconst(dex, 1))
X dex = NULL;
X if (lex) {
X if (dex)
X ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
X makeexpr_string(format_s("%%*.*%s", fmt)),
X lex, dex, ex);
X else
X ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
X makeexpr_string(format_s("%%*%s", fmt)),
X lex, ex);
X } else {
X if (dex)
X ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
X makeexpr_string(format_s("%%.*%s", fmt)),
X dex, ex);
X else
X ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
X makeexpr_string(format_s("%%%s", fmt)),
X ex);
X }
X return ex;
X}
X
X
X
X
XStatic Expr *func_hex()
X{
X Expr *ex;
X char *cp;
X
X if (!skipopenparen())
X return NULL;
X ex = makeexpr_stringcast(p_expr(tp_integer));
X if ((ex->val.type->kind == TK_STRING ||
X ex->val.type == tp_strptr) &&
X curtok != TOK_COMMA) {
X skipcloseparen();
X if (ex->kind == EK_CONST) { /* HP Pascal */
X cp = getstring(ex);
X ex = makeexpr_long(my_strtol(cp, NULL, 16));
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(16));
X }
X } else { /* VAX Pascal */
X return handle_vax_hex(ex, "x", 4);
X }
X}
X
X
X
XStatic Expr *func_hi()
X{
X Expr *ex;
X
X ex = force_unsigned(p_parexpr(tp_integer));
X return makeexpr_bin(EK_RSH, tp_ubyte,
X ex, makeexpr_long(8));
X}
X
X
X
XStatic Expr *func_high()
X{
X Expr *ex;
X Type *type;
X
X ex = p_parexpr(tp_integer);
X type = ex->val.type;
X if (type->kind == TK_POINTER)
X type = type->basetype;
X if (type->kind == TK_ARRAY ||
X type->kind == TK_SMALLARRAY) {
X ex = makeexpr_minus(copyexpr(type->indextype->smax),
X copyexpr(type->indextype->smin));
X } else {
X warning("HIGH requires an array name parameter [210]");
X ex = makeexpr_bicall_1("HIGH", tp_int, ex);
X }
X return ex;
X}
X
X
X
XStatic Expr *func_hiword()
X{
X Expr *ex;
X
X ex = force_unsigned(p_parexpr(tp_unsigned));
X return makeexpr_bin(EK_RSH, tp_unsigned,
X ex, makeexpr_long(16));
X}
X
X
X
XStatic Stmt *proc_inc()
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_plus(copyexpr(vex), ex));
X}
X
X
X
XStatic Stmt *proc_incl()
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_BOR, vex->val.type,
X copyexpr(vex),
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(setaddname, tp_void, vex,
X makeexpr_arglong(enum_to_int(ex), 0)));
X}
X
X
X
XStatic Stmt *proc_insert(ex)
XExpr *ex;
X{
X return makestmt_call(makeexpr_bicall_3(strinsertname, tp_void,
X ex->args[0],
X ex->args[1],
X makeexpr_arglong(ex->args[2], 0)));
X}
X
X
X
XStatic Expr *func_int()
X{
X Expr *ex;
X Meaning *tvar;
X
X ex = p_parexpr(tp_integer);
X if (ex->val.type->kind == TK_REAL) { /* Turbo Pascal INT */
X tvar = makestmttempvar(tp_longreal, name_TEMP);
X return makeexpr_comma(makeexpr_bicall_2("modf", tp_longreal,
X grabarg(ex, 0),
X makeexpr_addr(makeexpr_var(tvar))),
X makeexpr_var(tvar));
X } else { /* VAX Pascal INT */
X return makeexpr_ord(ex);
X }
X}
X
X
XStatic Expr *func_uint()
X{
X Expr *ex;
X
X ex = p_parexpr(tp_integer);
X return makeexpr_cast(ex, tp_unsigned);
X}
X
X
X
XStatic Stmt *proc_leave()
X{
X return makestmt(SK_BREAK);
X}
X
X
X
XStatic Expr *func_lo()
X{
X Expr *ex;
X
X ex = gentle_cast(p_parexpr(tp_integer), tp_ushort);
X return makeexpr_bin(EK_BAND, tp_ubyte,
X ex, makeexpr_long(255));
X}
X
X
XStatic Expr *func_loophole()
X{
X Type *type;
X Expr *ex;
X
X if (!skipopenparen())
X return NULL;
X type = p_type(NULL);
X if (!skipcomma())
X return NULL;
X ex = p_expr(tp_integer);
X skipcloseparen();
X return pascaltypecast(type, ex);
X}
X
X
X
XStatic Expr *func_lower()
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("LOWER(v,n) not supported for n>1 [190]");
X }
X skipcloseparen();
X return copyexpr(ex->val.type->indextype->smin);
X}
X
X
X
XStatic Expr *func_loword()
X{
X Expr *ex;
X
X ex = p_parexpr(tp_integer);
X return makeexpr_bin(EK_BAND, tp_ushort,
X ex, makeexpr_long(65535));
X}
X
X
X
XStatic Expr *func_ln(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("log", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_log(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("log10", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_max()
X{
X Type *tp;
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X if (curtok == TOK_IDENT && curtokmeaning &&
X curtokmeaning->kind == MK_TYPE) {
X tp = curtokmeaning->type;
X gettok();
X skipcloseparen();
X return copyexpr(tp->smax);
X }
X ex = p_expr(tp_integer);
X while (curtok == TOK_COMMA) {
X gettok();
X ex2 = p_expr(ex->val.type);
X if (ex->val.type->kind == TK_REAL) {
X tp = ex->val.type;
X if (ex2->val.type->kind != TK_REAL)
X ex2 = makeexpr_cast(ex2, tp);
X } else {
X tp = ex2->val.type;
X if (ex->val.type->kind != TK_REAL)
X ex = makeexpr_cast(ex, tp);
X }
X ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmax" : "P_imax",
X tp, ex, ex2);
X }
X skipcloseparen();
X return ex;
X}
X
X
X
XStatic Expr *func_maxavail(ex)
XExpr *ex;
X{
X freeexpr(ex);
X return makeexpr_bicall_0("maxavail", tp_integer);
X}
X
X
X
XStatic Expr *func_maxpos()
X{
X return file_iofunc(3, seek_base);
X}
X
X
X
XStatic Expr *func_memavail(ex)
XExpr *ex;
X{
X freeexpr(ex);
X return makeexpr_bicall_0("memavail", tp_integer);
X}
X
X
X
XStatic Expr *var_mem()
X{
X Expr *ex, *ex2;
X
X if (!wneedtok(TOK_LBR))
X return makeexpr_name("MEM", tp_integer);
X ex = p_expr(tp_integer);
X if (curtok == TOK_COLON) {
X gettok();
X ex2 = p_expr(tp_integer);
X ex = makeexpr_bicall_2("MEM", tp_ubyte, ex, ex2);
X } else {
X ex = makeexpr_bicall_1("MEM", tp_ubyte, ex);
X }
X if (!wneedtok(TOK_RBR))
X skippasttotoken(TOK_RBR, TOK_SEMI);
X note("Reference to MEM [191]");
X return ex;
X}
X
X
X
XStatic Expr *var_memw()
X{
X Expr *ex, *ex2;
X
X if (!wneedtok(TOK_LBR))
X return makeexpr_name("MEMW", tp_integer);
X ex = p_expr(tp_integer);
X if (curtok == TOK_COLON) {
X gettok();
X ex2 = p_expr(tp_integer);
X ex = makeexpr_bicall_2("MEMW", tp_ushort, ex, ex2);
X } else {
X ex = makeexpr_bicall_1("MEMW", tp_ushort, ex);
X }
X if (!wneedtok(TOK_RBR))
X skippasttotoken(TOK_RBR, TOK_SEMI);
X note("Reference to MEMW [191]");
X return ex;
X}
X
X
X
XStatic Expr *var_meml()
X{
X Expr *ex, *ex2;
X
X if (!wneedtok(TOK_LBR))
X return makeexpr_name("MEML", tp_integer);
X ex = p_expr(tp_integer);
X if (curtok == TOK_COLON) {
X gettok();
X ex2 = p_expr(tp_integer);
X ex = makeexpr_bicall_2("MEML", tp_integer, ex, ex2);
X } else {
X ex = makeexpr_bicall_1("MEML", tp_integer, ex);
X }
X if (!wneedtok(TOK_RBR))
X skippasttotoken(TOK_RBR, TOK_SEMI);
X note("Reference to MEML [191]");
X return ex;
X}
X
X
X
XStatic Expr *func_min()
X{
X Type *tp;
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X if (curtok == TOK_IDENT && curtokmeaning &&
X curtokmeaning->kind == MK_TYPE) {
X tp = curtokmeaning->type;
X gettok();
X skipcloseparen();
X return copyexpr(tp->smin);
X }
X ex = p_expr(tp_integer);
X while (curtok == TOK_COMMA) {
X gettok();
X ex2 = p_expr(ex->val.type);
X if (ex->val.type->kind == TK_REAL) {
X tp = ex->val.type;
X if (ex2->val.type->kind != TK_REAL)
X ex2 = makeexpr_cast(ex2, tp);
X } else {
X tp = ex2->val.type;
X if (ex->val.type->kind != TK_REAL)
X ex = makeexpr_cast(ex, tp);
X }
X ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmin" : "P_imin",
X tp, ex, ex2);
X }
X skipcloseparen();
X return ex;
X}
X
X
X
XStatic Stmt *proc_move(ex)
XExpr *ex;
X{
X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr); /* source */
X ex->args[1] = gentle_cast(ex->args[1], tp_anyptr); /* dest */
X ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
X argbasetype(ex->args[1])), ex->args[2], "MOVE");
X return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
X ex->args[1],
X ex->args[0],
X makeexpr_arglong(ex->args[2], (size_t_long != 0))));
X}
X
X
X
XStatic Stmt *proc_move_fast()
X{
X Expr *ex, *ex2, *ex3, *ex4;
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 if (!skipcomma())
X return NULL;
X ord_range_expr(ex2->val.type->indextype, &ex4, NULL);
X ex2 = makeexpr_index(ex2, p_expr(tp_integer), copyexpr(ex4));
X if (!skipcomma())
X return NULL;
X ex3 = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X ord_range_expr(ex3->val.type->indextype, &ex4, NULL);
X ex3 = makeexpr_index(ex3, p_expr(tp_integer), copyexpr(ex4));
X skipcloseparen();
X ex = convert_size(choosetype(argbasetype(ex2),
X argbasetype(ex3)), ex, "MOVE_FAST");
X return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
X makeexpr_addr(ex3),
X makeexpr_addr(ex2),
X makeexpr_arglong(ex, (size_t_long != 0))));
X}
X
X
X
XStatic Stmt *proc_new()
X{
X Expr *ex, *ex2;
X Stmt *sp, **spp;
X Type *type;
X char *name, *name2 = NULL, vbuf[1000];
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_anyptr);
X type = ex->val.type;
X if (type->kind == TK_POINTER)
X type = type->basetype;
X parse_special_variant(type, vbuf);
X skipcloseparen();
X name = find_special_variant(vbuf, NULL, specialmallocs, 3);
X if (!name) {
X name2 = find_special_variant(vbuf, NULL, specialsizeofs, 3);
X if (!name2) {
X name = find_special_variant(vbuf, NULL, specialmallocs, 1);
X name2 = find_special_variant(vbuf, NULL, specialsizeofs, 1);
X if (name || !name2)
X name = find_special_variant(vbuf, "SpecialMalloc", specialmallocs, 1);
X else
X name2 = find_special_variant(vbuf, "SpecialSizeOf", specialsizeofs, 1);
X }
X }
X if (name) {
X ex2 = makeexpr_bicall_0(name, ex->val.type);
X } else if (name2) {
X ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, pc_expr_str(name2));
X } else {
X ex2 = makeexpr_bicall_1(mallocname, tp_anyptr,
X makeexpr_sizeof(makeexpr_type(type), 1));
X }
X sp = makestmt_assign(copyexpr(ex), ex2);
X if (malloccheck) {
X sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ,
X copyexpr(ex),
X makeexpr_nil()),
X makestmt_call(makeexpr_bicall_0(name_OUTMEM, tp_int)),
X NULL));
X }
X spp = &sp->next;
X while (*spp)
X spp = &(*spp)->next;
X if (type->kind == TK_RECORD)
X initfilevars(type->fbase, &spp, makeexpr_hat(copyexpr(ex), 0));
X else if (isfiletype(type))
X sp = makestmt_seq(sp, makestmt_assign(makeexpr_hat(copyexpr(ex), 0),
X makeexpr_nil()));
X freeexpr(ex);
X return sp;
X}
X
X
X
XStatic Expr *func_oct()
X{
X return handle_vax_hex(NULL, "o", 3);
X}
X
X
X
XStatic Expr *func_octal(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, 8));
X insertarg(&ex, 0, makeexpr_name("0%lo", tp_integer));
X return ex;
X } else {
X return makeexpr_bicall_3("strtol", tp_integer,
X ex, makeexpr_nil(), makeexpr_long(8));
X }
X}
X
X
X
XStatic Expr *func_odd(ex)
XExpr *ex;
X{
X ex = makeexpr_unlongcast(grabarg(ex, 0));
X if (*oddname)
X return makeexpr_bicall_1(oddname, tp_boolean, ex);
X else
X return makeexpr_bin(EK_BAND, tp_boolean, ex, makeexpr_long(1));
X}
X
X
X
XStatic Stmt *proc_open()
X{
X return handleopen(2);
X}
X
X
X
XStatic Expr *func_ord()
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 return makeexpr_ord(ex);
X}
X
X
X
XStatic Expr *func_ord4()
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 return makeexpr_longcast(makeexpr_ord(ex), 1);
X}
X
X
X
XStatic Expr *func_pad(ex)
XExpr *ex;
X{
X if (checkconst(ex->args[1], 0) || /* "s" is null string */
X checkconst(ex->args[2], ' ')) {
X return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
X makeexpr_string("%*s"),
X makeexpr_longcast(ex->args[3], 0),
X makeexpr_string(""));
X }
X return makeexpr_bicall_4(strpadname, tp_strptr,
X ex->args[0], ex->args[1], ex->args[2],
X makeexpr_arglong(ex->args[3], 0));
X}
X
X
X
XStatic Stmt *proc_page()
X{
X Expr *fex, *ex;
X
X if (curtok == TOK_LPAR) {
X fex = p_parexpr(tp_text);
X ex = makeexpr_bicall_2("fprintf", tp_int,
X copyexpr(fex),
X makeexpr_string("\f"));
X } else {
X fex = makeexpr_var(mp_output);
X ex = makeexpr_bicall_1("printf", tp_int,
X makeexpr_string("\f"));
X }
X if (FCheck(checkfilewrite)) {
X ex = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_GE, ex, makeexpr_long(0)),
X makeexpr_name(filewriteerrorname, tp_int));
X }
X return wrapopencheck(makestmt_call(ex), fex);
X}
X
X
X
XStatic Expr *func_paramcount(ex)
XExpr *ex;
X{
X freeexpr(ex);
X return makeexpr_minus(makeexpr_name(name_ARGC, tp_int),
X makeexpr_long(1));
X}
X
X
X
XStatic Expr *func_paramstr(ex)
XExpr *ex;
X{
X Expr *ex2;
X
X ex2 = makeexpr_index(makeexpr_name(name_ARGV,
X makepointertype(tp_strptr)),
X makeexpr_unlongcast(ex->args[1]),
X makeexpr_long(0));
X ex2->val.type = tp_str255;
X return makeexpr_bicall_3("sprintf", tp_strptr,
X ex->args[0],
X makeexpr_string("%s"),
X ex2);
X}
X
X
X
XStatic Expr *func_pi()
X{
X return makeexpr_name("M_PI", tp_longreal);
X}
X
X
X
XStatic Expr *var_port()
X{
X Expr *ex;
X
X if (!wneedtok(TOK_LBR))
X return makeexpr_name("PORT", tp_integer);
X ex = p_expr(tp_integer);
X if (!wneedtok(TOK_RBR))
X skippasttotoken(TOK_RBR, TOK_SEMI);
X note("Reference to PORT [191]");
X return makeexpr_bicall_1("PORT", tp_ubyte, ex);
X}
X
X
X
XStatic Expr *var_portw()
X{
X Expr *ex;
X
X if (!wneedtok(TOK_LBR))
X return makeexpr_name("PORTW", tp_integer);
X ex = p_expr(tp_integer);
X if (!wneedtok(TOK_RBR))
X skippasttotoken(TOK_RBR, TOK_SEMI);
X note("Reference to PORTW [191]");
X return makeexpr_bicall_1("PORTW", tp_ushort, ex);
X}
X
X
X
XStatic Expr *func_pos(ex)
XExpr *ex;
X{
X char *cp;
X
X cp = strposname;
X if (!*cp) {
X note("POS function used [192]");
X cp = "POS";
X }
X return makeexpr_bicall_3(cp, tp_int,
X ex->args[1],
X ex->args[0],
X makeexpr_long(1));
X}
X
X
X
XStatic Expr *func_ptr(ex)
XExpr *ex;
X{
X note("PTR function was used [193]");
X return ex;
X}
X
X
X
XStatic Expr *func_position()
X{
X return file_iofunc(2, seek_base);
X}
X
X
X
XStatic Expr *func_pred()
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 Stmt *proc_put()
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_output);
X requirefilebuffer(ex);
X type = ex->val.type;
X if (isfiletype(type) && *charputname &&
X type->basetype->basetype->kind == TK_CHAR)
X return makestmt_call(makeexpr_bicall_1(charputname, tp_void, ex));
X else if (isfiletype(type) && *arrayputname &&
X type->basetype->basetype->kind == TK_ARRAY)
X return makestmt_call(makeexpr_bicall_2(arrayputname, tp_void, ex,
X makeexpr_type(type->basetype->basetype)));
X else
X return makestmt_call(makeexpr_bicall_2(putname, tp_void, ex,
X makeexpr_type(type->basetype->basetype)));
X}
X
X
X
XStatic Expr *func_pwroften(ex)
XExpr *ex;
X{
X return makeexpr_bicall_2("pow", tp_longreal,
X makeexpr_real("10.0"), grabarg(ex, 0));
X}
X
X
X
XStatic Stmt *proc_reset()
X{
X return handleopen(0);
X}
X
X
X
XStatic Stmt *proc_rewrite()
X{
X return handleopen(1);
X}
X
X
X
X
XStmt *doseek(fex, ex)
XExpr *fex, *ex;
X{
X Expr *ex2;
X Type *basetype = fex->val.type->basetype->basetype;
X
X if (ansiC == 1)
X ex2 = makeexpr_name("SEEK_SET", tp_int);
X else
X ex2 = makeexpr_long(0);
X ex = makeexpr_bicall_3("fseek", tp_int,
X copyexpr(fex),
X makeexpr_arglong(
X makeexpr_times(makeexpr_minus(ex,
X makeexpr_long(seek_base)),
X makeexpr_sizeof(makeexpr_type(basetype), 0)),
X 1),
X ex2);
X if (FCheck(checkfileseek)) {
X ex = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_EQ, ex, makeexpr_long(0)),
X makeexpr_name(endoffilename, tp_int));
X }
X return makestmt_call(ex);
X}
X
X
X
X
XStatic Expr *makegetchar(fex)
XExpr *fex;
X{
X if (isvar(fex, mp_input))
X return makeexpr_bicall_0("getchar", tp_char);
X else
X return makeexpr_bicall_1("getc", tp_char, copyexpr(fex));
X}
X
X
X
XStatic Stmt *fixscanf(sp, fex)
XStmt *sp;
XExpr *fex;
X{
X int nargs, i, isstrread;
X char *cp;
X Expr *ex;
X Stmt *sp2;
X
X isstrread = (fex->val.type->kind == TK_STRING);
X if (sp->kind == SK_ASSIGN && sp->exp1->kind == EK_BICALL &&
X !strcmp(sp->exp1->val.s, "scanf")) {
X if (sp->exp1->args[0]->kind == EK_CONST &&
X !(sp->exp1->args[0]->val.i&1) && !isstrread) {
X cp = sp->exp1->args[0]->val.s; /* scanf("%c%c") -> getchar;getchar */
X for (i = 0; cp[i] == '%' && cp[i+1] == 'c'; ) {
X i += 2;
X if (i == sp->exp1->args[0]->val.i) {
X sp2 = NULL;
X for (i = 1; i < sp->exp1->nargs; i++) {
X ex = makeexpr_hat(sp->exp1->args[i], 0);
X sp2 = makestmt_seq(sp2,
X makestmt_assign(copyexpr(ex),
X makegetchar(fex)));
X if (checkeof(fex)) {
X sp2 = makestmt_seq(sp2,
X makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_NE,
X ex,
X makeexpr_name("EOF", tp_char)),
X makeexpr_name(endoffilename, tp_int))));
X } else
X freeexpr(ex);
X }
X return sp2;
X }
X }
X }
X nargs = sp->exp1->nargs - 1;
X if (isstrread) {
X strchange(&sp->exp1->val.s, "sscanf");
X insertarg(&sp->exp1, 0, copyexpr(fex));
X } else if (!isvar(fex, mp_input)) {
X strchange(&sp->exp1->val.s, "fscanf");
X insertarg(&sp->exp1, 0, copyexpr(fex));
X }
X if (FCheck(checkreadformat)) {
X if (checkeof(fex) && !isstrread)
X ex = makeexpr_cond(makeexpr_rel(EK_NE,
X makeexpr_bicall_1("feof", tp_int, copyexpr(fex)),
X makeexpr_long(0)),
X makeexpr_name(endoffilename, tp_int),
X makeexpr_name(badinputformatname, tp_int));
X else
X ex = makeexpr_name(badinputformatname, tp_int);
X sp->exp1 = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_EQ,
X sp->exp1,
X makeexpr_long(nargs)),
X ex);
X } else if (checkeof(fex) && !isstrread) {
X sp->exp1 = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_NE,
X sp->exp1,
X makeexpr_name("EOF", tp_int)),
X makeexpr_name(endoffilename, tp_int));
X }
X }
X return sp;
X}
X
X
X
XStatic Expr *makefgets(vex, lex, fex)
XExpr *vex, *lex, *fex;
X{
X Expr *ex;
X
X ex = makeexpr_bicall_3("fgets", tp_strptr,
X vex,
X lex,
X copyexpr(fex));
X if (checkeof(fex)) {
X ex = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_NE, ex, makeexpr_nil()),
X makeexpr_name(endoffilename, tp_int));
X }
X return ex;
X}
X
X
X
XStatic Stmt *skipeoln(fex)
XExpr *fex;
X{
X Meaning *tvar;
X Expr *ex;
X
X if (!strcmp(readlnname, "fgets")) {
X tvar = makestmttempvar(tp_str255, name_STRING);
X return makestmt_call(makefgets(makeexpr_var(tvar),
X makeexpr_long(stringceiling+1),
X fex));
X } else if (!strcmp(readlnname, "scanf") || !*readlnname) {
X if (checkeof(fex))
X ex = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_NE,
X makegetchar(fex),
X makeexpr_name("EOF", tp_char)),
X makeexpr_name(endoffilename, tp_int));
X else
X ex = makegetchar(fex);
X return makestmt_seq(fixscanf(
X makestmt_call(makeexpr_bicall_1("scanf", tp_int,
X makeexpr_string("%*[^\n]"))), fex),
X makestmt_call(ex));
X } else {
X return makestmt_call(makeexpr_bicall_1(readlnname, tp_void,
X copyexpr(fex)));
X }
X}
X
X
X
XStatic Stmt *handleread_text(fex, var, isreadln)
XExpr *fex, *var;
Xint isreadln;
X{
X Stmt *spbase, *spafter, *sp;
X Expr *ex = NULL, *exj = NULL;
X Type *type;
X Meaning *tvar, *tempcp, *mp;
X int i, isstrread, scanfmode, readlnflag, varstring, maxstring;
X int longstrsize = (longstringsize > 0) ? longstringsize : stringceiling;
X long rmin, rmax;
X char *fmt;
X
X spbase = NULL;
X spafter = NULL;
X sp = NULL;
X tempcp = NULL;
X isstrread = (fex->val.type->kind == TK_STRING);
X if (isstrread) {
X exj = var;
X var = p_expr(NULL);
X }
X scanfmode = !strcmp(readlnname, "scanf") || !*readlnname || isstrread;
X for (;;) {
X readlnflag = isreadln && curtok == TOK_RPAR;
X if (var->val.type->kind == TK_STRING && !isstrread) {
X if (sp)
X spbase = makestmt_seq(spbase, fixscanf(sp, fex));
X spbase = makestmt_seq(spbase, spafter);
X varstring = (varstrings && var->kind == EK_VAR &&
X (mp = (Meaning *)var->val.i)->kind == MK_VARPARAM &&
X mp->type == tp_strptr);
X maxstring = (strmax(var) >= longstrsize && !varstring);
X if (isvar(fex, mp_input) && maxstring && usegets && readlnflag) {
X spbase = makestmt_seq(spbase,
X makestmt_call(makeexpr_bicall_1("gets", tp_str255,
X makeexpr_addr(var))));
X isreadln = 0;
X } else if (scanfmode && !varstring &&
X (*readlnname || !isreadln)) {
X spbase = makestmt_seq(spbase, makestmt_assign(makeexpr_hat(copyexpr(var), 0),
X makeexpr_char(0)));
X if (maxstring && usegets)
X ex = makeexpr_string("%[^\n]");
X else
X ex = makeexpr_string(format_d("%%%d[^\n]", strmax(var)));
X ex = makeexpr_bicall_2("scanf", tp_int, ex, makeexpr_addr(var));
X spbase = makestmt_seq(spbase, fixscanf(makestmt_call(ex), fex));
X if (readlnflag && maxstring && usegets) {
X spbase = makestmt_seq(spbase, makestmt_call(makegetchar(fex)));
X isreadln = 0;
X }
X } else {
X ex = makeexpr_plus(strmax_func(var), makeexpr_long(1));
X spbase = makestmt_seq(spbase,
X makestmt_call(makefgets(makeexpr_addr(copyexpr(var)),
X ex,
X fex)));
X if (!tempcp)
X tempcp = makestmttempvar(tp_charptr, name_TEMP);
X spbase = makestmt_seq(spbase,
X makestmt_assign(makeexpr_var(tempcp),
X makeexpr_bicall_2("strchr", tp_charptr,
X makeexpr_addr(copyexpr(var)),
X makeexpr_char('\n'))));
X sp = makestmt_assign(makeexpr_hat(makeexpr_var(tempcp), 0),
X makeexpr_long(0));
X if (readlnflag)
X isreadln = 0;
X else
X sp = makestmt_seq(sp,
X makestmt_call(makeexpr_bicall_2("ungetc", tp_void,
X makeexpr_char('\n'),
X copyexpr(fex))));
X spbase = makestmt_seq(spbase, makestmt_if(makeexpr_rel(EK_NE,
X makeexpr_var(tempcp),
X makeexpr_nil()),
X sp,
X NULL));
X }
X sp = NULL;
X spafter = NULL;
X } else if (var->val.type->kind == TK_ARRAY && !isstrread) {
X if (sp)
X spbase = makestmt_seq(spbase, fixscanf(sp, fex));
X spbase = makestmt_seq(spbase, spafter);
X ex = makeexpr_sizeof(copyexpr(var), 0);
X if (readlnflag) {
X spbase = makestmt_seq(spbase,
X makestmt_call(
X makeexpr_bicall_3("P_readlnpaoc", tp_void,
X copyexpr(fex),
X makeexpr_addr(var),
X makeexpr_arglong(ex, 0))));
X isreadln = 0;
X } else {
X spbase = makestmt_seq(spbase,
X makestmt_call(
X makeexpr_bicall_3("P_readpaoc", tp_void,
X copyexpr(fex),
X makeexpr_addr(var),
X makeexpr_arglong(ex, 0))));
X }
X sp = NULL;
X spafter = NULL;
X } else {
X switch (ord_type(var->val.type)->kind) {
X
X case TK_INTEGER:
X fmt = "d";
X if (curtok == TOK_COLON) {
X gettok();
X if (curtok == TOK_IDENT &&
X !strcicmp(curtokbuf, "HEX")) {
X fmt = "x";
X } else if (curtok == TOK_IDENT &&
X !strcicmp(curtokbuf, "OCT")) {
X fmt = "o";
X } else if (curtok == TOK_IDENT &&
X !strcicmp(curtokbuf, "BIN")) {
X fmt = "b";
X note("Using %b for binary format in scanf [194]");
X } else
X warning("Unrecognized format specified in READ [212]");
X gettok();
X }
X type = findbasetype(var->val.type, 0);
X if (exprlongness(var) > 0)
X ex = makeexpr_string(format_s("%%l%s", fmt));
X else if (type == tp_integer || type == tp_int ||
X type == tp_uint || type == tp_sint)
X ex = makeexpr_string(format_s("%%%s", fmt));
X else if (type == tp_sshort || type == tp_ushort)
X ex = makeexpr_string(format_s("%%h%s", fmt));
X else {
X tvar = makestmttempvar(tp_int, name_TEMP);
X spafter = makestmt_seq(spafter,
X makestmt_assign(var,
X makeexpr_var(tvar)));
X var = makeexpr_var(tvar);
X ex = makeexpr_string(format_s("%%%s", fmt));
X }
X break;
X
X case TK_CHAR:
X ex = makeexpr_string("%c");
X if (newlinespace && !isstrread) {
X spafter = makestmt_seq(spafter,
X makestmt_if(makeexpr_rel(EK_EQ,
X copyexpr(var),
X makeexpr_char('\n')),
X makestmt_assign(copyexpr(var),
X makeexpr_char(' ')),
X NULL));
X }
X break;
X
X case TK_BOOLEAN:
X tvar = makestmttempvar(tp_str255, name_STRING);
X spafter = makestmt_seq(spafter,
X makestmt_assign(var,
X makeexpr_or(makeexpr_rel(EK_EQ,
X makeexpr_hat(makeexpr_var(tvar), 0),
X makeexpr_char('T')),
X makeexpr_rel(EK_EQ,
X makeexpr_hat(makeexpr_var(tvar), 0),
X makeexpr_char('t')))));
X var = makeexpr_var(tvar);
X ex = makeexpr_string(" %[a-zA-Z]");
X break;
X
X case TK_ENUM:
X warning("READ on enumerated types not yet supported [213]");
X if (useenum)
X ex = makeexpr_string("%d");
X else
X ex = makeexpr_string("%hd");
X break;
X
X case TK_REAL:
X ex = makeexpr_string("%lg");
X break;
X
X case TK_STRING: /* strread only */
X ex = makeexpr_string(format_d("%%%dc", strmax(fex)));
X break;
X
X case TK_ARRAY: /* strread only */
X if (!ord_range(ex->val.type->indextype, &rmin, &rmax)) {
X rmin = 1;
X rmax = 1;
X note("Can't determine length of packed array of chars [195]");
X }
X ex = makeexpr_string(format_d("%%%ldc", rmax-rmin+1));
X break;
X
X default:
X note("Element has wrong type for WRITE statement [196]");
X ex = NULL;
X break;
X
X }
X if (ex) {
X var = makeexpr_addr(var);
X if (sp) {
X sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0], ex, 0);
X insertarg(&sp->exp1, sp->exp1->nargs, var);
X } else {
X sp = makestmt_call(makeexpr_bicall_2("scanf", tp_int, ex, var));
X }
X }
X }
X if (curtok == TOK_COMMA) {
X gettok();
X var = p_expr(NULL);
X } else
X break;
X }
X if (sp) {
X if (isstrread && !FCheck(checkreadformat) &&
X ((i=0, checkstring(sp->exp1->args[0], "%d")) ||
X (i++, checkstring(sp->exp1->args[0], "%ld")) ||
X (i++, checkstring(sp->exp1->args[0], "%hd")) ||
X (i++, checkstring(sp->exp1->args[0], "%lg")))) {
X if (fullstrread != 0 && exj) {
X tvar = makestmttempvar(tp_strptr, name_STRING);
X sp->exp1 = makeexpr_assign(makeexpr_hat(sp->exp1->args[1], 0),
X (i == 3) ? makeexpr_bicall_2("strtod", tp_longreal,
X copyexpr(fex),
X makeexpr_addr(makeexpr_var(tvar)))
X : makeexpr_bicall_3("strtol", tp_integer,
X copyexpr(fex),
X makeexpr_addr(makeexpr_var(tvar)),
X makeexpr_long(10)));
X spafter = makestmt_seq(spafter,
X makestmt_assign(copyexpr(exj),
X makeexpr_minus(makeexpr_var(tvar),
X makeexpr_addr(copyexpr(fex)))));
X } else {
X sp->exp1 = makeexpr_assign(makeexpr_hat(sp->exp1->args[1], 0),
X makeexpr_bicall_1((i == 1) ? "atol" : (i == 3) ? "atof" : "atoi",
X (i == 1) ? tp_integer : (i == 3) ? tp_longreal : tp_int,
X copyexpr(fex)));
X }
X } else if (isstrread && fullstrread != 0 && exj) {
X sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0],
X makeexpr_string(sizeof_int >= 32 ? "%n" : "%ln"), 0);
X insertarg(&sp->exp1, sp->exp1->nargs, makeexpr_addr(copyexpr(exj)));
X } else if (isreadln && scanfmode && !FCheck(checkreadformat)) {
X isreadln = 0;
X sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0],
X makeexpr_string("%*[^\n]"), 0);
X spafter = makestmt_seq(makestmt_call(makegetchar(fex)), spafter);
X }
X spbase = makestmt_seq(spbase, fixscanf(sp, fex));
X }
X spbase = makestmt_seq(spbase, spafter);
X if (isreadln)
X spbase = makestmt_seq(spbase, skipeoln(fex));
X return spbase;
X}
X
X
X
XStatic Stmt *handleread_bin(fex, var)
XExpr *fex, *var;
X{
X Type *basetype;
X Stmt *sp;
X Expr *ex, *tvardef = NULL;
X
X sp = NULL;
X basetype = fex->val.type->basetype->basetype;
X for (;;) {
X ex = makeexpr_bicall_4("fread", tp_integer, makeexpr_addr(var),
X makeexpr_sizeof(makeexpr_type(basetype), 0),
X makeexpr_long(1),
X copyexpr(fex));
X if (checkeof(fex)) {
X ex = makeexpr_bicall_2("~SETIO", tp_void,
X makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
X makeexpr_name(endoffilename, tp_int));
X }
X sp = makestmt_seq(sp, makestmt_call(ex));
X if (curtok == TOK_COMMA) {
X gettok();
X var = p_expr(NULL);
X } else
X break;
X }
X freeexpr(tvardef);
X return sp;
X}
X
X
X
XStatic Stmt *proc_read()
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_input);
X }
X if (fex->val.type == tp_text)
X sp = handleread_text(fex, ex, 0);
X else
X sp = handleread_bin(fex, ex);
X skipcloseparen();
X return wrapopencheck(sp, fex);
X}
X
X
X
XStatic Stmt *proc_readdir()
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 (!skipopenparen())
X return sp;
X sp = makestmt_seq(sp, handleread_bin(fex, p_expr(NULL)));
X skipcloseparen();
X return wrapopencheck(sp, fex);
X}
X
X
X
XStatic Stmt *proc_readln()
X{
X Expr *fex, *ex;
X Stmt *sp;
X
X if (curtok != TOK_LPAR) {
X fex = makeexpr_var(mp_input);
X return wrapopencheck(skipeoln(copyexpr(fex)), fex);
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 skippasttotoken(TOK_RPAR, TOK_SEMI);
X return wrapopencheck(skipeoln(copyexpr(fex)), fex);
X } else {
X ex = p_expr(NULL);
X }
X } else {
X fex = makeexpr_var(mp_input);
X }
X sp = handleread_text(fex, ex, 1);
X skipcloseparen();
X }
X return wrapopencheck(sp, fex);
X}
X
X
X
XStatic Stmt *proc_readv()
X{
X Expr *vex;
X Stmt *sp;
X
X if (!skipopenparen())
X return NULL;
X vex = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X sp = handleread_text(vex, NULL, 0);
X skipcloseparen();
X return sp;
X}
X
X
X
XStatic Stmt *proc_strread()
X{
X Expr *vex, *exi, *exj, *exjj, *ex;
X Stmt *sp, *sp2;
X Meaning *tvar, *jvar;
X
X if (!skipopenparen())
X return NULL;
X vex = p_expr(tp_str255);
X if (vex->kind != EK_VAR) {
X tvar = makestmttempvar(tp_str255, name_STRING);
X sp = makestmt_assign(makeexpr_var(tvar), vex);
X vex = makeexpr_var(tvar);
X } else
X sp = NULL;
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 if (exprspeed(exi) >= 5 || !nosideeffects(exi, 0)) {
X sp = makestmt_seq(sp, makestmt_assign(copyexpr(exj), exi));
X exi = copyexpr(exj);
X }
X if (fullstrread != 0 &&
X ((ex = singlevar(exj)) == NULL || exproccurs(exi, ex))) {
X jvar = makestmttempvar(exj->val.type, name_TEMP);
X exjj = makeexpr_var(jvar);
X } else {
X exjj = copyexpr(exj);
X jvar = (exj->kind == EK_VAR) ? (Meaning *)exj->val.i : NULL;
X }
X sp2 = handleread_text(bumpstring(copyexpr(vex),
X copyexpr(exi), 1),
X exjj, 0);
X sp = makestmt_seq(sp, sp2);
X skipcloseparen();
X if (fullstrread == 0) {
X sp = makestmt_seq(sp, makestmt_assign(exj,
X makeexpr_plus(makeexpr_bicall_1("strlen", tp_int,
X vex),
X makeexpr_long(1))));
X freeexpr(exjj);
X freeexpr(exi);
X } else {
X sp = makestmt_seq(sp, makestmt_assign(exj,
X makeexpr_plus(exjj, exi)));
X if (fullstrread == 2)
X note("STRREAD was used [197]");
X freeexpr(vex);
X }
X return mixassignments(sp, jvar);
X}
X
X
X
X
XStatic Expr *func_random()
X{
X Expr *ex;
X
X if (curtok == TOK_LPAR) {
X gettok();
X ex = p_expr(tp_integer);
X skipcloseparen();
X return makeexpr_bicall_1(randintname, tp_integer, makeexpr_arglong(ex, 1));
X } else {
X return makeexpr_bicall_0(randrealname, tp_longreal);
X }
X}
X
X
X
XStatic Stmt *proc_randomize()
X{
X if (*randomizename)
X return makestmt_call(makeexpr_bicall_0(randomizename, tp_void));
X else
X return NULL;
X}
X
X
X
XStatic Expr *func_round(ex)
XExpr *ex;
X{
X Meaning *tvar;
X
X ex = grabarg(ex, 0);
X if (ex->val.type->kind != TK_REAL)
X return ex;
X if (*roundname) {
X if (*roundname != '*' || (exprspeed(ex) < 5 && nosideeffects(ex, 0))) {
X return makeexpr_bicall_1(roundname, tp_integer, ex);
X } else {
X tvar = makestmttempvar(tp_longreal, name_TEMP);
X return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex),
X makeexpr_bicall_1(roundname, tp_integer, makeexpr_var(tvar)));
X }
X } else {
X return makeexpr_actcast(makeexpr_bicall_1("floor", tp_longreal,
X makeexpr_plus(ex, makeexpr_real("0.5"))),
X tp_integer);
X }
X}
X
X
X
XStatic Expr *func_uround(ex)
XExpr *ex;
X{
X ex = grabarg(ex, 0);
X if (ex->val.type->kind != TK_REAL)
X return ex;
X return makeexpr_actcast(makeexpr_bicall_1("floor", tp_longreal,
X makeexpr_plus(ex, makeexpr_real("0.5"))),
X tp_unsigned);
X}
X
X
X
XStatic Expr *func_scan()
X{
X Expr *ex, *ex2, *ex3;
X char *name;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_integer);
X if (!skipcomma())
X return NULL;
X if (curtok == TOK_EQ)
X name = "P_scaneq";
X else
X name = "P_scanne";
X gettok();
X ex2 = p_expr(tp_char);
X if (!skipcomma())
X return NULL;
X ex3 = p_expr(tp_str255);
X skipcloseparen();
X return makeexpr_bicall_3(name, tp_int,
X makeexpr_arglong(ex, 0),
X makeexpr_charcast(ex2), ex3);
X}
X
X
X
XStatic Expr *func_scaneq(ex)
XExpr *ex;
X{
X return makeexpr_bicall_3("P_scaneq", tp_int,
X makeexpr_arglong(ex->args[0], 0),
X makeexpr_charcast(ex->args[1]),
X ex->args[2]);
X}
X
X
XStatic Expr *func_scanne(ex)
XExpr *ex;
X{
X return makeexpr_bicall_3("P_scanne", tp_int,
X makeexpr_arglong(ex->args[0], 0),
X makeexpr_charcast(ex->args[1]),
X ex->args[2]);
X}
X
X
X
XStatic Stmt *proc_seek()
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 skipcloseparen();
X sp = wrapopencheck(doseek(fex, ex), copyexpr(fex));
X if (*setupbufname && isfilevar(fex))
X sp = makestmt_seq(sp,
X makestmt_call(
X makeexpr_bicall_2(setupbufname, tp_void, fex,
X makeexpr_type(fex->val.type->basetype->basetype))));
X else
X freeexpr(fex);
X return sp;
X}
X
X
X
XStatic Expr *func_seekeof()
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 if (*skipspacename)
X ex = makeexpr_bicall_1(skipspacename, tp_text, ex);
X else
X note("SEEKEOF was used [198]");
X return iofunc(ex, 0);
X}
X
X
X
XStatic Expr *func_seekeoln()
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 if (*skipspacename)
X ex = makeexpr_bicall_1(skipspacename, tp_text, ex);
X else
X note("SEEKEOLN was used [199]");
X return iofunc(ex, 1);
X}
X
X
X
XStatic Stmt *proc_setstrlen()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
X ex2 = p_expr(tp_integer);
X skipcloseparen();
X return makestmt_assign(makeexpr_bicall_1("strlen", tp_int, ex),
X ex2);
X}
X
X
X
XStatic Stmt *proc_settextbuf()
X{
X Expr *fex, *bex, *sex;
X
X if (!skipopenparen())
X return NULL;
X fex = p_expr(tp_text);
X if (!skipcomma())
X return NULL;
X bex = p_expr(NULL);
X if (curtok == TOK_COMMA) {
X gettok();
X sex = p_expr(tp_integer);
X } else
X sex = makeexpr_sizeof(copyexpr(bex), 0);
X skipcloseparen();
X note("Make sure setvbuf() call occurs when file is open [200]");
X return makestmt_call(makeexpr_bicall_4("setvbuf", tp_void,
X fex,
X makeexpr_addr(bex),
X makeexpr_name("_IOFBF", tp_integer),
X sex));
X}
X
X
X
XStatic Expr *func_sin(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("sin", tp_longreal, grabarg(ex, 0));
X}
X
X
XStatic Expr *func_sinh(ex)
XExpr *ex;
X{
X return makeexpr_bicall_1("sinh", tp_longreal, grabarg(ex, 0));
X}
X
X
X
XStatic Expr *func_sizeof()
X{
X Expr *ex;
X Type *type;
X char *name, vbuf[1000];
X int lpar;
X
X lpar = (curtok == TOK_LPAR);
X if (lpar)
X gettok();
X if (curtok == TOK_IDENT && curtokmeaning && 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 parse_special_variant(type, vbuf);
X if (lpar)
X skipcloseparen();
X name = find_special_variant(vbuf, "SpecialSizeOf", specialsizeofs, 1);
X if (name) {
X freeexpr(ex);
X return pc_expr_str(name);
X } else
X return makeexpr_sizeof(ex, 0);
X}
X
X
X
XStatic Expr *func_statusv()
X{
X return makeexpr_name(name_IORESULT, tp_integer);
X}
X
X
X
XStatic Expr *func_str_hp(ex)
XExpr *ex;
X{
X return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1],
X ex->args[2], ex->args[3]));
X}
X
X
X
XStatic Stmt *proc_strappend()
X{
X Expr *ex, *ex2;
X
X if (!skipopenparen())
X return NULL;
X ex = p_expr(tp_str255);
X if (!skipcomma())
X return NULL;
END_OF_FILE
if test 48594 -ne `wc -c <'src/funcs.c.2'`; then
echo shar: \"'src/funcs.c.2'\" unpacked with wrong size!
fi
# end of 'src/funcs.c.2'
fi
echo shar: End of archive 22 \(of 32\).
cp /dev/null ark22isdone
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