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