putpcc.c

把fortran语言编的程序转为c语言编的程序, 运行环境linux

 static char inconsist[] = "inconsistent calling sequences for ";

 void
#ifdef KR_headers
bad_atypes(at, fname, i, j, k, here, prev)
	Argtypes *at;
	char *fname;
	int i;
	int j;
	int k;
	char *here;
	char *prev;
#else
bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
#endif
{
	char buf[208], buf1[32], buf2[32];

	sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
		inconsist, fname, i, here, Argtype(k, buf1),
		prev, Argtype(j, buf2));
	atype_squawk(at, buf);
	}

 int
#ifdef KR_headers
type_fixup(at, a, k)
	Argtypes *at;
	Atype *a;
	int k;
#else
type_fixup(Argtypes *at,  Atype *a,  int k)
#endif
{
	register struct Entrypoint *ep;
	if (!infertypes)
		return 0;
	for(ep = entries; ep; ep = ep->entnextp)
		if (at == ep->entryname->arginfo) {
			a->type = k % 100;
			return proc_argchanges = 1;
			}
	return 0;
	}


 void
#ifdef KR_headers
save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
	chainp arglist;
	Argtypes **at0;
	Argtypes **at1;
	int ccall;
	char *fname;
	int stg;
	int nchargs;
	int type;
	int zap;
#else
save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
#endif
{
	Argtypes *at;
	chainp cp;
	int i, i0, j, k, nargs, nbad, *t, *te;
	Atype *atypes;
	expptr q;
	char buf[208], buf1[32], buf2[32];
	static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
	static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
#ifdef TYQUAD
							0,
#endif
				initargs, initargs+1,0,0,0,initargs+2};
	extern int init_ac[TYSUBR+1];

	i0 = init_ac[type];
	t = init_ap[type];
	te = t + i0;
	if (at = *at0) {
		*at1 = at;
		nargs = at->nargs;
		if (nargs < 0 && type && at->changes & 2 && !at->defined)
			--proc_protochanges;
		if (at->dnargs >= 0 && zap != 2)
			type = 0;
		if (nargs < 0) { /* inconsistent usage seen */
			if (type)
				goto newlist;
			return;
			}
		atypes = at->atypes;
		i = nchargs;
		for(nbad = 0; t < te; atypes++) {
			if (++i > nargs) {
 toomany:
				i = nchargs + i0;
				for(cp = arglist; cp; cp = cp->nextp)
					i++;
 toofew:
				switch(zap) {
					case 2:	zap = 6; break;
					case 1:	if (at->defined & 4)
							return;
					}
				sprintf(buf,
		"%s%.90s:\n\there %d, previously %d args and string lengths.",
					inconsist, fname, i, nargs);
				atype_squawk(at, buf);
				if (type) {
					t = init_ap[type];
					goto newlist;
					}
				return;
				}
			j = atypes->type;
			k = *t++;
			if (j != k && j-400 != k) {
				cp = 0;
				goto badtypes;
				}
			}
		for(cp = arglist; cp; atypes++, cp = cp->nextp) {
			if (++i > nargs)
				goto toomany;
			j = atypes->type;
			if (!(q = (expptr)cp->datap))
				continue;
			k = typekludge(ccall, q, atypes, j);
			if (k >= 300 || k == j)
				continue;
			if (j >= 300) {
				if (k >= 200) {
					if (k == TYUNKNOWN + 200)
						continue;
					if (j % 100 != k - 200
					 && k != TYSUBR + 200
					 && j != TYUNKNOWN + 300
					 && !type_fixup(at,atypes,k))
						goto badtypes;
					}
				else if (j % 100 % TYSUBR != k % TYSUBR
						&& !type_fixup(at,atypes,k))
					goto badtypes;
				}
			else if (k < 200 || j < 200)
				if (j) {
					if (k == TYUNKNOWN
					 && q->tag == TNAME
					 && q->nameblock.vinfproc) {
						q->nameblock.vdcldone = 0;
						impldcl((Namep)q);
						}
					goto badtypes;
					}
				else ; /* fall through to update */
			else if (k == TYUNKNOWN+200)
				continue;
			else if (j != TYUNKNOWN+200)
				{
 badtypes:
				if (++nbad == 1)
					bad_atypes(at, fname, i - nchargs,
						j, k, "here ", ", previously");
				else
					fprintf(stderr,
					 "\targ %d: here %s, previously %s.\n",
						i - nchargs, Argtype(k,buf1),
						Argtype(j,buf2));
				if (!cp)
					break;
				continue;
				}
			/* We've subsequently learned the right type,
			   as in the call on zoo below...

				subroutine foo(x, zap)
				external zap
				call goo(zap)
				x = zap(3)
				call zoo(zap)
				end
			 */
			if (!nbad) {
				atypes->type = k;
				at->changes |= 1;
				}
			}
		if (i < nargs)
			goto toofew;
		if (nbad) {
			if (type) {
				/* we're defining the procedure */
				t = init_ap[type];
				te = t + i0;
				proc_argchanges = 1;
				goto newlist;
				}
			return;
			}
		if (zap == 1 && (at->changes & 5) != 5)
			at->changes = 0;
		return;
		}
 newlist:
	i = i0 + nchargs;
	for(cp = arglist; cp; cp = cp->nextp)
		i++;
	k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
	*at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
					 : (Argtypes *) mem(k,1);
	at->dnargs = at->nargs = i;
	at->defined = zap & 6;
	at->changes = type ? 0 : 4;
	atypes = at->atypes;
	for(; t < te; atypes++) {
		atypes->type = *t++;
		atypes->cp = 0;
		}
	for(cp = arglist; cp; atypes++, cp = cp->nextp) {
		atypes->cp = 0;
		atypes->type = (q = (expptr)cp->datap)
			? typekludge(ccall, q, atypes, 0)
			: 0;
		}
	for(; --nchargs >= 0; atypes++) {
		atypes->type = TYFTNLEN + 100;
		atypes->cp = 0;
		}
	}

 void
