Commit | Line | Data |
---|---|---|
05594d83 TL |
1 | /* INTERMEDIATE CODE GENERATION FOR S C JOHNSON C COMPILERS */ |
2 | /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */ | |
3 | #if FAMILY != SCJ | |
4 | WRONG put FULE !!!! | |
5 | #endif | |
6 | ||
7 | #include "defs" | |
8 | #include "scjdefs" | |
9 | ||
10 | #define FOUR 4 | |
11 | extern int ops2[]; | |
12 | extern int types2[]; | |
13 | ||
14 | #define P2BUFFMAX 128 | |
15 | static long int p2buff[P2BUFFMAX]; | |
16 | static long int *p2bufp = &p2buff[0]; | |
17 | static long int *p2bufend = &p2buff[P2BUFFMAX]; | |
18 | ||
19 | ||
20 | puthead(s) | |
21 | char *s; | |
22 | { | |
23 | char buff[100]; | |
24 | #if TARGET == VAX | |
25 | if(s) | |
26 | p2pass( sprintf(buff, "\t.globl\t_%s", s) ); | |
27 | #endif | |
28 | /* put out fake copy of left bracket line, to be redone later */ | |
29 | if( ! headerdone ) | |
30 | { | |
31 | #if FAMILY==SCJ && OUTPUT==BINARY | |
32 | p2flush(); | |
33 | #endif | |
34 | headoffset = ftell(textfile); | |
35 | prhead(textfile); | |
36 | headerdone = YES; | |
37 | p2triple(P2STMT, (strlen(infname)+FOUR-1)/FOUR, 0); | |
38 | p2str(infname); | |
39 | } | |
40 | } | |
41 | ||
42 | ||
43 | ||
44 | ||
45 | ||
46 | /* It is necessary to precede each procedure with a "left bracket" | |
47 | * line that tells pass 2 how many register variables and how | |
48 | * much automatic space is required for the function. This compiler | |
49 | * does not know how much automatic space is needed until the | |
50 | * entire procedure has been processed. Therefore, "puthead" | |
51 | * is called at the begining to record the current location in textfile, | |
52 | * then to put out a placeholder left bracket line. This procedure | |
53 | * repositions the file and rewrites that line, then puts the | |
54 | * file pointer back to the end of the file. | |
55 | */ | |
56 | ||
57 | putbracket() | |
58 | { | |
59 | long int hereoffset; | |
60 | ||
61 | #if FAMILY==SCJ && OUTPUT==BINARY | |
62 | p2flush(); | |
63 | #endif | |
64 | hereoffset = ftell(textfile); | |
65 | if(fseek(textfile, headoffset, 0)) | |
66 | fatal("fseek failed"); | |
67 | prhead(textfile); | |
68 | if(fseek(textfile, hereoffset, 0)) | |
69 | fatal("fseek failed 2"); | |
70 | } | |
71 | ||
72 | ||
73 | ||
74 | ||
75 | putrbrack(k) | |
76 | int k; | |
77 | { | |
78 | p2op(P2RBRACKET, k); | |
79 | } | |
80 | ||
81 | ||
82 | ||
83 | putnreg() | |
84 | { | |
85 | } | |
86 | ||
87 | ||
88 | ||
89 | ||
90 | ||
91 | ||
92 | puteof() | |
93 | { | |
94 | p2op(P2EOF, 0); | |
95 | p2flush(); | |
96 | } | |
97 | ||
98 | ||
99 | ||
100 | putstmt() | |
101 | { | |
102 | p2triple(P2STMT, 0, lineno); | |
103 | } | |
104 | ||
105 | ||
106 | ||
107 | ||
108 | /* put out code for if( ! p) goto l */ | |
109 | putif(p,l) | |
110 | register expptr p; | |
111 | int l; | |
112 | { | |
113 | register int k; | |
114 | ||
115 | if( ( k = (p = fixtype(p))->vtype) != TYLOGICAL) | |
116 | { | |
117 | if(k != TYERROR) | |
118 | err("non-logical expression in IF statement"); | |
119 | frexpr(p); | |
120 | } | |
121 | else | |
122 | { | |
123 | putex1(p); | |
124 | p2icon( (long int) l , P2INT); | |
125 | p2op(P2CBRANCH, 0); | |
126 | putstmt(); | |
127 | } | |
128 | } | |
129 | ||
130 | ||
131 | ||
132 | ||
133 | ||
134 | /* put out code for goto l */ | |
135 | putgoto(label) | |
136 | int label; | |
137 | { | |
138 | p2triple(P2GOTO, 1, label); | |
139 | putstmt(); | |
140 | } | |
141 | ||
142 | ||
143 | /* branch to address constant or integer variable */ | |
144 | putbranch(p) | |
145 | register struct addrblock *p; | |
146 | { | |
147 | putex1(p); | |
148 | p2op(P2GOTO, P2INT); | |
149 | putstmt(); | |
150 | } | |
151 | ||
152 | ||
153 | ||
154 | /* put out label l: */ | |
155 | putlabel(label) | |
156 | int label; | |
157 | { | |
158 | p2op(P2LABEL, label); | |
159 | } | |
160 | ||
161 | ||
162 | ||
163 | ||
164 | putexpr(p) | |
165 | expptr p; | |
166 | { | |
167 | putex1(p); | |
168 | putstmt(); | |
169 | } | |
170 | ||
171 | ||
172 | ||
173 | ||
174 | putcmgo(index, nlab, labs) | |
175 | expptr index; | |
176 | int nlab; | |
177 | struct labelblock *labs[]; | |
178 | { | |
179 | int i, labarray, skiplabel; | |
180 | ||
181 | if(! ISINT(index->vtype) ) | |
182 | { | |
183 | execerr("computed goto index must be integer", NULL); | |
184 | return; | |
185 | } | |
186 | ||
187 | #if TARGET == VAX | |
188 | /* use special case instruction */ | |
189 | vaxgoto(index, nlab, labs); | |
190 | #else | |
191 | labarray = newlabel(); | |
192 | preven(ALIADDR); | |
193 | prlabel(asmfile, labarray); | |
194 | prcona(asmfile, (ftnint) (skiplabel = newlabel()) ); | |
195 | for(i = 0 ; i < nlab ; ++i) | |
196 | prcona(asmfile, (ftnint)(labs[i]->labelno) ); | |
197 | prcmgoto(index, nlab, skiplabel, labarray); | |
198 | putlabel(skiplabel); | |
199 | #endif | |
200 | } | |
201 | \f | |
202 | putx(p) | |
203 | expptr p; | |
204 | { | |
205 | struct addrblock *putcall(), *putcx1(), *realpart(); | |
206 | char *memname(); | |
207 | int opc; | |
208 | int ncomma; | |
209 | int type, k; | |
210 | ||
211 | switch(p->tag) | |
212 | { | |
213 | case TERROR: | |
214 | free(p); | |
215 | break; | |
216 | ||
217 | case TCONST: | |
218 | switch(type = p->vtype) | |
219 | { | |
220 | case TYLOGICAL: | |
221 | type = tyint; | |
222 | case TYLONG: | |
223 | case TYSHORT: | |
224 | p2icon(p->const.ci, types2[type]); | |
225 | free(p); | |
226 | break; | |
227 | ||
228 | case TYADDR: | |
229 | p2triple(P2ICON, 1, P2INT|P2PTR); | |
230 | p2word(0L); | |
231 | p2name(memname(STGCONST, (int) p->const.ci) ); | |
232 | free(p); | |
233 | break; | |
234 | ||
235 | default: | |
236 | putx( putconst(p) ); | |
237 | break; | |
238 | } | |
239 | break; | |
240 | ||
241 | case TEXPR: | |
242 | switch(opc = p->opcode) | |
243 | { | |
244 | case OPCALL: | |
245 | case OPCCALL: | |
246 | if( ISCOMPLEX(p->vtype) ) | |
247 | putcxop(p); | |
248 | else putcall(p); | |
249 | break; | |
250 | ||
251 | case OPMIN: | |
252 | case OPMAX: | |
253 | putmnmx(p); | |
254 | break; | |
255 | ||
256 | ||
257 | case OPASSIGN: | |
258 | if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) ) | |
259 | frexpr( putcxeq(p) ); | |
260 | else if( ISCHAR(p) ) | |
261 | putcheq(p); | |
262 | else | |
263 | goto putopp; | |
264 | break; | |
265 | ||
266 | case OPEQ: | |
267 | case OPNE: | |
268 | if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) ) | |
269 | { | |
270 | putcxcmp(p); | |
271 | break; | |
272 | } | |
273 | case OPLT: | |
274 | case OPLE: | |
275 | case OPGT: | |
276 | case OPGE: | |
277 | if(ISCHAR(p->leftp)) | |
278 | putchcmp(p); | |
279 | else | |
280 | goto putopp; | |
281 | break; | |
282 | ||
283 | case OPPOWER: | |
284 | putpower(p); | |
285 | break; | |
286 | ||
287 | case OPSTAR: | |
288 | #if FAMILY == SCJ | |
289 | /* m * (2**k) -> m<<k */ | |
290 | if(INT(p->leftp->vtype) && ISICON(p->rightp) && | |
291 | ( (k = log2(p->rightp->const.ci))>0) ) | |
292 | { | |
293 | p->opcode = OPLSHIFT; | |
294 | frexpr(p->rightp); | |
295 | p->rightp = ICON(k); | |
296 | goto putopp; | |
297 | } | |
298 | #endif | |
299 | ||
300 | case OPMOD: | |
301 | goto putopp; | |
302 | case OPPLUS: | |
303 | case OPMINUS: | |
304 | case OPSLASH: | |
305 | case OPNEG: | |
306 | if( ISCOMPLEX(p->vtype) ) | |
307 | putcxop(p); | |
308 | else goto putopp; | |
309 | break; | |
310 | ||
311 | case OPCONV: | |
312 | if( ISCOMPLEX(p->vtype) ) | |
313 | putcxop(p); | |
314 | else if( ISCOMPLEX(p->leftp->vtype) ) | |
315 | { | |
316 | ncomma = 0; | |
317 | putx( mkconv(p->vtype, | |
318 | realpart(putcx1(p->leftp, &ncomma)))); | |
319 | putcomma(ncomma, p->vtype, NO); | |
320 | free(p); | |
321 | } | |
322 | else goto putopp; | |
323 | break; | |
324 | ||
325 | case OPNOT: | |
326 | case OPOR: | |
327 | case OPAND: | |
328 | case OPEQV: | |
329 | case OPNEQV: | |
330 | case OPADDR: | |
331 | case OPPLUSEQ: | |
332 | case OPSTAREQ: | |
333 | case OPCOMMA: | |
334 | case OPQUEST: | |
335 | case OPCOLON: | |
336 | case OPBITOR: | |
337 | case OPBITAND: | |
338 | case OPBITXOR: | |
339 | case OPBITNOT: | |
340 | case OPLSHIFT: | |
341 | case OPRSHIFT: | |
342 | putopp: | |
343 | putop(p); | |
344 | break; | |
345 | ||
346 | default: | |
347 | fatal1("putx: invalid opcode %d", opc); | |
348 | } | |
349 | break; | |
350 | ||
351 | case TADDR: | |
352 | putaddr(p, YES); | |
353 | break; | |
354 | ||
355 | default: | |
356 | fatal1("putx: impossible tag %d", p->tag); | |
357 | } | |
358 | } | |
359 | ||
360 | ||
361 | ||
362 | LOCAL putop(p) | |
363 | expptr p; | |
364 | { | |
365 | int k; | |
366 | expptr lp, tp; | |
367 | int pt, lt; | |
368 | int comma; | |
369 | ||
370 | switch(p->opcode) /* check for special cases and rewrite */ | |
371 | { | |
372 | case OPCONV: | |
373 | pt = p->vtype; | |
374 | lp = p->leftp; | |
375 | lt = lp->vtype; | |
376 | while(p->tag==TEXPR && p->opcode==OPCONV && | |
377 | ( (ISREAL(pt)&&ISREAL(lt)) || | |
378 | (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR))) )) | |
379 | { | |
380 | #if SZINT < SZLONG | |
381 | if(lp->tag != TEXPR) | |
382 | { | |
383 | if(pt==TYINT && lt==TYLONG) | |
384 | break; | |
385 | if(lt==TYINT && pt==TYLONG) | |
386 | break; | |
387 | } | |
388 | #endif | |
389 | free(p); | |
390 | p = lp; | |
391 | pt = lt; | |
392 | lp = p->leftp; | |
393 | lt = lp->vtype; | |
394 | } | |
395 | if(p->tag==TEXPR && p->opcode==OPCONV) | |
396 | break; | |
397 | putx(p); | |
398 | return; | |
399 | ||
400 | case OPADDR: | |
401 | comma = NO; | |
402 | lp = p->leftp; | |
403 | if(lp->tag != TADDR) | |
404 | { | |
405 | tp = mktemp(lp->vtype, lp->vleng); | |
406 | putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); | |
407 | lp = tp; | |
408 | comma = YES; | |
409 | } | |
410 | putaddr(lp, NO); | |
411 | if(comma) | |
412 | putcomma(1, TYINT, NO); | |
413 | free(p); | |
414 | return; | |
415 | } | |
416 | ||
417 | if( (k = ops2[p->opcode]) <= 0) | |
418 | fatal1("putop: invalid opcode %d", p->opcode); | |
419 | putx(p->leftp); | |
420 | if(p->rightp) | |
421 | putx(p->rightp); | |
422 | p2op(k, types2[p->vtype]); | |
423 | ||
424 | if(p->vleng) | |
425 | frexpr(p->vleng); | |
426 | free(p); | |
427 | } | |
428 | \f | |
429 | putforce(t, p) | |
430 | int t; | |
431 | expptr p; | |
432 | { | |
433 | p = mkconv(t, fixtype(p)); | |
434 | putx(p); | |
435 | p2op(P2FORCE, | |
436 | (t==TYSHORT ? P2SHORT : (t==TYLONG ? P2LONG : P2DREAL)) ); | |
437 | putstmt(); | |
438 | } | |
439 | ||
440 | ||
441 | ||
442 | LOCAL putpower(p) | |
443 | expptr p; | |
444 | { | |
445 | expptr base; | |
446 | struct addrblock *t1, *t2; | |
447 | ftnint k; | |
448 | int type; | |
449 | int ncomma; | |
450 | ||
451 | if(!ISICON(p->rightp) || (k = p->rightp->const.ci)<2) | |
452 | fatal("putpower: bad call"); | |
453 | base = p->leftp; | |
454 | type = base->vtype; | |
455 | t1 = mktemp(type, NULL); | |
456 | t2 = NULL; | |
457 | ncomma = 1; | |
458 | putassign(cpexpr(t1), cpexpr(base) ); | |
459 | ||
460 | for( ; (k&1)==0 && k>2 ; k>>=1 ) | |
461 | { | |
462 | ++ncomma; | |
463 | putsteq(t1, t1); | |
464 | } | |
465 | ||
466 | if(k == 2) | |
467 | putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ); | |
468 | else | |
469 | { | |
470 | t2 = mktemp(type, NULL); | |
471 | ++ncomma; | |
472 | putassign(cpexpr(t2), cpexpr(t1)); | |
473 | ||
474 | for(k>>=1 ; k>1 ; k>>=1) | |
475 | { | |
476 | ++ncomma; | |
477 | putsteq(t1, t1); | |
478 | if(k & 1) | |
479 | { | |
480 | ++ncomma; | |
481 | putsteq(t2, t1); | |
482 | } | |
483 | } | |
484 | putx( mkexpr(OPSTAR, cpexpr(t2), | |
485 | mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) )); | |
486 | } | |
487 | putcomma(ncomma, type, NO); | |
488 | frexpr(t1); | |
489 | if(t2) | |
490 | frexpr(t2); | |
491 | frexpr(p); | |
492 | } | |
493 | ||
494 | ||
495 | ||
496 | ||
497 | LOCAL struct addrblock *intdouble(p, ncommap) | |
498 | struct addrblock *p; | |
499 | int *ncommap; | |
500 | { | |
501 | register struct addrblock *t; | |
502 | ||
503 | t = mktemp(TYDREAL, NULL); | |
504 | ++*ncommap; | |
505 | putassign(cpexpr(t), p); | |
506 | return(t); | |
507 | } | |
508 | ||
509 | ||
510 | ||
511 | ||
512 | ||
513 | LOCAL putcxeq(p) | |
514 | register struct exprblock *p; | |
515 | { | |
516 | register struct addrblock *lp, *rp; | |
517 | int ncomma; | |
518 | ||
519 | ncomma = 0; | |
520 | lp = putcx1(p->leftp, &ncomma); | |
521 | rp = putcx1(p->rightp, &ncomma); | |
522 | putassign(realpart(lp), realpart(rp)); | |
523 | if( ISCOMPLEX(p->vtype) ) | |
524 | { | |
525 | ++ncomma; | |
526 | putassign(imagpart(lp), imagpart(rp)); | |
527 | } | |
528 | putcomma(ncomma, TYREAL, NO); | |
529 | frexpr(rp); | |
530 | free(p); | |
531 | return(lp); | |
532 | } | |
533 | ||
534 | ||
535 | ||
536 | LOCAL putcxop(p) | |
537 | expptr p; | |
538 | { | |
539 | struct addrblock *putcx1(); | |
540 | int ncomma; | |
541 | ||
542 | ncomma = 0; | |
543 | putaddr( putcx1(p, &ncomma), NO); | |
544 | putcomma(ncomma, TYINT, NO); | |
545 | } | |
546 | ||
547 | ||
548 | ||
549 | LOCAL struct addrblock *putcx1(p, ncommap) | |
550 | register expptr p; | |
551 | int *ncommap; | |
552 | { | |
553 | struct addrblock *q, *lp, *rp; | |
554 | register struct addrblock *resp; | |
555 | int opcode; | |
556 | int ltype, rtype; | |
557 | ||
558 | if(p == NULL) | |
559 | return(NULL); | |
560 | ||
561 | switch(p->tag) | |
562 | { | |
563 | case TCONST: | |
564 | if( ISCOMPLEX(p->vtype) ) | |
565 | p = putconst(p); | |
566 | return( p ); | |
567 | ||
568 | case TADDR: | |
569 | if( ! addressable(p) ) | |
570 | { | |
571 | ++*ncommap; | |
572 | resp = mktemp(tyint, NULL); | |
573 | putassign( cpexpr(resp), p->memoffset ); | |
574 | p->memoffset = resp; | |
575 | } | |
576 | return( p ); | |
577 | ||
578 | case TEXPR: | |
579 | if( ISCOMPLEX(p->vtype) ) | |
580 | break; | |
581 | ++*ncommap; | |
582 | resp = mktemp(TYDREAL, NO); | |
583 | putassign( cpexpr(resp), p); | |
584 | return(resp); | |
585 | ||
586 | default: | |
587 | fatal1("putcx1: bad tag %d", p->tag); | |
588 | } | |
589 | ||
590 | opcode = p->opcode; | |
591 | if(opcode==OPCALL || opcode==OPCCALL) | |
592 | { | |
593 | ++*ncommap; | |
594 | return( putcall(p) ); | |
595 | } | |
596 | else if(opcode == OPASSIGN) | |
597 | { | |
598 | ++*ncommap; | |
599 | return( putcxeq(p) ); | |
600 | } | |
601 | resp = mktemp(p->vtype, NULL); | |
602 | if(lp = putcx1(p->leftp, ncommap) ) | |
603 | ltype = lp->vtype; | |
604 | if(rp = putcx1(p->rightp, ncommap) ) | |
605 | rtype = rp->vtype; | |
606 | ||
607 | switch(opcode) | |
608 | { | |
609 | case OPCOMMA: | |
610 | frexpr(resp); | |
611 | resp = rp; | |
612 | rp = NULL; | |
613 | break; | |
614 | ||
615 | case OPNEG: | |
616 | putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), NULL) ); | |
617 | putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), NULL) ); | |
618 | *ncommap += 2; | |
619 | break; | |
620 | ||
621 | case OPPLUS: | |
622 | case OPMINUS: | |
623 | putassign( realpart(resp), mkexpr(opcode, realpart(lp), realpart(rp) )); | |
624 | if(rtype < TYCOMPLEX) | |
625 | putassign( imagpart(resp), imagpart(lp) ); | |
626 | else if(ltype < TYCOMPLEX) | |
627 | { | |
628 | if(opcode == OPPLUS) | |
629 | putassign( imagpart(resp), imagpart(rp) ); | |
630 | else putassign( imagpart(resp), mkexpr(OPNEG, imagpart(rp), NULL) ); | |
631 | } | |
632 | else | |
633 | putassign( imagpart(resp), mkexpr(opcode, imagpart(lp), imagpart(rp) )); | |
634 | ||
635 | *ncommap += 2; | |
636 | break; | |
637 | ||
638 | case OPSTAR: | |
639 | if(ltype < TYCOMPLEX) | |
640 | { | |
641 | if( ISINT(ltype) ) | |
642 | lp = intdouble(lp, ncommap); | |
643 | putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(lp), realpart(rp) )); | |
644 | putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) )); | |
645 | } | |
646 | else if(rtype < TYCOMPLEX) | |
647 | { | |
648 | if( ISINT(rtype) ) | |
649 | rp = intdouble(rp, ncommap); | |
650 | putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(rp), realpart(lp) )); | |
651 | putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) )); | |
652 | } | |
653 | else { | |
654 | putassign( realpart(resp), mkexpr(OPMINUS, | |
655 | mkexpr(OPSTAR, realpart(lp), realpart(rp)), | |
656 | mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) )); | |
657 | putassign( imagpart(resp), mkexpr(OPPLUS, | |
658 | mkexpr(OPSTAR, realpart(lp), imagpart(rp)), | |
659 | mkexpr(OPSTAR, imagpart(lp), realpart(rp)) )); | |
660 | } | |
661 | *ncommap += 2; | |
662 | break; | |
663 | ||
664 | case OPSLASH: | |
665 | /* fixexpr has already replaced all divisions | |
666 | * by a complex by a function call | |
667 | */ | |
668 | if( ISINT(rtype) ) | |
669 | rp = intdouble(rp, ncommap); | |
670 | putassign( realpart(resp), mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) ); | |
671 | putassign( imagpart(resp), mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) ); | |
672 | *ncommap += 2; | |
673 | break; | |
674 | ||
675 | case OPCONV: | |
676 | putassign( realpart(resp), realpart(lp) ); | |
677 | if( ISCOMPLEX(lp->vtype) ) | |
678 | q = imagpart(lp); | |
679 | else if(rp != NULL) | |
680 | q = realpart(rp); | |
681 | else | |
682 | q = mkrealcon(TYDREAL, 0.0); | |
683 | putassign( imagpart(resp), q); | |
684 | *ncommap += 2; | |
685 | break; | |
686 | ||
687 | default: | |
688 | fatal1("putcx1 of invalid opcode %d", opcode); | |
689 | } | |
690 | ||
691 | frexpr(lp); | |
692 | frexpr(rp); | |
693 | free(p); | |
694 | return(resp); | |
695 | } | |
696 | ||
697 | ||
698 | ||
699 | ||
700 | LOCAL putcxcmp(p) | |
701 | register struct exprblock *p; | |
702 | { | |
703 | int opcode; | |
704 | int ncomma; | |
705 | register struct addrblock *lp, *rp; | |
706 | struct exprblock *q; | |
707 | ||
708 | ncomma = 0; | |
709 | opcode = p->opcode; | |
710 | lp = putcx1(p->leftp, &ncomma); | |
711 | rp = putcx1(p->rightp, &ncomma); | |
712 | ||
713 | q = mkexpr( opcode==OPEQ ? OPAND : OPOR , | |
714 | mkexpr(opcode, realpart(lp), realpart(rp)), | |
715 | mkexpr(opcode, imagpart(lp), imagpart(rp)) ); | |
716 | putx( fixexpr(q) ); | |
717 | putcomma(ncomma, TYINT, NO); | |
718 | ||
719 | free(lp); | |
720 | free(rp); | |
721 | free(p); | |
722 | } | |
723 | \f | |
724 | LOCAL struct addrblock *putch1(p, ncommap) | |
725 | register expptr p; | |
726 | int * ncommap; | |
727 | { | |
728 | register struct addrblock *t; | |
729 | struct addrblock *mktemp(), *putconst(); | |
730 | ||
731 | switch(p->tag) | |
732 | { | |
733 | case TCONST: | |
734 | return( putconst(p) ); | |
735 | ||
736 | case TADDR: | |
737 | return(p); | |
738 | ||
739 | case TEXPR: | |
740 | ++*ncommap; | |
741 | ||
742 | switch(p->opcode) | |
743 | { | |
744 | case OPCALL: | |
745 | case OPCCALL: | |
746 | t = putcall(p); | |
747 | break; | |
748 | ||
749 | case OPCONCAT: | |
750 | t = mktemp(TYCHAR, cpexpr(p->vleng) ); | |
751 | putcat( cpexpr(t), p ); | |
752 | break; | |
753 | ||
754 | case OPCONV: | |
755 | if(!ISICON(p->vleng) || p->vleng->const.ci!=1 | |
756 | || ! INT(p->leftp->vtype) ) | |
757 | fatal("putch1: bad character conversion"); | |
758 | t = mktemp(TYCHAR, ICON(1) ); | |
759 | putassign( cpexpr(t), p); | |
760 | break; | |
761 | default: | |
762 | fatal1("putch1: invalid opcode %d", p->opcode); | |
763 | } | |
764 | return(t); | |
765 | ||
766 | default: | |
767 | fatal1("putch1: bad tag %d", p->tag); | |
768 | } | |
769 | /* NOTREACHED */ | |
770 | } | |
771 | \f | |
772 | ||
773 | ||
774 | ||
775 | LOCAL putchop(p) | |
776 | expptr p; | |
777 | { | |
778 | int ncomma; | |
779 | ||
780 | ncomma = 0; | |
781 | putaddr( putch1(p, &ncomma) , NO ); | |
782 | putcomma(ncomma, TYCHAR, YES); | |
783 | } | |
784 | ||
785 | ||
786 | ||
787 | ||
788 | LOCAL putcheq(p) | |
789 | register struct exprblock *p; | |
790 | { | |
791 | int ncomma; | |
792 | ||
793 | ncomma = 0; | |
794 | if( p->rightp->tag==TEXPR && p->rightp->opcode==OPCONCAT ) | |
795 | putcat(p->leftp, p->rightp); | |
796 | else if( ISONE(p->leftp->vleng) && ISONE(p->rightp->vleng) ) | |
797 | { | |
798 | putaddr( putch1(p->leftp, &ncomma) , YES ); | |
799 | putaddr( putch1(p->rightp, &ncomma) , YES ); | |
800 | p2op(P2ASSIGN, P2CHAR); | |
801 | } | |
802 | else putx( call2(TYINT, "s_copy", p->leftp, p->rightp) ); | |
803 | ||
804 | putcomma(ncomma, TYINT, NO); | |
805 | frexpr(p->vleng); | |
806 | free(p); | |
807 | } | |
808 | ||
809 | ||
810 | ||
811 | ||
812 | LOCAL putchcmp(p) | |
813 | register struct exprblock *p; | |
814 | { | |
815 | int ncomma; | |
816 | ||
817 | ncomma = 0; | |
818 | if(ISONE(p->leftp->vleng) && ISONE(p->rightp->vleng) ) | |
819 | { | |
820 | putaddr( putch1(p->leftp, &ncomma) , YES ); | |
821 | putaddr( putch1(p->rightp, &ncomma) , YES ); | |
822 | p2op(ops2[p->opcode], P2CHAR); | |
823 | free(p); | |
824 | putcomma(ncomma, TYINT, NO); | |
825 | } | |
826 | else | |
827 | { | |
828 | p->leftp = call2(TYINT,"s_cmp", p->leftp, p->rightp); | |
829 | p->rightp = ICON(0); | |
830 | putop(p); | |
831 | } | |
832 | } | |
833 | ||
834 | ||
835 | ||
836 | ||
837 | ||
838 | LOCAL putcat(lhs, rhs) | |
839 | register struct addrblock *lhs; | |
840 | register expptr rhs; | |
841 | { | |
842 | int n, ncomma; | |
843 | struct addrblock *lp, *cp; | |
844 | ||
845 | ncomma = 0; | |
846 | n = ncat(rhs); | |
847 | lp = mktmpn(n, TYLENG, NULL); | |
848 | cp = mktmpn(n, TYADDR, NULL); | |
849 | ||
850 | n = 0; | |
851 | putct1(rhs, lp, cp, &n, &ncomma); | |
852 | ||
853 | putx( call4(TYSUBR, "s_cat", lhs, cp, lp, ICON(n) ) ); | |
854 | putcomma(ncomma, TYINT, NO); | |
855 | } | |
856 | ||
857 | ||
858 | ||
859 | ||
860 | ||
861 | LOCAL ncat(p) | |
862 | register expptr p; | |
863 | { | |
864 | if(p->tag==TEXPR && p->opcode==OPCONCAT) | |
865 | return( ncat(p->leftp) + ncat(p->rightp) ); | |
866 | else return(1); | |
867 | } | |
868 | ||
869 | ||
870 | ||
871 | ||
872 | LOCAL putct1(q, lp, cp, ip, ncommap) | |
873 | register expptr q; | |
874 | register struct addrblock *lp, *cp; | |
875 | int *ip, *ncommap; | |
876 | { | |
877 | int i; | |
878 | struct addrblock *lp1, *cp1; | |
879 | ||
880 | if(q->tag==TEXPR && q->opcode==OPCONCAT) | |
881 | { | |
882 | putct1(q->leftp, lp, cp, ip, ncommap); | |
883 | putct1(q->rightp, lp, cp , ip, ncommap); | |
884 | frexpr(q->vleng); | |
885 | free(q); | |
886 | } | |
887 | else | |
888 | { | |
889 | i = (*ip)++; | |
890 | lp1 = cpexpr(lp); | |
891 | lp1->memoffset = mkexpr(OPPLUS, lp1->memoffset, ICON(i*SZLENG)); | |
892 | cp1 = cpexpr(cp); | |
893 | cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR)); | |
894 | putassign( lp1, cpexpr(q->vleng) ); | |
895 | putassign( cp1, addrof(putch1(q,ncommap)) ); | |
896 | *ncommap += 2; | |
897 | } | |
898 | } | |
899 | \f | |
900 | LOCAL putaddr(p, indir) | |
901 | register struct addrblock *p; | |
902 | int indir; | |
903 | { | |
904 | int type, type2, funct; | |
905 | ftnint offset, simoffset(); | |
906 | expptr offp, shorten(); | |
907 | ||
908 | type = p->vtype; | |
909 | type2 = types2[type]; | |
910 | funct = (p->vclass==CLPROC ? P2FUNCT<<2 : 0); | |
911 | ||
912 | offp = (p->memoffset ? cpexpr(p->memoffset) : NULL); | |
913 | ||
914 | ||
915 | #if (FUDGEOFFSET != 1) | |
916 | if(offp) | |
917 | offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp); | |
918 | #endif | |
919 | ||
920 | offset = simoffset( &offp ); | |
921 | #if SZINT < SZLONG | |
922 | if(offp) | |
923 | if(shortsubs) | |
924 | offp = shorten(offp); | |
925 | else | |
926 | offp = mkconv(TYINT, offp); | |
927 | #else | |
928 | if(offp) | |
929 | offp = mkconv(TYINT, offp); | |
930 | #endif | |
931 | ||
932 | switch(p->vstg) | |
933 | { | |
934 | case STGAUTO: | |
935 | if(indir && !offp) | |
936 | { | |
937 | p2oreg(offset, AUTOREG, type2); | |
938 | break; | |
939 | } | |
940 | ||
941 | if(!indir && !offp && !offset) | |
942 | { | |
943 | p2reg(AUTOREG, type2 | P2PTR); | |
944 | break; | |
945 | } | |
946 | ||
947 | p2reg(AUTOREG, type2 | P2PTR); | |
948 | if(offp) | |
949 | { | |
950 | putx(offp); | |
951 | if(offset) | |
952 | p2icon(offset, P2INT); | |
953 | } | |
954 | else | |
955 | p2icon(offset, P2INT); | |
956 | if(offp && offset) | |
957 | p2op(P2PLUS, type2 | P2PTR); | |
958 | p2op(P2PLUS, type2 | P2PTR); | |
959 | if(offp && offset) | |
960 | if(indir) | |
961 | p2op(P2INDIRECT, type2); | |
962 | break; | |
963 | ||
964 | case STGARG: | |
965 | p2oreg( | |
966 | #ifdef ARGOFFSET | |
967 | ARGOFFSET + | |
968 | #endif | |
969 | (ftnint) (FUDGEOFFSET*p->memno), | |
970 | ARGREG, type2 | P2PTR | funct ); | |
971 | ||
972 | if(offp) | |
973 | putx(offp); | |
974 | if(offset) | |
975 | p2icon(offset, P2INT); | |
976 | if(offp && offset) | |
977 | p2op(P2PLUS, type2 | P2PTR); | |
978 | if(offp || offset) | |
979 | p2op(P2PLUS, type2 | P2PTR); | |
980 | if(indir) | |
981 | p2op(P2INDIRECT, type2); | |
982 | break; | |
983 | ||
984 | case STGLENG: | |
985 | if(indir) | |
986 | { | |
987 | p2oreg( | |
988 | #ifdef ARGOFFSET | |
989 | ARGOFFSET + | |
990 | #endif | |
991 | (ftnint) (FUDGEOFFSET*p->memno), | |
992 | ARGREG, type2 | P2PTR | funct); | |
993 | } | |
994 | else { | |
995 | p2op(P2PLUS, types2[TYLENG] | P2PTR ); | |
996 | p2reg(ARGREG, types2[TYLENG] | P2PTR ); | |
997 | p2icon( | |
998 | #ifdef ARGOFFSET | |
999 | ARGOFFSET + | |
1000 | #endif | |
1001 | (ftnint) (FUDGEOFFSET*p->memno), P2INT); | |
1002 | } | |
1003 | break; | |
1004 | ||
1005 | ||
1006 | case STGBSS: | |
1007 | case STGINIT: | |
1008 | case STGEXT: | |
1009 | case STGCOMMON: | |
1010 | case STGEQUIV: | |
1011 | case STGCONST: | |
1012 | if(offp) | |
1013 | { | |
1014 | putx(offp); | |
1015 | putmem(p, P2ICON, offset); | |
1016 | p2op(P2PLUS, type2 | P2PTR); | |
1017 | if(indir) | |
1018 | p2op(P2INDIRECT, type2); | |
1019 | } | |
1020 | else | |
1021 | putmem(p, (indir ? P2NAME : P2ICON), offset); | |
1022 | ||
1023 | break; | |
1024 | ||
1025 | case STGREG: | |
1026 | if(indir) | |
1027 | p2reg(p->memno, type2); | |
1028 | else | |
1029 | fatal("attempt to take address of a register"); | |
1030 | break; | |
1031 | ||
1032 | default: | |
1033 | fatal1("putaddr: invalid vstg %d", p->vstg); | |
1034 | } | |
1035 | frexpr(p); | |
1036 | } | |
1037 | ||
1038 | ||
1039 | ||
1040 | ||
1041 | LOCAL putmem(p, class, offset) | |
1042 | expptr p; | |
1043 | int class; | |
1044 | ftnint offset; | |
1045 | { | |
1046 | int type2; | |
1047 | int funct; | |
1048 | char *name, *memname(); | |
1049 | ||
1050 | funct = (p->vclass==CLPROC ? P2FUNCT<<2 : 0); | |
1051 | type2 = types2[p->vtype]; | |
1052 | if(p->vclass == CLPROC) | |
1053 | type2 |= (P2FUNCT<<2); | |
1054 | name = memname(p->vstg, p->memno); | |
1055 | if(class == P2ICON) | |
1056 | { | |
1057 | p2triple(P2ICON, name[0]!='\0', type2|P2PTR); | |
1058 | p2word(offset); | |
1059 | if(name[0]) | |
1060 | p2name(name); | |
1061 | } | |
1062 | else | |
1063 | { | |
1064 | p2triple(P2NAME, offset!=0, type2); | |
1065 | if(offset != 0) | |
1066 | p2word(offset); | |
1067 | p2name(name); | |
1068 | } | |
1069 | } | |
1070 | ||
1071 | ||
1072 | \f | |
1073 | LOCAL struct addrblock *putcall(p) | |
1074 | struct exprblock *p; | |
1075 | { | |
1076 | chainp arglist, charsp, cp; | |
1077 | int n, first; | |
1078 | struct addrblock *t; | |
1079 | struct exprblock *q; | |
1080 | struct exprblock *fval; | |
1081 | int type, type2, ctype, indir; | |
1082 | ||
1083 | type2 = types2[type = p->vtype]; | |
1084 | charsp = NULL; | |
1085 | indir = (p->opcode == OPCCALL); | |
1086 | n = 0; | |
1087 | first = YES; | |
1088 | ||
1089 | if(p->rightp) | |
1090 | { | |
1091 | arglist = p->rightp->listp; | |
1092 | free(p->rightp); | |
1093 | } | |
1094 | else | |
1095 | arglist = NULL; | |
1096 | ||
1097 | for(cp = arglist ; cp ; cp = cp->nextp) | |
1098 | if(indir) | |
1099 | ++n; | |
1100 | else { | |
1101 | q = cp->datap; | |
1102 | if(q->tag == TCONST) | |
1103 | cp->datap = q = putconst(q); | |
1104 | if( ISCHAR(q) ) | |
1105 | { | |
1106 | charsp = hookup(charsp, mkchain(cpexpr(q->vleng), 0) ); | |
1107 | n += 2; | |
1108 | } | |
1109 | else if(q->vclass == CLPROC) | |
1110 | { | |
1111 | charsp = hookup(charsp, mkchain( ICON(0) , 0)); | |
1112 | n += 2; | |
1113 | } | |
1114 | else | |
1115 | n += 1; | |
1116 | } | |
1117 | ||
1118 | if(type == TYCHAR) | |
1119 | { | |
1120 | if( ISICON(p->vleng) ) | |
1121 | { | |
1122 | fval = mktemp(TYCHAR, p->vleng); | |
1123 | n += 2; | |
1124 | } | |
1125 | else { | |
1126 | err("adjustable character function"); | |
1127 | return; | |
1128 | } | |
1129 | } | |
1130 | else if( ISCOMPLEX(type) ) | |
1131 | { | |
1132 | fval = mktemp(type, NULL); | |
1133 | n += 1; | |
1134 | } | |
1135 | else | |
1136 | fval = NULL; | |
1137 | ||
1138 | ctype = (fval ? P2INT : type2); | |
1139 | putaddr(p->leftp, NO); | |
1140 | ||
1141 | if(fval) | |
1142 | { | |
1143 | first = NO; | |
1144 | putaddr( cpexpr(fval), NO); | |
1145 | if(type==TYCHAR) | |
1146 | { | |
1147 | putx( cpexpr(p->vleng) ); | |
1148 | p2op(P2LISTOP, type2); | |
1149 | } | |
1150 | } | |
1151 | ||
1152 | for(cp = arglist ; cp ; cp = cp->nextp) | |
1153 | { | |
1154 | q = cp->datap; | |
1155 | if(q->tag==TADDR && (indir || q->vstg!=STGREG) ) | |
1156 | putaddr(q, indir && q->vtype!=TYCHAR); | |
1157 | else if( ISCOMPLEX(q->vtype) ) | |
1158 | putcxop(q); | |
1159 | else if (ISCHAR(q) ) | |
1160 | putchop(q); | |
1161 | else if( ! ISERROR(q) ) | |
1162 | { | |
1163 | if(indir) | |
1164 | putx(q); | |
1165 | else { | |
1166 | t = mktemp(q->vtype, q->vleng); | |
1167 | putassign( cpexpr(t), q ); | |
1168 | putaddr(t, NO); | |
1169 | putcomma(1, q->vtype, YES); | |
1170 | } | |
1171 | } | |
1172 | if(first) | |
1173 | first = NO; | |
1174 | else | |
1175 | p2op(P2LISTOP, type2); | |
1176 | } | |
1177 | ||
1178 | if(arglist) | |
1179 | frchain(&arglist); | |
1180 | for(cp = charsp ; cp ; cp = cp->nextp) | |
1181 | { | |
1182 | putx( mkconv(TYLENG,cp->datap) ); | |
1183 | p2op(P2LISTOP, type2); | |
1184 | } | |
1185 | frchain(&charsp); | |
1186 | p2op(n>0 ? P2CALL : P2CALL0 , ctype); | |
1187 | free(p); | |
1188 | return(fval); | |
1189 | } | |
1190 | ||
1191 | ||
1192 | ||
1193 | LOCAL putmnmx(p) | |
1194 | register struct exprblock *p; | |
1195 | { | |
1196 | int op, type; | |
1197 | int ncomma; | |
1198 | struct exprblock *qp; | |
1199 | chainp p0, p1; | |
1200 | struct addrblock *sp, *tp; | |
1201 | ||
1202 | type = p->vtype; | |
1203 | op = (p->opcode==OPMIN ? OPLT : OPGT ); | |
1204 | p0 = p->leftp->listp; | |
1205 | free(p->leftp); | |
1206 | free(p); | |
1207 | ||
1208 | sp = mktemp(type, NULL); | |
1209 | tp = mktemp(type, NULL); | |
1210 | qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp)); | |
1211 | qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp); | |
1212 | qp = fixexpr(qp); | |
1213 | ||
1214 | ncomma = 1; | |
1215 | putassign( cpexpr(sp), p0->datap ); | |
1216 | ||
1217 | for(p1 = p0->nextp ; p1 ; p1 = p1->nextp) | |
1218 | { | |
1219 | ++ncomma; | |
1220 | putassign( cpexpr(tp), p1->datap ); | |
1221 | if(p1->nextp) | |
1222 | { | |
1223 | ++ncomma; | |
1224 | putassign( cpexpr(sp), cpexpr(qp) ); | |
1225 | } | |
1226 | else | |
1227 | putx(qp); | |
1228 | } | |
1229 | ||
1230 | putcomma(ncomma, type, NO); | |
1231 | frtemp(sp); | |
1232 | frtemp(tp); | |
1233 | frchain( &p0 ); | |
1234 | } | |
1235 | ||
1236 | ||
1237 | ||
1238 | ||
1239 | LOCAL putcomma(n, type, indir) | |
1240 | int n, type, indir; | |
1241 | { | |
1242 | type = types2[type]; | |
1243 | if(indir) | |
1244 | type |= P2PTR; | |
1245 | while(--n >= 0) | |
1246 | p2op(P2COMOP, type); | |
1247 | } | |
1248 | ||
1249 | ||
1250 | ||
1251 | ||
1252 | ftnint simoffset(p0) | |
1253 | expptr *p0; | |
1254 | { | |
1255 | ftnint offset, prod; | |
1256 | register expptr p, lp, rp; | |
1257 | ||
1258 | offset = 0; | |
1259 | p = *p0; | |
1260 | if(p == NULL) | |
1261 | return(0); | |
1262 | ||
1263 | if( ! ISINT(p->vtype) ) | |
1264 | return(0); | |
1265 | ||
1266 | if(p->tag==TEXPR && p->opcode==OPSTAR) | |
1267 | { | |
1268 | lp = p->leftp; | |
1269 | rp = p->rightp; | |
1270 | if(ISICON(rp) && lp->tag==TEXPR && lp->opcode==OPPLUS && ISICON(lp->rightp)) | |
1271 | { | |
1272 | p->opcode = OPPLUS; | |
1273 | lp->opcode = OPSTAR; | |
1274 | prod = rp->const.ci * lp->rightp->const.ci; | |
1275 | lp->rightp->const.ci = rp->const.ci; | |
1276 | rp->const.ci = prod; | |
1277 | } | |
1278 | } | |
1279 | ||
1280 | if(p->tag==TEXPR && p->opcode==OPPLUS && ISICON(p->rightp)) | |
1281 | { | |
1282 | rp = p->rightp; | |
1283 | lp = p->leftp; | |
1284 | offset += rp->const.ci; | |
1285 | frexpr(rp); | |
1286 | free(p); | |
1287 | *p0 = lp; | |
1288 | } | |
1289 | ||
1290 | if(p->tag == TCONST) | |
1291 | { | |
1292 | offset += p->const.ci; | |
1293 | frexpr(p); | |
1294 | *p0 = NULL; | |
1295 | } | |
1296 | ||
1297 | return(offset); | |
1298 | } | |
1299 | \f | |
1300 | ||
1301 | ||
1302 | ||
1303 | ||
1304 | p2op(op, type) | |
1305 | int op, type; | |
1306 | { | |
1307 | p2triple(op, 0, type); | |
1308 | } | |
1309 | ||
1310 | p2icon(offset, type) | |
1311 | ftnint offset; | |
1312 | int type; | |
1313 | { | |
1314 | p2triple(P2ICON, 0, type); | |
1315 | p2word(offset); | |
1316 | } | |
1317 | ||
1318 | ||
1319 | ||
1320 | ||
1321 | p2oreg(offset, reg, type) | |
1322 | ftnint offset; | |
1323 | int reg, type; | |
1324 | { | |
1325 | p2triple(P2OREG, reg, type); | |
1326 | p2word(offset); | |
1327 | p2name(""); | |
1328 | } | |
1329 | ||
1330 | ||
1331 | ||
1332 | ||
1333 | p2reg(reg, type) | |
1334 | int reg, type; | |
1335 | { | |
1336 | p2triple(P2REG, reg, type); | |
1337 | } | |
1338 | ||
1339 | ||
1340 | ||
1341 | p2pass(s) | |
1342 | char *s; | |
1343 | { | |
1344 | p2triple(P2PASS, (strlen(s) + FOUR-1)/FOUR, 0); | |
1345 | p2str(s); | |
1346 | } | |
1347 | ||
1348 | ||
1349 | ||
1350 | ||
1351 | p2str(s) | |
1352 | register char *s; | |
1353 | { | |
1354 | union { long int word; char str[FOUR]; } u; | |
1355 | register int i; | |
1356 | ||
1357 | i = 0; | |
1358 | u.word = 0; | |
1359 | while(*s) | |
1360 | { | |
1361 | u.str[i++] = *s++; | |
1362 | if(i == FOUR) | |
1363 | { | |
1364 | p2word(u.word); | |
1365 | u.word = 0; | |
1366 | i = 0; | |
1367 | } | |
1368 | } | |
1369 | if(i > 0) | |
1370 | p2word(u.word); | |
1371 | } | |
1372 | ||
1373 | ||
1374 | ||
1375 | ||
1376 | p2triple(op, var, type) | |
1377 | int op, var, type; | |
1378 | { | |
1379 | register long word; | |
1380 | word = op | (var<<8); | |
1381 | word |= ( (long int) type) <<16; | |
1382 | p2word(word); | |
1383 | } | |
1384 | ||
1385 | ||
1386 | ||
1387 | ||
1388 | p2name(s) | |
1389 | char *s; | |
1390 | { | |
1391 | int i; | |
1392 | union { long int word[2]; char str[8]; } u; | |
1393 | ||
1394 | u.word[0] = u.word[1] = 0; | |
1395 | for(i = 0 ; i<8 && *s ; ++i) | |
1396 | u.str[i] = *s++; | |
1397 | p2word(u.word[0]); | |
1398 | p2word(u.word[1]); | |
1399 | } | |
1400 | ||
1401 | ||
1402 | ||
1403 | ||
1404 | p2word(w) | |
1405 | long int w; | |
1406 | { | |
1407 | *p2bufp++ = w; | |
1408 | if(p2bufp >= p2bufend) | |
1409 | p2flush(); | |
1410 | } | |
1411 | ||
1412 | ||
1413 | ||
1414 | p2flush() | |
1415 | { | |
1416 | if(p2bufp > p2buff) | |
1417 | write(fileno(textfile), p2buff, (p2bufp-p2buff)*sizeof(long int)); | |
1418 | p2bufp = p2buff; | |
1419 | } |