compilers/pcc/pcc-1.0.0/f77/fcom/exec.c

   1 /*      $Id: exec.c,v 1.14 2008/05/11 15:28:03 ragge Exp $      */
   2 /*
   3  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
   4  *
   5  * Redistribution and use in source and binary forms, with or without
   6  * modification, are permitted provided that the following conditions
   7  * are met:
   8  *
   9  * Redistributions of source code and documentation must retain the above
  10  * copyright notice, this list of conditions and the following disclaimer.
  11  * Redistributions in binary form must reproduce the above copyright
  12  * notice, this list of conditions and the following disclaimer in the
  13  * documentation and/or other materials provided with the distribution.
  14  * All advertising materials mentioning features or use of this software
  15  * must display the following acknowledgement:
  16  *      This product includes software developed or owned by Caldera
  17  *      International, Inc.
  18  * Neither the name of Caldera International, Inc. nor the names of other
  19  * contributors may be used to endorse or promote products derived from
  20  * this software without specific prior written permission.
  21  *
  22  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
  23  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
  24  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  25  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  26  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
  27  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  28  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  29  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  30  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
  31  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
  32  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33  * POSSIBILITY OF SUCH DAMAGE.
  34  */
  35 #include <string.h>
  36
  37 #include "defines.h"
  38 #include "defs.h"
  39
  40 /*   Logical IF codes
  41 */
  42 LOCAL void exar2(int, bigptr, int, int);
  43 LOCAL void pushctl(int code);
  44 LOCAL void popctl(void);
  45 LOCAL void poplab(void);
  46 LOCAL void mkstfunct(struct bigblock *, bigptr);
  47
  48 void
  49 exif(p)
  50 bigptr p;
  51 {
  52 pushctl(CTLIF);
  53 ctlstack->elselabel = newlabel();
  54 putif(p, ctlstack->elselabel);
  55 }
  56
  57
  58 void
  59 exelif(p)
  60 bigptr p;
  61 {
  62 if(ctlstack->ctltype == CTLIF)
  63         {
  64         if(ctlstack->endlabel == 0)
  65                 ctlstack->endlabel = newlabel();
  66         putgoto(ctlstack->endlabel);
  67         putlabel(ctlstack->elselabel);
  68         ctlstack->elselabel = newlabel();
  69         putif(p, ctlstack->elselabel);
  70         }
  71
  72 else    execerr("elseif out of place", 0);
  73 }
  74
  75
  76
  77
  78 void
  79 exelse()
  80 {
  81 if(ctlstack->ctltype==CTLIF)
  82         {
  83         if(ctlstack->endlabel == 0)
  84                 ctlstack->endlabel = newlabel();
  85         putgoto( ctlstack->endlabel );
  86         putlabel(ctlstack->elselabel);
  87         ctlstack->ctltype = CTLELSE;
  88         }
  89
  90 else    execerr("else out of place", 0);
  91 }
  92
  93 void
  94 exendif()
  95 {
  96 if(ctlstack->ctltype == CTLIF)
  97         {
  98         putlabel(ctlstack->elselabel);
  99         if(ctlstack->endlabel)
 100                 putlabel(ctlstack->endlabel);
 101         popctl();
 102         }
 103 else if(ctlstack->ctltype == CTLELSE)
 104         {
 105         putlabel(ctlstack->endlabel);
 106         popctl();
 107         }
 108
 109 else    execerr("endif out of place", 0);
 110 }
 111
 112
 113
 114 LOCAL void
 115 pushctl(code)
 116 int code;
 117 {
 118 register int i;
 119
 120 if(++ctlstack >= lastctl)
 121         fatal("nesting too deep");
 122 ctlstack->ctltype = code;
 123 for(i = 0 ; i < 4 ; ++i)
 124         ctlstack->ctlabels[i] = 0;
 125 ++blklevel;
 126 }
 127
 128
 129 LOCAL void
 130 popctl()
 131 {
 132 if( ctlstack-- < ctls )
 133         fatal("control stack empty");
 134 --blklevel;
 135 poplab();
 136 }
 137
 138
 139
 140 LOCAL void
 141 poplab()
 142 {
 143 register struct labelblock  *lp;
 144
 145 for(lp = labeltab ; lp < highlabtab ; ++lp)
 146         if(lp->labdefined)
 147                 {
 148                 /* mark all labels in inner blocks unreachable */
 149                 if(lp->blklevel > blklevel)
 150                         lp->labinacc = YES;
 151                 }
 152         else if(lp->blklevel > blklevel)
 153                 {
 154                 /* move all labels referred to in inner blocks out a level */
 155                 lp->blklevel = blklevel;
 156                 }
 157 }
 158 \f
 159
 160
 161 /*  BRANCHING CODE
 162 */
 163 void
 164 exgoto(lab)
 165 struct labelblock *lab;
 166 {
 167 putgoto(lab->labelno);
 168 }
 169
 170
 171
 172
 173 /*
 174  * Found an assignment expression.
 175  */
 176 void
 177 exequals(struct bigblock *lp, bigptr rp)
 178 {
 179         if(lp->tag != TPRIM) {
 180                 err("assignment to a non-variable");
 181                 frexpr(lp);
 182                 frexpr(rp);
 183         } else if(lp->b_prim.namep->vclass!=CLVAR && lp->b_prim.argsp) {
 184                 if(parstate >= INEXEC)
 185                         err("statement function amid executables");
 186                 else
 187                         mkstfunct(lp, rp);
 188         } else {
 189                 if(parstate < INDATA)
 190                         enddcl();
 191                 puteq(mklhs(lp), rp);
 192         }
 193 }
 194
 195 /*
 196  * Create a statement function; e.g. like "f(i)=i*i"
 197  */
 198 void
 199 mkstfunct(struct bigblock *lp, bigptr rp)
 200 {
 201         struct bigblock *p;
 202         struct bigblock *np;
 203         chainp args;
 204
 205         np = lp->b_prim.namep;
 206         if(np->vclass == CLUNKNOWN)
 207                 np->vclass = CLPROC;
 208         else {
 209                 dclerr("redeclaration of statement function", np);
 210                 return;
 211         }
 212
 213         np->b_name.vprocclass = PSTFUNCT;
 214         np->vstg = STGSTFUNCT;
 215         impldcl(np);
 216         args = (lp->b_prim.argsp ? lp->b_prim.argsp->b_list.listp : NULL);
 217         np->b_name.vardesc.vstfdesc = mkchain((void *)args, (void *)rp);
 218
 219         for( ; args ; args = args->chain.nextp)
 220                 if( (p = args->chain.datap)->tag!=TPRIM ||
 221                     p->b_prim.argsp || p->b_prim.fcharp || p->b_prim.lcharp)
 222                         err("non-variable argument in statement function definition");
 223                 else {
 224                         vardcl(args->chain.datap = p->b_prim.namep);
 225                         ckfree(p);
 226                 }
 227 }
 228
 229
 230 void
 231 excall(name, args, nstars, labels)
 232 struct bigblock *name;
 233 struct bigblock *args;
 234 int nstars;
 235 struct labelblock *labels[ ];
 236 {
 237 register bigptr p;
 238
 239 settype(name, TYSUBR, 0);
 240 p = mkfunct( mkprim(name, args, NULL, NULL) );
 241 p->vtype = p->b_expr.leftp->vtype = TYINT;
 242 if(nstars > 0)
 243         putcmgo(p, nstars, labels);
 244 else putexpr(p);
 245 }
 246
 247
 248 void
 249 exstop(stop, p)
 250 int stop;
 251 register bigptr p;
 252 {
 253 char *q;
 254 int n;
 255
 256 if(p)
 257         {
 258         if( ! ISCONST(p) )
 259                 {
 260                 execerr("pause/stop argument must be constant", 0);
 261                 frexpr(p);
 262                 p = mkstrcon(0, 0);
 263                 }
 264         else if( ISINT(p->vtype) )
 265                 {
 266                 q = convic(p->b_const.fconst.ci);
 267                 n = strlen(q);
 268                 if(n > 0)
 269                         {
 270                         p->b_const.fconst.ccp = copyn(n, q);
 271                         p->vtype = TYCHAR;
 272                         p->vleng = MKICON(n);
 273                         }
 274                 else
 275                         p = mkstrcon(0, 0);
 276                 }
 277         else if(p->vtype != TYCHAR)
 278                 {
 279                 execerr("pause/stop argument must be integer or string", 0);
 280                 p = mkstrcon(0, 0);
 281                 }
 282         }
 283 else    p = mkstrcon(0, 0);
 284
 285 putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
 286 }
 287 \f
 288 /* DO LOOP CODE */
 289
 290 #define DOINIT  par[0]
 291 #define DOLIMIT par[1]
 292 #define DOINCR  par[2]
 293
 294 #define VARSTEP 0
 295 #define POSSTEP 1
 296 #define NEGSTEP 2
 297
 298 void
 299 exdo(range, spec)
 300 int range;
 301 chainp spec;
 302 {
 303 register bigptr p, q;
 304 bigptr q1;
 305 register struct bigblock *np;
 306 chainp cp;
 307 register int i;
 308 int dotype, incsign = 0; /* XXX gcc */
 309 struct bigblock *dovarp, *dostgp;
 310 bigptr par[3];
 311
 312 pushctl(CTLDO);
 313 dorange = ctlstack->dolabel = range;
 314 np = spec->chain.datap;
 315 ctlstack->donamep = NULL;
 316 if(np->b_name.vdovar)
 317         {
 318         err1("nested loops with variable %s", varstr(VL,np->b_name.varname));
 319         ctlstack->donamep = NULL;
 320         return;
 321         }
 322
 323 dovarp = mklhs( mkprim(np, 0,0,0) );
 324 if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
 325         {
 326         err("bad type on do variable");
 327         return;
 328         }
 329 ctlstack->donamep = np;
 330
 331 np->b_name.vdovar = YES;
 332 if( enregister(np) )
 333         {
 334         /* stgp points to a storage version, varp to a register version */
 335         dostgp = dovarp;
 336         dovarp = mklhs( mkprim(np, 0,0,0) );
 337         }
 338 else
 339         dostgp = NULL;
 340 dotype = dovarp->vtype;
 341
 342 for(i=0 , cp = spec->chain.nextp ; cp!=NULL && i<3 ; cp = cp->chain.nextp)
 343         {
 344         p = par[i++] = fixtype(cp->chain.datap);
 345         if( ! ONEOF(p->vtype, MSKINT|MSKREAL) )
 346                 {
 347                 err("bad type on DO parameter");
 348                 return;
 349                 }
 350         }
 351
 352 frchain(&spec);
 353 switch(i)
 354         {
 355         case 0:
 356         case 1:
 357                 err("too few DO parameters");
 358                 return;
 359
 360         default:
 361                 err("too many DO parameters");
 362                 return;
 363
 364         case 2:
 365                 DOINCR = MKICON(1);
 366
 367         case 3:
 368                 break;
 369         }
 370
 371 ctlstack->endlabel = newlabel();
 372 ctlstack->dobodylabel = newlabel();
 373
 374 if( ISCONST(DOLIMIT) )
 375         ctlstack->domax = mkconv(dotype, DOLIMIT);
 376 else
 377         ctlstack->domax = fmktemp(dotype, NULL);
 378
 379 if( ISCONST(DOINCR) )
 380         {
 381         ctlstack->dostep = mkconv(dotype, DOINCR);
 382         if( (incsign = conssgn(ctlstack->dostep)) == 0)
 383                 err("zero DO increment");
 384         ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
 385         }
 386 else
 387         {
 388         ctlstack->dostep = fmktemp(dotype, NULL);
 389         ctlstack->dostepsign = VARSTEP;
 390         ctlstack->doposlabel = newlabel();
 391         ctlstack->doneglabel = newlabel();
 392         }
 393
 394 if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
 395         {
 396         puteq(cpexpr(dovarp), cpexpr(DOINIT));
 397         if( onetripflag )
 398                 frexpr(DOINIT);
 399         else
 400                 {
 401                 q = mkexpr(OPPLUS, MKICON(1),
 402                         mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) );
 403                 if(incsign != conssgn(q))
 404                         {
 405                         warn("DO range never executed");
 406                         putgoto(ctlstack->endlabel);
 407                         }
 408                 frexpr(q);
 409                 }
 410         }
 411 else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
 412         {
 413         if( ISCONST(ctlstack->domax) )
 414                 q = cpexpr(ctlstack->domax);
 415         else
 416                 q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
 417
 418         q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
 419         q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
 420         putif(q, ctlstack->endlabel);
 421         }
 422 else
 423         {
 424         if(! ISCONST(ctlstack->domax) )
 425                 puteq( cpexpr(ctlstack->domax), DOLIMIT);
 426         q = DOINIT;
 427         if( ! onetripflag )
 428                 q = mkexpr(OPMINUS, q,
 429                         mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
 430         puteq( cpexpr(dovarp), q);
 431         if(onetripflag && ctlstack->dostepsign==VARSTEP)
 432                 puteq( cpexpr(ctlstack->dostep), DOINCR);
 433         }
 434
 435 if(ctlstack->dostepsign == VARSTEP)
 436         {
 437         if(onetripflag)
 438                 putgoto(ctlstack->dobodylabel);
 439         else
 440                 putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), MKICON(0)),
 441                         ctlstack->doneglabel );
 442         putlabel(ctlstack->doposlabel);
 443
 444         p = cpexpr(dovarp);
 445         putif( mkexpr(OPLE, mkexpr(OPASSIGN, p,
 446             mkexpr(OPPLUS, cpexpr(dovarp), cpexpr(ctlstack->dostep))),
 447             cpexpr(ctlstack->domax)), ctlstack->endlabel);
 448         }
 449 putlabel(ctlstack->dobodylabel);
 450 if(dostgp)
 451         puteq(dostgp, cpexpr(dovarp));
 452 frexpr(dovarp);
 453 }
 454
 455 /*
 456  * Reached the end of a DO statement.
 457  */
 458 void
 459 enddo(int here)
 460 {
 461         register struct ctlframe *q;
 462         register bigptr t;
 463         struct bigblock *np;
 464         struct bigblock *ap;
 465         register int i;
 466
 467         while(here == dorange) {
 468                 if((np = ctlstack->donamep)) {
 469
 470                         t = mklhs(mkprim(ctlstack->donamep, 0,0 ,0));
 471                         t = mkexpr(OPASSIGN, cpexpr(t),
 472                             mkexpr(OPPLUS, t, cpexpr(ctlstack->dostep)));
 473
 474                         if(ctlstack->dostepsign == VARSTEP) {
 475                                 putif( mkexpr(OPLE, cpexpr(ctlstack->dostep),
 476                                     MKICON(0)), ctlstack->doposlabel);
 477                                 putlabel(ctlstack->doneglabel);
 478                                 putif( mkexpr(OPLT, t, ctlstack->domax),
 479                                     ctlstack->dobodylabel);
 480                         } else
 481                                 putif( mkexpr( (ctlstack->dostepsign==POSSTEP ?
 482                                         OPGT : OPLT), t, ctlstack->domax),
 483                                         ctlstack->dobodylabel);
 484                         putlabel(ctlstack->endlabel);
 485                         if((ap = memversion(np)))
 486                                 puteq(ap, mklhs( mkprim(np,0,0,0)) );
 487                         for(i = 0 ; i < 4 ; ++i)
 488                                 ctlstack->ctlabels[i] = 0;
 489                         deregister(ctlstack->donamep);
 490                         ctlstack->donamep->b_name.vdovar = NO;
 491                         frexpr(ctlstack->dostep);
 492                 }
 493
 494                 popctl();
 495                 dorange = 0;
 496                 for(q = ctlstack ; q>=ctls ; --q)
 497                         if(q->ctltype == CTLDO) {
 498                                 dorange = q->dolabel;
 499                                 break;
 500                         }
 501         }
 502 }
 503
 504 void
 505 exassign(vname, labelval)
 506 struct bigblock *vname;
 507 struct labelblock *labelval;
 508 {
 509 struct bigblock *p;
 510
 511 p = mklhs(mkprim(vname,0,0,0));
 512 if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
 513         err("noninteger assign variable");
 514 else
 515         puteq(p, mkaddcon(labelval->labelno) );
 516 }
 517
 518
 519 void
 520 exarif(expr, neglab, zerlab, poslab)
 521 bigptr expr;
 522 struct labelblock *neglab, *zerlab, *poslab;
 523 {
 524 register int lm, lz, lp;
 525
 526 lm = neglab->labelno;
 527 lz = zerlab->labelno;
 528 lp = poslab->labelno;
 529 expr = fixtype(expr);
 530
 531 if( ! ONEOF(expr->vtype, MSKINT|MSKREAL) )
 532         {
 533         err("invalid type of arithmetic if expression");
 534         frexpr(expr);
 535         }
 536 else
 537         {
 538         if(lm == lz)
 539                 exar2(OPLE, expr, lm, lp);
 540         else if(lm == lp)
 541                 exar2(OPNE, expr, lm, lz);
 542         else if(lz == lp)
 543                 exar2(OPGE, expr, lz, lm);
 544         else
 545                 prarif(expr, lm, lz, lp);
 546         }
 547 }
 548
 549
 550
 551 LOCAL void exar2(op, e, l1, l2)
 552 int op;
 553 bigptr e;
 554 int l1, l2;
 555 {
 556 putif( mkexpr(op, e, MKICON(0)), l2);
 557 putgoto(l1);
 558 }
 559
 560 void
 561 exreturn(p)
 562 register bigptr p;
 563 {
 564 if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
 565         {
 566         err("alternate return in nonsubroutine");
 567         p = 0;
 568         }
 569
 570 if(p)
 571         {
 572         putforce(TYINT, p);
 573         putgoto(retlabel);
 574         }
 575 else
 576         putgoto(procclass==TYSUBR ? ret0label : retlabel);
 577 }
 578
 579
 580 void
 581 exasgoto(labvar)
 582 bigptr labvar;
 583 {
 584 register struct bigblock *p;
 585
 586 p = mklhs( mkprim(labvar,0,0,0) );
 587 if( ! ISINT(p->vtype) )
 588         err("assigned goto variable must be integer");
 589 else
 590         putbranch(p);
 591 }