#ifdef KR_headers
saveargtypes(p)
	register Exprp p;
#else
saveargtypes(register Exprp p)
#endif
				/* for writing prototypes */
{
	Addrp a;
	Argtypes **at0, **at1;
	Namep np;
	chainp arglist;
	expptr rp;
	Extsym *e;
	char *fname;

	a = (Addrp)p->leftp;
	switch(a->vstg) {
		case STGEXT:
			switch(a->uname_tag) {
				case UNAM_EXTERN:	/* e.g., sqrt() */
					e = extsymtab + a->memno;
					at0 = at1 = &e->arginfo;
					fname = e->fextname;
					break;
				case UNAM_NAME:
					np = a->user.name;
					at0 = &extsymtab[np->vardesc.varno].arginfo;
					at1 = &np->arginfo;
					fname = np->fvarname;
					break;
				default:
					goto bug;
				}
			break;
		case STGARG:
			if (a->uname_tag != UNAM_NAME)
				goto bug;
			np = a->user.name;
			at0 = at1 = &np->arginfo;
			fname = np->fvarname;
			break;
		default:
	 bug:
			Fatal("Confusion in saveargtypes");
		}
	rp = p->rightp;
	arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
	save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
		fname, a->vstg, 0, 0, 0);
	}

/* putcall - fix up the argument list, and write out the invocation.   p
   is expected to be initialized and point to an OPCALL or OPCCALL
   expression.  The return value is a pointer to a temporary holding the
   result of a COMPLEX or CHARACTER operation, or NULL. */

 LOCAL expptr
#ifdef KR_headers
putcall(p0, temp)
	expptr p0;
	Addrp *temp;
