xref: /csrg-svn/usr.bin/pascal/src/clas.c (revision 14728)
1747Speter /* Copyright (c) 1979 Regents of the University of California */
2747Speter 
3*14728Sthien #ifndef lint
4*14728Sthien static	char sccsid[] = "@(#)clas.c 1.7 08/19/83";
5*14728Sthien #endif
6747Speter 
7747Speter #include "whoami.h"
8747Speter #include "0.h"
9747Speter #include "tree.h"
10*14728Sthien #include "tree_ty.h"
11747Speter 
12747Speter /*
13747Speter  * This is the array of class
14747Speter  * names for the classes returned
15747Speter  * by classify.  The order of the
16747Speter  * classes is the same as the base
17747Speter  * of the namelist, with special
18747Speter  * negative index entries for structures,
19747Speter  * scalars, pointers, sets and strings
20747Speter  * to be collapsed into.
21747Speter  */
22747Speter char	*clnxxxx[] =
23747Speter {
24747Speter 	"file",			/* -7	TFILE */
25747Speter 	"record",		/* -6	TREC */
26747Speter 	"array",		/* -5	TARY */
27747Speter 	"scalar",		/* -4	TSCAL */
28747Speter 	"pointer",		/* -3	TPTR */
29747Speter 	"set",			/* -2	TSET */
30747Speter 	"string",		/* -1	TSTR */
31747Speter 	"SNARK",		/*  0	NIL */
32747Speter 	"Boolean",		/*  1	TBOOL */
33747Speter 	"char",			/*  2	TCHAR */
34747Speter 	"integer",		/*  3	TINT */
35747Speter 	"real",			/*  4	TREAL */
36747Speter 	"\"nil\"",		/*  5	TNIL */
37747Speter };
38747Speter 
39747Speter char **clnames	= &clnxxxx[-(TFIRST)];
40747Speter 
41747Speter /*
42747Speter  * Classify takes a pointer
43747Speter  * to a type and returns one
44747Speter  * of several interesting group
45747Speter  * classifications for easy use.
46747Speter  */
47747Speter classify(p1)
48747Speter 	struct nl *p1;
49747Speter {
50747Speter 	register struct nl *p;
51747Speter 
52747Speter 	p = p1;
53747Speter swit:
54*14728Sthien 	if (p == NLNIL) {
55747Speter 		nocascade();
56747Speter 		return (NIL);
57747Speter 	}
58747Speter 	if (p == &nl[TSTR])
59747Speter 		return (TSTR);
60747Speter 	if ( p == &nl[ TSET ] ) {
61747Speter 	    return TSET;
62747Speter 	}
63747Speter 	switch (p->class) {
64747Speter 		case PTR:
65747Speter 			return (TPTR);
66747Speter 		case ARRAY:
67747Speter 			if (p->type == nl+T1CHAR)
68747Speter 				return (TSTR);
69747Speter 			return (TARY);
70747Speter 		case STR:
71747Speter 			return (TSTR);
72747Speter 		case SET:
73747Speter 			return (TSET);
74747Speter 		case RANGE:
75747Speter 			p = p->type;
76747Speter 			goto swit;
77747Speter 		case TYPE:
78747Speter 			if (p <= nl+TLAST)
79747Speter 				return (p - nl);
80747Speter 			panic("clas2");
81747Speter 		case FILET:
82747Speter 			return (TFILE);
83747Speter 		case RECORD:
84747Speter 			return (TREC);
85747Speter 		case SCAL:
86747Speter 			return (TSCAL);
87747Speter 		default:
88*14728Sthien 			{
89*14728Sthien 			    panic("clas");
90*14728Sthien 			    return(NIL);
91*14728Sthien 			}
92747Speter 	}
93747Speter }
94747Speter 
95747Speter #ifndef	PI0
96747Speter /*
97747Speter  * Is p a text file?
98747Speter  */
99747Speter text(p)
100747Speter 	struct nl *p;
101747Speter {
102747Speter 
103747Speter 	return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
104747Speter }
105747Speter #endif
106747Speter 
107747Speter /*
108747Speter  * Scalar returns a pointer to
109747Speter  * the the base scalar type of
110747Speter  * its argument if its argument
111747Speter  * is a SCALar else NIL.
112747Speter  */
113*14728Sthien struct nl *
114747Speter scalar(p1)
115747Speter 	struct nl *p1;
116747Speter {
117747Speter 	register struct nl *p;
118747Speter 
119747Speter 	p = p1;
120*14728Sthien 	if (p == NLNIL)
121*14728Sthien 		return (NLNIL);
122747Speter 	if (p->class == RANGE)
123747Speter 		p = p->type;
124*14728Sthien 	if (p == NLNIL)
125*14728Sthien 		return (NLNIL);
126*14728Sthien 	return (p->class == SCAL ? p : NLNIL);
127747Speter }
128747Speter 
129747Speter /*
130747Speter  * Isa tells whether p
131747Speter  * is one of a group of
132747Speter  * namelist classes.  The
133747Speter  * classes wanted are specified
134747Speter  * by the characters in s.
135747Speter  * (Note that s would more efficiently,
136747Speter  * if less clearly, be given by a mask.)
137747Speter  */
138747Speter isa(p, s)
139747Speter 	register struct nl *p;
140747Speter 	char *s;
141747Speter {
142747Speter 	register i;
143747Speter 	register char *cp;
144747Speter 
145747Speter 	if (p == NIL)
146747Speter 		return (NIL);
147747Speter 	/*
148747Speter 	 * map ranges down to
149747Speter 	 * the base type
150747Speter 	 */
151747Speter 	if (p->class == RANGE)
152747Speter 		p = p->type;
153747Speter 	/*
154747Speter 	 * the following character/class
155747Speter 	 * associations are made:
156747Speter 	 *
157747Speter 	 *	s	scalar
158747Speter 	 *	b	Boolean
159747Speter 	 *	c	character
160747Speter 	 *	i	integer
161747Speter 	 *	d	double (real)
162747Speter 	 *	t	set
163747Speter 	 */
164747Speter 	switch (p->class) {
165747Speter 		case SET:
166747Speter 			i = TDOUBLE+1;
167747Speter 			break;
168747Speter 		case SCAL:
169747Speter 			i = 0;
170747Speter 			break;
171747Speter 		default:
172747Speter 			i = p - nl;
173747Speter 	}
174747Speter 	if (i >= 0 && i <= TDOUBLE+1) {
175747Speter 		i = "sbcidt"[i];
176747Speter 		cp = s;
177747Speter 		while (*cp)
178747Speter 			if (*cp++ == i)
179747Speter 				return (1);
180747Speter 	}
181747Speter 	return (NIL);
182747Speter }
183747Speter 
184747Speter /*
185747Speter  * Isnta is !isa
186747Speter  */
187747Speter isnta(p, s)
188*14728Sthien     struct nl *p;
189*14728Sthien     char *s;
190747Speter {
191747Speter 
192747Speter 	return (!isa(p, s));
193747Speter }
194747Speter 
195747Speter /*
196747Speter  * "shorthand"
197747Speter  */
198*14728Sthien char *
199747Speter nameof(p)
200*14728Sthien struct nl *p;
201747Speter {
202747Speter 
203747Speter 	return (clnames[classify(p)]);
204747Speter }
205747Speter 
206747Speter #ifndef PI0
207*14728Sthien /* find out for sure what kind of node this is being passed
208*14728Sthien    possibly several different kinds of node are passed to it */
209*14728Sthien int nowexp(r)
210*14728Sthien 	struct tnode *r;
211747Speter {
212*14728Sthien 	if (r->tag == T_WEXP) {
213*14728Sthien 		if (r->var_node.cptr == NIL)
214747Speter 			error("Oct/hex allowed only on writeln/write calls");
215747Speter 		else
216747Speter 			error("Width expressions allowed only in writeln/write calls");
217747Speter 		return (1);
218747Speter 	}
219747Speter 	return (NIL);
220747Speter }
221747Speter #endif
2223276Smckusic 
2233276Smckusic     /*
2243825Speter      *	is a variable a local, a formal parameter, or a global?
2253276Smckusic      *	all this from just the offset:
2263825Speter      *	    globals are at levels 0 or 1
2273276Smckusic      *	    positives are parameters
2283276Smckusic      *	    negative evens are locals
2293276Smckusic      */
230*14728Sthien /*ARGSUSED*/
231*14728Sthien whereis( offset , other_flags )
2323825Speter     int		offset;
2337920Smckusick     char	other_flags;
2343276Smckusic {
2353276Smckusic 
2363825Speter #   ifdef OBJ
2373825Speter 	return ( offset >= 0 ? PARAMVAR : LOCALVAR );
2383825Speter #   endif OBJ
2393825Speter #   ifdef PC
2409127Smckusick 	switch ( other_flags & ( NGLOBAL | NPARAM | NLOCAL | NNLOCAL) ) {
241*14728Sthien 	    default:
242*14728Sthien 		panic( "whereis" );
2433825Speter 	    case NGLOBAL:
2443825Speter 		return GLOBALVAR;
2453825Speter 	    case NPARAM:
2463825Speter 		return PARAMVAR;
2479127Smckusick 	    case NNLOCAL:
2489127Smckusick 		return NAMEDLOCALVAR;
2493825Speter 	    case NLOCAL:
2503825Speter 		return LOCALVAR;
2513825Speter 	}
2523825Speter #   endif PC
2533276Smckusic }
254