funcs.c

把pascal程序转成C语言程序 把pascal程序转成C语言程序

{
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    skipcloseparen();
    return makestmt_assign(ex,
			   makeexpr_bin(EK_BAND, ex->val.type,
					copyexpr(ex),
					makeexpr_un(EK_BNOT, ex->val.type,
					makeexpr_bin(EK_LSH, tp_integer,
						     makeexpr_arglong(
						         makeexpr_long(1), 1),
						     ex2))));
}



Static Stmt *proc_bset()
{
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    skipcloseparen();
    return makestmt_assign(ex,
			   makeexpr_bin(EK_BOR, ex->val.type,
					copyexpr(ex),
					makeexpr_bin(EK_LSH, tp_integer,
						     makeexpr_arglong(
						         makeexpr_long(1), 1),
						     ex2)));
}



Static Expr *func_bsl()
{
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    skipcloseparen();
    return makeexpr_bin(EK_LSH, tp_integer, ex, ex2);
}



Static Expr *func_bsr()
{
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    skipcloseparen();
    return makeexpr_bin(EK_RSH, tp_integer, force_unsigned(ex), ex2);
}



Static Expr *func_btst()
{
    Expr *ex, *ex2;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_integer);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    skipcloseparen();
    return makeexpr_rel(EK_NE,
			makeexpr_bin(EK_BAND, tp_integer,
				     ex,
				     makeexpr_bin(EK_LSH, tp_integer,
						  makeexpr_arglong(
						      makeexpr_long(1), 1),
						  ex2)),
			makeexpr_long(0));
}



Static Expr *func_byteread()
{
    Expr *ex, *ex2, *vex, *sex, *fex;
    Type *type;

    if (!skipopenparen())
	return NULL;
    fex = p_expr(tp_text);
    if (!skipcomma())
	return NULL;
    vex = p_expr(NULL);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    if (curtok == TOK_COMMA) {
        gettok();
        sex = p_expr(tp_integer);
	sex = doseek(copyexpr(fex), sex)->exp1;
    } else
        sex = NULL;
    skipcloseparen();
    type = vex->val.type;
    ex = makeexpr_bicall_4("fread", tp_integer,
			   makeexpr_addr(vex),
			   makeexpr_long(1),
			   convert_size(type, ex2, "BYTEREAD"),
			   filebasename(copyexpr(fex)));
    return makeexpr_comma(sex, ex);
}



Static Expr *func_bytewrite()
{
    Expr *ex, *ex2, *vex, *sex, *fex;
    Type *type;

    if (!skipopenparen())
	return NULL;
    fex = p_expr(tp_text);
    if (!skipcomma())
	return NULL;
    vex = p_expr(NULL);
    if (!skipcomma())
	return NULL;
    ex2 = p_expr(tp_integer);
    if (curtok == TOK_COMMA) {
        gettok();
        sex = p_expr(tp_integer);
	sex = doseek(copyexpr(fex), sex)->exp1;
    } else
        sex = NULL;
    skipcloseparen();
    type = vex->val.type;
    ex = makeexpr_bicall_4("fwrite", tp_integer,
			   makeexpr_addr(vex),
			   makeexpr_long(1),
			   convert_size(type, ex2, "BYTEWRITE"),
			   filebasename(copyexpr(fex)));
    return makeexpr_comma(sex, ex);
}



Static Expr *func_byte_offset()
{
    Type *tp;
    Meaning *mp;
    Expr *ex;

    if (!skipopenparen())
	return NULL;
    tp = p_type(NULL);
    if (!skipcomma())
	return NULL;
    if (!wexpecttok(TOK_IDENT))
	return NULL;
    mp = curtoksym->fbase;
    while (mp && mp->rectype != tp)
	mp = mp->snext;
    if (!mp)
	ex = makeexpr_name(curtokcase, tp_integer);
    else
	ex = makeexpr_name(mp->name, tp_integer);
    gettok();
    skipcloseparen();
    return makeexpr_bicall_2("OFFSETOF", (size_t_long) ? tp_integer : tp_int,
			     makeexpr_type(tp), ex);
}