#else
putcall(expptr p0, Addrp *temp)
#endif
{
    register Exprp p = (Exprp)p0;
    chainp arglist;		/* Pointer to actual arguments, if any */
    chainp charsp;		/* List of copies of the variables which
				   hold the lengths of character
				   parameters (other than procedure
				   parameters) */
    chainp cp;			/* Iterator over argument lists */
    register expptr q;		/* Pointer to the current argument */
    Addrp fval;			/* Function return value */
    int type;			/* type of the call - presumably this was
				   set elsewhere */
    int byvalue;		/* True iff we don't want to massage the
				   parameter list, since we're calling a C
				   library routine */
    char *s;

    type = p -> vtype;
    charsp = NULL;
    byvalue =  (p->opcode == OPCCALL);

/* Verify the actual parameters */

    if (p == (Exprp) NULL)
	err ("putcall:  NULL call expression");
    else if (p -> tag != TEXPR)
	erri ("putcall:  expected TEXPR, got '%d'", p -> tag);

/* Find the argument list */

    if(p->rightp && p -> rightp -> tag == TLIST)
	arglist = p->rightp->listblock.listp;
    else
	arglist = NULL;

/* Count the number of explicit arguments, including lengths of character
   variables */

    for(cp = arglist ; cp ; cp = cp->nextp)
	if(!byvalue) {
	    q = (expptr) cp->datap;
	    if( ISCONST(q) )
	    {

/* Even constants are passed by reference, so we need to put them in the
   literal table */

		q = (expptr) putconst((Constp)q);
		cp->datap = (char *) q;
	    }

/* Save the length expression of character variables (NOT character
   procedures) for the end of the argument list */

	    if( ISCHAR(q) &&
		(q->headblock.vclass != CLPROC
		|| q->headblock.vstg == STGARG
			&& q->tag == TADDR
			&& q->addrblock.uname_tag == UNAM_NAME
			&& q->addrblock.user.name->vprocclass == PTHISPROC))
	    {
		p0 = cpexpr(q->headblock.vleng);
		charsp = mkchain((char *)p0, charsp);
		if (q->headblock.vclass == CLUNKNOWN
		 && q->headblock.vstg == STGARG)
			q->addrblock.user.name->vpassed = 1;
		else if (q->tag == TADDR
				&& q->addrblock.uname_tag == UNAM_CONST)
			p0->constblock.Const.ci
				+= q->addrblock.user.Const.ccp1.blanks;
	    }
	}
    charsp = revchain(charsp);

/* If the routine is a CHARACTER function ... */

    if(type == TYCHAR)
    {
	if( ISICON(p->vleng) )
	{

/* Allocate a temporary to hold the return value of the function */

	    fval = mktmp(TYCHAR, p->vleng);
	}
	else    {
		err("adjustable character function");
		if (temp)
			*temp = 0;
		return 0;
		}
    }

/* If the routine is a COMPLEX function ... */

    else if( ISCOMPLEX(type) )
	fval = mktmp(type, ENULL);
    else
	fval = NULL;

/* Write the function name, without taking its address */

    p -> leftp = putx(fixtype(putaddr(p->leftp)));

    if(fval)
    {
	chainp prepend;

/* Prepend a copy of the function return value buffer out as the first
   argument. */

	prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);

/* If it's a character function, also prepend the length of the result */

	if(type==TYCHAR)
	{

	    prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
					p->vleng)), arglist);
	}
	if (!(q = p->rightp))
		p->rightp = q = (expptr)mklist(CHNULL);
	q->listblock.listp = prepend;
    }

/* Scan through the fortran argument list */

    for(cp = arglist ; cp ; cp = cp->nextp)
    {
	q = (expptr) (cp->datap);
	if (q == ENULL)
	    err ("putcall:  NULL argument");

/* call putaddr only when we've got a parameter for a C routine or a
   memory resident parameter */

	if (q -> tag == TCONST && !byvalue)
	    q = (expptr) putconst ((Constp)q);

	if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
		if (q->addrblock.parenused
		 && !byvalue && q->headblock.vtype != TYCHAR)
			goto make_copy;
		cp->datap = (char *)putaddr(q);
		}
	else if( ISCOMPLEX(q->headblock.vtype) )
	    cp -> datap = (char *) putx (fixtype(putcxop(q)));
	else if (ISCHAR(q) )
	    cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
	else if( ! ISERROR(q) )
	{
	    if(byvalue
	    || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
		cp -> datap = (char *) putx(q);
	    else {
		expptr t, t1;

/* If we've got a register parameter, or (maybe?) a constant, save it in a
   temporary first */
 make_copy:
		t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);

/* Assign to temporary variables before invoking the subroutine or
   function */

		t1 = putassign( cpexpr(t), q );
		if (doin_setbound)
			t = mkexpr(OPCOMMA_ARG, t1, t);
		else
			putout(t1);
		cp -> datap = (char *) t;
	    } /* else */
	} /* if !ISERROR(q) */
    }

/* Now adjust the lengths of the CHARACTER parameters */

    for(cp = charsp ; cp ; cp = cp->nextp)
	cp->datap = (char *)addrfix(putx(
			/* in case MAIN has a character*(*)... */
			(s = cp->datap) ? mkconv(TYLENG,(expptr)s)
					 : ICON(0)));

/* ... and add them to the end of the argument list */

    hookup (arglist, charsp);

/* Return the name of the temporary used to hold the results, if any was
   necessary. */

    if (temp) *temp = fval;
    else frexpr ((expptr)fval);

    saveargtypes(p);

    return (expptr) p;
}



/* putmnmx -- Put min or max.   p   must point to an EXPR, not just a
   CONST */

 LOCAL expptr
#ifdef KR_headers
putmnmx(p)
	register expptr p;
