[unix-history] / usr / src / cmd / pi / type.c

/* Copyright (c) 1979 Regents of the University of California */
#
/*
 * pi - Pascal interpreter code translator
 *
 * Charles Haley, Bill Joy UCB
 * Version 1.2 November 1978
 */

#include "whoami"
#include "0.h"
#include "tree.h"

/*
 * Type declaration part
 */
typebeg()
{

#ifndef PI1
	if (parts & VPRT)
		error("Type declarations must precede var declarations");
	if (parts & TPRT)
		error("All types must be declared in one type part");
	parts |= TPRT;
#endif
	/*
	 * Forechain is the head of a list of types that
	 * might be self referential.  We chain them up and
	 * process them later.
	 */
	forechain = NIL;
#ifdef PI0
	send(REVTBEG);
#endif
}

type(tline, tid, tdecl)
	int tline;
	char *tid;
	register int *tdecl;
{
	register struct nl *np;

	np = gtype(tdecl);
	line = tline;
	if (np != NIL && (tdecl[0] == T_ID || tdecl[0] == T_TYID))
		np = nlcopy(np);
#ifndef PI0
	enter(defnl(tid, TYPE, np, 0))->nl_flags |= NMOD;
#else
	enter(defnl(tid, TYPE, np, 0));
	send(REVTYPE, tline, tid, tdecl);
#endif
#	ifdef PTREE
	    {
		pPointer Type = TypeDecl( tid , tdecl );
		pPointer *Types;

		pSeize( PorFHeader[ nesting ] );
		Types = &( pDEF( PorFHeader[ nesting ] ).PorFTypes );
		*Types = ListAppend( *Types , Type );
		pRelease( PorFHeader[ nesting ] );
	    }
#	endif
}

typeend()
{

#ifdef PI0
	send(REVTEND);
#endif
	foredecl();
}
\f
/*
 * Return a type pointer (into the namelist)
 * from a parse tree for a type, building
 * namelist entries as needed.
 */
struct nl *
gtype(r)
	register int *r;
{
	register struct nl *np;
	register char *cp;
	int oline;

	if (r == NIL)
		return (NIL);
	oline = line;
	if (r[0] != T_ID)
		oline = line = r[1];
	switch (r[0]) {
		default:
			panic("type");
		case T_TYID:
			r++;
		case T_ID:
			np = lookup(r[1]);
			if (np == NIL)
				break;
			if (np->class != TYPE) {
#ifndef PI1
				error("%s is a %s, not a type as required", r[1], classes[np->class]);
#endif
				np = NIL;
				break;
			}
			np = np->type;
			break;
		case T_TYSCAL:
			np = tyscal(r);
			break;
		case T_TYRANG:
			np = tyrang(r);
			break;
		case T_TYPTR:
			np = defnl(0, PTR, 0, 0 );
			np -> ptr[0] = r[2];
			np->nl_next = forechain;
			forechain = np;
			break;
		case T_TYPACK:
			np = gtype(r[2]);
			break;
		case T_TYARY:
			np = tyary(r);
			break;
		case T_TYREC:
			np = tyrec(r[2], 0);
#			ifdef PTREE
				/*
				 * mung T_TYREC[3] to point to the record
				 * for RecTCopy
				 */
			    r[3] = np;
#			endif
			break;
		case T_TYFILE:
			np = gtype(r[2]);
			if (np == NIL)
				break;
#ifndef PI1
			if (np->nl_flags & NFILES)
				error("Files cannot be members of files");
#endif
			np = defnl(0, FILET, np, 0);
			np->nl_flags |= NFILES;
			break;
		case T_TYSET:
			np = gtype(r[2]);
			if (np == NIL)
				break;
			if (np->type == nl+TDOUBLE) {
#ifndef PI1
				error("Set of real is not allowed");
#endif
				np = NIL;
				break;
			}
			if (np->class != RANGE && np->class != SCAL) {
#ifndef PI1
				error("Set type must be range or scalar, not %s", nameof(np));
#endif
				np = NIL;
				break;
			}
#ifndef PI1
			if (width(np) > 2)
				error("Implementation restriction: sets must be indexed by 16 bit quantities");
#endif
			np = defnl(0, SET, np, 0);
			break;
	}
	line = oline;
	return (np);
}

/*
 * Scalar (enumerated) types
 */