Static Stmt *proc_call()
{
    Expr *ex, *ex2, *ex3;
    Type *type, *tp;
    Meaning *mp;

    if (!skipopenparen())
	return NULL;
    ex2 = p_expr(tp_proc);
    type = ex2->val.type;
    if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
        warning("CALL requires a procedure variable [208]");
	type = tp_proc;
    }
    ex = makeexpr(EK_SPCALL, 1);
    ex->val.type = tp_void;
    ex->args[0] = copyexpr(ex2);
    if (type->escale != 0)
	ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
				    makepointertype(type->basetype));
    mp = type->basetype->fbase;
    if (mp) {
        if (wneedtok(TOK_COMMA))
	    ex = p_funcarglist(ex, mp, 0, 0);
    }
    skipcloseparen();
    if (type->escale != 1 || hasstaticlinks == 2) {
	freeexpr(ex2);
	return makestmt_call(ex);
    }
    ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
    ex3 = copyexpr(ex);
    insertarg(&ex3, ex3->nargs, copyexpr(ex2));
    tp = maketype(TK_FUNCTION);
    tp->basetype = type->basetype->basetype;
    tp->fbase = type->basetype->fbase;
    tp->issigned = 1;
    ex3->args[0]->val.type = makepointertype(tp);
    return makestmt_if(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
                       makestmt_call(ex3),
                       makestmt_call(ex));
}



Static Expr *func_chr()
{
    Expr *ex;

    ex = p_parexpr(tp_integer);
    if ((exprlongness(ex) < 0 || ex->kind == EK_CAST) && ex->kind != EK_ACTCAST)
        ex->val.type = tp_char;
    else
        ex = makeexpr_cast(ex, tp_char);
    return ex;
}



Static Stmt *proc_close()
{
    Stmt *sp, *sp2;
    Expr *fex, *ex;
    char *opt;

    if (!skipopenparen())
	return NULL;
    fex = p_expr(tp_text);
    sp = makestmt_if(makeexpr_rel(EK_NE, filebasename(copyexpr(fex)),
				  makeexpr_nil()),
                     makestmt_call(makeexpr_bicall_1("fclose", tp_void,
                                                     filebasename(copyexpr(fex)))),
                     (FCheck(checkfileisopen))
		         ? makestmt_call(
			     makeexpr_bicall_1(name_ESCIO,
					       tp_integer,
					       makeexpr_name(filenotopenname,
							     tp_int)))
                         : NULL);
    if (curtok == TOK_COMMA) {
        gettok();
	opt = "";
	if (curtok == TOK_IDENT &&
	    (!strcicmp(curtokbuf, "LOCK") ||
	     !strcicmp(curtokbuf, "PURGE") ||
	     !strcicmp(curtokbuf, "NORMAL") ||
	     !strcicmp(curtokbuf, "CRUNCH"))) {
	    opt = stralloc(curtokbuf);
	    gettok();
	} else {
	    ex = p_expr(tp_str255);
	    if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING)
		opt = ex->val.s;
	}
	if (!strcicmp(opt, "PURGE")) {
	    note("File is being closed with PURGE option [186]");
        }
    }
    sp2 = makestmt_assign(filebasename(fex), makeexpr_nil());
    sp2->quietelim = 1;
    sp = makestmt_seq(sp, sp2);
    skipcloseparen();
    return sp;
}



Static Expr *func_concat()
{
    Expr *ex;

    if (!skipopenparen())
	return makeexpr_string("oops");
    ex = p_expr(tp_str255);
    while (curtok == TOK_COMMA) {
        gettok();
        ex = makeexpr_concat(ex, p_expr(tp_str255), 0);
    }
    skipcloseparen();
    return ex;
}



Static Expr *func_copy(ex)
Expr *ex;
{
    if (isliteralconst(ex->args[3], NULL) == 2 &&
        ex->args[3]->val.i >= stringceiling) {
        return makeexpr_bicall_3("sprintf", ex->val.type,
                                 ex->args[0],
                                 makeexpr_string("%s"),
                                 bumpstring(ex->args[1], 
                                            makeexpr_unlongcast(ex->args[2]), 1));
    }
    if (checkconst(ex->args[2], 1)) {
        return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1], 
                                                ex->args[2], ex->args[3]));
    }
    return makeexpr_bicall_4(strsubname, ex->val.type,
                             ex->args[0],
                             ex->args[1],
                             makeexpr_arglong(ex->args[2], 0),
                             makeexpr_arglong(ex->args[3], 0));
}



Static Expr *func_cos(ex)
Expr *ex;
{
    return makeexpr_bicall_1("cos", tp_longreal, grabarg(ex, 0));
}


Static Expr *func_cosh(ex)
Expr *ex;
{
    return makeexpr_bicall_1("cosh", tp_longreal, grabarg(ex, 0));
}



Static Stmt *proc_cycle()
{
    return makestmt(SK_CONTINUE);
}



Static Stmt *proc_date()
{
    Expr *ex;

    if (!skipopenparen())
	return NULL;
    ex = p_expr(tp_str255);
    skipcloseparen();
    return makestmt_call(makeexpr_bicall_1("VAXdate", tp_integer, ex));
}


