Context Navigation

source: mainline/uspace/app/pcc/f77/fcom/proc.c@ 9d58539

Visit:

lfn serial ticket/834-toolchain-update topic/msim-upgrade topic/simplify-dev-export

Last change on this file since 9d58539 was 9d58539, checked in by Prutkov Alex <prutkov.alex@…>, 13 years ago
Fixed unix permissions for all files
Property mode set to `100644`
File size: 17.9 KB

Rev	Line
[a7de7182]	1	/* $Id: proc.c,v 1.14 2008/12/24 17:40:41 sgk Exp $ */
	2	/*
	3	* Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
	4	*
	5	* Redistribution and use in source and binary forms, with or without
	6	* modification, are permitted provided that the following conditions
	7	* are met:
	8	*
	9	* Redistributions of source code and documentation must retain the above
	10	* copyright notice, this list of conditions and the following disclaimer.
	11	* Redistributions in binary form must reproduce the above copyright
	12	* notice, this list of conditionsand the following disclaimer in the
	13	* documentation and/or other materials provided with the distribution.
	14	* All advertising materials mentioning features or use of this software
	15	* must display the following acknowledgement:
	16	* This product includes software developed or owned by Caldera
	17	* International, Inc.
	18	* Neither the name of Caldera International, Inc. nor the names of other
	19	* contributors may be used to endorse or promote products derived from
	20	* this software without specific prior written permission.
	21	*
	22	* USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
	23	* INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
	24	* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
	25	* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
	26	* DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
	27	* FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
	28	* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
	29	* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
	30	* HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
	31	* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
	32	* IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
	33	* POSSIBILITY OF SUCH DAMAGE.
	34	*/
	35	#include <string.h>
	36
	37	#include "defines.h"
	38	#include "defs.h"
	39
	40	LOCAL void doentry(struct entrypoint *ep);
	41	LOCAL void retval(int t);
	42	LOCAL void epicode(void);
	43	LOCAL void procode(void);
	44	LOCAL int nextarg(int);
	45	LOCAL int nextarg(int);
	46	LOCAL void dobss(void);
	47	LOCAL void docommon(void);
	48	LOCAL void docomleng(void);
	49
	50
	51	/* start a new procedure */
	52
	53	void
	54	newproc()
	55	{
	56	if(parstate != OUTSIDE) {
	57	execerr("missing end statement");
	58	endproc();
	59	}
	60
	61	parstate = INSIDE;
	62	procclass = CLMAIN; /* default */
	63	}
	64
	65
	66
	67	/* end of procedure. generate variables, epilogs, and prologs */
	68
	69	void
	70	endproc()
	71	{
	72	struct labelblock *lp;
	73
	74	if(parstate < INDATA)
	75	enddcl();
	76	if(ctlstack >= ctls)
	77	err("DO loop or BLOCK IF not closed");
	78	for(lp = labeltab ; lp < labtabend ; ++lp)
	79	if(lp->stateno!=0 && lp->labdefined==NO)
	80	err1("missing statement number %s",
	81	convic(lp->stateno) );
	82
	83	epicode();
	84	procode();
	85	dobss();
	86	prdbginfo();
	87
	88	putbracket();
	89
	90	procinit(); /* clean up for next procedure */
	91	}
	92
	93
	94
	95	/*
	96	* End of declaration section of procedure. Allocate storage.
	97	*/
	98	void
	99	enddcl()
	100	{
	101	chainp p;
	102
	103	parstate = INEXEC;
	104	docommon();
	105	doequiv();
	106	docomleng();
	107	for(p = entries ; p ; p = p->entrypoint.nextp)
	108	doentry(&p->entrypoint);
	109	}
	110
	111	/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
	112
	113	/*
	114	* Called when a PROGRAM or BLOCK DATA statement is found, or if a statement
	115	* is encountered outside of any block.
	116	*/
	117	void
	118	startproc(struct extsym *progname, int class)
	119	{
	120	chainp p;
	121
	122	p = ALLOC(entrypoint);
	123	if(class == CLMAIN) {
	124	puthead("MAIN__");
	125	newentry( mkname(5, "MAIN_") );
	126	}
	127	p->entrypoint.entryname = progname;
	128	p->entrypoint.entrylabel = newlabel();
	129	entries = p;
	130
	131	procclass = class;
	132	retlabel = newlabel();
	133	if (!quietflag) {
	134	fprintf(diagfile, " %s",
	135	(class==CLMAIN ? "MAIN" : "BLOCK DATA") );
	136	if (progname)
	137	fprintf(diagfile, " %s",
	138	nounder(XL, procname = progname->extname));
	139	fprintf(diagfile, ":\n");
	140	}
	141	}
	142
	143	/* subroutine or function statement */
	144
	145	struct extsym *
	146	newentry(struct bigblock *v)
	147	{
	148	struct extsym *p;
	149
	150	p = mkext( varunder(VL, v->b_name.varname) );
	151
	152	if (p==NULL \|\| p->extinit \|\|
	153	!ONEOF(p->extstg, M(STGUNKNOWN)\|M(STGEXT))) {
	154	if(p == 0)
	155	dclerr("invalid entry name", v);
	156	else
	157	dclerr("external name already used", v);
	158	return(0);
	159	}
	160	v->vstg = STGAUTO;
	161	v->b_name.vprocclass = PTHISPROC;
	162	v->vclass = CLPROC;
	163	p->extstg = STGEXT;
	164	p->extinit = YES;
	165	return(p);
	166	}
	167
	168	/*
	169	* Called if a SUBROUTINE, FUNCTION or ENTRY statement is found.
	170	*/
	171	void
	172	entrypt(int class, int type, ftnint length, struct extsym *entry, chainp args)
	173	{
	174	struct bigblock *q;
	175	chainp p;
	176
	177	if(class != CLENTRY)
	178	puthead( varstr(XL, procname = entry->extname) );
	179	if (!quietflag) {
	180	if (class == CLENTRY)
	181	fprintf(diagfile, " entry ");
	182	fprintf(diagfile, " %s:\n", nounder(XL, entry->extname));
	183	}
	184	q = mkname(VL, nounder(XL,entry->extname) );
	185
	186	if( (type = lengtype(type, (int) length)) != TYCHAR)
	187	length = 0;
	188
	189	if(class == CLPROC) {
	190	procclass = CLPROC;
	191	proctype = type;
	192	procleng = length;
	193
	194	retlabel = newlabel();
	195	if(type == TYSUBR)
	196	ret0label = newlabel();
	197	}
	198
	199	p = ALLOC(entrypoint);
	200	entries = hookup(entries, p);
	201	p->entrypoint.entryname = entry;
	202	p->entrypoint.arglist = args;
	203	p->entrypoint.entrylabel = newlabel();
	204	p->entrypoint.enamep = q;
	205
	206	if(class == CLENTRY) {
	207	class = CLPROC;
	208	if(proctype == TYSUBR)
	209	type = TYSUBR;
	210	}
	211
	212	q->vclass = class;
	213	q->b_name.vprocclass = PTHISPROC;
	214	settype(q, type, (int) length);
	215	/* hold all initial entry points till end of declarations */
	216	if(parstate >= INDATA)
	217	doentry(&p->entrypoint);
	218	}
	219
	220
	221	/* generate epilogs */
	222
	223	int multitypes = 0; /* XXX */
	224
	225	LOCAL void
	226	epicode()
	227	{
	228	int i;
	229
	230	if(procclass==CLPROC) {
	231	if(proctype==TYSUBR) {
	232	putlabel(ret0label);
	233	if(substars)
	234	putforce(TYINT, MKICON(0) );
	235	putlabel(retlabel);
	236	goret(TYSUBR);
	237	} else {
	238	putlabel(retlabel);
	239	if(multitypes) {
	240	typeaddr = autovar(1, TYADDR, NULL);
	241	putbranch( cpexpr(typeaddr) );
	242	for(i = 0; i < NTYPES ; ++i) {
	243	if(rtvlabel[i] != 0) {
	244	putlabel(rtvlabel[i]);
	245	retval(i);
	246	}
	247	}
	248	} else
	249	retval(proctype);
	250	}
	251	} else if(procclass != CLBLOCK) {
	252	putlabel(retlabel);
	253	goret(TYSUBR);
	254	}
	255	}
	256
	257
	258	/* generate code to return value of type t */
	259
	260	LOCAL void
	261	retval(t)
	262	register int t;
	263	{
	264	register struct bigblock *p;
	265
	266	switch(t)
	267	{
	268	case TYCHAR:
	269	case TYCOMPLEX:
	270	case TYDCOMPLEX:
	271	break;
	272
	273	case TYLOGICAL:
	274	t = tylogical;
	275	case TYADDR:
	276	case TYSHORT:
	277	case TYLONG:
	278	p = cpexpr(retslot);
	279	p->vtype = t;
	280	putforce(t, p);
	281	break;
	282
	283	case TYREAL:
	284	case TYDREAL:
	285	p = cpexpr(retslot);
	286	p->vtype = t;
	287	putforce(t, p);
	288	break;
	289
	290	default:
	291	fatal1("retval: impossible type %d", t);
	292	}
	293	goret(t);
	294	}
	295
	296
	297	/* Allocate extra argument array if needed. Generate prologs. */
	298
	299	LOCAL void
	300	procode()
	301	{
	302	register chainp p;
	303	struct bigblock *argvec;
	304
	305	if(lastargslot>0 && nentry>1)
	306	argvec = autovar(lastargslot/FSZADDR, TYADDR, NULL);
	307	else
	308	argvec = NULL;
	309
	310	for(p = entries ; p ; p = p->entrypoint.nextp)
	311	prolog(&p->entrypoint, argvec);
	312
	313	putrbrack(procno);
	314
	315	prendproc();
	316	}
	317
	318	/*
	319	manipulate argument lists (allocate argument slot positions)
	320	* keep track of return types and labels
	321	*/
	322	LOCAL void
	323	doentry(struct entrypoint *ep)
	324	{
	325	int type;
	326	struct bigblock np, q;
	327	chainp p;
	328
	329	++nentry;
	330	if(procclass == CLMAIN) {
	331	putlabel(ep->entrylabel);
	332	return;
	333	} else if(procclass == CLBLOCK)
	334	return;
	335
	336	impldcl(np = mkname(VL, nounder(XL, ep->entryname->extname)));
	337	type = np->vtype;
	338	if(proctype == TYUNKNOWN)
	339	if( (proctype = type) == TYCHAR)
	340	procleng = (np->vleng ? np->vleng->b_const.fconst.ci : (ftnint) 0);
	341
	342	if(proctype == TYCHAR) {
	343	if(type != TYCHAR)
	344	err("noncharacter entry of character function");
	345	else if( (np->vleng ? np->vleng->b_const.fconst.ci : (ftnint) 0) != procleng)
	346	err("mismatched character entry lengths");
	347	} else if(type == TYCHAR)
	348	err("character entry of noncharacter function");
	349	else if(type != proctype)
	350	multitype = YES;
	351	if(rtvlabel[type] == 0)
	352	rtvlabel[type] = newlabel();
	353	ep->typelabel = rtvlabel[type];
	354
	355	if(type == TYCHAR) {
	356	if(chslot < 0) {
	357	chslot = nextarg(TYADDR);
	358	chlgslot = nextarg(TYLENG);
	359	}
	360	np->vstg = STGARG;
	361	np->b_name.vardesc.varno = chslot;
	362	if(procleng == 0)
	363	np->vleng = mkarg(TYLENG, chlgslot);
	364	} else if( ISCOMPLEX(type) ) {
	365	np->vstg = STGARG;
	366	if(cxslot < 0)
	367	cxslot = nextarg(TYADDR);
	368	np->b_name.vardesc.varno = cxslot;
	369	} else if(type != TYSUBR) {
	370	if(nentry == 1)
	371	retslot = autovar(1, TYDREAL, NULL);
	372	np->vstg = STGAUTO;
	373	np->b_name.voffset = retslot->b_addr.memoffset->b_const.fconst.ci;
	374	}
	375
	376	for(p = ep->arglist ; p ; p = p->chain.nextp)
	377	if(! ((q = p->chain.datap)->b_name.vdcldone) )
	378	q->b_name.vardesc.varno = nextarg(TYADDR);
	379
	380	for(p = ep->arglist ; p ; p = p->chain.nextp)
	381	if(! ((q = p->chain.datap)->b_name.vdcldone) ) {
	382	impldcl(q);
	383	q->b_name.vdcldone = YES;
	384	if(q->vtype == TYCHAR) {
	385	if(q->vleng == NULL) /* character() */
	386	q->vleng = mkarg(TYLENG, nextarg(TYLENG) );
	387	else if(nentry == 1)
	388	nextarg(TYLENG);
	389	} else if(q->vclass==CLPROC && nentry==1)
	390	nextarg(TYLENG) ;
	391	}
	392	putlabel(ep->entrylabel);
	393	}
	394
	395
	396
	397	LOCAL int
	398	nextarg(type)
	399	int type;
	400	{
	401	int k;
	402	k = lastargslot;
	403	lastargslot += typesize[type];
	404	return(k);
	405	}
	406
	407
	408	/* generate variable references */
	409
	410	LOCAL void
	411	dobss()
	412	{
	413	register struct hashentry *p;
	414	register struct bigblock *q;
	415	register int i;
	416	int align;
	417	ftnint leng, iarrl;
	418
	419	setloc(UDATA);
	420
	421	for(p = hashtab ; p<lasthash ; ++p)
	422	if((q = p->varp))
	423	{
	424	if( (q->vclass==CLUNKNOWN && q->vstg!=STGARG) \|\|
	425	(q->vclass==CLVAR && q->vstg==STGUNKNOWN) )
	426	warn1("local variable %s never used", varstr(VL,q->b_name.varname) );
	427	else if(q->vclass==CLVAR && q->vstg==STGBSS)
	428	{
	429	align = (q->vtype==TYCHAR ? ALILONG : typealign[q->vtype]);
	430	if(bssleng % align != 0)
	431	{
	432	bssleng = roundup(bssleng, align);
	433	preven(align);
	434	}
	435	prlocvar( memname(STGBSS, q->b_name.vardesc.varno), iarrl = iarrlen(q) );
	436	bssleng += iarrl;
	437	}
	438	else if(q->vclass==CLPROC && q->b_name.vprocclass==PEXTERNAL && q->vstg!=STGARG)
	439	mkext(varunder(VL, q->b_name.varname)) ->extstg = STGEXT;
	440
	441	if(q->vclass==CLVAR && q->vstg!=STGARG)
	442	{
	443	if(q->b_name.vdim && !ISICON(q->b_name.vdim->nelt) )
	444	dclerr("adjustable dimension on non-argument", q);
	445	if(q->vtype==TYCHAR && (q->vleng==NULL \|\| !ISICON(q->vleng)))
	446	dclerr("adjustable leng on nonargument", q);
	447	}
	448	}
	449
	450	for(i = 0 ; i < nequiv ; ++i)
	451	if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 )
	452	{
	453	bssleng = roundup(bssleng, ALIDOUBLE);
	454	preven(ALIDOUBLE);
	455	prlocvar( memname(STGEQUIV, i), leng);
	456	bssleng += leng;
	457	}
	458	}
	459
	460
	461
	462	void
	463	doext()
	464	{
	465	struct extsym *p;
	466
	467	for(p = extsymtab ; p<nextext ; ++p)
	468	prext( varstr(XL, p->extname), p->maxleng, p->extinit);
	469	}
	470
	471
	472
	473
	474	ftnint iarrlen(q)
	475	register struct bigblock *q;
	476	{
	477	ftnint leng;
	478
	479	leng = typesize[q->vtype];
	480	if(leng <= 0)
	481	return(-1);
	482	if(q->b_name.vdim) {
	483	if( ISICON(q->b_name.vdim->nelt) )
	484	leng *= q->b_name.vdim->nelt->b_const.fconst.ci;
	485	else return(-1);
	486	}
	487	if(q->vleng) {
	488	if( ISICON(q->vleng) )
	489	leng *= q->vleng->b_const.fconst.ci;
	490	else return(-1);
	491	}
	492	return(leng);
	493	}
	494
	495
	496	LOCAL void
	497	docommon()
	498	{
	499	register struct extsym *p;
	500	register chainp q;
	501	struct dimblock *t;
	502	bigptr neltp;
	503	register struct bigblock *v;
	504	ftnint size;
	505	int type;
	506
	507	for(p = extsymtab ; p<nextext ; ++p)
	508	if(p->extstg==STGCOMMON)
	509	{
	510	for(q = p->extp ; q ; q = q->chain.nextp)
	511	{
	512	v = q->chain.datap;
	513	if(v->b_name.vdcldone == NO)
	514	vardcl(v);
	515	type = v->vtype;
	516	if(p->extleng % typealign[type] != 0)
	517	{
	518	dclerr("common alignment", v);
	519	p->extleng = roundup(p->extleng, typealign[type]);
	520	}
	521	v->b_name.voffset = p->extleng;
	522	v->b_name.vardesc.varno = p - extsymtab;
	523	if(type == TYCHAR)
	524	size = v->vleng->b_const.fconst.ci;
	525	else size = typesize[type];
	526	if((t = v->b_name.vdim)) {
	527	if( (neltp = t->nelt) && ISCONST(neltp) )
	528	size *= neltp->b_const.fconst.ci;
	529	else
	530	dclerr("adjustable array in common", v);
	531	}
	532	p->extleng += size;
	533	}
	534
	535	frchain( &(p->extp) );
	536	}
	537	}
	538
	539
	540
	541
	542
	543	LOCAL void
	544	docomleng()
	545	{
	546	register struct extsym *p;
	547
	548	for(p = extsymtab ; p < nextext ; ++p)
	549	if(p->extstg == STGCOMMON)
	550	{
	551	if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng &&
	552	!eqn(XL,"_BLNK__ ",p->extname) )
	553	warn1("incompatible lengths for common block %s",
	554	nounder(XL, p->extname) );
	555	if(p->maxleng < p->extleng)
	556	p->maxleng = p->extleng;
	557	p->extleng = 0;
	558	}
	559	}
	560
	561
	562
	563
	564
	565	/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
	566	void
	567	frtemp(p)
	568	struct bigblock *p;
	569	{
	570	holdtemps = mkchain(p, holdtemps);
	571	}
	572
	573
	574
	575
	576	/* allocate an automatic variable slot */
	577
	578	struct bigblock *
	579	autovar(int nelt, int t, bigptr lengp)
	580	{
	581	ftnint leng = 0;
	582	register struct bigblock *q;
	583
	584	if(t == TYCHAR) {
	585	if( ISICON(lengp) )
	586	leng = lengp->b_const.fconst.ci;
	587	else
	588	fatal("automatic variable of nonconstant length");
	589	} else
	590	leng = typesize[t];
	591	autoleng = roundup( autoleng, typealign[t]);
	592
	593	q = BALLO();
	594	q->tag = TADDR;
	595	q->vtype = t;
	596	if(t == TYCHAR)
	597	q->vleng = MKICON(leng);
	598	q->vstg = STGAUTO;
	599	q->b_addr.ntempelt = nelt;
	600	#ifdef BACKAUTO
	601	/* stack grows downward */
	602	autoleng += nelt*leng;
	603	q->b_addr.memoffset = MKICON( - autoleng );
	604	#else
	605	q->b_addr.memoffset = MKICON( autoleng );
	606	autoleng += nelt*leng;
	607	#endif
	608
	609	return(q);
	610	}
	611
	612
	613	struct bigblock *mktmpn(nelt, type, lengp)
	614	int nelt;
	615	register int type;
	616	bigptr lengp;
	617	{
	618	ftnint leng = 0; /* XXX gcc */
	619	chainp p, oldp;
	620	register struct bigblock *q;
	621
	622	if(type==TYUNKNOWN \|\| type==TYERROR)
	623	fatal1("mktmpn: invalid type %d", type);
	624
	625	if(type==TYCHAR) {
	626	if( ISICON(lengp) )
	627	leng = lengp->b_const.fconst.ci;
	628	else {
	629	err("adjustable length");
	630	return( errnode() );
	631	}
	632	}
	633	for(oldp = (chainp)&templist ; (p = oldp->chain.nextp) ; oldp = p)
	634	{
	635	q = p->chain.datap;
	636	if(q->vtype==type && q->b_addr.ntempelt==nelt &&
	637	(type!=TYCHAR \|\| q->vleng->b_const.fconst.ci==leng) )
	638	{
	639	oldp->chain.nextp = p->chain.nextp;
	640	ckfree(p);
	641	return(q);
	642	}
	643	}
	644	q = autovar(nelt, type, lengp);
	645	q->b_addr.istemp = YES;
	646	return(q);
	647	}
	648
	649
	650
	651
	652	struct bigblock *fmktemp(type, lengp)
	653	int type;
	654	bigptr lengp;
	655	{
	656	return( mktmpn(1,type,lengp) );
	657	}
	658
	659
	660	/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
	661
	662	struct extsym *comblock(len, s)
	663	register int len;
	664	register char *s;
	665	{
	666	struct extsym *p;
	667
	668	if(len == 0)
	669	{
	670	s = BLANKCOMMON;
	671	len = strlen(s);
	672	}
	673	p = mkext( varunder(len, s) );
	674	if(p->extstg == STGUNKNOWN)
	675	p->extstg = STGCOMMON;
	676	else if(p->extstg != STGCOMMON)
	677	{
	678	err1("%s cannot be a common block name", s);
	679	return(0);
	680	}
	681
	682	return( p );
	683	}
	684
	685	void
	686	incomm(c, v)
	687	struct extsym *c;
	688	struct bigblock *v;
	689	{
	690	if(v->vstg != STGUNKNOWN)
	691	dclerr("incompatible common declaration", v);
	692	else
	693	{
	694	v->vstg = STGCOMMON;
	695	c->extp = hookup(c->extp, mkchain(v,NULL) );
	696	}
	697	}
	698
	699
	700
	701	void
	702	settype(v, type, length)
	703	register struct bigblock * v;
	704	register int type;
	705	register int length;
	706	{
	707	if(type == TYUNKNOWN)
	708	return;
	709
	710	if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
	711	{
	712	v->vtype = TYSUBR;
	713	frexpr(v->vleng);
	714	}
	715	else if(type < 0) /* storage class set */
	716	{
	717	if(v->vstg == STGUNKNOWN)
	718	v->vstg = - type;
	719	else if(v->vstg != -type)
	720	dclerr("incompatible storage declarations", v);
	721	}
	722	else if(v->vtype == TYUNKNOWN)
	723	{
	724	if( (v->vtype = lengtype(type, length))==TYCHAR && length!=0)
	725	v->vleng = MKICON(length);
	726	}
	727	else if(v->vtype!=type \|\| (type==TYCHAR && v->vleng->b_const.fconst.ci!=length) )
	728	dclerr("incompatible type declarations", v);
	729	}
	730
	731
	732
	733
	734	int
	735	lengtype(type, length)
	736	register int type;
	737	register int length;
	738	{
	739	switch(type)
	740	{
	741	case TYREAL:
	742	if(length == 8)
	743	return(TYDREAL);
	744	if(length == 4)
	745	goto ret;
	746	break;
	747
	748	case TYCOMPLEX:
	749	if(length == 16)
	750	return(TYDCOMPLEX);
	751	if(length == 8)
	752	goto ret;
	753	break;
	754
	755	case TYSHORT:
	756	case TYDREAL:
	757	case TYDCOMPLEX:
	758	case TYCHAR:
	759	case TYUNKNOWN:
	760	case TYSUBR:
	761	case TYERROR:
	762	goto ret;
	763
	764	case TYLOGICAL:
	765	if(length == 4)
	766	goto ret;
	767	break;
	768
	769	case TYLONG:
	770	if(length == 0)
	771	return(tyint);
	772	if(length == 2)
	773	return(TYSHORT);
	774	if(length == 4)
	775	goto ret;
	776	break;
	777	default:
	778	fatal1("lengtype: invalid type %d", type);
	779	}
	780
	781	if(length != 0)
	782	err("incompatible type-length combination");
	783
	784	ret:
	785	return(type);
	786	}
	787
	788
	789
	790
	791	void
	792	setintr(v)
	793	register struct bigblock * v;
	794	{
	795	register int k;
	796
	797	if(v->vstg == STGUNKNOWN)
	798	v->vstg = STGINTR;
	799	else if(v->vstg!=STGINTR)
	800	dclerr("incompatible use of intrinsic function", v);
	801	if(v->vclass==CLUNKNOWN)
	802	v->vclass = CLPROC;
	803	if(v->b_name.vprocclass == PUNKNOWN)
	804	v->b_name.vprocclass = PINTRINSIC;
	805	else if(v->b_name.vprocclass != PINTRINSIC)
	806	dclerr("invalid intrinsic declaration", v);
	807	if((k = intrfunct(v->b_name.varname)))
	808	v->b_name.vardesc.varno = k;
	809	else
	810	dclerr("unknown intrinsic function", v);
	811	}
	812
	813
	814	void
	815	setext(v)
	816	register struct bigblock * v;
	817	{
	818	if(v->vclass == CLUNKNOWN)
	819	v->vclass = CLPROC;
	820	else if(v->vclass != CLPROC)
	821	dclerr("invalid external declaration", v);
	822
	823	if(v->b_name.vprocclass == PUNKNOWN)
	824	v->b_name.vprocclass = PEXTERNAL;
	825	else if(v->b_name.vprocclass != PEXTERNAL)
	826	dclerr("invalid external declaration", v);
	827	}
	828
	829
	830
	831
	832	/* create dimensions block for array variable */
	833	void
	834	setbound(v, nd, dims)
	835	register struct bigblock * v;
	836	int nd;
	837	struct uux dims[ ];
	838	{
	839	register bigptr q, t;
	840	register struct dimblock *p;
	841	int i;
	842
	843	if(v->vclass == CLUNKNOWN)
	844	v->vclass = CLVAR;
	845	else if(v->vclass != CLVAR)
	846	{
	847	dclerr("only variables may be arrays", v);
	848	return;
	849	}
	850
	851	v->b_name.vdim = p = (struct dimblock ) ckalloc( sizeof(int) + (3+2nd)*sizeof(bigptr) );
	852	p->ndim = nd;
	853	p->nelt = MKICON(1);
	854
	855	for(i=0 ; i<nd ; ++i)
	856	{
	857	if( (q = dims[i].ub) == NULL)
	858	{
	859	if(i == nd-1)
	860	{
	861	frexpr(p->nelt);
	862	p->nelt = NULL;
	863	}
	864	else
	865	err("only last bound may be asterisk");
	866	p->dims[i].dimsize = MKICON(1);;
	867	p->dims[i].dimexpr = NULL;
	868	}
	869	else
	870	{
	871	if(dims[i].lb)
	872	{
	873	q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
	874	q = mkexpr(OPPLUS, q, MKICON(1) );
	875	}
	876	if( ISCONST(q) )
	877	{
	878	p->dims[i].dimsize = q;
	879	p->dims[i].dimexpr = NULL;
	880	}
	881	else {
	882	p->dims[i].dimsize = autovar(1, tyint, NULL);
	883	p->dims[i].dimexpr = q;
	884	}
	885	if(p->nelt)
	886	p->nelt = mkexpr(OPSTAR, p->nelt, cpexpr(p->dims[i].dimsize));
	887	}
	888	}
	889
	890	q = dims[nd-1].lb;
	891	if(q == NULL)
	892	q = MKICON(1);
	893
	894	for(i = nd-2 ; i>=0 ; --i)
	895	{
	896	t = dims[i].lb;
	897	if(t == NULL)
	898	t = MKICON(1);
	899	if(p->dims[i].dimsize)
	900	q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
	901	}
	902
	903	if( ISCONST(q) )
	904	{
	905	p->baseoffset = q;
	906	p->basexpr = NULL;
	907	}
	908	else
	909	{
	910	p->baseoffset = autovar(1, tyint, NULL);
	911	p->basexpr = q;
	912	}
	913	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: