xref: /csrg-svn/usr.bin/pascal/src/const.c (revision 18345)
1748Speter /* Copyright (c) 1979 Regents of the University of California */
2748Speter 
3*18345Smckusick #ifndef lint
4*18345Smckusick static	char sccsid[] = "@(#)const.c 2.2 03/15/85";
5*18345Smckusick #endif
6748Speter 
7748Speter #include "whoami.h"
8748Speter #include "0.h"
9748Speter #include "tree.h"
10*18345Smckusick #include "tree_ty.h"
11748Speter 
12748Speter /*
13748Speter  * Const enters the definitions
14748Speter  * of the constant declaration
15748Speter  * part into the namelist.
16748Speter  */
17748Speter #ifndef PI1
18*18345Smckusick constbeg( lineofyconst )
197951Speter     int	lineofyconst;
20748Speter {
217951Speter     static bool	const_order = FALSE;
227951Speter     static bool	const_seen = FALSE;
23748Speter 
24748Speter /*
25834Speter  * this allows for multiple declaration
26748Speter  * parts, unless the "standard" option
27748Speter  * has been specified.
28748Speter  * If a routine segment is being compiled,
29748Speter  * do level one processing.
30748Speter  */
31748Speter 
32748Speter 	if (!progseen)
33748Speter 		level1();
347951Speter 	line = lineofyconst;
35834Speter 	if (parts[ cbn ] & (TPRT|VPRT|RPRT)) {
36834Speter 	    if ( opt( 's' ) ) {
37834Speter 		standard();
387951Speter 		error("Constant declarations should precede type, var and routine declarations");
39834Speter 	    } else {
407951Speter 		if ( !const_order ) {
417951Speter 		    const_order = TRUE;
427951Speter 		    warning();
437951Speter 		    error("Constant declarations should precede type, var and routine declarations");
447951Speter 		}
45834Speter 	    }
46834Speter 	}
47834Speter 	if (parts[ cbn ] & CPRT) {
48834Speter 	    if ( opt( 's' ) ) {
49834Speter 		standard();
507951Speter 		error("All constants should be declared in one const part");
51834Speter 	    } else {
527951Speter 		if ( !const_seen ) {
537951Speter 		    const_seen = TRUE;
547951Speter 		    warning();
557951Speter 		    error("All constants should be declared in one const part");
567951Speter 		}
57834Speter 	    }
58834Speter 	}
59834Speter 	parts[ cbn ] |= CPRT;
60748Speter }
61748Speter #endif PI1
62748Speter 
63748Speter const(cline, cid, cdecl)
64748Speter 	int cline;
65748Speter 	register char *cid;
66*18345Smckusick 	register struct tnode *cdecl;
67748Speter {
68748Speter 	register struct nl *np;
69748Speter 
70748Speter #ifdef PI0
71748Speter 	send(REVCNST, cline, cid, cdecl);
72748Speter #endif
73748Speter 	line = cline;
74748Speter 	gconst(cdecl);
75748Speter 	np = enter(defnl(cid, CONST, con.ctype, con.cival));
76748Speter #ifndef PI0
77748Speter 	np->nl_flags |= NMOD;
78748Speter #endif
79748Speter 
80748Speter #ifdef PC
81825Speter 	if (cbn == 1) {
82840Speter 	    stabgconst( cid , line );
83825Speter 	}
84748Speter #endif PC
85748Speter 
86748Speter #	ifdef PTREE
87748Speter 	    {
88748Speter 		pPointer	Const = ConstDecl( cid , cdecl );
89748Speter 		pPointer	*Consts;
90748Speter 
91748Speter 		pSeize( PorFHeader[ nesting ] );
92748Speter 		Consts = &( pDEF( PorFHeader[ nesting ] ).PorFConsts );
93748Speter 		*Consts = ListAppend( *Consts , Const );
94748Speter 		pRelease( PorFHeader[ nesting ] );
95748Speter 	    }
96748Speter #	endif
97748Speter 	if (con.ctype == NIL)
98748Speter 		return;
99748Speter 	if ( con.ctype == nl + TSTR )
100*18345Smckusick 		np->ptr[0] = (struct nl *) con.cpval;
101748Speter 	if (isa(con.ctype, "i"))
102748Speter 		np->range[0] = con.crval;
103748Speter 	else if (isa(con.ctype, "d"))
104748Speter 		np->real = con.crval;
10518344Smckusick #       ifdef PC
10618344Smckusick 	    if (cbn == 1 && con.ctype != NIL) {
10718344Smckusick 		    stabconst(np);
10818344Smckusick 	    }
10918344Smckusick #       endif
110748Speter }
111748Speter 
112748Speter #ifndef PI0
113748Speter #ifndef PI1
114748Speter constend()
115748Speter {
116748Speter 
117748Speter }
118748Speter #endif
119748Speter #endif
120748Speter 
121748Speter /*
122748Speter  * Gconst extracts
123748Speter  * a constant declaration
124748Speter  * from the tree for it.
125748Speter  * only types of constants
126748Speter  * are integer, reals, strings
127748Speter  * and scalars, the first two
128748Speter  * being possibly signed.
129748Speter  */
130*18345Smckusick gconst(c_node)
131*18345Smckusick 	struct tnode *c_node;
132748Speter {
133748Speter 	register struct nl *np;
134*18345Smckusick 	register struct tnode *cn;
135748Speter 	char *cp;
136748Speter 	int negd, sgnd;
137748Speter 	long ci;
138748Speter 
139748Speter 	con.ctype = NIL;
140*18345Smckusick 	cn = c_node;
141748Speter 	negd = sgnd = 0;
142748Speter loop:
143*18345Smckusick 	if (cn == TR_NIL || cn->sign_const.number == TR_NIL)
144*18345Smckusick 		return;
145*18345Smckusick 	switch (cn->tag) {
146748Speter 		default:
147748Speter 			panic("gconst");
148748Speter 		case T_MINUSC:
149748Speter 			negd = 1 - negd;
150748Speter 		case T_PLUSC:
151748Speter 			sgnd++;
152*18345Smckusick 			cn = cn->sign_const.number;
153748Speter 			goto loop;
154748Speter 		case T_ID:
155*18345Smckusick 			np = lookup(cn->char_const.cptr);
156*18345Smckusick 			if (np == NLNIL)
157748Speter 				return;
158748Speter 			if (np->class != CONST) {
159*18345Smckusick 				derror("%s is a %s, not a constant as required", cn->char_const.cptr, classes[np->class]);
160748Speter 				return;
161748Speter 			}
162748Speter 			con.ctype = np->type;
163748Speter 			switch (classify(np->type)) {
164748Speter 				case TINT:
165748Speter 					con.crval = np->range[0];
166748Speter 					break;
167748Speter 				case TDOUBLE:
168748Speter 					con.crval = np->real;
169748Speter 					break;
170748Speter 				case TBOOL:
171748Speter 				case TCHAR:
172748Speter 				case TSCAL:
173748Speter 					con.cival = np->value[0];
174748Speter 					con.crval = con.cival;
175748Speter 					break;
176748Speter 				case TSTR:
177*18345Smckusick 					con.cpval = (char *) np->ptr[0];
178748Speter 					break;
179748Speter 				case NIL:
180748Speter 					con.ctype = NIL;
181748Speter 					return;
182748Speter 				default:
183748Speter 					panic("gconst2");
184748Speter 			}
185748Speter 			break;
186748Speter 		case T_CBINT:
187*18345Smckusick 			con.crval = a8tol(cn->char_const.cptr);
188748Speter 			goto restcon;
189748Speter 		case T_CINT:
190*18345Smckusick 			con.crval = atof(cn->char_const.cptr);
191748Speter 			if (con.crval > MAXINT || con.crval < MININT) {
192748Speter 				derror("Constant too large for this implementation");
193748Speter 				con.crval = 0;
194748Speter 			}
195748Speter restcon:
196748Speter 			ci = con.crval;
197748Speter #ifndef PI0
198748Speter 			if (bytes(ci, ci) <= 2)
199748Speter 				con.ctype = nl+T2INT;
200748Speter 			else
201748Speter #endif
202748Speter 				con.ctype = nl+T4INT;
203748Speter 			break;
204748Speter 		case T_CFINT:
205748Speter 			con.ctype = nl+TDOUBLE;
206*18345Smckusick 			con.crval = atof(cn->char_const.cptr);
207748Speter 			break;
208748Speter 		case T_CSTRNG:
209*18345Smckusick 			cp = cn->char_const.cptr;
210748Speter 			if (cp[1] == 0) {
211748Speter 				con.ctype = nl+T1CHAR;
212748Speter 				con.cival = cp[0];
213748Speter 				con.crval = con.cival;
214748Speter 				break;
215748Speter 			}
216748Speter 			con.ctype = nl+TSTR;
217748Speter 			con.cpval = savestr(cp);
218748Speter 			break;
219748Speter 	}
220748Speter 	if (sgnd) {
221*18345Smckusick 		if (isnta((struct nl *) con.ctype, "id"))
222*18345Smckusick 			derror("%s constants cannot be signed",
223*18345Smckusick 				nameof((struct nl *) con.ctype));
224748Speter 		else {
225748Speter 			if (negd)
226748Speter 				con.crval = -con.crval;
227748Speter 			ci = con.crval;
228748Speter 		}
229748Speter 	}
230748Speter }
231748Speter 
232748Speter #ifndef PI0
233*18345Smckusick isconst(cn)
234*18345Smckusick 	register struct tnode *cn;
235748Speter {
236748Speter 
237*18345Smckusick 	if (cn == TR_NIL)
238748Speter 		return (1);
239*18345Smckusick 	switch (cn->tag) {
240748Speter 		case T_MINUS:
241*18345Smckusick 			cn->tag = T_MINUSC;
242*18345Smckusick 			cn->sign_const.number =
243*18345Smckusick 					 cn->un_expr.expr;
244*18345Smckusick 			return (isconst(cn->sign_const.number));
245748Speter 		case T_PLUS:
246*18345Smckusick 			cn->tag = T_PLUSC;
247*18345Smckusick 			cn->sign_const.number =
248*18345Smckusick 					 cn->un_expr.expr;
249*18345Smckusick 			return (isconst(cn->sign_const.number));
250748Speter 		case T_VAR:
251*18345Smckusick 			if (cn->var_node.qual != TR_NIL)
252748Speter 				return (0);
253*18345Smckusick 			cn->tag = T_ID;
254*18345Smckusick 			cn->char_const.cptr =
255*18345Smckusick 					cn->var_node.cptr;
256748Speter 			return (1);
257748Speter 		case T_BINT:
258*18345Smckusick 			cn->tag = T_CBINT;
259*18345Smckusick 			cn->char_const.cptr =
260*18345Smckusick 				cn->const_node.cptr;
261748Speter 			return (1);
262748Speter 		case T_INT:
263*18345Smckusick 			cn->tag = T_CINT;
264*18345Smckusick 			cn->char_const.cptr =
265*18345Smckusick 				cn->const_node.cptr;
266748Speter 			return (1);
267748Speter 		case T_FINT:
268*18345Smckusick 			cn->tag = T_CFINT;
269*18345Smckusick 			cn->char_const.cptr =
270*18345Smckusick 				cn->const_node.cptr;
271748Speter 			return (1);
272748Speter 		case T_STRNG:
273*18345Smckusick 			cn->tag = T_CSTRNG;
274*18345Smckusick 			cn->char_const.cptr =
275*18345Smckusick 				cn->const_node.cptr;
276748Speter 			return (1);
277748Speter 	}
278748Speter 	return (0);
279748Speter }
280748Speter #endif
281