00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027 #include "defs.h"
00028 #include "pccdefs.h"
00029 #include "output.h"
00030 #include "names.h"
00031 #include "p1defs.h"
00032
00033 static Addrp intdouble Argdcl((Addrp));
00034 static Addrp putcx1 Argdcl((tagptr));
00035 static tagptr putaddr Argdcl((tagptr));
00036 static tagptr putcall Argdcl((tagptr, Addrp*));
00037 static tagptr putcat Argdcl((tagptr, tagptr));
00038 static Addrp putch1 Argdcl((tagptr));
00039 static tagptr putchcmp Argdcl((tagptr));
00040 static tagptr putcheq Argdcl((tagptr));
00041 static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
00042 static tagptr putcxcmp Argdcl((tagptr));
00043 static Addrp putcxeq Argdcl((tagptr));
00044 static tagptr putmnmx Argdcl((tagptr));
00045 static tagptr putop Argdcl((tagptr));
00046 static tagptr putpower Argdcl((tagptr));
00047
00048 extern int init_ac[TYSUBR+1];
00049 extern int ops2[];
00050 extern int proc_argchanges, proc_protochanges;
00051 extern int krparens;
00052
00053 #define P2BUFFMAX 128
00054
00055
00056
00057
00058 void
00059 #ifdef KR_headers
00060 puthead(s, classKRH)
00061 char *s;
00062 int classKRH;
00063 #else
00064 puthead(char *s, int classKRH)
00065 #endif
00066 {
00067 if (headerdone == NO) {
00068 if (classKRH == CLMAIN)
00069 s = "MAIN__";
00070 p1_head (classKRH, s);
00071 headerdone = YES;
00072 }
00073 }
00074
00075 void
00076 #ifdef KR_headers
00077 putif(p, else_if_p)
00078 register expptr p;
00079 int else_if_p;
00080 #else
00081 putif(register expptr p, int else_if_p)
00082 #endif
00083 {
00084 register int k;
00085 int n;
00086 long where;
00087
00088 if (else_if_p) {
00089 p1put(P1_ELSEIFSTART);
00090 where = ftell(pass1_file);
00091 }
00092 if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
00093 {
00094 if(k != TYERROR)
00095 err("non-logical expression in IF statement");
00096 }
00097 else {
00098 if (else_if_p) {
00099 if (ei_next >= ei_last)
00100 {
00101 k = ei_last - ei_first;
00102 n = k + 100;
00103 ei_next = mem(n,0);
00104 ei_last = ei_first + n;
00105 if (k)
00106 memcpy(ei_next, ei_first, k);
00107 ei_first = ei_next;
00108 ei_next += k;
00109 ei_last = ei_first + n;
00110 }
00111 p = putx(p);
00112 if (*ei_next++ = ftell(pass1_file) > where) {
00113 p1_if(p);
00114 new_endif();
00115 }
00116 else
00117 p1_elif(p);
00118 }
00119 else {
00120 p = putx(p);
00121 p1_if(p);
00122 }
00123 }
00124 }
00125
00126 void
00127 #ifdef KR_headers
00128 putout(p)
00129 expptr p;
00130 #else
00131 putout(expptr p)
00132 #endif
00133 {
00134 p1_expr (p);
00135
00136
00137
00138 }
00139
00140
00141 void
00142 #ifdef KR_headers
00143 putcmgo(index, nlab, labs)
00144 expptr index;
00145 int nlab;
00146 struct Labelblock **labs;
00147 #else
00148 putcmgo(expptr index, int nlab, struct Labelblock **labs)
00149 #endif
00150 {
00151 if(! ISINT(index->headblock.vtype) )
00152 {
00153 execerr("computed goto index must be integer", CNULL);
00154 return;
00155 }
00156
00157 p1comp_goto (index, nlab, labs);
00158 }
00159
00160 static expptr
00161 #ifdef KR_headers
00162 krput(p)
00163 register expptr p;
00164 #else
00165 krput(register expptr p)
00166 #endif
00167 {
00168 register expptr e, e1;
00169 register unsigned op;
00170 int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
00171
00172 op = p->exprblock.opcode;
00173 e = p->exprblock.leftp;
00174 if (e->tag == TEXPR && e->exprblock.opcode == op) {
00175 e1 = (expptr)mktmp(t, ENULL);
00176 putout(putassign(cpexpr(e1), e));
00177 p->exprblock.leftp = e1;
00178 }
00179 else
00180 p->exprblock.leftp = putx(e);
00181
00182 e = p->exprblock.rightp;
00183 if (e->tag == TEXPR && e->exprblock.opcode == op) {
00184 e1 = (expptr)mktmp(t, ENULL);
00185 putout(putassign(cpexpr(e1), e));
00186 p->exprblock.rightp = e1;
00187 }
00188 else
00189 p->exprblock.rightp = putx(e);
00190 return p;
00191 }
00192
00193 expptr
00194 #ifdef KR_headers
00195 putx(p)
00196 register expptr p;
00197 #else
00198 putx(register expptr p)
00199 #endif
00200 {
00201 int opc;
00202 int k;
00203
00204 if (p)
00205 switch(p->tag)
00206 {
00207 case TERROR:
00208 break;
00209
00210 case TCONST:
00211 switch(p->constblock.vtype)
00212 {
00213 case TYLOGICAL1:
00214 case TYLOGICAL2:
00215 case TYLOGICAL:
00216 #ifdef TYQUAD
00217 case TYQUAD:
00218 #endif
00219 case TYLONG:
00220 case TYSHORT:
00221 case TYINT1:
00222 break;
00223
00224 case TYADDR:
00225 break;
00226 case TYREAL:
00227 case TYDREAL:
00228
00229
00230
00231
00232 break;
00233 default:
00234 p = putx( (expptr)putconst((Constp)p) );
00235 break;
00236 }
00237 break;
00238
00239 case TEXPR:
00240 switch(opc = p->exprblock.opcode)
00241 {
00242 case OPCALL:
00243 case OPCCALL:
00244 if( ISCOMPLEX(p->exprblock.vtype) )
00245 p = putcxop(p);
00246 else p = putcall(p, (Addrp *)NULL);
00247 break;
00248
00249 case OPMIN:
00250 case OPMAX:
00251 p = putmnmx(p);
00252 break;
00253
00254
00255 case OPASSIGN:
00256 if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
00257 || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
00258 (void) putcxeq(p);
00259 p = ENULL;
00260 } else if( ISCHAR(p) )
00261 p = putcheq(p);
00262 else
00263 goto putopp;
00264 break;
00265
00266 case OPEQ:
00267 case OPNE:
00268 if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
00269 ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
00270 {
00271 p = putcxcmp(p);
00272 break;
00273 }
00274 case OPLT:
00275 case OPLE:
00276 case OPGT:
00277 case OPGE:
00278 if(ISCHAR(p->exprblock.leftp))
00279 {
00280 p = putchcmp(p);
00281 break;
00282 }
00283 goto putopp;
00284
00285 case OPPOWER:
00286 p = putpower(p);
00287 break;
00288
00289 case OPSTAR:
00290
00291 if(INT(p->exprblock.leftp->headblock.vtype) &&
00292 ISICON(p->exprblock.rightp) &&
00293 ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
00294 {
00295 p->exprblock.opcode = OPLSHIFT;
00296 frexpr(p->exprblock.rightp);
00297 p->exprblock.rightp = ICON(k);
00298 goto putopp;
00299 }
00300 if (krparens && ISREAL(p->exprblock.vtype))
00301 return krput(p);
00302
00303 case OPMOD:
00304 goto putopp;
00305 case OPPLUS:
00306 if (krparens && ISREAL(p->exprblock.vtype))
00307 return krput(p);
00308 case OPMINUS:
00309 case OPSLASH:
00310 case OPNEG:
00311 case OPNEG1:
00312 case OPABS:
00313 case OPDABS:
00314 if( ISCOMPLEX(p->exprblock.vtype) )
00315 p = putcxop(p);
00316 else goto putopp;
00317 break;
00318
00319 case OPCONV:
00320 if( ISCOMPLEX(p->exprblock.vtype) )
00321 p = putcxop(p);
00322 else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
00323 {
00324 p = putx( mkconv(p->exprblock.vtype,
00325 (expptr)realpart(putcx1(p->exprblock.leftp))));
00326 }
00327 else goto putopp;
00328 break;
00329
00330 case OPNOT:
00331 case OPOR:
00332 case OPAND:
00333 case OPEQV:
00334 case OPNEQV:
00335 case OPADDR:
00336 case OPPLUSEQ:
00337 case OPSTAREQ:
00338 case OPCOMMA:
00339 case OPQUEST:
00340 case OPCOLON:
00341 case OPBITOR:
00342 case OPBITAND:
00343 case OPBITXOR:
00344 case OPBITNOT:
00345 case OPLSHIFT:
00346 case OPRSHIFT:
00347 case OPASSIGNI:
00348 case OPIDENTITY:
00349 case OPCHARCAST:
00350 case OPMIN2:
00351 case OPMAX2:
00352 case OPDMIN:
00353 case OPDMAX:
00354 case OPBITTEST:
00355 case OPBITCLR:
00356 case OPBITSET:
00357 #ifdef TYQUAD
00358 case OPQBITSET:
00359 case OPQBITCLR:
00360 #endif
00361 putopp:
00362 p = putop(p);
00363 break;
00364
00365 case OPCONCAT:
00366
00367 p = (expptr)putch1(p);
00368 break;
00369
00370 default:
00371 badop("putx", opc);
00372 p = errnode ();
00373 }
00374 break;
00375
00376 case TADDR:
00377 p = putaddr(p);
00378 break;
00379
00380 default:
00381 badtag("putx", p->tag);
00382 p = errnode ();
00383 }
00384
00385 return p;
00386 }
00387
00388
00389
00390 LOCAL expptr
00391 #ifdef KR_headers
00392 putop(p)
00393 expptr p;
00394 #else
00395 putop(expptr p)
00396 #endif
00397 {
00398 expptr lp, tp;
00399 int pt, lt, lt1;
00400 int comma;
00401 char *hsave;
00402
00403 switch(p->exprblock.opcode)
00404 {
00405 case OPCONV:
00406 pt = p->exprblock.vtype;
00407 lp = p->exprblock.leftp;
00408 lt = lp->headblock.vtype;
00409
00410
00411
00412 while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
00413 ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
00414 (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
00415 {
00416 if(pt==TYDREAL && lt==TYREAL)
00417 {
00418 if(lp->tag==TEXPR
00419 && lp->exprblock.opcode == OPCONV) {
00420 lt1 = lp->exprblock.leftp->headblock.vtype;
00421 if (lt1 == TYDREAL) {
00422 lp->exprblock.leftp =
00423 putx(lp->exprblock.leftp);
00424 return p;
00425 }
00426 if (lt1 == TYDCOMPLEX) {
00427 lp->exprblock.leftp = putx(
00428 (expptr)realpart(
00429 putcx1(lp->exprblock.leftp)));
00430 return p;
00431 }
00432 }
00433 break;
00434 }
00435 else if (ISREAL(pt) && ISCOMPLEX(lt)) {
00436 p->exprblock.leftp = putx(mkconv(pt,
00437 (expptr)realpart(
00438 putcx1(p->exprblock.leftp))));
00439 break;
00440 }
00441 if(lt==TYCHAR && lp->tag==TEXPR &&
00442 lp->exprblock.opcode==OPCALL)
00443 {
00444
00445
00446
00447
00448 putout (putcall (lp, (Addrp *) &(p ->
00449 exprblock.leftp)));
00450 return putop (p);
00451 }
00452 if (lt == TYCHAR) {
00453 if (ISCONST(p->exprblock.leftp)
00454 && ISNUMERIC(p->exprblock.vtype)) {
00455 hsave = halign;
00456 halign = 0;
00457 p->exprblock.leftp = putx((expptr)
00458 putconst((Constp)
00459 p->exprblock.leftp));
00460 halign = hsave;
00461 }
00462 else
00463 p->exprblock.leftp =
00464 putx(p->exprblock.leftp);
00465 return p;
00466 }
00467 if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
00468 break;
00469 frexpr(p->exprblock.vleng);
00470 free( (charptr) p );
00471 p = lp;
00472 if (p->tag != TEXPR)
00473 goto retputx;
00474 pt = lt;
00475 lp = p->exprblock.leftp;
00476 lt = lp->headblock.vtype;
00477 }
00478 if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
00479 break;
00480 retputx:
00481 return putx(p);
00482
00483 case OPADDR:
00484 comma = NO;
00485 lp = p->exprblock.leftp;
00486 free( (charptr) p );
00487 if(lp->tag != TADDR)
00488 {
00489 tp = (expptr)
00490 mktmp(lp->headblock.vtype,lp->headblock.vleng);
00491 p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
00492 lp = tp;
00493 comma = YES;
00494 }
00495 if(comma)
00496 p = mkexpr(OPCOMMA, p, putaddr(lp));
00497 else
00498 p = (expptr)putaddr(lp);
00499 return p;
00500
00501 case OPASSIGN:
00502 case OPASSIGNI:
00503 case OPLT:
00504 case OPLE:
00505 case OPGT:
00506 case OPGE:
00507 case OPEQ:
00508 case OPNE:
00509 ;
00510 }
00511
00512 if( ops2[p->exprblock.opcode] <= 0)
00513 badop("putop", p->exprblock.opcode);
00514 lp = p->exprblock.leftp = putx(p->exprblock.leftp);
00515 if (p -> exprblock.rightp) {
00516 tp = p->exprblock.rightp = putx(p->exprblock.rightp);
00517 if (ISCONST(tp) && ISCONST(lp))
00518 p = fold(p);
00519 }
00520 return p;
00521 }
00522
00523 LOCAL expptr
00524 #ifdef KR_headers
00525 putpower(p)
00526 expptr p;
00527 #else
00528 putpower(expptr p)
00529 #endif
00530 {
00531 expptr base;
00532 Addrp t1, t2;
00533 ftnint k;
00534 int type;
00535 char buf[80];
00536
00537 if(!ISICON(p->exprblock.rightp) ||
00538 (k = p->exprblock.rightp->constblock.Const.ci)<2)
00539 Fatal("putpower: bad call");
00540 base = p->exprblock.leftp;
00541 type = base->headblock.vtype;
00542 t1 = mktmp(type, ENULL);
00543 t2 = NULL;
00544
00545 free ((charptr) p);
00546 p = putassign (cpexpr((expptr) t1), base);
00547
00548 sprintf (buf, "Computing %ld%s power", k,
00549 k == 2 ? "nd" : k == 3 ? "rd" : "th");
00550 p1_comment (buf);
00551
00552 for( ; (k&1)==0 && k>2 ; k>>=1 )
00553 {
00554 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
00555 }
00556
00557 if(k == 2) {
00558
00559
00560 putout (p);
00561 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
00562 } else {
00563 t2 = mktmp(type, ENULL);
00564 p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
00565 cpexpr((expptr)t1)));
00566
00567 for(k>>=1 ; k>1 ; k>>=1)
00568 {
00569 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
00570 if(k & 1)
00571 {
00572 p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
00573 }
00574 }
00575
00576 putout (p);
00577 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
00578 mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
00579 }
00580 frexpr((expptr)t1);
00581 if(t2)
00582 frexpr((expptr)t2);
00583 return p;
00584 }
00585
00586
00587
00588
00589 LOCAL Addrp
00590 #ifdef KR_headers
00591 intdouble(p)
00592 Addrp p;
00593 #else
00594 intdouble(Addrp p)
00595 #endif
00596 {
00597 register Addrp t;
00598
00599 t = mktmp(TYDREAL, ENULL);
00600 putout (putassign(cpexpr((expptr)t), (expptr)p));
00601 return(t);
00602 }
00603
00604
00605
00606
00607
00608
00609
00610 LOCAL Addrp
00611 #ifdef KR_headers
00612 putcxeq(p)
00613 register expptr p;
00614 #else
00615 putcxeq(register expptr p)
00616 #endif
00617 {
00618 register Addrp lp, rp;
00619 expptr code;
00620
00621 if(p->tag != TEXPR)
00622 badtag("putcxeq", p->tag);
00623
00624 lp = putcx1(p->exprblock.leftp);
00625 rp = putcx1(p->exprblock.rightp);
00626 code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
00627
00628 if( ISCOMPLEX(p->exprblock.vtype) )
00629 {
00630 code = mkexpr (OPCOMMA, code, putassign
00631 (imagpart(lp), imagpart(rp)));
00632 }
00633 putout (code);
00634 frexpr((expptr)rp);
00635 free ((charptr) p);
00636 return lp;
00637 }
00638
00639
00640
00641
00642
00643
00644 expptr
00645 #ifdef KR_headers
00646 putcxop(p)
00647 expptr p;
00648 #else
00649 putcxop(expptr p)
00650 #endif
00651 {
00652 return (expptr)putaddr((expptr)putcx1(p));
00653 }
00654
00655 #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
00656
00657 LOCAL Addrp
00658 #ifdef KR_headers
00659 putcx1(p)
00660 register expptr p;
00661 #else
00662 putcx1(register expptr p)
00663 #endif
00664 {
00665 expptr q;
00666 Addrp lp, rp;
00667 register Addrp resp;
00668 int opcode;
00669 int ltype, rtype;
00670 long ts, tskludge;
00671
00672 if(p == NULL)
00673 return(NULL);
00674
00675 switch(p->tag)
00676 {
00677 case TCONST:
00678 if( ISCOMPLEX(p->constblock.vtype) )
00679 p = (expptr) putconst((Constp)p);
00680 return( (Addrp) p );
00681
00682 case TADDR:
00683 resp = &p->addrblock;
00684 if (addressable(p))
00685 return (Addrp) p;
00686 ts = tskludge = 0;
00687 if (q = resp->memoffset) {
00688 if (resp->uname_tag == UNAM_REF) {
00689 q = cpexpr((tagptr)resp);
00690 q->addrblock.vtype = tyint;
00691 q->addrblock.cmplx_sub = 1;
00692 p->addrblock.skip_offset = 1;
00693 resp->user.name->vsubscrused = 1;
00694 resp->uname_tag = UNAM_NAME;
00695 tskludge = typesize[resp->vtype]
00696 * (resp->Field ? 2 : 1);
00697 }
00698 else if (resp->isarray
00699 && resp->vtype != TYCHAR) {
00700 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
00701 && resp->uname_tag == UNAM_NAME)
00702 q = mkexpr(OPMINUS, q,
00703 mkintcon(resp->user.name->voffset));
00704 ts = typesize[resp->vtype]
00705 * (resp->Field ? 2 : 1);
00706 q = resp->memoffset = mkexpr(OPSLASH, q,
00707 ICON(ts));
00708 }
00709 }
00710 resp = mktmp(tyint, ENULL);
00711 putout(putassign(cpexpr((expptr)resp), q));
00712 p->addrblock.memoffset = tskludge
00713 ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
00714 : (expptr)resp;
00715 if (ts) {
00716 resp = &p->addrblock;
00717 q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
00718 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
00719 && resp->uname_tag == UNAM_NAME)
00720 q = mkexpr(OPPLUS, q,
00721 mkintcon(resp->user.name->voffset));
00722 resp->memoffset = q;
00723 }
00724 return (Addrp) p;
00725
00726 case TEXPR:
00727 if( ISCOMPLEX(p->exprblock.vtype) )
00728 break;
00729 resp = mktmp(p->exprblock.vtype, ENULL);
00730
00731 putout (putassign( cpexpr((expptr)resp), p));
00732 return(resp);
00733
00734 case TERROR:
00735 return NULL;
00736
00737 default:
00738 badtag("putcx1", p->tag);
00739 }
00740
00741 opcode = p->exprblock.opcode;
00742 if(opcode==OPCALL || opcode==OPCCALL)
00743 {
00744 Addrp t;
00745 p = putcall(p, &t);
00746 putout(p);
00747 return t;
00748 }
00749 else if(opcode == OPASSIGN)
00750 {
00751 return putcxeq (p);
00752 }
00753
00754
00755
00756 resp = mktmp(p->exprblock.vtype, ENULL);
00757 if(lp = putcx1(p->exprblock.leftp) )
00758 ltype = lp->vtype;
00759 if(rp = putcx1(p->exprblock.rightp) )
00760 rtype = rp->vtype;
00761
00762 switch(opcode)
00763 {
00764 case OPCOMMA:
00765 frexpr((expptr)resp);
00766 resp = rp;
00767 rp = NULL;
00768 break;
00769
00770 case OPNEG:
00771 case OPNEG1:
00772 putout (PAIR (
00773 putassign( (expptr)realpart(resp),
00774 mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
00775 putassign( imagpart(resp),
00776 mkexpr(OPNEG, imagpart(lp), ENULL))));
00777 break;
00778
00779 case OPPLUS:
00780 case OPMINUS: { expptr r;
00781 r = putassign( (expptr)realpart(resp),
00782 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
00783 if(rtype < TYCOMPLEX)
00784 q = putassign( imagpart(resp), imagpart(lp) );
00785 else if(ltype < TYCOMPLEX)
00786 {
00787 if(opcode == OPPLUS)
00788 q = putassign( imagpart(resp), imagpart(rp) );
00789 else
00790 q = putassign( imagpart(resp),
00791 mkexpr(OPNEG, imagpart(rp), ENULL) );
00792 }
00793 else
00794 q = putassign( imagpart(resp),
00795 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
00796 r = PAIR (r, q);
00797 putout (r);
00798 break;
00799 }
00800 case OPSTAR:
00801 if(ltype < TYCOMPLEX)
00802 {
00803 if( ISINT(ltype) )
00804 lp = intdouble(lp);
00805 putout (PAIR (
00806 putassign( (expptr)realpart(resp),
00807 mkexpr(OPSTAR, cpexpr((expptr)lp),
00808 (expptr)realpart(rp))),
00809 putassign( imagpart(resp),
00810 mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
00811 }
00812 else if(rtype < TYCOMPLEX)
00813 {
00814 if( ISINT(rtype) )
00815 rp = intdouble(rp);
00816 putout (PAIR (
00817 putassign( (expptr)realpart(resp),
00818 mkexpr(OPSTAR, cpexpr((expptr)rp),
00819 (expptr)realpart(lp))),
00820 putassign( imagpart(resp),
00821 mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
00822 }
00823 else {
00824 putout (PAIR (
00825 putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
00826 mkexpr(OPSTAR, (expptr)realpart(lp),
00827 (expptr)realpart(rp)),
00828 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
00829 putassign( imagpart(resp), mkexpr(OPPLUS,
00830 mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
00831 mkexpr(OPSTAR, imagpart(lp),
00832 (expptr)realpart(rp))))));
00833 }
00834 break;
00835
00836 case OPSLASH:
00837
00838
00839
00840 if( ISINT(rtype) )
00841 rp = intdouble(rp);
00842 putout (PAIR (
00843 putassign( (expptr)realpart(resp),
00844 mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
00845 putassign( imagpart(resp),
00846 mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
00847 break;
00848
00849 case OPCONV:
00850 if (!lp)
00851 break;
00852 if(ISCOMPLEX(lp->vtype) )
00853 q = imagpart(lp);
00854 else if(rp != NULL)
00855 q = (expptr) realpart(rp);
00856 else
00857 q = mkrealcon(TYDREAL, "0");
00858 putout (PAIR (
00859 putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
00860 putassign( imagpart(resp), q)));
00861 break;
00862
00863 default:
00864 badop("putcx1", opcode);
00865 }
00866
00867 frexpr((expptr)lp);
00868 frexpr((expptr)rp);
00869 free( (charptr) p );
00870 return(resp);
00871 }
00872
00873
00874
00875
00876
00877
00878
00879 LOCAL expptr
00880 #ifdef KR_headers
00881 putcxcmp(p)
00882 register expptr p;
00883 #else
00884 putcxcmp(register expptr p)
00885 #endif
00886 {
00887 int opcode;
00888 register Addrp lp, rp;
00889 expptr q;
00890
00891 if(p->tag != TEXPR)
00892 badtag("putcxcmp", p->tag);
00893
00894 opcode = p->exprblock.opcode;
00895 lp = putcx1(p->exprblock.leftp);
00896 rp = putcx1(p->exprblock.rightp);
00897
00898 q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
00899 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
00900 mkexpr(opcode, imagpart(lp), imagpart(rp)) );
00901
00902 free( (charptr) lp);
00903 free( (charptr) rp);
00904 free( (charptr) p );
00905 if (ISCONST(q))
00906 return q;
00907 return putx( fixexpr((Exprp)q) );
00908 }
00909
00910
00911
00912 LOCAL Addrp
00913 #ifdef KR_headers
00914 putch1(p)
00915 register expptr p;
00916 #else
00917 putch1(register expptr p)
00918 #endif
00919 {
00920 Addrp t;
00921 expptr e;
00922
00923 switch(p->tag)
00924 {
00925 case TCONST:
00926 return( putconst((Constp)p) );
00927
00928 case TADDR:
00929 return( (Addrp) p );
00930
00931 case TEXPR:
00932 switch(p->exprblock.opcode)
00933 {
00934 expptr q;
00935
00936 case OPCALL:
00937 case OPCCALL:
00938
00939 p = putcall(p, &t);
00940 putout (p);
00941 break;
00942
00943 case OPCONCAT:
00944 t = mktmp(TYCHAR, ICON(lencat(p)));
00945 q = (expptr) cpexpr(p->headblock.vleng);
00946 p = putcat( cpexpr((expptr)t), p );
00947
00948 frexpr(t->vleng);
00949 t->vleng = q;
00950 putout (p);
00951 break;
00952
00953 case OPCONV:
00954 if(!ISICON(p->exprblock.vleng)
00955 || p->exprblock.vleng->constblock.Const.ci!=1
00956 || ! INT(p->exprblock.leftp->headblock.vtype) )
00957 Fatal("putch1: bad character conversion");
00958 t = mktmp(TYCHAR, ICON(1));
00959 e = mkexpr(OPCONV, (expptr)t, ENULL);
00960 e->headblock.vtype = TYCHAR;
00961 p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
00962 putout (p);
00963 break;
00964 default:
00965 badop("putch1", p->exprblock.opcode);
00966 }
00967 return(t);
00968
00969 default:
00970 badtag("putch1", p->tag);
00971 }
00972 return 0;
00973 }
00974
00975
00976
00977
00978
00979 Addrp
00980 #ifdef KR_headers
00981 putchop(p)
00982 expptr p;
00983 #else
00984 putchop(expptr p)
00985 #endif
00986 {
00987 p = putaddr((expptr)putch1(p));
00988 return (Addrp)p;
00989 }
00990
00991
00992
00993
00994 LOCAL expptr
00995 #ifdef KR_headers
00996 putcheq(p)
00997 register expptr p;
00998 #else
00999 putcheq(register expptr p)
01000 #endif
01001 {
01002 expptr lp, rp;
01003 int nbad;
01004
01005 if(p->tag != TEXPR)
01006 badtag("putcheq", p->tag);
01007
01008 lp = p->exprblock.leftp;
01009 rp = p->exprblock.rightp;
01010 frexpr(p->exprblock.vleng);
01011 free( (charptr) p );
01012
01013
01014
01015
01016 nbad = badchleng(lp) + badchleng(rp);
01017 if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
01018 p = putcat(lp, rp);
01019 else if( !nbad
01020 && ISONE(lp->headblock.vleng)
01021 && ISONE(rp->headblock.vleng) ) {
01022 lp = mkexpr(OPCONV, lp, ENULL);
01023 rp = mkexpr(OPCONV, rp, ENULL);
01024 lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
01025 p = putop(mkexpr(OPASSIGN, lp, rp));
01026 }
01027 else
01028 p = putx( call2(TYSUBR, "s_copy", lp, rp) );
01029 return p;
01030 }
01031
01032
01033
01034
01035 LOCAL expptr
01036 #ifdef KR_headers
01037 putchcmp(p)
01038 register expptr p;
01039 #else
01040 putchcmp(register expptr p)
01041 #endif
01042 {
01043 expptr lp, rp;
01044
01045 if(p->tag != TEXPR)
01046 badtag("putchcmp", p->tag);
01047
01048 lp = p->exprblock.leftp;
01049 rp = p->exprblock.rightp;
01050
01051 if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
01052 lp = mkexpr(OPCONV, lp, ENULL);
01053 rp = mkexpr(OPCONV, rp, ENULL);
01054 lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
01055 }
01056 else {
01057 lp = call2(TYINT,"s_cmp", lp, rp);
01058 rp = ICON(0);
01059 }
01060 p->exprblock.leftp = lp;
01061 p->exprblock.rightp = rp;
01062 p = putop(p);
01063 return p;
01064 }
01065
01066
01067
01068
01069
01070
01071
01072
01073
01074
01075
01076
01077
01078
01079
01080 LOCAL expptr
01081 #ifdef KR_headers
01082 putcat(lhs0, rhs)
01083 expptr lhs0;
01084 register expptr rhs;
01085 #else
01086 putcat(expptr lhs0, register expptr rhs)
01087 #endif
01088 {
01089 register Addrp lhs = (Addrp)lhs0;
01090 int n, tyi;
01091 Addrp length_var, string_var;
01092 expptr p;
01093 static char Writing_concatenation[] = "Writing concatenation";
01094
01095
01096
01097 n = ncat(rhs);
01098 length_var = mktmpn(n, tyioint, ENULL);
01099 string_var = mktmpn(n, TYADDR, ENULL);
01100 frtemp((Addrp)cpexpr((expptr)length_var));
01101 frtemp((Addrp)cpexpr((expptr)string_var));
01102
01103
01104
01105 n = 0;
01106
01107
01108 p1_comment(Writing_concatenation);
01109 putct1(rhs, length_var, string_var, &n);
01110
01111
01112
01113 tyi = tyint;
01114 tyint = tyioint;
01115 p = putx (call4 (TYSUBR, "s_cat",
01116 (expptr)lhs,
01117 (expptr)string_var,
01118 (expptr)length_var,
01119 (expptr)putconst((Constp)ICON(n))));
01120 tyint = tyi;
01121
01122 return p;
01123 }
01124
01125
01126
01127
01128
01129 LOCAL void
01130 #ifdef KR_headers
01131 putct1(q, length_var, string_var, ip)
01132 register expptr q;
01133 register Addrp length_var;
01134 register Addrp string_var;
01135 int *ip;
01136 #else
01137 putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
01138 #endif
01139 {
01140 int i;
01141 Addrp length_copy, string_copy;
01142 expptr e;
01143 extern int szleng;
01144
01145 if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
01146 {
01147 putct1(q->exprblock.leftp, length_var, string_var,
01148 ip);
01149 putct1(q->exprblock.rightp, length_var, string_var,
01150 ip);
01151 frexpr (q -> exprblock.vleng);
01152 free ((charptr) q);
01153 }
01154 else
01155 {
01156 i = (*ip)++;
01157 e = cpexpr(q->headblock.vleng);
01158 if (!e)
01159 return;
01160 length_copy = (Addrp) cpexpr((expptr)length_var);
01161 length_copy->memoffset =
01162 mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
01163 string_copy = (Addrp) cpexpr((expptr)string_var);
01164 string_copy->memoffset =
01165 mkexpr(OPPLUS, string_copy->memoffset,
01166 ICON(i*typesize[TYADDR]));
01167 putout (PAIR (putassign((expptr)length_copy, e),
01168 putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
01169 }
01170 }
01171
01172
01173
01174 LOCAL expptr
01175 #ifdef KR_headers
01176 putaddr(p0)
01177 expptr p0;
01178 #else
01179 putaddr(expptr p0)
01180 #endif
01181 {
01182 register Addrp p;
01183 chainp cp;
01184
01185 if (!(p = (Addrp)p0))
01186 return ENULL;
01187
01188 if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
01189 {
01190 frexpr((expptr)p);
01191 return ENULL;
01192 }
01193 if (p->isarray && p->memoffset)
01194 if (p->uname_tag == UNAM_REF) {
01195 cp = p->memoffset->listblock.listp;
01196 for(; cp; cp = cp->nextp)
01197 cp->datap = (char *)fixtype((tagptr)cp->datap);
01198 }
01199 else
01200 p->memoffset = putx(p->memoffset);
01201 return (expptr) p;
01202 }
01203
01204 LOCAL expptr
01205 #ifdef KR_headers
01206 addrfix(e)
01207 expptr e;
01208 #else
01209 addrfix(expptr e)
01210 #endif
01211
01212 {
01213 return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
01214 }
01215
01216 LOCAL int
01217 #ifdef KR_headers
01218 typekludge(ccall, q, at, j)
01219 int ccall;
01220 register expptr q;
01221 Atype *at;
01222 int j;
01223 #else
01224 typekludge(int ccall, register expptr q, Atype *at, int j)
01225 #endif
01226
01227 {
01228 register int i, k;
01229 extern int iocalladdr;
01230 register Namep np;
01231
01232
01233
01234
01235
01236
01237
01238
01239
01240
01241 k = q->headblock.vtype;
01242 if (ccall) {
01243 if (k == TYREAL)
01244 k = TYDREAL;
01245 return k + 100;
01246 }
01247 if (k == TYADDR)
01248 return iocalladdr;
01249 i = q->tag;
01250 if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
01251 || (i == TADDR && q->addrblock.charleng)
01252 || i == TCONST)
01253 k = TYFTNLEN + 100;
01254 else if (i == TADDR)
01255 switch(q->addrblock.vclass) {
01256 case CLPROC:
01257 if (q->addrblock.uname_tag != UNAM_NAME)
01258 k += 200;
01259 else if ((np = q->addrblock.user.name)->vprocclass
01260 != PTHISPROC) {
01261 if (k && !np->vimpltype)
01262 k += 200;
01263 else {
01264 if (j > 200 && infertypes && j < 300) {
01265 k = j;
01266 inferdcl(np, j-200);
01267 }
01268 else k = (np->vstg == STGEXT
01269 ? extsymtab[np->vardesc.varno].extype
01270 : 0) + 200;
01271 at->cp = mkchain((char *)np, at->cp);
01272 }
01273 }
01274 else if (k == TYSUBR)
01275 k += 200;
01276 break;
01277
01278 case CLUNKNOWN:
01279 if (q->addrblock.vstg == STGARG
01280 && q->addrblock.uname_tag == UNAM_NAME) {
01281 k += 400;
01282 at->cp = mkchain((char *)q->addrblock.user.name,
01283 at->cp);
01284 }
01285 }
01286 else if (i == TNAME && q->nameblock.vstg == STGARG) {
01287 np = &q->nameblock;
01288 switch(np->vclass) {
01289 case CLPROC:
01290 if (!np->vimpltype)
01291 k += 200;
01292 else if (j <= 200 || !infertypes || j >= 300)
01293 k += 300;
01294 else {
01295 k = j;
01296 inferdcl(np, j-200);
01297 }
01298 goto add2chain;
01299
01300 case CLUNKNOWN:
01301
01302 if (np->vimpltype && j && infertypes
01303 && j < 300) {
01304 inferdcl(np, j % 100);
01305 k = j;
01306 }
01307 else
01308 k += 400;
01309
01310
01311
01312
01313 add2chain:
01314 at->cp = mkchain((char *)np, at->cp);
01315 }
01316 }
01317 return k;
01318 }
01319
01320 char *
01321 #ifdef KR_headers
01322 Argtype(k, buf)
01323 int k;
01324 char *buf;
01325 #else
01326 Argtype(int k, char *buf)
01327 #endif
01328 {
01329 if (k < 100) {
01330 sprintf(buf, "%s variable", ftn_types[k]);
01331 return buf;
01332 }
01333 if (k < 200) {
01334 k -= 100;
01335 return ftn_types[k];
01336 }
01337 if (k < 300) {
01338 k -= 200;
01339 if (k == TYSUBR)
01340 return ftn_types[TYSUBR];
01341 sprintf(buf, "%s function", ftn_types[k]);
01342 return buf;
01343 }
01344 if (k < 400)
01345 return "external argument";
01346 k -= 400;
01347 sprintf(buf, "%s argument", ftn_types[k]);
01348 return buf;
01349 }
01350
01351 static void
01352 #ifdef KR_headers
01353 atype_squawk(at, msg)
01354 Argtypes *at;
01355 char *msg;
01356 #else
01357 atype_squawk(Argtypes *at, char *msg)
01358 #endif
01359 {
01360 register Atype *a, *ae;
01361 warn(msg);
01362 for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
01363 frchain(&a->cp);
01364 at->nargs = -1;
01365 if (at->changes & 2 && !at->defined)
01366 proc_protochanges++;
01367 }
01368
01369 static char inconsist[] = "inconsistent calling sequences for ";
01370
01371 void
01372 #ifdef KR_headers
01373 bad_atypes(at, fname, i, j, k, here, prev)
01374 Argtypes *at;
01375 char *fname;
01376 int i;
01377 int j;
01378 int k;
01379 char *here;
01380 char *prev;
01381 #else
01382 bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
01383 #endif
01384 {
01385 char buf[208], buf1[32], buf2[32];
01386
01387 sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
01388 inconsist, fname, i, here, Argtype(k, buf1),
01389 prev, Argtype(j, buf2));
01390 atype_squawk(at, buf);
01391 }
01392
01393 int
01394 #ifdef KR_headers
01395 type_fixup(at, a, k)
01396 Argtypes *at;
01397 Atype *a;
01398 int k;
01399 #else
01400 type_fixup(Argtypes *at, Atype *a, int k)
01401 #endif
01402 {
01403 register struct Entrypoint *ep;
01404 if (!infertypes)
01405 return 0;
01406 for(ep = entries; ep; ep = ep->entnextp)
01407 if (ep->entryname && at == ep->entryname->arginfo) {
01408 a->type = k % 100;
01409 return proc_argchanges = 1;
01410 }
01411 return 0;
01412 }
01413
01414
01415 void
01416 #ifdef KR_headers
01417 save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
01418 chainp arglist;
01419 Argtypes **at0;
01420 Argtypes **at1;
01421 int ccall;
01422 char *fname;
01423 int stg;
01424 int nchargs;
01425 int type;
01426 int zap;
01427 #else
01428 save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
01429 #endif
01430 {
01431 Argtypes *at;
01432 chainp cp;
01433 int i, i0, j, k, nargs, nbad, *t, *te;
01434 Atype *atypes;
01435 expptr q;
01436 char buf[208], buf1[32], buf2[32];
01437 static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
01438 static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
01439 #ifdef TYQUAD
01440 0,
01441 #endif
01442 initargs, initargs+1,0,0,0,initargs+2};
01443
01444 i0 = init_ac[type];
01445 t = init_ap[type];
01446 te = t + i0;
01447 if (at = *at0) {
01448 *at1 = at;
01449 nargs = at->nargs;
01450 if (nargs < 0 && type && at->changes & 2 && !at->defined)
01451 --proc_protochanges;
01452 if (at->dnargs >= 0 && zap != 2)
01453 type = 0;
01454 if (nargs < 0) {
01455 if (type)
01456 goto newlist;
01457 return;
01458 }
01459 atypes = at->atypes;
01460 i = nchargs;
01461 for(nbad = 0; t < te; atypes++) {
01462 if (++i > nargs) {
01463 toomany:
01464 i = nchargs + i0;
01465 for(cp = arglist; cp; cp = cp->nextp)
01466 i++;
01467 toofew:
01468 switch(zap) {
01469 case 2: zap = 6; break;
01470 case 1: if (at->defined & 4)
01471 return;
01472 }
01473 sprintf(buf,
01474 "%s%.90s:\n\there %d, previously %d args and string lengths.",
01475 inconsist, fname, i, nargs);
01476 atype_squawk(at, buf);
01477 if (type) {
01478 t = init_ap[type];
01479 goto newlist;
01480 }
01481 return;
01482 }
01483 j = atypes->type;
01484 k = *t++;
01485 if (j != k && j-400 != k) {
01486 cp = 0;
01487 goto badtypes;
01488 }
01489 }
01490 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
01491 if (++i > nargs)
01492 goto toomany;
01493 j = atypes->type;
01494 if (!(q = (expptr)cp->datap))
01495 continue;
01496 k = typekludge(ccall, q, atypes, j);
01497 if (k >= 300 || k == j)
01498 continue;
01499 if (j >= 300) {
01500 if (k >= 200) {
01501 if (k == TYUNKNOWN + 200)
01502 continue;
01503 if (j % 100 != k - 200
01504 && k != TYSUBR + 200
01505 && j != TYUNKNOWN + 300
01506 && !type_fixup(at,atypes,k))
01507 goto badtypes;
01508 }
01509 else if (j % 100 % TYSUBR != k % TYSUBR
01510 && !type_fixup(at,atypes,k))
01511 goto badtypes;
01512 }
01513 else if (k < 200 || j < 200)
01514 if (j) {
01515 if (k == TYUNKNOWN
01516 && q->tag == TNAME
01517 && q->nameblock.vinfproc) {
01518 q->nameblock.vdcldone = 0;
01519 impldcl((Namep)q);
01520 }
01521 goto badtypes;
01522 }
01523 else ;
01524 else if (k == TYUNKNOWN+200)
01525 continue;
01526 else if (j != TYUNKNOWN+200)
01527 {
01528 badtypes:
01529 if (++nbad == 1)
01530 bad_atypes(at, fname, i - nchargs,
01531 j, k, "here ", ", previously");
01532 else
01533 fprintf(stderr,
01534 "\targ %d: here %s, previously %s.\n",
01535 i - nchargs, Argtype(k,buf1),
01536 Argtype(j,buf2));
01537 if (!cp)
01538 break;
01539 continue;
01540 }
01541
01542
01543
01544
01545
01546
01547
01548
01549
01550
01551 if (!nbad) {
01552 atypes->type = k;
01553 at->changes |= 1;
01554 }
01555 }
01556 if (i < nargs)
01557 goto toofew;
01558 if (nbad) {
01559 if (type) {
01560
01561 t = init_ap[type];
01562 te = t + i0;
01563 proc_argchanges = 1;
01564 goto newlist;
01565 }
01566 return;
01567 }
01568 if (zap == 1 && (at->changes & 5) != 5)
01569 at->changes = 0;
01570 return;
01571 }
01572 newlist:
01573 i = i0 + nchargs;
01574 for(cp = arglist; cp; cp = cp->nextp)
01575 i++;
01576 k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
01577 *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
01578 : (Argtypes *) mem(k,1);
01579 at->dnargs = at->nargs = i;
01580 at->defined = zap & 6;
01581 at->changes = type ? 0 : 4;
01582 atypes = at->atypes;
01583 for(; t < te; atypes++) {
01584 atypes->type = *t++;
01585 atypes->cp = 0;
01586 }
01587 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
01588 atypes->cp = 0;
01589 atypes->type = (q = (expptr)cp->datap)
01590 ? typekludge(ccall, q, atypes, 0)
01591 : 0;
01592 }
01593 for(; --nchargs >= 0; atypes++) {
01594 atypes->type = TYFTNLEN + 100;
01595 atypes->cp = 0;
01596 }
01597 }
01598
01599 static char*
01600 #ifdef KR_headers
01601 get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1;
01602 #else
01603 get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1)
01604 #endif
01605 {
01606 Addrp a;
01607 Argtypes **at0, **at1;
01608 Namep np;
01609 expptr rp;
01610 Extsym *e;
01611 char *fname;
01612
01613 a = (Addrp)p->leftp;
01614 switch(a->vstg) {
01615 case STGEXT:
01616 switch(a->uname_tag) {
01617 case UNAM_EXTERN:
01618 e = extsymtab + a->memno;
01619 at0 = at1 = &e->arginfo;
01620 fname = e->fextname;
01621 break;
01622 case UNAM_NAME:
01623 np = a->user.name;
01624 at0 = &extsymtab[np->vardesc.varno].arginfo;
01625 at1 = &np->arginfo;
01626 fname = np->fvarname;
01627 break;
01628 default:
01629 goto bug;
01630 }
01631 break;
01632 case STGARG:
01633 if (a->uname_tag != UNAM_NAME)
01634 goto bug;
01635 np = a->user.name;
01636 at0 = at1 = &np->arginfo;
01637 fname = np->fvarname;
01638 break;
01639 default:
01640 bug:
01641 Fatal("Confusion in saveargtypes");
01642 }
01643 *pat0 = at0;
01644 *pat1 = at1;
01645 return fname;
01646 }
01647
01648 void
01649 #ifdef KR_headers
01650 saveargtypes(p)
01651 register Exprp p;
01652 #else
01653 saveargtypes(register Exprp p)
01654 #endif
01655
01656 {
01657 Argtypes **at0, **at1;
01658 chainp arglist;
01659 expptr rp;
01660 char *fname;
01661
01662 fname = get_argtypes(p, &at0, &at1);
01663 rp = p->rightp;
01664 arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
01665 save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
01666 fname, p->leftp->addrblock.vstg, 0, 0, 0);
01667 }
01668
01669
01670
01671
01672
01673
01674 LOCAL expptr
01675 #ifdef KR_headers
01676 putcall(p0, temp)
01677 expptr p0;
01678 Addrp *temp;
01679 #else
01680 putcall(expptr p0, Addrp *temp)
01681 #endif
01682 {
01683 register Exprp p = (Exprp)p0;
01684 chainp arglist;
01685 chainp charsp;
01686
01687
01688
01689 chainp cp;
01690 register expptr q;
01691 Addrp fval;
01692 int type;
01693
01694 int byvalue;
01695
01696
01697 char *s;
01698 Argtypes *at, **at0, **at1;
01699 Atype *At, *Ate;
01700
01701 type = p -> vtype;
01702 charsp = NULL;
01703 byvalue = (p->opcode == OPCCALL);
01704
01705
01706
01707 if (p == (Exprp) NULL)
01708 err ("putcall: NULL call expression");
01709 else if (p -> tag != TEXPR)
01710 erri ("putcall: expected TEXPR, got '%d'", p -> tag);
01711
01712
01713
01714 if(p->rightp && p -> rightp -> tag == TLIST)
01715 arglist = p->rightp->listblock.listp;
01716 else
01717 arglist = NULL;
01718
01719
01720
01721
01722 if (!byvalue) {
01723 get_argtypes(p, &at0, &at1);
01724 At = Ate = 0;
01725 if ((at = *at0) && at->nargs >= 0) {
01726 At = at->atypes;
01727 Ate = At + at->nargs;
01728 At += init_ac[type];
01729 }
01730 for(cp = arglist ; cp ; cp = cp->nextp) {
01731 q = (expptr) cp->datap;
01732 if( ISCONST(q) ) {
01733
01734
01735
01736
01737 q = (expptr) putconst((Constp)q);
01738 cp->datap = (char *) q;
01739 }
01740
01741
01742
01743
01744 if( ISCHAR(q) &&
01745 (q->headblock.vclass != CLPROC
01746 || q->headblock.vstg == STGARG
01747 && q->tag == TADDR
01748 && q->addrblock.uname_tag == UNAM_NAME
01749 && q->addrblock.user.name->vprocclass == PTHISPROC)
01750 && (!At || At->type % 100 % TYSUBR == TYCHAR))
01751 {
01752 p0 = cpexpr(q->headblock.vleng);
01753 charsp = mkchain((char *)p0, charsp);
01754 if (q->headblock.vclass == CLUNKNOWN
01755 && q->headblock.vstg == STGARG)
01756 q->addrblock.user.name->vpassed = 1;
01757 else if (q->tag == TADDR
01758 && q->addrblock.uname_tag == UNAM_CONST)
01759 p0->constblock.Const.ci
01760 += q->addrblock.user.Const.ccp1.blanks;
01761 }
01762 if (At && ++At == Ate)
01763 At = 0;
01764 }
01765 }
01766 charsp = revchain(charsp);
01767
01768
01769
01770 if(type == TYCHAR)
01771 {
01772 if( ISICON(p->vleng) )
01773 {
01774
01775
01776
01777 fval = mktmp(TYCHAR, p->vleng);
01778 }
01779 else {
01780 err("adjustable character function");
01781 if (temp)
01782 *temp = 0;
01783 return 0;
01784 }
01785 }
01786
01787
01788
01789 else if( ISCOMPLEX(type) )
01790 fval = mktmp(type, ENULL);
01791 else
01792 fval = NULL;
01793
01794
01795
01796 p -> leftp = putx(fixtype(putaddr(p->leftp)));
01797
01798 if(fval)
01799 {
01800 chainp prepend;
01801
01802
01803
01804
01805 prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
01806
01807
01808
01809 if(type==TYCHAR)
01810 {
01811
01812 prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
01813 p->vleng)), arglist);
01814 }
01815 if (!(q = p->rightp))
01816 p->rightp = q = (expptr)mklist(CHNULL);
01817 q->listblock.listp = prepend;
01818 }
01819
01820
01821
01822 for(cp = arglist ; cp ; cp = cp->nextp)
01823 {
01824 q = (expptr) (cp->datap);
01825 if (q == ENULL)
01826 err ("putcall: NULL argument");
01827
01828
01829
01830
01831 if (q -> tag == TCONST && !byvalue)
01832 q = (expptr) putconst ((Constp)q);
01833
01834 if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
01835 if (q->addrblock.parenused
01836 && !byvalue && q->headblock.vtype != TYCHAR)
01837 goto make_copy;
01838 cp->datap = (char *)putaddr(q);
01839 }
01840 else if( ISCOMPLEX(q->headblock.vtype) )
01841 cp -> datap = (char *) putx (fixtype(putcxop(q)));
01842 else if (ISCHAR(q) )
01843 cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
01844 else if( ! ISERROR(q) )
01845 {
01846 if(byvalue) {
01847 if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) {
01848 if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype)
01849 && q->exprblock.leftp->tag == TEXPR)
01850 q->exprblock.leftp = putcxop(q->exprblock.leftp);
01851 else
01852 q->exprblock.leftp = putx(q->exprblock.leftp);
01853 }
01854 else
01855 cp -> datap = (char *) putx(q);
01856 }
01857 else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
01858 cp -> datap = (char *) putx(q);
01859 else {
01860 expptr t, t1;
01861
01862
01863
01864 make_copy:
01865 t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
01866
01867
01868
01869
01870 t1 = putassign( cpexpr(t), q );
01871 if (doin_setbound)
01872 t = mkexpr(OPCOMMA_ARG, t1, t);
01873 else
01874 putout(t1);
01875 cp -> datap = (char *) t;
01876 }
01877 }
01878 }
01879
01880
01881
01882 for(cp = charsp ; cp ; cp = cp->nextp)
01883 cp->datap = (char *)addrfix(putx(
01884
01885 (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
01886 : ICON(0)));
01887
01888
01889
01890 hookup (arglist, charsp);
01891
01892
01893
01894
01895 if (temp) *temp = fval;
01896 else frexpr ((expptr)fval);
01897
01898 saveargtypes(p);
01899
01900 return (expptr) p;
01901 }
01902
01903
01904
01905
01906
01907
01908 LOCAL expptr
01909 #ifdef KR_headers
01910 putmnmx(p)
01911 register expptr p;
01912 #else
01913 putmnmx(register expptr p)
01914 #endif
01915 {
01916 int op, op2, type;
01917 expptr arg, qp, temp;
01918 chainp p0, p1;
01919 Addrp sp, tp;
01920 char comment_buf[80];
01921 char *what;
01922
01923 if(p->tag != TEXPR)
01924 badtag("putmnmx", p->tag);
01925
01926 type = p->exprblock.vtype;
01927 op = p->exprblock.opcode;
01928 op2 = op == OPMIN ? OPMIN2 : OPMAX2;
01929 p0 = p->exprblock.leftp->listblock.listp;
01930 free( (charptr) (p->exprblock.leftp) );
01931 free( (charptr) p );
01932
01933
01934
01935 if (addressable((expptr)p0->datap)
01936 && (p1 = p0->nextp)
01937 && addressable((expptr)p1->datap)
01938 && !p1->nextp) {
01939 if (type == TYREAL && forcedouble)
01940 op2 = op == OPMIN ? OPDMIN : OPDMAX;
01941 p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
01942 mkconv(type, cpexpr((expptr)p1->datap)));
01943 frchain(&p0);
01944 return p;
01945 }
01946
01947
01948
01949 sp = mktmp(type, ENULL);
01950
01951
01952
01953
01954 tp = (Addrp) NULL;
01955 qp = ENULL;
01956 for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
01957 if (!addressable ((expptr) p1 -> datap)) {
01958 tp = mktmp(type, ENULL);
01959 qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
01960 qp = fixexpr((Exprp)qp);
01961 break;
01962 }
01963
01964
01965
01966
01967
01968
01969
01970
01971
01972
01973
01974
01975
01976
01977 if (!doin_setbound) {
01978 switch(op) {
01979 case OPLT:
01980 case OPMIN:
01981 case OPDMIN:
01982 case OPMIN2:
01983 what = "IN";
01984 break;
01985 default:
01986 what = "AX";
01987 }
01988 sprintf (comment_buf, "Computing M%s", what);
01989 p1_comment (comment_buf);
01990 }
01991
01992 p1 = p0->nextp;
01993 temp = (expptr)p0->datap;
01994 if (addressable(temp) && addressable((expptr)p1->datap)) {
01995 p = mkconv(type, cpexpr(temp));
01996 arg = mkconv(type, cpexpr((expptr)p1->datap));
01997 temp = mkexpr(op2, p, arg);
01998 if (!ISCONST(temp))
01999 temp = fixexpr((Exprp)temp);
02000 p1 = p1->nextp;
02001 }
02002 p = putassign (cpexpr((expptr)sp), temp);
02003
02004 for(; p1 ; p1 = p1->nextp)
02005 {
02006 if (addressable ((expptr) p1 -> datap)) {
02007 arg = mkconv(type, cpexpr((expptr)p1->datap));
02008 temp = mkexpr(op2, cpexpr((expptr)sp), arg);
02009 temp = fixexpr((Exprp)temp);
02010 } else {
02011 temp = (expptr) cpexpr (qp);
02012 p = mkexpr(OPCOMMA, p,
02013 putassign(cpexpr((expptr)tp), (expptr)p1->datap));
02014 }
02015
02016 if(p1->nextp)
02017 p = mkexpr(OPCOMMA, p,
02018 putassign(cpexpr((expptr)sp), temp));
02019 else {
02020 if (type == TYREAL && forcedouble)
02021 temp->exprblock.opcode =
02022 op == OPMIN ? OPDMIN : OPDMAX;
02023 if (doin_setbound)
02024 p = mkexpr(OPCOMMA, p, temp);
02025 else {
02026 putout (p);
02027 p = putx(temp);
02028 }
02029 if (qp)
02030 frexpr (qp);
02031 }
02032 }
02033
02034 frchain( &p0 );
02035 return p;
02036 }
02037
02038
02039 void
02040 #ifdef KR_headers
02041 putwhile(p)
02042 expptr p;
02043 #else
02044 putwhile(expptr p)
02045 #endif
02046 {
02047 long where;
02048 int k, n;
02049
02050 if (wh_next >= wh_last)
02051 {
02052 k = wh_last - wh_first;
02053 n = k + 100;
02054 wh_next = mem(n,0);
02055 wh_last = wh_first + n;
02056 if (k)
02057 memcpy(wh_next, wh_first, k);
02058 wh_first = wh_next;
02059 wh_next += k;
02060 wh_last = wh_first + n;
02061 }
02062 p1put(P1_WHILE1START);
02063 where = ftell(pass1_file);
02064 if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
02065 {
02066 if(k != TYERROR)
02067 err("non-logical expression in DO WHILE statement");
02068 }
02069 else {
02070 p = putx(p);
02071 *wh_next++ = ftell(pass1_file) > where;
02072 p1put(P1_WHILE2START);
02073 p1_expr(p);
02074 }
02075 }
