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