#else
putmnmx(register expptr p)
#endif
{
	int op, op2, type;
	expptr arg, qp, temp;
	chainp p0, p1;
	Addrp sp, tp;
	char comment_buf[80];
	char *what;

	if(p->tag != TEXPR)
		badtag("putmnmx", p->tag);

	type = p->exprblock.vtype;
	op = p->exprblock.opcode;
	op2 = op == OPMIN ? OPMIN2 : OPMAX2;
	p0 = p->exprblock.leftp->listblock.listp;
	free( (charptr) (p->exprblock.leftp) );
	free( (charptr) p );

	/* special case for two addressable operands */

	if (addressable((expptr)p0->datap)
	 && (p1 = p0->nextp)
	 && addressable((expptr)p1->datap)
	 && !p1->nextp) {
		if (type == TYREAL && forcedouble)
			op2 = op == OPMIN ? OPDMIN : OPDMAX;
		p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
				mkconv(type, cpexpr((expptr)p1->datap)));
		frchain(&p0);
		return p;
		}

	/* general case */

	sp = mktmp(type, ENULL);

/* We only need a second temporary if the arg list has an unaddressable
   value */

	tp = (Addrp) NULL;
	qp = ENULL;
	for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
		if (!addressable ((expptr) p1 -> datap)) {
			tp = mktmp(type, ENULL);
			qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
			qp = fixexpr((Exprp)qp);
			break;
		} /* if */

/* Now output the appropriate number of assignments and comparisons.  Min
   and max are implemented by the simple O(n) algorithm:

	min (a, b, c, d) ==>
	{ <type> t1, t2;

	    t1 = a;
	    t2 = b; t1 = (t1 < t2) ? t1 : t2;
	    t2 = c; t1 = (t1 < t2) ? t1 : t2;
	    t2 = d; t1 = (t1 < t2) ? t1 : t2;
	}
*/

	if (!doin_setbound) {
		switch(op) {
			case OPLT:
			case OPMIN:
			case OPDMIN:
			case OPMIN2:
				what = "IN";
				break;
			default:
				what = "AX";
			}
		sprintf (comment_buf, "Computing M%s", what);
		p1_comment (comment_buf);
		}

	p1 = p0->nextp;
	temp = (expptr)p0->datap;
	if (addressable(temp) && addressable((expptr)p1->datap)) {
		p = mkconv(type, cpexpr(temp));
		arg = mkconv(type, cpexpr((expptr)p1->datap));
		temp = mkexpr(op2, p, arg);
		if (!ISCONST(temp))
			temp = fixexpr((Exprp)temp);
		p1 = p1->nextp;
		}
	p = putassign (cpexpr((expptr)sp), temp);

	for(; p1 ; p1 = p1->nextp)
	{
		if (addressable ((expptr) p1 -> datap)) {
			arg = mkconv(type, cpexpr((expptr)p1->datap));
			temp = mkexpr(op2, cpexpr((expptr)sp), arg);
			temp = fixexpr((Exprp)temp);
		} else {
			temp = (expptr) cpexpr (qp);
			p = mkexpr(OPCOMMA, p,
				putassign(cpexpr((expptr)tp), (expptr)p1->datap));
		} /* else */

		if(p1->nextp)
			p = mkexpr(OPCOMMA, p,
				putassign(cpexpr((expptr)sp), temp));
		else {
			if (type == TYREAL && forcedouble)
				temp->exprblock.opcode =
					op == OPMIN ? OPDMIN : OPDMAX;
			if (doin_setbound)
				p = mkexpr(OPCOMMA, p, temp);
			else {
				putout (p);
				p = putx(temp);
				}
			if (qp)
				frexpr (qp);
		} /* else */
	} /* for */

	frchain( &p0 );
	return p;
}


 void
#ifdef KR_headers
putwhile(p)
	expptr p;
#else
putwhile(expptr p)
#endif
{
	long where;
	int k, n;

	if (wh_next >= wh_last)
		{
		k = wh_last - wh_first;
		n = k + 100;
		wh_next = mem(n,0);
		wh_last = wh_first + n;
		if (k)
			memcpy(wh_next, wh_first, k);
		wh_first =  wh_next;
		wh_next += k;
		wh_last = wh_first + n;
		}
	p1put(P1_WHILE1START);
	where = ftell(pass1_file);
	if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
		{
		if(k != TYERROR)
			err("non-logical expression in DO WHILE statement");
		}
	else	{
		p = putx(p);
		*wh_next++ = ftell(pass1_file) > where;
		p1put(P1_WHILE2START);
		p1_expr(p);
		}
	}