![[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 [Research Unix] / researchv10no / cmd / f2c|
Return to putpcc.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
25: /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
26:
27: #include "defs.h"
28: #include "pccdefs.h"
29: #include "output.h" /* for nice_printf */
30: #include "names.h"
31: #include "p1defs.h"
32:
33: Addrp realpart();
34: LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 ();
35: LOCAL putct1 ();
36:
37: expptr putcxop();
38: LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
39: LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
40: LOCAL expptr putcxcmp ();
41: expptr imagpart();
42: ftnint lencat();
43:
44: #define FOUR 4
45: extern int ops2[];
46: extern int proc_argchanges, proc_protochanges;
47: extern int krparens;
48:
49: #define P2BUFFMAX 128
50:
51: /* Puthead -- output the header information about subroutines, functions
52: and entry points */
53:
54: puthead(s, class)
55: char *s;
56: int class;
57: {
58: if (headerdone == NO) {
59: if (class == CLMAIN)
60: s = "MAIN__";
61: p1_head (class, s);
62: headerdone = YES;
63: }
64: }
65:
66: putif(p, else_if_p)
67: register expptr p;
68: int else_if_p;
69: {
70: register int k;
71: int n;
72: long where;
73:
74: if (else_if_p) {
75: p1put(P1_ELSEIFSTART);
76: where = ftell(pass1_file);
77: }
78: if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
79: {
80: if(k != TYERROR)
81: err("non-logical expression in IF statement");
82: }
83: else {
84: if (else_if_p) {
85: if (ei_next >= ei_last)
86: {
87: k = ei_last - ei_first;
88: n = k + 100;
89: ei_next = mem(n,0);
90: ei_last = ei_first + n;
91: if (k)
92: memcpy(ei_next, ei_first, k);
93: ei_first = ei_next;
94: ei_next += k;
95: ei_last = ei_first + n;
96: }
97: p = putx(p);
98: if (*ei_next++ = ftell(pass1_file) > where) {
99: p1_if(p);
100: new_endif();
101: }
102: else
103: p1_elif(p);
104: }
105: else {
106: p = putx(p);
107: p1_if(p);
108: }
109: }
110: }
111:
112:
113: putout(p)
114: expptr p;
115: {
116: p1_expr (p);
117:
118: /* Used to make temporaries in holdtemps available here, but they */
119: /* may be reused too soon (e.g. when multiple **'s are involved). */
120: }
121:
122:
123:
124: putcmgo(index, nlab, labs)
125: expptr index;
126: int nlab;
127: struct Labelblock *labs[];
128: {
129: if(! ISINT(index->headblock.vtype) )
130: {
131: execerr("computed goto index must be integer", CNULL);
132: return;
133: }
134:
135: p1comp_goto (index, nlab, labs);
136: }
137:
138: static expptr
139: krput(p)
140: register expptr p;
141: {
142: register expptr e, e1;
143: register unsigned op;
144: int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
145:
146: op = p->exprblock.opcode;
147: e = p->exprblock.leftp;
148: if (e->tag == TEXPR && e->exprblock.opcode == op) {
149: e1 = (expptr)mktmp(t, ENULL);
150: putout(putassign(cpexpr(e1), e));
151: p->exprblock.leftp = e1;
152: }
153: else
154: p->exprblock.leftp = putx(e);
155:
156: e = p->exprblock.rightp;
157: if (e->tag == TEXPR && e->exprblock.opcode == op) {
158: e1 = (expptr)mktmp(t, ENULL);
159: putout(putassign(cpexpr(e1), e));
160: p->exprblock.rightp = e1;
161: }
162: else
163: p->exprblock.rightp = putx(e);
164: return p;
165: }
166:
167: expptr putx(p)
168: register expptr p;
169: {
170: int opc;
171: int k;
172:
173: if (p)
174: switch(p->tag)
175: {
176: case TERROR:
177: break;
178:
179: case TCONST:
180: switch(p->constblock.vtype)
181: {
182: case TYLOGICAL1:
183: case TYLOGICAL2:
184: case TYLOGICAL:
185: #ifdef TYQUAD
186: case TYQUAD:
187: #endif
188: case TYLONG:
189: case TYSHORT:
190: case TYINT1:
191: break;
192:
193: case TYADDR:
194: break;
195: case TYREAL:
196: case TYDREAL:
197:
198: /* Don't write it out to the p2 file, since you'd need to call putconst,
199: which is just what we need to avoid in the translator */
200:
201: break;
202: default:
203: p = putx( (expptr)putconst((Constp)p) );
204: break;
205: }
206: break;
207:
208: case TEXPR:
209: switch(opc = p->exprblock.opcode)
210: {
211: case OPCALL:
212: case OPCCALL:
213: if( ISCOMPLEX(p->exprblock.vtype) )
214: p = putcxop(p);
215: else p = putcall(p, (Addrp *)NULL);
216: break;
217:
218: case OPMIN:
219: case OPMAX:
220: p = putmnmx(p);
221: break;
222:
223:
224: case OPASSIGN:
225: if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
226: || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
227: (void) putcxeq(p);
228: p = ENULL;
229: } else if( ISCHAR(p) )
230: p = putcheq(p);
231: else
232: goto putopp;
233: break;
234:
235: case OPEQ:
236: case OPNE:
237: if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
238: ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
239: {
240: p = putcxcmp(p);
241: break;
242: }
243: case OPLT:
244: case OPLE:
245: case OPGT:
246: case OPGE:
247: if(ISCHAR(p->exprblock.leftp))
248: {
249: p = putchcmp(p);
250: break;
251: }
252: goto putopp;
253:
254: case OPPOWER:
255: p = putpower(p);
256: break;
257:
258: case OPSTAR:
259: /* m * (2**k) -> m<<k */
260: if(INT(p->exprblock.leftp->headblock.vtype) &&
261: ISICON(p->exprblock.rightp) &&
262: ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
263: {
264: p->exprblock.opcode = OPLSHIFT;
265: frexpr(p->exprblock.rightp);
266: p->exprblock.rightp = ICON(k);
267: goto putopp;
268: }
269: if (krparens && ISREAL(p->exprblock.vtype))
270: return krput(p);
271:
272: case OPMOD:
273: goto putopp;
274: case OPPLUS:
275: if (krparens && ISREAL(p->exprblock.vtype))
276: return krput(p);
277: case OPMINUS:
278: case OPSLASH:
279: case OPNEG:
280: case OPNEG1:
281: case OPABS:
282: case OPDABS:
283: if( ISCOMPLEX(p->exprblock.vtype) )
284: p = putcxop(p);
285: else goto putopp;
286: break;
287:
288: case OPCONV:
289: if( ISCOMPLEX(p->exprblock.vtype) )
290: p = putcxop(p);
291: else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
292: {
293: p = putx( mkconv(p->exprblock.vtype,
294: (expptr)realpart(putcx1(p->exprblock.leftp))));
295: }
296: else goto putopp;
297: break;
298:
299: case OPNOT:
300: case OPOR:
301: case OPAND:
302: case OPEQV:
303: case OPNEQV:
304: case OPADDR:
305: case OPPLUSEQ:
306: case OPSTAREQ:
307: case OPCOMMA:
308: case OPQUEST:
309: case OPCOLON:
310: case OPBITOR:
311: case OPBITAND:
312: case OPBITXOR:
313: case OPBITNOT:
314: case OPLSHIFT:
315: case OPRSHIFT:
316: case OPASSIGNI:
317: case OPIDENTITY:
318: case OPCHARCAST:
319: case OPMIN2:
320: case OPMAX2:
321: case OPDMIN:
322: case OPDMAX:
323: putopp:
324: p = putop(p);
325: break;
326:
327: case OPCONCAT:
328: /* weird things like ichar(a//a) */
329: p = (expptr)putch1(p);
330: break;
331:
332: default:
333: badop("putx", opc);
334: p = errnode ();
335: }
336: break;
337:
338: case TADDR:
339: p = putaddr(p);
340: break;
341:
342: default:
343: badtag("putx", p->tag);
344: p = errnode ();
345: }
346:
347: return p;
348: }
349:
350:
351:
352: LOCAL expptr putop(p)
353: expptr p;
354: {
355: expptr lp, tp;
356: int pt, lt, lt1;
357: int comma;
358:
359: switch(p->exprblock.opcode) /* check for special cases and rewrite */
360: {
361: case OPCONV:
362: pt = p->exprblock.vtype;
363: lp = p->exprblock.leftp;
364: lt = lp->headblock.vtype;
365:
366: /* Simplify nested type casts */
367:
368: while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
369: ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
370: (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
371: {
372: if(pt==TYDREAL && lt==TYREAL)
373: {
374: if(lp->tag==TEXPR
375: && lp->exprblock.opcode == OPCONV) {
376: lt1 = lp->exprblock.leftp->headblock.vtype;
377: if (lt1 == TYDREAL) {
378: lp->exprblock.leftp =
379: putx(lp->exprblock.leftp);
380: return p;
381: }
382: if (lt1 == TYDCOMPLEX) {
383: lp->exprblock.leftp = putx(
384: (expptr)realpart(
385: putcx1(lp->exprblock.leftp)));
386: return p;
387: }
388: }
389: break;
390: }
391: else if (ISREAL(pt) && ISCOMPLEX(lt)) {
392: p->exprblock.leftp = putx(mkconv(pt,
393: (expptr)realpart(
394: putcx1(p->exprblock.leftp))));
395: break;
396: }
397: if(lt==TYCHAR && lp->tag==TEXPR &&
398: lp->exprblock.opcode==OPCALL)
399: {
400:
401: /* May want to make a comma expression here instead. I had one, but took
402: it out for my convenience, not for the convenience of the end user */
403:
404: putout (putcall (lp, (Addrp *) &(p ->
405: exprblock.leftp)));
406: return putop (p);
407: }
408: if (lt == TYCHAR) {
409: p->exprblock.leftp = putx(p->exprblock.leftp);
410: return p;
411: }
412: frexpr(p->exprblock.vleng);
413: free( (charptr) p );
414: p = lp;
415: if (p->tag != TEXPR)
416: goto retputx;
417: pt = lt;
418: lp = p->exprblock.leftp;
419: lt = lp->headblock.vtype;
420: } /* while */
421: if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
422: break;
423: retputx:
424: return putx(p);
425:
426: case OPADDR:
427: comma = NO;
428: lp = p->exprblock.leftp;
429: free( (charptr) p );
430: if(lp->tag != TADDR)
431: {
432: tp = (expptr)
433: mktmp(lp->headblock.vtype,lp->headblock.vleng);
434: p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
435: lp = tp;
436: comma = YES;
437: }
438: if(comma)
439: p = mkexpr(OPCOMMA, p, putaddr(lp));
440: else
441: p = (expptr)putaddr(lp);
442: return p;
443:
444: case OPASSIGN:
445: case OPASSIGNI:
446: case OPLT:
447: case OPLE:
448: case OPGT:
449: case OPGE:
450: case OPEQ:
451: case OPNE:
452: ;
453: }
454:
455: if( ops2[p->exprblock.opcode] <= 0)
456: badop("putop", p->exprblock.opcode);
457: p -> exprblock.leftp = putx (p -> exprblock.leftp);
458: if (p -> exprblock.rightp)
459: p -> exprblock.rightp = putx (p -> exprblock.rightp);
460: return p;
461: }
462:
463: LOCAL expptr putpower(p)
464: expptr p;
465: {
466: expptr base;
467: Addrp t1, t2;
468: ftnint k;
469: int type;
470: char buf[80]; /* buffer for text of comment */
471:
472: if(!ISICON(p->exprblock.rightp) ||
473: (k = p->exprblock.rightp->constblock.Const.ci)<2)
474: Fatal("putpower: bad call");
475: base = p->exprblock.leftp;
476: type = base->headblock.vtype;
477: t1 = mktmp(type, ENULL);
478: t2 = NULL;
479:
480: free ((charptr) p);
481: p = putassign (cpexpr((expptr) t1), base);
482:
483: sprintf (buf, "Computing %ld%s power", k,
484: k == 2 ? "nd" : k == 3 ? "rd" : "th");
485: p1_comment (buf);
486:
487: for( ; (k&1)==0 && k>2 ; k>>=1 )
488: {
489: p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
490: }
491:
492: if(k == 2) {
493:
494: /* Write the power computation out immediately */
495: putout (p);
496: p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
497: } else {
498: t2 = mktmp(type, ENULL);
499: p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
500: cpexpr((expptr)t1)));
501:
502: for(k>>=1 ; k>1 ; k>>=1)
503: {
504: p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
505: if(k & 1)
506: {
507: p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
508: }
509: }
510: /* Write the power computation out immediately */
511: putout (p);
512: p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
513: mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
514: }
515: frexpr((expptr)t1);
516: if(t2)
517: frexpr((expptr)t2);
518: return p;
519: }
520:
521:
522:
523:
524: LOCAL Addrp intdouble(p)
525: Addrp p;
526: {
527: register Addrp t;
528:
529: t = mktmp(TYDREAL, ENULL);
530: putout (putassign(cpexpr((expptr)t), (expptr)p));
531: return(t);
532: }
533:
534:
535:
536:
537:
538: /* Complex-type variable assignment */
539:
540: LOCAL Addrp putcxeq(p)
541: register expptr p;
542: {
543: register Addrp lp, rp;
544: expptr code;
545:
546: if(p->tag != TEXPR)
547: badtag("putcxeq", p->tag);
548:
549: lp = putcx1(p->exprblock.leftp);
550: rp = putcx1(p->exprblock.rightp);
551: code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
552:
553: if( ISCOMPLEX(p->exprblock.vtype) )
554: {
555: code = mkexpr (OPCOMMA, code, putassign
556: (imagpart(lp), imagpart(rp)));
557: }
558: putout (code);
559: frexpr((expptr)rp);
560: free ((charptr) p);
561: return lp;
562: }
563:
564:
565:
566: /* putcxop -- used to write out embedded calls to complex functions, and
567: complex arguments to procedures */
568:
569: expptr putcxop(p)
570: expptr p;
571: {
572: return (expptr)putaddr((expptr)putcx1(p));
573: }
574:
575: #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
576:
577: LOCAL Addrp putcx1(p)
578: register expptr p;
579: {
580: expptr q;
581: Addrp lp, rp;
582: register Addrp resp;
583: int opcode;
584: int ltype, rtype;
585: long ts, tskludge;
586: expptr mkrealcon();
587:
588: if(p == NULL)
589: return(NULL);
590:
591: switch(p->tag)
592: {
593: case TCONST:
594: if( ISCOMPLEX(p->constblock.vtype) )
595: p = (expptr) putconst((Constp)p);
596: return( (Addrp) p );
597:
598: case TADDR:
599: resp = &p->addrblock;
600: if (addressable(p))
601: return (Addrp) p;
602: ts = tskludge = 0;
603: if (q = resp->memoffset) {
604: if (resp->uname_tag == UNAM_REF) {
605: q = cpexpr((tagptr)resp);
606: q->addrblock.vtype = tyint;
607: q->addrblock.cmplx_sub = 1;
608: p->addrblock.skip_offset = 1;
609: resp->user.name->vsubscrused = 1;
610: resp->uname_tag = UNAM_NAME;
611: tskludge = typesize[resp->vtype]
612: * (resp->Field ? 2 : 1);
613: }
614: else if (resp->isarray
615: && resp->vtype != TYCHAR) {
616: if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
617: && resp->uname_tag == UNAM_NAME)
618: q = mkexpr(OPMINUS, q,
619: mkintcon(resp->user.name->voffset));
620: ts = typesize[resp->vtype]
621: * (resp->Field ? 2 : 1);
622: q = resp->memoffset = mkexpr(OPSLASH, q,
623: ICON(ts));
624: }
625: }
626: resp = mktmp(tyint, ENULL);
627: putout(putassign(cpexpr((expptr)resp), q));
628: p->addrblock.memoffset = tskludge
629: ? mkexpr(OPSTAR, resp, ICON(tskludge))
630: : (expptr)resp;
631: if (ts) {
632: resp = &p->addrblock;
633: q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
634: if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
635: && resp->uname_tag == UNAM_NAME)
636: q = mkexpr(OPPLUS, q,
637: mkintcon(resp->user.name->voffset));
638: resp->memoffset = q;
639: }
640: return (Addrp) p;
641:
642: case TEXPR:
643: if( ISCOMPLEX(p->exprblock.vtype) )
644: break;
645: resp = mktmp(TYDREAL, ENULL);
646: putout (putassign( cpexpr((expptr)resp), p));
647: return(resp);
648:
649: default:
650: badtag("putcx1", p->tag);
651: }
652:
653: opcode = p->exprblock.opcode;
654: if(opcode==OPCALL || opcode==OPCCALL)
655: {
656: Addrp t;
657: p = putcall(p, &t);
658: putout(p);
659: return t;
660: }
661: else if(opcode == OPASSIGN)
662: {
663: return putcxeq (p);
664: }
665:
666: /* BUG (inefficient) Generates too many temporary variables */
667:
668: resp = mktmp(p->exprblock.vtype, ENULL);
669: if(lp = putcx1(p->exprblock.leftp) )
670: ltype = lp->vtype;
671: if(rp = putcx1(p->exprblock.rightp) )
672: rtype = rp->vtype;
673:
674: switch(opcode)
675: {
676: case OPCOMMA:
677: frexpr((expptr)resp);
678: resp = rp;
679: rp = NULL;
680: break;
681:
682: case OPNEG:
683: case OPNEG1:
684: putout (PAIR (
685: putassign( (expptr)realpart(resp),
686: mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
687: putassign( imagpart(resp),
688: mkexpr(OPNEG, imagpart(lp), ENULL))));
689: break;
690:
691: case OPPLUS:
692: case OPMINUS: { expptr r;
693: r = putassign( (expptr)realpart(resp),
694: mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
695: if(rtype < TYCOMPLEX)
696: q = putassign( imagpart(resp), imagpart(lp) );
697: else if(ltype < TYCOMPLEX)
698: {
699: if(opcode == OPPLUS)
700: q = putassign( imagpart(resp), imagpart(rp) );
701: else
702: q = putassign( imagpart(resp),
703: mkexpr(OPNEG, imagpart(rp), ENULL) );
704: }
705: else
706: q = putassign( imagpart(resp),
707: mkexpr(opcode, imagpart(lp), imagpart(rp) ));
708: r = PAIR (r, q);
709: putout (r);
710: break;
711: } /* case OPPLUS, OPMINUS: */
712: case OPSTAR:
713: if(ltype < TYCOMPLEX)
714: {
715: if( ISINT(ltype) )
716: lp = intdouble(lp);
717: putout (PAIR (
718: putassign( (expptr)realpart(resp),
719: mkexpr(OPSTAR, cpexpr((expptr)lp),
720: (expptr)realpart(rp))),
721: putassign( imagpart(resp),
722: mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
723: }
724: else if(rtype < TYCOMPLEX)
725: {
726: if( ISINT(rtype) )
727: rp = intdouble(rp);
728: putout (PAIR (
729: putassign( (expptr)realpart(resp),
730: mkexpr(OPSTAR, cpexpr((expptr)rp),
731: (expptr)realpart(lp))),
732: putassign( imagpart(resp),
733: mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
734: }
735: else {
736: putout (PAIR (
737: putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
738: mkexpr(OPSTAR, (expptr)realpart(lp),
739: (expptr)realpart(rp)),
740: mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
741: putassign( imagpart(resp), mkexpr(OPPLUS,
742: mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
743: mkexpr(OPSTAR, imagpart(lp),
744: (expptr)realpart(rp))))));
745: }
746: break;
747:
748: case OPSLASH:
749: /* fixexpr has already replaced all divisions
750: * by a complex by a function call
751: */
752: if( ISINT(rtype) )
753: rp = intdouble(rp);
754: putout (PAIR (
755: putassign( (expptr)realpart(resp),
756: mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
757: putassign( imagpart(resp),
758: mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
759: break;
760:
761: case OPCONV:
762: if( ISCOMPLEX(lp->vtype) )
763: q = imagpart(lp);
764: else if(rp != NULL)
765: q = (expptr) realpart(rp);
766: else
767: q = mkrealcon(TYDREAL, "0");
768: putout (PAIR (
769: putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
770: putassign( imagpart(resp), q)));
771: break;
772:
773: default:
774: badop("putcx1", opcode);
775: }
776:
777: frexpr((expptr)lp);
778: frexpr((expptr)rp);
779: free( (charptr) p );
780: return(resp);
781: }
782:
783:
784:
785:
786: /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
787: are not defined */
788:
789: LOCAL expptr putcxcmp(p)
790: register expptr p;
791: {
792: int opcode;
793: register Addrp lp, rp;
794: expptr q;
795:
796: if(p->tag != TEXPR)
797: badtag("putcxcmp", p->tag);
798:
799: opcode = p->exprblock.opcode;
800: lp = putcx1(p->exprblock.leftp);
801: rp = putcx1(p->exprblock.rightp);
802:
803: q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
804: mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
805: mkexpr(opcode, imagpart(lp), imagpart(rp)) );
806:
807: free( (charptr) lp);
808: free( (charptr) rp);
809: free( (charptr) p );
810: return putx( fixexpr((Exprp)q) );
811: }
812:
813: /* putch1 -- Forces constants into the literal pool, among other things */
814:
815: LOCAL Addrp putch1(p)
816: register expptr p;
817: {
818: Addrp t;
819: expptr e;
820:
821: switch(p->tag)
822: {
823: case TCONST:
824: return( putconst((Constp)p) );
825:
826: case TADDR:
827: return( (Addrp) p );
828:
829: case TEXPR:
830: switch(p->exprblock.opcode)
831: {
832: expptr q;
833:
834: case OPCALL:
835: case OPCCALL:
836:
837: p = putcall(p, &t);
838: putout (p);
839: break;
840:
841: case OPCONCAT:
842: t = mktmp(TYCHAR, ICON(lencat(p)));
843: q = (expptr) cpexpr(p->headblock.vleng);
844: p = putcat( cpexpr((expptr)t), p );
845: /* put the correct length on the block */
846: frexpr(t->vleng);
847: t->vleng = q;
848: putout (p);
849: break;
850:
851: case OPCONV:
852: if(!ISICON(p->exprblock.vleng)
853: || p->exprblock.vleng->constblock.Const.ci!=1
854: || ! INT(p->exprblock.leftp->headblock.vtype) )
855: Fatal("putch1: bad character conversion");
856: t = mktmp(TYCHAR, ICON(1));
857: e = mkexpr(OPCONV, (expptr)t, ENULL);
858: e->headblock.vtype = TYCHAR;
859: p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
860: putout (p);
861: break;
862: default:
863: badop("putch1", p->exprblock.opcode);
864: }
865: return(t);
866:
867: default:
868: badtag("putch1", p->tag);
869: }
870: /* NOT REACHED */ return 0;
871: }
872:
873:
874: /* putchop -- Write out a character actual parameter; that is, this is
875: part of a procedure invocation */
876:
877: Addrp putchop(p)
878: expptr p;
879: {
880: p = putaddr((expptr)putch1(p));
881: return (Addrp)p;
882: }
883:
884:
885:
886:
887: LOCAL expptr putcheq(p)
888: register expptr p;
889: {
890: expptr lp, rp;
891: int nbad;
892:
893: if(p->tag != TEXPR)
894: badtag("putcheq", p->tag);
895:
896: lp = p->exprblock.leftp;
897: rp = p->exprblock.rightp;
898: frexpr(p->exprblock.vleng);
899: free( (charptr) p );
900:
901: /* If s = t // u, don't bother copying the result, write it directly into
902: this buffer */
903:
904: nbad = badchleng(lp) + badchleng(rp);
905: if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
906: p = putcat(lp, rp);
907: else if( !nbad
908: && ISONE(lp->headblock.vleng)
909: && ISONE(rp->headblock.vleng) ) {
910: lp = mkexpr(OPCONV, lp, ENULL);
911: rp = mkexpr(OPCONV, rp, ENULL);
912: lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
913: p = putop(mkexpr(OPASSIGN, lp, rp));
914: }
915: else
916: p = putx( call2(TYSUBR, "s_copy", lp, rp) );
917: return p;
918: }
919:
920:
921:
922:
923: LOCAL expptr putchcmp(p)
924: register expptr p;
925: {
926: expptr lp, rp;
927:
928: if(p->tag != TEXPR)
929: badtag("putchcmp", p->tag);
930:
931: lp = p->exprblock.leftp;
932: rp = p->exprblock.rightp;
933:
934: if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
935: lp = mkexpr(OPCONV, lp, ENULL);
936: rp = mkexpr(OPCONV, rp, ENULL);
937: lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
938: }
939: else {
940: lp = call2(TYINT,"s_cmp", lp, rp);
941: rp = ICON(0);
942: }
943: p->exprblock.leftp = lp;
944: p->exprblock.rightp = rp;
945: p = putop(p);
946: return p;
947: }
948:
949:
950:
951:
952:
953: /* putcat -- Writes out a concatenation operation. Two temporary arrays
954: are allocated, putct1() is called to initialize them, and then a
955: call to runtime library routine s_cat() is inserted.
956:
957: This routine generates code which will perform an (nconc lhs rhs)
958: at runtime. The runtime funciton does not return a value, the routine
959: that calls this putcat must remember the name of lhs.
960: */
961:
962:
963: LOCAL expptr putcat(lhs0, rhs)
964: expptr lhs0;
965: register expptr rhs;
966: {
967: register Addrp lhs = (Addrp)lhs0;
968: int n, tyi;
969: Addrp length_var, string_var;
970: expptr p;
971: static char Writing_concatenation[] = "Writing concatenation";
972:
973: /* Create the temporary arrays */
974:
975: n = ncat(rhs);
976: length_var = mktmpn(n, tyioint, ENULL);
977: string_var = mktmpn(n, TYADDR, ENULL);
978: frtemp((Addrp)cpexpr((expptr)length_var));
979: frtemp((Addrp)cpexpr((expptr)string_var));
980:
981: /* Initialize the arrays */
982:
983: n = 0;
984: /* p1_comment scribbles on its argument, so we
985: * cannot safely pass a string literal here. */
986: p1_comment(Writing_concatenation);
987: putct1(rhs, length_var, string_var, &n);
988:
989: /* Create the invocation */
990:
991: tyi = tyint;
992: tyint = tyioint; /* for -I2 */
993: p = putx (call4 (TYSUBR, "s_cat",
994: (expptr)lhs,
995: (expptr)string_var,
996: (expptr)length_var,
997: (expptr)putconst((Constp)ICON(n))));
998: tyint = tyi;
999:
1000: return p;
1001: }
1002:
1003:
1004:
1005:
1006:
1007: LOCAL putct1(q, length_var, string_var, ip)
1008: register expptr q;
1009: register Addrp length_var, string_var;
1010: int *ip;
1011: {
1012: int i;
1013: Addrp length_copy, string_copy;
1014: expptr e;
1015: extern int szleng;
1016:
1017: if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
1018: {
1019: putct1(q->exprblock.leftp, length_var, string_var,
1020: ip);
1021: putct1(q->exprblock.rightp, length_var, string_var,
1022: ip);
1023: frexpr (q -> exprblock.vleng);
1024: free ((charptr) q);
1025: }
1026: else
1027: {
1028: i = (*ip)++;
1029: e = cpexpr(q->headblock.vleng);
1030: if (!e)
1031: return; /* error -- character*(*) */
1032: length_copy = (Addrp) cpexpr((expptr)length_var);
1033: length_copy->memoffset =
1034: mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
1035: string_copy = (Addrp) cpexpr((expptr)string_var);
1036: string_copy->memoffset =
1037: mkexpr(OPPLUS, string_copy->memoffset,
1038: ICON(i*typesize[TYADDR]));
1039: putout (PAIR (putassign((expptr)length_copy, e),
1040: putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
1041: }
1042: }
1043:
1044: /* putaddr -- seems to write out function invocation actual parameters */
1045:
1046: LOCAL expptr putaddr(p0)
1047: expptr p0;
1048: {
1049: register Addrp p;
1050: chainp cp;
1051:
1052: if (!(p = (Addrp)p0))
1053: return ENULL;
1054:
1055: if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
1056: {
1057: frexpr((expptr)p);
1058: return ENULL;
1059: }
1060: if (p->isarray && p->memoffset)
1061: if (p->uname_tag == UNAM_REF) {
1062: cp = p->memoffset->listblock.listp;
1063: for(; cp; cp = cp->nextp)
1064: cp->datap = (char *)fixtype((tagptr)cp->datap);
1065: }
1066: else
1067: p->memoffset = putx(p->memoffset);
1068: return (expptr) p;
1069: }
1070:
1071: LOCAL expptr
1072: addrfix(e) /* fudge character string length if it's a TADDR */
1073: expptr e;
1074: {
1075: return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
1076: }
1077:
1078: LOCAL int
1079: typekludge(ccall, q, at, j)
1080: int ccall;
1081: register expptr q;
1082: Atype *at;
1083: int j; /* alternate type */
1084: {
1085: register int i, k;
1086: extern int iocalladdr;
1087: register Namep np;
1088:
1089: /* Return value classes:
1090: * < 100 ==> Fortran arg (pointer to type)
1091: * < 200 ==> C arg
1092: * < 300 ==> procedure arg
1093: * < 400 ==> external, no explicit type
1094: * < 500 ==> arg that may turn out to be
1095: * either a variable or a procedure
1096: */
1097:
1098: k = q->headblock.vtype;
1099: if (ccall) {
1100: if (k == TYREAL)
1101: k = TYDREAL; /* force double for library routines */
1102: return k + 100;
1103: }
1104: if (k == TYADDR)
1105: return iocalladdr;
1106: i = q->tag;
1107: if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
1108: || (i == TADDR && q->addrblock.charleng)
1109: || i == TCONST)
1110: k = TYFTNLEN + 100;
1111: else if (i == TADDR)
1112: switch(q->addrblock.vclass) {
1113: case CLPROC:
1114: if (q->addrblock.uname_tag != UNAM_NAME)
1115: k += 200;
1116: else if ((np = q->addrblock.user.name)->vprocclass
1117: != PTHISPROC) {
1118: if (k && !np->vimpltype)
1119: k += 200;
1120: else {
1121: if (j > 200 && infertypes && j < 300) {
1122: k = j;
1123: inferdcl(np, j-200);
1124: }
1125: else k = (np->vstg == STGEXT
1126: ? extsymtab[np->vardesc.varno].extype
1127: : 0) + 200;
1128: at->cp = mkchain((char *)np, at->cp);
1129: }
1130: }
1131: else if (k == TYSUBR)
1132: k += 200;
1133: break;
1134:
1135: case CLUNKNOWN:
1136: if (q->addrblock.vstg == STGARG
1137: && q->addrblock.uname_tag == UNAM_NAME) {
1138: k += 400;
1139: at->cp = mkchain((char *)q->addrblock.user.name,
1140: at->cp);
1141: }
1142: }
1143: else if (i == TNAME && q->nameblock.vstg == STGARG) {
1144: np = &q->nameblock;
1145: switch(np->vclass) {
1146: case CLPROC:
1147: if (!np->vimpltype)
1148: k += 200;
1149: else if (j <= 200 || !infertypes || j >= 300)
1150: k += 300;
1151: else {
1152: k = j;
1153: inferdcl(np, j-200);
1154: }
1155: goto add2chain;
1156:
1157: case CLUNKNOWN:
1158: /* argument may be a scalar variable or a function */
1159: if (np->vimpltype && j && infertypes
1160: && j < 300) {
1161: inferdcl(np, j % 100);
1162: k = j;
1163: }
1164: else
1165: k += 400;
1166:
1167: /* to handle procedure args only so far known to be
1168: * external, save a pointer to the symbol table entry...
1169: */
1170: add2chain:
1171: at->cp = mkchain((char *)np, at->cp);
1172: }
1173: }
1174: return k;
1175: }
1176:
1177: char *
1178: Argtype(k, buf)
1179: int k;
1180: char *buf;
1181: {
1182: if (k < 100) {
1183: sprintf(buf, "%s variable", ftn_types[k]);
1184: return buf;
1185: }
1186: if (k < 200) {
1187: k -= 100;
1188: return ftn_types[k];
1189: }
1190: if (k < 300) {
1191: k -= 200;
1192: if (k == TYSUBR)
1193: return ftn_types[TYSUBR];
1194: sprintf(buf, "%s function", ftn_types[k]);
1195: return buf;
1196: }
1197: if (k < 400)
1198: return "external argument";
1199: k -= 400;
1200: sprintf(buf, "%s argument", ftn_types[k]);
1201: return buf;
1202: }
1203:
1204: static void
1205: atype_squawk(at, msg)
1206: Argtypes *at;
1207: char *msg;
1208: {
1209: register Atype *a, *ae;
1210: warn(msg);
1211: for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
1212: frchain(&a->cp);
1213: at->nargs = -1;
1214: if (at->changes & 2 && !at->defined)
1215: proc_protochanges++;
1216: }
1217:
1218: static char inconsist[] = "inconsistent calling sequences for ";
1219:
1220: void
1221: bad_atypes(at, fname, i, j, k, here, prev)
1222: Argtypes *at;
1223: char *fname, *here, *prev;
1224: int i, j, k;
1225: {
1226: char buf[208], buf1[32], buf2[32];
1227:
1228: sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
1229: inconsist, fname, i, here, Argtype(k, buf1),
1230: prev, Argtype(j, buf2));
1231: atype_squawk(at, buf);
1232: }
1233:
1234: int
1235: type_fixup(at,a,k)
1236: Argtypes *at;
1237: Atype *a;
1238: int k;
1239: {
1240: register struct Entrypoint *ep;
1241: if (!infertypes)
1242: return 0;
1243: for(ep = entries; ep; ep = ep->entnextp)
1244: if (at == ep->entryname->arginfo) {
1245: a->type = k % 100;
1246: return proc_argchanges = 1;
1247: }
1248: return 0;
1249: }
1250:
1251:
1252: void
1253: save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
1254: chainp arglist;
1255: Argtypes **at0, **at1;
1256: int ccall, stg, nchargs, type, zap;
1257: char *fname;
1258: {
1259: Argtypes *at;
1260: chainp cp;
1261: int i, i0, j, k, nargs, nbad, *t, *te;
1262: Atype *atypes;
1263: expptr q;
1264: char buf[208], buf1[32], buf2[32];
1265: static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
1266: static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
1267: #ifdef TYQUAD
1268: 0,
1269: #endif
1270: initargs, initargs+1,0,0,0,initargs+2};
1271: extern int init_ac[TYSUBR+1];
1272:
1273: i0 = init_ac[type];
1274: t = init_ap[type];
1275: te = t + i0;
1276: if (at = *at0) {
1277: *at1 = at;
1278: nargs = at->nargs;
1279: if (nargs < 0 && type && at->changes & 2 && !at->defined)
1280: --proc_protochanges;
1281: if (at->dnargs >= 0 && zap != 2)
1282: type = 0;
1283: if (nargs < 0) { /* inconsistent usage seen */
1284: if (type)
1285: goto newlist;
1286: return;
1287: }
1288: atypes = at->atypes;
1289: i = nchargs;
1290: for(nbad = 0; t < te; atypes++) {
1291: if (++i > nargs) {
1292: toomany:
1293: i = nchargs + i0;
1294: for(cp = arglist; cp; cp = cp->nextp)
1295: i++;
1296: toofew:
1297: switch(zap) {
1298: case 2: zap = 6; break;
1299: case 1: if (at->defined & 4)
1300: return;
1301: }
1302: sprintf(buf,
1303: "%s%.90s:\n\there %d, previously %d args and string lengths.",
1304: inconsist, fname, i, nargs);
1305: atype_squawk(at, buf);
1306: if (type)
1307: goto newlist;
1308: return;
1309: }
1310: j = atypes->type;
1311: k = *t++;
1312: if (j != k)
1313: goto badtypes;
1314: }
1315: for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1316: if (++i > nargs)
1317: goto toomany;
1318: j = atypes->type;
1319: if (!(q = (expptr)cp->datap))
1320: continue;
1321: k = typekludge(ccall, q, atypes, j);
1322: if (k >= 300 || k == j)
1323: continue;
1324: if (j >= 300) {
1325: if (k >= 200) {
1326: if (k == TYUNKNOWN + 200)
1327: continue;
1328: if (j % 100 != k - 200
1329: && k != TYSUBR + 200
1330: && j != TYUNKNOWN + 300
1331: && !type_fixup(at,atypes,k))
1332: goto badtypes;
1333: }
1334: else if (j % 100 % TYSUBR != k % TYSUBR
1335: && !type_fixup(at,atypes,k))
1336: goto badtypes;
1337: }
1338: else if (k < 200 || j < 200)
1339: if (j) {
1340: if (k == TYUNKNOWN
1341: && q->tag == TNAME
1342: && q->nameblock.vinfproc) {
1343: q->nameblock.vdcldone = 0;
1344: impldcl((Namep)q);
1345: }
1346: goto badtypes;
1347: }
1348: else ; /* fall through to update */
1349: else if (k == TYUNKNOWN+200)
1350: continue;
1351: else if (j != TYUNKNOWN+200)
1352: {
1353: badtypes:
1354: if (++nbad == 1)
1355: bad_atypes(at, fname, i, j, k, "here ",
1356: ", previously");
1357: else
1358: fprintf(stderr,
1359: "\targ %d: here %s, previously %s.\n",
1360: i, Argtype(k,buf1),
1361: Argtype(j,buf2));
1362: continue;
1363: }
1364: /* We've subsequently learned the right type,
1365: as in the call on zoo below...
1366:
1367: subroutine foo(x, zap)
1368: external zap
1369: call goo(zap)
1370: x = zap(3)
1371: call zoo(zap)
1372: end
1373: */
1374: if (!nbad) {
1375: atypes->type = k;
1376: at->changes |= 1;
1377: }
1378: }
1379: if (i < nargs)
1380: goto toofew;
1381: if (nbad) {
1382: if (type) {
1383: /* we're defining the procedure */
1384: t = init_ap[type];
1385: te = t + i0;
1386: proc_argchanges = 1;
1387: goto newlist;
1388: }
1389: return;
1390: }
1391: if (zap == 1 && (at->changes & 5) != 5)
1392: at->changes = 0;
1393: return;
1394: }
1395: newlist:
1396: i = i0 + nchargs;
1397: for(cp = arglist; cp; cp = cp->nextp)
1398: i++;
1399: k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
1400: *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
1401: : (Argtypes *) mem(k,1);
1402: at->dnargs = at->nargs = i;
1403: at->defined = zap & 6;
1404: at->changes = type ? 0 : 4;
1405: atypes = at->atypes;
1406: for(; t < te; atypes++) {
1407: atypes->type = *t++;
1408: atypes->cp = 0;
1409: }
1410: for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1411: atypes->cp = 0;
1412: atypes->type = (q = (expptr)cp->datap)
1413: ? typekludge(ccall, q, atypes, 0)
1414: : 0;
1415: }
1416: for(; --nchargs >= 0; atypes++) {
1417: atypes->type = TYFTNLEN + 100;
1418: atypes->cp = 0;
1419: }
1420: }
1421:
1422: void
1423: saveargtypes(p) /* for writing prototypes */
1424: register Exprp p;
1425: {
1426: Addrp a;
1427: Argtypes **at0, **at1;
1428: Namep np;
1429: chainp arglist;
1430: expptr rp;
1431: Extsym *e;
1432: char *fname;
1433:
1434: a = (Addrp)p->leftp;
1435: switch(a->vstg) {
1436: case STGEXT:
1437: switch(a->uname_tag) {
1438: case UNAM_EXTERN: /* e.g., sqrt() */
1439: e = extsymtab + a->memno;
1440: at0 = at1 = &e->arginfo;
1441: fname = e->fextname;
1442: break;
1443: case UNAM_NAME:
1444: np = a->user.name;
1445: at0 = &extsymtab[np->vardesc.varno].arginfo;
1446: at1 = &np->arginfo;
1447: fname = np->fvarname;
1448: break;
1449: default:
1450: goto bug;
1451: }
1452: break;
1453: case STGARG:
1454: if (a->uname_tag != UNAM_NAME)
1455: goto bug;
1456: np = a->user.name;
1457: at0 = at1 = &np->arginfo;
1458: fname = np->fvarname;
1459: break;
1460: default:
1461: bug:
1462: Fatal("Confusion in saveargtypes");
1463: }
1464: rp = p->rightp;
1465: arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
1466: save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
1467: fname, a->vstg, 0, 0, 0);
1468: }
1469:
1470: /* putcall - fix up the argument list, and write out the invocation. p
1471: is expected to be initialized and point to an OPCALL or OPCCALL
1472: expression. The return value is a pointer to a temporary holding the
1473: result of a COMPLEX or CHARACTER operation, or NULL. */
1474:
1475: LOCAL expptr putcall(p0, temp)
1476: expptr p0;
1477: Addrp *temp;
1478: {
1479: register Exprp p = (Exprp)p0;
1480: chainp arglist; /* Pointer to actual arguments, if any */
1481: chainp charsp; /* List of copies of the variables which
1482: hold the lengths of character
1483: parameters (other than procedure
1484: parameters) */
1485: chainp cp; /* Iterator over argument lists */
1486: register expptr q; /* Pointer to the current argument */
1487: Addrp fval; /* Function return value */
1488: int type; /* type of the call - presumably this was
1489: set elsewhere */
1490: int byvalue; /* True iff we don't want to massage the
1491: parameter list, since we're calling a C
1492: library routine */
1493: char *s;
1494: extern struct Listblock *mklist();
1495:
1496: type = p -> vtype;
1497: charsp = NULL;
1498: byvalue = (p->opcode == OPCCALL);
1499:
1500: /* Verify the actual parameters */
1501:
1502: if (p == (Exprp) NULL)
1503: err ("putcall: NULL call expression");
1504: else if (p -> tag != TEXPR)
1505: erri ("putcall: expected TEXPR, got '%d'", p -> tag);
1506:
1507: /* Find the argument list */
1508:
1509: if(p->rightp && p -> rightp -> tag == TLIST)
1510: arglist = p->rightp->listblock.listp;
1511: else
1512: arglist = NULL;
1513:
1514: /* Count the number of explicit arguments, including lengths of character
1515: variables */
1516:
1517: for(cp = arglist ; cp ; cp = cp->nextp)
1518: if(!byvalue) {
1519: q = (expptr) cp->datap;
1520: if( ISCONST(q) )
1521: {
1522:
1523: /* Even constants are passed by reference, so we need to put them in the
1524: literal table */
1525:
1526: q = (expptr) putconst((Constp)q);
1527: cp->datap = (char *) q;
1528: }
1529:
1530: /* Save the length expression of character variables (NOT character
1531: procedures) for the end of the argument list */
1532:
1533: if( ISCHAR(q) &&
1534: (q->headblock.vclass != CLPROC
1535: || q->headblock.vstg == STGARG
1536: && q->tag == TADDR
1537: && q->addrblock.uname_tag == UNAM_NAME
1538: && q->addrblock.user.name->vprocclass == PTHISPROC))
1539: {
1540: p0 = cpexpr(q->headblock.vleng);
1541: charsp = mkchain((char *)p0, charsp);
1542: if (q->headblock.vclass == CLUNKNOWN
1543: && q->headblock.vstg == STGARG)
1544: q->addrblock.user.name->vpassed = 1;
1545: else if (q->tag == TADDR
1546: && q->addrblock.uname_tag == UNAM_CONST)
1547: p0->constblock.Const.ci
1548: += q->addrblock.user.Const.ccp1.blanks;
1549: }
1550: }
1551: charsp = revchain(charsp);
1552:
1553: /* If the routine is a CHARACTER function ... */
1554:
1555: if(type == TYCHAR)
1556: {
1557: if( ISICON(p->vleng) )
1558: {
1559:
1560: /* Allocate a temporary to hold the return value of the function */
1561:
1562: fval = mktmp(TYCHAR, p->vleng);
1563: }
1564: else {
1565: err("adjustable character function");
1566: if (temp)
1567: *temp = 0;
1568: return 0;
1569: }
1570: }
1571:
1572: /* If the routine is a COMPLEX function ... */
1573:
1574: else if( ISCOMPLEX(type) )
1575: fval = mktmp(type, ENULL);
1576: else
1577: fval = NULL;
1578:
1579: /* Write the function name, without taking its address */
1580:
1581: p -> leftp = putx(fixtype(putaddr(p->leftp)));
1582:
1583: if(fval)
1584: {
1585: chainp prepend;
1586:
1587: /* Prepend a copy of the function return value buffer out as the first
1588: argument. */
1589:
1590: prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
1591:
1592: /* If it's a character function, also prepend the length of the result */
1593:
1594: if(type==TYCHAR)
1595: {
1596:
1597: prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
1598: p->vleng)), arglist);
1599: }
1600: if (!(q = p->rightp))
1601: p->rightp = q = (expptr)mklist(CHNULL);
1602: q->listblock.listp = prepend;
1603: }
1604:
1605: /* Scan through the fortran argument list */
1606:
1607: for(cp = arglist ; cp ; cp = cp->nextp)
1608: {
1609: q = (expptr) (cp->datap);
1610: if (q == ENULL)
1611: err ("putcall: NULL argument");
1612:
1613: /* call putaddr only when we've got a parameter for a C routine or a
1614: memory resident parameter */
1615:
1616: if (q -> tag == TCONST && !byvalue)
1617: q = (expptr) putconst ((Constp)q);
1618:
1619: if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
1620: if (q->addrblock.parenused
1621: && !byvalue && q->headblock.vtype != TYCHAR)
1622: goto make_copy;
1623: cp->datap = (char *)putaddr(q);
1624: }
1625: else if( ISCOMPLEX(q->headblock.vtype) )
1626: cp -> datap = (char *) putx (fixtype(putcxop(q)));
1627: else if (ISCHAR(q) )
1628: cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
1629: else if( ! ISERROR(q) )
1630: {
1631: if(byvalue
1632: || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
1633: cp -> datap = (char *) putx(q);
1634: else {
1635: expptr t, t1;
1636:
1637: /* If we've got a register parameter, or (maybe?) a constant, save it in a
1638: temporary first */
1639: make_copy:
1640: t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
1641:
1642: /* Assign to temporary variables before invoking the subroutine or
1643: function */
1644:
1645: t1 = putassign( cpexpr(t), q );
1646: if (doin_setbound)
1647: t = mkexpr(OPCOMMA_ARG, t1, t);
1648: else
1649: putout(t1);
1650: cp -> datap = (char *) t;
1651: } /* else */
1652: } /* if !ISERROR(q) */
1653: }
1654:
1655: /* Now adjust the lengths of the CHARACTER parameters */
1656:
1657: for(cp = charsp ; cp ; cp = cp->nextp)
1658: cp->datap = (char *)addrfix(putx(
1659: /* in case MAIN has a character*(*)... */
1660: (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
1661: : ICON(0)));
1662:
1663: /* ... and add them to the end of the argument list */
1664:
1665: hookup (arglist, charsp);
1666:
1667: /* Return the name of the temporary used to hold the results, if any was
1668: necessary. */
1669:
1670: if (temp) *temp = fval;
1671: else frexpr ((expptr)fval);
1672:
1673: saveargtypes(p);
1674:
1675: return (expptr) p;
1676: }
1677:
1678:
1679:
1680: /* putmnmx -- Put min or max. p must point to an EXPR, not just a
1681: CONST */
1682:
1683: LOCAL expptr putmnmx(p)
1684: register expptr p;
1685: {
1686: int op, op2, type;
1687: expptr arg, qp, temp;
1688: chainp p0, p1;
1689: Addrp sp, tp;
1690: char comment_buf[80];
1691: char *what;
1692:
1693: if(p->tag != TEXPR)
1694: badtag("putmnmx", p->tag);
1695:
1696: type = p->exprblock.vtype;
1697: op = p->exprblock.opcode;
1698: op2 = op == OPMIN ? OPMIN2 : OPMAX2;
1699: p0 = p->exprblock.leftp->listblock.listp;
1700: free( (charptr) (p->exprblock.leftp) );
1701: free( (charptr) p );
1702:
1703: /* special case for two addressable operands */
1704:
1705: if (addressable((expptr)p0->datap)
1706: && (p1 = p0->nextp)
1707: && addressable((expptr)p1->datap)
1708: && !p1->nextp) {
1709: if (type == TYREAL && forcedouble)
1710: op2 = op == OPMIN ? OPDMIN : OPDMAX;
1711: p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
1712: mkconv(type, cpexpr((expptr)p1->datap)));
1713: frchain(&p0);
1714: return p;
1715: }
1716:
1717: /* general case */
1718:
1719: sp = mktmp(type, ENULL);
1720:
1721: /* We only need a second temporary if the arg list has an unaddressable
1722: value */
1723:
1724: tp = (Addrp) NULL;
1725: qp = ENULL;
1726: for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
1727: if (!addressable ((expptr) p1 -> datap)) {
1728: tp = mktmp(type, ENULL);
1729: qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
1730: qp = fixexpr((Exprp)qp);
1731: break;
1732: } /* if */
1733:
1734: /* Now output the appropriate number of assignments and comparisons. Min
1735: and max are implemented by the simple O(n) algorithm:
1736:
1737: min (a, b, c, d) ==>
1738: { <type> t1, t2;
1739:
1740: t1 = a;
1741: t2 = b; t1 = (t1 < t2) ? t1 : t2;
1742: t2 = c; t1 = (t1 < t2) ? t1 : t2;
1743: t2 = d; t1 = (t1 < t2) ? t1 : t2;
1744: }
1745: */
1746:
1747: if (!doin_setbound) {
1748: switch(op) {
1749: case OPLT:
1750: case OPMIN:
1751: case OPDMIN:
1752: case OPMIN2:
1753: what = "IN";
1754: break;
1755: default:
1756: what = "AX";
1757: }
1758: sprintf (comment_buf, "Computing M%s", what);
1759: p1_comment (comment_buf);
1760: }
1761:
1762: p1 = p0->nextp;
1763: temp = (expptr)p0->datap;
1764: if (addressable(temp) && addressable((expptr)p1->datap)) {
1765: p = mkconv(type, cpexpr(temp));
1766: arg = mkconv(type, cpexpr((expptr)p1->datap));
1767: temp = mkexpr(op2, p, arg);
1768: if (!ISCONST(temp))
1769: temp = fixexpr((Exprp)temp);
1770: p1 = p1->nextp;
1771: }
1772: p = putassign (cpexpr((expptr)sp), temp);
1773:
1774: for(; p1 ; p1 = p1->nextp)
1775: {
1776: if (addressable ((expptr) p1 -> datap)) {
1777: arg = mkconv(type, cpexpr((expptr)p1->datap));
1778: temp = mkexpr(op2, cpexpr((expptr)sp), arg);
1779: temp = fixexpr((Exprp)temp);
1780: } else {
1781: temp = (expptr) cpexpr (qp);
1782: p = mkexpr(OPCOMMA, p,
1783: putassign(cpexpr((expptr)tp), (expptr)p1->datap));
1784: } /* else */
1785:
1786: if(p1->nextp)
1787: p = mkexpr(OPCOMMA, p,
1788: putassign(cpexpr((expptr)sp), temp));
1789: else {
1790: if (type == TYREAL && forcedouble)
1791: temp->exprblock.opcode =
1792: op == OPMIN ? OPDMIN : OPDMAX;
1793: if (doin_setbound)
1794: p = mkexpr(OPCOMMA, p, temp);
1795: else {
1796: putout (p);
1797: p = putx(temp);
1798: }
1799: if (qp)
1800: frexpr (qp);
1801: } /* else */
1802: } /* for */
1803:
1804: frchain( &p0 );
1805: return p;
1806: }
1807:
1808:
1809: void
1810: putwhile(p)
1811: expptr p;
1812: {
1813: long where;
1814: int k, n;
1815:
1816: if (wh_next >= wh_last)
1817: {
1818: k = wh_last - wh_first;
1819: n = k + 100;
1820: wh_next = mem(n,0);
1821: wh_last = wh_first + n;
1822: if (k)
1823: memcpy(wh_next, wh_first, k);
1824: wh_first = wh_next;
1825: wh_next += k;
1826: wh_last = wh_first + n;
1827: }
1828: if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
1829: {
1830: if(k != TYERROR)
1831: err("non-logical expression in DO WHILE statement");
1832: }
1833: else {
1834: p1put(P1_WHILE1START);
1835: where = ftell(pass1_file);
1836: p = putx(p);
1837: *wh_next++ = ftell(pass1_file) > where;
1838: p1put(P1_WHILE2START);
1839: p1_expr(p);
1840: }
1841: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.