xref: /csrg-svn/usr.bin/pascal/src/const.c (revision 14728)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 #ifndef lint
4 static	char sccsid[] = "@(#)const.c 1.6 08/19/83";
5 #endif
6 
7 #include "whoami.h"
8 #include "0.h"
9 #include "tree.h"
10 #include "tree_ty.h"
11 
12 /*
13  * Const enters the definitions
14  * of the constant declaration
15  * part into the namelist.
16  */
17 #ifndef PI1
18 constbeg( lineofyconst )
19     int	lineofyconst;
20 {
21     static bool	const_order = FALSE;
22     static bool	const_seen = FALSE;
23 
24 /*
25  * this allows for multiple declaration
26  * parts, unless the "standard" option
27  * has been specified.
28  * If a routine segment is being compiled,
29  * do level one processing.
30  */
31 
32 	if (!progseen)
33 		level1();
34 	line = lineofyconst;
35 	if (parts[ cbn ] & (TPRT|VPRT|RPRT)) {
36 	    if ( opt( 's' ) ) {
37 		standard();
38 		error("Constant declarations should precede type, var and routine declarations");
39 	    } else {
40 		if ( !const_order ) {
41 		    const_order = TRUE;
42 		    warning();
43 		    error("Constant declarations should precede type, var and routine declarations");
44 		}
45 	    }
46 	}
47 	if (parts[ cbn ] & CPRT) {
48 	    if ( opt( 's' ) ) {
49 		standard();
50 		error("All constants should be declared in one const part");
51 	    } else {
52 		if ( !const_seen ) {
53 		    const_seen = TRUE;
54 		    warning();
55 		    error("All constants should be declared in one const part");
56 		}
57 	    }
58 	}
59 	parts[ cbn ] |= CPRT;
60 }
61 #endif PI1
62 
63 const(cline, cid, cdecl)
64 	int cline;
65 	register char *cid;
66 	register struct tnode *cdecl;
67 {
68 	register struct nl *np;
69 
70 #ifdef PI0
71 	send(REVCNST, cline, cid, cdecl);
72 #endif
73 	line = cline;
74 	gconst(cdecl);
75 	np = enter(defnl(cid, CONST, con.ctype, con.cival));
76 #ifndef PI0
77 	np->nl_flags |= NMOD;
78 #endif
79 
80 #ifdef PC
81 	if (cbn == 1) {
82 	    stabgconst( cid , line );
83 	}
84 #endif PC
85 
86 #	ifdef PTREE
87 	    {
88 		pPointer	Const = ConstDecl( cid , cdecl );
89 		pPointer	*Consts;
90 
91 		pSeize( PorFHeader[ nesting ] );
92 		Consts = &( pDEF( PorFHeader[ nesting ] ).PorFConsts );
93 		*Consts = ListAppend( *Consts , Const );
94 		pRelease( PorFHeader[ nesting ] );
95 	    }
96 #	endif
97 	if (con.ctype == NIL)
98 		return;
99 	if ( con.ctype == nl + TSTR )
100 		np->ptr[0] = (struct nl *) con.cpval;
101 	if (isa(con.ctype, "i"))
102 		np->range[0] = con.crval;
103 	else if (isa(con.ctype, "d"))
104 		np->real = con.crval;
105 }
106 
107 #ifndef PI0
108 #ifndef PI1
109 constend()
110 {
111 
112 }
113 #endif
114 #endif
115 
116 /*
117  * Gconst extracts
118  * a constant declaration
119  * from the tree for it.
120  * only types of constants
121  * are integer, reals, strings
122  * and scalars, the first two
123  * being possibly signed.
124  */
125 gconst(c_node)
126 	struct tnode *c_node;
127 {
128 	register struct nl *np;
129 	register struct tnode *cn;
130 	char *cp;
131 	int negd, sgnd;
132 	long ci;
133 
134 	con.ctype = NIL;
135 	cn = c_node;
136 	negd = sgnd = 0;
137 loop:
138 	if (cn == TR_NIL || cn->sign_const.number == TR_NIL)
139 		return;
140 	switch (cn->tag) {
141 		default:
142 			panic("gconst");
143 		case T_MINUSC:
144 			negd = 1 - negd;
145 		case T_PLUSC:
146 			sgnd++;
147 			cn = cn->sign_const.number;
148 			goto loop;
149 		case T_ID:
150 			np = lookup(cn->char_const.cptr);
151 			if (np == NLNIL)
152 				return;
153 			if (np->class != CONST) {
154 				derror("%s is a %s, not a constant as required", cn->char_const.cptr, classes[np->class]);
155 				return;
156 			}
157 			con.ctype = np->type;
158 			switch (classify(np->type)) {
159 				case TINT:
160 					con.crval = np->range[0];
161 					break;
162 				case TDOUBLE:
163 					con.crval = np->real;
164 					break;
165 				case TBOOL:
166 				case TCHAR:
167 				case TSCAL:
168 					con.cival = np->value[0];
169 					con.crval = con.cival;
170 					break;
171 				case TSTR:
172 					con.cpval = (char *) np->ptr[0];
173 					break;
174 				case NIL:
175 					con.ctype = NIL;
176 					return;
177 				default:
178 					panic("gconst2");
179 			}
180 			break;
181 		case T_CBINT:
182 			con.crval = a8tol(cn->char_const.cptr);
183 			goto restcon;
184 		case T_CINT:
185 			con.crval = atof(cn->char_const.cptr);
186 			if (con.crval > MAXINT || con.crval < MININT) {
187 				derror("Constant too large for this implementation");
188 				con.crval = 0;
189 			}
190 restcon:
191 			ci = con.crval;
192 #ifndef PI0
193 			if (bytes(ci, ci) <= 2)
194 				con.ctype = nl+T2INT;
195 			else
196 #endif
197 				con.ctype = nl+T4INT;
198 			break;
199 		case T_CFINT:
200 			con.ctype = nl+TDOUBLE;
201 			con.crval = atof(cn->char_const.cptr);
202 			break;
203 		case T_CSTRNG:
204 			cp = cn->char_const.cptr;
205 			if (cp[1] == 0) {
206 				con.ctype = nl+T1CHAR;
207 				con.cival = cp[0];
208 				con.crval = con.cival;
209 				break;
210 			}
211 			con.ctype = nl+TSTR;
212 			con.cpval = savestr(cp);
213 			break;
214 	}
215 	if (sgnd) {
216 		if (isnta((struct nl *) con.ctype, "id"))
217 			derror("%s constants cannot be signed",
218 				nameof((struct nl *) con.ctype));
219 		else {
220 			if (negd)
221 				con.crval = -con.crval;
222 			ci = con.crval;
223 		}
224 	}
225 }
226 
227 #ifndef PI0
228 isconst(cn)
229 	register struct tnode *cn;
230 {
231 
232 	if (cn == TR_NIL)
233 		return (1);
234 	switch (cn->tag) {
235 		case T_MINUS:
236 			cn->tag = T_MINUSC;
237 			cn->sign_const.number =
238 					 cn->un_expr.expr;
239 			return (isconst(cn->sign_const.number));
240 		case T_PLUS:
241 			cn->tag = T_PLUSC;
242 			cn->sign_const.number =
243 					 cn->un_expr.expr;
244 			return (isconst(cn->sign_const.number));
245 		case T_VAR:
246 			if (cn->var_node.qual != TR_NIL)
247 				return (0);
248 			cn->tag = T_ID;
249 			cn->char_const.cptr =
250 					cn->var_node.cptr;
251 			return (1);
252 		case T_BINT:
253 			cn->tag = T_CBINT;
254 			cn->char_const.cptr =
255 				cn->const_node.cptr;
256 			return (1);
257 		case T_INT:
258 			cn->tag = T_CINT;
259 			cn->char_const.cptr =
260 				cn->const_node.cptr;
261 			return (1);
262 		case T_FINT:
263 			cn->tag = T_CFINT;
264 			cn->char_const.cptr =
265 				cn->const_node.cptr;
266 			return (1);
267 		case T_STRNG:
268 			cn->tag = T_CSTRNG;
269 			cn->char_const.cptr =
270 				cn->const_node.cptr;
271 			return (1);
272 	}
273 	return (0);
274 }
275 #endif
276