[unix-history] / usr / src / usr.bin / pascal / src / type.c

/* Copyright (c) 1979 Regents of the University of California */

static	char sccsid[] = "@(#)type.c 1.1 %G%";

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

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

/*
 * PC allows for multiple
 * declaration parts unless
 * standard option has been
 * specified.
 * If routine segment is being
 * compiled, do level one processing.
 */

#ifndef PI1
if (!progseen)
	level1();
#ifdef PC
   if (opt('s')) {
	if (parts & VPRT) {
		standard();
		error("Type declarations must precede var declarations");
	}
	if (parts & TPRT) {
		standard();
		error("All types must be declared in one type part");
	}
   }
#endif PC
#ifdef OBJ
	if (parts & VPRT)
		error("Type declarations must precede var declarations");
	if (parts & TPRT)
		error("All types must be declared in one type part");
#endif OBJ
	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;
#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 PC
	if (cbn == 1)
		stabtname( tid );
#endif PC

#	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;
	register int oline, w;

	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;
	w = lwidth(np);
	if (w >= TOOMUCH) {
		error("Storage requirement of %s exceeds the implementation limit of %d by %d bytes",
			nameof(np), TOOMUCH-1, w-TOOMUCH+1);
		np = NIL;
	}
	return (np);
}

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

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