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