00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025 #include "p1defs.h"
00026 #include "names.h"
00027
00028 static void exar2 Argdcl((int, tagptr, struct Labelblock*, struct Labelblock*));
00029 static void popctl Argdcl((void));
00030 static void pushctl Argdcl((int));
00031
00032
00033
00034
00035 void
00036 #ifdef KR_headers
00037 exif(p)
00038 expptr p;
00039 #else
00040 exif(expptr p)
00041 #endif
00042 {
00043 pushctl(CTLIF);
00044 putif(p, 0);
00045 }
00046
00047
00048 void
00049 #ifdef KR_headers
00050 exelif(p)
00051 expptr p;
00052 #else
00053 exelif(expptr p)
00054 #endif
00055 {
00056 if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
00057 putif(p, 1);
00058 else
00059 execerr("elseif out of place", CNULL);
00060 }
00061
00062
00063
00064
00065 void
00066 exelse(Void)
00067 {
00068 register struct Ctlframe *c;
00069
00070 for(c = ctlstack; c->ctltype == CTLIFX; --c);
00071 if(c->ctltype == CTLIF) {
00072 p1_else ();
00073 c->ctltype = CTLELSE;
00074 }
00075 else
00076 execerr("else out of place", CNULL);
00077 }
00078
00079 void
00080 #ifdef KR_headers
00081 exendif()
00082 #else
00083 exendif()
00084 #endif
00085 {
00086 while(ctlstack->ctltype == CTLIFX) {
00087 popctl();
00088 p1else_end();
00089 }
00090 if(ctlstack->ctltype == CTLIF) {
00091 popctl();
00092 p1_endif ();
00093 }
00094 else if(ctlstack->ctltype == CTLELSE) {
00095 popctl();
00096 p1else_end ();
00097 }
00098 else
00099 execerr("endif out of place", CNULL);
00100 }
00101
00102
00103 void
00104 #ifdef KR_headers
00105 new_endif()
00106 #else
00107 new_endif()
00108 #endif
00109 {
00110 if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
00111 pushctl(CTLIFX);
00112 else
00113 err("new_endif bug");
00114 }
00115
00116
00117
00118
00119 LOCAL void
00120 #ifdef KR_headers
00121 pushctl(code)
00122 int code;
00123 #else
00124 pushctl(int code)
00125 #endif
00126 {
00127 register int i;
00128
00129 if(++ctlstack >= lastctl)
00130 many("loops or if-then-elses", 'c', maxctl);
00131 ctlstack->ctltype = code;
00132 for(i = 0 ; i < 4 ; ++i)
00133 ctlstack->ctlabels[i] = 0;
00134 ctlstack->dowhile = 0;
00135 ctlstack->domax = ctlstack->dostep = 0;
00136 ++blklevel;
00137 }
00138
00139
00140 LOCAL void
00141 popctl(Void)
00142 {
00143 if( ctlstack-- < ctls )
00144 Fatal("control stack empty");
00145 --blklevel;
00146 }
00147
00148
00149
00150
00151
00152 LOCAL void
00153 poplab(Void)
00154 {
00155 register struct Labelblock *lp;
00156
00157 for(lp = labeltab ; lp < highlabtab ; ++lp)
00158 if(lp->labdefined)
00159 {
00160
00161 if(lp->blklevel > blklevel)
00162 lp->labinacc = YES;
00163 }
00164 else if(lp->blklevel > blklevel)
00165 {
00166
00167 lp->blklevel = blklevel;
00168 }
00169 }
00170
00171
00172
00173
00174 void
00175 #ifdef KR_headers
00176 exgoto(lab)
00177 struct Labelblock *lab;
00178 #else
00179 exgoto(struct Labelblock *lab)
00180 #endif
00181 {
00182 lab->labused = 1;
00183 p1_goto (lab -> stateno);
00184 }
00185
00186
00187
00188
00189
00190
00191 void
00192 #ifdef KR_headers
00193 exequals(lp, rp)
00194 register struct Primblock *lp;
00195 register expptr rp;
00196 #else
00197 exequals(register struct Primblock *lp, register expptr rp)
00198 #endif
00199 {
00200 if(lp->tag != TPRIM)
00201 {
00202 err("assignment to a non-variable");
00203 frexpr((expptr)lp);
00204 frexpr(rp);
00205 }
00206 else if(lp->namep->vclass!=CLVAR && lp->argsp)
00207 {
00208 if(parstate >= INEXEC)
00209 errstr("statement function %.62s amid executables.",
00210 lp->namep->fvarname);
00211 mkstfunct(lp, rp);
00212 }
00213 else if (lp->vtype == TYSUBR)
00214 err("illegal use of subroutine name");
00215 else
00216 {
00217 expptr new_lp, new_rp;
00218
00219 if(parstate < INDATA)
00220 enddcl();
00221 new_lp = mklhs (lp, keepsubs);
00222 new_rp = fixtype (rp);
00223 puteq(new_lp, new_rp);
00224 }
00225 }
00226
00227
00228
00229
00230
00231 long laststfcn = -1, thisstno;
00232 int doing_stmtfcn;
00233
00234 void
00235 #ifdef KR_headers
00236 mkstfunct(lp, rp)
00237 struct Primblock *lp;
00238 expptr rp;
00239 #else
00240 mkstfunct(struct Primblock *lp, expptr rp)
00241 #endif
00242 {
00243 register struct Primblock *p;
00244 register Namep np;
00245 chainp args;
00246
00247 laststfcn = thisstno;
00248 np = lp->namep;
00249 if(np->vclass == CLUNKNOWN)
00250 np->vclass = CLPROC;
00251 else
00252 {
00253 dclerr("redeclaration of statement function", np);
00254 return;
00255 }
00256 np->vprocclass = PSTFUNCT;
00257 np->vstg = STGSTFUNCT;
00258
00259
00260
00261 impldcl(np);
00262 if (np->vtype == TYCHAR && !np->vleng)
00263 err("character statement function with length (*)");
00264 args = (lp->argsp ? lp->argsp->listp : CHNULL);
00265 np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
00266
00267 for(doing_stmtfcn = 1 ; args ; args = args->nextp)
00268
00269
00270
00271
00272 if( ((tagptr)(args->datap))->tag!=TPRIM ||
00273 (p = (struct Primblock *)(args->datap) )->argsp ||
00274 p->fcharp || p->lcharp ) {
00275 err("non-variable argument in statement function definition");
00276 args->datap = 0;
00277 }
00278 else
00279 {
00280
00281
00282
00283 args->datap = (char *)p->namep;
00284 vardcl(p -> namep);
00285 free((char *)p);
00286 }
00287 doing_stmtfcn = 0;
00288 }
00289
00290 static void
00291 #ifdef KR_headers
00292 mixed_type(np)
00293 Namep np;
00294 #else
00295 mixed_type(Namep np)
00296 #endif
00297 {
00298 char buf[128];
00299 sprintf(buf, "%s function %.90s invoked as subroutine",
00300 ftn_types[np->vtype], np->fvarname);
00301 warn(buf);
00302 }
00303
00304 void
00305 #ifdef KR_headers
00306 excall(name, args, nstars, labels)
00307 Namep name;
00308 struct Listblock *args;
00309 int nstars;
00310 struct Labelblock **labels;
00311 #else
00312 excall(Namep name, struct Listblock *args, int nstars, struct Labelblock **labels)
00313 #endif
00314 {
00315 register expptr p;
00316
00317 if (name->vtype != TYSUBR) {
00318 if (name->vinfproc && !name->vcalled) {
00319 name->vtype = TYSUBR;
00320 frexpr(name->vleng);
00321 name->vleng = 0;
00322 }
00323 else if (!name->vimpltype && name->vtype != TYUNKNOWN)
00324 mixed_type(name);
00325 else
00326 settype(name, TYSUBR, (ftnint)0);
00327 }
00328 p = mkfunct( mkprim(name, args, CHNULL) );
00329 if (p->tag == TERROR)
00330 return;
00331
00332
00333
00334 p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
00335
00336
00337
00338 if(nstars > 0)
00339 putcmgo(putx(fixtype(p)), nstars, labels);
00340 else
00341 putexpr(p);
00342 }
00343
00344
00345 void
00346 #ifdef KR_headers
00347 exstop(stop, p)
00348 int stop;
00349 register expptr p;
00350 #else
00351 exstop(int stop, register expptr p)
00352 #endif
00353 {
00354 char *str;
00355 int n;
00356
00357 if(p)
00358 {
00359 if( ! ISCONST(p) )
00360 {
00361 execerr("pause/stop argument must be constant", CNULL);
00362 frexpr(p);
00363 p = mkstrcon(0, CNULL);
00364 }
00365 else if( ISINT(p->constblock.vtype) )
00366 {
00367 str = convic(p->constblock.Const.ci);
00368 n = strlen(str);
00369 if(n > 0)
00370 {
00371 p->constblock.Const.ccp = copyn(n, str);
00372 p->constblock.Const.ccp1.blanks = 0;
00373 p->constblock.vtype = TYCHAR;
00374 p->constblock.vleng = (expptr) ICON(n);
00375 }
00376 else
00377 p = (expptr) mkstrcon(0, CNULL);
00378 }
00379 else if(p->constblock.vtype != TYCHAR)
00380 {
00381 execerr("pause/stop argument must be integer or string", CNULL);
00382 p = (expptr) mkstrcon(0, CNULL);
00383 }
00384 }
00385 else p = (expptr) mkstrcon(0, CNULL);
00386
00387 {
00388 expptr subr_call;
00389
00390 subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
00391 putexpr( subr_call );
00392 }
00393 }
00394
00395
00396
00397 #define DOINIT par[0]
00398 #define DOLIMIT par[1]
00399 #define DOINCR par[2]
00400
00401
00402
00403
00404 #define VARSTEP 0
00405 #define POSSTEP 1
00406 #define NEGSTEP 2
00407
00408
00409
00410
00411
00412
00413 void
00414 #ifdef KR_headers
00415 exdo(range, loopname, spec)
00416 int range;
00417 Namep loopname;
00418 chainp spec;
00419 #else
00420 exdo(int range, Namep loopname, chainp spec)
00421 #endif
00422
00423
00424 {
00425 register expptr p;
00426 register Namep np;
00427 chainp cp;
00428 register int i;
00429 int dotype;
00430 int incsign;
00431
00432 Addrp dovarp;
00433 expptr doinit;
00434 expptr par[3];
00435
00436 expptr init, test, inc;
00437
00438
00439 test = ENULL;
00440
00441 pushctl(CTLDO);
00442 dorange = ctlstack->dolabel = range;
00443 ctlstack->loopname = loopname;
00444
00445
00446
00447 np = (Namep)spec->datap;
00448 ctlstack->donamep = NULL;
00449 if (!np) {
00450 ctlstack->dowhile = 1;
00451 #if 0
00452 if (loopname) {
00453 if (loopname->vtype == TYUNKNOWN) {
00454 loopname->vdcldone = 1;
00455 loopname->vclass = CLLABEL;
00456 loopname->vprocclass = PLABEL;
00457 loopname->vtype = TYLABEL;
00458 }
00459 if (loopname->vtype == TYLABEL)
00460 if (loopname->vdovar)
00461 dclerr("already in use as a loop name",
00462 loopname);
00463 else
00464 loopname->vdovar = 1;
00465 else
00466 dclerr("already declared; cannot be a loop name",
00467 loopname);
00468 }
00469 #endif
00470 putwhile((expptr)spec->nextp);
00471 NOEXT("do while");
00472 spec->nextp = 0;
00473 frchain(&spec);
00474 return;
00475 }
00476 if(np->vdovar)
00477 {
00478 errstr("nested loops with variable %s", np->fvarname);
00479 ctlstack->donamep = NULL;
00480 return;
00481 }
00482
00483
00484
00485 dovarp = mkplace(np);
00486 if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
00487 {
00488 err("bad type on do variable");
00489 return;
00490 }
00491 ctlstack->donamep = np;
00492
00493 np->vdovar = YES;
00494
00495
00496
00497
00498 dotype = dovarp->vtype;
00499
00500
00501
00502
00503 for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
00504 {
00505 p = par[i++] = fixtype((tagptr)cp->datap);
00506 if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
00507 {
00508 err("bad type on DO parameter");
00509 return;
00510 }
00511 }
00512
00513 frchain(&spec);
00514 switch(i)
00515 {
00516 case 0:
00517 case 1:
00518 err("too few DO parameters");
00519 return;
00520
00521 default:
00522 err("too many DO parameters");
00523 return;
00524
00525 case 2:
00526 DOINCR = (expptr) ICON(1);
00527
00528 case 3:
00529 break;
00530 }
00531
00532
00533
00534
00535
00536
00537
00538
00539 ctlstack->doinit = 0;
00540 if (ISCONST (DOINIT) || !onetripflag)
00541
00542
00543 doinit = putx (mkconv (dotype, DOINIT));
00544 else {
00545 if (onetripflag)
00546 ctlstack->doinit = doinit = (expptr) mktmp0(dotype, ENULL);
00547 else
00548 doinit = (expptr) mktmp(dotype, ENULL);
00549 puteq (cpexpr (doinit), DOINIT);
00550 }
00551
00552
00553
00554
00555 if( ISCONST(DOLIMIT) )
00556 ctlstack->domax = mkconv(dotype, DOLIMIT);
00557 else {
00558 ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
00559 puteq (cpexpr (ctlstack -> domax), DOLIMIT);
00560 }
00561
00562
00563
00564
00565 if( ISCONST(DOINCR) )
00566 {
00567 ctlstack->dostep = mkconv(dotype, DOINCR);
00568 if( (incsign = conssgn(ctlstack->dostep)) == 0)
00569 err("zero DO increment");
00570 ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
00571 }
00572 else
00573 {
00574 ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
00575 ctlstack->dostepsign = VARSTEP;
00576 puteq (cpexpr (ctlstack -> dostep), DOINCR);
00577 }
00578
00579
00580
00581
00582 switch (ctlstack -> dostepsign) {
00583 case VARSTEP:
00584 test = mkexpr (OPQUEST, mkexpr (OPLT,
00585 cpexpr (ctlstack -> dostep), ICON(0)),
00586 mkexpr (OPCOLON,
00587 mkexpr (OPGE, cpexpr((expptr)dovarp),
00588 cpexpr (ctlstack -> domax)),
00589 mkexpr (OPLE, cpexpr((expptr)dovarp),
00590 cpexpr (ctlstack -> domax))));
00591 break;
00592 case POSSTEP:
00593 test = mkexpr (OPLE, cpexpr((expptr)dovarp),
00594 cpexpr (ctlstack -> domax));
00595 break;
00596 case NEGSTEP:
00597 test = mkexpr (OPGE, cpexpr((expptr)dovarp),
00598 cpexpr (ctlstack -> domax));
00599 break;
00600 default:
00601 erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign);
00602 break;
00603 }
00604
00605 if (onetripflag)
00606 test = mkexpr (OPOR, test,
00607 mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
00608 init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp),
00609 ctlstack->doinit ? cpexpr(doinit) : doinit);
00610 inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
00611
00612 if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
00613 && ctlstack -> dostepsign != VARSTEP) {
00614 expptr tester;
00615
00616 tester = mkexpr (OPMINUS, cpexpr (doinit),
00617 cpexpr (ctlstack -> domax));
00618 if (incsign == conssgn (tester))
00619 warn ("DO range never executed");
00620 frexpr (tester);
00621 }
00622
00623 p1_for (init, test, inc);
00624 }
00625
00626 void
00627 #ifdef KR_headers
00628 exenddo(np)
00629 Namep np;
00630 #else
00631 exenddo(Namep np)
00632 #endif
00633 {
00634 Namep np1;
00635 int here;
00636 struct Ctlframe *cf;
00637
00638 if( ctlstack < ctls )
00639 goto misplaced;
00640 here = ctlstack->dolabel;
00641 if (ctlstack->ctltype != CTLDO
00642 || here >= 0 && (!thislabel || thislabel->labelno != here)) {
00643 misplaced:
00644 err("misplaced ENDDO");
00645 return;
00646 }
00647 if (np != ctlstack->loopname) {
00648 if (np1 = ctlstack->loopname)
00649 errstr("expected \"enddo %s\"", np1->fvarname);
00650 else
00651 err("expected unnamed ENDDO");
00652 for(cf = ctls; cf < ctlstack; cf++)
00653 if (cf->ctltype == CTLDO && cf->loopname == np) {
00654 here = cf->dolabel;
00655 break;
00656 }
00657 }
00658 enddo(here);
00659 }
00660
00661 void
00662 #ifdef KR_headers
00663 enddo(here)
00664 int here;
00665 #else
00666 enddo(int here)
00667 #endif
00668 {
00669 register struct Ctlframe *q;
00670 Namep np;
00671 Addrp ap;
00672 register int i;
00673 register expptr e;
00674
00675
00676
00677
00678 while(here == dorange)
00679 {
00680 if(np = ctlstack->donamep)
00681 {
00682 p1for_end ();
00683
00684
00685
00686
00687 if(ap = memversion(np))
00688 puteq((expptr)ap, (expptr)mkplace(np));
00689 for(i = 0 ; i < 4 ; ++i)
00690 ctlstack->ctlabels[i] = 0;
00691 deregister(ctlstack->donamep);
00692 ctlstack->donamep->vdovar = NO;
00693
00694
00695 if (e = ctlstack->dostep)
00696 if (e->tag == TADDR && e->addrblock.istemp)
00697 frtemp((Addrp)e);
00698 else
00699 frexpr(e);
00700 if (e = ctlstack->domax)
00701 if (e->tag == TADDR && e->addrblock.istemp)
00702 frtemp((Addrp)e);
00703 else
00704 frexpr(e);
00705 if (e = ctlstack->doinit)
00706 frtemp((Addrp)e);
00707 }
00708 else if (ctlstack->dowhile)
00709 p1for_end ();
00710
00711
00712
00713
00714 popctl();
00715 poplab();
00716 dorange = 0;
00717 for(q = ctlstack ; q>=ctls ; --q)
00718 if(q->ctltype == CTLDO)
00719 {
00720 dorange = q->dolabel;
00721 break;
00722 }
00723 }
00724 }
00725
00726 void
00727 #ifdef KR_headers
00728 exassign(vname, labelval)
00729 register Namep vname;
00730 struct Labelblock *labelval;
00731 #else
00732 exassign(register Namep vname, struct Labelblock *labelval)
00733 #endif
00734 {
00735 Addrp p;
00736 register Addrp q;
00737 char *fs;
00738 register chainp cp, cpprev;
00739 register ftnint k, stno;
00740
00741 p = mkplace(vname);
00742 if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
00743 err("noninteger assign variable");
00744 return;
00745 }
00746
00747
00748
00749
00750
00751
00752
00753
00754
00755
00756 fs = labelval->fmtstring;
00757 if (!labelval->labdefined || !fs) {
00758
00759 if (vname -> vis_assigned == 0) {
00760 vname -> varxptr.assigned_values = CHNULL;
00761 vname -> vis_assigned = 1;
00762 }
00763
00764
00765
00766 stno = labelval->stateno;
00767 cpprev = 0;
00768 for(k = 0, cp = vname->varxptr.assigned_values;
00769 cp; cpprev = cp, cp = cp->nextp, k++)
00770 if ((ftnint)cp->datap == stno)
00771 break;
00772 if (!cp) {
00773 cp = mkchain((char *)stno, CHNULL);
00774 if (cpprev)
00775 cpprev->nextp = cp;
00776 else
00777 vname->varxptr.assigned_values = cp;
00778 labelval->labused = 1;
00779 }
00780 putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
00781 }
00782
00783
00784
00785 if (!labelval->labdefined || fs) {
00786
00787 labelval->fmtlabused = 1;
00788 p = ALLOC(Addrblock);
00789 p->tag = TADDR;
00790 p->vtype = TYCHAR;
00791 p->vstg = STGAUTO;
00792 p->memoffset = ICON(0);
00793 fmtname(vname, p);
00794 q = ALLOC(Addrblock);
00795 q->tag = TADDR;
00796 q->vtype = TYCHAR;
00797 q->vstg = STGAUTO;
00798 q->ntempelt = 1;
00799 q->memoffset = ICON(0);
00800 q->uname_tag = UNAM_IDENT;
00801 sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
00802 putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
00803 }
00804
00805 }
00806
00807
00808 void
00809 #ifdef KR_headers
00810 exarif(expr, neglab, zerlab, poslab)
00811 expptr expr;
00812 struct Labelblock *neglab;
00813 struct Labelblock *zerlab;
00814 struct Labelblock *poslab;
00815 #else
00816 exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab)
00817 #endif
00818 {
00819 register int lm, lz, lp;
00820
00821 lm = neglab->stateno;
00822 lz = zerlab->stateno;
00823 lp = poslab->stateno;
00824 expr = fixtype(expr);
00825
00826 if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
00827 {
00828 err("invalid type of arithmetic if expression");
00829 frexpr(expr);
00830 }
00831 else
00832 {
00833 if (lm == lz && lz == lp)
00834 exgoto (neglab);
00835 else if(lm == lz)
00836 exar2(OPLE, expr, neglab, poslab);
00837 else if(lm == lp)
00838 exar2(OPNE, expr, neglab, zerlab);
00839 else if(lz == lp)
00840 exar2(OPGE, expr, zerlab, neglab);
00841 else {
00842 expptr t;
00843
00844 if (!addressable (expr)) {
00845 t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
00846 expr = mkexpr (OPASSIGN, cpexpr (t), expr);
00847 } else
00848 t = (expptr) cpexpr (expr);
00849
00850 p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
00851 exgoto(neglab);
00852 p1_elif (mkexpr (OPEQ, t, ICON (0)));
00853 exgoto(zerlab);
00854 p1_else ();
00855 exgoto(poslab);
00856 p1else_end ();
00857 }
00858 }
00859 }
00860
00861
00862
00863
00864
00865
00866
00867 LOCAL void
00868 #ifdef KR_headers
00869 exar2(op, e, l1, l2)
00870 int op;
00871 expptr e;
00872 struct Labelblock *l1;
00873 struct Labelblock *l2;
00874 #else
00875 exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2)
00876 #endif
00877 {
00878 expptr comp;
00879
00880 comp = mkexpr (op, e, ICON (0));
00881 p1_if(putx(fixtype(comp)));
00882 exgoto(l1);
00883 p1_else ();
00884 exgoto(l2);
00885 p1else_end ();
00886 }
00887
00888
00889
00890
00891
00892 void
00893 #ifdef KR_headers
00894 exreturn(p)
00895 register expptr p;
00896 #else
00897 exreturn(register expptr p)
00898 #endif
00899 {
00900 if(procclass != CLPROC)
00901 warn("RETURN statement in main or block data");
00902 if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
00903 {
00904 err("alternate return in nonsubroutine");
00905 p = 0;
00906 }
00907
00908 if (p || proctype == TYSUBR) {
00909 if (p == ENULL) p = ICON (0);
00910 p = mkconv (TYLONG, fixtype (p));
00911 p1_subr_ret (p);
00912 }
00913 else
00914 p1_subr_ret((expptr)retslot);
00915 }
00916
00917
00918 void
00919 #ifdef KR_headers
00920 exasgoto(labvar)
00921 Namep labvar;
00922 #else
00923 exasgoto(Namep labvar)
00924 #endif
00925 {
00926 register Addrp p;
00927
00928 p = mkplace(labvar);
00929 if( ! ISINT(p->vtype) )
00930 err("assigned goto variable must be integer");
00931 else {
00932 p1_asgoto (p);
00933 }
00934 }