1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
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.
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
22 ****************************************************************/
24 /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
25 /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
29 #include "output.h" /* for nice_printf */
34 LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 (), putchop ();
38 LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
39 LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
40 LOCAL expptr putcxcmp ();
47 extern int proc_argchanges, proc_protochanges;
51 /* Puthead -- output the header information about subroutines, functions
58 if (headerdone == NO) {
72 if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
75 err("non-logical expression in IF statement");
100 /* Used to make temporaries in holdtemps available here, but they */
101 /* may be reused too soon (e.g. when multiple **'s are involved). */
106 putcmgo(index, nlab, labs)
109 struct Labelblock *labs[];
111 if(! ISINT(index->headblock.vtype) )
113 execerr("computed goto index must be integer", CNULL);
117 p1comp_goto (index, nlab, labs);
133 switch(p->constblock.vtype)
145 /* Don't write it out to the p2 file, since you'd need to call putconst,
146 which is just what we need to avoid in the translator */
150 p = putx( (expptr)putconst((Constp)p) );
156 switch(opc = p->exprblock.opcode)
160 if( ISCOMPLEX(p->exprblock.vtype) )
162 else p = putcall(p, (Addrp *)NULL);
172 if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
173 || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
176 } else if( ISCHAR(p) )
184 if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
185 ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
194 if(ISCHAR(p->exprblock.leftp))
206 /* m * (2**k) -> m<<k */
207 if(INT(p->exprblock.leftp->headblock.vtype) &&
208 ISICON(p->exprblock.rightp) &&
209 ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
211 p->exprblock.opcode = OPLSHIFT;
212 frexpr(p->exprblock.rightp);
213 p->exprblock.rightp = ICON(k);
226 if( ISCOMPLEX(p->exprblock.vtype) )
232 if( ISCOMPLEX(p->exprblock.vtype) )
234 else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
236 p = putx( mkconv(p->exprblock.vtype,
237 (expptr)realpart(putcx1(p->exprblock.leftp))));
281 badtag("putx", p->tag);
290 LOCAL expptr putop(p)
297 switch(p->exprblock.opcode) /* check for special cases and rewrite */
300 pt = p->exprblock.vtype;
301 lp = p->exprblock.leftp;
302 lt = lp->headblock.vtype;
304 /* Simplify nested type casts */
306 while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
307 ( (ISREAL(pt)&&ISREAL(lt)) ||
308 (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
313 if(pt==TYINT && lt==TYLONG)
315 if(lt==TYINT && pt==TYLONG)
321 if(pt==TYDREAL && lt==TYREAL)
324 lp->exprblock.opcode==OPCONV &&
325 lp->exprblock.leftp->headblock.vtype==TYDREAL)
327 lp->exprblock.leftp =
328 putx(lp->exprblock.leftp);
335 if(lt==TYCHAR && lp->tag==TEXPR &&
336 lp->exprblock.opcode==OPCALL)
339 /* May want to make a comma expression here instead. I had one, but took
340 it out for my convenience, not for the convenience of the end user */
342 putout (putcall (lp, (Addrp *) &(p ->
347 p->exprblock.leftp = putx(p->exprblock.leftp);
355 lp = p->exprblock.leftp;
356 lt = lp->headblock.vtype;
358 if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
365 lp = p->exprblock.leftp;
370 Mktemp(lp->headblock.vtype,lp->headblock.vleng);
371 p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
376 p = mkexpr(OPCOMMA, p, putaddr(lp));
378 p = (expptr)putaddr(lp);
392 if( ops2[p->exprblock.opcode] <= 0)
393 badop("putop", p->exprblock.opcode);
394 p -> exprblock.leftp = putx (p -> exprblock.leftp);
395 if (p -> exprblock.rightp)
396 p -> exprblock.rightp = putx (p -> exprblock.rightp);
400 LOCAL expptr putpower(p)
407 char buf[80]; /* buffer for text of comment */
409 if(!ISICON(p->exprblock.rightp) ||
410 (k = p->exprblock.rightp->constblock.Const.ci)<2)
411 Fatal("putpower: bad call");
412 base = p->exprblock.leftp;
413 type = base->headblock.vtype;
414 t1 = Mktemp(type, ENULL);
418 p = putassign (cpexpr((expptr) t1), base);
420 sprintf (buf, "Computing %d%s power", k, k == 2 ? "nd" : (k == 3 ?
424 for( ; (k&1)==0 && k>2 ; k>>=1 )
426 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
431 /* Write the power computation out immediately */
433 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
435 t2 = Mktemp(type, ENULL);
436 p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
437 cpexpr((expptr)t1)));
439 for(k>>=1 ; k>1 ; k>>=1)
441 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
444 p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
447 /* Write the power computation out immediately */
449 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
450 mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
461 LOCAL Addrp intdouble(p)
466 t = Mktemp(TYDREAL, ENULL);
467 putout (putassign(cpexpr((expptr)t), (expptr)p));
475 /* Complex-type variable assignment */
477 LOCAL Addrp putcxeq(p)
480 register Addrp lp, rp;
484 badtag("putcxeq", p->tag);
486 lp = putcx1(p->exprblock.leftp);
487 rp = putcx1(p->exprblock.rightp);
488 code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
490 if( ISCOMPLEX(p->exprblock.vtype) )
492 code = mkexpr (OPCOMMA, code, putassign
493 (imagpart(lp), imagpart(rp)));
503 /* putcxop -- used to write out embedded calls to complex functions, and
504 complex arguments to procedures */
509 return (expptr)putaddr((expptr)putcx1(p));
512 #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
514 LOCAL Addrp putcx1(p)
531 if( ISCOMPLEX(p->constblock.vtype) )
532 p = (expptr) putconst((Constp)p);
536 resp = &p->addrblock;
539 if ((q = resp->memoffset) && resp->isarray
540 && resp->vtype != TYCHAR) {
541 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
542 && resp->uname_tag == UNAM_NAME)
543 q = mkexpr(OPMINUS, q,
544 mkintcon(resp->user.name->voffset));
545 ts = typesize[resp->vtype]
546 * (resp->Field ? 2 : 1);
547 q = resp->memoffset = mkexpr(OPSLASH, q, ICON(ts));
551 resp = Mktemp(tyint, ENULL);
552 putout(putassign(cpexpr((expptr)resp), q));
553 p->addrblock.memoffset = (expptr)resp;
555 resp = &p->addrblock;
556 q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
557 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
558 && resp->uname_tag == UNAM_NAME)
559 q = mkexpr(OPPLUS, q,
560 mkintcon(resp->user.name->voffset));
566 if( ISCOMPLEX(p->exprblock.vtype) )
568 resp = Mktemp(TYDREAL, ENULL);
569 putout (putassign( cpexpr((expptr)resp), p));
573 badtag("putcx1", p->tag);
576 opcode = p->exprblock.opcode;
577 if(opcode==OPCALL || opcode==OPCCALL)
584 else if(opcode == OPASSIGN)
589 /* BUG (inefficient) Generates too many temporary variables */
591 resp = Mktemp(p->exprblock.vtype, ENULL);
592 if(lp = putcx1(p->exprblock.leftp) )
594 if(rp = putcx1(p->exprblock.rightp) )
600 frexpr((expptr)resp);
608 putassign( (expptr)realpart(resp),
609 mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
610 putassign( imagpart(resp),
611 mkexpr(OPNEG, imagpart(lp), ENULL))));
615 case OPMINUS: { expptr r;
616 r = putassign( (expptr)realpart(resp),
617 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
618 if(rtype < TYCOMPLEX)
619 q = putassign( imagpart(resp), imagpart(lp) );
620 else if(ltype < TYCOMPLEX)
623 q = putassign( imagpart(resp), imagpart(rp) );
625 q = putassign( imagpart(resp),
626 mkexpr(OPNEG, imagpart(rp), ENULL) );
629 q = putassign( imagpart(resp),
630 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
634 } /* case OPPLUS, OPMINUS: */
636 if(ltype < TYCOMPLEX)
641 putassign( (expptr)realpart(resp),
642 mkexpr(OPSTAR, cpexpr((expptr)lp),
643 (expptr)realpart(rp))),
644 putassign( imagpart(resp),
645 mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
647 else if(rtype < TYCOMPLEX)
652 putassign( (expptr)realpart(resp),
653 mkexpr(OPSTAR, cpexpr((expptr)rp),
654 (expptr)realpart(lp))),
655 putassign( imagpart(resp),
656 mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
660 putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
661 mkexpr(OPSTAR, (expptr)realpart(lp),
662 (expptr)realpart(rp)),
663 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
664 putassign( imagpart(resp), mkexpr(OPPLUS,
665 mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
666 mkexpr(OPSTAR, imagpart(lp),
667 (expptr)realpart(rp))))));
672 /* fixexpr has already replaced all divisions
673 * by a complex by a function call
678 putassign( (expptr)realpart(resp),
679 mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
680 putassign( imagpart(resp),
681 mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
685 if( ISCOMPLEX(lp->vtype) )
688 q = (expptr) realpart(rp);
690 q = mkrealcon(TYDREAL, "0");
692 putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
693 putassign( imagpart(resp), q)));
697 badop("putcx1", opcode);
709 /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
712 LOCAL expptr putcxcmp(p)
716 register Addrp lp, rp;
720 badtag("putcxcmp", p->tag);
722 opcode = p->exprblock.opcode;
723 lp = putcx1(p->exprblock.leftp);
724 rp = putcx1(p->exprblock.rightp);
726 q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
727 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
728 mkexpr(opcode, imagpart(lp), imagpart(rp)) );
733 return putx( fixexpr((Exprp)q) );
736 /* putch1 -- Forces constants into the literal pool, among other things */
738 LOCAL Addrp putch1(p)
747 return( putconst((Constp)p) );
753 switch(p->exprblock.opcode)
765 t = Mktemp(TYCHAR, ICON(lencat(p)));
766 q = (expptr) cpexpr(p->headblock.vleng);
767 p = putcat( cpexpr((expptr)t), p );
768 /* put the correct length on the block */
775 if(!ISICON(p->exprblock.vleng)
776 || p->exprblock.vleng->constblock.Const.ci!=1
777 || ! INT(p->exprblock.leftp->headblock.vtype) )
778 Fatal("putch1: bad character conversion");
779 t = Mktemp(TYCHAR, ICON(1));
780 e = mkexpr(OPCONV, (expptr)t, ENULL);
781 e->headblock.vtype = tyint;
782 p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
786 badop("putch1", p->exprblock.opcode);
791 badtag("putch1", p->tag);
793 /* NOT REACHED */ return 0;
797 /* putchop -- Write out a character actual parameter; that is, this is
798 part of a procedure invocation */
800 LOCAL Addrp putchop(p)
803 p = putaddr((expptr)putch1(p));
810 LOCAL expptr putcheq(p)
816 badtag("putcheq", p->tag);
818 lp = p->exprblock.leftp;
819 rp = p->exprblock.rightp;
820 frexpr(p->exprblock.vleng);
823 /* If s = t // u, don't bother copying the result, write it directly into
826 if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
828 else if( ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
829 lp = mkexpr(OPCONV, lp, ENULL);
830 rp = mkexpr(OPCONV, rp, ENULL);
831 lp->headblock.vtype = rp->headblock.vtype = tyint;
832 p = putop(mkexpr(OPASSIGN, lp, rp));
835 p = putx( call2(TYSUBR, "s_copy", lp, rp) );
842 LOCAL expptr putchcmp(p)
848 badtag("putchcmp", p->tag);
850 lp = p->exprblock.leftp;
851 rp = p->exprblock.rightp;
853 if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
854 lp = mkexpr(OPCONV, putx(lp), ENULL);
855 rp = mkexpr(OPCONV, putx(rp), ENULL);
856 lp->headblock.vtype = rp->headblock.vtype = tyint;
859 lp = call2(TYINT,"s_cmp", lp, rp);
862 p->exprblock.leftp = lp;
863 p->exprblock.rightp = rp;
872 /* putcat -- Writes out a concatenation operation. Two temporary arrays
873 are allocated, putct1() is called to initialize them, and then a
874 call to runtime library routine s_cat() is inserted.
876 This routine generates code which will perform an (nconc lhs rhs)
877 at runtime. The runtime funciton does not return a value, the routine
878 that calls this putcat must remember the name of lhs.
882 LOCAL expptr putcat(lhs0, rhs)
886 register Addrp lhs = (Addrp)lhs0;
888 Addrp length_var, string_var;
890 static char Writing_concatenation[] = "Writing concatenation";
892 /* Create the temporary arrays */
895 length_var = mktmpn(n, tyioint, ENULL);
896 string_var = mktmpn(n, TYADDR, ENULL);
897 frtemp((Addrp)cpexpr((expptr)length_var));
898 frtemp((Addrp)cpexpr((expptr)string_var));
900 /* Initialize the arrays */
903 /* p1_comment scribbles on its argument, so we
904 * cannot safely pass a string literal here. */
905 p1_comment(Writing_concatenation);
906 putct1(rhs, length_var, string_var, &n);
908 /* Create the invocation */
911 tyint = tyioint; /* for -I2 */
912 p = putx (call4 (TYSUBR, "s_cat",
916 (expptr)putconst((Constp)ICON(n))));
926 LOCAL putct1(q, length_var, string_var, ip)
928 register Addrp length_var, string_var;
932 Addrp length_copy, string_copy;
935 if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
937 putct1(q->exprblock.leftp, length_var, string_var,
939 putct1(q->exprblock.rightp, length_var, string_var,
941 frexpr (q -> exprblock.vleng);
947 length_copy = (Addrp) cpexpr((expptr)length_var);
948 length_copy->memoffset =
949 mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
950 string_copy = (Addrp) cpexpr((expptr)string_var);
951 string_copy->memoffset =
952 mkexpr(OPPLUS, string_copy->memoffset,
953 ICON(i*typesize[TYLONG]));
954 putout (PAIR (putassign((expptr)length_copy, cpexpr
955 (q->headblock.vleng)),
956 putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
960 /* putaddr -- seems to write out function invocation actual parameters */
962 LOCAL expptr putaddr(p0)
967 if (!(p = (Addrp)p0))
970 if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
975 if (p->isarray && p->memoffset)
976 p->memoffset = putx(p->memoffset);
981 addrfix(e) /* fudge character string length if it's a TADDR */
984 return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
988 typekludge(ccall, q, at, j)
992 int j; /* alternate type */
995 extern int iocalladdr;
998 /* Return value classes:
999 * < 100 ==> Fortran arg (pointer to type)
1001 * < 300 ==> procedure arg
1002 * < 400 ==> external, no explicit type
1003 * < 500 ==> arg that may turn out to be
1004 * either a variable or a procedure
1007 k = q->headblock.vtype;
1010 k = TYDREAL; /* force double for library routines */
1016 if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
1017 || (i == TADDR && q->addrblock.charleng)
1020 else if (i == TADDR)
1021 switch(q->addrblock.vclass) {
1023 if (q->addrblock.uname_tag != UNAM_NAME)
1025 else if ((np = q->addrblock.user.name)->vprocclass
1027 if (k && !np->vimpltype)
1030 if (j > 200 && infertypes && j < 300) {
1032 inferdcl(np, j-200);
1034 else k = (np->vstg == STGEXT
1035 ? extsymtab[np->vardesc.varno].extype
1037 at->cp = mkchain((char *)np, at->cp);
1040 else if (k == TYSUBR)
1045 if (q->addrblock.vstg == STGARG
1046 && q->addrblock.uname_tag == UNAM_NAME) {
1048 at->cp = mkchain((char *)q->addrblock.user.name,
1052 else if (i == TNAME && q->nameblock.vstg == STGARG) {
1054 switch(np->vclass) {
1058 else if (j <= 200 || !infertypes || j >= 300)
1062 inferdcl(np, j-200);
1067 /* argument may be a scalar variable or a function */
1068 if (np->vimpltype && j && infertypes
1070 inferdcl(np, j % 100);
1076 /* to handle procedure args only so far known to be
1077 * external, save a pointer to the symbol table entry...
1080 at->cp = mkchain((char *)np, at->cp);
1092 sprintf(buf, "%s variable", ftn_types[k]);
1097 return k == TYFTNLEN ? "ftnlen" : ftn_types[k];
1102 return ftn_types[TYSUBR];
1103 sprintf(buf, "%s function", ftn_types[k]);
1107 return "external argument";
1109 sprintf(buf, "%s argument", ftn_types[k]);
1114 atype_squawk(at, msg)
1118 register Atype *a, *ae;
1120 for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
1123 if (at->changes & 2)
1124 proc_protochanges++;
1127 static char inconsist[] = "inconsistent calling sequences for ";
1130 bad_atypes(at, fname, i, j, k, here, prev)
1132 char *fname, *here, *prev;
1135 char buf[208], buf1[32], buf2[32];
1137 sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
1138 inconsist, fname, i, here, Argtype(k, buf1),
1139 prev, Argtype(j, buf2));
1140 atype_squawk(at, buf);
1149 register struct Entrypoint *ep;
1152 for(ep = entries; ep; ep = ep->entnextp)
1153 if (at == ep->entryname->arginfo) {
1155 return proc_argchanges = 1;
1162 save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type)
1164 Argtypes **at0, **at1;
1165 int ccall, stg, nchargs, type;
1170 int i, i0, j, k, nargs, *t, *te;
1174 static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
1175 static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,
1176 initargs, initargs+1,0,initargs+2};
1177 static int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,
1180 i = i0 = init_ac[type];
1186 if (nargs < 0) { /* inconsistent usage seen */
1188 if (at->changes & 2)
1189 --proc_protochanges;
1194 for(cp = arglist; cp; cp = cp->nextp)
1196 if ((i += nchargs) != nargs) {
1198 "%s%.90s:\n\there %d, previously %d args and string lengths.",
1199 inconsist, fname, i, nargs);
1200 atype_squawk(at, buf);
1206 atypes = at->atypes;
1208 for(; t < te; atypes++) {
1215 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1218 if (!(q = (expptr)cp->datap))
1220 k = typekludge(ccall, q, atypes, j);
1221 if (k >= 300 || k == j)
1225 if (k == TYUNKNOWN + 200)
1227 if (j % 100 != k - 200
1228 && k != TYSUBR + 200
1229 && j != TYUNKNOWN + 300
1230 && !type_fixup(at,atypes,k))
1233 else if (j % 100 % TYSUBR != k % TYSUBR
1234 && !type_fixup(at,atypes,k))
1237 else if (k < 200 || j < 200)
1240 else ; /* fall through to update */
1241 else if (k == TYUNKNOWN+200)
1243 else if (j != TYUNKNOWN+200)
1246 bad_atypes(at, fname, i, j, k, "here ",
1249 /* we're defining the procedure */
1252 proc_argchanges = 1;
1257 /* We've subsequently learned the right type,
1258 as in the call on zoo below...
1260 subroutine foo(x, zap)
1276 for(cp = arglist; cp; cp = cp->nextp)
1278 k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
1279 *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
1280 : (Argtypes *) mem(k,1);
1283 atypes = at->atypes;
1284 for(; t < te; atypes++) {
1285 atypes->type = *t++;
1288 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
1290 atypes->type = (q = (expptr)cp->datap)
1291 ? typekludge(ccall, q, atypes, 0)
1294 for(; --nchargs >= 0; atypes++) {
1295 atypes->type = TYFTNLEN + 100;
1301 saveargtypes(p) /* for writing prototypes */
1305 Argtypes **at0, **at1;
1312 a = (Addrp)p->leftp;
1315 switch(a->uname_tag) {
1316 case UNAM_EXTERN: /* e.g., sqrt() */
1317 e = extsymtab + a->memno;
1318 at0 = at1 = &e->arginfo;
1319 fname = e->fextname;
1323 at0 = &extsymtab[np->vardesc.varno].arginfo;
1325 fname = np->fvarname;
1332 if (a->uname_tag != UNAM_NAME)
1335 at0 = at1 = &np->arginfo;
1336 fname = np->fvarname;
1340 Fatal("Confusion in saveargtypes");
1343 arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
1344 save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
1345 fname, a->vstg, 0, 0);
1348 /* putcall - fix up the argument list, and write out the invocation. p
1349 is expected to be initialized and point to an OPCALL or OPCCALL
1350 expression. The return value is a pointer to a temporary holding the
1351 result of a COMPLEX or CHARACTER operation, or NULL. */
1353 LOCAL expptr putcall(p0, temp)
1357 register Exprp p = (Exprp)p0;
1358 chainp arglist; /* Pointer to actual arguments, if any */
1359 chainp charsp; /* List of copies of the variables which
1360 hold the lengths of character
1361 parameters (other than procedure
1363 chainp cp; /* Iterator over argument lists */
1364 register expptr q; /* Pointer to the current argument */
1365 Addrp fval; /* Function return value */
1366 int type; /* type of the call - presumably this was
1368 int byvalue; /* True iff we don't want to massage the
1369 parameter list, since we're calling a C
1371 extern int Castargs;
1373 extern struct Listblock *mklist();
1377 byvalue = (p->opcode == OPCCALL);
1379 /* Verify the actual parameters */
1381 if (p == (Exprp) NULL)
1382 err ("putcall: NULL call expression");
1383 else if (p -> tag != TEXPR)
1384 erri ("putcall: expected TEXPR, got '%d'", p -> tag);
1386 /* Find the argument list */
1388 if(p->rightp && p -> rightp -> tag == TLIST)
1389 arglist = p->rightp->listblock.listp;
1393 /* Count the number of explicit arguments, including lengths of character
1396 for(cp = arglist ; cp ; cp = cp->nextp)
1398 q = (expptr) cp->datap;
1402 /* Even constants are passed by reference, so we need to put them in the
1405 q = (expptr) putconst((Constp)q);
1406 cp->datap = (char *) q;
1409 /* Save the length expression of character variables (NOT character
1410 procedures) for the end of the argument list */
1413 (q->headblock.vclass != CLPROC
1414 || q->headblock.vstg == STGARG
1416 && q->addrblock.uname_tag == UNAM_NAME
1417 && q->addrblock.user.name->vprocclass == PTHISPROC))
1419 charsp = mkchain((char *)cpexpr(q->headblock.vleng), charsp);
1420 if (q->headblock.vclass == CLUNKNOWN
1421 && q->headblock.vstg == STGARG)
1422 q->addrblock.user.name->vpassed = 1;
1425 charsp = revchain(charsp);
1427 /* If the routine is a CHARACTER function ... */
1431 if( ISICON(p->vleng) )
1434 /* Allocate a temporary to hold the return value of the function */
1436 fval = Mktemp(TYCHAR, p->vleng);
1439 err("adjustable character function");
1446 /* If the routine is a COMPLEX function ... */
1448 else if( ISCOMPLEX(type) )
1449 fval = Mktemp(type, ENULL);
1453 /* Write the function name, without taking its address */
1455 p -> leftp = putx(fixtype(putaddr(p->leftp)));
1461 /* Prepend a copy of the function return value buffer out as the first
1464 prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
1466 /* If it's a character function, also prepend the length of the result */
1471 prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
1472 p->vleng)), arglist);
1474 if (!(q = p->rightp))
1475 p->rightp = q = (expptr)mklist(CHNULL);
1476 q->listblock.listp = prepend;
1479 /* Scan through the fortran argument list */
1481 for(cp = arglist ; cp ; cp = cp->nextp)
1483 q = (expptr) (cp->datap);
1485 err ("putcall: NULL argument");
1487 /* call putaddr only when we've got a parameter for a C routine or a
1488 memory resident parameter */
1490 if (q -> tag == TCONST && !byvalue)
1491 q = (expptr) putconst ((Constp)q);
1493 if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) )
1494 cp->datap = (char *)putaddr(q);
1495 else if( ISCOMPLEX(q->headblock.vtype) )
1496 cp -> datap = (char *) putx (fixtype(putcxop(q)));
1497 else if (ISCHAR(q) )
1498 cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
1499 else if( ! ISERROR(q) )
1502 || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
1503 cp -> datap = (char *) putx(q);
1507 /* If we've got a register parameter, or (maybe?) a constant, save it in a
1510 t = (expptr) Mktemp(q->headblock.vtype, q->headblock.vleng);
1512 /* Assign to temporary variables before invoking the subroutine or
1515 t1 = putassign( cpexpr(t), q );
1517 t = mkexpr(OPCOMMA_ARG, t1, t);
1520 cp -> datap = (char *) t;
1522 } /* if !ISERROR(q) */
1525 /* Now adjust the lengths of the CHARACTER parameters */
1527 for(cp = charsp ; cp ; cp = cp->nextp)
1528 cp->datap = (char *)addrfix(putx(
1529 /* in case MAIN has a character*(*)... */
1530 (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
1533 /* ... and add them to the end of the argument list */
1535 hookup (arglist, charsp);
1537 /* Return the name of the temporary used to hold the results, if any was
1540 if (temp) *temp = fval;
1541 else frexpr ((expptr)fval);
1550 /* putmnmx -- Put min or max. p must point to an EXPR, not just a
1553 LOCAL expptr putmnmx(p)
1557 expptr arg, qp, temp;
1560 char comment_buf[80];
1564 badtag("putmnmx", p->tag);
1566 type = p->exprblock.vtype;
1567 op = p->exprblock.opcode;
1568 op2 = op == OPMIN ? OPMIN2 : OPMAX2;
1569 p0 = p->exprblock.leftp->listblock.listp;
1570 free( (charptr) (p->exprblock.leftp) );
1571 free( (charptr) p );
1573 /* special case for two addressable operands */
1575 if (addressable((expptr)p0->datap)
1577 && addressable((expptr)p1->datap)
1579 if (type == TYREAL && forcedouble)
1580 op2 = op == OPMIN ? OPDMIN : OPDMAX;
1581 p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
1582 mkconv(type, cpexpr((expptr)p1->datap)));
1589 sp = Mktemp(type, ENULL);
1591 /* We only need a second temporary if the arg list has an unaddressable
1596 for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
1597 if (!addressable ((expptr) p1 -> datap)) {
1598 tp = Mktemp(type, ENULL);
1599 qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
1600 qp = fixexpr((Exprp)qp);
1604 /* Now output the appropriate number of assignments and comparisons. Min
1605 and max are implemented by the simple O(n) algorithm:
1607 min (a, b, c, d) ==>
1611 t2 = b; t1 = (t1 < t2) ? t1 : t2;
1612 t2 = c; t1 = (t1 < t2) ? t1 : t2;
1613 t2 = d; t1 = (t1 < t2) ? t1 : t2;
1617 if (!doin_setbound) {
1628 sprintf (comment_buf, "Computing M%s", what);
1629 p1_comment (comment_buf);
1633 temp = (expptr)p0->datap;
1634 if (addressable(temp) && addressable((expptr)p1->datap)) {
1635 p = mkconv(type, cpexpr(temp));
1636 arg = mkconv(type, cpexpr((expptr)p1->datap));
1637 temp = mkexpr(op2, p, arg);
1639 temp = fixexpr((Exprp)temp);
1642 p = putassign (cpexpr((expptr)sp), temp);
1644 for(; p1 ; p1 = p1->nextp)
1646 if (addressable ((expptr) p1 -> datap)) {
1647 arg = mkconv(type, cpexpr((expptr)p1->datap));
1648 temp = mkexpr(op2, cpexpr((expptr)sp), arg);
1649 temp = fixexpr((Exprp)temp);
1651 temp = (expptr) cpexpr (qp);
1652 p = mkexpr(OPCOMMA, p,
1653 putassign(cpexpr((expptr)tp), (expptr)p1->datap));
1657 p = mkexpr(OPCOMMA, p,
1658 putassign(cpexpr((expptr)sp), temp));
1660 if (type == TYREAL && forcedouble)
1661 temp->exprblock.opcode =
1662 op == OPMIN ? OPDMIN : OPDMAX;
1664 p = mkexpr(OPCOMMA, p, temp);
1687 if (wh_next >= wh_last)
1689 k = wh_last - wh_first;
1692 wh_last = wh_first + n;
1694 memcpy(wh_next, wh_first, k);
1697 wh_last = wh_first + n;
1699 if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
1702 err("non-logical expression in IF statement");
1705 p1put(P1_WHILE1START);
1706 where = ftell(pass1_file);
1708 *wh_next++ = ftell(pass1_file) > where;
1709 p1put(P1_WHILE2START);