xref: /csrg-svn/usr.bin/pascal/src/var.c (revision 827)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 static	char sccsid[] = "@(#)var.c 1.2 08/31/80";
4 
5 #include "whoami.h"
6 #include "0.h"
7 #include "align.h"
8 #ifdef PC
9 #   include	"pc.h"
10 #   include	"pcops.h"
11 #   include	"iorec.h"
12 #endif PC
13 
14 /*
15  * Declare variables of a var part.  DPOFF1 is
16  * the local variable storage for all prog/proc/func
17  * modules aside from the block mark.  The total size
18  * of all the local variables is entered into the
19  * size array.
20  */
21 varbeg()
22 {
23 
24 /* PC allows for multiple declaration
25  * parts except when the "standard"
26  * option has been specified.
27  * If routine segment is being compiled,
28  * do level one processing.
29  */
30 
31 #ifndef PI1
32 if (!progseen)
33 	level1();
34 #ifdef PC
35     if (opt('s')) {
36 	if (parts & VPRT){
37 		standard();
38 		error("All variables must be declared in one var part");
39 	}
40     }
41 #else
42 	if (parts & VPRT)
43 		error("All variables must be declared in one var part");
44 #endif PC
45 
46 	parts |= VPRT;
47 #endif
48     /*
49      *  #ifndef PI0
50      *      sizes[cbn].om_max = sizes[cbn].om_off = -DPOFF1;
51      *  #endif
52      */
53 	forechain = NIL;
54 #ifdef PI0
55 	send(REVVBEG);
56 #endif
57 }
58 
59 var(vline, vidl, vtype)
60 #ifdef PI0
61 	int vline, *vidl, *vtype;
62 {
63 	register struct nl *np;
64 	register int *vl;
65 
66 	np = gtype(vtype);
67 	line = vline;
68 	for (vl = vidl; vl != NIL; vl = vl[2]) {
69 		}
70 	}
71 	send(REVVAR, vline, vidl, vtype);
72 }
73 #else
74 	int vline;
75 	register int *vidl;
76 	int *vtype;
77 {
78 	register struct nl *np;
79 	register struct om *op;
80 	long w;
81 	int o2;
82 	int *ovidl = vidl;
83 
84 	np = gtype(vtype);
85 	line = vline;
86 	    /*
87 	     * widths are evened out
88 	     */
89 	w = (lwidth(np) + 1) &~ 1;
90 	op = &sizes[cbn];
91 	for (; vidl != NIL; vidl = vidl[2]) {
92 #		ifdef OBJ
93 		    op -> om_off = roundup( op -> om_off - w , align( np ) );
94 		    o2 = op -> om_off;
95 #		endif OBJ
96 #		ifdef PC
97 		    if ( cbn == 1 ) {
98 				/*
99 				 * global variables are not accessed off the fp
100 				 * but rather by their names.
101 				 */
102 			    o2 = 0;
103 		    } else {
104 				/*
105 				 * locals are aligned, too.
106 				 */
107 			    op -> om_off = roundup( op -> om_off - w
108 							, align( np ) );
109 			    o2 = op -> om_off;
110 		    }
111 #		endif PC
112 		enter(defnl(vidl[1], VAR, np, o2));
113 		if ( np -> nl_flags & NFILES ) {
114 		    dfiles[ cbn ] = TRUE;
115 		}
116 #		ifdef PC
117 		    if ( cbn == 1 ) {
118 			putprintf( "	.data" , 0 );
119 			putprintf( "	.comm	" , 1 );
120 			putprintf( EXTFORMAT , 1 , vidl[1] );
121 			putprintf( ",%d" , 0 , w );
122 			putprintf( "	.text" , 0 );
123 		    }
124 		    stabvar( vidl[1] , p2type( np ) , cbn , o2 , w , line );
125 #		endif PC
126 	}
127 #	ifdef PTREE
128 	    {
129 		pPointer	*Vars;
130 		pPointer	Var = VarDecl( ovidl , vtype );
131 
132 		pSeize( PorFHeader[ nesting ] );
133 		Vars = &( pDEF( PorFHeader[ nesting ] ).PorFVars );
134 		*Vars = ListAppend( *Vars , Var );
135 		pRelease( PorFHeader[ nesting ] );
136 	    }
137 #	endif
138 }
139 #endif
140 
141 varend()
142 {
143 
144 	foredecl();
145 #ifndef PI0
146 	sizes[cbn].om_max = sizes[cbn].om_off;
147 #else
148 	send(REVVEND);
149 #endif
150 }
151 
152 /*
153  * Evening
154  */
155 even(w)
156 	register int w;
157 {
158 	if (w < 0)
159 		return (w & ~1);
160 	return ((w+1) & ~1);
161 }
162 
163 /*
164  * Find the width of a type in bytes.
165  */
166 width(np)
167 	struct nl *np;
168 {
169 
170 	return (lwidth(np));
171 }
172 
173 long
174 lwidth(np)
175 	struct nl *np;
176 {
177 	register struct nl *p;
178 	long w;
179 
180 	p = np;
181 	if (p == NIL)
182 		return (0);
183 loop:
184 	switch (p->class) {
185 		case TYPE:
186 			switch (nloff(p)) {
187 				case TNIL:
188 					return (2);
189 				case TSTR:
190 				case TSET:
191 					panic("width");
192 				default:
193 					p = p->type;
194 					goto loop;
195 			}
196 		case ARRAY:
197 			return (aryconst(p, 0));
198 		case PTR:
199 			return ( sizeof ( int * ) );
200 		case FILET:
201 #			ifdef OBJ
202 			    return ( sizeof ( int * ) );
203 #			endif OBJ
204 #			ifdef PC
205 			    return ( sizeof(struct iorec)
206 				    + lwidth( p -> type ) );
207 #			endif PC
208 		case RANGE:
209 			if (p->type == nl+TDOUBLE)
210 #ifdef DEBUG
211 				return (hp21mx ? 4 : 8);
212 #else
213 				return (8);
214 #endif
215 		case SCAL:
216 			return (bytes(p->range[0], p->range[1]));
217 		case SET:
218 			setran(p->type);
219 			return roundup( ( set.uprbp >> 3 ) + 1 , A_SET );
220 		case STR:
221 		case RECORD:
222 			return ( p->value[NL_OFFS] );
223 		default:
224 			panic("wclass");
225 	}
226 }
227 
228     /*
229      *	round up x to a multiple of y
230      *	for computing offsets of aligned things.
231      *	y had better be positive.
232      *	rounding is in the direction of x.
233      */
234 long
235 roundup( x , y )
236     long		x;
237     register long	y;
238     {
239 
240 	if ( y == 0 ) {
241 	    return 0;
242 	}
243 	if ( x >= 0 ) {
244 		return ( ( ( x + ( y - 1 ) ) / y ) * y );
245 	} else {
246 		return ( ( ( x - ( y - 1 ) ) / y ) * y );
247 	}
248     }
249 
250     /*
251      *	alignment of an object using the c alignment scheme
252      */
253 int
254 align( np )
255     struct nl	*np;
256     {
257 	register struct nl *p;
258 
259 	p = np;
260 	if ( p == NIL ) {
261 	    return 0;
262 	}
263 alignit:
264 	switch ( p -> class ) {
265 	    case TYPE:
266 		    switch ( nloff( p ) ) {
267 			case TNIL:
268 				return A_POINT;
269 			case TSTR:
270 				return A_CHAR;
271 			case TSET:
272 				return A_SET;
273 			default:
274 				p = p -> type;
275 				goto alignit;
276 		    }
277 	    case ARRAY:
278 			/*
279 			 * arrays are aligned as their component types
280 			 */
281 		    p = p -> type;
282 		    goto alignit;
283 	    case PTR:
284 		    return A_POINT;
285 	    case FILET:
286 		    return A_FILET;
287 	    case RANGE:
288 		    if ( p -> type == nl+TDOUBLE ) {
289 			return A_DOUBLE;
290 		    }
291 		    /* else, fall through */
292 	    case SCAL:
293 		    switch ( bytes( p -> range[0] , p -> range[1] ) ) {
294 			case 4:
295 			    return A_LONG;
296 			case 2:
297 			    return A_SHORT;
298 			case 1:
299 			    return A_CHAR;
300 			default:
301 			    panic( "align: scal" );
302 		    }
303 	    case SET:
304 		    return A_SET;
305 	    case STR:
306 		    return A_CHAR;
307 	    case RECORD:
308 			/*
309 			 * follow chain through all fields in record,
310 			 * taking max of alignments of types of fields.
311 			 * short circuit out if i reach the maximum alignment.
312 			 * this is pretty likely, as A_MAX is only 4.
313 			 */
314 		    {
315 			register long recalign;
316 			register long fieldalign;
317 
318 			recalign = A_MIN;
319 			p = p -> chain;
320 			while ( ( p != NIL ) && ( recalign < A_MAX ) ) {
321 			    fieldalign = align( p -> type );
322 			    if ( fieldalign > recalign ) {
323 				recalign = fieldalign;
324 			    }
325 			    p = p -> chain;
326 			}
327 			return recalign;
328 		    }
329 	    default:
330 		    panic( "align" );
331 	}
332     }
333 
334 /*
335  * Return the width of an element
336  * of a n time subscripted np.
337  */
338 long aryconst(np, n)
339 	struct nl *np;
340 	int n;
341 {
342 	register struct nl *p;
343 	long s, d;
344 
345 	if ((p = np) == NIL)
346 		return (NIL);
347 	if (p->class != ARRAY)
348 		panic("ary");
349 	s = lwidth(p->type);
350 	/*
351 	 * Arrays of anything but characters are word aligned.
352 	 */
353 	if (s & 1)
354 		if (s != 1)
355 			s++;
356 	/*
357 	 * Skip the first n subscripts
358 	 */
359 	while (n >= 0) {
360 		p = p->chain;
361 		n--;
362 	}
363 	/*
364 	 * Sum across remaining subscripts.
365 	 */
366 	while (p != NIL) {
367 		if (p->class != RANGE && p->class != SCAL)
368 			panic("aryran");
369 		d = p->range[1] - p->range[0] + 1;
370 		s *= d;
371 		p = p->chain;
372 	}
373 	return (s);
374 }
375 
376 /*
377  * Find the lower bound of a set, and also its size in bits.
378  */
379 setran(q)
380 	struct nl *q;
381 {
382 	register lb, ub;
383 	register struct nl *p;
384 
385 	p = q;
386 	if (p == NIL)
387 		return (NIL);
388 	lb = p->range[0];
389 	ub = p->range[1];
390 	if (p->class != RANGE && p->class != SCAL)
391 		panic("setran");
392 	set.lwrb = lb;
393 	/* set.(upperbound prime) = number of bits - 1; */
394 	set.uprbp = ub-lb;
395 }
396 
397 /*
398  * Return the number of bytes required to hold an arithmetic quantity
399  */
400 bytes(lb, ub)
401 	long lb, ub;
402 {
403 
404 #ifndef DEBUG
405 	if (lb < -32768 || ub > 32767)
406 		return (4);
407 	else if (lb < -128 || ub > 127)
408 		return (2);
409 #else
410 	if (!hp21mx && (lb < -32768 || ub > 32767))
411 		return (4);
412 	if (lb < -128 || ub > 127)
413 		return (2);
414 #endif
415 	else
416 		return (1);
417 }
418