tyscal(r)
	int *r;
{
	register struct nl *np, *op;
	register *v;
	int i;

	np = defnl(0, SCAL, 0, 0);
	np->type = np;
	v = r[2];
	if (v == NIL)
		return (NIL);
	i = -1;
	for (; v != NIL; v = v[2]) {
		op = enter(defnl(v[1], CONST, np, ++i));
#ifndef PI0
		op->nl_flags |= NMOD;
#endif
		op->value[1] = i;
	}
	np->range[1] = i;
	return (np);
}

/*
 * Declare a subrange.
 */
tyrang(r)
	register int *r;
{
	register struct nl *lp, *hp;
	double high;
	int c, c1;

	gconst(r[3]);
	hp = con.ctype;
	high = con.crval;
	gconst(r[2]);
	lp = con.ctype;
	if (lp == NIL || hp == NIL)
		return (NIL);
	if (norange(lp) || norange(hp))
		return (NIL);
	c = classify(lp);
	c1 = classify(hp);
	if (c != c1) {
#ifndef PI1
		error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp));
#endif
		return (NIL);
	}
	if (c == TSCAL && scalar(lp) != scalar(hp)) {
#ifndef PI1
		error("Scalar types must be identical in subranges");
#endif
		return (NIL);
	}
	if (con.crval > high) {
#ifndef PI1
		error("Range lower bound exceeds upper bound");
#endif
		return (NIL);
	}
	lp = defnl(0, RANGE, hp->type, 0);
	lp->range[0] = con.crval;
	lp->range[1] = high;
	return (lp);
}

norange(p)
	register struct nl *p;
{
	if (isa(p, "d")) {
#ifndef PI1
		error("Subrange of real is not allowed");
#endif
		return (1);
	}
	if (isnta(p, "bcsi")) {
#ifndef PI1
		error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p));
#endif
		return (1);
	}
	return (0);
}

/*
 * Declare arrays and chain together the dimension specification
 */
struct nl *
tyary(r)
	int *r;
{
	struct nl *np;
	register *tl;
	register struct nl *tp, *ltp;
	int i;

	tp = gtype(r[3]);
	if (tp == NIL)
		return (NIL);
	np = defnl(0, ARRAY, tp, 0);
	np->nl_flags |= (tp->nl_flags) & NFILES;
	ltp = np;
	i = 0;
	for (tl = r[2]; tl != NIL; tl = tl[2]) {
		tp = gtype(tl[1]);
		if (tp == NIL) {
			np = NIL;
			continue;
		}
		if (tp->class == RANGE && tp->type == nl+TDOUBLE) {
#ifndef PI1
			error("Index type for arrays cannot be real");
#endif
			np = NIL;
			continue;
		}
		if (tp->class != RANGE && tp->class != SCAL) {
#ifndef PI1
			error("Array index type is a %s, not a range or scalar as required", classes[tp->class]);
#endif
			np = NIL;
			continue;
		}
		if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) {
#ifndef PI1
			error("Value of dimension specifier too large or small for this implementation");
#endif
			continue;
		}
		tp = nlcopy(tp);
		i++;
		ltp->chain = tp;
		ltp = tp;
	}
	if (np != NIL)
		np->value[0] = i;
	return (np);
}

/*
 * Delayed processing for pointers to
 * allow self-referential and mutually
 * recursive pointer constructs.
 */
