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 ****************************************************************/
28 LOCAL void conspower(), consbinop(), zdiv();
29 LOCAL expptr fold(), mkpower(), stfcall();
31 typedef struct { double dreal, dimag; } dcomplex;
33 extern char dflttype[26];
35 /* little routines to create constant blocks */
42 p = ALLOC(Constblock);
49 /* mklogcon -- Make Logical Constant */
56 p = mkconst(TYLOGICAL);
63 /* mkintcon -- Make Integer Constant */
73 if(l >= -MAXSHORT && l <= MAXSHORT)
82 /* mkaddcon -- Make Address Constant, given integer value */
96 /* mkrealcon -- Make Real Constant. The type t is assumed
97 to be TYREAL or TYDREAL */
99 expptr mkrealcon(t, d)
106 p->Const.cds[0] = cds(d,CNULL);
108 return( (expptr) p );
112 /* mkbitcon -- Make bit constant. Reads the input string, which is
113 assumed to correctly specify a number in base 2^shift (where shift
114 is the input parameter). shift may not exceed 4, i.e. only binary,
115 quad, octal and hex bases may be input. Constants may not exceed 32
116 bits, or whatever the size of (struct Constblock).ci may be. */
118 expptr mkbitcon(shift, leng, s)
130 x = (x << shift) | hextoi(*s++);
131 /* mwm wanted to change the type to short for short constants,
132 * but this is dangerous -- there is no syntax for long constants
136 return( (expptr) p );
143 /* mkstrcon -- Make string constant. Allocates storage and initializes
144 the memory for a copy of the input Fortran-string. */
155 p->Const.ccp = s = (char *) ckalloc(l+1);
156 p->Const.ccp1.blanks = 0;
160 return( (expptr) p );
165 /* mkcxcon -- Make complex contsant. A complex number is a pair of
166 values, each of which may be integer, real or double. */
168 expptr mkcxcon(realp,imagp)
169 register expptr realp, imagp;
175 rtype = realp->headblock.vtype;
176 itype = imagp->headblock.vtype;
178 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
180 p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
181 ? TYDCOMPLEX : TYCOMPLEX);
182 if (realp->constblock.vstg || imagp->constblock.vstg) {
184 p->Const.cds[0] = ISINT(rtype)
185 ? string_num("", realp->constblock.Const.ci)
186 : realp->constblock.vstg
187 ? realp->constblock.Const.cds[0]
188 : dtos(realp->constblock.Const.cd[0]);
189 p->Const.cds[1] = ISINT(itype)
190 ? string_num("", imagp->constblock.Const.ci)
191 : imagp->constblock.vstg
192 ? imagp->constblock.Const.cds[0]
193 : dtos(imagp->constblock.Const.cd[0]);
196 p->Const.cd[0] = ISINT(rtype)
197 ? realp->constblock.Const.ci
198 : realp->constblock.Const.cd[0];
199 p->Const.cd[1] = ISINT(itype)
200 ? imagp->constblock.Const.ci
201 : imagp->constblock.Const.cd[0];
206 err("invalid complex constant");
207 p = (Constp)errnode();
212 return( (expptr) p );
216 /* errnode -- Allocate a new error block */
220 struct Errorblock *p;
221 p = ALLOC(Errorblock);
224 return( (expptr) p );
231 /* mkconv -- Make type conversion. Cast expression p into type t.
232 Note that casting to a character copies only the first sizeof(char)
243 if(t==TYUNKNOWN || t==TYERROR)
244 badtype("mkconv", t);
245 pt = p->headblock.vtype;
247 /* Casting to the same type is a no-op */
252 /* If we're casting a constant which is not in the literal table ... */
254 else if( ISCONST(p) && pt!=TYADDR)
256 if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
257 /* avoid trouble with -i2 */
258 p->headblock.vtype = t;
261 q = (expptr) mkconst(t);
262 consconv(t, &q->constblock, &p->constblock );
269 q->constblock.vleng = ICON(1);
275 /* opconv -- Convert expression p to type t using the main
276 expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */
284 q = mkexpr(OPCONV, p, ENULL);
285 q->headblock.vtype = t;
291 /* addrof -- Create an ADDR expression operation */
296 return( mkexpr(OPADDR, p, ENULL) );
301 /* cpexpr - Returns a new copy of input expression p */
308 register chainp ep, pp;
311 /* This table depends on the ordering of the TY macros, e.g. TYUNKNOWN */
313 static int blksize[ ] =
316 sizeof(struct Nameblock),
317 sizeof(struct Constblock),
318 sizeof(struct Exprblock),
319 sizeof(struct Addrblock),
320 sizeof(struct Primblock),
321 sizeof(struct Listblock),
322 sizeof(struct Errorblock)
328 /* TNAMEs are special, and don't get copied. Each name in the current
329 symbol table has a unique TNAME structure. */
331 if( (tag = p->tag) == TNAME)
334 e = cpblock(blksize[p->tag], (char *)p);
339 if(e->constblock.vtype == TYCHAR)
341 e->constblock.Const.ccp =
342 copyn((int)e->constblock.vleng->constblock.Const.ci+1,
343 e->constblock.Const.ccp);
344 e->constblock.vleng =
345 (expptr) cpexpr(e->constblock.vleng);
351 e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp);
352 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
356 if(pp = p->listblock.listp)
358 ep = e->listblock.listp =
359 mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
360 for(pp = pp->nextp ; pp ; pp = pp->nextp)
362 mkchain((char *)cpexpr((tagptr)pp->datap),
368 e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng);
369 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
370 e->addrblock.istemp = NO;
374 e->primblock.argsp = (struct Listblock *)
375 cpexpr((expptr)e->primblock.argsp);
376 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
377 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
381 badtag("cpexpr", tag);
387 /* frexpr -- Free expression -- frees up memory used by expression p */
402 free( (charptr) (p->constblock.Const.ccp) );
403 frexpr(p->constblock.vleng);
408 if (p->addrblock.vtype > TYERROR) /* i/o block */
410 frexpr(p->addrblock.vleng);
411 frexpr(p->addrblock.memoffset);
417 /* TNAME blocks don't get free'd - probably because they're pointed to in
418 the hash table. 14-Jun-88 -- mwm */
424 frexpr((expptr)p->primblock.argsp);
425 frexpr(p->primblock.fcharp);
426 frexpr(p->primblock.lcharp);
430 frexpr(p->exprblock.leftp);
431 if(p->exprblock.rightp)
432 frexpr(p->exprblock.rightp);
436 for(q = p->listblock.listp ; q ; q = q->nextp)
437 frexpr((tagptr)q->datap);
438 frchain( &(p->listblock.listp) );
442 badtag("frexpr", p->tag);
453 warn1("fixing wrong type inferred for %.65s", np->fvarname);
455 c = letter(np->fvarname[0]);
456 if ((np->vtype = impltype[c]) == TYCHAR
457 && (k = implleng[c]))
461 /* fix up types in expression; replace subtrees and convert
462 names to address blocks */
474 if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
478 return( (expptr) putconst((Constp)p) );
481 p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
488 badtag("fixtype", p->tag);
490 /* This case means that fixexpr can't call fixtype with any expr,
491 only a subexpr of its parameter. */
494 return( fixexpr((Exprp)p) );
497 return( (expptr) p );
500 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
502 if(p->primblock.namep->vtype == TYSUBR)
504 err("function invocation of subroutine");
508 if (p->primblock.namep->vinftype)
509 wronginf(p->primblock.namep);
510 return( mkfunct(p) );
514 /* The lack of args makes p a function name, substring reference
517 else return( mklhs((struct Primblock *) p) );
523 /* special case tree transformations and cleanups of expression trees.
524 Parameter p should have a TEXPR tag at its root, else an error is
533 int opcode, ltype, rtype, ptype, mtype;
536 return( (expptr) p );
537 else if(p->tag != TEXPR)
538 badtag("fixexpr", p->tag);
541 /* First set the types of the left and right subexpressions */
543 lp = p->leftp = fixtype(p->leftp);
544 ltype = lp->headblock.vtype;
546 if(opcode==OPASSIGN && lp->tag!=TADDR)
548 err("left side of assignment must be variable");
555 rp = p->rightp = fixtype(p->rightp);
556 rtype = rp->headblock.vtype;
564 if(ltype==TYERROR || rtype==TYERROR)
570 /* Now work on the whole expression */
572 /* force folding if possible */
574 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
576 q = mkexpr(opcode, lp, rp);
578 /* mkexpr is expected to reduce constant expressions */
582 free( (charptr) q ); /* constants did not fold */
585 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
595 p->vleng = mkexpr(OPPLUS,
596 cpexpr(lp->headblock.vleng),
597 cpexpr(rp->headblock.vleng) );
607 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
609 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
611 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
612 && typesize[ltype]>=typesize[rtype] )
615 /* Cast the right hand side to match the type of the expression */
617 p->rightp = fixtype( mkconv(ptype, rp) );
621 if( ISCOMPLEX(rtype) )
623 p = (Exprp) call2(ptype,
625 /* Handle double precision complex variables */
627 ptype == TYCOMPLEX ? "c_div" : "z_div",
628 mkconv(ptype, lp), mkconv(ptype, rp) );
635 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
636 (rtype==TYREAL && ! ISCONST(rp) ) ))
638 if( ISCOMPLEX(ptype) )
641 /* Cast both sides of the expression to match the type of the whole
644 if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL))
645 p->leftp = fixtype(mkconv(ptype,lp));
646 if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL))
647 p->rightp = fixtype(mkconv(ptype,rp));
651 return( mkpower((expptr)p) );
661 mtype = cktype(OPMINUS, ltype, rtype);
662 if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
663 (rtype==TYREAL && ! ISCONST(rp)) ))
665 if( ISCOMPLEX(mtype) )
668 p->leftp = fixtype(mkconv(mtype,lp));
670 p->rightp = fixtype(mkconv(mtype,rp));
674 ptype = cktype(OPCONV, p->vtype, ltype);
675 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
677 lp->exprblock.rightp =
678 fixtype( mkconv(ptype, lp->exprblock.rightp) );
685 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
686 Fatal("addr of addr");
714 /* fix an argument list, taking due care for special first level cases */
717 int doput; /* doput is true if constants need to be passed by reference */
718 struct Listblock *p0;
721 register tagptr q, t;
728 for(p = p0->listp ; p ; p = p->nextp)
731 q = (tagptr)p->datap;
735 if(q->constblock.vtype == TYSHORT)
736 q = (tagptr) mkconv(tyint, q);
737 /* leave constant arguments of intrinsics alone --
738 * the expression might still simplify.
741 /* Call putconst() to store values in a constant table. Since even
742 constants must be passed by reference, this can optimize on the storage
745 p->datap = doput ? (char *)putconst((Constp)q)
749 /* Take a function name and turn it into an Addr. This only happens when
750 nothing else has figured out the function beforehand */
752 else if(qtag==TPRIM && q->primblock.argsp==0 &&
753 q->primblock.namep->vclass==CLPROC &&
754 q->primblock.namep->vprocclass != PTHISPROC)
755 p->datap = (char *)mkaddr(q->primblock.namep);
757 else if(qtag==TPRIM && q->primblock.argsp==0 &&
758 q->primblock.namep->vdim!=NULL)
759 p->datap = (char *)mkscalar(q->primblock.namep);
761 else if(qtag==TPRIM && q->primblock.argsp==0 &&
762 q->primblock.namep->vdovar &&
763 (t = (tagptr) memversion(q->primblock.namep)) )
764 p->datap = (char *)fixtype(t);
766 p->datap = (char *)fixtype(q);
773 /* mkscalar -- only called by fixargs above, and by some routines in
784 /* The prolog causes array arguments to point to the
785 * (0,...,0) element, unless subscript checking is on.
787 if( !checksubs && np->vstg==STGARG)
789 register struct Dimblock *dp;
791 frexpr(ap->memoffset);
792 ap->memoffset = mkexpr(OPSTAR,
795 (tagptr)ICON(typesize[np->vtype]) ),
796 cpexpr(dp->baseoffset) );
803 adjust_arginfo(np) /* adjust arginfo to omit the length arg for the
804 arg that we now know to be a character-valued
808 struct Entrypoint *ep;
809 register chainp args;
812 for(ep = entries; ep; ep = ep->entnextp)
813 for(args = ep->arglist; args; args = args->nextp)
814 if (np == (Namep)args->datap
815 && (at = ep->entryname->arginfo))
824 register struct Primblock *p = (struct Primblock *)p0;
825 struct Entrypoint *ep;
831 extern chainp new_procs;
842 if(class == CLUNKNOWN)
844 np->vclass = class = CLPROC;
845 if(np->vstg == STGUNKNOWN)
847 if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
848 && (zflag || !(*(struct Intrpacked *)&k).f4
852 np->vardesc.varno = k;
853 np->vprocclass = PINTRINSIC;
857 extp = mkext(np->fvarname,
858 addunder(np->cvarname));
859 extp->extstg = STGEXT;
861 np->vardesc.varno = extp - extsymtab;
862 np->vprocclass = PEXTERNAL;
865 else if(np->vstg==STGARG)
867 if(np->vtype == TYCHAR) {
870 char wbuf[160], *who;
872 sprintf(wbuf, "%s%s%s\n\t%s%s%s",
873 "Character-valued dummy procedure ",
874 who, " not declared EXTERNAL.",
875 "Code may be wrong for previous function calls having ",
876 who, " as a parameter.");
880 np->vprocclass = PEXTERNAL;
885 fatali("invalid class code %d for function", class);
887 /* F77 doesn't allow subscripting of function calls */
889 if(p->fcharp || p->lcharp)
891 err("no substring of function call");
895 np->vimpltype = 0; /* invoking as function ==> inferred type */
897 nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp);
899 switch(np->vprocclass)
902 if(np->vtype == TYUNKNOWN)
904 dclerr("attempt to use untyped function", np);
905 np->vtype = dflttype[letter(np->fvarname[0])];
908 if (!extsymtab[np->vardesc.varno].extseen) {
909 new_procs = mkchain((char *)np, new_procs);
910 extsymtab[np->vardesc.varno].extseen = 1;
913 q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
914 q->exprblock.vtype = np->vtype;
916 q->exprblock.vleng = (expptr) cpexpr(np->vleng);
920 q = intrcall(np, p->argsp, nargs);
924 q = stfcall(np, p->argsp);
928 warn("recursive call");
930 /* entries is the list of multiple entry points */
932 for(ep = entries ; ep ; ep = ep->entnextp)
936 Fatal("mkfunct: impossible recursion");
938 ap = builtin(np->vtype, ep->entryname->cextname, -2);
939 /* the negative last arg prevents adding */
940 /* this name to the list of used builtins */
944 fatali("mkfunct: impossible vprocclass %d",
945 (int) (np->vprocclass) );
957 LOCAL expptr stfcall(np, actlist)
959 struct Listblock *actlist;
961 register chainp actuals;
963 chainp oactp, formals;
967 register struct Rplblock *rp;
968 struct Rplblock *tlist;
972 actuals = actlist->listp;
973 free( (charptr) actlist);
981 if( (type = np->vtype) == TYUNKNOWN)
983 dclerr("attempt to use untyped statement function", np);
984 type = np->vtype = dflttype[letter(np->fvarname[0])];
986 formals = (chainp) np->varxptr.vstfdesc->datap;
987 rhs = (expptr) (np->varxptr.vstfdesc->nextp);
989 /* copy actual arguments into temporaries */
990 while(actuals!=NULL && formals!=NULL)
992 rp = ALLOC(Rplblock);
993 rp->rplnp = tnp = (Namep) formals->datap;
994 ap = fixtype((tagptr)actuals->datap);
995 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
996 && (ap->tag==TCONST || ap->tag==TADDR) )
999 /* If actuals are constants or variable names, no temporaries are required */
1000 rp->rplvp = (expptr) ap;
1002 rp->rpltag = ap->tag;
1005 rp->rplvp = (expptr) Mktemp(tnp->vtype, tnp->vleng);
1007 putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
1008 if((rp->rpltag = rp->rplvp->tag) == TERROR)
1009 err("disagreement of argument types in statement function call");
1011 rp->rplnextp = tlist;
1013 actuals = actuals->nextp;
1014 formals = formals->nextp;
1018 if(actuals!=NULL || formals!=NULL)
1019 err("statement function definition and argument list differ");
1022 now push down names involved in formal argument list, then
1023 evaluate rhs of statement function definition in this environment
1026 if(tlist) /* put tlist in front of the rpllist */
1028 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
1030 rp->rplnextp = rpllist;
1034 /* So when the expression finally gets evaled, that evaluator must read
1035 from the globl rpllist 14-jun-88 mwm */
1037 q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
1039 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
1043 q = mkexpr(OPCOMMA, rpllist->rplxp, q);
1044 rp = rpllist->rplnextp;
1045 frexpr(rpllist->rplvp);
1046 free((char *)rpllist);
1054 static int replaced;
1056 /* mkplace -- Figure out the proper storage class for the input name and
1057 return an addrp with the appropriate stuff */
1063 register struct Rplblock *rp;
1066 /* is name on the replace list? */
1068 for(rp = rpllist ; rp ; rp = rp->rplnextp)
1073 if(rp->rpltag == TNAME)
1075 np = (Namep) (rp->rplvp);
1078 else return( (Addrp) cpexpr(rp->rplvp) );
1082 /* is variable a DO index in a register ? */
1084 if(np->vdovar && ( (regn = inregister(np)) >= 0) )
1085 if(np->vtype == TYERROR)
1086 return((Addrp) errnode() );
1089 s = ALLOC(Addrblock);
1094 s->memoffset = ICON(0);
1095 s -> uname_tag = UNAM_NAME;
1096 s -> user.name = np;
1105 static int doing_vleng;
1107 /* mklhs -- Compute the actual address of the given expression; account
1108 for array subscripts, stack offset, and substring offsets. The f -> C
1109 translator will need this only to worry about the subscript stuff */
1112 register struct Primblock *p;
1119 return( (expptr) p );
1124 if(s->tag!=TADDR || s->vstg==STGREG)
1126 free( (charptr) p );
1127 return( (expptr) s );
1130 /* compute the address modified by subscripts */
1133 s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
1134 frexpr((expptr)p->argsp);
1137 /* now do substring part */
1139 if(p->fcharp || p->lcharp)
1141 if(np->vtype != TYCHAR)
1142 errstr("substring of noncharacter %s", np->fvarname);
1144 if(p->lcharp == NULL)
1145 p->lcharp = (expptr) cpexpr(s->vleng);
1148 s->vleng = fixtype(mkexpr(OPMINUS,
1150 mkexpr(OPMINUS, p->fcharp, ICON(1) )));
1155 s->vleng = p->lcharp;
1160 s->vleng = fixtype( s->vleng );
1161 s->memoffset = fixtype( s->memoffset );
1162 free( (charptr) p );
1163 return( (expptr) s );
1170 /* deregister -- remove a register allocation from the list; assumes that
1171 names are deregistered in stack order (LIFO order - Last In First Out) */
1176 if(nregvar>0 && regnamep[nregvar-1]==np)
1185 /* memversion -- moves a DO index REGISTER into a memory location; other
1186 objects are passed through untouched */
1188 Addrp memversion(np)
1193 if(np->vdovar==NO || (inregister(np)<0) )
1203 /* inregister -- looks for the input name in the global list regnamep */
1210 for(i = 0 ; i < nregvar ; ++i)
1211 if(regnamep[i] == np)
1212 return( regnum[i] );
1218 /* suboffset -- Compute the offset from the start of the array, given the
1219 subscripts as arguments */
1222 register struct Primblock *p;
1229 struct Dimblock *dimp;
1230 expptr sub[MAXDIM+1];
1237 for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
1239 si = fixtype(cpexpr((tagptr)cp->datap));
1240 if (!ISINT(si->headblock.vtype)) {
1241 NOEXT("non-integer subscript");
1242 si = mkconv(TYLONG, si);
1247 erri("more than %d subscripts", maxdim);
1253 if(n>0 && dimp==NULL)
1254 err("subscripts on scalar variable");
1255 else if(dimp && dimp->ndim!=n)
1256 errstr("wrong number of subscripts on %s", np->fvarname);
1261 prod = mkexpr(OPPLUS, sub[n],
1262 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1263 if(checksubs || np->vstg!=STGARG)
1264 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1266 /* Add in the run-time bounds check */
1269 prod = subcheck(np, prod);
1270 size = np->vtype == TYCHAR ?
1271 (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
1272 prod = mkexpr(OPSTAR, prod, size);
1273 offp = mkexpr(OPPLUS, offp, prod);
1276 /* Check for substring indicator */
1278 if(p->fcharp && np->vtype==TYCHAR)
1279 offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
1287 expptr subcheck(np, p)
1291 struct Dimblock *dimp;
1292 expptr t, checkvar, checkcond, badcall;
1295 if(dimp->nelt == NULL)
1296 return(p); /* don't check arrays with * bounds */
1301 /* check for negative (constant) offset */
1303 if(p->constblock.Const.ci < 0)
1305 if( ISICON(dimp->nelt) )
1307 /* see if constant offset exceeds the array declaration */
1309 if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
1315 /* We know that the subscript offset p or dimp -> nelt is not a constant.
1316 Now find a register to use for run-time bounds checking */
1318 if(p->tag==TADDR && p->addrblock.vstg==STGREG)
1320 checkvar = (expptr) cpexpr(p);
1324 checkvar = (expptr) Mktemp(p->headblock.vtype, ENULL);
1325 t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
1327 checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
1329 checkcond = mkexpr(OPAND, checkcond,
1330 mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
1332 /* Construct the actual test */
1334 badcall = call4(p->headblock.vtype, "s_rnge",
1335 mkstrcon(strlen(np->fvarname), np->fvarname),
1336 mkconv(TYLONG, cpexpr(checkvar)),
1337 mkstrcon(strlen(procname), procname),
1339 badcall->exprblock.opcode = OPCCALL;
1340 p = mkexpr(OPQUEST, checkcond,
1341 mkexpr(OPCOLON, checkvar, badcall));
1347 errstr("subscript on variable %s out of range", np->fvarname);
1365 if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
1366 return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
1370 if(p->vclass != CLPROC)
1372 extp = mkext(p->fvarname, addunder(p->cvarname));
1373 extp->extstg = STGEXT;
1375 p->vardesc.varno = extp - extsymtab;
1376 p->vprocclass = PEXTERNAL;
1377 if ((extp->exproto || infertypes)
1378 && (p->vtype == TYUNKNOWN || p->vimpltype)
1379 && (k = extp->extype))
1391 t = ALLOC(Addrblock);
1394 t->vclass = p->vclass;
1395 t->vtype = p->vtype;
1397 t->memno = p->vardesc.varno;
1398 t->memoffset = ICON(p->voffset);
1403 t->vleng = (expptr) cpexpr(p->vleng);
1404 if( ISICON(t->vleng) )
1405 t->varleng = t->vleng->constblock.Const.ci;
1408 /* Keep the original name around for the C code generation */
1410 t -> uname_tag = UNAM_NAME;
1416 return ( intraddr (p));
1418 badstg("mkaddr", p->vstg);
1419 /* NOT REACHED */ return 0;
1425 /* mkarg -- create storage for a new parameter. This is called when a
1426 function returns a string (for the return value, which is the first
1427 parameter), or when a variable-length string is passed to a function. */
1429 Addrp mkarg(type, argno)
1434 p = ALLOC(Addrblock);
1439 /* TYLENG is the type of the field holding the length of a character string */
1441 p->vstg = (type==TYLENG ? STGLENG : STGARG);
1449 /* mkprim -- Create a PRIM (primary/primitive) block consisting of a
1450 Nameblock (or Paramblock), arguments (actual params or array
1451 subscripts) and substring bounds. Requires that v have lots of
1452 extra (uninitialized) storage, since it could be a paramblock or
1455 expptr mkprim(v0, args, substr)
1457 struct Listblock *args;
1461 struct Paramblock paramblock;
1462 struct Nameblock nameblock;
1463 struct Headblock headblock;
1465 register Primu v = (Primu)v0;
1466 register struct Primblock *p;
1468 if(v->headblock.vclass == CLPARAM)
1471 /* v is to be a Paramblock */
1475 errstr("no qualifiers on parameter name %s",
1476 v->paramblock.fvarname);
1477 frexpr((expptr)args);
1480 frexpr((tagptr)substr->datap);
1481 frexpr((tagptr)substr->nextp->datap);
1485 return( errnode() );
1487 return( (expptr) cpexpr(v->paramblock.paramval) );
1490 p = ALLOC(Primblock);
1492 p->vtype = v->nameblock.vtype;
1494 /* v is to be a Nameblock */
1496 p->namep = (Namep) v;
1500 p->fcharp = (expptr) substr->datap;
1501 p->lcharp = (expptr) substr->nextp->datap;
1504 return( (expptr) p);
1509 /* vardcl -- attempt to fill out the Name template for variable v.
1510 This function is called on identifiers known to be variables or
1511 recursive references to the same function */
1518 extern int doing_stmtfcn;
1520 if(v->vclass == CLUNKNOWN)
1524 if(v->vclass == CLNAMELIST)
1527 if(v->vtype == TYUNKNOWN)
1529 else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
1531 dclerr("used as variable", v);
1534 if(v->vstg==STGUNKNOWN) {
1535 if (doing_stmtfcn) {
1536 /* neither declare this variable if its only use */
1537 /* is in defining a stmt function, nor complain */
1538 /* that it is never used */
1542 v->vstg = implstg[ letter(v->fvarname[0]) ];
1546 /* Compute the actual storage location, i.e. offsets from base addresses,
1547 possibly the stack pointer */
1552 v->vardesc.varno = ++lastvarno;
1555 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
1558 if( (neltp = t->nelt) && ISCONST(neltp) ) ;
1560 dclerr("adjustable automatic array", v);
1571 /* Set the implicit type declaration of parameter p based on its first
1581 if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
1583 if(p->vtype == TYUNKNOWN)
1585 k = letter(p->fvarname[0]);
1586 type = impltype[ k ];
1587 leng = implleng[ k ];
1588 if(type == TYUNKNOWN)
1590 if(p->vclass == CLPROC)
1592 dclerr("attempt to use undefined variable", p);
1596 settype(p, type, leng);
1606 int k = impltype[letter(np->fvarname[0])];
1618 #define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c)
1619 #define COMMUTE { e = lp; lp = rp; rp = e; }
1623 /* mkexpr -- Make expression, and simplify constant subcomponents (tree
1624 order is not preserved). Assumes that lp is nonempty, and uses
1625 fold() to simplify adjacent constants */
1627 expptr mkexpr(opcode, lp, rp)
1629 register expptr lp, rp;
1631 register expptr e, e1;
1637 ltype = lp->headblock.vtype;
1639 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1641 rtype = rp->headblock.vtype;
1646 etype = cktype(opcode, ltype, rtype);
1647 if(etype == TYERROR)
1652 /* check for multiplication by 0 and 1 and addition to 0 */
1660 if(rp->constblock.Const.ci == 0)
1670 err("attempted division by zero");
1677 /* Handle multiplying or dividing by 1, -1 */
1682 if(rp->constblock.Const.ci == 1)
1685 if(rp->constblock.Const.ci == -1)
1688 return( mkexpr(OPNEG, lp, ENULL) );
1692 /* Group all constants together. In particular,
1694 (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
1695 (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
1698 if (lp->tag != TEXPR || !lp->exprblock.rightp
1699 || !ISICON(lp->exprblock.rightp))
1702 if (lp->exprblock.opcode == OPLSHIFT) {
1703 L = 1 << lp->exprblock.rightp->constblock.Const.ci;
1704 if (opcode == OPSTAR || ISICON(rp) &&
1705 !(L % rp->constblock.Const.ci)) {
1706 lp->exprblock.opcode = OPSTAR;
1707 lp->exprblock.rightp->constblock.Const.ci = L;
1711 if (lp->exprblock.opcode == OPSTAR) {
1712 if(opcode == OPSTAR)
1713 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
1714 else if(ISICON(rp) &&
1715 (lp->exprblock.rightp->constblock.Const.ci %
1716 rp->constblock.Const.ci) == 0)
1717 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
1720 e1 = lp->exprblock.leftp;
1721 free( (charptr) lp );
1722 return( mkexpr(OPSTAR, e1, e) );
1736 return( mkexpr(OPNEG, rp, ENULL) );
1739 if( ISCONST(rp) && is_negatable((Constp)rp))
1742 consnegop((Constp)rp);
1745 /* Group constants in an addition expression (also subtraction, since the
1746 subtracted value was negated above). In particular,
1748 (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
1754 if(rp->constblock.Const.ci == 0)
1756 if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
1758 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
1759 e1 = lp->exprblock.leftp;
1760 free( (charptr) lp );
1761 return( mkexpr(OPPLUS, e1, e) );
1764 if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
1765 /* check for (i [+const]) - (i [+const]) */
1766 if (lp->tag == TPRIM)
1768 else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
1769 && lp->exprblock.rightp->tag == TCONST) {
1770 e = lp->exprblock.leftp;
1771 if (e->tag != TPRIM)
1776 if (e->primblock.argsp)
1778 if (rp->tag == TPRIM)
1780 else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
1781 && rp->exprblock.rightp->tag == TCONST) {
1782 e1 = rp->exprblock.leftp;
1783 if (e1->tag != TPRIM)
1788 if (e->primblock.namep != e1->primblock.namep
1789 || e1->primblock.argsp)
1791 L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
1793 L -= rp->exprblock.rightp->constblock.Const.ci;
1805 /* Eliminate outermost double negations */
1809 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
1811 e = lp->exprblock.leftp;
1812 free( (charptr) lp );
1817 /* Eliminate outermost double NOTs */
1820 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
1822 e = lp->exprblock.leftp;
1823 free( (charptr) lp );
1831 if(rp!=NULL && rp->listblock.listp==NULL)
1833 free( (charptr) rp );
1845 if(rp->constblock.Const.ci == 0)
1850 else if(opcode == OPOR)
1911 badop("mkexpr", opcode);
1914 e = (expptr) ALLOC(Exprblock);
1915 e->exprblock.tag = TEXPR;
1916 e->exprblock.opcode = opcode;
1917 e->exprblock.vtype = etype;
1918 e->exprblock.leftp = lp;
1919 e->exprblock.rightp = rp;
1920 if(ltag==TCONST && (rp==0 || rtag==TCONST) )
1934 if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1936 return( errnode() );
1939 #define ERR(s) { errs = s; goto error; }
1941 /* cktype -- Check and return the type of the expression */
1944 register int op, lt, rt;
1948 if(lt==TYERROR || rt==TYERROR)
1955 /* If not unary operation, return UNKNOWN */
1957 if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
1968 if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1969 return( maxtype(lt, rt) );
1970 ERR("nonarithmetic operand of arithmetic operator")
1976 ERR("nonarithmetic operand of negation")
1981 ERR("NOT of nonlogical")
1987 if(lt==TYLOGICAL && rt==TYLOGICAL)
1989 ERR("nonlogical operand of logical operator")
1997 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
2000 ERR("illegal comparison")
2003 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
2005 if(op!=OPEQ && op!=OPNE)
2006 ERR("order comparison of complex data")
2009 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
2010 ERR("comparison of nonarithmetic data")
2014 if(lt==TYCHAR && rt==TYCHAR)
2016 ERR("concatenation of nonchar data")
2030 if(lt==TYCHAR && ISINT(rt) )
2044 if( ISINT(lt) && rt==TYCHAR)
2046 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
2047 if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
2050 ERR("impossible conversion")
2074 case OPCOLON: /* Only checks the rightmost type because
2075 of C language definition (rightmost
2076 comma-expr is the value of the expr) */
2084 badop("cktype", op);
2092 /* fold -- simplifies constant expressions; it assumes that e -> leftp and
2093 e -> rightp are TCONST or NULL */
2100 register expptr lp, rp;
2101 int etype, mtype, ltype, rtype, opcode;
2104 struct Constblock lcon, rcon;
2108 opcode = e->exprblock.opcode;
2109 etype = e->exprblock.vtype;
2111 lp = e->exprblock.leftp;
2112 ltype = lp->headblock.vtype;
2113 rp = e->exprblock.rightp;
2119 lp->constblock.Const.ci = ! lp->constblock.Const.ci;
2121 e->exprblock.leftp = 0;
2126 lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
2131 consnegop((Constp)lp);
2143 if ((L = lp->constblock.Const.ci) < 0)
2144 lp->constblock.Const.ci = -L;
2148 if (lp->constblock.vstg) {
2149 s = lp->constblock.Const.cds[0];
2151 lp->constblock.Const.cds[0] = s + 1;
2154 if ((d = lp->constblock.Const.cd[0]) < 0.)
2155 lp->constblock.Const.cd[0] = -d;
2158 return e; /* lazy way out */
2161 badop("fold", opcode);
2164 rtype = rp->headblock.vtype;
2166 p = ALLOC(Constblock);
2169 p->vleng = e->exprblock.vleng;
2180 p->Const.ci = lp->constblock.Const.ci &&
2181 rp->constblock.Const.ci;
2185 p->Const.ci = lp->constblock.Const.ci ||
2186 rp->constblock.Const.ci;
2190 p->Const.ci = lp->constblock.Const.ci ==
2191 rp->constblock.Const.ci;
2195 p->Const.ci = lp->constblock.Const.ci !=
2196 rp->constblock.Const.ci;
2200 p->Const.ci = lp->constblock.Const.ci &
2201 rp->constblock.Const.ci;
2205 p->Const.ci = lp->constblock.Const.ci |
2206 rp->constblock.Const.ci;
2210 p->Const.ci = lp->constblock.Const.ci ^
2211 rp->constblock.Const.ci;
2215 p->Const.ci = lp->constblock.Const.ci <<
2216 rp->constblock.Const.ci;
2220 p->Const.ci = lp->constblock.Const.ci >>
2221 rp->constblock.Const.ci;
2225 ll = lp->constblock.vleng->constblock.Const.ci;
2226 lr = rp->constblock.vleng->constblock.Const.ci;
2227 p->Const.ccp = q = (char *) ckalloc(ll+lr);
2228 p->Const.ccp1.blanks = 0;
2229 p->vleng = ICON(ll+lr);
2230 s = lp->constblock.Const.ccp;
2231 for(i = 0 ; i < ll ; ++i)
2233 s = rp->constblock.Const.ccp;
2234 for(i = 0; i < lr; ++i)
2240 if( ! ISINT(rtype) )
2242 conspower(p, (Constp)lp, rp->constblock.Const.ci);
2249 lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
2250 rp->constblock.Const.ccp,
2251 lp->constblock.vleng->constblock.Const.ci,
2252 rp->constblock.vleng->constblock.Const.ci);
2257 mtype = maxtype(ltype, rtype);
2258 consconv(mtype, &lcon, &lp->constblock);
2259 consconv(mtype, &rcon, &rp->constblock);
2261 consbinop(opcode, mtype, p, &lcon, &rcon);
2266 return( (expptr) p );
2271 /* assign constant l = r , doing coercion */
2273 consconv(lt, lc, rc)
2275 register Constp lc, rc;
2278 register union Constant *lv = &lc->Const, *rv = &rc->Const;
2281 if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
2282 memcpy((char *)lv, (char *)rv, sizeof(union Constant));
2283 lc->vstg = rc->vstg;
2284 if (ISCOMPLEX(lt) && ISREAL(rt)) {
2286 lv->cds[1] = cds("0",CNULL);
2297 /* Casting to character means just copying the first sizeof (character)
2298 bytes into a new 1 character string. This is weird. */
2301 *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
2302 lv->ccp1.blanks = 0;
2308 lv->ci = rv->ccp[0];
2309 else if( ISINT(rt) )
2311 else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
2334 /* Negate constant value -- changes the input node's value */
2342 if (ISCOMPLEX(p->vtype)) {
2343 s = p->Const.cds[1];
2344 p->Const.cds[1] = *s == '-' ? s+1
2345 : *s == '0' ? s : s-1;
2347 s = p->Const.cds[0];
2348 p->Const.cds[0] = *s == '-' ? s+1
2349 : *s == '0' ? s : s-1;
2356 p->Const.ci = - p->Const.ci;
2361 p->Const.cd[1] = - p->Const.cd[1];
2362 /* fall through and do the real parts */
2365 p->Const.cd[0] = - p->Const.cd[0];
2368 badtype("consnegop", p->vtype);
2374 /* conspower -- Expand out an exponentiation */
2381 register union Constant *powp = &p->Const;
2383 struct Constblock x, x0;
2386 memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
2390 switch(type = ap->vtype) /* pow = 1 */
2404 badtype("conspower", type);
2409 switch(type) /* x0 = ap */
2413 x0.Const.ci = ap->Const.ci;
2418 ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
2422 ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
2431 err("integer ** negative number");
2434 else if (!x0.Const.cd[0]
2435 && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
2436 err("0.0 ** negative number");
2440 consbinop(OPSLASH, type, &x, p, &x0);
2443 consbinop(OPSTAR, type, &x, p, &x0);
2448 consbinop(OPSTAR, type, p, p, &x);
2450 consbinop(OPSTAR, type, &x, &x, &x);
2458 /* do constant operation cp = a op b -- assumes that ap and bp have data
2459 matching the input type */
2463 consbinop(opcode, type, cpp, app, bpp)
2465 Constp cpp, app, bpp;
2467 register union Constant *ap = &app->Const,
2471 double ad[2], bd[2], temp;
2475 if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
2476 ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
2477 bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
2478 if (ISCOMPLEX(type)) {
2479 ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
2480 bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
2490 cp->ci = ap->ci + bp->ci;
2494 cp->cd[1] = ad[1] + bd[1];
2497 cp->cd[0] = ad[0] + bd[0];
2507 cp->ci = ap->ci - bp->ci;
2511 cp->cd[1] = ad[1] - bd[1];
2514 cp->cd[0] = ad[0] - bd[0];
2524 cp->ci = ap->ci * bp->ci;
2528 cp->cd[0] = ad[0] * bd[0];
2532 temp = ad[0] * bd[0] - ad[1] * bd[1] ;
2533 cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ;
2543 cp->ci = ap->ci / bp->ci;
2547 cp->cd[0] = ad[0] / bd[0];
2551 zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
2559 cp->ci = ap->ci % bp->ci;
2563 Fatal("inline mod of noninteger");
2571 cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
2575 cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
2578 Fatal("inline min of exected type");
2588 cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
2592 cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
2595 Fatal("inline max of exected type");
2599 default: /* relational ops */
2606 else if(ap->ci == bp->ci)
2614 else if(ad[0] == bd[0])
2620 if(ad[0] == bd[0] &&
2654 /* conssgn - returns the sign of a Fortran constant */
2662 Fatal( "sgn(nonconstant)" );
2664 switch(p->headblock.vtype)
2668 if(p->constblock.Const.ci > 0) return(1);
2669 if(p->constblock.Const.ci < 0) return(-1);
2674 if (p->constblock.vstg) {
2675 s = p->constblock.Const.cds[0];
2682 if(p->constblock.Const.cd[0] > 0) return(1);
2683 if(p->constblock.Const.cd[0] < 0) return(-1);
2687 /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
2691 if (p->constblock.vstg)
2692 return *p->constblock.Const.cds[0] != '0'
2693 && *p->constblock.Const.cds[1] != '0';
2694 return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
2697 badtype( "conssgn", p->constblock.vtype);
2699 /* NOT REACHED */ return 0;
2703 "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2705 LOCAL expptr mkpower(p)
2708 register expptr q, lp, rp;
2709 int ltype, rtype, mtype, tyi;
2711 lp = p->exprblock.leftp;
2712 rp = p->exprblock.rightp;
2713 ltype = lp->headblock.vtype;
2714 rtype = rp->headblock.vtype;
2718 if(rp->constblock.Const.ci == 0)
2723 else if (ISREAL (ltype))
2724 return mkconv (ltype, ICON (1));
2726 return( (expptr) putconst((Constp)
2727 mkconv(ltype, ICON(1))) );
2729 if(rp->constblock.Const.ci < 0)
2734 err("integer**negative");
2735 return( errnode() );
2737 rp->constblock.Const.ci = - rp->constblock.Const.ci;
2738 p->exprblock.leftp = lp
2739 = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
2741 if(rp->constblock.Const.ci == 1)
2744 free( (charptr) p );
2748 if( ONEOF(ltype, MSKINT|MSKREAL) && !doin_setbound) {
2749 p->exprblock.vtype = ltype;
2755 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2756 q = call2(TYSHORT, "pow_hh", lp, rp);
2758 if(ltype == TYSHORT)
2761 lp = mkconv(TYLONG,lp);
2763 rp = mkconv(TYLONG,rp);
2767 rp = (expptr)putconst((Constp)rp);
2770 q = call2(ltype, powint[ltype-TYLONG], lp, rp);
2773 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
2774 extern int callk_kludge;
2775 callk_kludge = TYDREAL;
2776 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2780 q = call2(TYDCOMPLEX, "pow_zz",
2781 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2782 if(mtype == TYCOMPLEX)
2783 q = mkconv(TYCOMPLEX, q);
2785 free( (charptr) p );
2790 /* Complex Division. Same code as in Runtime Library
2796 register dcomplex *a, *b, *c;
2801 if( (abr = b->dreal) < 0.)
2803 if( (abi = b->dimag) < 0.)
2808 Fatal("complex division by zero");
2809 ratio = b->dreal / b->dimag ;
2810 den = b->dimag * (1 + ratio*ratio);
2811 c->dreal = (a->dreal*ratio + a->dimag) / den;
2812 c->dimag = (a->dimag*ratio - a->dreal) / den;
2817 ratio = b->dimag / b->dreal ;
2818 den = b->dreal * (1 + ratio*ratio);
2819 c->dreal = (a->dreal + a->dimag*ratio) / den;
2820 c->dimag = (a->dimag - a->dreal*ratio) / den;