xref: /csrg-svn/usr.bin/pascal/src/var.c (revision 24053)
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[] = "@(#)var.c	5.2 (Berkeley) 07/26/85";
9 #endif not lint
10 
11 #include "whoami.h"
12 #include "0.h"
13 #include "objfmt.h"
14 #include "align.h"
15 #include "iorec.h"
16 #ifdef PC
17 #   include	"pc.h"
18 #endif PC
19 #include "tmps.h"
20 #include "tree_ty.h"
21 
22 /*
23  * Declare variables of a var part.  DPOFF1 is
24  * the local variable storage for all prog/proc/func
25  * modules aside from the block mark.  The total size
26  * of all the local variables is entered into the
27  * size array.
28  */
29 /*ARGSUSED*/
30 varbeg( lineofyvar , r )
31     int	lineofyvar;
32 {
33     static bool	var_order = FALSE;
34     static bool	var_seen = FALSE;
35 
36 /* this allows for multiple declaration
37  * parts except when the "standard"
38  * option has been specified.
39  * If routine segment is being compiled,
40  * do level one processing.
41  */
42 
43 #ifndef PI1
44 	if (!progseen)
45 		level1();
46 	line = lineofyvar;
47 	if ( parts[ cbn ] & RPRT ) {
48 	    if ( opt( 's' ) ) {
49 		standard();
50 		error("Variable declarations should precede routine declarations");
51 	    } else {
52 		if ( !var_order ) {
53 		    var_order = TRUE;
54 		    warning();
55 		    error("Variable declarations should precede routine declarations");
56 		}
57 	    }
58 	}
59 	if ( parts[ cbn ] & VPRT ) {
60 	    if ( opt( 's' ) ) {
61 		standard();
62 		error("All variables should be declared in one var part");
63 	    } else {
64 		if ( !var_seen ) {
65 		    var_seen = TRUE;
66 		    warning();
67 		    error("All variables should be declared in one var part");
68 		}
69 	    }
70 	}
71 	parts[ cbn ] |= VPRT;
72 #endif
73     /*
74      *  #ifndef PI0
75      *      sizes[cbn].om_max = sizes[cbn].curtmps.om_off = -DPOFF1;
76      *  #endif
77      */
78 	forechain = NIL;
79 #ifdef PI0
80 	send(REVVBEG);
81 #endif
82 }
83 
84 var(vline, vidl, vtype)
85 #ifdef PI0
86 	int vline;
87 	struct tnode *vidl, *vtype;
88 {
89 	register struct nl *np;
90 	register struct tnode *vl;
91 
92 	np = gtype(vtype);
93 	line = vline;
94 	/* why is this here? */
95 	for (vl = vidl; vl != TR_NIL; vl = vl->list_node.next) {
96 		}
97 	}
98 	send(REVVAR, vline, vidl, vtype);
99 }
100 #else
101 	int vline;
102 	register struct tnode *vidl;
103 	struct tnode *vtype;
104 {
105 	register struct nl *np;
106 	register struct om *op;
107 	long w;
108 	int o2;
109 #ifdef PC
110 	struct nl	*vp;
111 #endif
112 
113 	np = gtype(vtype);
114 	line = vline;
115 	w = lwidth(np);
116 	op = &sizes[cbn];
117 	for (; vidl != TR_NIL; vidl = vidl->list_node.next) {
118 #		ifdef OBJ
119 		    op->curtmps.om_off =
120 			roundup((int)(op->curtmps.om_off-w), (long)align(np));
121 		    o2 = op -> curtmps.om_off;
122 #		endif OBJ
123 #		ifdef PC
124 		    if ( cbn == 1 ) {
125 				/*
126 				 * global variables are not accessed off the fp
127 				 * but rather by their names.
128 				 */
129 			    o2 = 0;
130 		    } else {
131 				/*
132 				 * locals are aligned, too.
133 				 */
134 			    op->curtmps.om_off =
135 				roundup((int)(op->curtmps.om_off - w),
136 				(long)align(np));
137 			    o2 = op -> curtmps.om_off;
138 		    }
139 #		endif PC
140 #		ifdef PC
141 		vp = enter(defnl((char *) vidl->list_node.list, VAR, np, o2));
142 #		else
143 		(void) enter(defnl((char *) vidl->list_node.list, VAR, np, o2));
144 #		endif
145 		if ( np != NLNIL && (np -> nl_flags & NFILES) ) {
146 		    dfiles[ cbn ] = TRUE;
147 		}
148 #		ifdef PC
149 		    if ( cbn == 1 ) {
150 			putprintf( "	.data" , 0 );
151 			aligndot(align(np));
152 			putprintf( "	.comm	" , 1 );
153 			putprintf( EXTFORMAT , 1 , (int) vidl->list_node.list );
154 			putprintf( ",%d" , 0 , (int) w );
155 			putprintf( "	.text" , 0 );
156 			stabgvar( vp , w , line );
157 			vp -> extra_flags |= NGLOBAL;
158 		    } else {
159 			vp -> extra_flags |= NLOCAL;
160 		    }
161 #		endif PC
162 	}
163 #	ifdef PTREE
164 	    {
165 		pPointer	*Vars;
166 		pPointer	Var = VarDecl( ovidl , vtype );
167 
168 		pSeize( PorFHeader[ nesting ] );
169 		Vars = &( pDEF( PorFHeader[ nesting ] ).PorFVars );
170 		*Vars = ListAppend( *Vars , Var );
171 		pRelease( PorFHeader[ nesting ] );
172 	    }
173 #	endif
174 }
175 #endif
176 
177 varend()
178 {
179 
180 	foredecl();
181 #ifndef PI0
182 	sizes[cbn].om_max = sizes[cbn].curtmps.om_off;
183 #else
184 	send(REVVEND);
185 #endif
186 }
187 
188 /*
189  * Evening
190  */
191 long
192 leven(w)
193 	register long w;
194 {
195 	if (w < 0)
196 		return (w & 0xfffffffe);
197 	return ((w+1) & 0xfffffffe);
198 }
199 
200 #ifndef PC
201 int
202 even(w)
203 	register int w;
204 {
205 	return leven((long)w);
206 }
207 #endif
208 
209 /*
210  * Find the width of a type in bytes.
211  */
212 width(np)
213 	struct nl *np;
214 {
215 
216 	return (lwidth(np));
217 }
218 
219 long
220 lwidth(np)
221 	struct nl *np;
222 {
223 	register struct nl *p;
224 
225 	p = np;
226 	if (p == NIL)
227 		return (0);
228 loop:
229 	switch (p->class) {
230 		default:
231 			panic("wclass");
232 		case TYPE:
233 			switch (nloff(p)) {
234 				case TNIL:
235 					return (2);
236 				case TSTR:
237 				case TSET:
238 					panic("width");
239 				default:
240 					p = p->type;
241 					goto loop;
242 			}
243 		case ARRAY:
244 			return (aryconst(p, 0));
245 		case PTR:
246 			return ( sizeof ( int * ) );
247 		case FILET:
248 			return ( sizeof(struct iorec) + lwidth( p -> type ) );
249 		case CRANGE:
250 			p = p->type;
251 			goto loop;
252 		case RANGE:
253 			if (p->type == nl+TDOUBLE)
254 #ifdef DEBUG
255 				return (hp21mx ? 4 : 8);
256 #else
257 				return (8);
258 #endif
259 		case SCAL:
260 			return (bytes(p->range[0], p->range[1]));
261 		case SET:
262 			setran(p->type);
263 			/*
264 			 * Sets are some multiple of longs
265 			 */
266 			return roundup((int)((set.uprbp >> 3) + 1),
267 				(long)(sizeof(long)));
268 		case STR:
269 		case RECORD:
270 			return ( p->value[NL_OFFS] );
271 	}
272 }
273 
274     /*
275      *	round up x to a multiple of y
276      *	for computing offsets of aligned things.
277      *	y had better be positive.
278      *	rounding is in the direction of x.
279      */
280 long
281 roundup( x , y )
282     int			x;
283     register long	y;
284     {
285 
286 	if ( y == 0 ) {
287 	    return x;
288 	}
289 	if ( x >= 0 ) {
290 		return ( ( ( x + ( y - 1 ) ) / y ) * y );
291 	} else {
292 		return ( ( ( x - ( y - 1 ) ) / y ) * y );
293 	}
294     }
295 
296     /*
297      *	alignment of an object using the c alignment scheme
298      */
299 int
300 align( np )
301     struct nl	*np;
302     {
303 	register struct nl *p;
304 	long elementalign;
305 
306 	p = np;
307 	if ( p == NIL ) {
308 	    return 0;
309 	}
310 alignit:
311 	switch ( p -> class ) {
312 	    default:
313 		    panic( "align" );
314 	    case TYPE:
315 		    switch ( nloff( p ) ) {
316 			case TNIL:
317 				return A_POINT;
318 			case TSTR:
319 				return A_STRUCT;
320 			case TSET:
321 				return A_SET;
322 			default:
323 				p = p -> type;
324 				goto alignit;
325 		    }
326 	    case ARRAY:
327 			/*
328 			 * arrays are structures, since they can get
329 			 * assigned form/to as structure assignments.
330 			 * preserve internal alignment if it is greater.
331 			 */
332 		    elementalign = align(p -> type);
333 		    return elementalign > A_STRUCT ? elementalign : A_STRUCT;
334 	    case PTR:
335 		    return A_POINT;
336 	    case FILET:
337 		    return A_FILET;
338 	    case CRANGE:
339 	    case RANGE:
340 		    if ( p -> type == nl+TDOUBLE ) {
341 			return A_DOUBLE;
342 		    }
343 		    /* else, fall through */
344 	    case SCAL:
345 		    switch ( bytes( p -> range[0] , p -> range[1] ) ) {
346 			case 4:
347 			    return A_LONG;
348 			case 2:
349 			    return A_SHORT;
350 			case 1:
351 			    return A_CHAR;
352 			default:
353 			    panic( "align: scal" );
354 		    }
355 	    case SET:
356 		    return A_SET;
357 	    case STR:
358 			/*
359 			 * arrays of chars are structs
360 			 */
361 		    return A_STRUCT;
362 	    case RECORD:
363 			/*
364 			 * the alignment of a record is in its align_info field
365 			 * why don't we use this for the rest of the namelist?
366 			 */
367 		    return p -> align_info;
368 	}
369     }
370 
371 #ifdef PC
372     /*
373      *	output an alignment pseudo-op.
374      */
375 aligndot(alignment)
376     int	alignment;
377 #ifdef vax
378 {
379     switch (alignment) {
380 	case 1:
381 	    return;
382 	case 2:
383 	    putprintf("	.align 1", 0);
384 	    return;
385 	default:
386 	case 4:
387 	    putprintf("	.align 2", 0);
388 	    return;
389     }
390 }
391 #endif vax
392 #ifdef mc68000
393 {
394     switch (alignment) {
395 	case 1:
396 	    return;
397 	default:
398 	    putprintf("	.even", 0);
399 	    return;
400     }
401 }
402 #endif mc68000
403 #endif PC
404 
405 /*
406  * Return the width of an element
407  * of a n time subscripted np.
408  */
409 long aryconst(np, n)
410 	struct nl *np;
411 	int n;
412 {
413 	register struct nl *p;
414 	long s, d;
415 
416 	if ((p = np) == NIL)
417 		return (NIL);
418 	if (p->class != ARRAY)
419 		panic("ary");
420 	/*
421 	 * If it is a conformant array, we cannot find the width from
422 	 * the type.
423 	 */
424 	if (p->chain->class == CRANGE)
425 		return (NIL);
426 	s = lwidth(p->type);
427 	/*
428 	 * Arrays of anything but characters are word aligned.
429 	 */
430 	if (s & 1)
431 		if (s != 1)
432 			s++;
433 	/*
434 	 * Skip the first n subscripts
435 	 */
436 	while (n >= 0) {
437 		p = p->chain;
438 		n--;
439 	}
440 	/*
441 	 * Sum across remaining subscripts.
442 	 */
443 	while (p != NIL) {
444 		if (p->class != RANGE && p->class != SCAL)
445 			panic("aryran");
446 		d = p->range[1] - p->range[0] + 1;
447 		s *= d;
448 		p = p->chain;
449 	}
450 	return (s);
451 }
452 
453 /*
454  * Find the lower bound of a set, and also its size in bits.
455  */
456 setran(q)
457 	struct nl *q;
458 {
459 	register lb, ub;
460 	register struct nl *p;
461 
462 	p = q;
463 	if (p == NIL)
464 		return;
465 	lb = p->range[0];
466 	ub = p->range[1];
467 	if (p->class != RANGE && p->class != SCAL)
468 		panic("setran");
469 	set.lwrb = lb;
470 	/* set.(upperbound prime) = number of bits - 1; */
471 	set.uprbp = ub-lb;
472 }
473 
474 /*
475  * Return the number of bytes required to hold an arithmetic quantity
476  */
477 bytes(lb, ub)
478 	long lb, ub;
479 {
480 
481 #ifndef DEBUG
482 	if (lb < -32768 || ub > 32767)
483 		return (4);
484 	else if (lb < -128 || ub > 127)
485 		return (2);
486 #else
487 	if (!hp21mx && (lb < -32768 || ub > 32767))
488 		return (4);
489 	if (lb < -128 || ub > 127)
490 		return (2);
491 #endif
492 	else
493 		return (1);
494 }
495