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

/*-
 * Copyright (c) 1980 The Regents of the University of California.
 * All rights reserved.
 *
 * %sccs.include.redist.c%
 */

#ifndef lint
static char sccsid[] = "@(#)type.c	5.2 (Berkeley) %G%";
#endif /* not lint */

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

/*
 * Type declaration part
 */
/*ARGSUSED*/
typebeg( lineofytype , r )
    int	lineofytype;
{
    static bool	type_order = FALSE;
    static bool	type_seen = FALSE;

/*
 * this 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();
	line = lineofytype;
	if ( parts[ cbn ] & ( VPRT | RPRT ) ) {
	    if ( opt( 's' ) ) {
		standard();
		error("Type declarations should precede var and routine declarations");
	    } else {
		if ( !type_order ) {
		    type_order = TRUE;
		    warning();
		    error("Type declarations should precede var and routine declarations");
		}
	    }
	}
	if (parts[ cbn ] & TPRT) {
	    if ( opt( 's' ) ) {
		standard();
		error("All types should be declared in one type part");
	    } else {
		if ( !type_seen ) {
		    type_seen = TRUE;
		    warning();
		    error("All types should be declared in one type part");
		}
	    }
	}
	parts[ cbn ] |= 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 struct tnode *tdecl;
{
	register struct nl *np;
	struct nl *tnp;

	np = gtype(tdecl);
	line = tline;
	tnp = defnl(tid, TYPE, np, 0);
#ifndef PI0
	enter(tnp)->nl_flags |= (char) NMOD;
#else
	(void) enter(tnp);
	send(REVTYPE, tline, tid, tdecl);
#endif

#ifdef PC
	if (cbn == 1) {
	    stabgtype(tid, np, line);
	} else {
	    stabltype(tid, np);
	}
#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 struct tnode *r;
{
	register struct nl *np;
	register int oline;
#ifdef OBJ
	long w;
#endif

	if (r == TR_NIL)
		return (NLNIL);
	oline = line;
	if (r->tag != T_ID)
		oline = line = r->lined.line_no;
	switch (r->tag) {
		default:
			panic("type");
		case T_TYID:
			r = (struct tnode *) (&(r->tyid_node.line_no));
		case T_ID:
			np = lookup(r->char_const.cptr);
			if (np == NLNIL)
				break;
			if (np->class != TYPE) {
#ifndef PI1
				error("%s is a %s, not a type as required", r->char_const.cptr, classes[np->class]);
#endif
				np = NLNIL;
				break;
			}
			np = np->type;
			break;
		case T_TYSCAL:
			np = tyscal(r);
			break;
		case T_TYCRANG:
			np = tycrang(r);
			break;
		case T_TYRANG:
			np = tyrang(r);
			break;
		case T_TYPTR:
			np = defnl((char *) 0, PTR, NLNIL, 0 );
			np -> ptr[0] = ((struct nl *) r->ptr_ty.id_node);
			np->nl_next = forechain;
			forechain = np;
			break;
		case T_TYPACK:
			np = gtype(r->comp_ty.type);
			break;
		case T_TYCARY:
		case T_TYARY:
			np = tyary(r);
			break;
		case T_TYREC:
			np = tyrec(r->comp_ty.type, 0);
#			ifdef PTREE
				/*
				 * mung T_TYREC[3] to point to the record
				 * for RecTCopy
				 */
			    r->comp_ty.nl_entry = np;
#			endif
			break;
		case T_TYFILE:
			np = gtype(r->comp_ty.type);
			if (np == NLNIL)
				break;
#ifndef PI1
			if (np->nl_flags & NFILES)
				error("Files cannot be members of files");
#endif
			np = defnl((char *) 0, FILET, np, 0);
			np->nl_flags |= NFILES;
			break;
		case T_TYSET:
			np = gtype(r->comp_ty.type);
			if (np == NLNIL)
				break;
			if (np->type == nl+TDOUBLE) {
#ifndef PI1
				error("Set of real is not allowed");
#endif
				np = NLNIL;
				break;
			}
			if (np->class != RANGE && np->class != SCAL) {
#ifndef PI1
				error("Set type must be range or scalar, not %s", nameof(np));
#endif
				np = NLNIL;
				break;
			}
#ifndef PI1
			if (width(np) > 2)
				error("Implementation restriction: sets must be indexed by 16 bit quantities");
#endif
			np = defnl((char *) 0, SET, np, 0);
			break;
	}
	line = oline;
