/* * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved. * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. * */ /** * \file * \brief Fortran - symbol table access module. * This module contains the routines used to initialize, update, access, and * dump the symbol table. Note that in addition to being used by PGHPF, this * module is used by the utility program, symini, which processes intrinsic and * generic definitions in order to set up the initial symbol table for PGHPF. */ #include "gbldefs.h" #include "global.h" #include "error.h" #include "machar.h" #include "symtab.h" #include "symtabdf.h" #include "symutl.h" #include "syminidf.h" #include "dtypeutl.h" #include "soc.h" #include "state.h" #include "ast.h" #include "semant.h" #include "llmputil.h" #include "rtlRtns.h" #include /* During IPA recompilations, compiler-generated temporary names * need to be distinct from the names that were used on the first * compile. */ #define IPA_RECOMPILATION_SUFFIX (XBIT(89, 0x40) ? "i" : "") /* implicit data types */ typedef struct { int dtype; LOGICAL set, anyset; /* True if set by IMPLICIT stmt */ LOGICAL typ8; /* True if the type is altered by -r8 */ } DTIMPL[26 + 26 + 2]; typedef struct { SPTR dec_sptr; SPTR def_sptr; } DEC_DEF_MAP; static DTIMPL dtimplicit; static int dtimplicitsize = 0; static DTIMPL *save_dtimplicit = NULL; static int dtimplicitstack = 0; static void cng_inttyp(int, int); static void cng_specific(int, int); static void generate_type_mismatch_errors(SPTR s1, SPTR s2); static void update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies); /* entry hack? */ static ENTRY onlyentry; /*--------------------------------------------------------------------------*/ /** * Initialize symbol table for new user program unit. */ void sym_init(void) { int i; INT tmp[2], res[2]; int dtype; static char *npname = "hpf_np$"; int sptr; /* allocate symbol table and name table space: */ sym_init_first(); init_chartab(); /* see dtypeutl.c */ STG_RESET(stb.dt); STG_NEXT_SIZE(stb.dt, DT_MAX); for (i = 0; i <= DT_MAX; ++i) DTY(i) = pd_dtype[i]; if (XBIT(49, 0x800000)) { DT_REAL = DT_REAL8; DT_CMPLX = DT_CMPLX16; if (XBIT(49, 0x200)) { DT_DBLE = DT_REAL8; DT_DCMPLX = DT_CMPLX16; } else { DT_DBLE = DT_QUAD; DT_DCMPLX = DT_QCMPLX; } } if (XBIT(49, 0x80000000)) { DT_INT = DT_INT8; DT_LOG = DT_LOG8; } if (XBIT(49, 0x100) && !XBIT(125, 0x2000)) { DT_PTR = DT_INT8; } if (!XBIT(124, 0x10)) { stb.user.dt_int = DT_INT; stb.user.dt_log = DT_LOG; } else { /* -i8 */ stb.user.dt_int = DT_INT8; stb.user.dt_log = DT_LOG8; } if (!XBIT(124, 0x8)) { stb.user.dt_real = DT_REAL; stb.user.dt_cmplx = DT_CMPLX; } else { /* -r8 */ stb.user.dt_real = DT_DBLE; stb.user.dt_cmplx = DT_DCMPLX; } /* * Set up initial implicit types. All are real except for the letters i * thru n: */ init_implicit(); /* * now initialize symbol table. There are 2 cases: The first case occurs * within the utility symini - we start with a totally empty symbol * table. The second case occurs within PGHPF - the initial symbol table is * copied from some arrays set up by symini. */ #if DEBUG assert(stb.stg_size >= INIT_SYMTAB_SIZE, "sym_init:INIT_SYMTAB_SIZE", INIT_SYMTAB_SIZE, 0); #endif BCOPY(stb.stg_base, init_sym, SYM, INIT_SYMTAB_SIZE); stb.stg_avail = INIT_SYMTAB_SIZE; stb.stg_cleared = INIT_SYMTAB_SIZE; #if DEBUG assert(stb.n_size >= INIT_NAMES_SIZE, "sym_init:INIT_NAMES_SIZE", INIT_NAMES_SIZE, 0); #endif BCOPY(stb.n_base, init_names, char, INIT_NAMES_SIZE); stb.namavl = INIT_NAMES_SIZE; BCOPY(stb.hashtb, init_hashtb, int, HASHSIZE); if (XBIT(124, 0x10)) { /* -i8 */ cng_inttyp(intast_sym[I_ICHAR], DT_INT8); } /* change the specific intrinsics whose types are DT_QUAD and DT_QCMPLX * if the the '-dp' switch is present. This could be within a #ifdef C90, * but we do build the T3E/C90 pghpfc on solaris. */ if (XBIT(49, 0x200)) for (i = 1; i < INIT_SYMTAB_SIZE; i++) if (STYPEG(i) == ST_INTRIN) { if (INTTYPG(i) == DT_QUAD) INTTYPP(i, DT_REAL8); else if (INTTYPG(i) == DT_QCMPLX) INTTYPP(i, DT_CMPLX16); if (ARGTYPG(i) == DT_QUAD) ARGTYPP(i, DT_REAL8); else if (ARGTYPG(i) == DT_QCMPLX) ARGTYPP(i, DT_CMPLX16); } /* * enter constants into symbol table: * * * * * * * * * * * N O T E * * * * * * * * * * * * * * * * * * * N O T E * * * * * * * * * * DO NOT CHANGE the order of entering these predefined symbols. * To add a predefined, insert it between the last getcon/getsym * and where stb.firstosym is set. */ /* int 0, 1 */ tmp[0] = tmp[1] = (INT)0; stb.i0 = getcon(tmp, DT_INT); if (DT_INT == DT_INT8) stb.k0 = stb.i0; else if (!XBIT(57, 0x2)) stb.k0 = getcon(tmp, DT_INT8); else stb.k0 = 0; tmp[1] = (INT)1; stb.i1 = getcon(tmp, DT_INT); if (DT_INT == DT_INT8) stb.k1 = stb.i1; else if (!XBIT(57, 0x2)) stb.k1 = getcon(tmp, DT_INT8); else stb.k1 = 0; add_fp_constants(); /* * * * * * * * * * * N O T E * * * * * * * * * * NO MORE predefined contants until immediately before * stb.firstosym is set ... */ /* create symbol hpf_np$ */ sptr = getsymbol(npname); STYPEP(sptr, ST_UNKNOWN); DTYPEP(sptr, DT_INT); DCLDP(sptr, 1); SCP(sptr, SC_LOCAL); NODESCP(sptr, 1); gbl.sym_nproc = sptr; if (XBIT(70, 0x80000000)) { int bsym; SCP(sptr, SC_BASED); bsym = getsymf("%sp", npname); /* hpf_np$p */ STYPEP(bsym, ST_UNKNOWN); DTYPEP(bsym, DT_PTR); DCLDP(bsym, 1); SCP(bsym, SC_LOCAL); NODESCP(bsym, 1); MIDNUMP(sptr, bsym); } /* allocate space for auxiliary symtab structures: */ if (aux.dpdsc_size <= 0) { aux.dpdsc_size = 100; NEW(aux.dpdsc_base, int, aux.dpdsc_size); } aux.dpdsc_avl = 1; /* 0 => null DPDSC field */ aux.dpdsc_base[0] = 0; if (aux.arrdsc_size <= 0) { aux.arrdsc_size = 200; NEW(aux.arrdsc_base, int, aux.arrdsc_size); } aux.arrdsc_base[0] = 0; /* numdim=0 if array descriptor is zero */ aux.arrdsc_avl = 1; if (aux.nml_size <= 0) { aux.nml_size = 200; NEW(aux.nml_base, NMLDSC, aux.nml_size); } aux.nml_avl = 1; aux.nml_base[0].sptr = 0; aux.nml_base[0].next = 0; aux.nml_base[0].lineno = 0; if (!XBIT(7, 0x100000)) { if (aux.dvl_size <= 0) { aux.dvl_size = 32; NEW(aux.dvl_base, DVL, aux.dvl_size); } aux.dvl_avl = 0; } if (aux.symi_size <= 0) { aux.symi_size = 100; NEW(aux.symi_base, SYMI, aux.symi_size); } aux.symi_avl = 1; /* 0 => end of list */ aux.symi_base[0].sptr = 0; aux.symi_base[0].next = 0; /* * * * * * * * * * * N O T E * * * * * * * * * * More predefined constants after ORIGINAL set; note the * value of NXTRA (number of post-original symbols. */ tmp[0] = 0; res[0] = 0; tmp[1] = CONVAL2G(stb.flt0); xfneg(tmp[1], &res[1]); stb.fltm0 = getcon(res, DT_REAL4); tmp[0] = CONVAL1G(stb.dbl0); tmp[1] = CONVAL2G(stb.dbl0); xdneg(tmp, res); stb.dblm0 = getcon(res, DT_DBLE); #define NXTRA 2 aux.curr_entry = &onlyentry; stb.firstusym = stb.firstosym = stb.stg_avail; stb.lbavail = 99999; for (i = 0; i < ST_MAX; i++) aux.list[i] = NOSYM; /* 'empty' list for each stype */ soc.avail = 1; if ((gbl.internal == 0) && (flg.ipa & 0x100) == 0) { /* clear at outer routines, but not for static$init routines */ if (gbl.currmod == 0) { dtimplicitstack = 0; } else { dtimplicitstack = 1; } } symutl.sc = SC_LOCAL; llmp_reset_uplevel(); } static void cng_inttyp(int ss, int dt) { #if DEBUG assert(STYPEG(ss) == ST_INTRIN, "cng_inttyp not intr", ss, 3); #endif INTTYPP(ss, dt); } static void cng_specific(int os, int ns) { #if DEBUG assert(STYPEG(os) == ST_INTRIN, "cng_specific not intr", os, 3); assert(STYPEG(ns) == ST_INTRIN, "cng_specific not intr", ns, 3); #endif dup_sym(os, &stb.stg_base[ns]); } /** * Set up initial implicit types. All are real except for the letters i * thru n: */ void init_implicit(void) { int i; int default_real; int default_int; for (i = 0; i < 54; i++) { dtimplicit[i].dtype = stb.user.dt_real; dtimplicit[i].set = FALSE; dtimplicit[i].anyset = FALSE; /* not explicit set anywhere */ if (XBIT(124, 0x8) && !XBIT(49, 0x800000)) { dtimplicit[i].typ8 = TRUE; } else { dtimplicit[i].typ8 = FALSE; } } default_int = flg.i4 ? stb.user.dt_int : DT_SINT; implicit_int(default_int); } /** * simple routine to reset the default integer type for implicitly typing * integer variables. Needed for compile-type processing of -i4/-noi4 * options in OPTIONS statement. */ void implicit_int(int default_int) { int i; for (i = 8; i <= 13; i++) { dtimplicit[i].dtype = dtimplicit[i + 26].dtype = default_int; dtimplicit[i].typ8 = dtimplicit[i + 26].typ8 = FALSE; } } void save_implicit(LOGICAL reset) { if (save_dtimplicit == NULL) { dtimplicitsize = 4; NEW(save_dtimplicit, DTIMPL, dtimplicitsize); BZERO(save_dtimplicit, DTIMPL, dtimplicitsize); } else { NEED(dtimplicitstack + 1, save_dtimplicit, DTIMPL, dtimplicitsize, dtimplicitsize * 2); } BCOPY(save_dtimplicit[dtimplicitstack], dtimplicit, DTIMPL, 1); ++dtimplicitstack; if (reset) { int i; for (i = 0; i < 54; i++) { dtimplicit[i].set = FALSE; /* not explicitly set at this level */ } } } void restore_implicit(void) { if (dtimplicitstack <= 0) interr("IMPLICIT stack too shallow", dtimplicitstack, 3); --dtimplicitstack; BCOPY(dtimplicit, save_dtimplicit[dtimplicitstack], DTIMPL, 1); } /** * Return the first & last sym pointers for the HPF_LIBRARY procedures. * Initially, the stype of the HPF library procedures is ST_HL; * when the USE statement is seen, the stype of these symbols is changed * to ST_PD. */ void hpf_library_stat(int *firstp, int *lastp, int stype) { if (stype == ST_CRAY) { *firstp = CRAY_FIRST; *lastp = CRAY_LAST; } #if DEBUG else { interr("hpf_library_stat:illegal stype", stype, 0); } #endif } /** * Return the first & last sym pointers for the ISO_C intrinsic * procedures. Initially, the stype of the ISO_C library procedures is ST_ISOC * when the USE statement is seen, the stype of these symbols is changed * to ST_INTRIN */ void iso_c_lib_stat(int *firstp, int *lastp, int stype) { if (stype == ST_ISOC) { *firstp = ISO_C_FIRST; *lastp = ISO_C_LAST; } #if DEBUG else { interr("iso_c_lib_stat:illegal stype", stype, 0); } #endif } extern int get_ieee_arith_intrin(char *nm) { int i; for (i = IEEEARITH_FIRST; i <= IEEEARITH_LAST; i++) { if (strcmp(SYMNAME(i), nm) == 0) return i; } return 0; } /* * Enter symbol with indicated null-terminated name into symbol table, * initialize the new entry, and return pointer to it. If there is already * such a symbol, just return pointer to the existing symbol table entry. */ int getsymbol(const char *name) { return getsym(name, strlen(name)); } /** \brief Enter symbol with indicated name into symbol table, initialize the new entry. \param name symbol name \param olength number of characters in the symbol name \return pointer to new symbol If there is already such a symbol, just return pointer to the existing symbol table entry. */ int getsym(const char *name, int olength) { int sptr; /* pointer to symbol table entry */ sptr = installsym(name, olength); switch (STYPEG(sptr)) { case ST_ISOC: case ST_IEEEARITH: case ST_IEEEEXCEPT: case ST_ISOFTNENV: case ST_CRAY: /* predefined symbol is the name of an HPF library procedure; since * the stype is ST_HL, this implies that a 'USE HPF_LIBRARY' statement * was not seen. Consequently, this symbol is a user symbol and * a new (ST_UNKNOWN) symbol must be entered into the symbol table. */ sptr = insert_sym(sptr); setimplicit(sptr); if (gbl.internal > 1) INTERNALP(sptr, 1); SCOPEP(sptr, stb.curr_scope); IGNOREP(sptr, 0); break; case ST_UNKNOWN: setimplicit(sptr); if (gbl.internal > 1) INTERNALP(sptr, 1); SCOPEP(sptr, stb.curr_scope); IGNOREP(sptr, 0); break; default: break; } return sptr; } /* Construct a name via vsnprintf(), then use it to look up or * create a symbol. */ int getsymf(const char *fmt, ...) { char buffer[MAXIDLEN + 1]; va_list ap; va_start(ap, fmt); vsnprintf(buffer, sizeof buffer, fmt, ap); va_end(ap); buffer[sizeof buffer - 1] = '\0'; /* Windows vsnprintf bug work-around */ return getsymbol(buffer); } /*--------------------------------------------------------------------------* * getcon & get_acon is identical between C and Fortran; should be shared * *--------------------------------------------------------------------------*/ /** \brief Enter constant of given dtype and value into the symbol table and return pointer to it. If an entry for the constant already exists, return pointer to the existing entry instead. */ SPTR getcon(INT *value, DTYPE dtype) { int sptr; /* symbol table pointer */ int hashval; /* index into hashtb */ /* * First loop thru the appropriate hash link list to see if this constant * is already in the symbol table: */ hashval = HASH_CON(value); if (hashval < 0) hashval = -hashval; for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) { if (DTY(dtype) == TY_QUAD) { if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST || CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1] || CONVAL3G(sptr) != value[2] || CONVAL4G(sptr) != value[3]) continue; /* Matching entry has been found. Return it: */ return (sptr); } if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST || CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1]) continue; /* Matching entry has been found. Return it: */ return (sptr); } /* Constant not found. Create a new symbol table entry for it: */ ADDSYM(sptr, hashval); STYPEP(sptr, ST_CONST); CONVAL1P(sptr, value[0]); CONVAL2P(sptr, value[1]); if (DTY(dtype) == TY_QUAD) { CONVAL3P(sptr, value[2]); CONVAL4P(sptr, value[3]); } DTYPEP(sptr, dtype); SCOPEP(sptr, 1); return (sptr); } /* constant value (value[1] if 1 word) */ int hashcon(INT *value, int dtype, int sptr) { int sptr1; /* symbol table pointer */ int hashval; /* index into hashtb */ /* * First loop thru the appropriate hash link list to see if this constant * is already in the symbol table: */ hashval = HASH_CON(value); if (hashval < 0) hashval = -hashval; for (sptr1 = stb.hashtb[hashval]; sptr1 != 0; sptr1 = HASHLKG(sptr1)) { if (sptr1 == sptr) return (sptr); } /* sptr not found. */ HASHLKP(sptr, stb.hashtb[hashval]); stb.hashtb[hashval] = sptr; return (sptr); } SPTR get_acon(SPTR sym, ISZ_T off) { return get_acon3(sym, off, DT_CPTR); } /* * BIGOBJects are supported, need an acon-specific getcon */ SPTR get_acon3(SPTR sym, ISZ_T off, DTYPE dtype) { INT value[2]; int sptr; /* symbol table pointer */ int hashval; /* index into stb.hashtb */ /* * First loop thru the appropriate hash link list to see if this constant * is already in the symbol table: */ bgitoi64(off, value); value[0] = sym; hashval = HASH_CON(value); if (hashval < 0) hashval = -hashval; for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) { if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST || CONVAL1G(sptr) != sym || ACONOFFG(sptr) != off) continue; /* Matching entry has been found. Return it: */ return (sptr); } /* Constant not found. Create a new symbol table entry for it: */ ADDSYM(sptr, hashval); CONVAL1P(sptr, sym); ACONOFFP(sptr, off); STYPEP(sptr, ST_CONST); DTYPEP(sptr, dtype); SCOPEP(sptr, 1); return (sptr); } ISZ_T get_isz_cval(int con) { INT num[2]; ISZ_T v; #if DEBUG assert(STYPEG(con) == ST_CONST, "get_isz_cval-not ST_CONST", con, 0); assert(DT_ISINT(DTYPEG(con)) || DT_ISLOG(DTYPEG(con)), "get_int_cval-not int const", con, 0); #endif if (XBIT(68, 0x1)) { if (size_of(DTYPEG(con)) <= 4) return get_int_cval(con); } num[0] = CONVAL1G(con); num[1] = CONVAL2G(con); INT64_2_ISZ(num, v); return v; } /** * Retrieve the value of an integer constant symbol table entry and * return as an 'INT'. Coerce TY_INT8 values if necessary. */ INT get_int_cval(int con) { INT res; DBLINT64 inum; #if DEBUG assert(STYPEG(con) == ST_CONST, "get_int_cval-not ST_CONST", con, 0); assert(DT_ISINT(DTYPEG(con)) || DT_ISLOG(DTYPEG(con)), "get_int_cval-not int const", con, 0); #endif switch (DTY(DTYPEG(con))) { case TY_INT8: case TY_LOG8: res = CONVAL2G(con); break; default: res = CONVAL2G(con); break; } return res; } /** * Sign extend an integer value of an indicated width (8, 16, 32); value * returned is sign extended with respect to the host's int type. */ INT sign_extend(INT val, int width) { /* 32-bit INT */ int w; if (width == 32) return val; w = 32 - width; return ARSHIFT(LSHIFT(val, w), w); } /*--------------------------------------------------------------------------*/ /** \brief Enter character constant into symbol table and return pointer to it. \param value character string value \param length length of character string If the constant is already in the table, return pointer to the existing entry instead. */ int getstring(char *value, int length) { int sptr; /* symbol table pointer */ int hashval; /* index into hashtb */ char *np; /* pointer to string characters */ char *p; int i, clen; int dtype; /* * first loop thru the appropriate hash link list to see if symbol is * already in the table: */ HASH_STR(hashval, value, length); /* Ensure hash value is positive. '\nnn' can cause negative hash values */ if (hashval < 0) hashval = -hashval; for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) { if (STYPEG(sptr) != ST_CONST) continue; i = DTYPEG(sptr); if (DTY(i) == TY_CHAR) { clen = DTY(i + 1); if (clen > 0 && A_ALIASG(clen)) { clen = A_ALIASG(clen); clen = A_SPTRG(clen); clen = CONVAL2G(clen); if (clen == length) { /* now match the characters in the strings: */ np = stb.n_base + CONVAL1G(sptr); p = value; i = length; while (i--) if (*np++ != *p++) goto Continue; /* Matching entry has been found in symtab. Return it: */ return sptr; } } } Continue:; } /* String not found. Create a new symtab entry for it: */ dtype = get_type(2, TY_CHAR, mk_cval(length, DT_INT4)); ADDSYM(sptr, hashval); STYPEP(sptr, ST_CONST); CONVAL1P(sptr, putsname(value, length)); DTYPEP(sptr, dtype); SCOPEP(sptr, 1); return (sptr); } /*--------------------------------------------------------------------------*/ /** * Create a 'kinded' hollerith constant from a string constant and return the * pointer to it. If the constant is already in the table, return pointer to * the existing entry. Possible kind values are: * 'h' - left justifed, blank filled. * 'l' - left justfied, zero filled. * 'r' - right justfied, zero filled. */ int gethollerith(int strcon, int kind) { INT val[2]; int sptr; val[0] = strcon; val[1] = kind; sptr = getcon(val, DT_HOLL); HOLLP(sptr, 1); return sptr; } /*--------------------------------------------------------------------------*/ /** \brief Change the current settings for implicit variable types and character lengths. \param firstc characters delimiting range \param lastc new value assigned to range \param dtype data type */ void newimplicit(int firstc, int lastc, int dtype) { int i, j; /* indices into implicit arrays */ char temp[2]; i = IMPL_INDEX(firstc); /* IMPL_INDEX is defined in symtab.h */ j = IMPL_INDEX(lastc); #if DEBUG assert(i >= 0 && j >= 0 && i < 54 && j < 54, "newimplicit: bad impl range", i, 4); #endif for (; i <= j; i++) { if (dtimplicit[i].set) { /* already set */ temp[0] = 'a' + i; temp[1] = 0; if (dtype == dtimplicit[i].dtype) error(54, 2, gbl.lineno, temp, CNULL); else error(54, 3, gbl.lineno, temp, CNULL); } dtimplicit[i].dtype = dtype; dtimplicit[i].set = TRUE; dtimplicit[i].anyset = TRUE; /* explicitly set */ dtimplicit[i].typ8 = FALSE; } } void newimplicitnone(void) { int i; for (i = 0; i < 54; ++i) { dtimplicit[i].anyset = FALSE; /* explicit reset */ } } /* newimplicitnone */ /*--------------------------------------------------------------------------*/ /** * assign to the indicated symbol table entry, the current implicit dtype. */ void setimplicit(int sptr) { int firstc; /* first character of symbol name */ int i; /* index into implicit tables defined by the * first character of the name of sptr. */ firstc = *SYMNAME(sptr); /* * determine index into implicit array. Note that the value returned * will be -1 if this routine is being called from within the symini * utility for a symbol beginning with ".". */ i = IMPL_INDEX(firstc); if (i != -1) { DTYPEP(sptr, dtimplicit[i].dtype); } } /** \brief Return FALSE if this symbol could not have been properly implicitly * typed */ LOGICAL was_implicit(int sptr) { int firstc, i; firstc = *SYMNAME(sptr); i = IMPL_INDEX(firstc); if (symutl.none_implicit && !dtimplicit[i].anyset) return FALSE; return TRUE; } /* was_implicit */ /** \brief Return ptr to printable representation of the indicated PARAMETER. \param sptr symbol table pointer */ char * parmprint(int sptr) { int dtype; char *buf; INT save; if (STYPEG(sptr) != ST_PARAM) return ""; /* * Change the symbol table entry to an ST_CONST use getprint * to get the character representation. */ STYPEP(sptr, ST_CONST); dtype = DTYPEG(sptr); if (DTY(dtype) == TY_SINT || DTY(dtype) == TY_BINT || DTY(dtype) == TY_HOLL || DTY(dtype) == TY_WORD) DTYPEP(sptr, DT_INT); else if (DTY(dtype) == DT_SLOG || DTY(dtype) == DT_BLOG) DTYPEP(sptr, DT_LOG); if (TY_ISWORD(DTY(dtype))) { save = CONVAL2G(sptr); CONVAL2P(sptr, CONVAL1G(sptr)); buf = getprint(sptr); CONVAL2P(sptr, save); } else buf = getprint((int)CONVAL1G(sptr)); STYPEP(sptr, ST_PARAM); DTYPEP(sptr, dtype); return buf; } /*---------------------------------------------------------------------* * getprint cannot be shared between FORTRAN and C * *---------------------------------------------------------------------*/ /** * Return ptr to printable representation of the indicated symbol. For * symbols which are not constants, the name of the symbol is used. * Constants are converted into the appropriate character representation. */ static char * __log_print(INT val) { if (val == 0) return ".FALSE."; return ".TRUE."; } /** \param sptr symbol table pointer */ char * getprint(int sptr) { int len; /* length of character string */ static char *b = NULL; char *from, *end, *to; int c; INT num[4]; int dtype; if (sptr == 0) return ".0."; if (sptr < 0) return ".neg."; if (sptr >= stb.stg_avail) return ".toobig."; if (STYPEG(sptr) != ST_CONST) return SYMNAME(sptr); if (b == NULL) { NEW(b, char, 100); } dtype = DTYPEG(sptr); switch (DTY(dtype)) { case TY_WORD: sprintf(b, "%08X", CONVAL2G(sptr)); break; case TY_DWORD: sprintf(b, "%08X%08X", CONVAL1G(sptr), CONVAL2G(sptr)); break; case TY_BINT: sprintf(b, "%d_1", CONVAL2G(sptr)); break; case TY_SINT: sprintf(b, "%d_2", CONVAL2G(sptr)); break; case TY_INT: sprintf(b, "%d", CONVAL2G(sptr)); break; case TY_INT8: num[0] = CONVAL1G(sptr); num[1] = CONVAL2G(sptr); ui64toax(num, b, 22, 0, 10); break; case TY_BLOG: sprintf(b, "%s_1", __log_print(CONVAL2G(sptr))); break; case TY_SLOG: sprintf(b, "%s_2", __log_print(CONVAL2G(sptr))); break; case TY_LOG: case TY_LOG8: sprintf(b, "%s", __log_print(CONVAL2G(sptr))); break; case TY_REAL: num[0] = CONVAL2G(sptr); cprintf(b, "%17.10e", (INT*)(size_t)(num[0])); break; case TY_DBLE: num[0] = CONVAL1G(sptr); num[1] = CONVAL2G(sptr); cprintf(b, "%24.17le", num); break; case TY_QUAD: num[0] = CONVAL1G(sptr); num[1] = CONVAL2G(sptr); num[2] = CONVAL3G(sptr); num[3] = CONVAL4G(sptr); cprintf(b, "%44.37qd", num); break; case TY_CMPLX: num[0] = CONVAL1G(sptr); cprintf(b, "%17.10e", (INT*)(size_t)(num[0])); b[17] = ','; b[18] = ' '; num[0] = CONVAL2G(sptr); cprintf(&b[19], "%17.10e", (INT*)(size_t)(num[0])); break; case TY_DCMPLX: num[0] = CONVAL1G(CONVAL1G(sptr)); num[1] = CONVAL2G(CONVAL1G(sptr)); cprintf(b, "%24.17le", num); b[24] = ','; b[25] = ' '; num[0] = CONVAL1G(CONVAL2G(sptr)); num[1] = CONVAL2G(CONVAL2G(sptr)); cprintf(&b[26], "%24.17le", num); break; case TY_NCHAR: sptr = CONVAL1G(sptr); /* sptr to char string constant */ dtype = DTYPEG(sptr); goto like_char; case TY_HOLL: sptr = CONVAL1G(sptr); dtype = DTYPEG(sptr); case TY_CHAR: like_char: from = stb.n_base + CONVAL1G(sptr); len = string_length(dtype); end = b + 93; *b = '\"'; for (to = b + 1; len-- && to < end;) { c = *from++ & 0xff; if (c == '\"' || c == '\'' || c == '\\') { *to++ = '\\'; *to++ = c; } else if (c >= ' ' && c <= '~') { *to++ = c; } else if (c == '\n') { *to++ = '\\'; *to++ = 'n'; } else { *to++ = '\\'; /* Mask off 8 bits worth of unprintable character */ sprintf(to, "%03o", (c & 255)); to += 3; } } *to++ = '\"'; *to = '\0'; break; case TY_PTR: strcpy(b, "address constant"); break; default: interr("getprint:bad const dtype", sptr, 1); } return b; } /*--------------------------------------------------------------------------*/ #undef _PFG #define _PFG(cond, str) \ if (cond) \ fprintf(dfil, " %s", str) /** \param file the file \param sptr symbol currently being dumped */ void symdentry(FILE *file, int sptr) { FILE *dfil; int dscptr; /* ptr to dummy parameter descriptor list */ char buff[210]; /* text buffer used to create output lines */ char typeb[4096]; /* buffer for text of dtype */ int stype; /* symbol type of sptr */ int dtype; /* data type of sptr */ int i; dfil = file ? file : stderr; strcpy(buff, getprint(sptr)); stype = STYPEG(sptr); dtype = DTYPEG(sptr); /* write first line containing symbol name, dtype, and stype: */ if (stype == ST_CMBLK || stype == ST_LABEL || stype == ST_GENERIC || stype == ST_NML || stype == ST_USERGENERIC || stype == ST_PD ) { fprintf(dfil, "\n%-40.40s %s\n", buff, stb.stypes[stype]); } else { *typeb = '\0'; getdtype(dtype, typeb); fprintf(dfil, "\n%-40.40s %s %s\n", buff, typeb, stb.stypes[stype]); } if (UNAMEG(sptr)) { fprintf(dfil, "original uname:%s \n", stb.n_base + UNAMEG(sptr)); } /* write second line: */ fprintf(dfil, "sptr: %d hashlk: %d nmptr: %d dtype: %d scope: %d", sptr, HASHLKG(sptr), NMPTRG(sptr), DTYPEG(sptr), SCOPEG(sptr)); _PFG(INTERNALG(sptr), "internal"); fprintf(dfil, " lineno: %d", LINENOG(sptr)); fprintf(dfil, " enclfunc: %d\n", ENCLFUNCG(sptr)); switch (stype) { case ST_UNKNOWN: case ST_IDENT: case ST_VAR: case ST_ARRAY: case ST_DESCRIPTOR: case ST_STRUCT: case ST_UNION: fprintf(dfil, "dcld:%d ccsym:%d save:%d ref:%d dinit:%d", DCLDG(sptr), CCSYMG(sptr), SAVEG(sptr), REFG(sptr), DINITG(sptr)); fprintf(dfil, " vol:%d ptrv:%d cvlen:%d\n", VOLG(sptr), PTRVG(sptr), CVLENG(sptr)); fprintf(dfil, "address: %" ISZ_PF "d sc:%d(%s) symlk: %d midnum: %d ", ADDRESSG(sptr), SCG(sptr), (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na", SYMLKG(sptr), MIDNUMG(sptr)); fprintf(dfil, "socptr: %d autobj: %d\n", SOCPTRG(sptr), AUTOBJG(sptr)); fprintf(dfil, "addrtkn:%d eqv:%d hccsym:%d", ADDRTKNG(sptr), EQVG(sptr), HCCSYMG(sptr)); fprintf(dfil, " alloc:%d arg:%d seq:%d nml:%d assn:%d", ALLOCG(sptr), ARGG(sptr), SEQG(sptr), NMLG(sptr), ASSNG(sptr)); fprintf(dfil, "\nprivate:%d", PRIVATEG(sptr)); _PFG(MDALLOCG(sptr), "mdalloc"); #ifdef DYNAMICG _PFG(DYNAMICG(sptr), "dynamic"); #endif _PFG(POINTERG(sptr), "pointer"); _PFG(F90POINTERG(sptr), "f90pointer"); _PFG(TARGETG(sptr), "target"); _PFG(NOMDCOMG(sptr), "nomdcom"); _PFG(HIDDENG(sptr), "hidden"); _PFG(IGNOREG(sptr), "ignore"); #ifdef LNRZDG _PFG(LNRZDG(sptr), "lnrzd"); #endif _PFG(TYP8G(sptr), "typ8"); _PFG(ASSUMLENG(sptr), "assumlen"); _PFG(ADJLENG(sptr), "adjlen"); _PFG(PARAMG(sptr), "param"); _PFG(PASSBYVALG(sptr), "passbyval"); _PFG(PASSBYREFG(sptr), "passbyref"); _PFG(CFUNCG(sptr), "cfunc"); _PFG(STDCALLG(sptr), "stdcall"); _PFG(ALLOCATTRG(sptr), "allocattr"); _PFG(DESCARRAYG(sptr), "descarray"); _PFG(CONTIGATTRG(sptr), "contigattr"); _PFG(CLASSG(sptr), "class"); _PFG(THREADG(sptr), "thread"); _PFG(PROTECTEDG(sptr), "protected"); if (stype == ST_VAR && CCSYMG(sptr)) _PFG(ERLYSPECG(sptr), "erlyspec"); #ifdef PTRSTOREG _PFG(PTRSTOREG(sptr), "ptrstore"); #endif _PFG(DESCUSEDG(sptr), "descused"); _PFG(ALLOCDESCG(sptr), "allocdesc"); _PFG(RESHAPEDG(sptr), "reshaped"); _PFG(INTERNREFG(sptr), "internref"); #ifdef TASKG _PFG(TASKG(sptr), "task"); #endif #ifdef PARREFG _PFG(PARREFG(sptr), "parref"); #endif #ifdef NOEXTENTG _PFG(NOEXTENTG(sptr), "noextent"); #endif #if defined(TARGET_WIN) if (SCG(sptr) != SC_DUMMY) { if (DLLG(sptr) == DLL_EXPORT) fprintf(dfil, " dllexport"); else if (DLLG(sptr) == DLL_IMPORT) fprintf(dfil, " dllimport"); } #endif fprintf(dfil, " sdsc: %d", SDSCG(sptr)); fprintf(dfil, " ptroff: %d", PTROFFG(sptr)); if (NEWARGG(sptr)) fprintf(dfil, " newarg: %d", NEWARGG(sptr)); if (PARAMVALG(sptr)) fprintf(dfil, " paramval: %d", PARAMVALG(sptr)); if (SCG(sptr) == SC_CMBLK) fprintf(dfil, " cmblk: %d", CMBLKG(sptr)); if (stype == ST_ARRAY) { fprintf(dfil, "\n"); fprintf(dfil, "asumsz: %d adjarr: %d aftent: %d assumshp: %d", (int)ASUMSZG(sptr), (int)ADJARRG(sptr), (int)AFTENTG(sptr), (int)ASSUMSHPG(sptr)); fprintf(dfil, " nodesc: %d", (int)NODESCG(sptr)); } if (ADJARRG(sptr) || ADJLENG(sptr)) { fprintf(dfil, "\n"); fprintf(dfil, "adjstrlk: %d", ADJSTRLKG(sptr)); } fprintf(dfil, " descr: %d\n", DESCRG(sptr)); fprintf(dfil, "altname:%d\n", ALTNAMEG(sptr)); if (SCG(sptr) == SC_DUMMY) { _PFG(RESULTG(sptr), "result "); fprintf(dfil, "optarg:%d intent:%s", OPTARGG(sptr), INTENTG(sptr) == INTENT_IN || INTENTG(sptr) == INTENT_OUT ? (INTENTG(sptr) == INTENT_IN ? "IN" : "OUT") : "INOUT"); if (IGNORE_TKRG(sptr)) { fprintf(dfil, " IGNORE_"); if (IGNORE_TKRG(sptr) & IGNORE_T) fprintf(dfil, "T"); if (IGNORE_TKRG(sptr) & IGNORE_K) fprintf(dfil, "K"); if (IGNORE_TKRG(sptr) & IGNORE_R) fprintf(dfil, "R"); if (IGNORE_TKRG(sptr) & IGNORE_D) fprintf(dfil, "D"); if (IGNORE_TKRG(sptr) & IGNORE_M) fprintf(dfil, "M"); if (IGNORE_TKRG(sptr) & IGNORE_C) fprintf(dfil, "C"); } fprintf(dfil, "\n"); } if (stype != ST_UNKNOWN && SCG(sptr) != SC_DUMMY && SOCPTRG(sptr)) dmp_socs(sptr, dfil); if (DBGBIT(8, 4) && DTY(dtype) == TY_ARRAY) { /* print the declared array bounds */ char comma = '('; ADSC *ad; int i; static char line[200], *p; ad = AD_DPTR(dtype); p = line; for (i = 0; i < AD_NUMDIM(ad); ++i) { *p++ = comma; comma = ','; if (AD_LWBD(ad, i)) { *p = '\0'; getast(AD_LWBD(ad, i), p); p += strlen(p); *p++ = ':'; } if (AD_UPBD(ad, i)) { *p = '\0'; getast(AD_UPBD(ad, i), p); p += strlen(p); } else { *p++ = '*'; } } *p++ = ')'; *p = '\0'; fprintf(dfil, "declared bounds %s\n", line); } break; case ST_STAG: fprintf(dfil, "dcld:%d nest:%d\n", DCLDG(sptr), NESTG(sptr)); break; case ST_NML: fprintf(dfil, "symlk: %d address: %" ISZ_PF "d cmemf: %d cmeml: %d ref: %d\n", SYMLKG(sptr), ADDRESSG(sptr), CMEMFG(sptr), (int)CMEMLG(sptr), REFG(sptr)); for (i = CMEMFG(sptr); i; i = NML_NEXT(i)) fprintf(dfil, " nml:%5d sptr:%5d %s\n", i, (int)NML_SPTR(i), SYMNAME(NML_SPTR(i))); break; case ST_MEMBER: fprintf(dfil, "address:%" ISZ_PF "d symlk:%d variant:%d fnml:%d ccsym:%d", ADDRESSG(sptr), SYMLKG(sptr), VARIANTG(sptr), (int)FNMLG(sptr), CCSYMG(sptr)); fprintf(dfil, "\nencldtype:%d sc:%d(%s) private:%d", ENCLDTYPEG(sptr), SCG(sptr), (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na", PRIVATEG(sptr)); _PFG(IGNOREG(sptr), "ignore"); _PFG(POINTERG(sptr), "pointer"); #ifdef LNRZDG _PFG(LNRZDG(sptr), "lnrzd"); #endif _PFG(ALLOCG(sptr), "alloc"); _PFG(SEQG(sptr), "seq"); _PFG(ALLOCATTRG(sptr), "allocattr"); _PFG(DESCARRAYG(sptr), "descarray"); _PFG(NOPASSG(sptr), "nopass"); _PFG(CONTIGATTRG(sptr), "contigattr"); _PFG(CLASSG(sptr), "class"); fprintf(dfil, "\n"); fprintf(dfil, "ptroff:%d", PTROFFG(sptr)); fprintf(dfil, " midnum:%d", MIDNUMG(sptr)); fprintf(dfil, " sdsc:%d", SDSCG(sptr)); fprintf(dfil, " descr: %d", DESCRG(sptr)); if (PASSG(sptr)) fprintf(dfil, " pass: %d", PASSG(sptr)); #ifdef IFACEG if (IFACEG(sptr)) fprintf(dfil, " iface: %d", IFACEG(sptr)); #endif #ifdef VTABLEG if (VTABLEG(sptr)) fprintf(dfil, " vtable: %d", VTABLEG(sptr)); #endif fprintf(dfil, "\n"); break; case ST_CMBLK: fprintf(dfil, "save:%d dinit:%d size:%" ISZ_PF "d vol:%d alloc:%d", SAVEG(sptr), DINITG(sptr), SIZEG(sptr), VOLG(sptr), ALLOCG(sptr)); _PFG(THREADG(sptr), "thread"); fprintf(dfil, " seq:%d private:%d\n", SEQG(sptr), PRIVATEG(sptr)); fprintf(dfil, "hccsym:%d", HCCSYMG(sptr)); #ifdef PDALNG fprintf(dfil, " pdaln:%d%s", PDALNG(sptr), PDALN_IS_DEFAULT(sptr) ? "(default)" : ""); #endif _PFG(HIDDENG(sptr), "hidden"); _PFG(IGNOREG(sptr), "ignore"); fprintf(dfil, "\n"); fprintf(dfil, "midnum: %d symlk: %d cmemf: %d cmeml: %d\n", MIDNUMG(sptr), SYMLKG(sptr), CMEMFG(sptr), (int)CMEMLG(sptr)); fprintf(dfil, "altname: %d", ALTNAMEG(sptr)); _PFG(MODCMNG(sptr), "modcmn"); _PFG(QALNG(sptr), "qaln"); _PFG(CFUNCG(sptr), "cfunc"); _PFG(STDCALLG(sptr), "stdcall"); #ifdef TLSG _PFG(TLSG(sptr), "tls"); #endif /* TLSG */ #ifdef USE_MPC if (ETLSG(sptr)) fprintf(file, " etls: %d", ETLSG(sptr)); #endif /* USE_MPC */ #if defined(TARGET_WIN) if (DLLG(sptr) == DLL_EXPORT) fprintf(dfil, " dllexport"); else if (DLLG(sptr) == DLL_IMPORT) fprintf(dfil, " dllimport"); #endif fprintf(dfil, "\n"); break; case ST_ENTRY: fprintf(dfil, "dcld: %d ccsym: %d entstd: %d entnum: %d\n", DCLDG(sptr), CCSYMG(sptr), ENTSTDG(sptr), (int)ENTNUMG(sptr)); fprintf(dfil, "endline: %d symlk: %d paramct: %d dpdsc: %d\n", ENDLINEG(sptr), SYMLKG(sptr), PARAMCTG(sptr), DPDSCG(sptr)); fprintf(dfil, "funcline: %d bihnum: %d fval: %d pure: %d impure: %d " " recur:%d\n", FUNCLINEG(sptr), BIHNUMG(sptr), FVALG(sptr), PUREG(sptr), IMPUREG(sptr), RECURG(sptr)); fprintf(dfil, "adjarr:%d aftent:%d assumshp:%d", ADJARRG(sptr), AFTENTG(sptr), ASSUMSHPG(sptr)); fprintf(dfil, " private:%d", PRIVATEG(sptr)); _PFG(ASSUMLENG(sptr), "assumlen"); _PFG(ADJLENG(sptr), "adjlen"); _PFG(POINTERG(sptr), "pointer"); _PFG(PTRARGG(sptr), "ptrarg"); _PFG(TYP8G(sptr), "typ8"); _PFG(ELEMENTALG(sptr), "elemental"); _PFG(DFLTG(sptr), "dflt"); _PFG(ARETG(sptr), "aret"); fprintf(dfil, "\n"); fprintf(dfil, " gsame: %d\n", (int)GSAMEG(sptr)); fprintf(dfil, "altname: %d", ALTNAMEG(sptr)); #ifdef MVDESCG _PFG(MVDESCG(sptr), "mvdesc"); #endif _PFG(MSCALLG(sptr), "mscall"); #ifdef CREFP _PFG(CREFG(sptr), "cref"); _PFG(NOMIXEDSTRLENG(sptr), "nomixedstrlen"); #endif _PFG(PASSBYVALG(sptr), "passbyval"); _PFG(PASSBYREFG(sptr), "passbyref"); _PFG(STDCALLG(sptr), "stdcall"); _PFG(CFUNCG(sptr), "cfunc"); _PFG(DECORATEG(sptr), "decorate"); #if defined(TARGET_WIN) if (DLLG(sptr) == DLL_EXPORT) fprintf(dfil, " dllexport"); else if (DLLG(sptr) == DLL_IMPORT) fprintf(dfil, " dllimport"); #endif fprintf(dfil, "\n"); fprintf(dfil, "Parameters:\n"); dscptr = DPDSCG(sptr); for (i = PARAMCTG(sptr); i > 0; dscptr++, i--) { fprintf(dfil, "sptr =%5d", aux.dpdsc_base[dscptr]); if (aux.dpdsc_base[dscptr]) fprintf(dfil, ", %s", SYMNAME(aux.dpdsc_base[dscptr])); fprintf(dfil, "\n"); } break; case ST_PROC: fprintf(dfil, "dcld:%d ref:%d ccsym:%d func:%d typd:%d pure:%d " "impure: %d\n", DCLDG(sptr), REFG(sptr), CCSYMG(sptr), FUNCG(sptr), TYPDG(sptr), PUREG(sptr), IMPUREG(sptr)); fprintf(dfil, "fval:%d recur:%d private:%d sc:%d(%s)\n", FVALG(sptr), RECURG(sptr), PRIVATEG(sptr), SCG(sptr), (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na"); fprintf(dfil, "symlk: %d paramct: %d dpdsc: %d:", SYMLKG(sptr), PARAMCTG(sptr), DPDSCG(sptr)); fprintf(dfil, " private:%d inmod:%d fwdref:%d", PRIVATEG(sptr), INMODULEG(sptr), FWDREFG(sptr)); _PFG(HCCSYMG(sptr), "hccsym"); _PFG(ASSUMLENG(sptr), "assumlen"); _PFG(ADJLENG(sptr), "adjlen"); _PFG(POINTERG(sptr), "pointer"); _PFG(PTRARGG(sptr), "ptrarg"); _PFG(OPTARGG(sptr), "optarg"); _PFG(TYP8G(sptr), "typ8"); _PFG(ARETG(sptr), "aret"); fprintf(dfil, "\n"); fprintf(dfil, "altname: %d", ALTNAMEG(sptr)); #ifdef MVDESCG _PFG(MVDESCG(sptr), "mvdesc"); #endif _PFG(CFUNCG(sptr), "cfunc"); _PFG(CSTRUCTRETG(sptr), "cstructret"); _PFG(MSCALLG(sptr), "mscall"); #ifdef CREFP _PFG(CREFG(sptr), "cref"); _PFG(NOMIXEDSTRLENG(sptr), "nomixedstrlen"); #endif _PFG(PASSBYVALG(sptr), "passbyval"); _PFG(PASSBYREFG(sptr), "passbyref"); _PFG(STDCALLG(sptr), "stdcall"); _PFG(DECORATEG(sptr), "decorate"); #if defined(TARGET_WIN) if (SCG(sptr) != SC_DUMMY) { if (DLLG(sptr) == DLL_EXPORT) fprintf(dfil, " dllexport"); else if (DLLG(sptr) == DLL_IMPORT) fprintf(dfil, " dllimport"); } #endif _PFG(ELEMENTALG(sptr), "elemental"); _PFG(DFLTG(sptr), "dflt"); #ifdef NOCOG _PFG(NOCOG(sptr), "noco"); #endif _PFG(VARARGG(sptr), "vararg"); fprintf(dfil, "\n"); fprintf(dfil, " gsame: %d", (int)GSAMEG(sptr)); if (HCCSYMG(sptr) && INTENTG(sptr)) { fprintf(dfil, " intent:%s", INTENTG(sptr) == INTENT_IN || INTENTG(sptr) == INTENT_OUT ? (INTENTG(sptr) == INTENT_IN ? "IN" : "OUT") : "INOUT"); } fprintf(dfil, "\n"); if (DPDSCG(sptr) && PARAMCTG(sptr)) { fprintf(dfil, "Parameters:\n"); dscptr = DPDSCG(sptr); for (i = PARAMCTG(sptr); i > 0; dscptr++, i--) { fprintf(dfil, "sptr =%5d", aux.dpdsc_base[dscptr]); if (aux.dpdsc_base[dscptr]) fprintf(dfil, ", %s", SYMNAME(aux.dpdsc_base[dscptr])); fprintf(dfil, "\n"); } } break; case ST_CONST: fprintf(dfil, "holl: %d ", HOLLG(sptr)); fprintf(dfil, "symlk: %d address: %" ISZ_PF "d conval1: %d ", SYMLKG(sptr), ADDRESSG(sptr), CONVAL1G(sptr)); if (DTYPEG(sptr) == DT_HOLL) fprintf(dfil, "conval2: %c\n", CONVAL2G(sptr)); else fprintf(dfil, "conval2: %d\n", CONVAL2G(sptr)); _PFG(PRIVATEG(sptr), "private"); break; case ST_LABEL: fprintf(dfil, "rfcnt: %d address: %" ISZ_PF "d symlk: %d iliblk: %d fmtpt: %d agoto: %" ISZ_PF "d", RFCNTG(sptr), ADDRESSG(sptr), SYMLKG(sptr), ILIBLKG(sptr), FMTPTG(sptr), AGOTOG(sptr)); _PFG(TARGETG(sptr), "target"); _PFG(ASSNG(sptr), "assn"); _PFG(VOLG(sptr), "vol"); fprintf(dfil, "\n"); break; case ST_STFUNC: fprintf(dfil, "symlk: %d sfdsc: %x excvlen: %d sfast: %d\n", SYMLKG(sptr), (int)SFDSCG(sptr), (int)DTY(DTYPEG(sptr) + 1), SFASTG(sptr)); break; case ST_PARAM: if (TY_ISWORD(DTY(dtype))) { /* fprintf(dfil, "conval1: 0x%lx\n", CONVAL1G(sptr)); */ fprintf(dfil, "conval1: 0x%x (%s)\n", CONVAL1G(sptr), parmprint(sptr)); } else fprintf(dfil, "conval1: %d (sptr)\n", CONVAL1G(sptr)); fprintf(dfil, "symlk:%d", SYMLKG(sptr)); fprintf(dfil, " private:%d", PRIVATEG(sptr)); _PFG(DCLDG(sptr), "dcld"); _PFG(TYPDG(sptr), "typd"); _PFG(VAXG(sptr), "vax"); _PFG(HIDDENG(sptr), "hidden"); _PFG(IGNOREG(sptr), "ignore"); _PFG(ENDG(sptr), "end"); if (DTY(dtype) != TY_ARRAY) fprintf(dfil, " conval2: %d(ast)\n", CONVAL2G(sptr)); else fprintf(dfil, " conval2: get_getitem_p(%d)\n", CONVAL2G(sptr)); break; case ST_ISOC: case ST_ISOFTNENV: case ST_INTRIN: fprintf(dfil, "dcld:%d expst:%d typd:%d\n", (int)DCLDG(sptr), (int)EXPSTG(sptr), (int)TYPDG(sptr)); *typeb = '\0'; getdtype((int)ARGTYPG(sptr), typeb); fprintf( dfil, "pnmptr: %d paramct: %d ilm: %d arrayf: %d argtype: %s\n", PNMPTRG(sptr), PARAMCTG(sptr), (int)ILMG(sptr), ARRAYFG(sptr), typeb); *typeb = '\0'; getdtype((int)INTTYPG(sptr), typeb); fprintf(dfil, "inttyp: %s intast: %d", typeb, (int)INTASTG(sptr)); _PFG(NATIVEG(sptr), "native"); fprintf(dfil, "\n"); break; case ST_USERGENERIC: fprintf(dfil, "gsame: %d gncnt:%d gndsc:%d private:%d gtype:%d\n", GSAMEG(sptr), GNCNTG(sptr), GNDSCG(sptr), PRIVATEG(sptr), GTYPEG(sptr)); fprintf(dfil, "Overloaded funcs:\n"); for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr), SYMNAME(SYMI_SPTR(dscptr))); break; case ST_GENERIC: fprintf(dfil, "expst:%d typd:%d gsame:%d gsint:%d gint:%d gint8:%d\n", EXPSTG(sptr), TYPDG(sptr), GSAMEG(sptr), GSINTG(sptr), GINTG(sptr), GINT8G(sptr)); fprintf( dfil, "greal:%d gdble:%d gquad:%d gcmplx:%d gdcmplx:%d gqcmplx:%d\n", GREALG(sptr), GDBLEG(sptr), GQUADG(sptr), GCMPLXG(sptr), GDCMPLXG(sptr), GQCMPLXG(sptr)); break; case ST_PD: case ST_IEEEARITH: case ST_IEEEEXCEPT: case ST_CRAY: fprintf(dfil, "pdnum: %d intast: %d", (int)PDNUMG(sptr), (int)INTASTG(sptr)); _PFG(DCLDG(sptr), "dcld"); _PFG(NATIVEG(sptr), "native"); fprintf(dfil, "\n"); break; case ST_PLIST: fprintf(dfil, "ref: %d", REFG(sptr)); if (SCG(sptr) == SC_CMBLK) fprintf(dfil, " cmblk: %d", CMBLKG(sptr)); _PFG(DINITG(sptr), "dinit"); fprintf(dfil, "\n"); fprintf(dfil, "address: %" ISZ_PF "d pllen: %d sc:%d(%s) symlk: %d\n", ADDRESSG(sptr), PLLENG(sptr), SCG(sptr), (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na", SYMLKG(sptr)); if (SYMNAME(sptr)[1] == 'J') fprintf(dfil, "swel: %d, deflab: %d\n", SWELG(sptr), (int)DEFLABG(sptr)); break; case ST_ALIAS: fprintf(dfil, "symlk: %d private: %d ", SYMLKG(sptr), PRIVATEG(sptr)); _PFG(IGNOREG(sptr), "ignore"); fprintf(dfil, "\n"); break; case ST_ARRDSC: fprintf(dfil, "descr: %d secd: %d secdsc: %d slnk: %d array %d", DESCRG(sptr), SECDG(sptr), SECDSCG(sptr), SLNKG(sptr), ARRAYG(sptr)); fprintf(dfil, " alnd: %d", ALNDG(sptr)); fprintf(dfil, "\n"); break; case ST_TYPEDEF: fprintf(dfil, "private:%d", PRIVATEG(sptr)); _PFG(POINTERG(sptr), "pointer"); _PFG(SEQG(sptr), "seq"); _PFG(ALLOCFLDG(sptr), "allocfld"); _PFG(CFUNCG(sptr), "bind(c)"); _PFG(UNLPOLYG(sptr), "unlpoly"); fprintf(dfil, "\n"); break; case ST_MODULE: fprintf(dfil, "funcline: %d ", FUNCLINEG(sptr)); fprintf(dfil, "base: %d", CMEMFG(sptr)); fprintf(dfil, " private:%d", PRIVATEG(sptr)); _PFG(DCLDG(sptr), "dcld"); _PFG(DINITG(sptr), "dinit"); _PFG(NEEDMODG(sptr), "needmod"); _PFG(TYPDG(sptr), "typd"); #if defined(TARGET_WIN) if (DLLG(sptr) == DLL_EXPORT) fprintf(dfil, " dllexport"); else if (DLLG(sptr) == DLL_IMPORT) fprintf(dfil, " dllimport"); #endif fprintf(dfil, "\n"); break; case ST_OPERATOR: fprintf(dfil, "inkind:%d pdnum:%d", INKINDG(sptr), PDNUMG(sptr)); fprintf(dfil, " gncnt:%d gndsc:%d", GNCNTG(sptr), GNDSCG(sptr)); fprintf(dfil, " private:%d\n", PRIVATEG(sptr)); fprintf(dfil, "Overloaded funcs:\n"); for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr), SYMNAME(SYMI_SPTR(dscptr))); break; case ST_MODPROC: fprintf(dfil, "symlk: %d symi: %d gsame: %d private: %d\n", SYMLKG(sptr), SYMIG(sptr), (int)GSAMEG(sptr), PRIVATEG(sptr)); fprintf(dfil, "Mapped from generics/operators:\n"); for (dscptr = SYMIG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr), SYMNAME(SYMI_SPTR(dscptr))); break; case ST_CONSTRUCT: fprintf(dfil, "funcline:%d\n", FUNCLINEG(sptr)); break; case ST_BLOCK: fprintf(dfil, "startline %d endline %d enclfunc %d\n", STARTLINEG(sptr), ENDLINEG(sptr), ENCLFUNCG(sptr)); fprintf(dfil, "startlab %d endlab %d", STARTLABG(sptr), ENDLABG(sptr)); fprintf(dfil, " autobj: %d", AUTOBJG(sptr)); fprintf(dfil, "\n"); break; default: interr("symdmp: bad symbol type", stype, 1); } } /** * dump symbol table for debugging purposes. If full == TRUE, dump entire * symbol table, otherwise dump symtab beginning with user symbols. */ void symdmp(FILE *dfil, LOGICAL full) { int sptr; /* symbol currently being dumped */ for (sptr = (full ? 1 : stb.firstusym); sptr < stb.stg_avail; sptr++) symdentry(dfil, sptr); } void dmp_socs(int sptr, FILE *file) { int p; int q; fprintf(file, "dmp_socs(%d)\n", sptr); if (!soc.base) { fprintf(file, "ERROR - soc.base is null\n"); return; } q = 0; for (p = SOCPTRG(sptr); p; p = SOC_NEXT(p)) { fprintf(file, " overlaps: %s\n", SYMNAME(SOC_SPTR(p))); if (q == p) { fprintf(file, ">>>>> soc loop\n"); break; } q = p; } } /*--------------------------------------------------------------------------* * getccsym could be shared between C and Fortran * *--------------------------------------------------------------------------*/ /** * create (or possibly reuse) a compiler created symbol whose name is of the * form . 'letter' dddd where dddd is the decimal representation of n and * 'letter' is the character specified in the letter argument. */ int getccsym(int letter, int n, SYMTYPE stype) { char name[32]; int sptr, i; char *suffix = IPA_RECOMPILATION_SUFFIX; sprintf(name, ".%c%04d%s", letter, n, suffix); /* at least 4, could be more */ i = 0; do { sptr = getsymbol(name); if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, stype); CCSYMP(sptr, 1); IGNOREP(sptr, 0); SCOPEP(sptr, stb.curr_scope); return sptr; } if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype) return sptr; /* make up a new name */ ++i; sprintf(&name[2], "%04d%03d%s", n, i, suffix); } while (1); } /** * create (never reuse) a compiler created symbol whose name is of the * form . 'letter' dddd where dddd is the decimal representation of n * and 'letter' is the character specified in the letter argument. */ int getnewccsym(int letter, int n, int stype) { char name[32]; int sptr; sprintf(name, ".%c%04d", letter, n); /* at least 4, could be more */ NEWSYM(sptr); NMPTRP(sptr, putsname(name, strlen(name))); STYPEP(sptr, stype); CCSYMP(sptr, 1); SCOPEP(sptr, 2); if (gbl.internal > 1) INTERNALP(sptr, 1); return (sptr); } /* getnewccsym */ /** * create (never reuse) a compiler created symbol whose name is of the * form . */ static int getnewccsym2(char *name, int n, int stype) { int sptr; NEWSYM(sptr); NMPTRP(sptr, putsname(name, strlen(name))); STYPEP(sptr, stype); CCSYMP(sptr, 1); SCOPEP(sptr, 2); if (gbl.internal > 1) INTERNALP(sptr, 1); return (sptr); } /* getnewccsym2 */ int getnewccsymf(int stype, const char *fmt, ...) { char buffer[MAXIDLEN + 1]; va_list ap; int sptr; va_start(ap, fmt); vsnprintf(buffer, sizeof buffer, fmt, ap); va_end(ap); buffer[sizeof buffer - 1] = '\0'; /* Windows vsnprintf bug work-around */ return getnewccsym2(buffer, 0 /*unused*/, stype); } /** * similar to getccsym, but storage class is an argument. Calls getccsym * if the storage class is not private; if private, a 'p' is appended to * the name. */ int getccsym_sc(int letter, int n, int stype, int sc) { int sptr; if (sc != SC_PRIVATE) sptr = getccsym(letter, n, stype); else { char name[32]; int i; char *suffix = IPA_RECOMPILATION_SUFFIX; sprintf(name, ".%c%04dp%s", letter, n, suffix); /* at least 4, could be more */ i = 0; do { sptr = getsymbol(name); if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, stype); CCSYMP(sptr, 1); IGNOREP(sptr, 0); SCOPEP(sptr, stb.curr_scope); break; } if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype && SCG(sptr) == sc) break; /* make up a new name */ ++i; sprintf(&name[2], "%04d%03dp%s", n, i, suffix); } while (1); } SCP(sptr, sc); return (sptr); } /** * create (or possibly reuse) a compiler created symbol whose name is of the * form . "pfx" dddd where dddd is the decimal representation of n and * "pfx" is the prefix specified in the pfx argument. */ int getccssym(const char *pfx, int n, int stype) { char name[32]; int sptr, i; char *suffix = IPA_RECOMPILATION_SUFFIX; sprintf(name, ".%s%04d%s", pfx, n, suffix); /* at least 4, could be more */ i = 0; do { sptr = getsymbol(name); if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, stype); CCSYMP(sptr, 1); IGNOREP(sptr, 0); SCOPEP(sptr, stb.curr_scope); return sptr; } if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype) return sptr; /* make up a new name */ ++i; sprintf(&name[strlen(pfx) + 1], "%04d%03d%s", n, i, suffix); } while (1); } /** * similar to getccssym, but storage class is an argument. Calls getccssym * if the storage class is not private; if private, a 'p' is appended to * the name. */ int getccssym_sc(const char *pfx, int n, int stype, int sc) { int sptr; if (sc != SC_PRIVATE) sptr = getccssym(pfx, n, stype); else { int i = 0; sptr = getsymf(".%s%04dp%s", pfx, n, IPA_RECOMPILATION_SUFFIX); do { if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, stype); CCSYMP(sptr, 1); IGNOREP(sptr, 0); SCOPEP(sptr, stb.curr_scope); break; } if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype && SCG(sptr) == sc) break; /* make up a new name */ sptr = getsymf(".%s%04d%03dp%s", pfx, n, ++i, IPA_RECOMPILATION_SUFFIX); } while (1); } SCP(sptr, sc); return sptr; } /** * create (or possibly reuse) a compiler created symbol whose name is of the * form z_'letter'_'d' where 'd' is the decimal representation of n. * If the storage class is private, 'p' is appended to the name. */ int getcctmp_sc(int letter, int n, int stype, int dtype, int sc) { int i = 0; const char *scp = sc == SC_PRIVATE ? "p" : ""; int sptr = getsymf("z_%c_%d%s%s", letter, n, IPA_RECOMPILATION_SUFFIX, scp); #if DEBUG assert(sc, "getcctmp_sc: SC_NONE", letter, 4); #endif do { if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, stype); DTYPEP(sptr, dtype); DCLDP(sptr, 1); SCOPEP(sptr, stb.curr_scope); HCCSYMP(sptr, 1); SCP(sptr, sc); IGNOREP(sptr, 0); #ifdef CUDAG if (CUDAG(gbl.currsub) & (CUDA_GLOBAL | CUDA_DEVICE)) { DEVICEP(sptr, 1); } #endif return (sptr); } /* getcctmp_sc() is called from get_arr_tmp() in semutil2.c in a * search loop that checks dtypes for acceptable matches, so we'll * allow distinct dtypes here if both are arrays. */ if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype && SCG(sptr) == sc && (DTYPEG(sptr) == dtype || (dtype > 0 && DTYPEG(sptr) > 0 && DTY(dtype) == TY_ARRAY && DTY(DTYPEG(sptr)) == TY_ARRAY))) return sptr; /* make up a new name */ sptr = getsymf("z_%c_%d_%d%s%s", letter, n, ++i, IPA_RECOMPILATION_SUFFIX, scp); } while (1); } /** * Create a local compiler-created symbol - calls getcctmp_sc with the * storage class SC_LOCAL. */ int getcctmp(int letter, int n, int stype, int dtype) { int sptr; sptr = getcctmp_sc(letter, n, stype, dtype, SC_LOCAL); return sptr; } /*--------------------------------------------------------------------------* * insert_sym is the same between C and Fortran * *--------------------------------------------------------------------------*/ /** * create new symbol table entry and insert it in the hash list immediately * in front of 'first': */ int insert_sym(int first) { int sptr, i, j; INT hashval; char *np; NEWSYM(sptr); NMPTRP(sptr, NMPTRG(first)); /* link newly created symbol immediately in front of first: */ np = SYMNAME(first); i = strlen(np); HASH_ID(hashval, np, i); HASHLKP(sptr, first); if (stb.hashtb[hashval] == first) stb.hashtb[hashval] = sptr; else { /* scan hash list to find immed. predecessor of first: */ for (i = stb.hashtb[hashval]; (j = HASHLKG(i)) != first; i = j) assert(j != 0, "insert_sym: bad hash", first, 4); HASHLKP(i, sptr); } SYMLKP(sptr, NOSYM); /* installsym for ftn also sets SYMLK */ setimplicit(sptr); if (gbl.internal > 1) INTERNALP(sptr, 1); SCOPEP(sptr, stb.curr_scope); return sptr; } /** * create new symbol table entry and insert it in the hash list * in front of the head of the list containing 'first': */ int insert_sym_first(int first) { int sptr, i, j; INT hashval; char *np; NEWSYM(sptr); NMPTRP(sptr, NMPTRG(first)); /* link newly created symbol in front of the hash list: */ np = SYMNAME(first); i = strlen(np); HASH_ID(hashval, np, i); HASHLKP(sptr, stb.hashtb[hashval]); stb.hashtb[hashval] = sptr; SYMLKP(sptr, NOSYM); /* installsym for ftn also sets SYMLK */ setimplicit(sptr); if (gbl.internal > 1) INTERNALP(sptr, 1); SCOPEP(sptr, stb.curr_scope); return sptr; } /** * return a compiler-created label -- user labels begin with '.', compiler- * created labels begin with '%'. Compiler-created labels will be mapped * to fortran 77 labels by astout. */ int getlab(void) { int lab; while (TRUE) { lab = getsymf("%%L%05d", stb.lbavail--); if (STYPEG(lab) != ST_LABEL) { #if DEBUG assert(STYPEG(lab) == ST_UNKNOWN, "getlab,sym not unk", lab, 3); #endif STYPEP(lab, ST_LABEL); CCSYMP(lab, 1); SYMLKP(lab, 0); break; } } return lab; } /** \brief Return TRUE if sptr is in symi list represented by list. */ LOGICAL sym_in_sym_list(int sptr, int list) { for (; list != 0; list = SYMI_NEXT(list)) { if (SYMI_SPTR(list) == sptr) { return TRUE; } } return FALSE; } /** \brief Return TRUE if these two symi lists have the same sptrs in the same * order. */ LOGICAL same_sym_list(int list1, int list2) { for (;;) { if (list1 == 0) { return list2 == 0; } if (list2 == 0 || SYMI_SPTR(list1) != SYMI_SPTR(list2)) { return FALSE; } list1 = SYMI_NEXT(list1); list2 = SYMI_NEXT(list2); } } /** * \brief remove a symbol from its hash list */ void pop_sym(int sptr) { char *name; INT hashval; int s, j, l; #if DEBUG if (DBGBIT(5, 1024)) fprintf(gbl.dbgfil, "pop_sym(): sym %d\n", sptr); #endif if (NMPTRG(sptr) == 0) return; name = SYMNAME(sptr); l = strlen(name); HASH_ID(hashval, name, l); for (s = stb.hashtb[hashval], j = 0; s; s = HASHLKG(s)) { if (s == sptr) { #if DEBUG if (DBGBIT(5, 1024)) fprintf(gbl.dbgfil, "removing %s, sptr:%d\n", SYMNAME(sptr), sptr); #endif if (j) HASHLKP(j, HASHLKG(sptr)); else stb.hashtb[hashval] = HASHLKG(sptr); break; } j = s; } HASHLKP(sptr, 0); } /** * \brief push a symbol onto a hash list */ void push_sym(int sptr) { char *name; int l; INT hashval; #if DEBUG if (DBGBIT(5, 1024)) fprintf(gbl.dbgfil, "push_sym(sym %d)\n", sptr); #endif if (NMPTRG(sptr) == 0) return; name = SYMNAME(sptr); l = strlen(name); HASH_ID(hashval, name, l); HASHLKP(sptr, stb.hashtb[hashval]); stb.hashtb[hashval] = sptr; } /* push_sym */ /** create a function ST item given a name */ SPTR mkfunc(const char *nmptr) { SPTR sptr; sptr = getsymbol(nmptr); STYPEP(sptr, ST_PROC); DTYPEP(sptr, DT_INT); SCP(sptr, SC_EXTERN); CCSYMP(sptr, 1); return (sptr); } /** \brief create a coercion function based on the data type. */ char * mk_coercion_func_name(int dtype) { SPTR sptr; FtnRtlEnum rtlRtn; switch (DTY(dtype)) { case TY_BINT: rtlRtn = RTE_int1; break; case TY_SINT: rtlRtn = RTE_int2; break; case TY_INT: rtlRtn = RTE_int4; break; case TY_INT8: rtlRtn = RTE_int8; break; case TY_BLOG: rtlRtn = RTE_log1; break; case TY_SLOG: rtlRtn = RTE_log2; break; case TY_LOG: rtlRtn = RTE_log4; break; case TY_LOG8: rtlRtn = RTE_log8; break; case TY_REAL: rtlRtn = RTE_real4; break; case TY_DBLE: rtlRtn = RTE_real8; break; case TY_QUAD: rtlRtn = RTE_real16; break; case TY_CMPLX: rtlRtn = RTE_cmplx8; break; case TY_DCMPLX: rtlRtn = RTE_cmplx16; break; case TY_QCMPLX: rtlRtn = RTE_cmplx32; break; default: interr("mk_coercion_func_name: ty not allowed", DTY(dtype), 3); rtlRtn = RTE_no_rtn; break; } return (mkRteRtnNm(rtlRtn)); } /** \brief Create a coercion function based on the data type. */ int mk_coercion_func(int dtype) { int sptr; sptr = sym_mkfunc_nodesc(mk_coercion_func_name(dtype), dtype); return sptr; } /** * create an external variable given a name and its data type. A common block * of the same name is created and its member is the variable. If the variable * already exists, just return it. */ int mk_external_var(char *name, int dtype) { int commonsptr = getsymbol(name); int sptr; if (STYPEG(commonsptr) != ST_UNKNOWN) { #if DEBUG if (DTY(dtype) != TY_ARRAY) assert(STYPEG(commonsptr) == ST_VAR, "mk_external_var:scalar name conflict", commonsptr, 3); else assert(STYPEG(commonsptr) == ST_ARRAY, "mk_external_var:array name conflict", commonsptr, 3); #endif return commonsptr; } STYPEP(commonsptr, ST_CMBLK); DCLDP(commonsptr, 1); HCCSYMP(commonsptr, 1); SCP(commonsptr, SC_CMBLK); pop_sym(commonsptr); /* hide common block from subsequent getsyms */ sptr = getsymbol(name); if (DTY(dtype) != TY_ARRAY) STYPEP(sptr, ST_VAR); else STYPEP(sptr, ST_ARRAY); DTYPEP(sptr, dtype); DCLDP(sptr, 1); HCCSYMP(sptr, 1); SCP(sptr, SC_CMBLK); SYMLKP(commonsptr, gbl.cmblks); /* link into list of common blocks */ gbl.cmblks = commonsptr; CMEMFP(commonsptr, sptr); /* add the variable to the common */ CMEMLP(commonsptr, NOSYM); CMBLKP(sptr, commonsptr); SYMLKP(sptr, NOSYM); return sptr; } /** \brief determine if an argument is an argument to a given entry \param ent entry sptr \param arg argument sptr */ LOGICAL is_arg_in_entry(int ent, int arg) { int dscptr; /* ptr to dummy parameter descriptor list */ int i; #if DEBUG assert(STYPEG(ent) == ST_ENTRY, "is_arg_entry:need ST_ENTRY", ent, 3); assert(SCG(arg) == SC_DUMMY, "is_arg_entry:need SC_DUMMY", arg, 3); #endif dscptr = DPDSCG(ent); for (i = PARAMCTG(ent); i > 0; dscptr++, i--) if (arg == *(aux.dpdsc_base + dscptr)) return TRUE; return FALSE; } /** \brief determine if an argument $p is an $p of argument to a given entry \param ent entry sptr \param arg argument sptr */ LOGICAL is_argp_in_entry(int ent, int arg) { int dscptr; /* ptr to dummy parameter descriptor list */ int i; #if DEBUG assert(STYPEG(ent) == ST_ENTRY, "is_arg_entry:need ST_ENTRY", ent, 3); assert(SCG(arg) == SC_DUMMY, "is_arg_entry:need SC_DUMMY", arg, 3); #endif dscptr = DPDSCG(ent); for (i = PARAMCTG(ent); i > 0; dscptr++, i--) { int sptr = *(aux.dpdsc_base + dscptr); if (arg == sptr) return TRUE; if (POINTERG(sptr) || ALLOCG(sptr)) { if (arg == MIDNUMG(sptr)) return TRUE; } } return FALSE; } int resolve_sym_aliases(int sptr) { while (sptr > NOSYM && STYPEG(sptr) == ST_ALIAS) { sptr = SYMLKG(sptr); } return sptr; } LOGICAL is_procedure_ptr(int sptr) { sptr = resolve_sym_aliases(sptr); if (sptr > NOSYM && (POINTERG(sptr) || IS_PROC_DUMMYG(sptr))) { switch (STYPEG(sptr)) { case ST_PROC: case ST_ENTRY: /* subprograms aren't considered to be procedure pointers */ break; default: return is_procedure_ptr_dtype(DTYPEG(sptr)); } } return FALSE; } void proc_arginfo(int sptr, int *paramct, int *dpdsc, int *iface) { if (!is_procedure_ptr(sptr)) { if (STYPEG(sptr) == ST_GENERIC || STYPEG(sptr) == ST_INTRIN) { if (paramct) *paramct = 0; if (dpdsc) *dpdsc = 0; if (iface) *iface = sptr; } else if (IS_TBP(sptr)) { int mem, sptr2; mem = 0; sptr2 = get_implementation(TBPLNKG(sptr), sptr, 0, &mem); if (STYPEG(BINDG(mem)) == ST_OPERATOR || STYPEG(BINDG(mem)) == ST_USERGENERIC) { mem = get_specific_member(TBPLNKG(sptr), sptr); sptr = VTABLEG(mem); } else sptr = sptr2; if (paramct) *paramct = PARAMCTG(sptr); if (dpdsc) *dpdsc = DPDSCG(sptr); if (iface) *iface = (IFACEG(mem)) ? IFACEG(mem) : sptr; } else if (STYPEG(sptr) == ST_MEMBER && CLASSG(sptr) && CCSYMG(sptr) && VTABLEG(sptr) && BINDG(sptr)) { int mem; mem = sptr; sptr = VTABLEG(sptr); if (paramct) *paramct = PARAMCTG(sptr); if (dpdsc) *dpdsc = DPDSCG(sptr); if (iface) *iface = (IFACEG(mem)) ? IFACEG(mem) : sptr; return; } else if (STYPEG(sptr) == ST_PD) { if (paramct) *paramct = 0; if (dpdsc) *dpdsc = 0; if (iface) *iface = sptr; } else { if (paramct) *paramct = PARAMCTG(sptr); if (dpdsc) *dpdsc = DPDSCG(sptr); if (iface) *iface = sptr; } } else { int dtype, dtproc; dtype = DTYPEG(sptr); #if DEBUG assert(DTY(dtype) == TY_PTR, "proc_arginfo, expected TY_PTR dtype", sptr, 4); #endif dtproc = DTY(dtype + 1); #if DEBUG assert(DTY(dtproc) == TY_PROC, "proc_arginfo, expected TY_PROC dtype", sptr, 4); #endif if (paramct) *paramct = DTY(dtproc + 3); if (dpdsc) *dpdsc = DTY(dtproc + 4); if (iface) *iface = DTY(dtproc + 2); } } /** * \brief Compares two symbols by returning true if they both have equivalent * interfaces. Otherwise, return false. * * If flag is set, then we also make sure that sym1 and sym2 have the same * symbol name. */ bool cmp_interfaces(int sym1, int sym2, int flag) { int i, paramct, paramct2, dpdsc, dpdsc2, psptr, psptr2; int iface1, iface2; if (sym1 <= NOSYM) return false; /* It's OK for the argument procedure pointer to point to NOSYM as long as * the formal procedure pointer points to a valid symtab entry. * * We assume the following: * * sym1 is the formal procedure pointer dummy argument * sym2 is the actual procedure pointer argument */ if (sym2 <= NOSYM) return true; if (STYPEG(sym1) != ST_PROC) { int scope, alt_iface; int hash, hptr, len; char *symname; symname = SYMNAME(sym1); len = strlen(symname); HASH_ID(hash, symname, len); for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) { if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) { alt_iface = hptr; if (alt_iface && (scope = test_scope(alt_iface))) { if (scope <= test_scope(sym1)) { sym1 = alt_iface; break; } } } } } if (STYPEG(sym2) != ST_PROC) { int scope, alt_iface; int hash, hptr, len; char *symname; symname = SYMNAME(sym2); len = strlen(symname); HASH_ID(hash, symname, len); for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) { if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) { alt_iface = hptr; if (alt_iface && (scope = test_scope(alt_iface))) { if (scope <= test_scope(sym2)) { sym2 = alt_iface; break; } } } } } iface1 = iface2 = paramct = paramct2 = dpdsc = dpdsc2 = 0; proc_arginfo(sym1, ¶mct2, &dpdsc2, &iface1); proc_arginfo(sym2, ¶mct, &dpdsc, &iface2); if (!iface1 || !iface2) return false; if (flag && strcmp(SYMNAME(iface1), SYMNAME(iface2)) != 0) return false; if (paramct != paramct2) return false; if (iface1 && iface1 == iface2) return true; if (!eq_dtype2(DTYPEG(FVALG(iface1)), DTYPEG(FVALG(iface2)), 0)) return false; /* result types differ */ for (i = 0; i < paramct; ++dpdsc, ++dpdsc2, ++i) { psptr2 = *(aux.dpdsc_base + dpdsc2); psptr = *(aux.dpdsc_base + dpdsc); if (!psptr || !psptr2 || STYPEG(psptr) != STYPEG(psptr2) || strcmp(SYMNAME(psptr), SYMNAME(psptr2)) != 0) return false; if (STYPEG(psptr) == ST_PROC && STYPEG(psptr2) == ST_PROC) { if (!cmp_interfaces(psptr, psptr2, flag)) { return false; } } else if (!eq_dtype2(DTYPEG(psptr), DTYPEG(psptr2), 0)) { return false; } } return true; } /** * \brief Tests the characteristics between two interfaces. * * \param psptr is the first interface. * * \param pstr2 is the second interface. * * \param flag is a bit mask that enforces/relaxes certain checks (see * cmp_interface_flags enum in symtab.c). * * \return true if the two characteristics are compatible, else false. */ bool compatible_characteristics(int psptr, int psptr2, cmp_interface_flags flag) { if (!psptr || !psptr2) { return false; } if ( (((flag & RELAX_INTENT_CHK) == 0) && INTENTG(psptr) != INTENTG(psptr2)) || (((flag & CMP_OPTARG) != 0) && OPTARGG(psptr) != OPTARGG(psptr2)) || ALLOCATTRG(psptr) != ALLOCATTRG(psptr2) || PASSBYVALG(psptr) != PASSBYVALG(psptr2) || ASYNCG(psptr) != ASYNCG(psptr2) || VOLG(psptr) != VOLG(psptr2) || CLASSG(psptr) != CLASSG(psptr2) || (((flag & RELAX_POINTER_CHK) == 0) && POINTERG(psptr) != POINTERG(psptr2)) || TARGETG(psptr) != TARGETG(psptr2) || CONTIGATTRG(psptr) != CONTIGATTRG(psptr2)) { if (flag & CMP_SUBMOD_IFACE) generate_type_mismatch_errors(psptr, psptr2); return false; } if ((flag & RELAX_STYPE_CHK) == 0 && STYPEG(psptr) != STYPEG(psptr2)) { return false; } if (strcmp(SYMNAME(psptr), SYMNAME(psptr2)) != 0) { if (flag & CMP_SUBMOD_IFACE) { /* function may use itself name as a return variable, so no name comparison for function return variables. */ if (!RESULTG(psptr) && !RESULTG(psptr2)) error(1057, ERR_Severe, gbl.lineno, SYMNAME(psptr2),SYMNAME(psptr)); } if ((flag & IGNORE_ARG_NAMES) == 0 && (flag & CMP_SUBMOD_IFACE) == 0) return false; } if (STYPEG(psptr) == ST_PROC && STYPEG(psptr2) == ST_PROC && (flag & DEFER_IFACE_CHK) == 0) { if (!cmp_interfaces_strict(psptr, psptr2, (flag | CMP_OPTARG))) { return false; } } else if (DTY(DTYPEG(psptr)) == DTY(DTYPEG(psptr2)) && (DTY(DTYPEG(psptr)) == TY_CHAR || DTY(DTYPEG(psptr)) == TY_NCHAR )) { /* check character objects only when they both * have constant lengths or at least one is assumed shape. */ int d1 = DTYPEG(psptr); int a1 = DTY(d1+1); int d2 = DTYPEG(psptr2); int a2 = DTY(d2+1); if ((a1 == 0 || a2 == 0 || (A_TYPEG(a1) == A_CNST && A_TYPEG(a2) == A_CNST)) && !eq_dtype2(d1, d2, 0)) { return FALSE; } } else if (!eq_dtype2(DTYPEG(psptr), DTYPEG(psptr2), 0)) { if (flag & CMP_SUBMOD_IFACE) { /* check whether variable type matches for: 1. argument type 2. function return type */ if ((DTY(DTYPEG(psptr)) != DTY(DTYPEG(psptr2))) || (DDTG(DTYPEG(psptr)) != DDTG(DTYPEG(psptr2)) && DTYG(DTYPEG(psptr)) != DTYG(DTYPEG(psptr2)))) generate_type_mismatch_errors(psptr, psptr2); } return FALSE; } else if (DTY(DTYPEG(psptr)) == TY_ARRAY && DTY(DTYPEG(psptr2)) == TY_ARRAY) { /* Check extents of array dimensions. Note: the call to eq_dtype2() * above checks type and rank. */ ADSC *ad, *ad2; int i, ast, ast2, numdim; ad = AD_DPTR(DTYPEG(psptr)); numdim = AD_NUMDIM(ad); ad2 = AD_DPTR(DTYPEG(psptr2)); for(i=0; i < numdim; ++i) { ast = AD_EXTNTAST(ad, i); ast2 = AD_EXTNTAST(ad2, i); if (A_TYPEG(ast) == A_CNST && A_TYPEG(ast2) == A_CNST && CONVAL2G(A_SPTRG(ast)) != CONVAL2G(A_SPTRG(ast2))) { return false; } } } return true; } /** * \brief Same as cmp_interfaces() except we also compare the characteristics as * defined in "12.2 Characteristics of procedures" in F2003 Spec. */ bool cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag) { int i, paramct, paramct2, dpdsc, dpdsc2, psptr, psptr2; int iface1, iface2, chk_stype, j; bool relax1, relax2; iface1 = iface2 = paramct = paramct2 = dpdsc = dpdsc2 = 0; proc_arginfo(sym1, ¶mct, &dpdsc, &iface1); proc_arginfo(sym2, ¶mct2, &dpdsc2, &iface2); if (FVALG(sym1) && FVALG(sym2) && dpdsc > 0 && dpdsc2 > 0) { /* Check characteristics of results if applicable. We do this here * to handle the case where one symbol will have its result in argument * 1 and another symbol will not. This occurs when one symbol is a * function and another symbol is a function interface (i.e., we do not * put the function result into argument 1 for interfaces). We then * adjust parameter counts and argument descriptors when the result is * in an argument so parameter counts are consistent between the two * symbols. */ if (paramct > 0) { psptr = aux.dpdsc_base[dpdsc]; if (FVALG(sym1) == psptr) { paramct--; dpdsc++; } } if (paramct2 > 0) { psptr2 = aux.dpdsc_base[dpdsc2]; if (FVALG(sym2) == psptr2) { paramct2--; dpdsc2++; } } psptr = FVALG(sym1); psptr2 = FVALG(sym2); if (!compatible_characteristics(psptr, psptr2, flag)) { return false; } } /* we may have added descriptors such as type descriptors to the * argument descriptor. Do not count them. */ for (j = i = 0; i < paramct; ++i) { psptr = aux.dpdsc_base[dpdsc + i]; if (CCSYMG(psptr) && CLASSG(psptr)) { ++j; } } paramct -= j; for (j = i = 0; i < paramct2; ++i) { psptr2 = aux.dpdsc_base[dpdsc2 + i]; if (CCSYMG(psptr2) && CLASSG(psptr2)) { ++j; } } paramct2 -= j; if (PUREG(sym1) != PUREG(sym2) || IMPUREG(sym1) != IMPUREG(sym2)) { if (flag & CMP_SUBMOD_IFACE) error(1060, ERR_Severe, gbl.lineno, "PURE function prefix",SYMNAME(sym1)); relax1 = (flag & RELAX_PURE_CHK_1) != 0; relax2 = (flag & RELAX_PURE_CHK_2) != 0; if (!relax1 && !relax2) { /* both arguments must have matching pure/impure attributes */ return false; } if (relax1 != relax2 && PUREG(sym1) != PUREG(sym2)) { if (!relax1 && PUREG(sym1)) { /* argument 1 has pure but argument 2 does not. */ return false; } if (!relax2 && PUREG(sym2)) { /* argument 2 has pure but argument 1 does not */ return false; } } } if (paramct != paramct2) { if (flag & CMP_SUBMOD_IFACE) error(1059, ERR_Severe, gbl.lineno, SYMNAME(sym1), NULL); return false; } if (CFUNCG(sym1) != CFUNCG(sym2)){ if (flag & CMP_SUBMOD_IFACE) error(1060, ERR_Severe, gbl.lineno, "BIND attribute", SYMNAME(sym1)); return false; } if (ELEMENTALG(sym1) != ELEMENTALG(sym2)){ if (flag & CMP_SUBMOD_IFACE) error(1060, ERR_Severe, gbl.lineno, "ELEMENTAL function prefix",SYMNAME(sym1)); return false; } if ((FVALG(sym1) && !FVALG(sym2)) || (FVALG(sym2) && !FVALG(sym1))) { if (flag & CMP_SUBMOD_IFACE) error(1058, ERR_Severe, gbl.lineno, SYMNAME(sym1), NULL); return false; } if (!iface1 || !iface2) return false; if ( ((flag & CMP_IFACE_NAMES) != 0) && strcmp(SYMNAME(iface1), SYMNAME(iface2)) != 0) return false; if (iface1 && iface1 == iface2) return true; for (i = 0; i < paramct; ++dpdsc, ++dpdsc2, ++i) { psptr2 = aux.dpdsc_base[dpdsc2]; psptr = aux.dpdsc_base[dpdsc]; if (!compatible_characteristics(psptr, psptr2, flag)) { return false; } } return true; } /** * replace contents of a symbol with values defining every field while ensuring * values necessary for the hashing function are saved and restored. */ void dup_sym(int new, SYM *content) { int hashlk, nmptr, scope; hashlk = HASHLKG(new); nmptr = NMPTRG(new); scope = SCOPEG(new); *(stb.stg_base + new) = *content; HASHLKP(new, hashlk); NMPTRP(new, nmptr); SCOPEP(new, scope); } /** \Brief Create a duplicate of this sym and return it */ int insert_dup_sym(int sptr) { int new_sptr = insert_sym(sptr); dup_sym(new_sptr, &stb.stg_base[sptr]); return new_sptr; } /** If mod is a submodule, return the module it is a submodule of. * If it's a module, return mod. Otherwise 0. */ SPTR get_ancestor_module(SPTR mod) { if (mod == 0 || STYPEG(mod) != ST_MODULE) return 0; for (;;) { SPTR parent = PARENTG(mod); if (parent == 0) return mod; mod = parent; } } /** return the symbol of the explicit interface of the ST_PROC */ SPTR find_explicit_interface(SPTR s) { SPTR sptr; for (sptr = HASHLKG(s); sptr; sptr = HASHLKG(sptr)) { /* skip noise sptr with same string name*/ if (NMPTRG(sptr) != NMPTRG(s)) continue; if (!INMODULEG(sptr)) break; if (SEPARATEMPG(sptr)) return sptr; } return 0; } /** \brief Instantiate a copy of a separate module subprogram's declared interface as part of the MODULE PROCEDURE's definition (i.e., implement what would have taken place had the subprogram been defined with a MODULE SUBROUTINE or MODULE FUNCTION with a compatible interface). */ SPTR instantiate_interface(SPTR iface) { int dummies; SPTR fval, hashlk_sptr, proc; DEC_DEF_MAP *dec_def_map; proc = insert_dup_sym(iface); gbl.currsub = proc; SCOPEP(proc, SCOPEG(find_explicit_interface(proc))); dummies = PARAMCTG(iface); NEW(dec_def_map, DEC_DEF_MAP, dummies); fval = NOSYM; STYPEP(proc, ST_ENTRY); INMODULEP(proc, TRUE); if (FVALG(iface) > NOSYM) { fval = insert_sym_first(FVALG(iface)); dup_sym(fval, &stb.stg_base[FVALG(iface)]); /* Needs to disable hidden attribute to enable proc to * access derived type members */ HIDDENP(fval, 0); IGNOREP(fval, 0); SCOPEP(fval, proc); if (ENCLFUNCG(FVALG(iface)) == iface) { ENCLFUNCP(fval, proc); } FVALP(proc, fval); ++aux.dpdsc_avl; /* always reserve one for fval */ } if (dummies > 0 || fval > NOSYM) { int iface_dpdsc = DPDSCG(iface); int proc_dpdsc = aux.dpdsc_avl; int j, newdsc; aux.dpdsc_avl += dummies; NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + dummies + 100); DPDSCP(proc, proc_dpdsc); if (fval > NOSYM) { aux.dpdsc_base[proc_dpdsc - 1] = fval; } for (j = 0; j < dummies; ++j) { SPTR arg = aux.dpdsc_base[iface_dpdsc + j]; if (arg > NOSYM) { dec_def_map[j].dec_sptr = arg; arg = insert_dup_sym(arg); dec_def_map[j].def_sptr = arg; SCOPEP(arg, proc); if (DTY(DTYPEG(arg)) == TY_ARRAY && ASSUMSHPG(arg)) { DTYPE elem_dt = array_element_dtype(DTYPEG(arg)); int arr_dsc = mk_arrdsc(); DTY(arr_dsc + 1) = elem_dt; DTYPEP(arg, arr_dsc); trans_mkdescr(arg); ALLOCP(arg, TRUE); /* needs to tie the array descritor with the symbol arg here*/ get_static_descriptor(arg); } if (ALLOCATTRG(arg) || POINTERG(arg)) { if (!SDSCG(arg)) get_static_descriptor(arg); if (!PTROFFG(arg)) get_all_descriptors(arg); } HIDDENP(arg, 0); IGNOREP(arg, 0); if (ENCLFUNCG(arg) == iface) { ENCLFUNCP(arg, proc); } } aux.dpdsc_base[proc_dpdsc + j] = arg; } } if (ADJARRG(fval)) { ADSC *ad; int arr_dsc; DTYPE elem_dt; ad = AD_DPTR(DTYPEG(FVALG(iface))); update_arrdsc(fval, dec_def_map, dummies); elem_dt = array_element_dtype(DTYPEG(iface)); arr_dsc = mk_arrdsc(); DTY(arr_dsc + 1) = elem_dt; DTYPEP(fval, arr_dsc); trans_mkdescr(fval); } FREE(dec_def_map); return proc; } /** \brief Update array bound AST SPTRs (old_sptr) using newly created SPTRs (new_sptr) by referring to DEC_DEF_MAP. The DEC_DEF_MAP is a struct which contains mapping info from the old_sptr to new_sptr. */ static void update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies) { int i, j; SPTR dec_sptr_lwbd, dec_sptr_upbd; ADSC *ad; ad = AD_DPTR(DTYPEG(s)); sem.arrdim.ndim = AD_NUMDIM(ad); sem.arrdim.ndefer = AD_DEFER(ad); for (i = 0; i < sem.arrdim.ndim; ++i) { /* restore arrdsc bound ast info from *ad */ sem.bounds[i].lwast = AD_LWAST(ad, i); sem.bounds[i].upast = AD_UPAST(ad, i); /* update arrdsc bound ast info */ dec_sptr_lwbd = A_SPTRG(AD_LWBD(ad, i)); dec_sptr_upbd = A_SPTRG(AD_UPBD(ad, i)); for (j = 0; j < num_dummies; ++j) { if (dec_sptr_lwbd == smap[j].dec_sptr) sem.bounds[i].lwast = mk_id(smap[j].def_sptr); if (dec_sptr_upbd == smap[j].dec_sptr) sem.bounds[i].upast = mk_id(smap[j].def_sptr); } } } /** * reinitialize a symbol */ void reinit_sym(int sptr) { int nmptr, scope, hashlk; hashlk = HASHLKG(sptr); nmptr = NMPTRG(sptr); scope = SCOPEG(sptr); BZERO(stb.stg_base + sptr, char, sizeof(SYM)); HASHLKP(sptr, hashlk); NMPTRP(sptr, nmptr); SCOPEP(sptr, scope); } /* reinit_sym */ char * sym_strsave(char *s) { int i; char *p; i = strlen(s); NEW(p, char, i + 1); strcpy(p, s); return p; } static int manglecount = 0; /** * create a distinct mangled name */ char * mangle_name(char *basename, char *purpose) { int length, i, j; int sptr, hashval; int tail_index; static char name[MAXIDLEN + 1]; int max_idlen = MAXIDLEN; /* we use the convention: basename$purpose%d * if purpose is absent, just basename%d * to deal with the length issue: * + if the length of the name exceeds the max allowed, truncate. * + if a clash occurs, append to or replace the 'tail' of the name * with a digit string (max 5 digits). ) */ if (flg.standard) { max_idlen = STANDARD_MAXIDLEN; } length = strlen(basename); if (length > max_idlen) length = max_idlen; memcpy(name, basename, length); if (purpose) { j = length + 1 + strlen(purpose); /* basname$purpose */ if (j > max_idlen) j = max_idlen; j -= length; /* room for $purpose */ if (j > 0) { name[length] = '$'; memcpy(&name[length + 1], purpose, j - 1); length += j; } } name[length] = '\0'; tail_index = length; /* append digit string */ if ((max_idlen - length) < 5) tail_index = max_idlen - 5; /* no room replace last 5 characters */ for (i = 0;;) { length = strlen(name); HASH_ID(hashval, name, length); for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) { if (IGNOREG(sptr) && stb.curr_scope == SCOPEG(sptr)) continue; if (strcmp(name, SYMNAME(sptr)) == 0) break; } if (sptr == 0) break; ++i; ++manglecount; if (manglecount >= 10000) manglecount = 0; sprintf(&name[tail_index], "%d", manglecount); assert(i < 10000, "mangle_name: too many temps", 0, 4); } return name; } /** same as mangle_name, except only clash for members of the same derived type */ char * mangle_name_dt(char *basename, char *purpose, int encldtype) { int length, i, j; int sptr, hashval; int tail_index; static char name[MAXIDLEN + 1]; int max_idlen = MAXIDLEN; if (flg.standard) { max_idlen = STANDARD_MAXIDLEN; } length = strlen(basename); if (length > max_idlen) length = max_idlen; memcpy(name, basename, length); if (purpose) { j = length + 1 + strlen(purpose); /* basname$purpose */ if (j > max_idlen) j = max_idlen; j -= length; /* room for $purpose */ if (j > 0) { name[length] = '$'; memcpy(&name[length + 1], purpose, j - 1); length += j; } } name[length] = '\0'; tail_index = length; /* append digit string */ if ((max_idlen - length) < 5) tail_index = max_idlen - 5; /* no room replace last 5 characters */ for (i = 0;;) { length = strlen(name); HASH_ID(hashval, name, length); for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) { if (STYPEG(sptr) != ST_MEMBER || ENCLDTYPEG(sptr) != encldtype) continue; /* no clash */ if (strcmp(name, SYMNAME(sptr)) == 0) break; } if (sptr == 0) break; ++i; sprintf(&name[tail_index], "%d", i); assert(i < 10000, "mangle_name: too many temps", 0, 4); } return name; } /** can be called after name mangling if the original name needs to be saved in the symbol table, (for instance, for debug symbols.) */ void save_uname(int newsptr, INT oldnmptr) { if (!newsptr) { interr("save_uname bad sptr", newsptr, 3); return; } if (!UNAMEG(newsptr)) { UNAMEP(newsptr, oldnmptr); /* save original user name */ } else { ; /* do nothing, name is being changed again. */ } #if DEBUG assert(oldnmptr <= stb.namavl, "save_uname: bad nmptr", oldnmptr, 3); #endif } int add_symitem(int sptr, int nxt) { int i; i = aux.symi_avl++; NEED(aux.symi_avl, aux.symi_base, SYMI, aux.symi_size, aux.symi_avl + 100); SYMI_SPTR(i) = sptr; SYMI_NEXT(i) = nxt; return i; } /** * switch from ST_CRAFT/ST_CRAY to ST_PD or vice versa */ void change_predefineds(int stype, LOGICAL remove) { int first, last; int s; hpf_library_stat(&first, &last, stype); if (first == 0) return; if (!remove) { for (s = first; s <= last; s++) if (STYPEG(s) == stype) STYPEP(s, ST_PD); } else { for (s = first; s <= last; s++) if (STYPEG(s) == ST_PD) BCOPY(stb.stg_base + s, init_sym + s, SYM, 1); } } #if DEBUG void dbg_symdentry(int sptr) { symdentry(stderr, sptr); } #endif void rw_sym_state(RW_ROUTINE, RW_FILE) { int nw; RW_FD(stb.hashtb, stb.hashtb, 1); RW_SCALAR(stb.firstusym); RW_SCALAR(stb.stg_avail); RW_SCALAR(stb.stg_cleared); RW_FD(stb.stg_base, SYM, stb.stg_avail); RW_SCALAR(stb.namavl); RW_FD(stb.n_base, char, stb.namavl); RW_SCALAR(stb.lbavail); RW_SCALAR(aux.dpdsc_avl); RW_FD(aux.dpdsc_base, int, aux.dpdsc_avl); RW_SCALAR(aux.arrdsc_avl); RW_FD(aux.arrdsc_base, int, aux.arrdsc_avl); RW_SCALAR(aux.nml_avl); RW_FD(aux.nml_base, NMLDSC, aux.nml_avl); RW_SCALAR(aux.symi_avl); RW_FD(aux.symi_base, SYMI, aux.symi_avl); RW_FD(aux.list, int, ST_MAX + 1); RW_SCALAR(gbl.cmblks); RW_SCALAR(soc.avail); if (soc.avail > 1) { if (ISREAD()) { if (soc.size == 0) { soc.size = soc.avail + 100; NEW(soc.base, SOC_ITEM, soc.size); } else { NEED(soc.avail, soc.base, SOC_ITEM, soc.size, soc.avail + 1000); } } RW_FD(soc.base, SOC_ITEM, soc.avail); } } /** * Compilation is finished - deallocate storage, close files, etc. */ void symtab_fini(void) { FREE(stb.stg_base); stb.stg_size = 0; FREE(stb.n_base); stb.n_size = 0; STG_DELETE(stb.dt); FREE(stb.w_base); stb.w_size = 0; fini_chartab(); if (aux.dpdsc_base) { FREE(aux.dpdsc_base); aux.dpdsc_avl = aux.dpdsc_size = 0; } if (aux.arrdsc_base) { FREE(aux.arrdsc_base); aux.arrdsc_avl = aux.arrdsc_size = 0; } if (aux.nml_base) { FREE(aux.nml_base); aux.nml_avl = aux.nml_size = 0; } if (aux.dvl_base) { FREE(aux.dvl_base); aux.dvl_avl = aux.dvl_size = 0; } if (aux.symi_base) { FREE(aux.symi_base); aux.symi_avl = aux.symi_size = 0; } if (soc.base) { FREE(soc.base); soc.avail = soc.size = 0; } if (save_dtimplicit) { FREE(save_dtimplicit); dtimplicitsize = dtimplicitstack = 0; } } /* symtab_fini */ /** * call this when -standard is set */ void symtab_standard(void) { /* remove _TY_INT from TY_LOG types */ dttypes[TY_BLOG] &= ~_TY_INT; dttypes[TY_SLOG] &= ~_TY_INT; dttypes[TY_LOG] &= ~_TY_INT; dttypes[TY_LOG8] &= ~_TY_INT; } /* symtab_standard */ /** * call this when -nostandard is set; undo what symtab_standard does */ void symtab_nostandard(void) { /* add _TY_INT to TY_LOG types */ dttypes[TY_BLOG] |= _TY_INT; dttypes[TY_SLOG] |= _TY_INT; dttypes[TY_LOG] |= _TY_INT; dttypes[TY_LOG8] |= _TY_INT; } /* symtab_nostandard */ /** \brief Adding intrinsics, predeclareds, etc. to symini_ftn has the effect of rendering existng .mod files incompatible because the values of stb.firstosym will be different. stb.firstosym is computed from: 1. the number of intrinsics, predeclareds defined by symini_ftn, and 2. the number of predeclared constants/symbols created in symtab.c:sym_init() (e.g., 1.0, 0, 2, etc.) It should be possible to map the 'firstosym' symbols from the previous symini to the current symini by just subscripting a table using the old symbol as the index. The purpose of oldsyms0() is to generate the table, map_init0[], based on the old (6.1) version of symini and the current symini which defines the mapping. The 6.1 information, represented by init_sym0[] and init_names0[], are manually extracted from the 6.1-generated syminidf.h; these tables are just renamed versions of init_sym[] & init_names[]. oldsyms0() just scans these 'symbols' and looks for the symbols with the same names in the current symini. In addition to generating the table, map_init0[], the size of the table, init_syms0_size, is generated. If new intrinsics are added after today's symini is released, a new table & size, presumably named init_sym1 and init_syms1_size, will be generated from inputs init_sym1 & init_names1. This process should be able to be repreated to create map_init2, ... Determine if a firstosym value read from a .mod file matches the current initial symtab or a previous initial symtab for which we have mapping information. */ int can_map_initsym(int old_firstosym) { int xtra; if (old_firstosym == stb.firstosym) { return 1; } if (old_firstosym == stb.firstosym - NXTRA) { return 1; } xtra = stb.firstosym - INIT_SYMTAB_SIZE - NXTRA; /*predefined consts, etc.*/ if (old_firstosym == (init_syms0_size + xtra)) { return 1; } if (old_firstosym == (init_syms1_size + xtra)) { return 1; } if (old_firstosym == (init_syms2_size + xtra)) { return 1; } if (old_firstosym == (init_syms3_size + xtra)) { return 1; } return 0; } /** \brief Determine if oldsym, read from a .mod file, is a predefined (intrinsic, predeclared, constant, etc.). If it is, attempt to map the oldsym to the current set of predefineds; note that oldsym could also be from the current set. The value of old_firstosym indicates to which set, current or older, oldsym belongs. */ int map_initsym(int oldsym, int old_firstosym) { int xtra; if (old_firstosym == stb.firstosym) { /* current set of predefineds */ if (oldsym < stb.firstosym) return oldsym; return 0; } if (old_firstosym == (stb.firstosym - NXTRA)) { /* current set of predefineds */ if (oldsym < (stb.firstosym - NXTRA)) return oldsym; return 0; } if (oldsym >= old_firstosym) return 0; xtra = stb.firstosym - INIT_SYMTAB_SIZE - NXTRA; if (old_firstosym == (init_syms0_size + xtra)) { if (oldsym >= init_syms0_size) { xtra = oldsym - init_syms0_size; return INIT_SYMTAB_SIZE + xtra; } return map_init0[oldsym]; } if (old_firstosym == (init_syms1_size + xtra)) { if (oldsym >= init_syms1_size) { xtra = oldsym - init_syms1_size; return INIT_SYMTAB_SIZE + xtra; } return map_init1[oldsym]; } if (old_firstosym == (init_syms2_size + xtra)) { if (oldsym >= init_syms2_size) { xtra = oldsym - init_syms2_size; return INIT_SYMTAB_SIZE + xtra; } return map_init2[oldsym]; } if (old_firstosym == (init_syms3_size + xtra)) { if (oldsym >= init_syms3_size) { xtra = oldsym - init_syms3_size; return INIT_SYMTAB_SIZE + xtra; } return map_init3[oldsym]; } interr("map_initsym: bad osym", old_firstosym, 0); return 0; } /** \brief Convert two dollar signs to a hyphen. Especially used for the submodule *.mod file renaming: ancestor$$submod.mod -> ancestor-submod.mod */ void convert_2dollar_signs_to_hyphen(char *name) { char *p, *q; p = q = name; while (*q) { if (*q == '$' && *(q+1) == '$') { q = q + 2; *p++ = '-'; } *p++ = *q++; } *p = *q; } /** \brief Used for check whether sym2 used inside the scope of sym1 is defined in parent modules (SCOPEG(sym2)) and used by inherited submodules ENCLFUNCG(sym1). */ bool is_used_by_submod(SPTR sym1, SPTR sym2) { if (SCOPEG(sym2) == sym1 && STYPEG(ENCLFUNCG(sym1)) == ST_MODULE && STYPEG(SCOPEG(sym2)) == ST_MODULE && SCOPEG(sym2) == ANCESTORG(ENCLFUNCG(sym1))) return true; /* when sym2 is defined in the common block of parent module of submodule sym1 */ if (SCG(sym2) == SC_CMBLK) return SCOPEG(CMBLKG(sym2)) == ANCESTORG(ENCLFUNCG(sym1)); return false; } /** \brief Emit variable type mismatch errors for either subprogram argument variables or function return type based on separate module subprogram's definition vs. its declaration. */ static void generate_type_mismatch_errors(SPTR s1, SPTR s2) { if (RESULTG(s1) && RESULTG(s2)) error(1061, ERR_Severe, gbl.lineno, SYMNAME(s1), NULL); else error(1058, ERR_Severe, gbl.lineno, SYMNAME(s1), NULL); }