Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume21/p2c/part22

Internet Message Format | 1990-04-05 | 50.9 KB

Subject:  v21i067:  Pascal to C translator, Part22/32
Newsgroups: comp.sources.unix
Approved: [e-mail]
X-Checksum-Snefru: d6ced95e 591e403d fc229aa2 64ef719a

Submitted-by: Dave Gillespie <[e-mail]>
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 [e-mail] 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