Static Stmt *proc_dec()
{
    Expr *vex, *ex;

    if (!skipopenparen())
	return NULL;
    vex = p_expr(NULL);
    if (curtok == TOK_COMMA) {
        gettok();
        ex = p_expr(tp_integer);
    } else
        ex = makeexpr_long(1);
    skipcloseparen();
    return makestmt_assign(vex, makeexpr_minus(copyexpr(vex), ex));
}



Static Expr *func_dec()
{
    return handle_vax_hex(NULL, "d", 0);
}



Static Stmt *proc_delete(ex)
Expr *ex;
{
    if (ex->nargs == 1)   /* Kludge for Oregon Software Pascal's delete(f) */
	return makestmt_call(makeexpr_bicall_1(strdeletename, tp_void, ex->args[0]));
    return makestmt_call(makeexpr_bicall_3(strdeletename, tp_void,
                                           ex->args[0], 
                                           makeexpr_arglong(ex->args[1], 0),
                                           makeexpr_arglong(ex->args[2], 0)));
}



void parse_special_variant(tp, buf)
Type *tp;
char *buf;
{
    char *cp;
    Expr *ex;

    if (!tp)
	intwarning("parse_special_variant", "tp == NULL");
    if (!tp || tp->meaning == NULL) {
	*buf = 0;
	if (curtok == TOK_COMMA) {
	    skiptotoken(TOK_RPAR);
	}
	return;
    }
    strcpy(buf, tp->meaning->name);
    while (curtok == TOK_COMMA) {
	gettok();
	cp = buf + strlen(buf);
	*cp++ = '.';
	if (curtok == TOK_MINUS) {
	    *cp++ = '-';
	    gettok();
	}
	if (curtok == TOK_INTLIT ||
	    curtok == TOK_HEXLIT ||
	    curtok == TOK_OCTLIT) {
	    sprintf(cp, "%ld", curtokint);
	    gettok();
	} else if (curtok == TOK_HAT || curtok == TOK_STRLIT) {
	    ex = makeexpr_charcast(accumulate_strlit());
	    if (ex->kind == EK_CONST) {
		if (ex->val.i <= 32 || ex->val.i > 126 ||
		    ex->val.i == '\'' || ex->val.i == '\\' ||
		    ex->val.i == '=' || ex->val.i == '}')
		    sprintf(cp, "%ld", ex->val.i);
		else
		    strcpy(cp, makeCchar(ex->val.i));
	    } else {
		*buf = 0;
		*cp = 0;
	    }
	    freeexpr(ex);
	} else {
	    if (!wexpecttok(TOK_IDENT)) {
		skiptotoken(TOK_RPAR);
		return;
	    }
	    if (curtokmeaning)
		strcpy(cp, curtokmeaning->name);
	    else
		strcpy(cp, curtokbuf);
	    gettok();
	}
    }
}


char *find_special_variant(buf, spname, splist, need)
char *buf, *spname;
Strlist *splist;
int need;
{
    Strlist *best = NULL;
    int len, bestlen = -1;
    char *cp, *cp2;

    if (!*buf)
	return NULL;
    while (splist) {
	cp = splist->s;
	cp2 = buf;
	while (*cp && toupper(*cp) == toupper(*cp2))
	    cp++, cp2++;
	len = cp2 - buf;
	if (!*cp && (!*cp2 || *cp2 == '.') && len > bestlen) {
	    best = splist;
	    bestlen = len;
	}
	splist = splist->next;
    }
    if (bestlen != strlen(buf) && my_strchr(buf, '.')) {
	if ((need & 1) || bestlen >= 0) {
	    if (need & 2)
		return NULL;
	    if (spname)
		note(format_ss("No %s form known for %s [187]",
			       spname, strupper(buf)));
	}
    }
    if (bestlen >= 0)
	return (char *)best->value;
    else
	return NULL;
}


Static Expr *parse_constructor(type, var)
Type *type;
Expr *var;
{
    Meaning *mp;
    Expr *expr = NULL;
    int savewith = withlevel;

    if (curtok == TOK_COMMA) {
	curtokmeaning = mp;
	withrecordtype(type, makeexpr_hat(copyexpr(var), 0));
	gettok();
	if (wexpecttok(TOK_IDENT)) {
	    mp = curtokmeaning;
	    if (mp && mp->kind == MK_FUNCTION && curtokint >= savewith) {
		expr = p_expr(tp_void);
	    } else
		warning(format_s("No constructor/destructor named %s [334]",
				 curtokbuf));
	}
	withlevel = savewith;
	freeexpr(withexprs[withlevel]);
    }
    return expr;
}


Static char *choose_free_func(ex)
Expr *ex;
{
    if (!*freename) {
	if (!*freervaluename)
	    return "free";
	else
	    return freervaluename;
    }
    if (!*freervaluename)
	return freervaluename;
    if (expr_is_lvalue(ex))
	return freename;
    else
	return freervaluename;
}