make_param(register struct Paramblock *p, expptr e) #endif { register expptr q; struct Constblock qc; p->vclass = CLPARAM; impldcl((Namep)p); if (e->headblock.vtype != TYCHAR) e = putx(fixtype(e)); p->paramval = q = mkconv(p->vtype, e); if (p->vtype == TYCHAR) { if (q->tag == TEXPR) p->paramval = q = fixexpr((Exprp)q); if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { qc.Const = q->addrblock.user.Const; qc.tag = TCONST; qc.vtype = q->addrblock.vtype; qc.vleng = q->addrblock.vleng; q = (expptr)&qc; } if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { errstr("invalid value for character parameter %s", p->fvarname); return; } if (!(e = p->vleng)) p->vleng = ICON(q->constblock.vleng->constblock.Const.ci + q->constblock.Const.ccp1.blanks); else if (q->constblock.vleng->constblock.Const.ci > e->constblock.Const.ci) { q->constblock.vleng->constblock.Const.ci = e->constblock.Const.ci; q->constblock.Const.ccp1.blanks = 0; } else q->constblock.Const.ccp1.blanks = e->constblock.Const.ci - q->constblock.vleng->constblock.Const.ci; } }
doentry(struct Entrypoint *ep) #endif { register int type; register Namep np; chainp p, p1; register Namep q; Addrp rs; int it, k; extern char dflttype[26]; Extsym *entryname = ep->entryname; if (++nentry > 1) p1_label((long)(extsymtab - entryname - 1)); /* The main program isn't allowed to have parameters, so any given parameters are ignored */ if(procclass == CLMAIN && !ep->arglist || procclass == CLBLOCK) return; /* Entry points in MAIN are an error, but we process them here */ /* to prevent faults elsewhere. */ /* So now we're working with something other than CLMAIN or CLBLOCK. Determine the type of its return value. */ impldcl( np = mkname(entryname->fextname) ); type = np->vtype; proc_argchanges = prev_proc && type != entryname->extype; entryname->extseen = 1; if(proctype == TYUNKNOWN) if( (proctype = type) == TYCHAR) procleng = np->vleng ? np->vleng->constblock.Const.ci : (ftnint) (-1); if(proctype == TYCHAR) { if(type != TYCHAR) err("noncharacter entry of character function"); /* Functions returning type char can only have multiple entries if all entries return the same length */ else if( (np->vleng ? np->vleng->constblock.Const.ci : (ftnint) (-1)) != procleng) err("mismatched character entry lengths"); } else if(type == TYCHAR) err("character entry of noncharacter function"); else if(type != proctype) multitype = YES; if(rtvlabel[type] == 0) rtvlabel[type] = (int)newlabel(); ep->typelabel = rtvlabel[type]; if(type == TYCHAR) { if(chslot < 0) { chslot = nextarg(TYADDR); chlgslot = nextarg(TYLENG); } np->vstg = STGARG; /* Put a new argument in the function, one which will hold the result of a character function. This will have to be named sometime, probably in mkarg(). */ if(procleng < 0) { np->vleng = (expptr) mkarg(TYLENG, chlgslot); np->vleng->addrblock.uname_tag = UNAM_IDENT; strcpy (np -> vleng -> addrblock.user.ident, new_func_length()); } if (!xretslot[TYCHAR]) { xretslot[TYCHAR] = rs = autovar(0, type, ISCONST(np->vleng) ? np->vleng : ICON(0), ""); strcpy(rs->user.ident, "ret_val"); } } /* Handle a complex return type -- declare a new parameter (pointer to a complex value) */ else if( ISCOMPLEX(type) ) { if (!xretslot[type]) xretslot[type] = autovar(0, type, EXNULL, " ret_val"); /* the blank is for use in out_addr */ np->vstg = STGARG; if(cxslot < 0) cxslot = nextarg(TYADDR); } else if (type != TYSUBR) { if (type == TYUNKNOWN) { dclerr("untyped function", np); proctype = type = np->vtype = dflttype[letter(np->fvarname[0])]; } if (!xretslot[type]) xretslot[type] = retslot = autovar(1, type, EXNULL, " ret_val"); /* the blank is for use in out_addr */ np->vstg = STGAUTO; } for(p = ep->arglist ; p ; p = p->nextp) if(! (( q = (Namep) (p->datap) )->vknownarg) ) { q->vknownarg = 1; q->vardesc.varno = nextarg(TYADDR); allargs = mkchain((char *)q, allargs); q->argno = nallargs++; } else if (nentry == 1) duparg(q); else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp) if ((Namep)p1->datap == q) duparg(q); k = 0; for(p = ep->arglist ; p ; p = p->nextp) { if(! (( q = (Namep) (p->datap) )->vdcldone) ) { impldcl(q); q->vdcldone = YES; if(q->vtype == TYCHAR) { /* If we don't know the length of a char*(*) (i.e. a string), we must add in this additional length argument. */ ++nallchargs; if (q->vclass == CLPROC) nallchargs--; else if (q->vleng == NULL) { /* character*(*) */ q->vleng = (expptr) mkarg(TYLENG, nextarg(TYLENG) ); unamstring((Addrp)q->vleng, new_arg_length(q)); } } } if (q->vdimfinish) dim_finish(q); if (q->vtype == TYCHAR && q->vclass != CLPROC) k++; } if (entryname->extype != type) changedtype(np); /* save information for checking consistency of arg lists */ it = infertypes; if (entryname->exproto) infertypes = 1; save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo, 0, np->fvarname, STGEXT, k, np->vtype, 2); infertypes = it; }