foredecl()
{
	register struct nl *p, *q;

	for (p = forechain; p != NIL; p = p->nl_next) {
		if (p->class == PTR && p -> ptr[0] != 0)
		{
			p->type = gtype(p -> ptr[0]);
#ifndef PI1
			if (p->type != NIL && ( ( p->type )->nl_flags & NFILES))
				error("Files cannot be members of dynamic structures");
#endif
#			ifdef PTREE
			{
			    if ( pUSE( p -> inTree ).PtrTType == pNIL ) {
				pPointer	PtrTo = tCopy( p -> ptr[0] );

				pDEF( p -> inTree ).PtrTType = PtrTo;
			    }
			}
#			endif
			p -> ptr[0] = 0;
		}
	}
}
Commit	Line	Data
9e6c4af0 CH	1	/* Copyright (c) 1979 Regents of the University of California */
	2	#
	3	/*
	4	* pi - Pascal interpreter code translator
	5	*
	6	* Charles Haley, Bill Joy UCB
	7	* Version 1.2 November 1978
	8	*/
	9
	10	#include "whoami"
	11	#include "0.h"
	12	#include "tree.h"
	13
	14	/*
	15	* Type declaration part
	16	*/
	17	typebeg()
	18	{
	19
	20	#ifndef PI1
	21	if (parts & VPRT)
	22	error("Type declarations must precede var declarations");
	23	if (parts & TPRT)
	24	error("All types must be declared in one type part");
	25	parts \|= TPRT;
	26	#endif
	27	/*
	28	* Forechain is the head of a list of types that
	29	* might be self referential. We chain them up and
	30	* process them later.
	31	*/
	32	forechain = NIL;
	33	#ifdef PI0
	34	send(REVTBEG);
	35	#endif
	36	}
	37
	38	type(tline, tid, tdecl)
	39	int tline;
	40	char *tid;
	41	register int *tdecl;
	42	{
	43	register struct nl *np;
	44
	45	np = gtype(tdecl);
	46	line = tline;
	47	if (np != NIL && (tdecl[0] == T_ID \|\| tdecl[0] == T_TYID))
	48	np = nlcopy(np);
	49	#ifndef PI0
	50	enter(defnl(tid, TYPE, np, 0))->nl_flags \|= NMOD;
	51	#else
	52	enter(defnl(tid, TYPE, np, 0));
	53	send(REVTYPE, tline, tid, tdecl);
	54	#endif
	55	# ifdef PTREE
	56	{
	57	pPointer Type = TypeDecl( tid , tdecl );
	58	pPointer *Types;
	59
	60	pSeize( PorFHeader[ nesting ] );
	61	Types = &( pDEF( PorFHeader[ nesting ] ).PorFTypes );
	62	Types = ListAppend( Types , Type );
	63	pRelease( PorFHeader[ nesting ] );
	64	}
65	# endif
66	}
67
68	typeend()
69	{
70
71	#ifdef PI0
72	send(REVTEND);
73	#endif
74	foredecl();
75	}
76	\f
77	/*
78	* Return a type pointer (into the namelist)
79	* from a parse tree for a type, building
80	* namelist entries as needed.
81	*/
82	struct nl *
83	gtype(r)
84	register int *r;
85	{
86	register struct nl *np;
87	register char *cp;
88	int oline;
89
90	if (r == NIL)
91	return (NIL);
92	oline = line;
93	if (r[0] != T_ID)
94	oline = line = r[1];
95	switch (r[0]) {
96	default:
97	panic("type");
98	case T_TYID:
99	r++;
100	case T_ID:
101	np = lookup(r[1]);
102	if (np == NIL)
103	break;
104	if (np->class != TYPE) {
105	#ifndef PI1
106	error("%s is a %s, not a type as required", r[1], classes[np->class]);
107	#endif
108	np = NIL;
109	break;
110	}
111	np = np->type;
112	break;
113	case T_TYSCAL:
114	np = tyscal(r);
115	break;
116	case T_TYRANG:
117	np = tyrang(r);
118	break;
119	case T_TYPTR:
120	np = defnl(0, PTR, 0, 0 );
121	np -> ptr[0] = r[2];
122	np->nl_next = forechain;
123	forechain = np;
124	break;
125	case T_TYPACK:
126	np = gtype(r[2]);
127	break;
128	case T_TYARY:
129	np = tyary(r);
130	break;
131	case T_TYREC:
132	np = tyrec(r[2], 0);
133	# ifdef PTREE
134	/*
135	* mung T_TYREC[3] to point to the record
136	* for RecTCopy
137	*/
138	r[3] = np;
139	# endif
140	break;
141	case T_TYFILE:
142	np = gtype(r[2]);
143	if (np == NIL)
144	break;
145	#ifndef PI1
146	if (np->nl_flags & NFILES)
147	error("Files cannot be members of files");
148	#endif
149	np = defnl(0, FILET, np, 0);
150	np->nl_flags \|= NFILES;
151	break;
152	case T_TYSET:
153	np = gtype(r[2]);
154	if (np == NIL)
155	break;
156	if (np->type == nl+TDOUBLE) {
157	#ifndef PI1
158	error("Set of real is not allowed");
159	#endif
160	np = NIL;
161	break;
162	}
163	if (np->class != RANGE && np->class != SCAL) {
164	#ifndef PI1
165	error("Set type must be range or scalar, not %s", nameof(np));
166	#endif
167	np = NIL;
168	break;
169	}
170	#ifndef PI1
171	if (width(np) > 2)
172	error("Implementation restriction: sets must be indexed by 16 bit quantities");
173	#endif
174	np = defnl(0, SET, np, 0);
175	break;
176	}
177	line = oline;
178	return (np);
179	}
180
181	/*
182	* Scalar (enumerated) types
183	*/
184	tyscal(r)
185	int *r;
186	{
187	register struct nl np, op;
188	register *v;
189	int i;
190
191	np = defnl(0, SCAL, 0, 0);
192	np->type = np;
193	v = r[2];
194	if (v == NIL)
195	return (NIL);
196	i = -1;
197	for (; v != NIL; v = v[2]) {
198	op = enter(defnl(v[1], CONST, np, ++i));
199	#ifndef PI0
200	op->nl_flags \|= NMOD;
201	#endif
202	op->value[1] = i;
203	}
204	np->range[1] = i;
205	return (np);
206	}
207
208	/*
209	* Declare a subrange.
210	*/
211	tyrang(r)
212	register int *r;
213	{
214	register struct nl lp, hp;
215	double high;
216	int c, c1;
217
218	gconst(r[3]);
219	hp = con.ctype;
220	high = con.crval;
221	gconst(r[2]);
222	lp = con.ctype;
223	if (lp == NIL \|\| hp == NIL)
224	return (NIL);
225	if (norange(lp) \|\| norange(hp))
226	return (NIL);
227	c = classify(lp);
228	c1 = classify(hp);
229	if (c != c1) {
230	#ifndef PI1
231	error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp));
232	#endif
233	return (NIL);
234	}
235	if (c == TSCAL && scalar(lp) != scalar(hp)) {
236	#ifndef PI1
237	error("Scalar types must be identical in subranges");
238	#endif
239	return (NIL);
240	}
241	if (con.crval > high) {
242	#ifndef PI1
243	error("Range lower bound exceeds upper bound");
244	#endif
245	return (NIL);
246	}
247	lp = defnl(0, RANGE, hp->type, 0);
248	lp->range[0] = con.crval;
249	lp->range[1] = high;
250	return (lp);
251	}
252
253	norange(p)
254	register struct nl *p;
255	{
256	if (isa(p, "d")) {
257	#ifndef PI1
258	error("Subrange of real is not allowed");
259	#endif
260	return (1);
261	}
262	if (isnta(p, "bcsi")) {
263	#ifndef PI1
264	error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p));
265	#endif
266	return (1);
267	}
268	return (0);
269	}
270
271	/*
272	* Declare arrays and chain together the dimension specification
273	*/
274	struct nl *
275	tyary(r)
276	int *r;
277	{
278	struct nl *np;
279	register *tl;
280	register struct nl tp, ltp;
281	int i;
282
283	tp = gtype(r[3]);
284	if (tp == NIL)
285	return (NIL);
286	np = defnl(0, ARRAY, tp, 0);
287	np->nl_flags \|= (tp->nl_flags) & NFILES;
288	ltp = np;
289	i = 0;
290	for (tl = r[2]; tl != NIL; tl = tl[2]) {
291	tp = gtype(tl[1]);
292	if (tp == NIL) {
293	np = NIL;
294	continue;
295	}
296	if (tp->class == RANGE && tp->type == nl+TDOUBLE) {
297	#ifndef PI1
298	error("Index type for arrays cannot be real");
299	#endif
300	np = NIL;
301	continue;
302	}
303	if (tp->class != RANGE && tp->class != SCAL) {
304	#ifndef PI1
305	error("Array index type is a %s, not a range or scalar as required", classes[tp->class]);
306	#endif
307	np = NIL;
308	continue;
309	}
310	if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) {
311	#ifndef PI1
312	error("Value of dimension specifier too large or small for this implementation");
313	#endif
314	continue;
315	}
316	tp = nlcopy(tp);
317	i++;
318	ltp->chain = tp;
319	ltp = tp;
320	}
321	if (np != NIL)
322	np->value[0] = i;
323	return (np);
324	}
325
326	/*
327	* Delayed processing for pointers to
328	* allow self-referential and mutually
329	* recursive pointer constructs.
330	*/
331	foredecl()
332	{
333	register struct nl p, q;
334
335	for (p = forechain; p != NIL; p = p->nl_next) {
336	if (p->class == PTR && p -> ptr[0] != 0)
337	{
338	p->type = gtype(p -> ptr[0]);
339	#ifndef PI1
340	if (p->type != NIL && ( ( p->type )->nl_flags & NFILES))
341	error("Files cannot be members of dynamic structures");
342	#endif
343	# ifdef PTREE
344	{
345	if ( pUSE( p -> inTree ).PtrTType == pNIL ) {
346	pPointer PtrTo = tCopy( p -> ptr[0] );
347
348	pDEF( p -> inTree ).PtrTType = PtrTo;
349	}
350	}
351	# endif
352	p -> ptr[0] = 0;
353	}
354	}
355	}