Context Navigation

source: mainline/uspace/app/pcc/f77/fcom/io.c@ c6a7b3a

Visit:

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

Last change on this file since c6a7b3a was a7de7182, checked in by Jiří Zárevúcky <zarevucky.jiri@…>, 14 years ago
Added pcc source tree (contents of pcc-1.0.0.tgz)
Property mode set to `100644`
File size: 16.3 KB

Rev	Line
[a7de7182]	1	/* $Id: io.c,v 1.15 2008/12/19 08:08:48 ragge 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 conditions and 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	/* TEMPORARY */
	36	#define TYIOINT TYLONG
	37	#define FSZIOINT FSZLONG
	38
	39	#include <string.h>
	40
	41	#include "defines.h"
	42	#include "defs.h"
	43
	44	LOCAL void doiolist(chainp);
	45	LOCAL void dofopen(void);
	46	LOCAL void dofclose(void);
	47	LOCAL void dofinquire(void);
	48	LOCAL void dofmove(char *);
	49	LOCAL void ioset(int, int, bigptr);
	50	LOCAL void iosetc(int, bigptr);
	51	LOCAL void iosetip(int, int);
	52	LOCAL void iosetlc(int, int, int);
	53	LOCAL void putiocall(struct bigblock *q);
	54	LOCAL void putio(bigptr, bigptr);
	55	LOCAL void startrw(void);
	56
	57
	58	LOCAL char ioroutine[XL+1];
	59
	60	LOCAL int ioendlab;
	61	LOCAL int ioerrlab;
	62	LOCAL int endbit;
	63	LOCAL int jumplab;
	64	LOCAL int skiplab;
	65	LOCAL int ioformatted;
	66
	67	#define UNFORMATTED 0
	68	#define FORMATTED 1
	69	#define LISTDIRECTED 2
	70
	71	#define V(z) ioc[z].iocval
	72
	73	#define IOALL 07777
	74
	75	LOCAL struct ioclist
	76	{
	77	char *iocname;
	78	int iotype;
	79	bigptr iocval;
	80	} ioc[ ] =
	81	{
	82	{ "", 0 },
	83	{ "unit", IOALL },
	84	{ "fmt", M(IOREAD) \| M(IOWRITE) },
	85	{ "err", IOALL },
	86	{ "end", M(IOREAD) },
	87	{ "iostat", IOALL },
	88	{ "rec", M(IOREAD) \| M(IOWRITE) },
	89	{ "recl", M(IOOPEN) \| M(IOINQUIRE) },
	90	{ "file", M(IOOPEN) \| M(IOINQUIRE) },
	91	{ "status", M(IOOPEN) \| M(IOCLOSE) },
	92	{ "access", M(IOOPEN) \| M(IOINQUIRE) },
	93	{ "form", M(IOOPEN) \| M(IOINQUIRE) },
	94	{ "blank", M(IOOPEN) \| M(IOINQUIRE) },
	95	{ "exist", M(IOINQUIRE) },
	96	{ "opened", M(IOINQUIRE) },
	97	{ "number", M(IOINQUIRE) },
	98	{ "named", M(IOINQUIRE) },
	99	{ "name", M(IOINQUIRE) },
	100	{ "sequential", M(IOINQUIRE) },
	101	{ "direct", M(IOINQUIRE) },
	102	{ "formatted", M(IOINQUIRE) },
	103	{ "unformatted", M(IOINQUIRE) },
	104	{ "nextrec", M(IOINQUIRE) }
	105	} ;
	106
	107	#define NIOS (sizeof(ioc)/sizeof(struct ioclist) - 1)
	108	#define MAXIO FSZFLAG + 10FSZIOINT + 15FSZADDR
	109
	110	#define IOSUNIT 1
	111	#define IOSFMT 2
	112	#define IOSERR 3
	113	#define IOSEND 4
	114	#define IOSIOSTAT 5
	115	#define IOSREC 6
	116	#define IOSRECL 7
	117	#define IOSFILE 8
	118	#define IOSSTATUS 9
	119	#define IOSACCESS 10
	120	#define IOSFORM 11
	121	#define IOSBLANK 12
	122	#define IOSEXISTS 13
	123	#define IOSOPENED 14
	124	#define IOSNUMBER 15
	125	#define IOSNAMED 16
	126	#define IOSNAME 17
	127	#define IOSSEQUENTIAL 18
	128	#define IOSDIRECT 19
	129	#define IOSFORMATTED 20
	130	#define IOSUNFORMATTED 21
	131	#define IOSNEXTREC 22
	132
	133	#define IOSTP V(IOSIOSTAT)
	134
	135
	136	/* offsets in generated structures */
	137
	138	#define FSZFLAG FSZIOINT
	139
	140	#define XERR 0
	141	#define XUNIT FSZFLAG
	142	#define XEND FSZFLAG + FSZIOINT
	143	#define XFMT 2*FSZFLAG + FSZIOINT
	144	#define XREC 2*FSZFLAG + FSZIOINT + FSZADDR
	145	#define XRLEN 2FSZFLAG + 2FSZADDR
	146	#define XRNUM 2FSZFLAG + 2FSZADDR + FSZIOINT
	147
	148	#define XIFMT 2*FSZFLAG + FSZADDR
	149	#define XIEND FSZFLAG + FSZADDR
	150	#define XIUNIT FSZFLAG
	151
	152	#define XFNAME FSZFLAG + FSZIOINT
	153	#define XFNAMELEN FSZFLAG + FSZIOINT + FSZADDR
	154	#define XSTATUS FSZFLAG + 2*FSZIOINT + FSZADDR
	155	#define XACCESS FSZFLAG + 2FSZIOINT + 2FSZADDR
	156	#define XFORMATTED FSZFLAG + 2FSZIOINT + 3FSZADDR
	157	#define XRECLEN FSZFLAG + 2FSZIOINT + 4FSZADDR
	158	#define XBLANK FSZFLAG + 3FSZIOINT + 4FSZADDR
	159
	160	#define XCLSTATUS FSZFLAG + FSZIOINT
	161
	162	#define XFILE FSZFLAG + FSZIOINT
	163	#define XFILELEN FSZFLAG + FSZIOINT + FSZADDR
	164	#define XEXISTS FSZFLAG + 2*FSZIOINT + FSZADDR
	165	#define XOPEN FSZFLAG + 2FSZIOINT + 2FSZADDR
	166	#define XNUMBER FSZFLAG + 2FSZIOINT + 3FSZADDR
	167	#define XNAMED FSZFLAG + 2FSZIOINT + 4FSZADDR
	168	#define XNAME FSZFLAG + 2FSZIOINT + 5FSZADDR
	169	#define XNAMELEN FSZFLAG + 2FSZIOINT + 6FSZADDR
	170	#define XQACCESS FSZFLAG + 3FSZIOINT + 6FSZADDR
	171	#define XQACCLEN FSZFLAG + 3FSZIOINT + 7FSZADDR
	172	#define XSEQ FSZFLAG + 4FSZIOINT + 7FSZADDR
	173	#define XSEQLEN FSZFLAG + 4FSZIOINT + 8FSZADDR
	174	#define XDIRECT FSZFLAG + 5FSZIOINT + 8FSZADDR
	175	#define XDIRLEN FSZFLAG + 5FSZIOINT + 9FSZADDR
	176	#define XFORM FSZFLAG + 6FSZIOINT + 9FSZADDR
	177	#define XFORMLEN FSZFLAG + 6FSZIOINT + 10FSZADDR
	178	#define XFMTED FSZFLAG + 7FSZIOINT + 10FSZADDR
	179	#define XFMTEDLEN FSZFLAG + 7FSZIOINT + 11FSZADDR
	180	#define XUNFMT FSZFLAG + 8FSZIOINT + 11FSZADDR
	181	#define XUNFMTLEN FSZFLAG + 8FSZIOINT + 12FSZADDR
	182	#define XQRECL FSZFLAG + 9FSZIOINT + 12FSZADDR
	183	#define XNEXTREC FSZFLAG + 9FSZIOINT + 13FSZADDR
	184	#define XQBLANK FSZFLAG + 9FSZIOINT + 14FSZADDR
	185	#define XQBLANKLEN FSZFLAG + 9FSZIOINT + 15FSZADDR
	186
	187
	188	int
	189	fmtstmt(lp)
	190	register struct labelblock *lp;
	191	{
	192	if(lp == NULL)
	193	{
	194	execerr("unlabeled format statement" , 0);
	195	return(-1);
	196	}
	197	if(lp->labtype == LABUNKNOWN)
	198	{
	199	lp->labtype = LABFORMAT;
	200	lp->labelno = newlabel();
	201	}
	202	else if(lp->labtype != LABFORMAT)
	203	{
	204	execerr("bad format number", 0);
	205	return(-1);
	206	}
	207	return(lp->labelno);
	208	}
	209
	210
	211	void
	212	setfmt(struct labelblock *lp)
	213	{
	214	ftnint n;
	215	char *s;
	216
	217	s = lexline(&n);
	218	preven(ALILONG);
	219	prlabel(lp->labelno);
	220	putstr(s, n);
	221	flline();
	222	}
	223
	224
	225	void
	226	startioctl()
	227	{
	228	unsigned int i;
	229
	230	inioctl = YES;
	231	nioctl = 0;
	232	ioerrlab = 0;
	233	ioformatted = UNFORMATTED;
	234	for(i = 1 ; i<=NIOS ; ++i)
	235	V(i) = NULL;
	236	}
	237
	238
	239	void
	240	endioctl()
	241	{
	242	unsigned int i;
	243	bigptr p;
	244
	245	inioctl = NO;
	246	if(ioblkp == NULL)
	247	ioblkp = autovar( (MAXIO+FSZIOINT-1)/FSZIOINT , TYIOINT, NULL);
	248
	249	/* set up for error recovery */
	250
	251	ioerrlab = ioendlab = skiplab = jumplab = 0;
	252
	253	if((p = V(IOSEND))) {
	254	if(ISICON(p))
	255	ioendlab = mklabel(p->b_const.fconst.ci)->labelno;
	256	else
	257	err("bad end= clause");
	258	}
	259
	260	if((p = V(IOSERR))) {
	261	if(ISICON(p))
	262	ioerrlab = mklabel(p->b_const.fconst.ci)->labelno;
	263	else
	264	err("bad err= clause");
	265	}
	266
	267	if(IOSTP==NULL && ioerrlab!=0 && ioendlab!=0 && ioerrlab!=ioendlab)
	268	IOSTP = fmktemp(TYINT, NULL);
	269
	270	if(IOSTP != NULL) {
	271	if(IOSTP->tag!=TADDR \|\| ! ISINT(IOSTP->vtype) )
	272	{
	273	err("iostat must be an integer variable");
	274	frexpr(IOSTP);
	275	IOSTP = NULL;
	276	}
	277	}
	278
	279	if(IOSTP)
	280	{
	281	if( (iostmt==IOREAD \|\| iostmt==IOWRITE) &&
	282	(ioerrlab!=ioendlab \|\| ioerrlab==0) )
	283	jumplab = skiplab = newlabel();
	284	else
	285	jumplab = ioerrlab;
	286	}
	287	else
	288	{
	289	jumplab = ioerrlab;
	290	if(ioendlab)
	291	jumplab = ioendlab;
	292	}
	293
	294	ioset(TYIOINT, XERR, MKICON(IOSTP!=NULL \|\| ioerrlab!=0) );
	295	endbit = IOSTP!=NULL \|\| ioendlab!=0; /* for use in startrw() */
	296
	297	switch(iostmt)
	298	{
	299	case IOOPEN:
	300	dofopen(); break;
	301
	302	case IOCLOSE:
	303	dofclose(); break;
	304
	305	case IOINQUIRE:
	306	dofinquire(); break;
	307
	308	case IOBACKSPACE:
	309	dofmove("f_back"); break;
	310
	311	case IOREWIND:
	312	dofmove("f_rew"); break;
	313
	314	case IOENDFILE:
	315	dofmove("f_end"); break;
	316
	317	case IOREAD:
	318	case IOWRITE:
	319	startrw(); break;
	320
	321	default:
	322	fatal1("impossible iostmt %d", iostmt);
	323	}
	324	for(i = 1 ; i<=NIOS ; ++i)
	325	if(i!=IOSIOSTAT \|\| (iostmt!=IOREAD && iostmt!=IOWRITE) )
	326	frexpr(V(i));
	327	}
	328
	329
	330	int
	331	iocname()
	332	{
	333	unsigned int i;
	334	int found, mask;
	335
	336	found = 0;
	337	mask = M(iostmt);
	338	for(i = 1 ; i <= NIOS ; ++i) {
	339	if(toklen==(int)strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname)) {
	340	if(ioc[i].iotype & mask)
	341	return(i);
	342	else found = i;
	343	}
	344	}
	345
	346	if(found)
	347	err1("invalid control %s for statement", ioc[found].iocname);
	348	else
	349	err1("unknown iocontrol %s", varstr(toklen, token) );
	350	return(IOSBAD);
	351	}
	352
	353	void
	354	ioclause(n, p)
	355	register int n;
	356	register bigptr p;
	357	{
	358	struct ioclist *iocp;
	359
	360	++nioctl;
	361	if(n == IOSBAD)
	362	return;
	363	if(n == IOSPOSITIONAL)
	364	{
	365	if(nioctl > IOSFMT)
	366	{
	367	err("illegal positional iocontrol");
	368	return;
	369	}
	370	n = nioctl;
	371	}
	372
	373	if(p == NULL)
	374	{
	375	if(n == IOSUNIT)
	376	p = (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
	377	else if(n != IOSFMT)
	378	{
	379	err("illegal * iocontrol");
	380	return;
	381	}
	382	}
	383	if(n == IOSFMT)
	384	ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
	385
	386	iocp = & ioc[n];
	387	if(iocp->iocval == NULL)
	388	{
	389	p = cpexpr(p);
	390	if(n!=IOSFMT && ( n!=IOSUNIT \|\| (p!=NULL && p->vtype!=TYCHAR) ) )
	391	p = fixtype(p);
	392	iocp->iocval = p;
	393	}
	394	else
	395	err1("iocontrol %s repeated", iocp->iocname);
	396	}
	397
	398	/* io list item */
	399	void
	400	doio(list)
	401	chainp list;
	402	{
	403	doiolist(list);
	404	ioroutine[0] = 'e';
	405	putiocall( call0(TYINT, ioroutine) );
	406	frexpr(IOSTP);
	407	}
	408
	409
	410
	411
	412
	413	LOCAL void doiolist(p0)
	414	chainp p0;
	415	{
	416	chainp p;
	417	register bigptr q;
	418	register bigptr qe;
	419	register struct bigblock *qn;
	420	struct bigblock *tp;
	421	int range;
	422
	423	for (p = p0 ; p ; p = p->chain.nextp)
	424	{
	425	q = p->chain.datap;
	426	if(q->tag == TIMPLDO)
	427	{
	428	exdo(range=newlabel(), (chainp)q->b_impldo.varnp);
	429	doiolist(q->b_impldo.datalist);
	430	enddo(range);
	431	ckfree(q);
	432	}
	433	else {
	434	if(q->tag==TPRIM && q->b_prim.argsp==NULL && q->b_prim.namep->b_name.vdim!=NULL)
	435	{
	436	vardcl(qn = q->b_prim.namep);
	437	if(qn->b_name.vdim->nelt)
	438	putio( fixtype(cpexpr(qn->b_name.vdim->nelt)),
	439	mkscalar(qn) );
	440	else
	441	err("attempt to i/o array of unknown size");
	442	}
	443	else if(q->tag==TPRIM && q->b_prim.argsp==NULL && (qe = memversion(q->b_prim.namep)) )
	444	putio(MKICON(1),qe);
	445	else if( (qe = fixtype(cpexpr(q)))->tag==TADDR)
	446	putio(MKICON(1), qe);
	447	else if(qe->vtype != TYERROR)
	448	{
	449	if(iostmt == IOWRITE)
	450	{
	451	tp = fmktemp(qe->vtype, qe->vleng);
	452	puteq( cpexpr(tp), qe);
	453	putio(MKICON(1), tp);
	454	}
	455	else
	456	err("non-left side in READ list");
	457	}
	458	frexpr(q);
	459	}
	460	}
	461	frchain( &p0 );
	462	}
	463
	464
	465
	466
	467
	468	LOCAL void
	469	putio(nelt, addr)
	470	bigptr nelt;
	471	register bigptr addr;
	472	{
	473	int type;
	474	register struct bigblock *q;
	475
	476	type = addr->vtype;
	477	if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
	478	{
	479	nelt = mkexpr(OPSTAR, MKICON(2), nelt);
	480	type -= (TYCOMPLEX-TYREAL);
	481	}
	482
	483	/* pass a length with every item. for noncharacter data, fake one */
	484	if(type != TYCHAR)
	485	{
	486	if( ISCONST(addr) )
	487	addr = putconst(addr);
	488	addr->vtype = TYCHAR;
	489	addr->vleng = MKICON( typesize[type] );
	490	}
	491
	492	nelt = fixtype( mkconv(TYLENG,nelt) );
	493	if(ioformatted == LISTDIRECTED)
	494	q = call3(TYINT, "do_lio", mkconv(TYLONG, MKICON(type)), nelt, addr);
	495	else
	496	q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
	497	nelt, addr);
	498	putiocall(q);
	499	}
	500
	501
	502
	503	void
	504	endio()
	505	{
	506	if(skiplab)
	507	{
	508	putlabel(skiplab);
	509	if(ioendlab)
	510	putif( mkexpr(OPGE, cpexpr(IOSTP), MKICON(0)), ioendlab);
	511	if(ioerrlab)
	512	putif( mkexpr( ( (iostmt==IOREAD\|\|iostmt==IOWRITE) ? OPLE : OPEQ),
	513	cpexpr(IOSTP), MKICON(0)) , ioerrlab);
	514	}
	515	if(IOSTP)
	516	frexpr(IOSTP);
	517	}
	518
	519
	520
	521	LOCAL void
	522	putiocall(q)
	523	register struct bigblock *q;
	524	{
	525	if(IOSTP)
	526	{
	527	q->vtype = TYINT;
	528	q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
	529	}
	530
	531	if(jumplab)
	532	putif( mkexpr(OPEQ, q, MKICON(0) ), jumplab);
	533	else
	534	putexpr(q);
	535	}
	536
	537
	538
	539	void
	540	startrw()
	541	{
	542	register bigptr p;
	543	register struct bigblock *np;
	544	register struct bigblock unitp, nump;
	545	int k, fmtoff;
	546	int intfile, sequential;
	547
	548
	549	sequential = YES;
	550	if((p = V(IOSREC))) {
	551	if( ISINT(p->vtype) )
	552	{
	553	ioset(TYIOINT, XREC, cpexpr(p) );
	554	sequential = NO;
	555	}
	556	else
	557	err("bad REC= clause");
	558	}
	559
	560	intfile = NO;
	561	if((p = V(IOSUNIT)))
	562	{
	563	if( ISINT(p->vtype) )
	564	ioset(TYIOINT, XUNIT, cpexpr(p) );
	565	else if(p->vtype == TYCHAR)
	566	{
	567	intfile = YES;
	568	if(p->tag==TPRIM && p->b_prim.argsp==NULL && (np = p->b_prim.namep)->b_name.vdim!=NULL)
	569	{
	570	vardcl(np);
	571	if(np->b_name.vdim->nelt)
	572	nump = cpexpr(np->b_name.vdim->nelt);
	573	else
	574	{
	575	err("attempt to use internal unit array of unknown size");
	576	nump = MKICON(1);
	577	}
	578	unitp = mkscalar(np);
	579	}
	580	else {
	581	nump = MKICON(1);
	582	unitp = fixtype(cpexpr(p));
	583	}
	584	ioset(TYIOINT, XRNUM, nump);
	585	ioset(TYIOINT, XRLEN, cpexpr(unitp->vleng) );
	586	ioset(TYADDR, XUNIT, addrof(unitp) );
	587	}
	588	}
	589	else
	590	err("bad unit specifier");
	591
	592	if(iostmt == IOREAD)
	593	ioset(TYIOINT, (intfile ? XIEND : XEND), MKICON(endbit) );
	594
	595	fmtoff = (intfile ? XIFMT : XFMT);
	596
	597	if((p = V(IOSFMT)))
	598	{
	599	if(p->tag==TPRIM && p->b_prim.argsp==NULL)
	600	{
	601	vardcl(np = p->b_prim.namep);
	602	if(np->b_name.vdim)
	603	{
	604	ioset(TYADDR, fmtoff, addrof(mkscalar(np)) );
	605	goto endfmt;
	606	}
	607	if( ISINT(np->vtype) )
	608	{
	609	ioset(TYADDR, fmtoff, cpexpr(p));
	610	goto endfmt;
	611	}
	612	}
	613	p = V(IOSFMT) = fixtype(p);
	614	if(p->vtype == TYCHAR)
	615	ioset(TYADDR, fmtoff, addrof(cpexpr(p)) );
	616	else if( ISICON(p) )
	617	{
	618	if( (k = fmtstmt( mklabel(p->b_const.fconst.ci) )) > 0 )
	619	ioset(TYADDR, fmtoff, mkaddcon(k) );
	620	else
	621	ioformatted = UNFORMATTED;
	622	}
	623	else {
	624	err("bad format descriptor");
	625	ioformatted = UNFORMATTED;
	626	}
	627	}
	628	else
	629	ioset(TYADDR, fmtoff, MKICON(0) );
	630
	631	endfmt:
	632
	633
	634	ioroutine[0] = 's';
	635	ioroutine[1] = '_';
	636	ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
	637	ioroutine[3] = (sequential ? 's' : 'd');
	638	ioroutine[4] = "ufl" [ioformatted];
	639	ioroutine[5] = (intfile ? 'i' : 'e');
	640	ioroutine[6] = '\0';
	641	putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
	642	}
	643
	644
	645
	646	LOCAL void dofopen()
	647	{
	648	register bigptr p;
	649
	650	if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
	651	ioset(TYIOINT, XUNIT, cpexpr(p) );
	652	else
	653	err("bad unit in open");
	654	if( (p = V(IOSFILE)) && p->vtype==TYCHAR)
	655	{
	656	ioset(TYIOINT, XFNAMELEN, cpexpr(p->vleng) );
	657	iosetc(XFNAME, p);
	658	}
	659	else
	660	err("bad file in open");
	661
	662	if((p = V(IOSRECL)))
	663	if( ISINT(p->vtype) )
	664	ioset(TYIOINT, XRECLEN, cpexpr(p) );
	665	else
	666	err("bad recl");
	667	else
	668	ioset(TYIOINT, XRECLEN, MKICON(0) );
	669
	670	iosetc(XSTATUS, V(IOSSTATUS));
	671	iosetc(XACCESS, V(IOSACCESS));
	672	iosetc(XFORMATTED, V(IOSFORM));
	673	iosetc(XBLANK, V(IOSBLANK));
	674
	675	putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
	676	}
	677
	678
	679	LOCAL void
	680	dofclose()
	681	{
	682	register bigptr p;
	683
	684	if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
	685	{
	686	ioset(TYIOINT, XUNIT, cpexpr(p) );
	687	iosetc(XCLSTATUS, V(IOSSTATUS));
	688	putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
	689	}
	690	else
	691	err("bad unit in close statement");
	692	}
	693
	694
	695	LOCAL void dofinquire()
	696	{
	697	register bigptr p;
	698	if((p = V(IOSUNIT)))
	699	{
	700	if( V(IOSFILE) )
	701	err("inquire by unit or by file, not both");
	702	ioset(TYIOINT, XUNIT, cpexpr(p) );
	703	}
	704	else if( ! V(IOSFILE) )
	705	err("must inquire by unit or by file");
	706	iosetlc(IOSFILE, XFILE, XFILELEN);
	707	iosetip(IOSEXISTS, XEXISTS);
	708	iosetip(IOSOPENED, XOPEN);
	709	iosetip(IOSNUMBER, XNUMBER);
	710	iosetip(IOSNAMED, XNAMED);
	711	iosetlc(IOSNAME, XNAME, XNAMELEN);
	712	iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
	713	iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
	714	iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
	715	iosetlc(IOSFORM, XFORM, XFORMLEN);
	716	iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
	717	iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
	718	iosetip(IOSRECL, XQRECL);
	719	iosetip(IOSNEXTREC, XNEXTREC);
	720
	721	putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) ));
	722	}
	723
	724
	725
	726	LOCAL void
	727	dofmove(subname)
	728	char *subname;
	729	{
	730	register bigptr p;
	731
	732	if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
	733	{
	734	ioset(TYIOINT, XUNIT, cpexpr(p) );
	735	putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
	736	}
	737	else
	738	err("bad unit in move statement");
	739	}
	740
	741
	742
	743	LOCAL void
	744	ioset(type, offset, p)
	745	int type, offset;
	746	bigptr p;
	747	{
	748	register struct bigblock *q;
	749
	750	q = cpexpr(ioblkp);
	751	q->vtype = type;
	752	q->b_addr.memoffset = fixtype( mkexpr(OPPLUS, q->b_addr.memoffset, MKICON(offset)) );
	753	puteq(q, p);
	754	}
	755
	756
	757
	758
	759	LOCAL void
	760	iosetc(offset, p)
	761	int offset;
	762	register bigptr p;
	763	{
	764	if(p == NULL)
	765	ioset(TYADDR, offset, MKICON(0) );
	766	else if(p->vtype == TYCHAR)
	767	ioset(TYADDR, offset, addrof(cpexpr(p) ));
	768	else
	769	err("non-character control clause");
	770	}
	771
	772
	773
	774	LOCAL void
	775	iosetip(i, offset)
	776	int i, offset;
	777	{
	778	register bigptr p;
	779
	780	if((p = V(i))) {
	781	if(p->tag==TADDR && ONEOF(p->vtype, M(TYLONG)\|M(TYLOGICAL)) )
	782	ioset(TYADDR, offset, addrof(cpexpr(p)) );
	783	else
	784	err1("impossible inquire parameter %s", ioc[i].iocname);
	785	} else
	786	ioset(TYADDR, offset, MKICON(0) );
	787	}
	788
	789
	790
	791	LOCAL void
	792	iosetlc(i, offp, offl)
	793	int i, offp, offl;
	794	{
	795	register bigptr p;
	796	if( (p = V(i)) && p->vtype==TYCHAR)
	797	ioset(TYIOINT, offl, cpexpr(p->vleng) );
	798	iosetc(offp, p);
	799	}

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

Download in other formats: