![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to putpcc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / f77.tahoe / f77pass1|
Return to putpcc.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / f77.tahoe / f77pass1 |
1.1 root 1: /*
2: * Copyright (c) 1980 Regents of the University of California.
3: * All rights reserved. The Berkeley software License Agreement
4: * specifies the terms and conditions for redistribution.
5: */
6:
7: #ifndef lint
8: static char sccsid[] = "@(#)putpcc.c 5.1 (Berkeley) 6/7/85";
9: #endif not lint
10:
11: /*
12: * putpcc.c
13: *
14: * Intermediate code generation for S. C. Johnson C compilers
15: * New version using binary polish postfix intermediate
16: *
17: * University of Utah CS Dept modification history:
18: *
19: * $Header: putpcc.c,v 3.2 85/03/25 09:35:57 root Exp $
20: * $Log: putpcc.c,v $
21: * Revision 3.2 85/03/25 09:35:57 root
22: * fseek return -1 on error.
23: *
24: * Revision 3.1 85/02/27 19:06:55 donn
25: * Changed to use pcc.h instead of pccdefs.h.
26: *
27: * Revision 2.12 85/02/22 01:05:54 donn
28: * putaddr() didn't know about intrinsic functions...
29: *
30: * Revision 2.11 84/11/28 21:28:49 donn
31: * Hacked putop() to handle any character expression being converted to int,
32: * not just function calls. Previously it bombed on concatenations.
33: *
34: * Revision 2.10 84/11/01 22:07:07 donn
35: * Yet another try at getting putop() to work right. It appears that the
36: * second pass can't abide certain explicit conversions (e.g. short to long)
37: * so the conversion code in putop() tries to remove them. I think this
38: * version (finally) works.
39: *
40: * Revision 2.9 84/10/29 02:30:57 donn
41: * Earlier fix to putop() for conversions was insufficient -- we NEVER want to
42: * see the type of the left operand of the thing left over from stripping off
43: * conversions...
44: *
45: * Revision 2.8 84/09/18 03:09:21 donn
46: * Fixed bug in putop() where the left operand of an addrblock was being
47: * extracted... This caused an extremely obscure conversion error when
48: * an array of longs was subscripted by a short.
49: *
50: * Revision 2.7 84/08/19 20:10:19 donn
51: * Removed stuff in putbranch that treats STGARG parameters specially -- the
52: * bug in the code generation pass that motivated it has been fixed.
53: *
54: * Revision 2.6 84/08/07 21:32:23 donn
55: * Bumped the size of the buffer for the intermediate code file from 0.5K
56: * to 4K on a VAX.
57: *
58: * Revision 2.5 84/08/04 20:26:43 donn
59: * Fixed a goof in the new putbranch() -- it now calls mkaltemp instead of
60: * mktemp(). Correction due to Jerry Berkman.
61: *
62: * Revision 2.4 84/07/24 19:07:15 donn
63: * Fixed bug reported by Craig Leres in which putmnmx() mistakenly assumed
64: * that mkaltemp() returns tempblocks, and tried to free them with frtemp().
65: *
66: * Revision 2.3 84/07/19 17:22:09 donn
67: * Changed putch1() so that OPPAREN expressions of type CHARACTER are legal.
68: *
69: * Revision 2.2 84/07/19 12:30:38 donn
70: * Fixed a type clash in Bob Corbett's new putbranch().
71: *
72: * Revision 2.1 84/07/19 12:04:27 donn
73: * Changed comment headers for UofU.
74: *
75: * Revision 1.8 84/07/19 11:38:23 donn
76: * Replaced putbranch() routine so that you can ASSIGN into argument variables.
77: * The code is from Bob Corbett, donated by Jerry Berkman.
78: *
79: * Revision 1.7 84/05/31 00:48:32 donn
80: * Fixed an extremely obscure bug dealing with the comparison of CHARACTER*1
81: * expressions -- a foulup in the order of COMOP and the comparison caused
82: * one operand of the comparison to be garbage.
83: *
84: * Revision 1.6 84/04/16 09:54:19 donn
85: * Backed out earlier fix for bug where items in the argtemplist were
86: * (incorrectly) being given away; this is now fixed in mkargtemp().
87: *
88: * Revision 1.5 84/03/23 22:49:48 donn
89: * Took out the initialization of the subroutine argument temporary list in
90: * putcall() -- it needs to be done once per statement instead of once per call.
91: *
92: * Revision 1.4 84/03/01 06:48:05 donn
93: * Fixed bug in Bob Corbett's code for argument temporaries that caused an
94: * addrblock to get thrown out inadvertently when it was needed for recycling
95: * purposes later on.
96: *
97: * Revision 1.3 84/02/26 06:32:38 donn
98: * Added Berkeley changes to move data definitions around and reduce offsets.
99: *
100: * Revision 1.2 84/02/26 06:27:45 donn
101: * Added code to catch TTEMP values passed to putx().
102: *
103: */
104:
105: #if FAMILY != PCC
106: WRONG put FILE !!!!
107: #endif
108:
109: #include "defs.h"
110: #include <pcc.h>
111:
112: Addrp putcall(), putcxeq(), putcx1(), realpart();
113: expptr imagpart();
114: ftnint lencat();
115:
116: #define FOUR 4
117: extern int ops2[];
118: extern int types2[];
119:
120: #if HERE==VAX || HERE == TAHOE
121: #define PCC_BUFFMAX 1024
122: #else
123: #define PCC_BUFFMAX 128
124: #endif
125: static long int p2buff[PCC_BUFFMAX];
126: static long int *p2bufp = &p2buff[0];
127: static long int *p2bufend = &p2buff[PCC_BUFFMAX];
128:
129:
130: puthead(s, class)
131: char *s;
132: int class;
133: {
134: char buff[100];
135: #if TARGET == VAX || TARGET == TAHOE
136: if(s)
137: p2ps("\t.globl\t_%s", s);
138: #endif
139: /* put out fake copy of left bracket line, to be redone later */
140: if( ! headerdone )
141: {
142: #if FAMILY == PCC
143: p2flush();
144: #endif
145: headoffset = ftell(textfile);
146: prhead(textfile);
147: headerdone = YES;
148: p2triple(PCCF_FEXPR, (strlen(infname)+ALILONG-1)/ALILONG, 0);
149: p2str(infname);
150: #if TARGET == PDP11
151: /* fake jump to start the optimizer */
152: if(class != CLBLOCK)
153: putgoto( fudgelabel = newlabel() );
154: #endif
155:
156: #if TARGET == VAX || TARGET == TAHOE
157: /* jump from top to bottom */
158: if(s!=CNULL && class!=CLBLOCK)
159: {
160: int proflab = newlabel();
161: p2pass("\t.align\t1");
162: p2ps("_%s:", s);
163: p2pi("\t.word\tLWM%d", procno);
164: prsave(proflab);
165: #if TARGET == VAX
166: p2pi("\tjbr\tL%d",
167: #else
168: putgoto(
169: #endif
170: fudgelabel = newlabel());
171: }
172: #endif
173: }
174: }
175:
176:
177:
178:
179:
180: /* It is necessary to precede each procedure with a "left bracket"
181: * line that tells pass 2 how many register variables and how
182: * much automatic space is required for the function. This compiler
183: * does not know how much automatic space is needed until the
184: * entire procedure has been processed. Therefore, "puthead"
185: * is called at the begining to record the current location in textfile,
186: * then to put out a placeholder left bracket line. This procedure
187: * repositions the file and rewrites that line, then puts the
188: * file pointer back to the end of the file.
189: */
190:
191: putbracket()
192: {
193: long int hereoffset;
194:
195: #if FAMILY == PCC
196: p2flush();
197: #endif
198: hereoffset = ftell(textfile);
199: if(fseek(textfile, headoffset, 0) == -1)
200: fatal("fseek failed");
201: prhead(textfile);
202: if(fseek(textfile, hereoffset, 0) == -1)
203: fatal("fseek failed 2");
204: }
205:
206:
207:
208:
209: putrbrack(k)
210: int k;
211: {
212: p2op(PCCF_FRBRAC, k);
213: }
214:
215:
216:
217: putnreg()
218: {
219: }
220:
221:
222:
223:
224:
225:
226: puteof()
227: {
228: p2op(PCCF_FEOF, 0);
229: p2flush();
230: }
231:
232:
233:
234: putstmt()
235: {
236: p2triple(PCCF_FEXPR, 0, lineno);
237: }
238:
239:
240:
241:
242: /* put out code for if( ! p) goto l */
243: putif(p,l)
244: register expptr p;
245: int l;
246: {
247: register int k;
248:
249: if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
250: {
251: if(k != TYERROR)
252: err("non-logical expression in IF statement");
253: frexpr(p);
254: }
255: else
256: {
257: putex1(p);
258: p2icon( (long int) l , PCCT_INT);
259: p2op(PCC_CBRANCH, 0);
260: putstmt();
261: }
262: }
263:
264:
265:
266:
267:
268: /* put out code for goto l */
269: putgoto(label)
270: int label;
271: {
272: p2triple(PCC_GOTO, 1, label);
273: putstmt();
274: }
275:
276:
277: /* branch to address constant or integer variable */
278: putbranch(p)
279: register Addrp p;
280: {
281: putex1((expptr) p);
282: p2op(PCC_GOTO, PCCT_INT);
283: putstmt();
284: }
285:
286:
287:
288: /* put out label l: */
289: putlabel(label)
290: int label;
291: {
292: p2op(PCCF_FLABEL, label);
293: }
294:
295:
296:
297:
298: putexpr(p)
299: expptr p;
300: {
301: putex1(p);
302: putstmt();
303: }
304:
305:
306:
307:
308: putcmgo(index, nlab, labs)
309: expptr index;
310: int nlab;
311: struct Labelblock *labs[];
312: {
313: int i, labarray, skiplabel;
314:
315: if(! ISINT(index->headblock.vtype) )
316: {
317: execerr("computed goto index must be integer", CNULL);
318: return;
319: }
320:
321: #if TARGET == VAX || TARGET == TAHOE
322: /* use special case instruction */
323: casegoto(index, nlab, labs);
324: #else
325: labarray = newlabel();
326: preven(ALIADDR);
327: prlabel(asmfile, labarray);
328: prcona(asmfile, (ftnint) (skiplabel = newlabel()) );
329: for(i = 0 ; i < nlab ; ++i)
330: if( labs[i] )
331: prcona(asmfile, (ftnint)(labs[i]->labelno) );
332: prcmgoto(index, nlab, skiplabel, labarray);
333: putlabel(skiplabel);
334: #endif
335: }
336:
337: putx(p)
338: expptr p;
339: {
340: char *memname();
341: int opc;
342: int ncomma;
343: int type, k;
344:
345: if (!p)
346: return;
347:
348: switch(p->tag)
349: {
350: case TERROR:
351: free( (charptr) p );
352: break;
353:
354: case TCONST:
355: switch(type = p->constblock.vtype)
356: {
357: case TYLOGICAL:
358: type = tyint;
359: case TYLONG:
360: case TYSHORT:
361: p2icon(p->constblock.const.ci, types2[type]);
362: free( (charptr) p );
363: break;
364:
365: case TYADDR:
366: p2triple(PCC_ICON, 1, PCCT_INT|PCCTM_PTR);
367: p2word(0L);
368: p2name(memname(STGCONST,
369: (int) p->constblock.const.ci) );
370: free( (charptr) p );
371: break;
372:
373: default:
374: putx( putconst(p) );
375: break;
376: }
377: break;
378:
379: case TEXPR:
380: switch(opc = p->exprblock.opcode)
381: {
382: case OPCALL:
383: case OPCCALL:
384: if( ISCOMPLEX(p->exprblock.vtype) )
385: putcxop(p);
386: else putcall(p);
387: break;
388:
389: case OPMIN:
390: case OPMAX:
391: putmnmx(p);
392: break;
393:
394:
395: case OPASSIGN:
396: if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
397: || ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
398: frexpr( putcxeq(p) );
399: else if( ISCHAR(p) )
400: putcheq(p);
401: else
402: goto putopp;
403: break;
404:
405: case OPEQ:
406: case OPNE:
407: if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
408: ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
409: {
410: putcxcmp(p);
411: break;
412: }
413: case OPLT:
414: case OPLE:
415: case OPGT:
416: case OPGE:
417: if(ISCHAR(p->exprblock.leftp))
418: {
419: putchcmp(p);
420: break;
421: }
422: goto putopp;
423:
424: case OPPOWER:
425: putpower(p);
426: break;
427:
428: case OPSTAR:
429: #if FAMILY == PCC
430: /* m * (2**k) -> m<<k */
431: if(INT(p->exprblock.leftp->headblock.vtype) &&
432: ISICON(p->exprblock.rightp) &&
433: ( (k = log2(p->exprblock.rightp->constblock.const.ci))>0) )
434: {
435: p->exprblock.opcode = OPLSHIFT;
436: frexpr(p->exprblock.rightp);
437: p->exprblock.rightp = ICON(k);
438: goto putopp;
439: }
440: #endif
441:
442: case OPMOD:
443: goto putopp;
444: case OPPLUS:
445: case OPMINUS:
446: case OPSLASH:
447: case OPNEG:
448: if( ISCOMPLEX(p->exprblock.vtype) )
449: putcxop(p);
450: else goto putopp;
451: break;
452:
453: case OPCONV:
454: if( ISCOMPLEX(p->exprblock.vtype) )
455: putcxop(p);
456: else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
457: {
458: ncomma = 0;
459: putx( mkconv(p->exprblock.vtype,
460: realpart(putcx1(p->exprblock.leftp,
461: &ncomma))));
462: putcomma(ncomma, p->exprblock.vtype, NO);
463: free( (charptr) p );
464: }
465: else goto putopp;
466: break;
467:
468: case OPNOT:
469: case OPOR:
470: case OPAND:
471: case OPEQV:
472: case OPNEQV:
473: case OPADDR:
474: case OPPLUSEQ:
475: case OPSTAREQ:
476: case OPCOMMA:
477: case OPQUEST:
478: case OPCOLON:
479: case OPBITOR:
480: case OPBITAND:
481: case OPBITXOR:
482: case OPBITNOT:
483: case OPLSHIFT:
484: case OPRSHIFT:
485: putopp:
486: putop(p);
487: break;
488:
489: case OPPAREN:
490: putx (p->exprblock.leftp);
491: break;
492: default:
493: badop("putx", opc);
494: }
495: break;
496:
497: case TADDR:
498: putaddr(p, YES);
499: break;
500:
501: case TTEMP:
502: /*
503: * This type is sometimes passed to putx when errors occur
504: * upstream, I don't know why.
505: */
506: frexpr(p);
507: break;
508:
509: default:
510: badtag("putx", p->tag);
511: }
512: }
513:
514:
515:
516: LOCAL putop(p)
517: expptr p;
518: {
519: int k;
520: expptr lp, tp;
521: int pt, lt, tt;
522: int comma;
523: Addrp putch1();
524:
525: switch(p->exprblock.opcode) /* check for special cases and rewrite */
526: {
527: case OPCONV:
528: tt = pt = p->exprblock.vtype;
529: lp = p->exprblock.leftp;
530: lt = lp->headblock.vtype;
531: #if TARGET == VAX
532: if (pt == TYREAL && lt == TYDREAL)
533: {
534: putx(lp);
535: p2op(PCC_SCONV, PCCT_FLOAT);
536: return;
537: }
538: #endif
539: while(p->tag==TEXPR && p->exprblock.opcode==OPCONV && (
540: #if TARGET != TAHOE
541: (ISREAL(pt)&&ISREAL(lt)) ||
542: #endif
543: (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
544: {
545: #if SZINT < SZLONG
546: if(lp->tag != TEXPR)
547: {
548: if(pt==TYINT && lt==TYLONG)
549: break;
550: if(lt==TYINT && pt==TYLONG)
551: break;
552: }
553: #endif
554:
555: #if TARGET == VAX
556: if(pt==TYDREAL && lt==TYREAL)
557: {
558: if(lp->tag==TEXPR &&
559: lp->exprblock.opcode==OPCONV &&
560: lp->exprblock.leftp->headblock.vtype==TYDREAL)
561: {
562: putx(lp->exprblock.leftp);
563: p2op(PCC_SCONV, PCCT_FLOAT);
564: p2op(PCC_SCONV, PCCT_DOUBLE);
565: free( (charptr) p );
566: return;
567: }
568: else break;
569: }
570: #endif
571: if(lt==TYCHAR && lp->tag==TEXPR)
572: {
573: int ncomma = 0;
574: p->exprblock.leftp = (expptr) putch1(lp, &ncomma);
575: putop(p);
576: putcomma(ncomma, pt, NO);
577: free( (charptr) p );
578: return;
579: }
580: free( (charptr) p );
581: p = lp;
582: pt = lt;
583: if (p->tag == TEXPR)
584: {
585: lp = p->exprblock.leftp;
586: lt = lp->headblock.vtype;
587: }
588: }
589: if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
590: break;
591: putx(p);
592: if (types2[tt] != types2[pt] &&
593: ! ( (ISREAL(tt)&&ISREAL(pt)) ||
594: (INT(tt)&&(ONEOF(pt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
595: p2op(PCC_SCONV,types2[tt]);
596: return;
597:
598: case OPADDR:
599: comma = NO;
600: lp = p->exprblock.leftp;
601: if(lp->tag != TADDR)
602: {
603: tp = (expptr) mkaltemp
604: (lp->headblock.vtype,lp->headblock.vleng);
605: putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
606: lp = tp;
607: comma = YES;
608: }
609: putaddr(lp, NO);
610: if(comma)
611: putcomma(1, TYINT, NO);
612: free( (charptr) p );
613: return;
614: #if TARGET == VAX || TARGET == TAHOE
615: /* take advantage of a glitch in the code generator that does not check
616: the type clash in an assignment or comparison of an integer zero and
617: a floating left operand, and generates optimal code for the correct
618: type. (The PCC has no floating-constant node to encode this correctly.)
619: */
620: case OPASSIGN:
621: case OPLT:
622: case OPLE:
623: case OPGT:
624: case OPGE:
625: case OPEQ:
626: case OPNE:
627: if(ISREAL(p->exprblock.leftp->headblock.vtype) &&
628: ISREAL(p->exprblock.rightp->headblock.vtype) &&
629: ISCONST(p->exprblock.rightp) &&
630: p->exprblock.rightp->constblock.const.cd[0]==0)
631: {
632: p->exprblock.rightp->constblock.vtype = TYINT;
633: p->exprblock.rightp->constblock.const.ci = 0;
634: }
635: #endif
636: }
637:
638: if( (k = ops2[p->exprblock.opcode]) <= 0)
639: badop("putop", p->exprblock.opcode);
640: putx(p->exprblock.leftp);
641: if(p->exprblock.rightp)
642: putx(p->exprblock.rightp);
643: p2op(k, types2[p->exprblock.vtype]);
644:
645: if(p->exprblock.vleng)
646: frexpr(p->exprblock.vleng);
647: free( (charptr) p );
648: }
649:
650: putforce(t, p)
651: int t;
652: expptr p;
653: {
654: p = mkconv(t, fixtype(p));
655: putx(p);
656: p2op(PCC_FORCE,
657: #if TARGET == TAHOE
658: (t==TYLONG ? PCCT_LONG : (t==TYREAL ? PCCT_FLOAT : PCCT_DOUBLE)) );
659: #else
660: (t==TYSHORT ? PCCT_SHORT : (t==TYLONG ? PCCT_LONG : PCCT_DOUBLE)) );
661: #endif
662: putstmt();
663: }
664:
665:
666:
667: LOCAL putpower(p)
668: expptr p;
669: {
670: expptr base;
671: Addrp t1, t2;
672: ftnint k;
673: int type;
674: int ncomma;
675:
676: if(!ISICON(p->exprblock.rightp) ||
677: (k = p->exprblock.rightp->constblock.const.ci)<2)
678: fatal("putpower: bad call");
679: base = p->exprblock.leftp;
680: type = base->headblock.vtype;
681:
682: if ((k == 2) && base->tag == TADDR && ISCONST(base->addrblock.memoffset))
683: {
684: putx( mkexpr(OPSTAR,cpexpr(base),cpexpr(base)));
685:
686: return;
687: }
688: t1 = mkaltemp(type, PNULL);
689: t2 = NULL;
690: ncomma = 1;
691: putassign(cpexpr(t1), cpexpr(base) );
692:
693: for( ; (k&1)==0 && k>2 ; k>>=1 )
694: {
695: ++ncomma;
696: putsteq(t1, t1);
697: }
698:
699: if(k == 2)
700: putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) );
701: else
702: {
703: t2 = mkaltemp(type, PNULL);
704: ++ncomma;
705: putassign(cpexpr(t2), cpexpr(t1));
706:
707: for(k>>=1 ; k>1 ; k>>=1)
708: {
709: ++ncomma;
710: putsteq(t1, t1);
711: if(k & 1)
712: {
713: ++ncomma;
714: putsteq(t2, t1);
715: }
716: }
717: putx( mkexpr(OPSTAR, cpexpr(t2),
718: mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
719: }
720: putcomma(ncomma, type, NO);
721: frexpr(t1);
722: if(t2)
723: frexpr(t2);
724: frexpr(p);
725: }
726:
727:
728:
729:
730: LOCAL Addrp intdouble(p, ncommap)
731: Addrp p;
732: int *ncommap;
733: {
734: register Addrp t;
735:
736: t = mkaltemp(TYDREAL, PNULL);
737: ++*ncommap;
738: putassign(cpexpr(t), p);
739: return(t);
740: }
741:
742:
743:
744:
745:
746: LOCAL Addrp putcxeq(p)
747: register expptr p;
748: {
749: register Addrp lp, rp;
750: int ncomma;
751:
752: if(p->tag != TEXPR)
753: badtag("putcxeq", p->tag);
754:
755: ncomma = 0;
756: lp = putcx1(p->exprblock.leftp, &ncomma);
757: rp = putcx1(p->exprblock.rightp, &ncomma);
758: putassign(realpart(lp), realpart(rp));
759: if( ISCOMPLEX(p->exprblock.vtype) )
760: {
761: ++ncomma;
762: putassign(imagpart(lp), imagpart(rp));
763: }
764: putcomma(ncomma, TYREAL, NO);
765: frexpr(rp);
766: free( (charptr) p );
767: return(lp);
768: }
769:
770:
771:
772: LOCAL putcxop(p)
773: expptr p;
774: {
775: Addrp putcx1();
776: int ncomma;
777:
778: ncomma = 0;
779: putaddr( putcx1(p, &ncomma), NO);
780: putcomma(ncomma, TYINT, NO);
781: }
782:
783:
784:
785: LOCAL Addrp putcx1(p, ncommap)
786: register expptr p;
787: int *ncommap;
788: {
789: expptr q;
790: Addrp lp, rp;
791: register Addrp resp;
792: int opcode;
793: int ltype, rtype;
794: expptr mkrealcon();
795:
796: if(p == NULL)
797: return(NULL);
798:
799: switch(p->tag)
800: {
801: case TCONST:
802: if( ISCOMPLEX(p->constblock.vtype) )
803: p = (expptr) putconst(p);
804: return( (Addrp) p );
805:
806: case TADDR:
807: if( ! addressable(p) )
808: {
809: ++*ncommap;
810: resp = mkaltemp(tyint, PNULL);
811: putassign( cpexpr(resp), p->addrblock.memoffset );
812: p->addrblock.memoffset = (expptr)resp;
813: }
814: return( (Addrp) p );
815:
816: case TEXPR:
817: if( ISCOMPLEX(p->exprblock.vtype) )
818: break;
819: ++*ncommap;
820: resp = mkaltemp(TYDREAL, NO);
821: putassign( cpexpr(resp), p);
822: return(resp);
823:
824: default:
825: badtag("putcx1", p->tag);
826: }
827:
828: opcode = p->exprblock.opcode;
829: if(opcode==OPCALL || opcode==OPCCALL)
830: {
831: ++*ncommap;
832: return( putcall(p) );
833: }
834: else if(opcode == OPASSIGN)
835: {
836: ++*ncommap;
837: return( putcxeq(p) );
838: }
839: resp = mkaltemp(p->exprblock.vtype, PNULL);
840: if(lp = putcx1(p->exprblock.leftp, ncommap) )
841: ltype = lp->vtype;
842: if(rp = putcx1(p->exprblock.rightp, ncommap) )
843: rtype = rp->vtype;
844:
845: switch(opcode)
846: {
847: case OPPAREN:
848: frexpr (resp);
849: resp = lp;
850: lp = NULL;
851: break;
852:
853: case OPCOMMA:
854: frexpr(resp);
855: resp = rp;
856: rp = NULL;
857: break;
858:
859: case OPNEG:
860: putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), ENULL) );
861: putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), ENULL) );
862: *ncommap += 2;
863: break;
864:
865: case OPPLUS:
866: case OPMINUS:
867: putassign( realpart(resp),
868: mkexpr(opcode, realpart(lp), realpart(rp) ));
869: if(rtype < TYCOMPLEX)
870: putassign( imagpart(resp), imagpart(lp) );
871: else if(ltype < TYCOMPLEX)
872: {
873: if(opcode == OPPLUS)
874: putassign( imagpart(resp), imagpart(rp) );
875: else putassign( imagpart(resp),
876: mkexpr(OPNEG, imagpart(rp), ENULL) );
877: }
878: else
879: putassign( imagpart(resp),
880: mkexpr(opcode, imagpart(lp), imagpart(rp) ));
881:
882: *ncommap += 2;
883: break;
884:
885: case OPSTAR:
886: if(ltype < TYCOMPLEX)
887: {
888: if( ISINT(ltype) )
889: lp = intdouble(lp, ncommap);
890: putassign( realpart(resp),
891: mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
892: putassign( imagpart(resp),
893: mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
894: }
895: else if(rtype < TYCOMPLEX)
896: {
897: if( ISINT(rtype) )
898: rp = intdouble(rp, ncommap);
899: putassign( realpart(resp),
900: mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
901: putassign( imagpart(resp),
902: mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
903: }
904: else {
905: putassign( realpart(resp), mkexpr(OPMINUS,
906: mkexpr(OPSTAR, realpart(lp), realpart(rp)),
907: mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
908: putassign( imagpart(resp), mkexpr(OPPLUS,
909: mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
910: mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
911: }
912: *ncommap += 2;
913: break;
914:
915: case OPSLASH:
916: /* fixexpr has already replaced all divisions
917: * by a complex by a function call
918: */
919: if( ISINT(rtype) )
920: rp = intdouble(rp, ncommap);
921: putassign( realpart(resp),
922: mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
923: putassign( imagpart(resp),
924: mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
925: *ncommap += 2;
926: break;
927:
928: case OPCONV:
929: putassign( realpart(resp), realpart(lp) );
930: if( ISCOMPLEX(lp->vtype) )
931: q = imagpart(lp);
932: else if(rp != NULL)
933: q = (expptr) realpart(rp);
934: else
935: q = mkrealcon(TYDREAL, 0.0);
936: putassign( imagpart(resp), q);
937: *ncommap += 2;
938: break;
939:
940: default:
941: badop("putcx1", opcode);
942: }
943:
944: frexpr(lp);
945: frexpr(rp);
946: free( (charptr) p );
947: return(resp);
948: }
949:
950:
951:
952:
953: LOCAL putcxcmp(p)
954: register expptr p;
955: {
956: int opcode;
957: int ncomma;
958: register Addrp lp, rp;
959: expptr q;
960:
961: if(p->tag != TEXPR)
962: badtag("putcxcmp", p->tag);
963:
964: ncomma = 0;
965: opcode = p->exprblock.opcode;
966: lp = putcx1(p->exprblock.leftp, &ncomma);
967: rp = putcx1(p->exprblock.rightp, &ncomma);
968:
969: q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
970: mkexpr(opcode, realpart(lp), realpart(rp)),
971: mkexpr(opcode, imagpart(lp), imagpart(rp)) );
972: putx( fixexpr(q) );
973: putcomma(ncomma, TYINT, NO);
974:
975: free( (charptr) lp);
976: free( (charptr) rp);
977: free( (charptr) p );
978: }
979:
980: LOCAL Addrp putch1(p, ncommap)
981: register expptr p;
982: int * ncommap;
983: {
984: register Addrp t;
985:
986: switch(p->tag)
987: {
988: case TCONST:
989: return( putconst(p) );
990:
991: case TADDR:
992: return( (Addrp) p );
993:
994: case TEXPR:
995: ++*ncommap;
996:
997: switch(p->exprblock.opcode)
998: {
999: expptr q;
1000:
1001: case OPCALL:
1002: case OPCCALL:
1003: t = putcall(p);
1004: break;
1005:
1006: case OPPAREN:
1007: --*ncommap;
1008: t = putch1(p->exprblock.leftp, ncommap);
1009: break;
1010:
1011: case OPCONCAT:
1012: t = mkaltemp(TYCHAR, ICON(lencat(p)) );
1013: q = (expptr) cpexpr(p->headblock.vleng);
1014: putcat( cpexpr(t), p );
1015: /* put the correct length on the block */
1016: frexpr(t->vleng);
1017: t->vleng = q;
1018:
1019: break;
1020:
1021: case OPCONV:
1022: if(!ISICON(p->exprblock.vleng)
1023: || p->exprblock.vleng->constblock.const.ci!=1
1024: || ! INT(p->exprblock.leftp->headblock.vtype) )
1025: fatal("putch1: bad character conversion");
1026: t = mkaltemp(TYCHAR, ICON(1) );
1027: putop( mkexpr(OPASSIGN, cpexpr(t), p) );
1028: break;
1029: default:
1030: badop("putch1", p->exprblock.opcode);
1031: }
1032: return(t);
1033:
1034: default:
1035: badtag("putch1", p->tag);
1036: }
1037: /* NOTREACHED */
1038: }
1039:
1040:
1041:
1042:
1043: LOCAL putchop(p)
1044: expptr p;
1045: {
1046: int ncomma;
1047:
1048: ncomma = 0;
1049: putaddr( putch1(p, &ncomma) , NO );
1050: putcomma(ncomma, TYCHAR, YES);
1051: }
1052:
1053:
1054:
1055:
1056: LOCAL putcheq(p)
1057: register expptr p;
1058: {
1059: int ncomma;
1060: expptr lp, rp;
1061:
1062: if(p->tag != TEXPR)
1063: badtag("putcheq", p->tag);
1064:
1065: ncomma = 0;
1066: lp = p->exprblock.leftp;
1067: rp = p->exprblock.rightp;
1068: if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
1069: putcat(lp, rp);
1070: else if( ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) )
1071: {
1072: putaddr( putch1(lp, &ncomma) , YES );
1073: putaddr( putch1(rp, &ncomma) , YES );
1074: putcomma(ncomma, TYINT, NO);
1075: p2op(PCC_ASSIGN, PCCT_CHAR);
1076: }
1077: else
1078: {
1079: putx( call2(TYINT, "s_copy", lp, rp) );
1080: putcomma(ncomma, TYINT, NO);
1081: }
1082:
1083: frexpr(p->exprblock.vleng);
1084: free( (charptr) p );
1085: }
1086:
1087:
1088:
1089:
1090: LOCAL putchcmp(p)
1091: register expptr p;
1092: {
1093: int ncomma;
1094: expptr lp, rp;
1095:
1096: if(p->tag != TEXPR)
1097: badtag("putchcmp", p->tag);
1098:
1099: ncomma = 0;
1100: lp = p->exprblock.leftp;
1101: rp = p->exprblock.rightp;
1102:
1103: if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) )
1104: {
1105: putaddr( putch1(lp, &ncomma) , YES );
1106: putcomma(ncomma, TYINT, NO);
1107: ncomma = 0;
1108: putaddr( putch1(rp, &ncomma) , YES );
1109: putcomma(ncomma, TYINT, NO);
1110: p2op(ops2[p->exprblock.opcode], PCCT_CHAR);
1111: free( (charptr) p );
1112: }
1113: else
1114: {
1115: p->exprblock.leftp = call2(TYINT,"s_cmp", lp, rp);
1116: p->exprblock.rightp = ICON(0);
1117: putop(p);
1118: }
1119: }
1120:
1121:
1122:
1123:
1124:
1125: LOCAL putcat(lhs, rhs)
1126: register Addrp lhs;
1127: register expptr rhs;
1128: {
1129: int n, ncomma;
1130: Addrp lp, cp;
1131:
1132: ncomma = 0;
1133: n = ncat(rhs);
1134: lp = mkaltmpn(n, TYLENG, PNULL);
1135: cp = mkaltmpn(n, TYADDR, PNULL);
1136:
1137: n = 0;
1138: putct1(rhs, lp, cp, &n, &ncomma);
1139:
1140: putx( call4(TYSUBR, "s_cat", lhs, cp, lp, mkconv(TYLONG, ICON(n)) ) );
1141: putcomma(ncomma, TYINT, NO);
1142: }
1143:
1144:
1145:
1146:
1147:
1148: LOCAL putct1(q, lp, cp, ip, ncommap)
1149: register expptr q;
1150: register Addrp lp, cp;
1151: int *ip, *ncommap;
1152: {
1153: int i;
1154: Addrp lp1, cp1;
1155:
1156: if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
1157: {
1158: putct1(q->exprblock.leftp, lp, cp, ip, ncommap);
1159: putct1(q->exprblock.rightp, lp, cp , ip, ncommap);
1160: frexpr(q->exprblock.vleng);
1161: free( (charptr) q );
1162: }
1163: else
1164: {
1165: i = (*ip)++;
1166: lp1 = (Addrp) cpexpr(lp);
1167: lp1->memoffset = mkexpr(OPPLUS,lp1->memoffset, ICON(i*SZLENG));
1168: cp1 = (Addrp) cpexpr(cp);
1169: cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR));
1170: putassign( lp1, cpexpr(q->headblock.vleng) );
1171: putassign( cp1, addrof(putch1(q,ncommap)) );
1172: *ncommap += 2;
1173: }
1174: }
1175:
1176: LOCAL putaddr(p, indir)
1177: register Addrp p;
1178: int indir;
1179: {
1180: int type, type2, funct;
1181: ftnint offset, simoffset();
1182: expptr offp, shorten();
1183:
1184: if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
1185: {
1186: frexpr(p);
1187: return;
1188: }
1189: if (p->tag != TADDR) badtag ("putaddr",p->tag);
1190:
1191: type = p->vtype;
1192: type2 = types2[type];
1193: funct = (p->vclass==CLPROC ? PCCTM_FTN<<2 : 0);
1194:
1195: offp = (p->memoffset ? (expptr) cpexpr(p->memoffset) : (expptr)NULL );
1196:
1197:
1198: #if (FUDGEOFFSET != 1)
1199: if(offp)
1200: offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp);
1201: #endif
1202:
1203: offset = simoffset( &offp );
1204: #if SZINT < SZLONG
1205: if(offp)
1206: if(shortsubs)
1207: offp = shorten(offp);
1208: else
1209: offp = mkconv(TYINT, offp);
1210: #else
1211: if(offp)
1212: offp = mkconv(TYINT, offp);
1213: #endif
1214:
1215: if (p->vclass == CLVAR
1216: && (p->vstg == STGBSS || p->vstg == STGEQUIV)
1217: && SMALLVAR(p->varsize)
1218: && offset >= -32768 && offset <= 32767)
1219: {
1220: anylocals = YES;
1221: if (indir && !offp)
1222: p2ldisp(offset, memname(p->vstg, p->memno), type2);
1223: else
1224: {
1225: p2reg(LVARREG, type2 | PCCTM_PTR);
1226: p2triple(PCC_ICON, 1, PCCT_INT);
1227: p2word(offset);
1228: p2ndisp(memname(p->vstg, p->memno));
1229: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1230: if (offp)
1231: {
1232: putx(offp);
1233: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1234: }
1235: if (indir)
1236: p2op(PCC_DEREF, type2);
1237: }
1238: frexpr((tagptr) p);
1239: return;
1240: }
1241:
1242: switch(p->vstg)
1243: {
1244: case STGAUTO:
1245: if(indir && !offp)
1246: {
1247: p2oreg(offset, AUTOREG, type2);
1248: break;
1249: }
1250:
1251: if(!indir && !offp && !offset)
1252: {
1253: p2reg(AUTOREG, type2 | PCCTM_PTR);
1254: break;
1255: }
1256:
1257: p2reg(AUTOREG, type2 | PCCTM_PTR);
1258: if(offp)
1259: {
1260: putx(offp);
1261: if(offset)
1262: p2icon(offset, PCCT_INT);
1263: }
1264: else
1265: p2icon(offset, PCCT_INT);
1266: if(offp && offset)
1267: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1268: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1269: if(indir)
1270: p2op(PCC_DEREF, type2);
1271: break;
1272:
1273: case STGARG:
1274: p2oreg(
1275: #ifdef ARGOFFSET
1276: ARGOFFSET +
1277: #endif
1278: (ftnint) (FUDGEOFFSET*p->memno),
1279: ARGREG, type2 | PCCTM_PTR | funct );
1280:
1281: based:
1282: if(offset)
1283: {
1284: p2icon(offset, PCCT_INT);
1285: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1286: }
1287: if(offp)
1288: {
1289: putx(offp);
1290: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1291: }
1292: if(indir)
1293: p2op(PCC_DEREF, type2);
1294: break;
1295:
1296: case STGLENG:
1297: if(indir)
1298: {
1299: p2oreg(
1300: #ifdef ARGOFFSET
1301: ARGOFFSET +
1302: #endif
1303: (ftnint) (FUDGEOFFSET*p->memno),
1304: ARGREG, type2 );
1305: }
1306: else {
1307: p2reg(ARGREG, type2 | PCCTM_PTR );
1308: p2icon(
1309: #ifdef ARGOFFSET
1310: ARGOFFSET +
1311: #endif
1312: (ftnint) (FUDGEOFFSET*p->memno), PCCT_INT);
1313: p2op(PCC_PLUS, type2 | PCCTM_PTR );
1314: }
1315: break;
1316:
1317:
1318: case STGBSS:
1319: case STGINIT:
1320: case STGEXT:
1321: case STGINTR:
1322: case STGCOMMON:
1323: case STGEQUIV:
1324: case STGCONST:
1325: if(offp)
1326: {
1327: putx(offp);
1328: putmem(p, PCC_ICON, offset);
1329: p2op(PCC_PLUS, type2 | PCCTM_PTR);
1330: if(indir)
1331: p2op(PCC_DEREF, type2);
1332: }
1333: else
1334: putmem(p, (indir ? PCC_NAME : PCC_ICON), offset);
1335:
1336: break;
1337:
1338: case STGREG:
1339: if(indir)
1340: p2reg(p->memno, type2);
1341: else
1342: fatal("attempt to take address of a register");
1343: break;
1344:
1345: case STGPREG:
1346: if(indir && !offp)
1347: p2oreg(offset, p->memno, type2);
1348: else
1349: {
1350: p2reg(p->memno, type2 | PCCTM_PTR);
1351: goto based;
1352: }
1353: break;
1354:
1355: default:
1356: badstg("putaddr", p->vstg);
1357: }
1358: frexpr(p);
1359: }
1360:
1361:
1362:
1363:
1364: LOCAL putmem(p, class, offset)
1365: expptr p;
1366: int class;
1367: ftnint offset;
1368: {
1369: int type2;
1370: int funct;
1371: char *name, *memname();
1372:
1373: funct = (p->headblock.vclass==CLPROC ? PCCTM_FTN<<2 : 0);
1374: type2 = types2[p->headblock.vtype];
1375: if(p->headblock.vclass == CLPROC)
1376: type2 |= (PCCTM_FTN<<2);
1377: name = memname(p->addrblock.vstg, p->addrblock.memno);
1378: if(class == PCC_ICON)
1379: {
1380: p2triple(PCC_ICON, name[0]!='\0', type2|PCCTM_PTR);
1381: p2word(offset);
1382: if(name[0])
1383: p2name(name);
1384: }
1385: else
1386: {
1387: p2triple(PCC_NAME, offset!=0, type2);
1388: if(offset != 0)
1389: p2word(offset);
1390: p2name(name);
1391: }
1392: }
1393:
1394:
1395:
1396: LOCAL Addrp putcall(p)
1397: register Exprp p;
1398: {
1399: chainp arglist, charsp, cp;
1400: int n, first;
1401: Addrp t;
1402: register expptr q;
1403: Addrp fval, mkargtemp();
1404: int type, type2, ctype, qtype, indir;
1405:
1406: type2 = types2[type = p->vtype];
1407: charsp = NULL;
1408: indir = (p->opcode == OPCCALL);
1409: n = 0;
1410: first = YES;
1411:
1412: if(p->rightp)
1413: {
1414: arglist = p->rightp->listblock.listp;
1415: free( (charptr) (p->rightp) );
1416: }
1417: else
1418: arglist = NULL;
1419:
1420: for(cp = arglist ; cp ; cp = cp->nextp)
1421: {
1422: q = (expptr) cp->datap;
1423: if(indir)
1424: ++n;
1425: else {
1426: q = (expptr) (cp->datap);
1427: if( ISCONST(q) )
1428: {
1429: q = (expptr) putconst(q);
1430: cp->datap = (tagptr) q;
1431: }
1432: if( ISCHAR(q) && q->headblock.vclass!=CLPROC )
1433: {
1434: charsp = hookup(charsp,
1435: mkchain(cpexpr(q->headblock.vleng),
1436: CHNULL));
1437: n += 2;
1438: }
1439: else
1440: n += 1;
1441: }
1442: }
1443:
1444: if(type == TYCHAR)
1445: {
1446: if( ISICON(p->vleng) )
1447: {
1448: fval = mkargtemp(TYCHAR, p->vleng);
1449: n += 2;
1450: }
1451: else {
1452: err("adjustable character function");
1453: return;
1454: }
1455: }
1456: else if( ISCOMPLEX(type) )
1457: {
1458: fval = mkargtemp(type, PNULL);
1459: n += 1;
1460: }
1461: else
1462: fval = NULL;
1463:
1464: ctype = (fval ? PCCT_INT : type2);
1465: putaddr(p->leftp, NO);
1466:
1467: if(fval)
1468: {
1469: first = NO;
1470: putaddr( cpexpr(fval), NO);
1471: if(type==TYCHAR)
1472: {
1473: putx( mkconv(TYLENG,p->vleng) );
1474: p2op(PCC_CM, type2);
1475: }
1476: }
1477:
1478: for(cp = arglist ; cp ; cp = cp->nextp)
1479: {
1480: q = (expptr) (cp->datap);
1481: if(q->tag==TADDR && (indir || q->addrblock.vstg!=STGREG) )
1482: putaddr(q, indir && q->addrblock.vtype!=TYCHAR);
1483: else if( ISCOMPLEX(q->headblock.vtype) )
1484: putcxop(q);
1485: else if (ISCHAR(q) )
1486: putchop(q);
1487: else if( ! ISERROR(q) )
1488: {
1489: if(indir)
1490: putx(q);
1491: else {
1492: t = mkargtemp(qtype = q->headblock.vtype,
1493: q->headblock.vleng);
1494: putassign( cpexpr(t), q );
1495: putaddr(t, NO);
1496: putcomma(1, qtype, YES);
1497: }
1498: }
1499: if(first)
1500: first = NO;
1501: else
1502: p2op(PCC_CM, type2);
1503: }
1504:
1505: if(arglist)
1506: frchain(&arglist);
1507: for(cp = charsp ; cp ; cp = cp->nextp)
1508: {
1509: putx( mkconv(TYLENG,cp->datap) );
1510: p2op(PCC_CM, type2);
1511: }
1512: frchain(&charsp);
1513: #if TARGET == TAHOE
1514: if(indir && ctype==PCCT_FLOAT) /* function opcodes */
1515: p2op(PCC_FORTCALL, ctype);
1516: else
1517: #endif
1518: p2op(n>0 ? PCC_CALL : PCC_UCALL , ctype);
1519: free( (charptr) p );
1520: return(fval);
1521: }
1522:
1523:
1524:
1525: LOCAL putmnmx(p)
1526: register expptr p;
1527: {
1528: int op, type;
1529: int ncomma;
1530: expptr qp;
1531: chainp p0, p1;
1532: Addrp sp, tp;
1533:
1534: if(p->tag != TEXPR)
1535: badtag("putmnmx", p->tag);
1536:
1537: type = p->exprblock.vtype;
1538: op = (p->exprblock.opcode==OPMIN ? OPLT : OPGT );
1539: p0 = p->exprblock.leftp->listblock.listp;
1540: free( (charptr) (p->exprblock.leftp) );
1541: free( (charptr) p );
1542:
1543: sp = mkaltemp(type, PNULL);
1544: tp = mkaltemp(type, PNULL);
1545: qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp));
1546: qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp);
1547: qp = fixexpr(qp);
1548:
1549: ncomma = 1;
1550: putassign( cpexpr(sp), p0->datap );
1551:
1552: for(p1 = p0->nextp ; p1 ; p1 = p1->nextp)
1553: {
1554: ++ncomma;
1555: putassign( cpexpr(tp), p1->datap );
1556: if(p1->nextp)
1557: {
1558: ++ncomma;
1559: putassign( cpexpr(sp), cpexpr(qp) );
1560: }
1561: else
1562: putx(qp);
1563: }
1564:
1565: putcomma(ncomma, type, NO);
1566: frexpr(sp);
1567: frexpr(tp);
1568: frchain( &p0 );
1569: }
1570:
1571:
1572:
1573:
1574: LOCAL putcomma(n, type, indir)
1575: int n, type, indir;
1576: {
1577: type = types2[type];
1578: if(indir)
1579: type |= PCCTM_PTR;
1580: while(--n >= 0)
1581: p2op(PCC_COMOP, type);
1582: }
1583:
1584:
1585:
1586:
1587: ftnint simoffset(p0)
1588: expptr *p0;
1589: {
1590: ftnint offset, prod;
1591: register expptr p, lp, rp;
1592:
1593: offset = 0;
1594: p = *p0;
1595: if(p == NULL)
1596: return(0);
1597:
1598: if( ! ISINT(p->headblock.vtype) )
1599: return(0);
1600:
1601: if(p->tag==TEXPR && p->exprblock.opcode==OPSTAR)
1602: {
1603: lp = p->exprblock.leftp;
1604: rp = p->exprblock.rightp;
1605: if(ISICON(rp) && lp->tag==TEXPR &&
1606: lp->exprblock.opcode==OPPLUS && ISICON(lp->exprblock.rightp))
1607: {
1608: p->exprblock.opcode = OPPLUS;
1609: lp->exprblock.opcode = OPSTAR;
1610: prod = rp->constblock.const.ci *
1611: lp->exprblock.rightp->constblock.const.ci;
1612: lp->exprblock.rightp->constblock.const.ci = rp->constblock.const.ci;
1613: rp->constblock.const.ci = prod;
1614: }
1615: }
1616:
1617: if(p->tag==TEXPR && p->exprblock.opcode==OPPLUS &&
1618: ISICON(p->exprblock.rightp))
1619: {
1620: rp = p->exprblock.rightp;
1621: lp = p->exprblock.leftp;
1622: offset += rp->constblock.const.ci;
1623: frexpr(rp);
1624: free( (charptr) p );
1625: *p0 = lp;
1626: }
1627:
1628: if( ISCONST(p) )
1629: {
1630: offset += p->constblock.const.ci;
1631: frexpr(p);
1632: *p0 = NULL;
1633: }
1634:
1635: return(offset);
1636: }
1637:
1638:
1639:
1640:
1641:
1642: p2op(op, type)
1643: int op, type;
1644: {
1645: p2triple(op, 0, type);
1646: }
1647:
1648: p2icon(offset, type)
1649: ftnint offset;
1650: int type;
1651: {
1652: p2triple(PCC_ICON, 0, type);
1653: p2word(offset);
1654: }
1655:
1656:
1657:
1658:
1659: p2oreg(offset, reg, type)
1660: ftnint offset;
1661: int reg, type;
1662: {
1663: p2triple(PCC_OREG, reg, type);
1664: p2word(offset);
1665: p2name("");
1666: }
1667:
1668:
1669:
1670:
1671: p2reg(reg, type)
1672: int reg, type;
1673: {
1674: p2triple(PCC_REG, reg, type);
1675: }
1676:
1677:
1678:
1679: p2pi(s, i)
1680: char *s;
1681: int i;
1682: {
1683: char buff[100];
1684: sprintf(buff, s, i);
1685: p2pass(buff);
1686: }
1687:
1688:
1689:
1690: p2pij(s, i, j)
1691: char *s;
1692: int i, j;
1693: {
1694: char buff[100];
1695: sprintf(buff, s, i, j);
1696: p2pass(buff);
1697: }
1698:
1699:
1700:
1701:
1702: p2ps(s, t)
1703: char *s, *t;
1704: {
1705: char buff[100];
1706: sprintf(buff, s, t);
1707: p2pass(buff);
1708: }
1709:
1710:
1711:
1712:
1713: p2pass(s)
1714: char *s;
1715: {
1716: p2triple(PCCF_FTEXT, (strlen(s) + ALILONG-1)/ALILONG, 0);
1717: p2str(s);
1718: }
1719:
1720:
1721:
1722:
1723: p2str(s)
1724: register char *s;
1725: {
1726: union { long int word; char str[SZLONG]; } u;
1727: register int i;
1728:
1729: i = 0;
1730: u.word = 0;
1731: while(*s)
1732: {
1733: u.str[i++] = *s++;
1734: if(i == SZLONG)
1735: {
1736: p2word(u.word);
1737: u.word = 0;
1738: i = 0;
1739: }
1740: }
1741: if(i > 0)
1742: p2word(u.word);
1743: }
1744:
1745:
1746:
1747:
1748: p2triple(op, var, type)
1749: int op, var, type;
1750: {
1751: register long word;
1752: word = PCCM_TRIPLE(op, var, type);
1753: p2word(word);
1754: }
1755:
1756:
1757:
1758:
1759:
1760: p2name(s)
1761: register char *s;
1762: {
1763: register int i;
1764:
1765: #ifdef UCBPASS2
1766: /* arbitrary length names, terminated by a null,
1767: padded to a full word */
1768:
1769: # define WL sizeof(long int)
1770: union { long int word; char str[WL]; } w;
1771:
1772: w.word = 0;
1773: i = 0;
1774: while(w.str[i++] = *s++)
1775: if(i == WL)
1776: {
1777: p2word(w.word);
1778: w.word = 0;
1779: i = 0;
1780: }
1781: if(i > 0)
1782: p2word(w.word);
1783: #else
1784: /* standard intermediate, names are 8 characters long */
1785:
1786: union { long int word[2]; char str[8]; } u;
1787:
1788: u.word[0] = u.word[1] = 0;
1789: for(i = 0 ; i<8 && *s ; ++i)
1790: u.str[i] = *s++;
1791: p2word(u.word[0]);
1792: p2word(u.word[1]);
1793:
1794: #endif
1795:
1796: }
1797:
1798:
1799:
1800:
1801: p2word(w)
1802: long int w;
1803: {
1804: *p2bufp++ = w;
1805: if(p2bufp >= p2bufend)
1806: p2flush();
1807: }
1808:
1809:
1810:
1811: p2flush()
1812: {
1813: if(p2bufp > p2buff)
1814: write(fileno(textfile), p2buff, (p2bufp-p2buff)*sizeof(long int));
1815: p2bufp = p2buff;
1816: }
1817:
1818:
1819:
1820: LOCAL
1821: p2ldisp(offset, vname, type)
1822: ftnint offset;
1823: char *vname;
1824: int type;
1825: {
1826: char buff[100];
1827:
1828: sprintf(buff, "%s-v.%d", vname, bsslabel);
1829: p2triple(PCC_OREG, LVARREG, type);
1830: p2word(offset);
1831: p2name(buff);
1832: }
1833:
1834:
1835:
1836: p2ndisp(vname)
1837: char *vname;
1838: {
1839: char buff[100];
1840:
1841: sprintf(buff, "%s-v.%d", vname, bsslabel);
1842: p2name(buff);
1843: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.