#ifndef PC
	w = lwidth(np);
	if (w >= TOOMUCH) {
		error("Storage requirement of %s exceeds the implementation limit of %D by %D bytes",
			nameof(np), (char *) (long)(TOOMUCH-1), (char *) (long)(w-TOOMUCH+1));
		np = NLNIL;
	}
#endif
	return (np);
}

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

	np = defnl((char *) 0, SCAL, NLNIL, 0);
	np->type = np;
	v = r->comp_ty.type;
	if (v == TR_NIL)
		return (NLNIL);
	i = -1;
	zp = np;
	for (; v != TR_NIL; v = v->list_node.next) {
		op = enter(defnl((char *) v->list_node.list, 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 for conformant arrays.
 */
struct nl *
tycrang(r)
	register struct tnode *r;
{
	register struct nl *p, *op, *tp;

	tp = gtype(r->crang_ty.type);
	if ( tp == NLNIL )
		return (NLNIL);
	/*
	 * Just make a new type -- the lower and upper bounds must be
	 * set by params().
	 */
	p = defnl ( 0, CRANGE, tp, 0 );
	return(p);
}

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

	gconst(r->rang_ty.const2);
	hp = con.ctype;
	high = con.crval;
	gconst(r->rang_ty.const1);
	lp = con.ctype;
	if (lp == NLNIL || hp == NLNIL)
		return (NLNIL);
	if (norange(lp) || norange(hp))
		return (NLNIL);
	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 (NLNIL);
	}
	if (c == TSCAL && scalar(lp) != scalar(hp)) {
#ifndef PI1
		error("Scalar types must be identical in subranges");
#endif
		return (NLNIL);
	}
	if (con.crval > high) {
#ifndef PI1
		error("Range lower bound exceeds upper bound");
#endif
		return (NLNIL);
	}
	lp = defnl((char *) 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)
	struct tnode *r;
{
	struct nl *np;
	register struct tnode *tl, *s;
	register struct nl *tp, *ltp;
	int i, n;

	s = r;
	/* Count the dimensions */
	for (n = 0; s->tag == T_TYARY || s->tag == T_TYCARY;
					s = s->ary_ty.type, n++)
		/* NULL STATEMENT */;
	tp = gtype(s);
	if (tp == NLNIL)
		return (NLNIL);
	np = defnl((char *) 0, ARRAY, tp, 0);
	np->nl_flags |= (tp->nl_flags) & NFILES;
	ltp = np;
	i = 0;
	for (s = r; s->tag == T_TYARY || s->tag == T_TYCARY;
					s = s->ary_ty.type) {
	    for (tl = s->ary_ty.type_list; tl != TR_NIL; tl=tl->list_node.next){
		tp = gtype(tl->list_node.list);
		if (tp == NLNIL) {
			np = NLNIL;
			continue;
		}
		if ((tp->class == RANGE || tp->class == CRANGE) &&
		    tp->type == nl+TDOUBLE) {
#ifndef PI1
			error("Index type for arrays cannot be real");
#endif
			np = NLNIL;
			continue;
		}
		if (tp->class != RANGE && tp->class != SCAL && tp->class !=CRANGE){
#ifndef PI1
			error("Array index type is a %s, not a range or scalar as required", classes[tp->class]);
#endif
			np = NLNIL;
			continue;
		}
#ifndef PC
		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;
		}
#endif
		if (tp->class != CRANGE)
			tp = nlcopy(tp);
		i++;
		ltp->chain = tp;
		ltp = tp;
	    }
	}
	if (np != NLNIL)
		np->value[0] = i;
	return (np);
}

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

	for (p = forechain; p != NLNIL; p = p->nl_next) {
		if (p->class == PTR && p -> ptr[0] != 0)
		{
			p->type = gtype((struct tnode *) p -> ptr[0]);
#			ifdef PTREE
			{
			    if ( pUSE( p -> inTree ).PtrTType == pNIL ) {
				pPointer	PtrTo = tCopy( p -> ptr[0] );

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