Doxygen Source Code Documentation
proc.c File Reference
#include "defs.h"
#include "names.h"
#include "output.h"
#include "p1defs.h"
Go to the source code of this file.
Defines | |
#define | roundup(a, b) ( b * ( (a+b-1)/b) ) |
#define | EXNULL (union Expression *)0 |
Functions | |
void dobss | Argdcl ((void)) |
void doentry | Argdcl ((struct Entrypoint *)) |
int nextarg | Argdcl ((int)) |
void | changedtype (Namep q) |
void | unamstring (register Addrp q, register char *s) |
void | fix_entry_returns (Void) |
void | putentries (FILE *outfile) |
void | entry_goto (FILE *outfile) |
void | newproc (Void) |
void | zap_changes (Void) |
void | endproc (Void) |
void | enddcl (Void) |
void | startproc (Extsym *progname, int classKRH) |
Extsym * | newentry (register Namep v, int substmsg) |
void | entrypt (int classKRH, int type, ftnint length, Extsym *entry, chainp args) |
LOCAL void | epicode (Void) |
LOCAL void | retval (register int t) |
void | procode (FILE *outfile) |
void | bad_dimtype (Namep q) |
void | dim_finish (Namep v) |
void | duparg (Namep q) |
LOCAL void | doentry (struct Entrypoint *ep) |
LOCAL int | nextarg (int type) |
LOCAL void | dim_check (Namep q) |
LOCAL void | dobss (Void) |
void | donmlist (Void) |
ftnint | iarrlen (register Namep q) |
void | namelist (Namep np) |
LOCAL void | docommon (Void) |
void | copy_data (chainp list) |
LOCAL void | docomleng (Void) |
void | frtemp (Addrp p) |
void | freetemps (Void) |
Addrp | autovar (register int nelt0, register int t, expptr lengp, char *name) |
Addrp | mktmpn (int nelt, register int type, expptr lengp) |
Addrp | mktmp (int type, expptr lengp) |
Addrp | mktmp0 (int type, expptr lengp) |
Extsym * | comblock (register char *s) |
void | incomm (Extsym *c, Namep v) |
void | settype (register Namep v, register int type, register ftnint length) |
int | lengtype (register int type, ftnint len) |
void | setintr (register Namep v) |
void | setext (register Namep v) |
void | setbound (register Namep v, int nd, struct Dims *dims) |
void | wr_abbrevs (FILE *outfile, int function_head, chainp vars) |
Variables | |
char | Blank [] = BLANKCOMMON |
char * | postfix [] |
chainp | new_procs |
int | prev_proc |
int | proc_argchanges |
int | proc_protochanges |
Define Documentation
|
Definition at line 36 of file proc.c. Referenced by doentry(), and setbound(). |
|
Definition at line 34 of file proc.c. Referenced by docommon(). |
Function Documentation
|
|
|
|
|
|
|
Definition at line 1225 of file proc.c. References ALLOC, av_pfix, Constant::ci, Constblock::Const, Expression::constblock, declare_new_addr(), Fatal(), ICON, Addrblock::isarray, ISICON, Addrblock::memoffset, name, Addrblock::ntempelt, q, STGAUTO, TADDR, Addrblock::tag, temp_name(), UNAM_IDENT, Addrblock::uname_tag, unamstring(), Addrblock::user, Addrblock::varleng, Addrblock::vleng, Addrblock::vstg, and Addrblock::vtype. Referenced by doentry(), endioctl(), mktmpn(), setbound(), settype(), and startrw().
01227 { 01228 ftnint leng; 01229 register Addrp q; 01230 register int nelt = nelt0 > 0 ? nelt0 : 1; 01231 extern char *av_pfix[]; 01232 01233 if(t == TYCHAR) 01234 if( ISICON(lengp) ) 01235 leng = lengp->constblock.Const.ci; 01236 else { 01237 Fatal("automatic variable of nonconstant length"); 01238 } 01239 else 01240 leng = typesize[t]; 01241 01242 q = ALLOC(Addrblock); 01243 q->tag = TADDR; 01244 q->vtype = t; 01245 if(t == TYCHAR) 01246 { 01247 q->vleng = ICON(leng); 01248 q->varleng = leng; 01249 } 01250 q->vstg = STGAUTO; 01251 q->ntempelt = nelt; 01252 q->isarray = (nelt > 1); 01253 q->memoffset = ICON(0); 01254 01255 /* kludge for nls so we can have ret_val rather than ret_val_4 */ 01256 if (*name == ' ') 01257 unamstring(q, name); 01258 else { 01259 q->uname_tag = UNAM_IDENT; 01260 temp_name(av_pfix[t], ++autonum[t], q->user.ident); 01261 } 01262 if (nelt0 > 0) 01263 declare_new_addr (q); 01264 return(q); 01265 } |
|
Definition at line 664 of file proc.c. Referenced by dim_check(), and dim_finish().
|
|
Definition at line 62 of file proc.c. References Extsym::arginfo, Argtypes::changes, Argtypes::defined, Extsym::extype, Extsym::exused, proc_protochanges, q, and warn(). Referenced by dobss(), doentry(), and settype().
00064 { 00065 char buf[200]; 00066 int qtype, type1; 00067 register Extsym *e; 00068 Argtypes *at; 00069 00070 if (q->vtypewarned) 00071 return; 00072 q->vtypewarned = 1; 00073 qtype = q->vtype; 00074 e = &extsymtab[q->vardesc.varno]; 00075 if (!(at = e->arginfo)) { 00076 if (!e->exused) 00077 return; 00078 } 00079 else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined) 00080 proc_protochanges++; 00081 type1 = e->extype; 00082 if (type1 == TYUNKNOWN) 00083 return; 00084 if (qtype == TYUNKNOWN) 00085 /* e.g., 00086 subroutine foo 00087 end 00088 external foo 00089 call goo(foo) 00090 end 00091 */ 00092 return; 00093 sprintf(buf, "%.90s: inconsistent declarations:\n\ 00094 here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype], 00095 qtype == TYSUBR ? "" : " function", 00096 ftn_types[type1], type1 == TYSUBR ? "" : " function"); 00097 warn(buf); 00098 } |
|
Definition at line 1375 of file proc.c. References Blank, c, cbuf, errstr(), Extsym::extstg, i, mkext1(), p, STGCOMMON, and STGUNKNOWN. Referenced by yyparse().
01377 { 01378 Extsym *p; 01379 register char *t; 01380 register int c, i; 01381 char cbuf[256], *s0; 01382 01383 /* Give the unnamed common block a unique name */ 01384 01385 if(*s == 0) 01386 p = mkext1(s0 = Blank, Blank); 01387 else { 01388 s0 = s; 01389 t = cbuf; 01390 for(i = 0; c = *t = *s++; t++) 01391 if (c == '_') 01392 i = 1; 01393 if (i) 01394 *t++ = '_'; 01395 t[0] = '_'; 01396 t[1] = 0; 01397 p = mkext1(s0,cbuf); 01398 } 01399 if(p->extstg == STGUNKNOWN) 01400 p->extstg = STGCOMMON; 01401 else if(p->extstg != STGCOMMON) 01402 { 01403 errstr("%.52s cannot be a common block: it is a subprogram.", 01404 s0); 01405 return(0); 01406 } 01407 01408 return( p ); 01409 } |
|
Definition at line 1126 of file proc.c. References ALLOC, cpexpr(), cpn(), Nameblock::cvarname, Nameblock::fvarname, gmem(), i, Dimblock::nelt, and Nameblock::vdim. Referenced by endproc().
01128 { 01129 for (; list; list = list -> nextp) { 01130 Namep namep = ALLOC (Nameblock); 01131 int size, nd, i; 01132 struct Dimblock *dp; 01133 01134 cpn(sizeof(struct Nameblock), list->datap, (char *)namep); 01135 namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0), 01136 namep->fvarname); 01137 namep->cvarname = strcmp(namep->fvarname, namep->cvarname) 01138 ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname) 01139 : namep->fvarname; 01140 if (namep -> vleng) 01141 namep -> vleng = (expptr) cpexpr (namep -> vleng); 01142 if (namep -> vdim) { 01143 nd = namep -> vdim -> ndim; 01144 size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr); 01145 dp = (struct Dimblock *) ckalloc (size); 01146 cpn(size, (char *)namep->vdim, (char *)dp); 01147 namep -> vdim = dp; 01148 dp->nelt = (expptr)cpexpr(dp->nelt); 01149 for (i = 0; i < nd; i++) { 01150 dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize); 01151 } /* for */ 01152 } /* if */ 01153 list -> datap = (char *) namep; 01154 } /* for */ 01155 } /* copy_data */ |
|
Definition at line 904 of file proc.c. References bad_dimtype(), Constant::cd, Constant::ci, Constblock::Const, Expression::constblock, dclerr(), Expression::headblock, ISCONST, ISINT, MSKINT, MSKREAL, Dimblock::nelt, ONEOF, q, and Headblock::vtype. Referenced by dobss().
00906 { 00907 register struct Dimblock *vdim = q->vdim; 00908 register expptr nelt; 00909 00910 if(!(nelt = vdim->nelt) || !ISCONST(nelt)) 00911 dclerr("adjustable dimension on non-argument", q); 00912 else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL)) 00913 bad_dimtype(q); 00914 else if (ISINT(nelt->headblock.vtype) 00915 && nelt->constblock.Const.ci <= 0 00916 || nelt->constblock.Const.cd[0] <= 0) 00917 dclerr("nonpositive dimension", q); 00918 } |
|
Definition at line 683 of file proc.c. References bad_dimtype(), Dimblock::basexpr, Dimblock::dims, fixtype(), i, make_int_expr(), MSKINT, MSKREAL, Dimblock::ndim, ONEOF, putx(), q, and v. Referenced by doentry().
00685 { 00686 register struct Dimblock *p; 00687 register expptr q; 00688 register int i, nd; 00689 00690 p = v->vdim; 00691 v->vdimfinish = 0; 00692 nd = p->ndim; 00693 doin_setbound = 1; 00694 for(i = 0; i < nd; i++) 00695 if (q = p->dims[i].dimexpr) { 00696 q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q))); 00697 if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL)) 00698 bad_dimtype(v); 00699 } 00700 if (q = p->basexpr) 00701 p->basexpr = make_int_expr(putx(fixtype(q))); 00702 doin_setbound = 0; 00703 } |
|
Definition at line 921 of file proc.c. References addunder(), changedtype(), CLPROC, CLUNKNOWN, CLVAR, dim_check(), Extsym::extstg, Extsym::extype, mkext(), PEXTERNAL, q, STGARG, STGBSS, STGEXT, STGUNKNOWN, Hashentry::varp, and warn1(). Referenced by endproc().
00922 { 00923 register struct Hashentry *p; 00924 register Namep q; 00925 int qstg, qclass, qtype; 00926 Extsym *e; 00927 00928 for(p = hashtab ; p<lasthash ; ++p) 00929 if(q = p->varp) 00930 { 00931 qstg = q->vstg; 00932 qtype = q->vtype; 00933 qclass = q->vclass; 00934 00935 if( (qclass==CLUNKNOWN && qstg!=STGARG) || 00936 (qclass==CLVAR && qstg==STGUNKNOWN) ) { 00937 if (!(q->vis_assigned | q->vimpldovar)) 00938 warn1("local variable %s never used", 00939 q->fvarname); 00940 } 00941 else if(qclass==CLVAR && qstg==STGBSS) 00942 { ; } 00943 00944 /* Give external procedures the proper storage class */ 00945 00946 else if(qclass==CLPROC && q->vprocclass==PEXTERNAL 00947 && qstg!=STGARG) { 00948 e = mkext(q->fvarname,addunder(q->cvarname)); 00949 e->extstg = STGEXT; 00950 q->vardesc.varno = e - extsymtab; 00951 if (e->extype != qtype) 00952 changedtype(q); 00953 } 00954 if(qclass==CLVAR) { 00955 if (qstg != STGARG && q->vdim) 00956 dim_check(q); 00957 } /* if qclass == CLVAR */ 00958 } 00959 00960 } |
|
Definition at line 1160 of file proc.c. References Blank, Extsym::cextname, Extsym::extleng, Extsym::extstg, Extsym::fextname, Extsym::maxleng, p, STGCOMMON, and warn1(). Referenced by enddcl().
01161 { 01162 register Extsym *p; 01163 01164 for(p = extsymtab ; p < nextext ; ++p) 01165 if(p->extstg == STGCOMMON) 01166 { 01167 if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng 01168 && strcmp(Blank, p->cextname) ) 01169 warn1("incompatible lengths for common block %.60s", 01170 p->fextname); 01171 if(p->maxleng < p->extleng) 01172 p->maxleng = p->extleng; 01173 p->extleng = 0; 01174 } 01175 } |
|
Definition at line 1036 of file proc.c. References Extsym::allextp, Constant::ci, Constblock::Const, Expression::constblock, Extsym::curno, Chain::datap, dclerr(), Extsym::extleng, Extsym::extp, Extsym::extstg, Extsym::extype, i, ISCONST, Extsym::maxno, mkchain(), Dimblock::nelt, Chain::nextp, NO, q, revchain(), roundup, STGCOMMON, struct_eq(), type_pref, vardcl(), Nameblock::vardesc, Nameblock::vdcldone, Nameblock::vdim, Nameblock::vleng, Nameblock::voffset, and Nameblock::vtype. Referenced by enddcl().
01037 { 01038 register Extsym *extptr; 01039 register chainp q, q1; 01040 struct Dimblock *t; 01041 expptr neltp; 01042 register Namep comvar; 01043 ftnint size; 01044 int i, k, pref, type; 01045 extern int type_pref[]; 01046 01047 for(extptr = extsymtab ; extptr<nextext ; ++extptr) 01048 if (extptr->extstg == STGCOMMON && (q = extptr->extp)) { 01049 01050 /* If a common declaration also had a list of variables ... */ 01051 01052 q = extptr->extp = revchain(q); 01053 pref = 1; 01054 for(k = TYCHAR; q ; q = q->nextp) 01055 { 01056 comvar = (Namep) (q->datap); 01057 01058 if(comvar->vdcldone == NO) 01059 vardcl(comvar); 01060 type = comvar->vtype; 01061 if (pref < type_pref[type]) 01062 pref = type_pref[k = type]; 01063 if(extptr->extleng % typealign[type] != 0) { 01064 dclerr("common alignment", comvar); 01065 --nerr; /* don't give bad return code for this */ 01066 #if 0 01067 extptr->extleng = roundup(extptr->extleng, typealign[type]); 01068 #endif 01069 } /* if extptr -> extleng % */ 01070 01071 /* Set the offset into the common block */ 01072 01073 comvar->voffset = extptr->extleng; 01074 comvar->vardesc.varno = extptr - extsymtab; 01075 if(type == TYCHAR) 01076 if (comvar->vleng) 01077 size = comvar->vleng->constblock.Const.ci; 01078 else { 01079 dclerr("character*(*) in common", comvar); 01080 size = 1; 01081 } 01082 else 01083 size = typesize[type]; 01084 if(t = comvar->vdim) 01085 if( (neltp = t->nelt) && ISCONST(neltp) ) 01086 size *= neltp->constblock.Const.ci; 01087 else 01088 dclerr("adjustable array in common", comvar); 01089 01090 /* Adjust the length of the common block so far */ 01091 01092 extptr->extleng += size; 01093 } /* for */ 01094 01095 extptr->extype = k; 01096 01097 /* Determine curno and, if new, save this identifier chain */ 01098 01099 q1 = extptr->extp; 01100 for (q = extptr->allextp, i = 0; q; i++, q = q->nextp) 01101 if (struct_eq((chainp)q->datap, q1)) 01102 break; 01103 if (q) 01104 extptr->curno = extptr->maxno - i; 01105 else { 01106 extptr->curno = ++extptr->maxno; 01107 extptr->allextp = mkchain((char *)extptr->extp, 01108 extptr->allextp); 01109 } 01110 } /* if extptr -> extstg == STGCOMMON */ 01111 01112 /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and 01113 varno. And the common block itself has its full size in extleng. */ 01114 01115 } /* docommon */ |
|
Definition at line 724 of file proc.c. References Expression::addrblock, Nameblock::arginfo, Extsym::arginfo, Entrypoint::arglist, Nameblock::argno, autovar(), changedtype(), Constant::ci, CLBLOCK, CLMAIN, CLPROC, Constblock::Const, Expression::constblock, Chain::datap, dclerr(), dim_finish(), duparg(), Entrypoint::entryname, err, EXNULL, Extsym::exproto, Extsym::extseen, Extsym::extype, Extsym::fextname, Nameblock::fvarname, ICON, impldcl(), ISCOMPLEX, ISCONST, letter, mkarg(), mkchain(), mkname(), new_arg_length(), new_func_length(), newlabel(), nextarg(), Chain::nextp, p, p1_label(), prev_proc, proc_argchanges, q, save_argtypes(), STGARG, STGAUTO, STGEXT, TYLENG, Entrypoint::typelabel, UNAM_IDENT, Addrblock::uname_tag, unamstring(), Addrblock::user, Nameblock::vardesc, Nameblock::vclass, Nameblock::vdcldone, Nameblock::vdimfinish, Nameblock::vknownarg, Nameblock::vleng, Nameblock::vstg, Nameblock::vtype, and YES. Referenced by enddcl(), and entrypt().
00726 { 00727 register int type; 00728 register Namep np; 00729 chainp p, p1; 00730 register Namep q; 00731 Addrp rs; 00732 int it, k; 00733 extern char dflttype[26]; 00734 Extsym *entryname = ep->entryname; 00735 00736 if (++nentry > 1) 00737 p1_label((long)(extsymtab - entryname - 1)); 00738 00739 /* The main program isn't allowed to have parameters, so any given 00740 parameters are ignored */ 00741 00742 if(procclass == CLMAIN || procclass == CLBLOCK) 00743 return; 00744 00745 /* So now we're working with something other than CLMAIN or CLBLOCK. 00746 Determine the type of its return value. */ 00747 00748 impldcl( np = mkname(entryname->fextname) ); 00749 type = np->vtype; 00750 proc_argchanges = prev_proc && type != entryname->extype; 00751 entryname->extseen = 1; 00752 if(proctype == TYUNKNOWN) 00753 if( (proctype = type) == TYCHAR) 00754 procleng = np->vleng ? np->vleng->constblock.Const.ci 00755 : (ftnint) (-1); 00756 00757 if(proctype == TYCHAR) 00758 { 00759 if(type != TYCHAR) 00760 err("noncharacter entry of character function"); 00761 00762 /* Functions returning type char can only have multiple entries if all 00763 entries return the same length */ 00764 00765 else if( (np->vleng ? np->vleng->constblock.Const.ci : 00766 (ftnint) (-1)) != procleng) 00767 err("mismatched character entry lengths"); 00768 } 00769 else if(type == TYCHAR) 00770 err("character entry of noncharacter function"); 00771 else if(type != proctype) 00772 multitype = YES; 00773 if(rtvlabel[type] == 0) 00774 rtvlabel[type] = (int)newlabel(); 00775 ep->typelabel = rtvlabel[type]; 00776 00777 if(type == TYCHAR) 00778 { 00779 if(chslot < 0) 00780 { 00781 chslot = nextarg(TYADDR); 00782 chlgslot = nextarg(TYLENG); 00783 } 00784 np->vstg = STGARG; 00785 00786 /* Put a new argument in the function, one which will hold the result of 00787 a character function. This will have to be named sometime, probably in 00788 mkarg(). */ 00789 00790 if(procleng < 0) { 00791 np->vleng = (expptr) mkarg(TYLENG, chlgslot); 00792 np->vleng->addrblock.uname_tag = UNAM_IDENT; 00793 strcpy (np -> vleng -> addrblock.user.ident, 00794 new_func_length()); 00795 } 00796 if (!xretslot[TYCHAR]) { 00797 xretslot[TYCHAR] = rs = 00798 autovar(0, type, ISCONST(np->vleng) 00799 ? np->vleng : ICON(0), ""); 00800 strcpy(rs->user.ident, "ret_val"); 00801 } 00802 } 00803 00804 /* Handle a complex return type -- declare a new parameter (pointer to 00805 a complex value) */ 00806 00807 else if( ISCOMPLEX(type) ) { 00808 if (!xretslot[type]) 00809 xretslot[type] = 00810 autovar(0, type, EXNULL, " ret_val"); 00811 /* the blank is for use in out_addr */ 00812 np->vstg = STGARG; 00813 if(cxslot < 0) 00814 cxslot = nextarg(TYADDR); 00815 } 00816 else if (type != TYSUBR) { 00817 if (type == TYUNKNOWN) { 00818 dclerr("untyped function", np); 00819 proctype = type = np->vtype = 00820 dflttype[letter(np->fvarname[0])]; 00821 } 00822 if (!xretslot[type]) 00823 xretslot[type] = retslot = 00824 autovar(1, type, EXNULL, " ret_val"); 00825 /* the blank is for use in out_addr */ 00826 np->vstg = STGAUTO; 00827 } 00828 00829 for(p = ep->arglist ; p ; p = p->nextp) 00830 if(! (( q = (Namep) (p->datap) )->vknownarg) ) { 00831 q->vknownarg = 1; 00832 q->vardesc.varno = nextarg(TYADDR); 00833 allargs = mkchain((char *)q, allargs); 00834 q->argno = nallargs++; 00835 } 00836 else if (nentry == 1) 00837 duparg(q); 00838 else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp) 00839 if ((Namep)p1->datap == q) 00840 duparg(q); 00841 00842 k = 0; 00843 for(p = ep->arglist ; p ; p = p->nextp) { 00844 if(! (( q = (Namep) (p->datap) )->vdcldone) ) 00845 { 00846 impldcl(q); 00847 q->vdcldone = YES; 00848 if(q->vtype == TYCHAR) 00849 { 00850 00851 /* If we don't know the length of a char*(*) (i.e. a string), we must add 00852 in this additional length argument. */ 00853 00854 ++nallchargs; 00855 if (q->vclass == CLPROC) 00856 nallchargs--; 00857 else if (q->vleng == NULL) { 00858 /* character*(*) */ 00859 q->vleng = (expptr) 00860 mkarg(TYLENG, nextarg(TYLENG) ); 00861 unamstring((Addrp)q->vleng, 00862 new_arg_length(q)); 00863 } 00864 } 00865 } 00866 if (q->vdimfinish) 00867 dim_finish(q); 00868 if (q->vtype == TYCHAR && q->vclass != CLPROC) 00869 k++; 00870 } 00871 00872 if (entryname->extype != type) 00873 changedtype(np); 00874 00875 /* save information for checking consistency of arg lists */ 00876 00877 it = infertypes; 00878 if (entryname->exproto) 00879 infertypes = 1; 00880 save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo, 00881 0, np->fvarname, STGEXT, k, np->vtype, 2); 00882 infertypes = it; 00883 } |
|
Definition at line 964 of file proc.c. References CLNAMELIST, namelist(), q, and Hashentry::varp. Referenced by endproc().
|
|
Definition at line 710 of file proc.c. Referenced by doentry().
|
|
Definition at line 378 of file proc.c. References docomleng(), docommon(), doentry(), doequiv(), Entrypoint::entnextp, err_proc, frchain(), freetemps(), INEXEC, p1_label(), p1_line_number(), P1_PROCODE, p1put(), and revchain(). Referenced by endproc(), exequals(), and yyparse().
00379 { 00380 register struct Entrypoint *ep; 00381 struct Entrypoint *ep0; 00382 chainp cp; 00383 extern char *err_proc; 00384 static char comblks[] = "common blocks"; 00385 00386 err_proc = comblks; 00387 docommon(); 00388 00389 /* Now the hash table entries for fields of common blocks have STGCOMMON, 00390 vdcldone, voffset, and varno. And the common blocks themselves have 00391 their full sizes in extleng. */ 00392 00393 err_proc = "equivalences"; 00394 doequiv(); 00395 00396 err_proc = comblks; 00397 docomleng(); 00398 00399 /* This implies that entry points in the declarations are buffered in 00400 entries but not written out */ 00401 00402 err_proc = "entries"; 00403 if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) { 00404 /* entries could be 0 in case of an error */ 00405 do doentry(ep); 00406 while(ep = ep->entnextp); 00407 entries = (struct Entrypoint *)revchain((chainp)ep0); 00408 } 00409 00410 err_proc = 0; 00411 parstate = INEXEC; 00412 p1put(P1_PROCODE); 00413 freetemps(); 00414 if (earlylabs) { 00415 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp) 00416 p1_label((long)cp->datap); 00417 frchain(&earlylabs); 00418 } 00419 p1_line_number(lineno); /* for files that start with a MAIN program */ 00420 /* that starts with an executable statement */ 00421 } |
|
Definition at line 328 of file proc.c. References CHNULL, convic(), copy_data(), dobss(), donmlist(), enddcl(), epicode(), err, errstr(), fix_entry_returns(), INDATA, Labelblock::labdefined, NO, procinit(), putentries(), start_formatting(), Labelblock::stateno, STGCOMMON, usedefsforcommon, wr_abbrevs(), and zap_changes(). Referenced by main(), newproc(), startproc(), and yyparse().
00329 { 00330 struct Labelblock *lp; 00331 Extsym *ext; 00332 00333 if(parstate < INDATA) 00334 enddcl(); 00335 if(ctlstack >= ctls) 00336 err("DO loop or BLOCK IF not closed"); 00337 for(lp = labeltab ; lp < labtabend ; ++lp) 00338 if(lp->stateno!=0 && lp->labdefined==NO) 00339 errstr("missing statement label %s", 00340 convic(lp->stateno) ); 00341 00342 /* Save copies of the common variables in extptr -> allextp */ 00343 00344 for (ext = extsymtab; ext < nextext; ext++) 00345 if (ext -> extstg == STGCOMMON && ext -> extp) { 00346 extern int usedefsforcommon; 00347 00348 /* Write out the abbreviations for common block reference */ 00349 00350 copy_data (ext -> extp); 00351 if (usedefsforcommon) { 00352 wr_abbrevs (c_file, 1, ext -> extp); 00353 ext -> used_here = 1; 00354 } 00355 else 00356 ext -> extp = CHNULL; 00357 00358 } 00359 00360 if (nentry > 1) 00361 fix_entry_returns(); 00362 epicode(); 00363 donmlist(); 00364 dobss(); 00365 start_formatting (); 00366 if (nentry > 1) 00367 putentries(c_file); 00368 00369 zap_changes(); 00370 procinit(); /* clean up for next procedure */ 00371 } |
|
Definition at line 277 of file proc.c. References Entrypoint::entnextp, Entrypoint::entryname, next_tab, nice_printf(), prev_tab, and user_label(). Referenced by procode().
00279 { 00280 struct Entrypoint *e = entries; 00281 int k = 0; 00282 00283 nice_printf(outfile, "switch(n__) {\n"); 00284 next_tab(outfile); 00285 while(e = e->entnextp) 00286 nice_printf(outfile, "case %d: goto %s;\n", ++k, 00287 user_label((long)(extsymtab - e->entryname - 1))); 00288 nice_printf(outfile, "}\n\n"); 00289 prev_tab(outfile); 00290 } |
|
Definition at line 521 of file proc.c. References ALLOC, Entrypoint::arglist, Extsym::cextname, CLENTRY, CLPROC, doentry(), Entrypoint::enamep, Entrypoint::entnextp, Entrypoint::entryname, Extsym::fextname, INDATA, lengtype(), mkname(), PTHISPROC, puthead(), q, revchain(), settype(), STGEXT, Nameblock::vclass, Nameblock::vprocclass, and Nameblock::vstg. Referenced by startproc(), and yyparse().
00523 { 00524 register Namep q; 00525 register struct Entrypoint *p; 00526 00527 if(classKRH != CLENTRY) 00528 puthead( procname = entry->cextname, classKRH); 00529 else 00530 fprintf(diagfile, " entry "); 00531 fprintf(diagfile, " %s:\n", entry->fextname); 00532 fflush(diagfile); 00533 q = mkname(entry->fextname); 00534 if (type == TYSUBR) 00535 q->vstg = STGEXT; 00536 00537 type = lengtype(type, length); 00538 if(classKRH == CLPROC) 00539 { 00540 procclass = CLPROC; 00541 proctype = type; 00542 procleng = type == TYCHAR ? length : 0; 00543 } 00544 00545 p = ALLOC(Entrypoint); 00546 00547 p->entnextp = entries; 00548 entries = p; 00549 00550 p->entryname = entry; 00551 p->arglist = revchain(args); 00552 p->enamep = q; 00553 00554 if(classKRH == CLENTRY) 00555 { 00556 classKRH = CLPROC; 00557 if(proctype == TYSUBR) 00558 type = TYSUBR; 00559 } 00560 00561 q->vclass = classKRH; 00562 q->vprocclass = 0; 00563 settype(q, type, length); 00564 q->vprocclass = PTHISPROC; 00565 /* hold all initial entry points till end of declarations */ 00566 if(parstate >= INDATA) 00567 doentry(p); 00568 } |
|
Definition at line 577 of file proc.c. References CLMAIN, CLPROC, ICON, lastwasbranch, NO, p1_subr_ret(), retval(), and YES. Referenced by endproc().
00578 { 00579 extern int lastwasbranch; 00580 00581 if(procclass==CLPROC) 00582 { 00583 if(proctype==TYSUBR) 00584 { 00585 00586 /* Return a zero only when the alternate return mechanism has been 00587 specified in the function header */ 00588 00589 if ((substars || Ansi) && lastwasbranch != YES) 00590 p1_subr_ret (ICON(0)); 00591 } 00592 else if (!multitype && lastwasbranch != YES) 00593 retval(proctype); 00594 } 00595 else if (procclass == CLMAIN && Ansi && lastwasbranch != YES) 00596 p1_subr_ret (ICON(0)); 00597 lastwasbranch = NO; 00598 } |
|
Definition at line 125 of file proc.c. References a, Entrypoint::enamep, Entrypoint::entnextp, i, postfix, revchain(), STGARG, TYQUAD, and Addrblock::user. Referenced by endproc().
00126 { 00127 Addrp a; 00128 int i; 00129 struct Entrypoint *e; 00130 Namep np; 00131 00132 e = entries = (struct Entrypoint *)revchain((chainp)entries); 00133 allargs = revchain(allargs); 00134 if (!multitype) 00135 return; 00136 00137 /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */ 00138 00139 for(i = TYINT1; i <= TYLOGICAL; i++) 00140 if (a = xretslot[i]) 00141 sprintf(a->user.ident, "(*ret_val).%s", 00142 postfix[i-TYINT1]); 00143 00144 do { 00145 np = e->enamep; 00146 switch(np->vtype) { 00147 case TYINT1: 00148 case TYSHORT: 00149 case TYLONG: 00150 #ifdef TYQUAD 00151 case TYQUAD: 00152 #endif 00153 case TYREAL: 00154 case TYDREAL: 00155 case TYCOMPLEX: 00156 case TYDCOMPLEX: 00157 case TYLOGICAL1: 00158 case TYLOGICAL2: 00159 case TYLOGICAL: 00160 np->vstg = STGARG; 00161 } 00162 } 00163 while(e = e->entnextp); 00164 } |
|
Definition at line 1193 of file proc.c. References Chain::datap, frexpr(), ICON, Chain::nextp, p, q, Addrblock::varleng, Addrblock::vleng, and Addrblock::vtype. Referenced by enddcl(), and yyparse().
01194 { 01195 register chainp p, p1; 01196 register Addrp q; 01197 register int t; 01198 01199 p1 = holdtemps; 01200 while(p = p1) { 01201 q = (Addrp)p->datap; 01202 t = q->vtype; 01203 if (t == TYCHAR && q->varleng != 0) { 01204 /* restore clobbered character string lengths */ 01205 frexpr(q->vleng); 01206 q->vleng = ICON(q->varleng); 01207 } 01208 p1 = p->nextp; 01209 p->nextp = templist[t]; 01210 templist[t] = p; 01211 } 01212 holdtemps = 0; 01213 } |
|
Definition at line 1185 of file proc.c. Referenced by enddo(), mktmp(), and putcat().
01187 { 01188 /* put block on chain of temps to be reclaimed */ 01189 holdtemps = mkchain((char *)p, holdtemps); 01190 } |
|
Definition at line 982 of file proc.c. Referenced by doequiv().
00984 { 00985 ftnint leng; 00986 00987 leng = typesize[q->vtype]; 00988 if(leng <= 0) 00989 return(-1); 00990 if(q->vdim) 00991 if( ISICON(q->vdim->nelt) ) 00992 leng *= q->vdim->nelt->constblock.Const.ci; 00993 else return(-1); 00994 if(q->vleng) 00995 if( ISICON(q->vleng) ) 00996 leng *= q->vleng->constblock.Const.ci; 00997 else return(-1); 00998 return(leng); 00999 } |
|
Definition at line 1420 of file proc.c. References c, dclerr(), mkchain(), STGARG, STGCOMMON, STGUNKNOWN, Nameblock::vimplstg, and Nameblock::vstg. Referenced by yyparse().
01422 { 01423 if (!c) 01424 return; 01425 if(v->vstg != STGUNKNOWN && !v->vimplstg) 01426 dclerr(v->vstg == STGARG 01427 ? "dummy arguments cannot be in common" 01428 : "incompatible common declaration", v); 01429 else 01430 { 01431 v->vstg = STGCOMMON; 01432 c->extp = mkchain((char *)v, c->extp); 01433 } 01434 } |
|
Definition at line 1532 of file proc.c. References badtype(), err, TYERROR, and TYQUAD. Referenced by entrypt(), setimpl(), and settype().
01534 { 01535 register int length = (int)len; 01536 switch(type) 01537 { 01538 case TYREAL: 01539 if(length == typesize[TYDREAL]) 01540 return(TYDREAL); 01541 if(length == typesize[TYREAL]) 01542 goto ret; 01543 break; 01544 01545 case TYCOMPLEX: 01546 if(length == typesize[TYDCOMPLEX]) 01547 return(TYDCOMPLEX); 01548 if(length == typesize[TYCOMPLEX]) 01549 goto ret; 01550 break; 01551 01552 case TYINT1: 01553 case TYSHORT: 01554 case TYDREAL: 01555 case TYDCOMPLEX: 01556 case TYCHAR: 01557 case TYLOGICAL1: 01558 case TYLOGICAL2: 01559 case TYUNKNOWN: 01560 case TYSUBR: 01561 case TYERROR: 01562 #ifdef TYQUAD 01563 case TYQUAD: 01564 #endif 01565 goto ret; 01566 01567 case TYLOGICAL: 01568 switch(length) { 01569 case 0: return tylog; 01570 case 1: return TYLOGICAL1; 01571 case 2: return TYLOGICAL2; 01572 case 4: goto ret; 01573 } 01574 #if 0 /*!!??!!*/ 01575 if(length == typesize[TYLOGICAL]) 01576 goto ret; 01577 #endif 01578 break; 01579 01580 case TYLONG: 01581 if(length == 0) 01582 return(tyint); 01583 if (length == 1) 01584 return TYINT1; 01585 if(length == typesize[TYSHORT]) 01586 return(TYSHORT); 01587 #ifdef TYQUAD 01588 if(length == typesize[TYQUAD] && use_tyquad) 01589 return(TYQUAD); 01590 #endif 01591 if(length == typesize[TYLONG]) 01592 goto ret; 01593 break; 01594 default: 01595 badtype("lengtype", type); 01596 } 01597 01598 if(len != 0) 01599 err("incompatible type-length combination"); 01600 01601 ret: 01602 return(type); 01603 } |
|
Definition at line 1336 of file proc.c. References cpexpr(), frtemp(), and mktmpn(). Referenced by cast_args(), doiolist(), endioctl(), exarif(), exdo(), Inline(), intdouble(), krput(), putcall(), putch1(), putcx1(), putmnmx(), putop(), putpower(), stfcall(), subcheck(), and suboffset().
|
|
Definition at line 1354 of file proc.c. References Addrblock::istemp, mktmpn(), and YES. Referenced by exdo().
|
|
Definition at line 1278 of file proc.c. References autovar(), badtype(), charptr, CHNULL, Constant::ci, Constblock::Const, Expression::constblock, Chain::datap, err, erri(), errnode, free, ISICON, M, Chain::nextp, Addrblock::ntempelt, ONEOF, p, q, TYERROR, and Addrblock::vleng. Referenced by mktmp(), mktmp0(), and putcat().
01280 { 01281 ftnint leng; 01282 chainp p, oldp; 01283 register Addrp q; 01284 extern int krparens; 01285 01286 if(type==TYUNKNOWN || type==TYERROR) 01287 badtype("mktmpn", type); 01288 01289 if(type==TYCHAR) 01290 if(lengp && ISICON(lengp) ) 01291 leng = lengp->constblock.Const.ci; 01292 else { 01293 err("adjustable length"); 01294 return( (Addrp) errnode() ); 01295 } 01296 else if (type > TYCHAR || type < TYADDR) { 01297 erri("mktmpn: unexpected type %d", type); 01298 exit(1); 01299 } 01300 /* 01301 * if a temporary of appropriate shape is on the templist, 01302 * remove it from the list and return it 01303 */ 01304 if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX))) 01305 type++; 01306 for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp) 01307 { 01308 q = (Addrp) (p->datap); 01309 if(q->ntempelt==nelt && 01310 (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) ) 01311 { 01312 if(oldp) 01313 oldp->nextp = p->nextp; 01314 else 01315 templist[type] = p->nextp; 01316 free( (charptr) p); 01317 return(q); 01318 } 01319 } 01320 q = autovar(nelt, type, lengp, ""); 01321 return(q); 01322 } |
|
Definition at line 1006 of file proc.c. References Chain::datap, dclerr(), MSKSTATIC, Chain::nextp, ONEOF, q, v, vardcl(), Nameblock::visused, Nameblock::vnamelist, Nameblock::vsave, and Nameblock::vstg. Referenced by donmlist().
01008 { 01009 register chainp q; 01010 register Namep v; 01011 int y; 01012 01013 if (!np->visused) 01014 return; 01015 y = 0; 01016 01017 for(q = np->varxptr.namelist ; q ; q = q->nextp) 01018 { 01019 vardcl( v = (Namep) (q->datap) ); 01020 if( !ONEOF(v->vstg, MSKSTATIC) ) 01021 dclerr("may not appear in namelist", v); 01022 else { 01023 v->vnamelist = 1; 01024 v->visused = 1; 01025 v->vsave = 1; 01026 y = 1; 01027 } 01028 np->visused = y; 01029 } 01030 } |
|
Definition at line 478 of file proc.c. References addunder(), CLPROC, dclerr(), Extsym::extinit, Extsym::extstg, M, mkext(), ONEOF, p, prev_proc, PTHISPROC, STGAUTO, STGEXT, STGUNKNOWN, v, and YES. Referenced by startproc(), and yyparse().
00480 { 00481 register Extsym *p; 00482 char buf[128], badname[64]; 00483 static int nbad = 0; 00484 static char already[] = "external name already used"; 00485 00486 p = mkext(v->fvarname, addunder(v->cvarname)); 00487 00488 if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) 00489 { 00490 sprintf(badname, "%s_bad%d", v->fvarname, ++nbad); 00491 if (substmsg) { 00492 sprintf(buf,"%s\n\tsubstituting \"%s\"", 00493 already, badname); 00494 dclerr(buf, v); 00495 } 00496 else 00497 dclerr(already, v); 00498 p = mkext(v->fvarname, badname); 00499 } 00500 v->vstg = STGAUTO; 00501 v->vprocclass = PTHISPROC; 00502 v->vclass = CLPROC; 00503 if (p->extstg == STGEXT) 00504 prev_proc = 1; 00505 else 00506 p->extstg = STGEXT; 00507 p->extinit = YES; 00508 v->vardesc.varno = p - extsymtab; 00509 return(p); 00510 } |
|
Definition at line 295 of file proc.c. References CLMAIN, CNULL, endproc(), execerr(), and OUTSIDE. Referenced by startproc(), and yyparse().
|
|
Definition at line 892 of file proc.c. Referenced by doentry().
00894 { 00895 type = type; /* shut up warning */ 00896 return(lastargslot++); 00897 } |
|
Definition at line 651 of file proc.c. References entry_goto(), and prolog(). Referenced by do_format().
00653 { 00654 prolog(outfile, allargs); 00655 00656 if (nentry > 1) 00657 entry_goto(outfile); 00658 } |
|
Definition at line 171 of file proc.c. References a, Entrypoint::arglist, args, base, c_type_decl(), ckalloc(), CLPROC, Nameblock::cvarname, Chain::datap, dfltarg, dfltproc, Entrypoint::enamep, Entrypoint::entnextp, frchain(), free, i, ISCOMPLEX, length_comp(), list_arg_types(), listargs(), MAXNAMELEN, new_arg_length(), next_tab, Chain::nextp, nice_printf(), postfix, and prev_tab. Referenced by endproc().
00174 { 00175 char base[MAXNAMELEN+4]; 00176 struct Entrypoint *e; 00177 Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np; 00178 chainp args, lengths; 00179 int i, k, mt, nL, t, type; 00180 extern char *dfltarg[], **dfltproc; 00181 00182 e = entries; 00183 if (!e->enamep) /* only possible with erroneous input */ 00184 return; 00185 nL = (nallargs + nallchargs) * sizeof(Namep *); 00186 A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **)); 00187 Ae = A + nallargs; 00188 Alp = (Namep **)(Ae1 = Ae + nallchargs); 00189 i = k = 0; 00190 for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) { 00191 np = (Namep)args->datap; 00192 if (np->vtype == TYCHAR && np->vclass != CLPROC) 00193 *a1 = &Ae[i++]; 00194 } 00195 00196 mt = multitype; 00197 multitype = 0; 00198 sprintf(base, "%s0_", e->enamep->cvarname); 00199 do { 00200 np = e->enamep; 00201 lengths = length_comp(e, 0); 00202 proctype = type = np->vtype; 00203 if (protofile) 00204 protowrite(protofile, type, np->cvarname, e, lengths); 00205 nice_printf(outfile, "\n%s ", c_type_decl(type, 1)); 00206 nice_printf(outfile, "%s", np->cvarname); 00207 if (!Ansi) { 00208 listargs(outfile, e, 0, lengths); 00209 nice_printf(outfile, "\n"); 00210 } 00211 list_arg_types(outfile, e, lengths, 0, "\n"); 00212 nice_printf(outfile, "{\n"); 00213 frchain(&lengths); 00214 next_tab(outfile); 00215 if (mt) 00216 nice_printf(outfile, 00217 "Multitype ret_val;\n%s(%d, &ret_val", 00218 base, k); /*)*/ 00219 else if (ISCOMPLEX(type)) 00220 nice_printf(outfile, "%s(%d,%s", base, k, 00221 xretslot[type]->user.ident); /*)*/ 00222 else if (type == TYCHAR) 00223 nice_printf(outfile, 00224 "%s(%d, ret_val, ret_val_len", base, k); /*)*/ 00225 else 00226 nice_printf(outfile, "return %s(%d", base, k); /*)*/ 00227 k++; 00228 memset((char *)A, 0, nL); 00229 for(args = e->arglist; args; args = args->nextp) { 00230 np = (Namep)args->datap; 00231 A[np->argno] = np; 00232 if (np->vtype == TYCHAR && np->vclass != CLPROC) 00233 *Alp[np->argno] = np; 00234 } 00235 args = allargs; 00236 for(a = A; a < Ae; a++, args = args->nextp) { 00237 t = ((Namep)args->datap)->vtype; 00238 nice_printf(outfile, ", %s", (np = *a) 00239 ? np->cvarname 00240 : ((Namep)args->datap)->vclass == CLPROC 00241 ? dfltproc[((Namep)args->datap)->vimpltype 00242 ? (Castargs ? TYUNKNOWN : TYSUBR) 00243 : t == TYREAL && forcedouble && !Castargs 00244 ? TYDREAL : t] 00245 : dfltarg[((Namep)args->datap)->vtype]); 00246 } 00247 for(; a < Ae1; a++) 00248 if (np = *a) 00249 nice_printf(outfile, ", %s", 00250 new_arg_length(np)); 00251 else 00252 nice_printf(outfile, ", (ftnint)0"); 00253 nice_printf(outfile, /*(*/ ");\n"); 00254 if (mt) { 00255 if (type == TYCOMPLEX) 00256 nice_printf(outfile, 00257 "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n"); 00258 else if (type == TYDCOMPLEX) 00259 nice_printf(outfile, 00260 "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n"); 00261 else if (type <= TYLOGICAL) 00262 nice_printf(outfile, "return ret_val.%s;\n", 00263 postfix[type-TYINT1]); 00264 } 00265 nice_printf(outfile, "}\n"); 00266 prev_tab(outfile); 00267 } 00268 while(e = e->entnextp); 00269 free((char *)A); 00270 } |
|
Definition at line 608 of file proc.c. References badtype(), cpexpr(), fixtype(), mkconv(), p, p1_subr_ret(), TYQUAD, and Addrblock::vtype. Referenced by AFNI_process_plugout(), dlopen(), do_format(), do_p1_subr_ret(), drive_MCW_imseq(), epicode(), is_negatable(), isnegative_const(), loop(), mri_stat_seq(), op_assign(), PLUTO_4D_to_nothing(), and yylex().
00610 { 00611 register Addrp p; 00612 00613 switch(t) 00614 { 00615 case TYCHAR: 00616 case TYCOMPLEX: 00617 case TYDCOMPLEX: 00618 break; 00619 00620 case TYLOGICAL: 00621 t = tylogical; 00622 case TYINT1: 00623 case TYADDR: 00624 case TYSHORT: 00625 case TYLONG: 00626 #ifdef TYQUAD 00627 case TYQUAD: 00628 #endif 00629 case TYREAL: 00630 case TYDREAL: 00631 case TYLOGICAL1: 00632 case TYLOGICAL2: 00633 p = (Addrp) cpexpr((expptr)retslot); 00634 p->vtype = t; 00635 p1_subr_ret (mkconv (t, fixtype((expptr)p))); 00636 break; 00637 00638 default: 00639 badtype("retval", t); 00640 } 00641 } |
|
Definition at line 1682 of file proc.c. References autovar(), Dimblock::baseoffset, Dimblock::basexpr, CLUNKNOWN, CLVAR, cpexpr(), dclerr(), Dimblock::dims, err, errext(), EXNULL, frexpr(), Nameblock::fvarname, Expression::headblock, i, ICON, ISCONST, ISINT, mkconv(), mkexpr(), Dimblock::ndim, Dimblock::nelt, new_vars, OPMINUS, OPPLUS, OPSTAR, PNULL, q, TYINT, Nameblock::vclass, Nameblock::vdim, Nameblock::vdimfinish, Nameblock::vlastdim, and Headblock::vtype. Referenced by yyparse().
01684 { 01685 register expptr q, t; 01686 register struct Dimblock *p; 01687 int i; 01688 extern chainp new_vars; 01689 char buf[256]; 01690 01691 if(v->vclass == CLUNKNOWN) 01692 v->vclass = CLVAR; 01693 else if(v->vclass != CLVAR) 01694 { 01695 dclerr("only variables may be arrays", v); 01696 return; 01697 } 01698 01699 v->vdim = p = (struct Dimblock *) 01700 ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); 01701 p->ndim = nd--; 01702 p->nelt = ICON(1); 01703 doin_setbound = 1; 01704 01705 if (noextflag) 01706 for(i = 0; i <= nd; i++) 01707 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)) 01708 || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) { 01709 sprintf(buf, "dimension %d of %s is not an integer.", 01710 i+1, v->fvarname); 01711 errext(buf); 01712 break; 01713 } 01714 01715 for(i = 0; i <= nd; i++) { 01716 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))) 01717 dims[i].lb = mkconv(TYINT, q); 01718 if (((q = dims[i].ub) && !ISINT(q->headblock.vtype))) 01719 dims[i].ub = mkconv(TYINT, q); 01720 } 01721 01722 for(i = 0; i <= nd; ++i) 01723 { 01724 if( (q = dims[i].ub) == NULL) 01725 { 01726 if(i == nd) 01727 { 01728 frexpr(p->nelt); 01729 p->nelt = NULL; 01730 } 01731 else 01732 err("only last bound may be asterisk"); 01733 p->dims[i].dimsize = ICON(1); 01734 p->dims[i].dimexpr = NULL; 01735 } 01736 else 01737 { 01738 01739 if(dims[i].lb) 01740 { 01741 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); 01742 q = mkexpr(OPPLUS, q, ICON(1) ); 01743 } 01744 if( ISCONST(q) ) 01745 { 01746 p->dims[i].dimsize = q; 01747 p->dims[i].dimexpr = (expptr) PNULL; 01748 } 01749 else { 01750 sprintf(buf, " %s_dim%d", v->fvarname, i+1); 01751 p->dims[i].dimsize = (expptr) 01752 autovar(1, tyint, EXNULL, buf); 01753 p->dims[i].dimexpr = q; 01754 if (i == nd) 01755 v->vlastdim = new_vars; 01756 v->vdimfinish = 1; 01757 } 01758 if(p->nelt) 01759 p->nelt = mkexpr(OPSTAR, p->nelt, 01760 cpexpr(p->dims[i].dimsize) ); 01761 } 01762 } 01763 01764 q = dims[nd].lb; 01765 if(q == NULL) 01766 q = ICON(1); 01767 01768 for(i = nd-1 ; i>=0 ; --i) 01769 { 01770 t = dims[i].lb; 01771 if(t == NULL) 01772 t = ICON(1); 01773 if(p->dims[i].dimsize) 01774 q = mkexpr(OPPLUS, t, 01775 mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q)); 01776 } 01777 01778 if( ISCONST(q) ) 01779 { 01780 p->baseoffset = q; 01781 p->basexpr = NULL; 01782 } 01783 else 01784 { 01785 sprintf(buf, " %s_offset", v->fvarname); 01786 p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf); 01787 p->basexpr = q; 01788 v->vdimfinish = 1; 01789 } 01790 doin_setbound = 0; 01791 } |
|
Definition at line 1656 of file proc.c. References CLPROC, CLUNKNOWN, dclerr(), PEXTERNAL, PUNKNOWN, Nameblock::vclass, and Nameblock::vprocclass. Referenced by yyparse().
01658 { 01659 if(v->vclass == CLUNKNOWN) 01660 v->vclass = CLPROC; 01661 else if(v->vclass != CLPROC) 01662 dclerr("invalid external declaration", v); 01663 01664 if(v->vprocclass == PUNKNOWN) 01665 v->vprocclass = PEXTERNAL; 01666 else if(v->vprocclass != PEXTERNAL) 01667 dclerr("invalid external declaration", v); 01668 } /* setext */ |
|
!??!! Definition at line 1616 of file proc.c. References CLPROC, CLUNKNOWN, dclerr(), Nameblock::fvarname, intrfunct(), PINTRINSIC, PUNKNOWN, STGINTR, STGUNKNOWN, Nameblock::vardesc, Nameblock::vclass, Nameblock::vprocclass, and Nameblock::vstg. Referenced by yyparse().
01618 { 01619 int k; 01620 01621 if(k = intrfunct(v->fvarname)) { 01622 if ((*(struct Intrpacked *)&k).f4) 01623 if (noextflag) 01624 goto unknown; 01625 else 01626 dcomplex_seen++; 01627 v->vardesc.varno = k; 01628 } 01629 else { 01630 unknown: 01631 dclerr("unknown intrinsic function", v); 01632 return; 01633 } 01634 if(v->vstg == STGUNKNOWN) 01635 v->vstg = STGINTR; 01636 else if(v->vstg!=STGINTR) 01637 dclerr("incompatible use of intrinsic function", v); 01638 if(v->vclass==CLUNKNOWN) 01639 v->vclass = CLPROC; 01640 if(v->vprocclass == PUNKNOWN) 01641 v->vprocclass = PINTRINSIC; 01642 else if(v->vprocclass != PINTRINSIC) 01643 dclerr("invalid intrinsic declaration", v); 01644 } |
|
Definition at line 1451 of file proc.c. References autovar(), changedtype(), Constant::ci, CLMAIN, CLPROC, Constblock::Const, Expression::constblock, dclerr(), errstr(), frexpr(), Nameblock::fvarname, ICON, INDATA, lengtype(), MSKCHAR, MSKCOMPLEX, ONEOF, PTHISPROC, STGARG, STGEXT, STGUNKNOWN, Nameblock::vardesc, Nameblock::vclass, Nameblock::vimpltype, Nameblock::vinfproc, Nameblock::vinftype, Nameblock::vleng, Nameblock::vprocclass, Nameblock::vstg, and Nameblock::vtype. Referenced by entrypt(), excall(), impldcl(), and yyparse().
01453 { 01454 int type1; 01455 01456 if(type == TYUNKNOWN) 01457 return; 01458 01459 if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) 01460 { 01461 v->vtype = TYSUBR; 01462 frexpr(v->vleng); 01463 v->vleng = 0; 01464 v->vimpltype = 0; 01465 } 01466 else if(type < 0) /* storage class set */ 01467 { 01468 if(v->vstg == STGUNKNOWN) 01469 v->vstg = - type; 01470 else if(v->vstg != -type) 01471 dclerr("incompatible storage declarations", v); 01472 } 01473 else if(v->vtype == TYUNKNOWN 01474 || v->vtype != type 01475 && (v->vimpltype || v->vinftype || v->vinfproc)) 01476 { 01477 if( (v->vtype = lengtype(type, length))==TYCHAR ) 01478 if (length>=0) 01479 v->vleng = ICON(length); 01480 else if (parstate >= INDATA) 01481 v->vleng = ICON(1); /* avoid a memory fault */ 01482 v->vimpltype = 0; 01483 v->vinftype = 0; /* 19960709 */ 01484 v->vinfproc = 0; /* 19960709 */ 01485 01486 if (v->vclass == CLPROC) { 01487 if (v->vstg == STGEXT 01488 && (type1 = extsymtab[v->vardesc.varno].extype) 01489 && type1 != v->vtype) 01490 changedtype(v); 01491 else if (v->vprocclass == PTHISPROC 01492 && (parstate >= INDATA 01493 || procclass == CLMAIN) 01494 && !xretslot[type]) { 01495 xretslot[type] = autovar(ONEOF(type, 01496 MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, 01497 v->vleng, " ret_val"); 01498 if (procclass == CLMAIN) 01499 errstr( 01500 "illegal use of %.60s (main program name)", 01501 v->fvarname); 01502 /* not completely right, but enough to */ 01503 /* avoid memory faults; we won't */ 01504 /* emit any C as we have illegal Fortran */ 01505 } 01506 } 01507 } 01508 else if(v->vtype!=type) { 01509 incompat: 01510 dclerr("incompatible type declarations", v); 01511 } 01512 else if (type==TYCHAR) 01513 if (v->vleng && v->vleng->constblock.Const.ci != length) 01514 goto incompat; 01515 else if (parstate >= INDATA) 01516 v->vleng = ICON(1); /* avoid a memory fault */ 01517 } |
|
Definition at line 433 of file proc.c. References ALLOC, CLBLOCK, CLMAIN, CLPROC, CNULL, endproc(), Entrypoint::entryname, entrypt(), Extsym::extinit, mkname(), newentry(), newproc(), and puthead(). Referenced by yyparse().
00435 { 00436 register struct Entrypoint *p; 00437 00438 p = ALLOC(Entrypoint); 00439 if(classKRH == CLMAIN) { 00440 puthead(CNULL, CLMAIN); 00441 if (progname) 00442 strcpy (main_alias, progname->cextname); 00443 } else { 00444 if (progname) { 00445 /* Construct an empty subroutine with this name */ 00446 /* in case the name is needed to force loading */ 00447 /* of this block-data subprogram: the name can */ 00448 /* appear elsewhere in an external statement. */ 00449 entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0); 00450 endproc(); 00451 newproc(); 00452 } 00453 puthead(CNULL, CLBLOCK); 00454 } 00455 if(classKRH == CLMAIN) 00456 newentry( mkname(" MAIN"), 0 )->extinit = 1; 00457 p->entryname = progname; 00458 entries = p; 00459 00460 procclass = classKRH; 00461 fprintf(diagfile, " %s", (classKRH==CLMAIN ? "MAIN" : "BLOCK DATA") ); 00462 if(progname) { 00463 fprintf(diagfile, " %s", progname->fextname); 00464 procname = progname->cextname; 00465 } 00466 fprintf(diagfile, ":\n"); 00467 fflush(diagfile); 00468 } |
|
Definition at line 106 of file proc.c. References IDENT_LEN, mem(), q, UNAM_CHARP, and UNAM_IDENT. Referenced by autovar(), and doentry().
00108 { 00109 register int k; 00110 register char *t; 00111 00112 k = strlen(s); 00113 if (k < IDENT_LEN) { 00114 q->uname_tag = UNAM_IDENT; 00115 t = q->user.ident; 00116 } 00117 else { 00118 q->uname_tag = UNAM_CHARP; 00119 q->user.Charp = t = mem(k+1, 0); 00120 } 00121 strcpy(t, s); 00122 } |
|
Definition at line 1801 of file proc.c. References Extsym::curno, Nameblock::cvarname, extern_out(), name, nice_printf(), out_name(), Nameblock::varno, and Nameblock::visused. Referenced by endproc(), and start_formatting().
01803 { 01804 for (; vars; vars = vars -> nextp) { 01805 Namep name = (Namep) vars -> datap; 01806 if (!name->visused) 01807 continue; 01808 01809 if (function_head) 01810 nice_printf (outfile, "#define "); 01811 else 01812 nice_printf (outfile, "#undef "); 01813 out_name (outfile, name); 01814 01815 if (function_head) { 01816 Extsym *comm = &extsymtab[name -> vardesc.varno]; 01817 01818 nice_printf (outfile, " ("); 01819 extern_out (outfile, comm); 01820 nice_printf (outfile, "%d.", comm->curno); 01821 nice_printf (outfile, "%s)", name->cvarname); 01822 } /* if function_head */ 01823 nice_printf (outfile, "\n"); 01824 } /* for */ 01825 } /* wr_abbrevs */ |
|
Definition at line 308 of file proc.c. References Argtypes::changes, Chain::datap, frchain(), Chain::nextp, prev_proc, proc_argchanges, and proc_protochanges. Referenced by endproc().
00309 { 00310 register chainp cp; 00311 register Argtypes *at; 00312 00313 /* arrange to get correct count of prototypes that would 00314 change by running f2c again */ 00315 00316 if (prev_proc && proc_argchanges) 00317 proc_protochanges++; 00318 prev_proc = proc_argchanges = 0; 00319 for(cp = new_procs; cp; cp = cp->nextp) 00320 if (at = ((Namep)cp->datap)->arginfo) 00321 at->changes &= ~1; 00322 frchain(&new_procs); 00323 } |
Variable Documentation
|
Definition at line 46 of file proc.c. Referenced by comblock(), and docomleng(). |
|
Definition at line 54 of file proc.c. Referenced by mkfunct(). |
|
Initial value: { "g", "h", "i", "j", "r", "d", "c", "z", "g", "h", "i" } Definition at line 48 of file proc.c. Referenced by fix_entry_returns(), and putentries(). |
|
Definition at line 55 of file proc.c. Referenced by doentry(), newentry(), and zap_changes(). |
|
Definition at line 55 of file proc.c. Referenced by doentry(), save_argtypes(), type_fixup(), and zap_changes(). |
|
Definition at line 55 of file proc.c. Referenced by atype_squawk(), changedtype(), save_argtypes(), and zap_changes(). |