Commit | Line | Data |
---|---|---|
55839dac PK |
1 | /* Copyright (c) 1979 Regents of the University of California */ |
2 | ||
542a2aa0 | 3 | static char sccsid[] = "@(#)rval.c 1.3 %G%"; |
55839dac PK |
4 | |
5 | #include "whoami.h" | |
6 | #include "0.h" | |
7 | #include "tree.h" | |
8 | #include "opcode.h" | |
9 | #include "objfmt.h" | |
10 | #ifdef PC | |
11 | # include "pc.h" | |
12 | # include "pcops.h" | |
13 | #endif PC | |
14 | ||
15 | extern char *opnames[]; | |
16 | bool inempty = FALSE; | |
17 | ||
18 | #ifdef PC | |
19 | char *relts[] = { | |
20 | "_RELEQ" , "_RELNE" , | |
21 | "_RELTLT" , "_RELTGT" , | |
22 | "_RELTLE" , "_RELTGE" | |
23 | }; | |
24 | char *relss[] = { | |
25 | "_RELEQ" , "_RELNE" , | |
26 | "_RELSLT" , "_RELSGT" , | |
27 | "_RELSLE" , "_RELSGE" | |
28 | }; | |
29 | long relops[] = { | |
30 | P2EQ , P2NE , | |
31 | P2LT , P2GT , | |
32 | P2LE , P2GE | |
33 | }; | |
34 | long mathop[] = { P2MUL , P2PLUS , P2MINUS }; | |
35 | char *setop[] = { "_MULT" , "_ADDT" , "_SUBT" }; | |
36 | #endif PC | |
37 | /* | |
38 | * Rvalue - an expression. | |
39 | * | |
40 | * Contype is the type that the caller would prefer, nand is important | |
41 | * if constant sets or constant strings are involved, the latter | |
42 | * because of string padding. | |
43 | * required is a flag whether an lvalue or an rvalue is required. | |
44 | * only VARs and structured things can have gt their lvalue this way. | |
45 | */ | |
46 | struct nl * | |
47 | rvalue(r, contype , required ) | |
48 | int *r; | |
49 | struct nl *contype; | |
50 | int required; | |
51 | { | |
52 | register struct nl *p, *p1; | |
53 | register struct nl *q; | |
54 | int c, c1, *rt, w, g; | |
55 | char *cp, *cp1, *opname; | |
56 | long l; | |
57 | double f; | |
58 | extern int flagwas; | |
59 | struct csetstr csetd; | |
60 | # ifdef PC | |
61 | struct nl *rettype; | |
62 | long ctype; | |
63 | long tempoff; | |
64 | # endif PC | |
65 | ||
66 | if (r == NIL) | |
67 | return (NIL); | |
68 | if (nowexp(r)) | |
69 | return (NIL); | |
70 | /* | |
71 | * Pick up the name of the operation | |
72 | * for future error messages. | |
73 | */ | |
74 | if (r[0] <= T_IN) | |
75 | opname = opnames[r[0]]; | |
76 | ||
77 | /* | |
78 | * The root of the tree tells us what sort of expression we have. | |
79 | */ | |
80 | switch (r[0]) { | |
81 | ||
82 | /* | |
83 | * The constant nil | |
84 | */ | |
85 | case T_NIL: | |
86 | # ifdef OBJ | |
87 | put(2, O_CON2, 0); | |
88 | # endif OBJ | |
89 | # ifdef PC | |
542a2aa0 | 90 | putleaf( P2ICON , 0 , 0 , P2PTR|P2UNDEF , 0 ); |
55839dac PK |
91 | # endif PC |
92 | return (nl+TNIL); | |
93 | ||
94 | /* | |
95 | * Function call with arguments. | |
96 | */ | |
97 | case T_FCALL: | |
98 | # ifdef OBJ | |
99 | return (funccod(r)); | |
100 | # endif OBJ | |
101 | # ifdef PC | |
102 | return (pcfunccod( r )); | |
103 | # endif PC | |
104 | ||
105 | case T_VAR: | |
106 | p = lookup(r[2]); | |
107 | if (p == NIL || p->class == BADUSE) | |
108 | return (NIL); | |
109 | switch (p->class) { | |
110 | case VAR: | |
111 | /* | |
112 | * If a variable is | |
113 | * qualified then get | |
114 | * the rvalue by a | |
115 | * lvalue and an ind. | |
116 | */ | |
117 | if (r[3] != NIL) | |
118 | goto ind; | |
119 | q = p->type; | |
120 | if (q == NIL) | |
121 | return (NIL); | |
122 | # ifdef OBJ | |
123 | w = width(q); | |
124 | switch (w) { | |
125 | case 8: | |
126 | put(2, O_RV8 | bn << 8+INDX, p->value[0]); | |
127 | break; | |
128 | case 4: | |
129 | put(2, O_RV4 | bn << 8+INDX, p->value[0]); | |
130 | break; | |
131 | case 2: | |
132 | put(2, O_RV2 | bn << 8+INDX, p->value[0]); | |
133 | break; | |
134 | case 1: | |
135 | put(2, O_RV1 | bn << 8+INDX, p->value[0]); | |
136 | break; | |
137 | default: | |
138 | put(3, O_RV | bn << 8+INDX, p->value[0], w); | |
139 | } | |
140 | # endif OBJ | |
141 | # ifdef PC | |
142 | if ( required == RREQ ) { | |
143 | putRV( p -> symbol , bn , p -> value[0] | |
144 | , p2type( q ) ); | |
145 | } else { | |
146 | putLV( p -> symbol , bn , p -> value[0] | |
147 | , p2type( q ) ); | |
148 | } | |
149 | # endif PC | |
150 | return (q); | |
151 | ||
152 | case WITHPTR: | |
153 | case REF: | |
154 | /* | |
155 | * A lvalue for these | |
156 | * is actually what one | |
157 | * might consider a rvalue. | |
158 | */ | |
159 | ind: | |
160 | q = lvalue(r, NOFLAGS , LREQ ); | |
161 | if (q == NIL) | |
162 | return (NIL); | |
163 | # ifdef OBJ | |
164 | w = width(q); | |
165 | switch (w) { | |
166 | case 8: | |
167 | put(1, O_IND8); | |
168 | break; | |
169 | case 4: | |
170 | put(1, O_IND4); | |
171 | break; | |
172 | case 2: | |
173 | put(1, O_IND2); | |
174 | break; | |
175 | case 1: | |
176 | put(1, O_IND1); | |
177 | break; | |
178 | default: | |
179 | put(2, O_IND, w); | |
180 | } | |
181 | # endif OBJ | |
182 | # ifdef PC | |
183 | if ( required == RREQ ) { | |
184 | putop( P2UNARY P2MUL , p2type( q ) ); | |
185 | } | |
186 | # endif PC | |
187 | return (q); | |
188 | ||
189 | case CONST: | |
190 | if (r[3] != NIL) { | |
191 | error("%s is a constant and cannot be qualified", r[2]); | |
192 | return (NIL); | |
193 | } | |
194 | q = p->type; | |
195 | if (q == NIL) | |
196 | return (NIL); | |
197 | if (q == nl+TSTR) { | |
198 | /* | |
199 | * Find the size of the string | |
200 | * constant if needed. | |
201 | */ | |
202 | cp = p->ptr[0]; | |
203 | cstrng: | |
204 | cp1 = cp; | |
205 | for (c = 0; *cp++; c++) | |
206 | continue; | |
207 | if (contype != NIL && !opt('s')) { | |
208 | if (width(contype) < c && classify(contype) == TSTR) { | |
209 | error("Constant string too long"); | |
210 | return (NIL); | |
211 | } | |
212 | c = width(contype); | |
213 | } | |
214 | # ifdef OBJ | |
215 | put( 2 + (sizeof(char *)/sizeof(short)) | |
216 | , O_CONG, c, cp1); | |
217 | # endif OBJ | |
218 | # ifdef PC | |
219 | putCONG( cp1 , c , required ); | |
220 | # endif PC | |
221 | /* | |
222 | * Define the string temporarily | |
223 | * so later people can know its | |
224 | * width. | |
225 | * cleaned out by stat. | |
226 | */ | |
227 | q = defnl(0, STR, 0, c); | |
228 | q->type = q; | |
229 | return (q); | |
230 | } | |
231 | if (q == nl+T1CHAR) { | |
232 | # ifdef OBJ | |
233 | put(2, O_CONC, p->value[0]); | |
234 | # endif OBJ | |
235 | # ifdef PC | |
236 | putleaf( P2ICON , p -> value[0] , 0 | |
237 | , P2CHAR , 0 ); | |
238 | # endif PC | |
239 | return (q); | |
240 | } | |
241 | /* | |
242 | * Every other kind of constant here | |
243 | */ | |
244 | switch (width(q)) { | |
245 | case 8: | |
246 | #ifndef DEBUG | |
247 | # ifdef OBJ | |
248 | put(2, O_CON8, p->real); | |
249 | # endif OBJ | |
250 | # ifdef PC | |
251 | putCON8( p -> real ); | |
252 | # endif PC | |
253 | #else | |
254 | if (hp21mx) { | |
255 | f = p->real; | |
256 | conv(&f); | |
257 | l = f.plong; | |
258 | put(2, O_CON4, l); | |
259 | } else | |
260 | # ifdef OBJ | |
261 | put(2, O_CON8, p->real); | |
262 | # endif OBJ | |
263 | # ifdef PC | |
264 | putCON8( p -> real ); | |
265 | # endif PC | |
266 | #endif | |
267 | break; | |
268 | case 4: | |
269 | # ifdef OBJ | |
270 | put(2, O_CON4, p->range[0]); | |
271 | # endif OBJ | |
272 | # ifdef PC | |
273 | putleaf( P2ICON , p -> range[0] , 0 | |
274 | , P2INT , 0 ); | |
275 | # endif PC | |
276 | break; | |
277 | case 2: | |
278 | # ifdef OBJ | |
279 | put(2, O_CON2, ( short ) p->range[0]); | |
280 | # endif OBJ | |
281 | # ifdef PC | |
282 | /* | |
283 | * make short constants ints | |
284 | */ | |
285 | putleaf( P2ICON , (short) p -> range[0] | |
286 | , 0 , P2INT , 0 ); | |
287 | # endif PC | |
288 | break; | |
289 | case 1: | |
290 | # ifdef OBJ | |
291 | put(2, O_CON1, p->value[0]); | |
292 | # endif OBJ | |
293 | # ifdef PC | |
294 | /* | |
295 | * make char constants ints | |
296 | */ | |
297 | putleaf( P2ICON , p -> value[0] , 0 | |
298 | , P2INT , 0 ); | |
299 | # endif PC | |
300 | break; | |
301 | default: | |
302 | panic("rval"); | |
303 | } | |
304 | return (q); | |
305 | ||
306 | case FUNC: | |
c4e911b6 | 307 | case FFUNC: |
55839dac PK |
308 | /* |
309 | * Function call with no arguments. | |
310 | */ | |
311 | if (r[3]) { | |
312 | error("Can't qualify a function result value"); | |
313 | return (NIL); | |
314 | } | |
315 | # ifdef OBJ | |
316 | return (funccod((int *) r)); | |
317 | # endif OBJ | |
318 | # ifdef PC | |
319 | return (pcfunccod( r )); | |
320 | # endif PC | |
321 | ||
322 | case TYPE: | |
323 | error("Type names (e.g. %s) allowed only in declarations", p->symbol); | |
324 | return (NIL); | |
325 | ||
326 | case PROC: | |
c4e911b6 | 327 | case FPROC: |
55839dac PK |
328 | error("Procedure %s found where expression required", p->symbol); |
329 | return (NIL); | |
330 | default: | |
331 | panic("rvid"); | |
332 | } | |
333 | /* | |
334 | * Constant sets | |
335 | */ | |
336 | case T_CSET: | |
337 | # ifdef OBJ | |
338 | if ( precset( r , contype , &csetd ) ) { | |
339 | if ( csetd.csettype == NIL ) { | |
340 | return NIL; | |
341 | } | |
342 | postcset( r , &csetd ); | |
343 | } else { | |
344 | put( 2, O_PUSH, -width(csetd.csettype)); | |
345 | postcset( r , &csetd ); | |
346 | setran( ( csetd.csettype ) -> type ); | |
347 | put( 2, O_CON24, set.uprbp); | |
348 | put( 2, O_CON24, set.lwrb); | |
349 | put( 2, O_CTTOT, 5 + csetd.singcnt + 2 * csetd.paircnt); | |
350 | } | |
351 | return csetd.csettype; | |
352 | # endif OBJ | |
353 | # ifdef PC | |
354 | if ( precset( r , contype , &csetd ) ) { | |
355 | if ( csetd.csettype == NIL ) { | |
356 | return NIL; | |
357 | } | |
358 | postcset( r , &csetd ); | |
359 | } else { | |
360 | putleaf( P2ICON , 0 , 0 | |
361 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
362 | , "_CTTOT" ); | |
363 | /* | |
364 | * allocate a temporary and use it | |
365 | */ | |
366 | sizes[ cbn ].om_off -= lwidth( csetd.csettype ); | |
367 | tempoff = sizes[ cbn ].om_off; | |
368 | putlbracket( ftnno , -tempoff ); | |
369 | if ( tempoff < sizes[ cbn ].om_max ) { | |
370 | sizes[ cbn ].om_max = tempoff; | |
371 | } | |
372 | putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); | |
373 | setran( ( csetd.csettype ) -> type ); | |
374 | putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); | |
375 | putop( P2LISTOP , P2INT ); | |
376 | putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); | |
377 | putop( P2LISTOP , P2INT ); | |
378 | postcset( r , &csetd ); | |
379 | putop( P2CALL , P2INT ); | |
380 | } | |
381 | return csetd.csettype; | |
382 | # endif PC | |
383 | ||
384 | /* | |
385 | * Unary plus and minus | |
386 | */ | |
387 | case T_PLUS: | |
388 | case T_MINUS: | |
389 | q = rvalue(r[2], NIL , RREQ ); | |
390 | if (q == NIL) | |
391 | return (NIL); | |
392 | if (isnta(q, "id")) { | |
393 | error("Operand of %s must be integer or real, not %s", opname, nameof(q)); | |
394 | return (NIL); | |
395 | } | |
396 | if (r[0] == T_MINUS) { | |
397 | # ifdef OBJ | |
398 | put(1, O_NEG2 + (width(q) >> 2)); | |
399 | # endif OBJ | |
400 | # ifdef PC | |
401 | putop( P2UNARY P2MINUS , p2type( q ) ); | |
402 | # endif PC | |
403 | return (isa(q, "d") ? q : nl+T4INT); | |
404 | } | |
405 | return (q); | |
406 | ||
407 | case T_NOT: | |
408 | q = rvalue(r[2], NIL , RREQ ); | |
409 | if (q == NIL) | |
410 | return (NIL); | |
411 | if (isnta(q, "b")) { | |
412 | error("not must operate on a Boolean, not %s", nameof(q)); | |
413 | return (NIL); | |
414 | } | |
415 | # ifdef OBJ | |
416 | put(1, O_NOT); | |
417 | # endif OBJ | |
418 | # ifdef PC | |
419 | putop( P2NOT , P2INT ); | |
420 | # endif PC | |
421 | return (nl+T1BOOL); | |
422 | ||
423 | case T_AND: | |
424 | case T_OR: | |
425 | p = rvalue(r[2], NIL , RREQ ); | |
426 | p1 = rvalue(r[3], NIL , RREQ ); | |
427 | if (p == NIL || p1 == NIL) | |
428 | return (NIL); | |
429 | if (isnta(p, "b")) { | |
430 | error("Left operand of %s must be Boolean, not %s", opname, nameof(p)); | |
431 | return (NIL); | |
432 | } | |
433 | if (isnta(p1, "b")) { | |
434 | error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); | |
435 | return (NIL); | |
436 | } | |
437 | # ifdef OBJ | |
438 | put(1, r[0] == T_AND ? O_AND : O_OR); | |
439 | # endif OBJ | |
440 | # ifdef PC | |
441 | /* | |
442 | * note the use of & and | rather than && and || | |
443 | * to force evaluation of all the expressions. | |
444 | */ | |
445 | putop( r[ 0 ] == T_AND ? P2AND : P2OR , P2INT ); | |
446 | # endif PC | |
447 | return (nl+T1BOOL); | |
448 | ||
449 | case T_DIVD: | |
450 | # ifdef OBJ | |
451 | p = rvalue(r[2], NIL , RREQ ); | |
452 | p1 = rvalue(r[3], NIL , RREQ ); | |
453 | # endif OBJ | |
454 | # ifdef PC | |
455 | /* | |
456 | * force these to be doubles for the divide | |
457 | */ | |
458 | p = rvalue( r[ 2 ] , NIL , RREQ ); | |
459 | if ( isnta( p , "d" ) ) { | |
460 | putop( P2SCONV , P2DOUBLE ); | |
461 | } | |
462 | p1 = rvalue( r[ 3 ] , NIL , RREQ ); | |
463 | if ( isnta( p1 , "d" ) ) { | |
464 | putop( P2SCONV , P2DOUBLE ); | |
465 | } | |
466 | # endif PC | |
467 | if (p == NIL || p1 == NIL) | |
468 | return (NIL); | |
469 | if (isnta(p, "id")) { | |
470 | error("Left operand of / must be integer or real, not %s", nameof(p)); | |
471 | return (NIL); | |
472 | } | |
473 | if (isnta(p1, "id")) { | |
474 | error("Right operand of / must be integer or real, not %s", nameof(p1)); | |
475 | return (NIL); | |
476 | } | |
477 | # ifdef OBJ | |
478 | return gen(NIL, r[0], width(p), width(p1)); | |
479 | # endif OBJ | |
480 | # ifdef PC | |
481 | putop( P2DIV , P2DOUBLE ); | |
482 | return nl + TDOUBLE; | |
483 | # endif PC | |
484 | ||
485 | case T_MULT: | |
486 | case T_ADD: | |
487 | case T_SUB: | |
488 | # ifdef OBJ | |
489 | /* | |
490 | * If the context hasn't told us | |
491 | * the type and a constant set is | |
492 | * present on the left we need to infer | |
493 | * the type from the right if possible | |
494 | * before generating left side code. | |
495 | */ | |
496 | if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) { | |
497 | codeoff(); | |
498 | contype = rvalue(r[3], NIL , RREQ ); | |
499 | codeon(); | |
500 | if (contype == NIL) | |
501 | return (NIL); | |
502 | } | |
503 | p = rvalue(r[2], contype , RREQ ); | |
504 | p1 = rvalue(r[3], p , RREQ ); | |
505 | if (p == NIL || p1 == NIL) | |
506 | return (NIL); | |
507 | if (isa(p, "id") && isa(p1, "id")) | |
508 | return (gen(NIL, r[0], width(p), width(p1))); | |
509 | if (isa(p, "t") && isa(p1, "t")) { | |
510 | if (p != p1) { | |
511 | error("Set types of operands of %s must be identical", opname); | |
512 | return (NIL); | |
513 | } | |
514 | gen(TSET, r[0], width(p), 0); | |
515 | return (p); | |
516 | } | |
517 | # endif OBJ | |
518 | # ifdef PC | |
519 | /* | |
520 | * the second pass can't do | |
521 | * long op double or double op long | |
522 | * so we have to know the type of both operands | |
523 | * also, it gets tricky for sets, which are done | |
524 | * by function calls. | |
525 | */ | |
526 | codeoff(); | |
527 | p1 = rvalue( r[ 3 ] , contype , RREQ ); | |
528 | codeon(); | |
529 | if ( isa( p1 , "id" ) ) { | |
530 | p = rvalue( r[ 2 ] , contype , RREQ ); | |
531 | if ( ( p == NIL ) || ( p1 == NIL ) ) { | |
532 | return NIL; | |
533 | } | |
534 | if ( isa( p , "i" ) && isa( p1 , "d" ) ) { | |
535 | putop( P2SCONV , P2DOUBLE ); | |
536 | } | |
537 | p1 = rvalue( r[ 3 ] , contype , RREQ ); | |
538 | if ( isa( p , "d" ) && isa( p1 , "i" ) ) { | |
539 | putop( P2SCONV , P2DOUBLE ); | |
540 | } | |
541 | if ( isa( p , "id" ) ) { | |
542 | if ( isa( p , "d" ) || isa( p1 , "d" ) ) { | |
543 | ctype = P2DOUBLE; | |
544 | rettype = nl + TDOUBLE; | |
545 | } else { | |
546 | ctype = P2INT; | |
547 | rettype = nl + T4INT; | |
548 | } | |
549 | putop( mathop[ r[0] - T_MULT ] , ctype ); | |
550 | return rettype; | |
551 | } | |
552 | } | |
553 | if ( isa( p1 , "t" ) ) { | |
554 | putleaf( P2ICON , 0 , 0 | |
555 | , ADDTYPE( ADDTYPE( P2PTR | P2STRTY , P2FTN ) | |
556 | , P2PTR ) | |
557 | , setop[ r[0] - T_MULT ] ); | |
558 | /* | |
559 | * allocate a temporary and use it | |
560 | */ | |
561 | sizes[ cbn ].om_off -= lwidth( p1 ); | |
562 | tempoff = sizes[ cbn ].om_off; | |
563 | putlbracket( ftnno , -tempoff ); | |
564 | if ( tempoff < sizes[ cbn ].om_max ) { | |
565 | sizes[ cbn ].om_max = tempoff; | |
566 | } | |
567 | putLV( 0 , cbn , tempoff , P2PTR|P2STRTY ); | |
568 | p = rvalue( r[2] , p1 , LREQ ); | |
569 | if ( isa( p , "t" ) ) { | |
570 | putop( P2LISTOP , P2INT ); | |
571 | if ( p == NIL || p1 == NIL ) { | |
572 | return NIL; | |
573 | } | |
574 | p1 = rvalue( r[3] , p , LREQ ); | |
575 | if ( p != p1 ) { | |
576 | error("Set types of operands of %s must be identical", opname); | |
577 | return NIL; | |
578 | } | |
579 | putop( P2LISTOP , P2INT ); | |
580 | putleaf( P2ICON , lwidth( p1 ) / sizeof( long ) , 0 | |
581 | , P2INT , 0 ); | |
582 | putop( P2LISTOP , P2INT ); | |
583 | putop( P2CALL , P2PTR | P2STRTY ); | |
584 | return p; | |
585 | } | |
586 | } | |
587 | if ( isnta( p1 , "idt" ) ) { | |
588 | /* | |
589 | * find type of left operand for error message. | |
590 | */ | |
591 | p = rvalue( r[2] , contype , RREQ ); | |
592 | } | |
593 | /* | |
594 | * don't give spurious error messages. | |
595 | */ | |
596 | if ( p == NIL || p1 == NIL ) { | |
597 | return NIL; | |
598 | } | |
599 | # endif PC | |
600 | if (isnta(p, "idt")) { | |
601 | error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); | |
602 | return (NIL); | |
603 | } | |
604 | if (isnta(p1, "idt")) { | |
605 | error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); | |
606 | return (NIL); | |
607 | } | |
608 | error("Cannot mix sets with integers and reals as operands of %s", opname); | |
609 | return (NIL); | |
610 | ||
611 | case T_MOD: | |
612 | case T_DIV: | |
613 | p = rvalue(r[2], NIL , RREQ ); | |
614 | p1 = rvalue(r[3], NIL , RREQ ); | |
615 | if (p == NIL || p1 == NIL) | |
616 | return (NIL); | |
617 | if (isnta(p, "i")) { | |
618 | error("Left operand of %s must be integer, not %s", opname, nameof(p)); | |
619 | return (NIL); | |
620 | } | |
621 | if (isnta(p1, "i")) { | |
622 | error("Right operand of %s must be integer, not %s", opname, nameof(p1)); | |
623 | return (NIL); | |
624 | } | |
625 | # ifdef OBJ | |
626 | return (gen(NIL, r[0], width(p), width(p1))); | |
627 | # endif OBJ | |
628 | # ifdef PC | |
629 | putop( r[ 0 ] == T_DIV ? P2DIV : P2MOD , P2INT ); | |
630 | return ( nl + T4INT ); | |
631 | # endif PC | |
632 | ||
633 | case T_EQ: | |
634 | case T_NE: | |
635 | case T_LT: | |
636 | case T_GT: | |
637 | case T_LE: | |
638 | case T_GE: | |
639 | /* | |
640 | * Since there can be no, a priori, knowledge | |
641 | * of the context type should a constant string | |
642 | * or set arise, we must poke around to find such | |
643 | * a type if possible. Since constant strings can | |
644 | * always masquerade as identifiers, this is always | |
645 | * necessary. | |
646 | */ | |
647 | codeoff(); | |
648 | p1 = rvalue(r[3], NIL , RREQ ); | |
649 | codeon(); | |
650 | if (p1 == NIL) | |
651 | return (NIL); | |
652 | contype = p1; | |
653 | # ifdef OBJ | |
654 | if (p1 == nl+TSET || p1->class == STR) { | |
655 | /* | |
656 | * For constant strings we want | |
657 | * the longest type so as to be | |
658 | * able to do padding (more importantly | |
659 | * avoiding truncation). For clarity, | |
660 | * we get this length here. | |
661 | */ | |
662 | codeoff(); | |
663 | p = rvalue(r[2], NIL , RREQ ); | |
664 | codeon(); | |
665 | if (p == NIL) | |
666 | return (NIL); | |
667 | if (p1 == nl+TSET || width(p) > width(p1)) | |
668 | contype = p; | |
669 | } | |
670 | /* | |
671 | * Now we generate code for | |
672 | * the operands of the relational | |
673 | * operation. | |
674 | */ | |
675 | p = rvalue(r[2], contype , RREQ ); | |
676 | if (p == NIL) | |
677 | return (NIL); | |
678 | p1 = rvalue(r[3], p , RREQ ); | |
679 | if (p1 == NIL) | |
680 | return (NIL); | |
681 | # endif OBJ | |
682 | # ifdef PC | |
683 | c1 = classify( p1 ); | |
684 | if ( c1 == TSET || c1 == TSTR || c1 == TREC ) { | |
685 | putleaf( P2ICON , 0 , 0 | |
686 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
687 | , c1 == TSET ? relts[ r[0] - T_EQ ] | |
688 | : relss[ r[0] - T_EQ ] ); | |
689 | /* | |
690 | * for [] and strings, comparisons are done on | |
691 | * the maximum width of the two sides. | |
692 | * for other sets, we have to ask the left side | |
693 | * what type it is based on the type of the right. | |
694 | * (this matters for intsets). | |
695 | */ | |
696 | if ( p1 == nl + TSET || c1 == TSTR ) { | |
697 | codeoff(); | |
698 | p = rvalue( r[ 2 ] , NIL , LREQ ); | |
699 | codeon(); | |
700 | if ( p1 == nl + TSET | |
701 | || lwidth( p ) > lwidth( p1 ) ) { | |
702 | contype = p; | |
703 | } | |
704 | } else { | |
705 | codeoff(); | |
706 | p = rvalue( r[ 2 ] , contype , LREQ ); | |
707 | codeon(); | |
708 | contype = p; | |
709 | } | |
710 | if ( p == NIL ) { | |
711 | return NIL; | |
712 | } | |
713 | /* | |
714 | * put out the width of the comparison. | |
715 | */ | |
716 | putleaf( P2ICON , lwidth( contype ) , 0 , P2INT , 0 ); | |
717 | /* | |
718 | * and the left hand side, | |
719 | * for sets, strings, records | |
720 | */ | |
721 | p = rvalue( r[ 2 ] , contype , LREQ ); | |
722 | putop( P2LISTOP , P2INT ); | |
723 | p1 = rvalue( r[ 3 ] , p , LREQ ); | |
724 | putop( P2LISTOP , P2INT ); | |
725 | putop( P2CALL , P2INT ); | |
726 | } else { | |
727 | /* | |
728 | * the easy (scalar or error) case | |
729 | */ | |
730 | p = rvalue( r[ 2 ] , contype , RREQ ); | |
731 | if ( p == NIL ) { | |
732 | return NIL; | |
733 | /* | |
734 | * since the second pass can't do | |
735 | * long op double or double op long | |
736 | * we may have to do some coercing. | |
737 | */ | |
738 | if ( isa( p , "i" ) && isa( p1 , "d" ) ) | |
739 | putop( P2SCONV , P2DOUBLE ); | |
740 | } | |
741 | p1 = rvalue( r[ 3 ] , p , RREQ ); | |
742 | if ( isa( p , "d" ) && isa( p1 , "i" ) ) | |
743 | putop( P2SCONV , P2DOUBLE ); | |
744 | putop( relops[ r[0] - T_EQ ] , P2INT ); | |
745 | } | |
746 | # endif PC | |
747 | c = classify(p); | |
748 | c1 = classify(p1); | |
749 | if (nocomp(c) || nocomp(c1)) | |
750 | return (NIL); | |
751 | g = NIL; | |
752 | switch (c) { | |
753 | case TBOOL: | |
754 | case TCHAR: | |
755 | if (c != c1) | |
756 | goto clash; | |
757 | break; | |
758 | case TINT: | |
759 | case TDOUBLE: | |
760 | if (c1 != TINT && c1 != TDOUBLE) | |
761 | goto clash; | |
762 | break; | |
763 | case TSCAL: | |
764 | if (c1 != TSCAL) | |
765 | goto clash; | |
766 | if (scalar(p) != scalar(p1)) | |
767 | goto nonident; | |
768 | break; | |
769 | case TSET: | |
770 | if (c1 != TSET) | |
771 | goto clash; | |
772 | if (p != p1) | |
773 | goto nonident; | |
774 | g = TSET; | |
775 | break; | |
776 | case TREC: | |
777 | if ( c1 != TREC ) { | |
778 | goto clash; | |
779 | } | |
780 | if ( p != p1 ) { | |
781 | goto nonident; | |
782 | } | |
783 | if (r[0] != T_EQ && r[0] != T_NE) { | |
784 | error("%s not allowed on records - only allow = and <>" , opname ); | |
785 | return (NIL); | |
786 | } | |
787 | g = TREC; | |
788 | break; | |
789 | case TPTR: | |
790 | case TNIL: | |
791 | if (c1 != TPTR && c1 != TNIL) | |
792 | goto clash; | |
793 | if (r[0] != T_EQ && r[0] != T_NE) { | |
794 | error("%s not allowed on pointers - only allow = and <>" , opname ); | |
795 | return (NIL); | |
796 | } | |
797 | break; | |
798 | case TSTR: | |
799 | if (c1 != TSTR) | |
800 | goto clash; | |
801 | if (width(p) != width(p1)) { | |
802 | error("Strings not same length in %s comparison", opname); | |
803 | return (NIL); | |
804 | } | |
805 | g = TSTR; | |
806 | break; | |
807 | default: | |
808 | panic("rval2"); | |
809 | } | |
810 | # ifdef OBJ | |
811 | return (gen(g, r[0], width(p), width(p1))); | |
812 | # endif OBJ | |
813 | # ifdef PC | |
814 | return nl + TBOOL; | |
815 | # endif PC | |
816 | clash: | |
817 | error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); | |
818 | return (NIL); | |
819 | nonident: | |
820 | error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); | |
821 | return (NIL); | |
822 | ||
823 | case T_IN: | |
824 | rt = r[3]; | |
825 | # ifdef OBJ | |
826 | if (rt != NIL && rt[0] == T_CSET) { | |
827 | precset( rt , NIL , &csetd ); | |
828 | p1 = csetd.csettype; | |
829 | if (p1 == NIL) | |
830 | return NIL; | |
831 | if (p1 == nl+TSET) { | |
832 | if ( !inempty ) { | |
833 | warning(); | |
834 | error("... in [] makes little sense, since it is always false!"); | |
835 | inempty = TRUE; | |
836 | } | |
837 | put(1, O_CON1, 0); | |
838 | return (nl+T1BOOL); | |
839 | } | |
840 | postcset( rt, &csetd); | |
841 | } else { | |
842 | p1 = stkrval(r[3], NIL , RREQ ); | |
843 | rt = NIL; | |
844 | } | |
845 | # endif OBJ | |
846 | # ifdef PC | |
847 | if (rt != NIL && rt[0] == T_CSET) { | |
848 | if ( precset( rt , NIL , &csetd ) ) { | |
849 | if ( csetd.csettype != nl + TSET ) { | |
850 | putleaf( P2ICON , 0 , 0 | |
851 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
852 | , "_IN" ); | |
853 | } | |
854 | } else { | |
855 | putleaf( P2ICON , 0 , 0 | |
856 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
857 | , "_INCT" ); | |
858 | } | |
859 | p1 = csetd.csettype; | |
860 | if (p1 == NIL) | |
861 | return NIL; | |
862 | if ( p1 == nl + TSET ) { | |
863 | if ( !inempty ) { | |
864 | warning(); | |
865 | error("... in [] makes little sense, since it is always false!"); | |
866 | inempty = TRUE; | |
867 | } | |
868 | putleaf( P2ICON , 0 , 0 , P2INT , 0 ); | |
869 | return (nl+T1BOOL); | |
870 | } | |
871 | } else { | |
872 | putleaf( P2ICON , 0 , 0 | |
873 | , ADDTYPE( P2FTN | P2INT , P2PTR ) | |
874 | , "_IN" ); | |
875 | codeoff(); | |
876 | p1 = rvalue(r[3], NIL , LREQ ); | |
877 | codeon(); | |
878 | } | |
879 | # endif PC | |
880 | p = stkrval(r[2], NIL , RREQ ); | |
881 | if (p == NIL || p1 == NIL) | |
882 | return (NIL); | |
883 | if (p1->class != SET) { | |
884 | error("Right operand of 'in' must be a set, not %s", nameof(p1)); | |
885 | return (NIL); | |
886 | } | |
887 | if (incompat(p, p1->type, r[2])) { | |
888 | cerror("Index type clashed with set component type for 'in'"); | |
889 | return (NIL); | |
890 | } | |
891 | setran(p1->type); | |
892 | # ifdef OBJ | |
893 | if (rt == NIL || csetd.comptime) | |
894 | put(4, O_IN, width(p1), set.lwrb, set.uprbp); | |
895 | else | |
896 | put(2, O_INCT, 3 + csetd.singcnt + 2*csetd.paircnt); | |
897 | # endif OBJ | |
898 | # ifdef PC | |
899 | if ( rt == NIL || rt[0] != T_CSET ) { | |
900 | putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); | |
901 | putop( P2LISTOP , P2INT ); | |
902 | putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); | |
903 | putop( P2LISTOP , P2INT ); | |
904 | p1 = rvalue( r[3] , NIL , LREQ ); | |
905 | putop( P2LISTOP , P2INT ); | |
906 | } else if ( csetd.comptime ) { | |
907 | putleaf( P2ICON , set.lwrb , 0 , P2INT , 0 ); | |
908 | putop( P2LISTOP , P2INT ); | |
909 | putleaf( P2ICON , set.uprbp , 0 , P2INT , 0 ); | |
910 | putop( P2LISTOP , P2INT ); | |
911 | postcset( r[3] , &csetd ); | |
912 | putop( P2LISTOP , P2INT ); | |
913 | } else { | |
914 | postcset( r[3] , &csetd ); | |
915 | } | |
916 | putop( P2CALL , P2INT ); | |
917 | # endif PC | |
918 | return (nl+T1BOOL); | |
919 | default: | |
920 | if (r[2] == NIL) | |
921 | return (NIL); | |
922 | switch (r[0]) { | |
923 | default: | |
924 | panic("rval3"); | |
925 | ||
926 | ||
927 | /* | |
928 | * An octal number | |
929 | */ | |
930 | case T_BINT: | |
931 | f = a8tol(r[2]); | |
932 | goto conint; | |
933 | ||
934 | /* | |
935 | * A decimal number | |
936 | */ | |
937 | case T_INT: | |
938 | f = atof(r[2]); | |
939 | conint: | |
940 | if (f > MAXINT || f < MININT) { | |
941 | error("Constant too large for this implementation"); | |
942 | return (NIL); | |
943 | } | |
944 | l = f; | |
945 | if (bytes(l, l) <= 2) { | |
946 | # ifdef OBJ | |
947 | put(2, O_CON2, ( short ) l); | |
948 | # endif OBJ | |
949 | # ifdef PC | |
950 | /* | |
951 | * short constants are ints | |
952 | */ | |
953 | putleaf( P2ICON , l , 0 , P2INT , 0 ); | |
954 | # endif PC | |
955 | return (nl+T2INT); | |
956 | } | |
957 | # ifdef OBJ | |
958 | put(2, O_CON4, l); | |
959 | # endif OBJ | |
960 | # ifdef PC | |
961 | putleaf( P2ICON , l , 0 , P2INT , 0 ); | |
962 | # endif PC | |
963 | return (nl+T4INT); | |
964 | ||
965 | /* | |
966 | * A floating point number | |
967 | */ | |
968 | case T_FINT: | |
969 | # ifdef OBJ | |
970 | put(2, O_CON8, atof(r[2])); | |
971 | # endif OBJ | |
972 | # ifdef PC | |
973 | putCON8( atof( r[2] ) ); | |
974 | # endif PC | |
975 | return (nl+TDOUBLE); | |
976 | ||
977 | /* | |
978 | * Constant strings. Note that constant characters | |
979 | * are constant strings of length one; there is | |
980 | * no constant string of length one. | |
981 | */ | |
982 | case T_STRNG: | |
983 | cp = r[2]; | |
984 | if (cp[1] == 0) { | |
985 | # ifdef OBJ | |
986 | put(2, O_CONC, cp[0]); | |
987 | # endif OBJ | |
988 | # ifdef PC | |
989 | putleaf( P2ICON , cp[0] , 0 , P2CHAR , 0 ); | |
990 | # endif PC | |
991 | return (nl+T1CHAR); | |
992 | } | |
993 | goto cstrng; | |
994 | } | |
995 | ||
996 | } | |
997 | } | |
998 | ||
999 | /* | |
1000 | * Can a class appear | |
1001 | * in a comparison ? | |
1002 | */ | |
1003 | nocomp(c) | |
1004 | int c; | |
1005 | { | |
1006 | ||
1007 | switch (c) { | |
1008 | case TREC: | |
1009 | if ( opt( 's' ) ) { | |
1010 | standard(); | |
1011 | error("record comparison is non-standard"); | |
1012 | } | |
1013 | break; | |
1014 | case TFILE: | |
1015 | case TARY: | |
1016 | error("%ss may not participate in comparisons", clnames[c]); | |
1017 | return (1); | |
1018 | } | |
1019 | return (NIL); | |
1020 | } | |
1021 | \f | |
1022 | /* | |
1023 | * this is sort of like gconst, except it works on expression trees | |
1024 | * rather than declaration trees, and doesn't give error messages for | |
1025 | * non-constant things. | |
1026 | * as a side effect this fills in the con structure that gconst uses. | |
1027 | * this returns TRUE or FALSE. | |
1028 | */ | |
1029 | constval(r) | |
1030 | register int *r; | |
1031 | { | |
1032 | register struct nl *np; | |
1033 | register *cn; | |
1034 | char *cp; | |
1035 | int negd, sgnd; | |
1036 | long ci; | |
1037 | ||
1038 | con.ctype = NIL; | |
1039 | cn = r; | |
1040 | negd = sgnd = 0; | |
1041 | loop: | |
1042 | /* | |
1043 | * cn[2] is nil if error recovery generated a T_STRNG | |
1044 | */ | |
1045 | if (cn == NIL || cn[2] == NIL) | |
1046 | return FALSE; | |
1047 | switch (cn[0]) { | |
1048 | default: | |
1049 | return FALSE; | |
1050 | case T_MINUS: | |
1051 | negd = 1 - negd; | |
1052 | /* and fall through */ | |
1053 | case T_PLUS: | |
1054 | sgnd++; | |
1055 | cn = cn[2]; | |
1056 | goto loop; | |
1057 | case T_NIL: | |
1058 | con.cpval = NIL; | |
1059 | con.cival = 0; | |
1060 | con.crval = con.cival; | |
1061 | con.ctype = nl + TNIL; | |
1062 | break; | |
1063 | case T_VAR: | |
1064 | np = lookup(cn[2]); | |
1065 | if (np == NIL || np->class != CONST) { | |
1066 | return FALSE; | |
1067 | } | |
1068 | if ( cn[3] != NIL ) { | |
1069 | return FALSE; | |
1070 | } | |
1071 | con.ctype = np->type; | |
1072 | switch (classify(np->type)) { | |
1073 | case TINT: | |
1074 | con.crval = np->range[0]; | |
1075 | break; | |
1076 | case TDOUBLE: | |
1077 | con.crval = np->real; | |
1078 | break; | |
1079 | case TBOOL: | |
1080 | case TCHAR: | |
1081 | case TSCAL: | |
1082 | con.cival = np->value[0]; | |
1083 | con.crval = con.cival; | |
1084 | break; | |
1085 | case TSTR: | |
1086 | con.cpval = np->ptr[0]; | |
1087 | break; | |
1088 | default: | |
1089 | con.ctype = NIL; | |
1090 | return FALSE; | |
1091 | } | |
1092 | break; | |
1093 | case T_BINT: | |
1094 | con.crval = a8tol(cn[2]); | |
1095 | goto restcon; | |
1096 | case T_INT: | |
1097 | con.crval = atof(cn[2]); | |
1098 | if (con.crval > MAXINT || con.crval < MININT) { | |
1099 | derror("Constant too large for this implementation"); | |
1100 | con.crval = 0; | |
1101 | } | |
1102 | restcon: | |
1103 | ci = con.crval; | |
1104 | #ifndef PI0 | |
1105 | if (bytes(ci, ci) <= 2) | |
1106 | con.ctype = nl+T2INT; | |
1107 | else | |
1108 | #endif | |
1109 | con.ctype = nl+T4INT; | |
1110 | break; | |
1111 | case T_FINT: | |
1112 | con.ctype = nl+TDOUBLE; | |
1113 | con.crval = atof(cn[2]); | |
1114 | break; | |
1115 | case T_STRNG: | |
1116 | cp = cn[2]; | |
1117 | if (cp[1] == 0) { | |
1118 | con.ctype = nl+T1CHAR; | |
1119 | con.cival = cp[0]; | |
1120 | con.crval = con.cival; | |
1121 | break; | |
1122 | } | |
1123 | con.ctype = nl+TSTR; | |
1124 | con.cpval = cp; | |
1125 | break; | |
1126 | } | |
1127 | if (sgnd) { | |
1128 | if (isnta(con.ctype, "id")) { | |
1129 | derror("%s constants cannot be signed", nameof(con.ctype)); | |
1130 | return FALSE; | |
1131 | } else if (negd) | |
1132 | con.crval = -con.crval; | |
1133 | } | |
1134 | return TRUE; | |
1135 | } |