/* * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ /* * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. * Notified per clause 4(b) of the license. * * Support for AMDGPU OpenMP offloading * Date of Modification : 9th July 2019 * * Suppressed a duplicate diagnostic message: "Redundant specification of array" * Date of Modification: 16th July 2019 * * Fix for allowing atomic read/write construct inside omp critical construct * Date of Modification: November 2019 * * Support for AMDGPU OpenMP offloading * Date of modification 04th April 2020 * Date of modification 10th April 2020 * * Support for assumed size array as parameter * Date of modification 9th June 2020 * * Fix to assign right kind of dtype for derived types * Date of modification 06 October 2020 * */ /** \file \brief This file contains part 1 of the compiler's semantic actions (also known as the semant1 phase). */ #include "gbldefs.h" #include "gramsm.h" #include "gramtk.h" #include "error.h" #include "global.h" #include "symtab.h" #include "symutl.h" #include "dtypeutl.h" #include "semant.h" #include "scan.h" #include "dinit.h" #include "semstk.h" #include "ast.h" #include "pragma.h" #include "rte.h" #include "pd.h" #include "interf.h" #include "direct.h" #include "fih.h" #include "atomic_common.h" #include "extern.h" static void gen_dinit(int, SST *); static void pop_subprogram(void); static void fix_proc_ptr_dummy_args(); static void set_len_attributes(SST *, int); static void set_char_attributes(int, int *); static void set_aclen(SST *, int, int); static void copy_type_to_entry(int); static void save_host(INTERF *); static void restore_host(INTERF *, LOGICAL); static void do_end_subprogram(SST *, RU_TYPE); static void check_end_subprogram(RU_TYPE, int); static const char *name_of_rutype(RU_TYPE); static void convert_intrinsics_to_idents(void); static int chk_intrinsic(int, LOGICAL, LOGICAL); static int create_func_entry(int); static int create_func_entry_result(int); static int create_var(int); static int chk_func_entry_result(int); static void get_param_alias_const(SST *, int, int); static void set_string_type_from_init(int, ACL *); static void fixup_param_vars(SST *, SST *); static void save_typedef_init(int, int); static void symatterr(int, int, char *); static void fixup_function_return_type(int, int); static void get_retval_KIND_value(); static void get_retval_LEN_value(); static void get_retval_derived_type(); static void init_allocatable_typedef_components(int); static int mystrcasecmp(char *, char *); static int chk_kind_parm(SST *); static int get_kind_parm(int, int); static int get_kind_parm_strict(int, int); static int get_len_parm(int, int); static int has_kind_parm_expr(int, int, int); static void chk_initialization_with_kind_parm(int); static void check_kind_type_param(int dtype); static void defer_put_kind_type_param(int, int, char *, int, int, int); static void replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i); static int replace_sdsc_in_ast(int sdsc, int ast); static void chk_new_param_dt(int, int); static int get_vtoff(int, DTYPE); static int has_length_type_parameter(int); static int get_highest_param_offset(int); static ACL *dup_acl(ACL *src, int sptr); static int match_memname(int sptr, int list); static LOGICAL is_pdt_dtype(DTYPE dtype); static int chk_asz_deferlen(int, int); static int ident_host_sub = 0; static void defer_ident_list(int ident, int proc); static void clear_ident_list(); static void decr_ident_use(int ident, int proc); static void check_duplicate(bool checker, const char * op); #ifdef GSCOPEP static void fixup_ident_bounds(int); #endif static int decl_procedure_sym(int sptr, int proc_interf_sptr, int attr); static int setup_procedure_sym(int sptr, int proc_interf_sptr, int attr, char access); static LOGICAL ignore_common_decl(void); static void record_func_result(int func_sptr, int func_result_sptr, LOGICAL in_ENTRY); static bool bindingNameRequiresOverloading(SPTR sptr); static void clear_iface(int i, SPTR iface); static bool do_fixup_param_vars_for_derived_arrays(bool, SPTR, int); static void gen_unique_func_ast(int ast, SPTR sptr, SST *stkptr); static IFACE *iface_base; static int iface_avail; static int iface_size; static IDENT_LIST *ident_base[HASHSIZE]; static LOGICAL dirty_ident_base = FALSE; static STSK *stsk; /* gen_dinit() defines, semant1() uses */ static LOGICAL seen_implicit; static LOGICAL seen_parameter; static LOGICAL craft_intrinsics; static LOGICAL is_entry; static LOGICAL is_exe_stmt; static LOGICAL entry_seen; static LOGICAL seen_options; static int adjlen; /* ast of adjustable length specifier */ static int assumlen; /* non-zero if '*' present */ static struct { int kind; INT len; int propagated; } lenspec[2]; #define _LEN_CONST 1 #define _LEN_ASSUM 2 #define _LEN_ZERO 3 #define _LEN_ADJ 4 #define _LEN_DEFER 5 #define MAXDIMS 7 /** \brief Subprogram prefix struct defintions for RECURESIVE, PURE, IMPURE, ELEMENTAL, and MODULE. */ static struct subp_prefix_t { bool recursive; /** processing RECURSIVE attribute */ bool pure; /** processing PURE attribute */ bool impure; /** processing IMPURE attribute */ bool elemental; /** processing ELEMENTAL attribute */ bool module; /** processing MODULE attribute */ } subp_prefix; static void clear_subp_prefix_settings(struct subp_prefix_t *); static void check_module_prefix(); static int generic_rutype; static int mscall; static int cref; static int nomixedstrlen; static int next_enum; /* for non array parameters, default set by attributes of the function */ #define BYVALDEFAULT(ffunc) \ (!(PASSBYREFG(ffunc)) && \ (PASSBYVALG(ffunc) | STDCALLG(ffunc) | CFUNCG(ffunc))) /* flag indicating the presence of a 'host' for contained subprograms. Values * are selected so that they can be used as a mask to determine when an * IMPLICIT NONE statement has already been specified: * * 0x02 - no host present (module or top level subprogram) * 0x04 - host present (within a module CONTAINed subprogram) * 0x08 - host present (within a CONTAINed subprogram in another subprogram) */ static int host_present; static INTERF host_state; static int end_of_host; extern int has_target; #define ERR310(s1, s2) error(310, 3, gbl.lineno, s1, s2) /* * Declarations for processing the attributes specified in an entity type * declaration. Note that some of the ET_ manifest constants, as well as * the entity_attr struct, are used in other processing, such as for PROCEDURE * attributes; likewise, there are a few ET_ entries that aren't used * for declarations, but are for PROCEDURE attributes such as PASS/NOPASS. */ #define ET_ACCESS 0 #define ET_ALLOCATABLE 1 #define ET_DIMENSION 2 #define ET_EXTERNAL 3 #define ET_INTENT 4 #define ET_INTRINSIC 5 #define ET_OPTIONAL 6 #define ET_PARAMETER 7 #define ET_POINTER 8 #define ET_SAVE 9 #define ET_TARGET 10 #define ET_AUTOMATIC 11 #define ET_STATIC 12 #define ET_BIND 13 #define ET_VALUE 14 #define ET_VOLATILE 15 #define ET_PASS 16 #define ET_NOPASS 17 #define ET_DEVICE 18 #define ET_PINNED 19 #define ET_SHARED 20 #define ET_CONSTANT 21 #define ET_PROTECTED 22 #define ET_ASYNCHRONOUS 23 #define ET_TEXTURE 24 #define ET_KIND 25 #define ET_LEN 26 #define ET_CONTIGUOUS 27 #define ET_MANAGED 28 #define ET_IMPL_MANAGED 29 #define ET_MAX 30 /* derive bit mask for each entity type */ #define ET_B(e) (1 << e) #define SYMI_SPTR(i) aux.symi_base[i].sptr #define SYMI_NEXT(i) aux.symi_base[i].next /* * structure to record which attributes occurred for an entity type * declaration. */ static LOGICAL in_entity_typdcl; /* TRUE if processing an entity type decl */ static struct { int exist; /* bit vector indicating which attributes exist */ int dimension; /* TY_ARRAY DT record */ char access; /* 'u' => access public ; 'v' => access private */ char intent; /* bit vector formed from INTENT_... */ char bounds[sizeof(sem.bounds)]; /* copy of sem.bounds[...] */ char arrdim[sizeof(sem.arrdim)]; /* copy of sem.arrdim */ int pass_arg; /* sptr of the ident in PASS ( ) */ } entity_attr; static struct { char *name; int no; /* bit vector of attributes which do not coexist */ } et[ET_MAX] = { {"access", ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTRINSIC) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_DEVICE) | ET_B(ET_CONSTANT) | ET_B(ET_PINNED) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED) | ET_B(ET_CONTIGUOUS))}, {"allocatable", ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_VOLATILE) | ET_B(ET_DEVICE) | ET_B(ET_PINNED) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED) | ET_B(ET_CONTIGUOUS))}, {"dimension", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_DEVICE) | ET_B(ET_SHARED) | ET_B(ET_PINNED) | ET_B(ET_CONSTANT) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_TEXTURE) | ET_B(ET_CONTIGUOUS) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED))}, {"external", ~(ET_B(ET_ACCESS) | ET_B(ET_OPTIONAL) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_POINTER))}, {"intent", ~(ET_B(ET_DIMENSION) | ET_B(ET_OPTIONAL) | ET_B(ET_TARGET) | ET_B(ET_ALLOCATABLE) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_POINTER) | ET_B(ET_VOLATILE) | ET_B(ET_DEVICE) | ET_B(ET_CONSTANT) | ET_B(ET_PINNED) | ET_B(ET_SHARED | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED)) | ET_B(ET_CONTIGUOUS) | ET_B(ET_TEXTURE) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED))}, {"intrinsic", ~(ET_B(ET_ACCESS))}, {"optional", ~(ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTENT) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_ALLOCATABLE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_CONTIGUOUS) | ET_B(ET_MANAGED) | ET_B(ET_VALUE) | ET_B(ET_IMPL_MANAGED) | ET_B(ET_DEVICE))}, {"parameter", ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_SAVE) | ET_B(ET_VALUE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_CONSTANT))}, {"pointer", ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_OPTIONAL) | ET_B(ET_SAVE) | ET_B(ET_VALUE) | ET_B(ET_BIND) | ET_B(ET_INTENT) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_TEXTURE) | ET_B(ET_DEVICE) | ET_B(ET_CONTIGUOUS) | ET_B(ET_MANAGED) | ET_B(ET_EXTERNAL))}, {"save", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_TARGET) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_SHARED) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_PINNED) | ET_B(ET_TEXTURE) | ET_B(ET_DEVICE) | ET_B(ET_MANAGED) | ET_B(ET_CONTIGUOUS) | ET_B(ET_IMPL_MANAGED))}, {"target", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_SAVE) | ET_B(ET_VALUE) | ET_B(ET_BIND) | ET_B(ET_PINNED) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_CONTIGUOUS) | ET_B(ET_DEVICE) | ET_B(ET_MANAGED) | ET_B(ET_IMPL_MANAGED))}, {"automatic", ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_POINTER) | ET_B(ET_TARGET) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED))}, {"static", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED))}, {"bind", ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTENT) | ET_B(ET_POINTER) | ET_B(ET_TARGET) | ET_B(ET_STATIC) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_SAVE) | ET_B(ET_CONTIGUOUS))}, {"value", ~(ET_B(ET_ACCESS) | ET_B(ET_DIMENSION) | ET_B(ET_EXTERNAL) | ET_B(ET_INTENT) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_STATIC) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_OPTIONAL) | ET_B(ET_PROTECTED) | ET_B(ET_CONTIGUOUS))}, {"volatile", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_AUTOMATIC) | ET_B(ET_STATIC) | ET_B(ET_BIND) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_PROTECTED) | ET_B(ET_DEVICE) | ET_B(ET_SHARED) | ET_B(ET_CONTIGUOUS))}, {"pass", ~(0)}, {"nopass", ~(0)}, {"device", ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_VOLATILE) | ET_B(ET_ACCESS) | ET_B(ET_TARGET) | ET_B(ET_POINTER) | ET_B(ET_TEXTURE) | ET_B(ET_CONTIGUOUS) | ET_B(ET_OPTIONAL) | ET_B(ET_SAVE) | ET_B(ET_IMPL_MANAGED))}, {"pinned", ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_ACCESS) | ET_B(ET_CONTIGUOUS) | ET_B(ET_IMPL_MANAGED))}, {"shared", ~(ET_B(ET_DIMENSION) | ET_B(ET_SAVE) | ET_B(ET_INTENT) | ET_B(ET_VOLATILE))}, {"constant", ~(ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_ACCESS) | ET_B(ET_PARAMETER))}, {"protected", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_AUTOMATIC) | ET_B(ET_STATIC) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_ASYNCHRONOUS) | ET_B(ET_CONTIGUOUS) | ET_B(ET_IMPL_MANAGED))}, {"asynchronous", ~(ET_B(ET_ACCESS) | ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_PARAMETER) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_AUTOMATIC) | ET_B(ET_STATIC) | ET_B(ET_BIND) | ET_B(ET_VALUE) | ET_B(ET_VOLATILE) | ET_B(ET_PROTECTED) | ET_B(ET_IMPL_MANAGED))}, {"texture", ~(ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_POINTER) | ET_B(ET_DEVICE) | ET_B(ET_SAVE))}, {"kind", 0}, /* 'no' field not used, so make it 0 */ {"len", 0}, /* 'no' field not used, so make it 0 */ {"contiguous", 0}, /* 'no' field not used, so make it 0 */ {"managed", ~(ET_B(ET_ALLOCATABLE) | ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_SAVE) | ET_B(ET_TARGET) | ET_B(ET_ACCESS) | ET_B(ET_CONTIGUOUS) | ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_IMPL_MANAGED))}, {"implicit-managed", 0}, /* 'no' field not used */ }; /* * Declarations for processing the attributes specified in a DEC ATTRIBUTES * declaration. */ #define DA_ALIAS 0 #define DA_C 1 #define DA_STDCALL 2 #define DA_DLLEXPORT 3 #define DA_DLLIMPORT 4 #define DA_VALUE 5 #define DA_REFERENCE 6 #define DA_DECORATE 7 #define DA_NOMIXEDSLA 8 #define DA_MAX 9 /* derive bit mask for each attribute type */ #define DA_B(e) (1 << e) /* * structure to record which attributes occurred for a DEC ATTRIBUTES * and BIND declaration. */ struct dec_attr_t { int exist; /* bit vector indicating which attributes exist */ int altname; /* sptr to a character constant representing alias */ }; static struct dec_attr_t dec_attr; static struct dec_attr_t bind_attr; static struct { char *name; int no; /* bit vector of attributes which do not coexist */ /* unlike the et[...].no values, it's easier to explicitly * specify those which do not coexist as opposed to the * negation of those which can coexist. */ } da[DA_MAX] = { {"alias", 0}, {"c", (DA_B(DA_STDCALL))}, {"stdcall", (DA_B(DA_C))}, {"dllexport", (0)}, {"dllimport", (0)}, {"value", (DA_B(DA_REFERENCE))}, {"reference", (DA_B(DA_VALUE))}, {"decorate", 0}, {"nomixed_str_len_arg", 0}, }; static void process_bind(int); static void defer_iface(int, int, int, int); static void do_iface(int); static void do_iface_module(void); static void _do_iface(int, int); static void fix_iface(int); static void fix_iface0(); //AOCC begin // variables used in assumed size expression computation extern int asz_count; /* number of rhs elements */ int asz_status = 0; /* lhs is assumed size expression */ int asz_arrdsc; /* array descriptor of assumed size lhs expression */ int asz_string = 0; /* indicator to indicate assumed length string */ int asz_id_elem; /* variable element in assumed size array */ extern int asz_id_elem_count_tot; /* total number of elements in assumed size array when variables are its elements */ //AOCC end /** \brief Initialize semantic analyzer for new user subprogram unit. */ void semant_init(int noparse) { if (!noparse) { if (sem.doif_base == NULL) { sem.doif_size = 12; NEW(sem.doif_base, DOIF, sem.doif_size); } sem.doif_depth = 0; DI_ID(0) = -1; DI_NEST(0) = 0; DI_LINENO(0) = 0; if (sem.stsk_base == NULL) { sem.stsk_size = 12; NEW(sem.stsk_base, STSK, sem.stsk_size); } sem.block_scope = 0; sem.doconcurrent_symavl = SPTR_NULL; sem.doconcurrent_dtype = DT_NONE; sem.stsk_depth = 0; scopestack_init(); sem.eqvlist = 0; sem.eqv_avail = 1; if (sem.eqv_size == 0) { sem.eqv_size = 20; NEW(sem.eqv_base, EQVV, sem.eqv_size); } sem.eqv_ss_avail = 1; if (sem.eqv_ss_size == 0) { sem.eqv_ss_size = 50; NEW(sem.eqv_ss_base, int, sem.eqv_ss_size); } EQV_NUMSS(0) = 0; sem.non_private_avail = 0; if (sem.non_private_size == 0) { sem.non_private_size = 50; NEW(sem.non_private_base, int, sem.non_private_size); } if (sem.typroc_base == NULL) { sem.typroc_size = 50; NEW(sem.typroc_base, int, sem.typroc_size); } sem.typroc_avail = 0; if (sem.iface_base == NULL) { sem.iface_size = 50; NEW(sem.iface_base, IFACE, sem.iface_size); } sem.iface_avail = 0; sem.pgphase = PHASE_INIT; sem.flabels = 0; /* not NOSYM - a sym's SYMLK is init'd to NOSYM. if * its SYMLK is NOSYM, then it hasn't been added */ sem.nml = NOSYM; sem.atemps = 0; sem.itemps = 0; sem.ptemps = 0; sem.savall = flg.save; sem.savloc = FALSE; sem.autoloc = FALSE; sem.psfunc = FALSE; sem.in_stfunc = FALSE; sem.dinit_error = FALSE; sem.dinit_data = FALSE; sem.equal_initializer = false; sem.proc_initializer = false; sem.dinit_nbr_inits = 0; sem.contiguous = XBIT(125, 0x80000); /* xbit is set for -Mcontiguous */ seen_implicit = FALSE; symutl.none_implicit = sem.none_implicit = flg.dclchk; seen_parameter = FALSE; } flg.sequence = TRUE; flg.hpf = FALSE; if (!noparse) { sem.ignore_stmt = FALSE; sem.switch_avl = 0; if (switch_base == NULL) { sem.switch_size = 400; NEW(switch_base, SWEL, sem.switch_size); } sem.temps_reset = FALSE; seen_options = FALSE; sem.gdtype = -1; lenspec[0].kind = 0; sem.seql.type = 0; /* [NO]SEQUENCE not yet seen */ sem.seql.next = NULL; /* sequence list is empty */ sem.dtemps = 0; sem.interface = 0; if (sem.interf_base == NULL) { sem.interf_size = 2; NEW(sem.interf_base, INTERF, sem.interf_size); } sem.p_dealloc = NULL; sem.p_dealloc_delete = NULL; sem.alloc_std = 0; clear_subp_prefix_settings(&subp_prefix); sem.accl.type = 0; /* PUBLIC/PRIVATE statement not yet seen */ sem.accl.next = NULL; /* access list is empty */ sem.in_struct_constr = 0; sem.atomic[0] = sem.atomic[1] = sem.atomic[2] = FALSE; sem.master.cnt = 0; sem.critical.cnt = 0; sem.intent_list = NULL; sem.symmetric = FALSE; sem.mpaccatomic.seen = sem.mpaccatomic.pending = sem.mpaccatomic.apply = sem.mpaccatomic.is_acc = FALSE; sem.mpaccatomic.ast = 0; sem.mpaccatomic.action_type = ATOMIC_UNDEF; sem.mpaccatomic.mem_order = MO_UNDEF; sem.mpaccatomic.rmw_op = AOP_UNDEF; sem.mpaccatomic.accassignc = 0; sem.parallel = 0; sem.task = 0; sem.orph = 0; sem.target = 0; sem.teams = 0; sem.expect_do = FALSE; sem.expect_simd_do = FALSE; sem.expect_dist_do = FALSE; sem.expect_acc_do = 0; sem.collapsed_acc_do = 0; sem.seq_acc_do = 0; sem.expect_cuf_do = 0; sem.close_pdo = FALSE; sem.is_hpf = FALSE; sem.hpfdcl = 0; sem.ssa_area = 0; sem.use_etmps = FALSE; sem.etmp_list = NULL; sem.auto_dealloc = NULL; sem.blksymnum = 0; sem.ignore_default_none = FALSE; sem.in_enum = FALSE; sem.type_mode = 0; sem.seen_import = FALSE; sem.seen_end_module = FALSE; sem.tbp_arg = 0; sem.tbp_arg_cnt = 0; sem.tbp_access_stmt = 0; sem.generic_tbp = 0; sem.auto_finalize = NULL; sem.type_initialize = NULL; sem.alloc_mem_initialize = NULL; sem.select_type_seen = 0; sem.param_offset = 0; sem.kind_type_param = 0; sem.len_type_param = 0; sem.type_param_candidate = 0; sem.len_candidate = 0; sem.kind_candidate = 0; sem.type_param_sptr = 0; sem.param_struct_constr = 0; sem.new_param_dt = 0; sem.extends = 0; sem.param_assume_sz = 0; sem.param_defer_len = 0; sem.save_aconst = 0; sem.defined_io_type = 0; sem.defined_io_seen = 0; sem.use_seen = 0; sem.ieee_features = FALSE; sem.collapse = sem.collapse_depth = 0; sem.stats.allocs = 0; sem.stats.nodes = 0; sem.modhost_proc = 0; sem.modhost_entry = 0; sem.in_array_const = false; sem.parsing_operator = false; mscall = 0; cref = 0; nomixedstrlen = 0; #if defined(TARGET_WIN) if (WINNT_CALL) mscall = 1; if (WINNT_CREF) cref = 1; if (WINNT_NOMIXEDSTRLEN) nomixedstrlen = 1; #endif } else { /* * Needed for handling the 03 allocatable semantics in semutil2.c via * transform which might occur during the IPA recompile. */ sem.p_dealloc = NULL; sem.p_dealloc_delete = NULL; } sem.sc = SC_LOCAL; stb.curr_scope = 0; ast_init(); /* ast.c */ init_intrinsic_opr(); /* semgnr.c */ import_init(); /* interf.c */ if (!noparse) { if (IN_MODULE) { mod_init(); host_present = 0x04; restore_implicit(); save_implicit(TRUE); } else if (gbl.internal) { /* hasn't been incremented yet */ host_present = 0x08; restore_implicit(); save_implicit(TRUE); } else { host_present = 0x02; } } clean_struct_default_init(stb.stg_avail); use_init(); /* module.c */ bblock_init(); /* bblock.c */ if (!noparse) { craft_intrinsics = FALSE; if (XBIT(49, 0x1040000)) /* T3D/T3E or C90 Cray targets */ change_predefineds(ST_CRAY, FALSE); end_of_host = 0; if (gbl.internal && sem.which_pass) restore_host_state(2); } else { if (gbl.internal) restore_host_state(4); } } /* for each SC_DUMMY parameter that is passed by value, copy it to a local (reference ) of the same name. all lookups will subsequently find this local */ static void reloc_byvalue_parameters() { INT dpdsc; INT psptr, sptr1; INT iarg; INT newsptr; INT vv; ITEM *itemp; /* Pointers to items */ char *name; int name_len; int byval_default = 0; int tmp_nmptr; int thesub; if (STYPEG(gbl.currsub) == ST_MODULE) return; for (thesub = gbl.currsub; thesub > NOSYM; thesub = SYMLKG(thesub)) { dpdsc = DPDSCG(thesub); for (iarg = PARAMCTG(thesub); iarg > 0; dpdsc++, iarg--) { psptr = *(aux.dpdsc_base + dpdsc); /* copy all parameters passed by value to local stack. arrays are always passed by reference unless specifically marked by value */ /* disable array and struct parameters passed by value */ if (((DTY(DTYPEG(psptr))) == TY_ARRAY) || ((DTY(DTYPEG(psptr))) == TY_STRUCT)) { if (PASSBYVALG(thesub) || PASSBYVALG(psptr)) error(84, 3, gbl.lineno, SYMNAME(psptr), "- VALUE derived types and arrays not yet supported"); } else byval_default = BYVALDEFAULT(thesub); if (PASSBYVALG(psptr) && OPTARGG(psptr)) { /* an address is passed for optional value arguments as if call by * reference, but the address is of a temp */ continue; } if ((byval_default || PASSBYVALG(psptr)) && (!PASSBYREFG(psptr)) && (DTY(DTYPEG(psptr)) != TY_ARRAY) && /* don't redo what we've already done */ (strncmp(SYMNAME(psptr), "_V_", 3) != 0)) { /* declare a new variable _V_ which subsumes the * original by value parameter. The original variable becomes * SC_LOCAL and all further user code references will be to this * SC_LOCAL var. * The copy of the by-value _V_ parameter to this local * is done at expand time. */ newsptr = lookupsymf("_V_%s", SYMNAME(psptr)); if (newsptr > NOSYM) { /* already exists */ *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */ return; } newsptr = getsymf("_V_%s", SYMNAME(psptr)); dup_sym(newsptr, stb.stg_base + psptr); /* also _V_... is the dummy*/ DCLDP(newsptr, TRUE); /* so DCLCHK is quiet */ REFP(newsptr, TRUE); SCP(psptr, SC_LOCAL); /* make the original a local*/ /* the byval flag on the original arg (psptr) is cleared in semfin */ MIDNUMP(newsptr, psptr); /* link from new symbol to original symbol */ *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */ for (itemp = sem.intent_list; itemp != NULL; itemp = itemp->next) { if (psptr == itemp->t.sptr) { itemp->t.sptr = newsptr; break; } } /* * The original symbol may not yet be classified as an object. * Take care of that here for the original symbol; semfin will * take of new symbol. */ switch (STYPEG(psptr)) { case ST_UNKNOWN: case ST_IDENT: STYPEP(psptr, ST_VAR); break; default:; } if (sem.which_pass) { /* the back-end will always copy _V_ to * ; make sure that is referenced. */ sym_is_refd(psptr); } } /* if pass by val */ else if (thesub != gbl.currsub && SCG(psptr) == SC_LOCAL) { /* presumably, thesub is an ST_ENTRY and the parameter has * already been processed; make sure to fix the DPDSC entry. */ newsptr = lookupsymf("_V_%s", SYMNAME(psptr)); if (newsptr) { *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */ } } } /* for all parameters */ } } static void end_subprogram_checks() { if (sem.master.cnt) error(155, 3, sem.master.lineno, "Unterminated MASTER", CNULL); if (sem.critical.cnt) error(155, 3, sem.critical.lineno, "Unterminated CRITICAL", CNULL); sem_err104(sem.doif_depth, DI_LINENO(sem.doif_depth), "unterminated"); } /* end_subprogram_checks */ static int restored = 0; /** \brief Semantic actions - part 1. \param rednum reduction number \param top top of stack after reduction */ void semant1(int rednum, SST *top) { SPTR sptr, sptr1, sptr2, block_sptr, sptr_temp, lab, sptras, asz_sptr; int dtype, dtypeset, ss, numss, dtypeas; int stype, stype1, i; int begin, end, count; int opc; int std; INT rhstop, rhsptr; LOGICAL inited; ITEM *itemp, /* Pointers to items */ *itemp1; INT conval; int doif; int evp; ADSC *ad; ADSC *adas; char *np, *np2; /* char ptrs to symbol names area */ int name_prefix_char; char *nmptr; VAR *ivl; /* Initializer Variable List */ ACL *ict, *ict1; /* Initializer Constant Tree */ int ast, alias; int asz_ast; int res; static int et_type; /* one of ET_...; '::=' passes up */ int et_bitv; LOGICAL no_init; /* init not allowed for entity decl */ int func_result; /* sptr of ident in result ( ident ) */ ACL *aclp; ACL *tmpaclp; ACCL *accessp; int gnr; LOGICAL is_array; LOGICAL is_member; INT val[2]; int mndsc; LOGICAL is_first; int constarraysize; /* set to 1 if array bounds are constant */ ISZ_T arraysize; /* the actual array size; check for < 0 */ static int da_type; /* one of DA_...; '::=' passes up */ PHASE_TYPE prevphase; INT id_name; INT result_name; int construct_name; int dpdsc; SST *e1; static int proc_interf_sptr; /* passed up */ /* for deepcopy */ bool is_duplicate_decl; int bfind; int newpolicymemid; int newpolicyidx; int newshapeid; int idptemp, newsubidx; int symi; //AOCC begin SST *asz_sst; SST *asz_rhssst; asz_sst = (SST *)getitem(sem.ssa_area, sizeof(SST)); asz_rhssst = (SST *)getitem(sem.ssa_area, sizeof(SST)); //AOCC end switch (rednum) { /* ------------------------------------------------------------------ */ /* * ::= */ case SYSTEM_GOAL_SYMBOL1: break; /* ------------------------------------------------------------------ */ /* * ::= */ case STMT1: break; /* ------------------------------------------------------------------ */ /* * ::= */ case STBEG1: if (sem.in_enum) { switch (scn.stmtyp) { case TK_ENUMERATOR: case TK_ENDENUM: break; default: error(155, 3, gbl.lineno, "ENUMERATOR statement expected", CNULL); sem.ignore_stmt = TRUE; break; } } sem.is_hpf = scn.is_hpf; sem.alloc_std = 0; sem.p_dealloc_delete = NULL; if (sem.pgphase == PHASE_USE) { switch (scn.stmtyp) { case TK_USE: case TK_INCLUDE: break; default: apply_use_stmts(); if (sem.deferred_func_kind) { get_retval_KIND_value(); } if (sem.deferred_func_len) { get_retval_LEN_value(); } if (sem.deferred_dertype) { get_retval_derived_type(); } break; } } if (sem.pgphase == 0 && sem.interface && gbl.currsub == 0) { if (scn.stmtyp == TK_USE) { error(155, 3, gbl.lineno, "USE", "is not in a correct position."); sem.ignore_stmt = TRUE; } } if (sem.deferred_func_kind && (sem.pgphase > PHASE_USE || is_exe_stmt)) { get_retval_KIND_value(); } if (sem.deferred_func_len && (sem.pgphase > PHASE_USE || is_exe_stmt)) { get_retval_LEN_value(); } if (sem.deferred_dertype && (sem.pgphase > PHASE_USE || is_exe_stmt)) { get_retval_derived_type(); } if (!sem.interface && sem.pgphase < PHASE_EXEC && (is_exe_stmt = is_executable(sem.tkntyp)) && !sem.block_scope) { if (!IN_MODULE) do_iface(0); else do_iface_module(); reloc_byvalue_parameters(); if (sem.which_pass == 1 && restored == 0) { restore_internal_subprograms(); restored = 1; } } if (sem.expect_do || sem.expect_acc_do || sem.expect_simd_do || sem.expect_dist_do || (sem.expect_cuf_do && XBIT(137, 0x20000))) { int stt; stt = sem.tkntyp; if (stt == TK_NAMED_CONSTRUCT) stt = get_named_stmtyp(); if (stt != TK_DO) { char *p; switch (DI_ID(sem.doif_depth)) { case DI_ACCDO: sem.doif_depth--; /* remove from stack */ p = "ACC DO"; break; case DI_ACCLOOP: sem.doif_depth--; /* remove from stack */ p = "ACC LOOP"; break; case DI_ACCREGDO: sem.doif_depth--; /* remove from stack */ p = "ACC REGION DO"; break; case DI_ACCREGLOOP: sem.doif_depth--; /* remove from stack */ p = "ACC REGION LOOP"; break; case DI_ACCKERNELSDO: sem.doif_depth--; /* remove from stack */ p = "ACC KERNELS DO"; break; case DI_ACCKERNELSLOOP: sem.doif_depth--; /* remove from stack */ p = "ACC KERNELS LOOP"; break; case DI_ACCPARALLELDO: sem.doif_depth--; /* remove from stack */ p = "ACC PARALLEL DO"; break; case DI_ACCPARALLELLOOP: sem.doif_depth--; /* remove from stack */ p = "ACC PARALLEL LOOP"; break; case DI_ACCSERIALLOOP: sem.doif_depth--; /* remove from stack */ p = "ACC SERIAL LOOP"; break; case DI_CUFKERNEL: sem.doif_depth--; /* remove from stack */ p = "CUDA KERNEL DO"; break; case DI_PDO: if (DI_ISSIMD(sem.doif_depth)) p = "OMP DO SIMD"; else p = "OMP DO"; sem.doif_depth--; /* remove PDO from stack */ par_pop_scope(); break; case DI_TARGETSIMD: sem.doif_depth--; /* remove from TARGET SIMD stack */ p = "OMP TARGET SIMD"; par_pop_scope(); break; case DI_SIMD: sem.doif_depth--; /* remove from SIMD stack */ p = "OMP SIMD"; par_pop_scope(); break; case DI_DISTRIBUTE: sem.doif_depth--; /* remove from DISTRIBUTE stack */ p = "OMP DISTRIBUTE"; par_pop_scope(); break; case DI_TARGPARDO: sem.doif_depth--; /* remove from TARGET PARALLEL DO stack */ p = "OMP TARGET PARALLEL DO"; par_pop_scope(); break; case DI_DISTPARDO: sem.doif_depth--; /* remove from stack */ p = "OMP DISTRIBUTE PARALLEL DO"; par_pop_scope(); if (scn.stmtyp == TK_MP_ENDTEAMS) { /* distribute parallel do */ break; } else if (scn.stmtyp == TK_MP_ENDTARGET) { /* teams distribute parallel do */ par_pop_scope(); } else if (DI_ID(sem.doif_depth) == DI_TEAMS) { /* if the previous stack id is DI_TEAMS * and scn.stmtyp != TK_MP_ENDTEAMS, then * this is target teams distribute parallel do * construct: pop teams and target as we manually * add stack for those. */ par_pop_scope(); par_pop_scope(); } break; case DI_DOACROSS: p = "DOACROSS"; goto reset_st; case DI_PARDO: if (DI_ISSIMD(sem.doif_depth)) p = "PARALLEL DO SIMD"; else p = "PARALLEL DO"; reset_st: sem.doif_depth--; /* remove from stack */ /* restore symbol table state */ par_pop_scope(); break; case DI_TASKLOOP: sem.doif_depth--; /* remove from stack */ p = "OMP TASKLOOP"; par_pop_scope(); break; default: p = "???"; break; } error(155, 3, gbl.lineno, "DO loop expected after", p); sem.expect_do = FALSE; sem.expect_simd_do = FALSE; sem.expect_dist_do = FALSE; sem.expect_acc_do = 0; sem.collapsed_acc_do = 0; sem.seq_acc_do = 0; sem.expect_cuf_do = 0; sem.collapse = sem.collapse_depth = 0; } } else if (sem.collapse_depth) { int stt; stt = sem.tkntyp; if (stt == TK_NAMED_CONSTRUCT) stt = get_named_stmtyp(); if (stt != TK_DO) { /* * The collapse value is larger than the number of loops; * this needs to be a fatal error since the DOIF stack * is probably inconsistent wrt matching ENDDOs etc. */ error(155, 4, gbl.lineno, "DO loop expected after", "COLLAPSE"); sem.collapse = sem.collapse_depth = 0; } } if (sem.close_pdo) { sem.close_pdo = FALSE; switch (DI_ID(sem.doif_depth)) { case DI_PDO: if (scn.stmtyp != TK_MP_ENDPDO && scn.stmtyp != TK_MP_ENDDOSIMD) { if (A_TYPEG(STD_AST(STD_PREV(0))) != A_MP_BARRIER) (void)add_stmt(mk_stmt(A_MP_BARRIER, 0)); sem.doif_depth--; /* pop DOIF stack */ } /* else ENDPDO pops the stack */ break; case DI_DISTRIBUTE: if (scn.stmtyp != TK_MP_ENDDISTRIBUTE) { sem.doif_depth--; /* pop DOIF stack */ } /* else ENDDISTRIBUTE pops the stack */ break; case DI_TEAMSDIST: if (scn.stmtyp != TK_MP_ENDTEAMSDIST) { sem.doif_depth--; /* pop DOIF stack */ end_teams(); } /* else ENDTEAMSDIST pops the stack */ break; case DI_TARGTEAMSDIST: if (scn.stmtyp != TK_MP_ENDTARGTEAMSDIST) { sem.doif_depth--; /* pop DOIF stack */ end_teams(); end_target(); } /* else ENDTEAMSDIST pops the stack */ break; case DI_TARGPARDO: if (scn.stmtyp != TK_MP_ENDTARGPARDO) { (void)add_stmt(mk_stmt(A_MP_BARRIER, 0)); sem.doif_depth--; /* pop DOIF stack */ end_target(); } /* else ENDTARGPARDO[SIMD] pops the stack */ break; case DI_TEAMSDISTPARDO: if (scn.stmtyp != TK_MP_ENDTEAMSDISTPARDO && scn.stmtyp != TK_MP_ENDTEAMSDISTPARDOSIMD) { sem.doif_depth--; /* pop DOIF stack */ end_teams(); } /* else ENDTEAMSDISTPARDO[SIMD] pops the stack */ break; case DI_TARGTEAMSDISTPARDO: if (scn.stmtyp != TK_MP_ENDTARGTEAMSDISTPARDO && scn.stmtyp != TK_MP_ENDTARGTEAMSDISTPARDOSIMD) { sem.doif_depth--; /* pop DOIF stack */ end_teams(); end_target(); } /* else ENDTARGTEAMSDISTPARDO[SIMD] pops the stack */ break; case DI_DISTPARDO: if (scn.stmtyp != TK_MP_ENDDISTPARDO && scn.stmtyp != TK_MP_ENDDISTPARDOSIMD) { sem.doif_depth--; /* pop DOIF stack */ } break; case DI_TARGETSIMD: if (scn.stmtyp != TK_MP_ENDTARGSIMD) { sem.doif_depth--; /* pop DOIF stack */ end_target(); } /* else ENDTARGETSIMD pops the stack */ break; case DI_SIMD: if (scn.stmtyp != TK_MP_ENDSIMD) { sem.doif_depth--; /* pop DOIF stack */ } /* else ENDSIMD pops the stack */ break; case DI_DOACROSS: /* the DOIF stack could have been popped when the * DO loop was closed, but it's done here with * the other DO directives. */ sem.doif_depth--; /* pop DOIF stack */ break; case DI_PARDO: if (scn.stmtyp != TK_MP_ENDPARDO) { sem.doif_depth--; /* pop DOIF stack */ /* else ENDPARDO pops the stack */ } if (sem.doif_depth && has_target) { if (scn.stmtyp != TK_MP_ENDTARGPARDO && scn.stmtyp != TK_MP_ENDTARGET) { end_target(); } has_target = false; } break; case DI_TASKLOOP: if (scn.stmtyp != TK_MP_ENDTASKLOOP) { sem.doif_depth--; /* pop DOIF stack */ /* else ENDTASKLOOP pops the stack */ } break; case DI_TARGET: if(scn.stmtyp != TK_MP_ENDTARGET && scn.stmtyp != TK_MP_ENDTARGSIMD){ end_target(); } break; default: break; } } break; /* ------------------------------------------------------------------ */ /* * ::= */ case STEND1: if (sem.pgphase >= PHASE_EXEC) { if (sem.atomic[0]) { sem.atomic[0] = sem.atomic[1] = sem.atomic[2] = FALSE; error(155, 3, gbl.lineno, "Statement after ATOMIC UPDATE is not an assignment", CNULL); } else { sem.atomic[0] = sem.atomic[1]; sem.atomic[1] = FALSE; } // AOCC: Allows the omp atomics read/write construct declation inside // omp critical construct if (sem.mpaccatomic.pending && sem.mpaccatomic.action_type != ATOMIC_CAPTURE && // AOCC begin (sem.mpaccatomic.action_type != ATOMIC_READ && sem.mpaccatomic.action_type != ATOMIC_WRITE)) { // AOCC end error(155, 3, gbl.lineno, "Statement after ATOMIC UPDATE is not an assignment", CNULL); } if (sem.mpaccatomic.seen && sem.mpaccatomic.action_type != ATOMIC_CAPTURE) { if ((!sem.mpaccatomic.is_acc && use_opt_atomic(sem.doif_depth))) { ; } else { // AOCC: removing this if condition as sem.mpaccatomic.is_acc is not // a valid check here /*if (sem.mpaccatomic.is_acc)*/ sem.mpaccatomic.seen = FALSE; sem.mpaccatomic.pending = TRUE; } } } freearea(0); /* free ITEM list areas */ sem.new_param_dt = 0; sem.param_offset = 0; sem.kind_type_param = 0; sem.len_type_param = 0; sem.type_param_candidate = 0; sem.len_candidate = 0; sem.kind_candidate = 0; sem.type_param_sptr = 0; sem.param_struct_constr = 0; sem.save_aconst = 0; sem.tbp_arg = 0; sem.tbp_arg_cnt = 0; sem.extends = 0; if (sem.select_type_seen > 1) { error(155, 3, gbl.lineno, "Only a CLASS IS, TYPE IS, CLASS DEFAULT, or END SELECT" " statement may follow a SELECT TYPE statement", CNULL); } else if (sem.select_type_seen == 1) { sem.select_type_seen = 2; } else { sem.select_type_seen = 0; } if (flg.smp && sem.doif_base && sem.doif_depth && DI_ID(sem.doif_depth) != DI_SELECT_TYPE) check_no_scope_sptr(); entity_attr.access = ' '; /* Need to reset entity access */ sem.parsing_operator = false; sem.equal_initializer = false; sem.proc_initializer = false; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case STATEMENT1: prevphase = sem.pgphase; sem.gdtype = -1; lenspec[0].kind = 0; /*if( sem.which_pass == 1 ) restore_internal_subprograms();*/ restored = 0; goto statement_shared; /* * ::= | */ case STATEMENT2: prevphase = sem.pgphase; SST_ASTP(LHS, SST_ASTG(RHS(3))); goto statement_shared; /* * ::= | */ case STATEMENT3: sem.class = 0; prevphase = sem.pgphase; if (scn.stmtyp == TK_IMPLICIT) { if (sem.pgphase > PHASE_IMPLICIT) errsev(70); else sem.pgphase = PHASE_IMPLICIT; } else if (scn.stmtyp == TK_DATA || scn.stmtyp == TK_NAMELIST) { if (sem.pgphase > PHASE_EXEC) errsev(70); else if (sem.pgphase < PHASE_SPEC) sem.pgphase = PHASE_SPEC; } else if (scn.stmtyp == TK_INTERFACE || scn.stmtyp == TK_ABSTRACT) { sem.pgphase = PHASE_INIT; prevphase = PHASE_INIT; } else if (scn.stmtyp == TK_PARAMETER) { if (sem.pgphase > PHASE_SPEC) errsev(70); else if (sem.pgphase < PHASE_IMPLICIT) sem.pgphase = PHASE_IMPLICIT; } else if (scn.stmtyp == TK_USE) { if (sem.pgphase > PHASE_USE) errsev(70); else if (sem.pgphase < PHASE_USE) sem.pgphase = PHASE_USE; } else if (scn.stmtyp == TK_IMPORT) { if (sem.pgphase > PHASE_IMPORT) errsev(70); else if (sem.pgphase < PHASE_IMPORT) sem.pgphase = PHASE_IMPORT; } else { if (sem.pgphase > PHASE_SPEC) errsev(70); /* allow for routine before a use statement */ /* allow for attributes before a use statement */ else if (scn.stmtyp != TK_ATTRIBUTES && scn.stmtyp != TK_MP_DECLARESIMD) sem.pgphase = PHASE_SPEC; } sem.gdtype = -1; lenspec[0].kind = 0; goto statement_shared; /* * ::= | */ case STATEMENT4: prevphase = sem.pgphase; SST_ASTP(LHS, SST_ASTG(RHS(3))); goto statement_shared; /* * ::= | */ case STATEMENT5: prevphase = sem.pgphase; SST_ASTP(LHS, SST_ASTG(RHS(3))); goto executable_shared; /* * ::= | */ case STATEMENT6: prevphase = sem.pgphase; SST_ASTP(LHS, SST_ASTG(RHS(3))); goto executable_shared; /* * ::= | */ case STATEMENT7: prevphase = sem.pgphase; goto statement_end; /* * ::= | */ case STATEMENT8: prevphase = sem.pgphase; if (sem.pgphase == PHASE_INIT) sem.pgphase = PHASE_HEADER; /* * Allow semant ccsym vars allocated by get_temp to be re-used for * the next statement, if necessary: */ sem.temps_reset = FALSE; SST_ASTP(LHS, SST_ASTG(RHS(3))); if (SST_ASTG(LHS)) /* TBD: delete this and next stmt */ (void)add_stmt((int)SST_ASTG(LHS)); goto statement_end; /* * ::= | */ case STATEMENT9: prevphase = sem.pgphase; if (scn.currlab) { errlabel(18, 3, gbl.lineno, SYMNAME(scn.currlab), "- must be followed by a keyword or an identifier"); ast = mk_stmt(A_CONTINUE, 0); SST_ASTP(LHS, ast); DEFDP(scn.currlab, 1); goto executable_shared; } SST_ASTP(LHS, 0); /* don't change sem.pgphase */ break; /* * ::= | */ case STATEMENT10: /* * Initialize AST field since an A_END is not generated for the end * of a host subprogram containing internal procedures */ prevphase = sem.pgphase; if (!sem.interface && sem.pgphase < PHASE_EXEC) { reloc_byvalue_parameters(); if (sem.which_pass == 1 && restored == 0) { restore_internal_subprograms(); restored = 1; } } SST_ASTP(LHS, 0); if (sem.interface) { if ((gnr = sem.interf_base[sem.interface - 1].generic)) { if (GTYPEG(gnr) && gbl.rutype == RU_SUBR) { error(155, 3, gbl.lineno, "Generic INTERFACE with the same name as a " "derived type may only contain functions -", SYMNAME(gbl.currsub)); GTYPEP(gnr, 0); } if (GNCNTG(gnr) == 0) sem.interf_base[sem.interface - 1].gnr_rutype = gbl.rutype; else if (sem.interf_base[sem.interface - 1].gnr_rutype && sem.interf_base[sem.interface - 1].gnr_rutype != gbl.rutype) { errWithSrc(155, 3, SST_LINENOG(RHS(2)), "Generic INTERFACE may not mix functions and subroutines", CNULL, SST_COLUMNG(RHS(2)), 0, false, CNULL); } if (gbl.currsub) add_overload(gnr, gbl.currsub); } else if ((gnr = sem.interf_base[sem.interface - 1].operator)) { if (sem.interf_base[sem.interface - 1].opval == OP_ST) { if (gbl.rutype != RU_SUBR) error(155, 3, gbl.lineno, "Assignment INTERFACE requires subroutines -", SYMNAME(gbl.currsub)); else if (PARAMCTG(gbl.currsub) != 2) error(155, 3, gbl.lineno, "Assignment INTERFACE requires subroutines 2 arguments -", SYMNAME(gbl.currsub)); } else { if (gbl.rutype != RU_FUNC) error(155, 3, gbl.lineno, "Operator INTERFACE requires functions -", SYMNAME(gbl.currsub)); else if (PARAMCTG(gbl.currsub) != 1 && PARAMCTG(gbl.currsub) != 2) error( 155, 3, gbl.lineno, "Operator INTERFACE requires functions with 1 or 2 arguments -", SYMNAME(gbl.currsub)); } add_overload(gnr, gbl.currsub); } if (gbl.currsub) pop_subprogram(); break; } if (gbl.rutype == RU_BDATA) { /* error if executable statements in block data: */ if (sem.pgphase > PHASE_SPEC) errsev(71); } else if (!end_of_host && SST_IDG(RHS(2))) { chk_adjarr(); /* any extra code for adjustable arrays */ end_subprogram_checks(); } /* * The END statement may be for a module or subprogram. If a * subprogram, the end AST is generated and semfin() is called. * If the end of a module, there are two cases: * 1. only specifications were seen (i.e., no contained subprograms); * since the module blockdata will be output, the end AST needs * to be generated, however, semfin() can't be called. * 2. module subprograms were present; the module blockdata was * already written when the CONTAINS was seen; no END ast is * necessary; semfin() still can't be called. */ if (gbl.currsub || gbl.rutype == RU_PROG) SST_ASTP(LHS, mk_stmt(A_END, 0)); if (SST_IDG(RHS(2))) /* end of subprogram */ sem.pgphase = PHASE_END; else sem.pgphase = PHASE_END_MODULE; /* end of module */ goto statement_shared; /* * ::= */ case STATEMENT11: prevphase = sem.pgphase; goto statement_end; /* * ::= INCLUDE */ case STATEMENT12: prevphase = sem.pgphase; sptr = SST_SYMG(RHS(2)); scan_include(stb.n_base + CONVAL1G(sptr)); goto statement_end; /* * ::= OPTIONS | * [stuff that follows OPTIONS is not parsed - hidden by scanner] */ case STATEMENT13: prevphase = sem.pgphase; if (flg.standard) error(171, 2, gbl.lineno, "OPTIONS", CNULL); if (sem.pgphase != PHASE_INIT || seen_options) errsev(70); else { scan_options(); seen_options = TRUE; } goto statement_end; /* * ::= CONTAINS | */ case STATEMENT14: prevphase = sem.pgphase; SST_ASTP(LHS, 0); /*do_iface(0);*/ reloc_byvalue_parameters(); if (sem.pgphase >= PHASE_CONTAIN) errsev(70); sem.pgphase = PHASE_CONTAIN; if (gbl.currsub) { /* internal subprogram context */ if (gbl.rutype == RU_BDATA) { errsev(70); goto executable_shared; } if (gbl.internal) { error(155, 3, gbl.lineno, "Internal subprograms may not be nested", CNULL); goto executable_shared; } convert_intrinsics_to_idents(); save_host(&host_state); gbl.internal = 1; if (sem.which_pass == 0) gbl.empty_contains = FALSE; restore_host(&host_state, TRUE); if (sem.which_pass == 0) { /* * when first processing an internal procedure within a module * subprogram, need to save the state of the host which will be * restored for subsequent internal procedures within the same * module subprogram. Note that the scanner ensures that the * end statement of the internal procedure in this context * (processing a module the first time) does not terminate * compilation (scn.end_program_unit is FALSE). */ save_host_state(0x3); sem.pgphase = PHASE_INIT; SST_ASTP(LHS, 0); } else { chk_adjarr(); /* any extra code for adjustable arrays */ end_subprogram_checks(); fix_class_args(gbl.currsub); save_host_state(0x11); /* * When the CONTAINS is seen, ensure that an END ast is * generated for the host subprogram. * Note that scan has set 'scn.end_program_unit to TRUE'. */ if (sem.end_host_labno && sem.which_pass) { int labsym = getsymf(".L%05ld", (long)sem.end_host_labno); /* * If a label was present on the end statement of the * host subprogram, need to define & emit the label now. */ int lab = declref(labsym, ST_LABEL, 'd'); if (DEFDG(lab)) errlabel(97, 3, 0, SYMNAME(labsym), CNULL); else scn.currlab = lab; L3FP(lab, 1); /* HACK - disable errorcheck in scan.c*/ } SST_ASTP(LHS, mk_stmt(A_END, 0)); } sem.end_host_labno = 0; goto statement_shared; } if (IN_MODULE) { if (ANCESTORG(gbl.currmod) && !HAS_SMP_DECG(ANCESTORG(gbl.currmod))) error(1210, ERR_Severe, gbl.lineno, SYMNAME(ANCESTORG(gbl.currmod)), CNULL); fe_save_state(); begin_contains(); sem.pgphase = PHASE_INIT; /* * When the CONTAINS is seen, emit a blockdata just in case any * data statements are seen; ensure that an END ast is generated. * Note that scan has set 'scn.end_program_unit to TRUE'. */ SST_ASTP(LHS, mk_stmt(A_END, 0)); goto statement_shared; } errsev(70); goto executable_shared; /* * ::= */ case STATEMENT15: prevphase = sem.pgphase; if (sem.interface == 0) { ast = mk_comstr(scn.directive); (void)add_stmt(ast); } goto statement_end; executable_shared: sem.pgphase = PHASE_EXEC; sem.temps_reset = FALSE; /* fall thru to 'statement_shared' */ statement_shared: if ((ast = SST_ASTG(LHS))) { (void)add_stmt(ast); SST_ASTG(LHS) = 0; } sem.dinit_error = FALSE; gen_deallocate_arrays(); if (sem.atomic[2]) { ast = mk_stmt(A_ENDATOMIC, 0); (void)add_stmt(ast); sem.atomic[0] = sem.atomic[2] = FALSE; } if (sem.mpaccatomic.apply && sem.mpaccatomic.action_type != ATOMIC_CAPTURE) { int ecs; sem.mpaccatomic.apply = FALSE; if (!sem.mpaccatomic.is_acc) { if (use_opt_atomic(sem.doif_depth)) { ecs = mk_stmt(A_MP_ENDATOMIC, 0); add_stmt(ecs); } else { ecs = emit_bcs_ecs(A_MP_ENDCRITICAL); /* point to each other */ A_LOPP(ecs, sem.mpaccatomic.ast); A_LOPP(sem.mpaccatomic.ast, ecs); } sem.mpaccatomic.ast = 0; } else { int ast_atomic; ast_atomic = mk_stmt(A_ENDATOMIC, 0); add_stmt(ast_atomic); A_LOPP(ast_atomic, sem.mpaccatomic.ast); A_LOPP(sem.mpaccatomic.ast, ast_atomic); sem.mpaccatomic.ast = 0; } } /* * If the current statement is labeled and we are inside a DO [WHILE| * CONCURRENT] loop, search to see if this statement ends the loop. * * OpenMP ARB interpretations version 1.0: * If a do loop nest which shares the same termination statement is * followed by an ENDDO or ENDPARALLEL, the DO or PARALLEL DO can * only be specified for the outermost DO. */ if (scn.currlab != 0 && sem.doif_depth > 0) { int par_type = 0; /* nonzero => par do needs to be closed */ for (doif = sem.doif_depth; doif > 0; --doif) { if ((DI_ID(doif) == DI_DO || DI_ID(doif) == DI_DOWHILE || DI_ID(doif) == DI_DOCONCURRENT) && DI_DO_LABEL(doif) == scn.currlab) { switch (par_type) { /* * If a parallel do appears between two do loops sharing the * same termination statement, close the parallel do now. * (The innermost do loop is the parallel do.) */ case DI_PDO: case DI_TARGETSIMD: case DI_SIMD: case DI_DISTRIBUTE: case DI_DISTPARDO: case DI_DOACROSS: case DI_PARDO: case DI_TASKLOOP: case DI_ACCDO: case DI_ACCLOOP: case DI_CUFKERNEL: sem.close_pdo = FALSE; --sem.doif_depth; par_type = 0; } do_end(DI_DOINFO(doif)); if (sem.which_pass) direct_loop_end(DI_LINENO(doif), gbl.lineno); par_type = DI_ID(sem.doif_depth); } } } /* For END statements clean up end of program unit. */ if (sem.pgphase == PHASE_END) { if (!end_of_host) { semfin(); if (IN_MODULE && sem.interface == 0) mod_end_subprogram_two(); if (sem.which_pass != 0 || gbl.internal == 0) semfin_free_memory(); if (sem.which_pass == 0) { /* CONTAINS clause has an empty body without any internal subprograms */ if (gbl.internal == 1) { /* even if it CONTAINS no internal routine, still need to change the entry points of the containing */ if (STYPEG(gbl.currsub) == ST_ENTRY) STYPEP(gbl.currsub, ST_PROC); gbl.currsub = 0; gbl.internal = 0; gbl.empty_contains = TRUE; gbl.p_adjarr = NOSYM; gbl.p_adjstr = NOSYM; } else if (gbl.internal > 1) { /* * we're at the end of an internal procedure within a * a module during the first pass over the module. * The scanner does not set scn.end_program_unit to TRUE * in this context. So now, need to reinitialize for the * next internal subprogram if it appears. */ restore_host_state(1); restore_host(&host_state, TRUE); gbl.currsub = 0; sem.pgphase = PHASE_INIT; gbl.p_adjarr = NOSYM; gbl.p_adjstr = NOSYM; } } } else { if (IN_MODULE && sem.interface == 0) { gbl.currsub = end_of_host; mod_end_subprogram_two(); gbl.currsub = 0; } semfin_free_memory(); } } else if (sem.pgphase == PHASE_END_MODULE) { /* end of module */ sem.pgphase = PHASE_INIT; /* * For a module containing just specifications, end_module() calls * semfin() in which case sem.doif_base is NULL. * For a module with contained subprograms, semfin() isn't called * after the last END statement. */ semfin_free_memory(); if (sem.which_pass) { gbl.currmod = 0; } } else if (sem.pgphase == PHASE_CONTAIN && gbl.internal && sem.which_pass) { /* end of host subprogram*/ semfin(); if (sem.mod_sym && sem.interface == 0) mod_end_subprogram_two(); if (sem.which_pass != 0 || gbl.internal == 0) semfin_free_memory(); } /* * Allow semant ccsym vars allocated by get_temp to be re-used for * the next statement, if necessary: */ sem.temps_reset = FALSE; /* fall thru to 'statement_end' */ statement_end: /* Processing for all s terminates here */ if (STYPEG(gbl.currsub) == ST_ENTRY && FVALG(gbl.currsub) && prevphase <= PHASE_USE && sem.pgphase > PHASE_USE) { int retdtype = DTYPEG(FVALG(gbl.currsub)); int dtsptr = DTY(retdtype + 3); if (DTY(retdtype) == TY_DERIVED && dtsptr > NOSYM && !DCLDG(dtsptr)) { fixup_function_return_type(retdtype, dtsptr); } } sem.last_std = STD_PREV(0); break; /* ------------------------------------------------------------------ */ /* * ::= */ case III1: if (sem.interface) { error(155, 1, gbl.lineno, "Statement is redundant in an INTERFACE block", CNULL); sem.ignore_stmt = TRUE; } /* check whether we have entered a program as yet */ if (sem.scope_level == 0) { dummy_program(); restored = 0; } break; /* ------------------------------------------------------------------ */ /* * ::= */ case NII1: if (sem.interface) { errsev(195); sem.ignore_stmt = TRUE; } /* check whether we have entered a program as yet */ if (sem.scope_level == 0) { dummy_program(); restored = 0; } break; /* ------------------------------------------------------------------ */ /* * ::= */ case NIM1: if (IN_MODULE_SPEC) { ERR310("Illegal statement in the specification part of a MODULE", CNULL); sem.ignore_stmt = TRUE; } break; /* ------------------------------------------------------------------ */ /* * ::= */ case PGM1: /* check that we have entered a program as yet */ if (sem.scope_level == 0) dummy_program(); break; /* ------------------------------------------------------------------ */ /* * ::= */ case END1: if (!sem.interface && sem.pgphase < PHASE_EXEC) { if (gbl.currsub && !sem.which_pass) { do_iface(0); } if (!IN_MODULE) do_iface(1); else do_iface_module(); } else if (sem.which_pass && !IN_MODULE && gbl.internal <= 1) { do_iface(1); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case PROG_TITLE1: itemp = ITEM_END; func_result = 0; goto prog_title; /* * ::= ( ) | */ case PROG_TITLE2: itemp = ITEM_END; func_result = SST_SYMG(RHS(4)); goto prog_title; /* * ::= ( ) | */ case PROG_TITLE3: itemp = SST_BEGG(RHS(3)); func_result = SST_SYMG(RHS(5)); prog_title: /* no parameters allowed for programs */ if (gbl.rutype == RU_PROG && itemp != ITEM_END) errsev(41); if (!sem.interface) gbl.funcline = gbl.lineno; if (gbl.rutype == RU_FUNC) { /* reserve one extra space in case this a function requires an * extra argument - a new argument may be inserted at the * beginning of the list. */ NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + 100); *(aux.dpdsc_base + (aux.dpdsc_avl++)) = 0; } DPDSCP(gbl.currsub, aux.dpdsc_avl); NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + 100); *(aux.dpdsc_base + (aux.dpdsc_avl)) = 0; count = 0; for (; itemp != ITEM_END; itemp = itemp->next) { sptr = itemp->t.sptr; if (sptr == 0) { /* alternate return designator (i.e. *) */ if (gbl.rutype != RU_SUBR) errsev(49); else if (!sem.interface) gbl.arets = TRUE; } else { if ((sptr < gbl.currsub) && IN_MODULE) { sptr = insert_sym(sptr); } sptr = declsym(sptr, ST_IDENT, TRUE); if (SCG(sptr) != SC_NONE) error(42, 3, gbl.lineno, SYMNAME(sptr), CNULL); SCP(sptr, SC_DUMMY); if (sem.interface) { NODESCP(sptr, 1); IGNOREP(sptr, TRUE); } } count++; NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + 100); *(aux.dpdsc_base + (aux.dpdsc_avl++)) = sptr; } /* Set parameter count * * For procedure pointer symbols it should go into dtype, for old style * procedure symbols use PARAMCT attribute. * * FIXME this might need to go into a function */ if (is_procedure_ptr(gbl.currsub)) { set_proc_ptr_param_count_dtype(DTYPEG(gbl.currsub), count); } else { PARAMCTP(gbl.currsub, count); } SST_ASTP(LHS, 0); if (IN_MODULE && sem.interface == 0) gbl.currsub = mod_add_subprogram(gbl.currsub); record_func_result(gbl.currsub, func_result, FALSE /* not in ENTRY */); if (bind_attr.exist != -1) { process_bind(gbl.currsub); bind_attr.exist = -1; bind_attr.altname = 0; } break; /* * ::= BLOCKDATA | */ case PROG_TITLE4: rhstop = 1; gbl.rutype = RU_BDATA; sem.module_procedure = false; SST_SYMP(RHS(rhstop), getsymbol(".blockdata.")); CCSYMP(SST_SYMG(RHS(rhstop)), 1); if (IN_MODULE) ERR310("BLOCKDATA may not appear in a MODULE", CNULL); goto routine_id; /* * ::= BLOCKDATA | */ case PROG_TITLE5: rhstop = 2; gbl.rutype = RU_BDATA; sem.module_procedure = false; if (IN_MODULE) ERR310("BLOCKDATA may not appear in a MODULE", CNULL); goto routine_id; /* * ::= MODULE | */ case PROG_TITLE6: sem.submod_sym = 0; sptr = begin_module(SST_SYMG(RHS(2))); sptr1 = NOSYM; goto module_shared; /* * ::= SUBMODULE ( ) | */ case PROG_TITLE7: sem.submod_sym = SST_SYMG(RHS(5)); sptr = begin_submodule(sem.submod_sym, SST_SYMG(RHS(3)), NOSYM, &sptr1); STYPEP(sem.submod_sym, ST_MODULE); goto module_shared; /* * ::= SUBMODULE ( : ) | */ case PROG_TITLE8: sem.submod_sym = SST_SYMG(RHS(7)); sptr = begin_submodule(sem.submod_sym, SST_SYMG(RHS(3)), SST_SYMG(RHS(5)), &sptr1); goto module_shared; /* * ::= */ case PROG_TITLE9: break; module_shared: gbl.prog_file_name = (char *)getitem(15, strlen(gbl.curr_file) + 1); strcpy(gbl.prog_file_name, gbl.curr_file); if (sem.pgphase != PHASE_INIT) { errsev(70); break; } if (sem.mod_sym) { if (sem.mod_cnt == 1) /* issue error during first pass */ ERR310("MODULEs may not be nested", CNULL); break; } sem.mod_cnt++; sem.pgphase = PHASE_HEADER; sem.mod_sym = sptr; setfile(1, SYMNAME(sem.mod_sym), 0); gbl.currmod = sem.mod_sym; push_scope_level(sem.mod_sym, SCOPE_NORMAL); push_scope_level(sem.mod_sym, SCOPE_MODULE); SST_ASTP(LHS, 0); clear_subp_prefix_settings(&subp_prefix); /* SUBMODULEs work as if they are hosted within their immediate parents. */ if (sptr1 > NOSYM) { sem.use_seen = TRUE; sem.pgphase = PHASE_USE; init_use_stmts(); open_module(sptr1); add_submodule_use(); close_module(); } break; /* ------------------------------------------------------------------ */ /* * ::= */ case IDENT1: sptr = SST_SYMG(RHS(1)); if (STYPEG(sptr) == ST_ALIAS) { /*SST_SYMP(LHS, SYMLKG(sptr));*/ SST_ALIASP(LHS, 1); } else SST_ALIASP(LHS, 0); SST_IDP(LHS, S_IDENT); break; /* ------------------------------------------------------------------ */ /* * ::= */ case ID1: np = scn.id.name + SST_CVALG(RHS(1)); /* AOCC begin * a variable is the element of an assumed size array */ if (asz_status == 1 && sem.in_array_const == true) { asz_id_elem = 1; } //AOCC end sptr = getsymbol(np); if (sem.in_dim && sem.type_mode && !KINDG(sptr) && STYPEG(sptr) != ST_MEMBER) { /* possible use of a type parameter in the dimension field * of an array type component declaration */ KINDP(sptr, -1); } SST_SYMP(LHS, sptr); SST_ACLP(LHS, 0); if (sem.arrdim.assumedrank && SCG(sptr) == SC_DUMMY) { IGNORE_TKRP(sptr, IGNORE_R); } #ifdef GSCOPEP if (!sem.which_pass && gbl.internal <= 1 && gbl.currsub) { ident_host_sub = gbl.currsub; } else if (!sem.which_pass && gbl.internal > 1 && gbl.currsub /* && STYPEG(sptr)*/) { defer_ident_list(sptr, ident_host_sub); } else if (sem.which_pass && gbl.internal <= 1 && internal_proc_has_ident(sptr, gbl.currsub)) { if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) { if (FVALG(sptr)) GSCOPEP(FVALG(sptr), 1); } else if (STYPEG(sptr) == ST_UNKNOWN || STYPEG(sptr) == ST_IDENT || ST_ISVAR(STYPEG(sptr))) { GSCOPEP(sptr, 1); } } #endif break; /* ------------------------------------------------------------------ */ /* * ::= | */ case FUNC_SUFFIX1: SST_SYMP(LHS, 0); break; /* * ::= BIND ( ) | */ case FUNC_SUFFIX2: result_name = SST_CVALG(RHS(3)); id_name = SST_CVALG(RHS(5)); goto result_shared; /* * ::= BIND | */ case FUNC_SUFFIX3: /* pass nothing */ SST_SYMP(LHS, 0); break; /* * ::= ( ) BIND */ case FUNC_SUFFIX4: /* do nothing */ /* fall through */ /* * ::= ( ) */ case FUNC_SUFFIX5: result_name = SST_CVALG(RHS(1)); id_name = SST_CVALG(RHS(3)); result_shared: sptr = 0; np = scn.id.name + result_name; if (sem_strcmp(np, "result") == 0) { np2 = scn.id.name + id_name; sptr2 = getsymbol(np2); sptr = chk_intrinsic(sptr2, FALSE, FALSE); if (scn.stmtyp == TK_ENTRY && gbl.rutype == RU_FUNC) { /* have a function entry - create its result variable */ sptr = create_func_entry_result(sptr); } else { sptr = declsym(sptr, ST_IDENT, TRUE); SCP(sptr, SC_DUMMY); } if (sem.interface) { NODESCP(sptr, 1); IGNOREP(sptr, TRUE); } } else error(34, 3, gbl.lineno, np, CNULL); SST_SYMP(LHS, sptr); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ENTRY_STATEMENT1: itemp = ITEM_END; func_result = 0; goto entry_statement; /* * ::= ( ) | */ case ENTRY_STATEMENT2: itemp = ITEM_END; func_result = SST_SYMG(RHS(4)); goto entry_statement; /* * ::= ( ) */ case ENTRY_STATEMENT3: itemp = SST_BEGG(RHS(3)); func_result = SST_SYMG(RHS(5)); entry_statement: if (flg.standard) { error(535, 2, gbl.lineno, "ENTRY statement", "FORTRAN 2008"); } entry_seen = TRUE; sptr2 = SST_SYMG(RHS(1)); if (sptr2 == 0) { /* an error was detected in */ SST_ASTP(LHS, 0); break; } /* write out ENTRY */ sptr1 = getlab(); RFCNTP(sptr1, 1); /* reserve one extra space in case this is an array-valued function - * a new argument may be inserted at the beginning of the list. */ if (gbl.rutype == RU_FUNC) { NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + 100); *(aux.dpdsc_base + (aux.dpdsc_avl++)) = 0; } else DTYPEP(sptr2, 0); DPDSCP(sptr2, aux.dpdsc_avl); NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + 100); *(aux.dpdsc_base + (aux.dpdsc_avl)) = 0; count = 0; for (; itemp != ITEM_END; itemp = itemp->next) { sptr = itemp->t.sptr; if (sptr == 0) { /* alternate return designator (i.e. *) */ if (gbl.rutype != RU_SUBR) errsev(49); else gbl.arets = TRUE; } else { sptr = ref_ident(sptr); stype = STYPEG(sptr); if (stype == ST_ENTRY) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); sptr = insert_sym(sptr); SCP(sptr, SC_DUMMY); } else if (SCG(sptr) == SC_NONE) { if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_ARRAY && stype != ST_STRUCT && stype != ST_PROC && stype != ST_VAR) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); } SCP(sptr, SC_DUMMY); } else if (SCG(sptr) == SC_LOCAL && !SAVEG(sptr)) /* * watch out for the case where an is seen * as a use in a declaration (e.g., in an adj. array * expression). NOTE that if it's dinit'd, dinit will * issue error. */ SCP(sptr, SC_DUMMY); else if (SCG(sptr) != SC_DUMMY) error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); } NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + 100); *(aux.dpdsc_base + (aux.dpdsc_avl++)) = sptr; count++; } PARAMCTP(sptr2, count); ast = mk_stmt(A_ENTRY, 0); A_SPTRP(ast, sptr2); SST_ASTP(LHS, ast); record_func_result(sptr2, func_result, TRUE /* in ENTRY */); break; /* ------------------------------------------------------------------ */ /* * ::= SUBROUTINE | */ case ROUTINE_ID1: rhstop = 3; gbl.rutype = RU_SUBR; sem.module_procedure = false; goto routine_id; /* * ::= FUNCTION | */ case ROUTINE_ID2: rhstop = 3; gbl.rutype = RU_FUNC; sem.module_procedure = false; /* data type of function not specified */ lenspec[1].len = sem.gdtype = -1; lenspec[1].propagated = 0; goto routine_id; /* * ::= FUNCTION | */ case ROUTINE_ID3: rhstop = 3; gbl.rutype = RU_FUNC; if (!(sem.deferred_func_kind || sem.deferred_func_len)) { /* The KIND was an unresolved ident (e.g., ident from an unprocessed module), skip the mod_type until after USE stmt processing */ sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len, lenspec[1].propagated, (int)SST_SYMG(RHS(3))); } goto routine_id; /* * ::= PROGRAM */ case ROUTINE_ID4: gbl.rutype = RU_PROG; sem.module_procedure = false; rhstop = 2; if (IN_MODULE) ERR310("PROGRAM may not appear in a MODULE", CNULL); routine_id: is_entry = FALSE; if (sem.interface && gbl.currsub) { error(303, 2, gbl.lineno, SYMNAME(gbl.currsub), CNULL); pop_subprogram(); pop_scope_level(SCOPE_NORMAL); } if (gbl.empty_contains && sem.pgphase == PHASE_END && sem.which_pass == 0) { /* empty CONTAINS body with no internal subprograms */ gbl.internal = 0; sem.pgphase = PHASE_INIT; } if (sem.pgphase != PHASE_INIT && !sem.interface) { if (IN_MODULE && !have_module_state()) { /* terminate -- ow, reset_module_state() will issue * an ICE because modstate_file is NULL; could say * something about CONTAINS, but we currently cannot * detect the missing CONTAINS of a module after the * first. */ error(70, 0, gbl.lineno, CNULL, CNULL); } errsev(70); } /* C1548: checking MODULE prefix for subprograms that were declared as separate module procedures */ if (!sem.interface && subp_prefix.module) { sptr_temp = SST_SYMG(RHS(rhstop)); if (!SEPARATEMPG(sptr_temp) && !find_explicit_interface(sptr_temp)) error(1056, ERR_Severe, gbl.lineno, NULL, NULL); } /* First internal subprogram after CONTAINS, semfin may have altered the * symbol table * (esp. INVOBJ) for the host subprogram processing. Restore the state to * what it was * before semfin. (FS 20415) */ if (sem.which_pass && sem.pgphase == PHASE_CONTAIN && gbl.internal == 1) { restore_host_state(2); } if (!sem.interface && sem.mod_cnt == 0) { gbl.prog_file_name = (char *)getitem(15, strlen(gbl.curr_file) + 1); strcpy(gbl.prog_file_name, gbl.curr_file); } entry_seen = FALSE; if (sem.interface) { /* Open the interface scope. */ sem.scope_stack[sem.scope_level].closed = FALSE; /* set curr_scope to parent's scope */ stb.curr_scope = sem.scope_stack[sem.scope_level - 1].sptr; queue_tbp(SST_SYMG(RHS(rhstop)), 0, 0, 0, TBP_IFACE); } sptr = block_local_sym(refsym_inscope(SST_SYMG(RHS(rhstop)), OC_OTHER)); if (STYPEG(sptr) == ST_ENTRY /* Call insert_sym() if there's a type bound * procedure that is in scope */ || (STYPEG(sptr) == ST_PROC && CLASSG(sptr) && VTOFFG(sptr))) { /* this must be the enclosing routine */ sptr = insert_sym(sptr); } else if (STYPEG(sptr) == ST_PROC && IN_MODULE_SPEC && get_seen_contains() && !sem.which_pass && /* separate module procedure is allowed to be declared & defined within the same module */ !IS_INTERFACEG(sptr)) { LOGICAL err = TYPDG(sptr) && SCOPEG(sptr) != stb.curr_scope; if (!err) { int dpdsc = 0; proc_arginfo(sptr, 0, &dpdsc, 0); err = dpdsc != 0; } if (err) { errWithSrc(155, 3, SST_LINENOG(RHS(rhstop)), "Redefinition of", SYMNAME(sptr), SST_COLUMNG(RHS(rhstop)), 0, false, CNULL); } } if (subp_prefix.pure && subp_prefix.impure) { error(545, 3, gbl.lineno, NULL, NULL); } sptr = declsym(sptr, ST_ENTRY, TRUE); if (sem.interface) { /* Re-close the interface scope. */ sem.scope_stack[sem.scope_level].closed = TRUE; /* curr_scope will be reset by push_scope_level */ } gbl.currsub = sptr; push_scope_level(sptr, SCOPE_NORMAL); if (sem.interface) { /* For submodules, don't close the scope_stack in order to make * sure entities defined in parent modules are visible in * descendant submodules */ if (!subp_prefix.module) /* Close the 'normal' scope. */ sem.scope_stack[sem.scope_level].closed = TRUE; } push_scope_level(sptr, SCOPE_SUBPROGRAM); sem.pgphase = PHASE_HEADER; /* Set the storage class; if it's already dummy, then this subprogram * is an argument for which there is an interface. */ if (SCG(sptr) != SC_DUMMY) { if (!sem.interface || !sem.interf_base[sem.interface - 1].abstract) SCP(sptr, SC_EXTERN); else { SCP(sptr, SC_NONE); if (sem.interf_base[sem.interface - 1].abstract) { ABSTRACTP(sptr, 1); INMODULEP(sptr, IN_MODULE); } } } PUREP(sptr, subp_prefix.pure); RECURP(sptr, subp_prefix.recursive); IMPUREP(sptr, subp_prefix.impure); ELEMENTALP(sptr, subp_prefix.elemental); if (subp_prefix.module) { if (!IN_MODULE && !INMODULEG(sptr)) { ERR310("MODULE prefix allowed only within a module or submodule", CNULL); } else if (sem.interface) { /* Use SEPARATEMPP to mark this is submod related subroutines, * functions, procdures to differentiate regular module. The * SEPARATEMPP field is overloaded with ISSUBMODULEP field * ISSUBMODULEP is used for name mangling. */ SEPARATEMPP(sptr, TRUE); HAS_SMP_DECP(SCOPEG(sptr), TRUE); if (IN_MODULE) INMODULEP(sptr, TRUE); if (SST_FIRSTG(RHS(rhstop))) { TBP_BOUND_TO_SMPP(sptr, TRUE); /* We also set the HAS_TBP_BOUND_TO_SMP flag on the separate module * procedure's module. This indicates that the module contains a * separate module procedure declaration to which at least one TBP * has been bound. */ HAS_TBP_BOUND_TO_SMPP(SCOPEG(sptr), TRUE); } } else { SEPARATEMPP(sptr, TRUE); /* check definition vs. declared interface */ /* F2008 [12.6.2.5] The characteristics and binding label of a procedure are fixed, but the remainder of the interface may differ in differing contexts, except that for a separate module procedure body. */ if (sem.which_pass) { SPTR def = find_explicit_interface(sptr); /* Make sure this def is not from the contains of ancestor module*/ if (def > NOSYM) { sptr_temp = SYMLKG(sptr) ? SYMLKG(sptr) : sptr; /* Check Characteristics of procedures matches for definition vs. declaration*/ if (!cmp_interfaces_strict(def, sptr_temp, CMP_IFACE_NAMES | CMP_SUBMOD_IFACE)) ; } } } } else { if (sem.interface && SYMIG(sptr) && INMODULEG(sptr)) { for (symi = SYMIG(sptr); symi; symi = SYMI_NEXT(symi)) { if (STYPEG(SYMI_SPTR(symi)) == ST_OPERATOR || STYPEG(SYMI_SPTR(symi)) == ST_USERGENERIC) error(1212, ERR_Severe, gbl.lineno, SYMNAME(sptr), NULL); } } } clear_subp_prefix_settings(&subp_prefix); if (gbl.rutype == RU_FUNC) { /* for a FUNCTION (including ENTRY's), compiler created * symbols are created to represent the return values and * are stored in the FVAL field of the ENTRY's. * In the worst case, each entry will have its own ccsym. * As references occur (and in semfin), an attempt will be * made to share the temporaries. Also, at these times, * the dtype of the temporary will have to be set properly. * semfin adjusts the storage class if necessary. */ if (sem.gdtype != -1) { /* data type of function was specified */ DCLDP(sptr, TRUE); DTYPEP(sptr, sem.gdtype); set_char_attributes(sptr, &sem.gdtype); } } else { DTYPEP(sptr, 0); } SYMLKP(sptr, NOSYM); FUNCLINEP(sptr, gbl.lineno); if (gbl.rutype != RU_PROG) { MSCALLP(sptr, mscall); #ifdef CREFP CREFP(sptr, cref); NOMIXEDSTRLENP(sptr, nomixedstrlen); #endif } SST_ASTP(LHS, 0); if (sem.interface) { init_implicit(); } else if (IN_MODULE) { } else if (gbl.internal) { gbl.internal++; host_present = 0x8; symutl.none_implicit = sem.none_implicit &= ~host_present; SCP(sptr, SC_STATIC); } seen_implicit = FALSE; seen_parameter = FALSE; if (sem.interface && gbl.internal <= 1) { /* INTERNAL flag might have gotten set in getsym() * for this symbol even though it is an interface. An interface * body should never contain a procedure defined by a subprogram, * so this flag should never be set for an interface. Because * getsym() does not have access to sem.interface, we reset the * INTERNAL flag here. */ INTERNALP(sptr, 0); } IS_INTERFACEP(sptr, sem.interface); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case SUBR_PREFIX1: /* fall through */ /* * ::= */ case SUBR_PREFIX2: check_module_prefix(); if (sem.interface) { /* set curr_scope to parent's scope, so subprogram ID * gets scope of parent */ stb.curr_scope = sem.scope_stack[sem.scope_level - 1].sptr; } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case PREFIX_SPEC1: break; /* * ::= */ case PREFIX_SPEC2: break; /* ------------------------------------------------------------------ */ /* * ::= RECURSIVE | */ case PREFIX1: check_duplicate(subp_prefix.recursive, "RECURSIVE"); subp_prefix.recursive = TRUE; if (subp_prefix.elemental) { errsev(460); } break; /* * ::= PURE | */ case PREFIX2: check_duplicate(subp_prefix.pure, "PURE"); subp_prefix.pure = TRUE; break; /* * ::= ELEMENTAL | */ case PREFIX3: check_duplicate(subp_prefix.elemental, "ELEMENTAL"); subp_prefix.elemental = TRUE; if (subp_prefix.recursive) { errsev(460); } break; /* * ::= ATTRIBUTES ( ) */ case PREFIX4: if (!cuda_enabled("attributes")) break; break; /* * ::= IMPURE */ case PREFIX5: check_duplicate(subp_prefix.impure, "IMPURE"); subp_prefix.impure = TRUE; break; /* * ::= MODULE */ case PREFIX6: check_duplicate(subp_prefix.module, "MODULE"); subp_prefix.module = TRUE; break; /* * ::= LAUNCHBOUNDS ( ) | */ case PREFIX7: break; /* * ::= LAUNCHBOUNDS ( , ) */ case PREFIX8: break; /* ------------------------------------------------------------------ */ /* * ::= */ case LAUNCHBOUND1: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ID_NAME_LIST1: rhstop = 3; goto add_name_to_list; break; /* * ::= */ case ID_NAME_LIST2: rhstop = 1; add_name_to_list: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.conval = SST_CVALG(RHS(rhstop)); if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case FUNC_PREFIX1: /* fall through */ /* * ::= | */ case FUNC_PREFIX2: /* fall through */ /* * ::= */ case FUNC_PREFIX3: /* fall through */ /* * ::= */ case FUNC_PREFIX4: check_module_prefix(); if (sem.interface) { /* set curr_scope to parent's scope, so subprogram ID * gets scope of parent */ stb.curr_scope = sem.scope_stack[sem.scope_level - 1].sptr; } break; /* ------------------------------------------------------------------ */ /* * ::= ENTRY */ case ENTRY_ID1: sptr = SST_SYMG(RHS(2)); if (gbl.internal > 1) { error(155, 3, gbl.lineno, SYMNAME(sptr), "- The ENTRY statement is not allowed in an internal procedure"); SST_SYMP(LHS, 0); break; } if (sem.doif_depth > 0) { /* Inside DO, IF, WHERE block; ignore statement */ errsev(118); SST_SYMP(LHS, 0); break; } if (INSIDE_STRUCT) { error(117, 3, gbl.lineno, STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL); SST_SYMP(LHS, 0); break; } if (gbl.rutype == RU_PROG || gbl.rutype == RU_BDATA || sem.interface) { errsev(70); SST_SYMP(LHS, 0); break; } if (gbl.rutype == RU_FUNC) /* have a function entry; create its ST_ENTRY symbol */ sptr = create_func_entry(sptr); else sptr = declsym(sptr, ST_ENTRY, TRUE); if (IN_MODULE && sem.interface == 0) sptr = mod_add_subprogram(sptr); SST_SYMP(LHS, sptr); SYMLKP(sptr, SYMLKG(gbl.currsub)); SYMLKP(gbl.currsub, sptr); FUNCLINEP(sptr, gbl.lineno); MSCALLP(sptr, mscall); if (sptr != gbl.currsub) { CFUNCP(sptr, CFUNCG(gbl.currsub)); } #ifdef CREFP CREFP(sptr, cref); NOMIXEDSTRLENP(sptr, nomixedstrlen); #endif is_entry = TRUE; PUREP(sptr, PUREG(gbl.currsub)); break; /* ------------------------------------------------------------------ */ /* * ::= */ case FCN_NAME1: set_len_attributes(RHS(2), 1); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case FORMAL_LIST1: rhstop = 3; goto add_sym_to_list; /* * ::= */ case FORMAL_LIST2: rhstop = 1; goto add_sym_to_list; /* ------------------------------------------------------------------ */ /* * ::= | */ case FORMAL1: /* scan sets SST_SYMP with sym pointer */ sptr = chk_intrinsic(SST_SYMG(RHS(1)), TRUE, is_entry); SST_SYMP(LHS, sptr); break; /* * ::= * */ case FORMAL2: SST_SYMP(LHS, 0); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case IDENT_LIST1: rhstop = 3; goto add_sym_to_list; /* * ::= */ case IDENT_LIST2: rhstop = 1; add_sym_to_list: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(rhstop)); itemp->ast = SST_ASTG(RHS(rhstop)); /* copied for rules */ if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case END_STMT1: if (gbl.rutype == RU_SUBR || gbl.rutype == RU_FUNC) defer_arg_chk(SPTR_NULL, SPTR_NULL, SPTR_NULL, 0, 0, true); if (sem.interface && !gbl.rutype) error(310, 3, gbl.lineno, "Missing ENDINTERFACE statement", CNULL); else if (sem.which_pass) fix_class_args(gbl.currsub); dummy_program(); if (IN_MODULE_SPEC && gbl.internal == 0) goto end_of_module; if (gbl.currsub == 0 && sem.pgphase == PHASE_INIT && gbl.internal) check_end_subprogram(host_state.rutype, 0); else if (gbl.internal > 1) { if (gbl.rutype == RU_PROG || gbl.rutype == RU_BDATA) { error(302, 3, gbl.lineno, name_of_rutype(gbl.rutype), CNULL); gbl.internal = 0; } } else { if (0 && sem.which_pass && !sem.mod_cnt && gbl.internal == 0 && !sem.interface) { fprintf(stderr, "OPROC %s:", gbl.src_file); fprintf(stderr, "%s\n", SYMNAME(gbl.currsub)); } enforce_denorm(); } SST_IDP(LHS, 1); /* mark as end of subprogram unit */ if (IN_MODULE && sem.interface == 0) mod_end_subprogram(); pop_scope_level(SCOPE_NORMAL); if (!IN_MODULE && !sem.interface) { queue_tbp(0, 0, 0, 0, TBP_CLEAR); check_defined_io(); } defer_pt_decl(0, 0); break; /* * ::= ENDBLOCKDATA | */ case END_STMT2: if (gbl.currsub == 0 || gbl.rutype != RU_BDATA) error(302, 3, gbl.lineno, "BLOCKDATA", CNULL); else if (SST_SYMG(RHS(2)) && strcmp(SYMNAME(gbl.currsub), SYMNAME(SST_SYMG(RHS(2)))) != 0) error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL); SST_IDP(LHS, 1); /* mark as end of subprogram unit */ pop_scope_level(SCOPE_NORMAL); break; /* * ::= ENDFUNCTION | */ case END_STMT3: defer_arg_chk(SPTR_NULL, SPTR_NULL, SPTR_NULL, 0, 0, true); submod_proc_endfunc: fix_iface(gbl.currsub); if (sem.which_pass && !sem.interface) { fix_class_args(gbl.currsub); } if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) { queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END); queue_tbp(0, 0, 0, 0, TBP_CLEAR); } defer_pt_decl(0, 0); dummy_program(); check_end_subprogram(RU_FUNC, SST_SYMG(RHS(2))); SST_IDP(LHS, 1); /* mark as end of subprogram unit */ pop_scope_level(SCOPE_NORMAL); if (sem.interface) { if (DTYPEG(gbl.currsub) == DT_ASSCHAR) { error( 155, 3, FUNCLINEG(gbl.currsub), "FUNCTION may not be declared character*(*) when in an INTERFACE -", SYMNAME(gbl.currsub)); } if (IN_MODULE) { do_iface_module(); } } if (IN_MODULE && sem.interface == 0) mod_end_subprogram(); check_defined_io(); if (!IN_MODULE && !sem.interface) clear_ident_list(); fix_proc_ptr_dummy_args(); sem.seen_import = FALSE; break; /* * ::= ENDMODULE | */ case END_STMT4: sem.seen_end_module = TRUE; if (sem.mod_sym == 0) { error(302, 3, gbl.lineno, "MODULE", CNULL); gbl.internal = 0; break; } if (sem.interface) { error(310, 3, gbl.lineno, "Missing ENDINTERFACE statement", CNULL); sem.interface = 0; } if (gbl.currsub) { error(310, 3, gbl.lineno, "Missing END statement", SYMNAME(gbl.currsub)); } if (SST_SYMG(RHS(2)) && strcmp(SYMNAME(sem.mod_sym), SYMNAME(SST_SYMG(RHS(2)))) != 0) error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL); end_of_module: queue_tbp(0, 0, 0, 0, TBP_COMPLETE_ENDMODULE); queue_tbp(0, 0, 0, 0, TBP_CLEAR); do_iface(sem.which_pass); fix_iface0(); end_module(); SST_IDP(LHS, 0); /* mark as end of module */ if (sem.mod_cnt == 1) { sem.mod_cnt++; /*fe_restart();*/ } else { sem.mod_cnt = 0; sem.mod_sym = 0; sem.submod_sym = 0; } check_defined_io(); clear_ident_list(); sem.seen_end_module = FALSE; break; /* * ::= ENDPROGRAM | */ case END_STMT5: queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END); queue_tbp(0, 0, 0, 0, TBP_CLEAR); defer_pt_decl(0, 0); dummy_program(); check_end_subprogram(RU_PROG, SST_SYMG(RHS(2))); SST_IDP(LHS, 1); /* mark as end of subprogram unit */ pop_scope_level(SCOPE_NORMAL); check_defined_io(); break; /* * ::= ENDSUBROUTINE | */ case END_STMT6: defer_arg_chk(SPTR_NULL, SPTR_NULL, SPTR_NULL, 0, 0, true); fix_iface(gbl.currsub); if (sem.which_pass && !sem.interface) { fix_class_args(gbl.currsub); } if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) { queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END); queue_tbp(0, 0, 0, 0, TBP_CLEAR); } defer_pt_decl(0, 0); dummy_program(); check_end_subprogram(RU_SUBR, SST_SYMG(RHS(2))); SST_IDP(LHS, 1); /* mark as end of subprogram unit */ pop_scope_level(SCOPE_NORMAL); if (sem.interface && IN_MODULE) { do_iface_module(); } if (IN_MODULE && sem.interface == 0) mod_end_subprogram(); check_defined_io(); if (!IN_MODULE && !sem.interface) clear_ident_list(); fix_proc_ptr_dummy_args(); sem.seen_import = FALSE; break; /* * ::= ENDSUBMODULE */ case END_STMT7: sem.seen_end_module = TRUE; if (sem.submod_sym <= NOSYM) { error(302, 3, gbl.lineno, "SUBMODULE", CNULL); gbl.internal = 0; break; } if (SST_SYMG(RHS(2)) && strcmp(SYMNAME(sem.submod_sym), SYMNAME(SST_SYMG(RHS(2)))) != 0) { error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL); } goto end_of_module; /* * ::= ENDPROCEDURE */ case END_STMT8: if (gbl.currsub == 0 || !sem.module_procedure) { ERR310("unexpected END PROCEDURE", CNULL); break; } if (gbl.rutype == RU_FUNC) goto submod_proc_endfunc; /* For sub-module procedure points to a subroutine of another module, we need to take cares of the dummy arguments and process differently from the general ENDPROCEDURE. */ if (gbl.rutype == RU_SUBR) { dummy_program(); enforce_denorm(); SST_IDP(LHS, 1); /* mark as end of subprogram unit */ pop_scope_level(SCOPE_SUBPROGRAM); defer_pt_decl(0, 0); sem.seen_import = FALSE; do_end_subprogram(top, gbl.rutype); break; } SST_IDP(LHS, 1); /* mark as end of subprogram unit */ mod_end_subprogram(); sem.seen_import = FALSE; do_end_subprogram(top, gbl.rutype); gbl.currsub = 0; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_IDENT1: SST_SYMP(LHS, 0); break; /* * ::= */ case OPT_IDENT2: break; /* ------------------------------------------------------------------ */ /* * ::= BLOCK | * ::= : BLOCK * * Generate block code with the form: * continue -- first block std (labeled) * block prolog -- allocate/init/array_check code * comment (continue) -- prolog end == body begin boundary marker * block body -- user code * block epilog -- finalize/deallocate code * continue -- last block std (labeled) * * Each block has an ST_BLOCK sptr where: * - STARTLAB(sptr) is the top-of-block label * - ENDLAB(sptr) is the end-of-block label * * For any sptr local to a block, the block entry, end-of-prolog, and exit * stds that are needed for inserting prolog and epilog code are accessible * via macros defined in symutl.h: * - BLOCK_ENTRY_STD(sptr) * - BLOCK_ENDPROLOG_STD(sptr) * - BLOCK_EXIT_STD(sptr) * Prolog code can be inserted at the top of the prolog via BLOCK_ENTRY_STD, * and at the end of the prolog via BLOCK_ENDPROLOG_STD. Epilog code can * be inserted at the end of the epilog via BLOCK_EXIT_STD. There is no * known need to insert code at the top of the epilog, so there is no * marker std between body and epilog code. */ case BLOCK_STMT1: set_construct_name(0); // fall through case BLOCK_STMT2: if (DI_NEST(sem.doif_depth) >= DI_B(DI_FIRST_DIRECTIVE) && !XBIT(59,8)) error(1219, ERR_Severe, gbl.lineno, "BLOCK construct in the scope of a parallel directive", CNULL); sptr = sem.scope_stack[sem.scope_level].sptr; push_scope_level(sptr, SCOPE_NORMAL); push_scope_level(sptr, SCOPE_BLOCK); block_sptr = getccsym('b', sem.blksymnum++, ST_BLOCK); ENCLFUNCP(block_sptr, sem.construct_sptr ? sem.construct_sptr : gbl.currsub); sem.construct_sptr = block_sptr; if (sem.which_pass) { lab = scn.currlab ? scn.currlab : getlab(); RFCNTI(lab); // Setting VOL on this block entry label and the exit label just below // prohibits the back end from deleting them. This is necessary to // support parallelization and debugging. However, this can cause the // back end at -O2 and above to generate dead code during unrolling, // which causes control flow analysis prior to vectorization to fail. // Pending a more complete fix for this problem, only set this flag at // low opt levels (and prohibit parallelization of code containing a // block). VOLP(lab, flg.opt < 2 && flg.debug && !XBIT(123, 0x400)); ENCLFUNCP(lab, block_sptr); std = add_stmt(mk_stmt(A_CONTINUE, 0)); STARTLINEP(block_sptr, gbl.lineno); STARTLABP(block_sptr, lab); LABSTDP(lab, std); STD_LABEL(std) = lab; std = add_stmt(mk_stmt(A_CONTINUE, 0)); ast_to_comment(STD_AST(std)); ENTSTDP(block_sptr, std); } NEED_DOIF(doif, DI_BLOCK); DI_NAME(doif) = get_construct_name(); DI_ENCL_BLOCK_SCOPE(doif) = sem.block_scope; sem.block_scope = sem.scope_level; sem.pgphase = PHASE_HEADER; break; /* ------------------------------------------------------------------ */ /* * ::= ENDBLOCK */ case BLOCK_STMT3: doif = sem.doif_depth; if (sem.doif_depth <= 0) { error(104, ERR_Severe, gbl.lineno, "- mismatched END BLOCK", CNULL); break; } construct_name = get_construct_name(); if (DI_NAME(doif) != construct_name) err307("BLOCK and ENDBLOCK", DI_NAME(doif), construct_name); if (sem.which_pass) { if (scn.currlab) add_stmt(mk_stmt(A_CONTINUE, 0)); if (DI_EXIT_LABEL(doif)) { std = add_stmt(mk_stmt(A_CONTINUE, 0)); STD_LABEL(std) = DI_EXIT_LABEL(doif); } block_sptr = sem.construct_sptr; lab = getlab(); RFCNTI(lab); // See the comment just above about the entry label VOL flag. VOLP(lab, flg.opt < 2 && flg.debug && !XBIT(123, 0x400)); ENCLFUNCP(lab, block_sptr); std = add_stmt(mk_stmt(A_CONTINUE, 0)); ENDLINEP(block_sptr, gbl.lineno); ENDLABP(block_sptr, lab); LABSTDP(lab, std); STD_LABEL(std) = lab; } --sem.doif_depth; sem.block_scope = DI_ENCL_BLOCK_SCOPE(doif); sem.construct_sptr = ENCLFUNCG(sem.construct_sptr); if (STYPEG(sem.construct_sptr) != ST_BLOCK) sem.construct_sptr = 0; // not in a construct pop_scope_level(SCOPE_NORMAL); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DECLARATION1: if (sem.class && sem.type_mode) { error(155, 3, gbl.lineno, "CLASS components must be pointer or" " allocatable", CNULL); } SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION2: SST_ASTP(LHS, 0); break; /* * ::= IMPLICIT | */ case DECLARATION3: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "An IMPLICIT", CNULL); SST_ASTP(LHS, 0); break; /* * ::= COMMON | */ case DECLARATION4: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "A COMMON", CNULL); SST_ASTP(LHS, 0); break; /* * ::= EXTERNAL | */ case DECLARATION5: for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) { /* Produce a procedure symbol */ if (POINTERG(itemp->t.sptr)) { LOGICAL was_declared = DCLDG(itemp->t.sptr); /* External pointer should come out the same as procedure(T) pointer */ sptr = decl_procedure_sym(itemp->t.sptr, proc_interf_sptr, (entity_attr.exist | ET_B(ET_POINTER))); sptr = setup_procedure_sym(itemp->t.sptr, proc_interf_sptr, (entity_attr.exist | ET_B(ET_POINTER)), entity_attr.access); DCLDP(sptr, was_declared); } else { /* Use simple approach when we can't argue that this needs to be a * procedure pointer */ sptr = declsym(itemp->t.sptr, ST_PROC, FALSE); } if (!TYPDG(sptr)) { TYPDP(sptr, 1); } if (SCG(sptr) == SC_DUMMY) { IS_PROC_DUMMYP(sptr, 1); } } SST_ASTP(LHS, 0); break; /* * ::= INTRINSIC | */ case DECLARATION6: for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) { sptr = refsym(itemp->t.sptr, OC_OTHER); stype = STYPEG(sptr); if (!IS_INTRINSIC(sptr)) { /* Not an intrinsic. So, try finding it */ sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_PD, 0); if (!sptr2) { sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_INTRIN, 0); if (!sptr2) { sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_GENERIC, 0); } } if (sptr2) { sptr = sptr2; stype = STYPEG(sptr); sptr2 = insert_sym(sptr); STYPEP(sptr2, ST_ALIAS); SYMLKP(sptr2, sptr); } } if (IS_INTRINSIC(stype)) { EXPSTP(sptr, 1); /* Freeze as an intrinsic */ TYPDP(sptr, 1); /* appeared in INTRINSIC statement */ if (stype == ST_GENERIC) { sptr2 = select_gsame(sptr); if (sptr2) /* no need to * EXPSTP(sptr2, 1); * symbol is always begins with a . */ ; else if (IN_MODULE) { /* Predefined symbols such as generics are * not exported into mod files. A statement such as * use m, ren => max * will produce a "not public entity" message unless * we make a symbol that will be exported. */ sptr2 = insert_sym(sptr); STYPEP(sptr2, ST_ALIAS); SYMLKP(sptr2, sptr); } } } else error(126, 3, gbl.lineno, SYMNAME(sptr), CNULL); } SST_ASTP(LHS, 0); break; /* * ::= SAVE | */ case DECLARATION7: SST_ASTP(LHS, 0); break; /* * ::= SAVE | */ case DECLARATION8: SST_ASTP(LHS, 0); if (sem.construct_sptr) SAVEP(sem.construct_sptr, true); else sem.savall = TRUE; sem.savloc = TRUE; break; /* * ::= PARAMETER ( ) | */ case DECLARATION9: seen_parameter = TRUE; SST_ASTP(LHS, 0); if (sem.interface == 0) end_param(); break; /* * ::= EQUIVALENCE | */ case DECLARATION10: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "An EQUIVALENCE", CNULL); SST_ASTP(LHS, 0); break; /* * ::= DATA | */ case DECLARATION11: SST_ASTP(LHS, 0); break; /* * ::= PARAMETER | */ case DECLARATION12: if (flg.standard) error(171, 2, gbl.lineno, "PARAMETER", CNULL); seen_parameter = TRUE; SST_ASTP(LHS, 0); if (sem.interface == 0) end_param(); break; /* * ::= NAMELIST | */ case DECLARATION13: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "A NAMELIST", CNULL); SST_ASTP(LHS, 0); break; /* * ::= STRUCTURE | */ case DECLARATION14: if (flg.standard) error(171, 2, gbl.lineno, "STRUCTURE", CNULL); if (INSIDE_STRUCT && STSK_ENT(0).type != 's' && STSK_ENT(0).type != 'm') { error(70, 2, gbl.lineno, "(STRUCTURE ignored)", CNULL); break; } /* Get a structure stack entry */ sem.stsk_depth++; NEED(sem.stsk_depth, sem.stsk_base, STSK, sem.stsk_size, sem.stsk_depth + 12); stsk = &STSK_ENT(0); dtype = sem.stag_dtype; /* Save structure information in structure stack */ stsk->type = 's'; stsk->mem_access = 0; stsk->dtype = dtype; stsk->sptr = SST_RNG2G(RHS(4)); /* sym ptr to field name list */ stsk->last = NOSYM; stsk->ict_beg = stsk->ict_end = NULL; /* Handle the field-namelist field */ sptr = stsk->sptr; if (sptr == NOSYM) { if (sem.stsk_depth != 1) error(137, 2, gbl.lineno, CNULL, CNULL); } else { if (sem.stsk_depth == 1) { error(136, 2, gbl.lineno, CNULL, CNULL); } else { /* link field-namelist into member list at this level */ stsk = &STSK_ENT(1); link_members(stsk, sptr); } } SST_ASTP(LHS, 0); break; /* * ::= ENDSTRUCTURE | */ case DECLARATION15: if (flg.standard) error(171, 2, gbl.lineno, "ENDSTRUCTURE", CNULL); if (INSIDE_STRUCT) { /* Check out structure, get its length */ stsk = &STSK_ENT(0); if (stsk->type != 's') { errsev(160); break; } dtype = stsk->dtype; sptr = stsk->sptr; chkstruct(dtype); /* Save initializer constant tree (ict) for this structure */ if (sem.stsk_depth == 1 && stsk->ict_beg != NULL) { /* This is top structure, fix up top subc ict entry */ ict = GET_ACL(15); ict->id = AC_VMSSTRUCT; ict->next = NULL; ict->subc = stsk->ict_beg; ict->u1.ast = 0; ict->repeatc = astb.i1; ict->sptr = 0; ict->dtype = dtype; stsk->ict_beg = ict; } DTY(dtype + 5) = put_getitem_p(stsk->ict_beg); if (DTY(dtype + 3)) DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */ /* Pop out to parent structure (if any) */ sem.stsk_depth--; stsk = &STSK_ENT(0); /* For each member in parent structure (if any), having this * ict generate a substructure (subc) ict entry. These are then * linked to the parent's ict. */ if (INSIDE_STRUCT && DTY(dtype + 5) != 0) { for (; sptr != NOSYM; sptr = SYMLKG(sptr)) { ict = GET_ACL(15); ict->id = AC_VMSSTRUCT; ict->next = NULL; if (stsk->ict_end) stsk->ict_end->next = ict; else stsk->ict_beg = ict; stsk->ict_end = ict; ict->subc = get_getitem_p(DTY(dtype + 5)); ict->u1.ast = 0; if (DTY(DTYPEG(sptr)) == TY_ARRAY) ict->repeatc = AD_NUMELM(AD_PTR(sptr)); else ict->repeatc = astb.i1; ict->sptr = sptr; ict->dtype = dtype; } } } else error(70, 2, gbl.lineno, "(ENDSTRUCTURE ignored)", CNULL); SST_ASTP(LHS, 0); break; /* * ::= RECORD */ case DECLARATION16: if (flg.standard) error(171, 2, gbl.lineno, "RECORD", CNULL); break; /* * ::= UNION */ case DECLARATION17: if (flg.standard) error(171, 2, gbl.lineno, "UNION", CNULL); if (!INSIDE_STRUCT) { error(70, 2, gbl.lineno, "(UNION ignored)", CNULL); break; } stsk = &STSK_ENT(0); if (stsk->type != 's' && stsk->type != 'm') { error(70, 2, gbl.lineno, "(UNION ignored)", CNULL); break; } dtype = get_type(6, TY_UNION, NOSYM); name_prefix_char = 'u'; goto union_map; /* * ::= ENDUNION */ case DECLARATION18: if (flg.standard) error(171, 2, gbl.lineno, "ENDUNION", CNULL); if (!INSIDE_STRUCT) { error(70, 2, gbl.lineno, "(ENDUNION ignored)", CNULL); break; } stsk = &STSK_ENT(0); if (stsk->type != 'u') { errsev(160); break; } dtype = stsk->dtype; sptr = stsk->sptr; chkstruct(dtype); STSK_ENT(1).last = stsk->last; DTY(dtype + 5) = put_getitem_p(stsk->ict_beg); if (stsk->ict_beg != NULL) { STSK *pstsk = &STSK_ENT(1); /* parent (a struct) of the union */ #if DEBUG assert(pstsk->type == 's', "ENDUNION:union not in struct", sptr, 3); #endif /* * create a set node of the union which contains all of the * initializers for the union's maps. This set node is added * to the structure stack of the union's parent (a structure). */ ict = GET_ACL(15); ict->id = AC_VMSUNION; ict->next = NULL; ict->subc = stsk->ict_beg; ict->u1.ast = 0; ict->repeatc = astb.i1; ict->sptr = sptr; ict->dtype = dtype; if (pstsk->ict_beg == NULL) pstsk->ict_beg = ict; else pstsk->ict_end->next = ict; pstsk->ict_end = ict; } sem.stsk_depth--; SST_ASTP(LHS, 0); break; /* * ::= MAP */ case DECLARATION19: if (flg.standard) error(171, 2, gbl.lineno, "MAP", CNULL); if (!INSIDE_STRUCT) { error(70, 2, gbl.lineno, "(MAP ignored)", CNULL); break; } stsk = &STSK_ENT(0); if (stsk->type != 'u') { error(70, 2, gbl.lineno, "(MAP ignored)", CNULL); break; } dtype = get_type(6, TY_STRUCT, NOSYM); name_prefix_char = 'm'; union_map: stype = ST_MEMBER; sptr = declref(getsymf("%c@%05ld", name_prefix_char, (long)dtype), stype, 'r'); #if DEBUG assert(STYPEG(sptr) == stype, scn.stmtyp == TK_UNION ? "UNION: bad stype" : "MAP: bad stype", sptr, 3); #endif CCSYMP(sptr, 1); SYMLKP(sptr, NOSYM); DTYPEP(sptr, dtype); /* must be done before link members */ DTY(dtype + 3) = 0; /* no tag */ /* link the union or map (structure) into the current structure */ link_members(stsk, sptr); /* Save union information in structure stack */ sem.stsk_depth++; NEED(sem.stsk_depth, sem.stsk_base, STSK, sem.stsk_size, sem.stsk_depth + 12); stsk = &STSK_ENT(0); stsk->type = scn.stmtyp == TK_UNION ? 'u' : 'm'; stsk->mem_access = 0; stsk->dtype = dtype; stsk->sptr = sptr; /* sym ptr union */ stsk->last = STSK_ENT(1).last; stsk->ict_beg = stsk->ict_end = NULL; SST_ASTP(LHS, 0); break; /* * ::= ENDMAP | */ case DECLARATION20: if (flg.standard) error(171, 2, gbl.lineno, "ENDMAP", CNULL); if (!INSIDE_STRUCT) { error(70, 2, gbl.lineno, "(ENDMAP ignored)", CNULL); break; } stsk = &STSK_ENT(0); if (stsk->type != 'm') { errsev(160); break; } dtype = stsk->dtype; sptr = stsk->sptr; chkstruct(dtype); STSK_ENT(1).last = stsk->last; DTY(dtype + 5) = put_getitem_p(stsk->ict_beg); if (stsk->ict_beg != NULL) { STSK *pstsk = &STSK_ENT(1); /* parent (a union) of the map */ #if DEBUG assert(pstsk->type == 'u', "ENDMAP: map not in union", sptr, 3); #endif /* * add the map's initializer trees to the union's (its parent) * structure stack. */ if (pstsk->ict_beg == NULL) pstsk->ict_beg = stsk->ict_beg; else pstsk->ict_end->next = stsk->ict_beg; pstsk->ict_end = stsk->ict_end; } sem.stsk_depth--; SST_ASTP(LHS, 0); break; /* * ::= TYPE | */ case DECLARATION21: sptr = block_local_sym(SST_SYMG(RHS(5))); np = SYMNAME(sptr); if (strcmp(np, "integer") == 0 || strcmp(np, "logical") == 0 || strcmp(np, "real") == 0 || strcmp(np, "doubleprecision") == 0 || strcmp(np, "complex") == 0 || strcmp(np, "character") == 0) { error(155, 3, gbl.lineno, "A derived type type-name must not be the same " "as the name of the intrinsic type", np); if (IS_INTRINSIC(STYPEG(sptr))) sptr = insert_sym(sptr); } else sptr = getocsym(sptr, OC_OTHER, TRUE); if (STYPEG(sptr) == ST_TYPEDEF && DTY(DTYPEG(sptr) + 2) == 0) { /* This declaration will fill in an empty TYPEDEF created in * an implicit statement. */ dtype = sem.stag_dtype = DTYPEG(sptr); DTY(sem.stag_dtype + 2) = 1; /* size */ } else { if (STYPEG(sptr) == ST_USERGENERIC) { int origSym = sptr; sptr = insert_sym(sptr); STYPEP(sptr, ST_TYPEDEF); GTYPEP(origSym, sptr); } else { sptr = declsym(sptr, ST_TYPEDEF, TRUE); } dtype = sem.stag_dtype = get_type(6, TY_DERIVED, NOSYM); DTYPEP(sptr, sem.stag_dtype); DTY(sem.stag_dtype + 2) = 1; /* size */ DTY(sem.stag_dtype + 3) = sptr; DTY(sem.stag_dtype + 5) = 0; } #if defined(PARENTP) if (SST_CVALG(RHS(2)) & 0x4) { int sym = SST_LSYMG(RHS(2)); int dtype2 = DTYPEG(sym); /* type extension */ if (CFUNCG(sym)) { error(155, 3, gbl.lineno, "Cannot EXTEND BIND(C) derived type", SYMNAME(sym)); } else if (DTY(dtype2) == TY_DERIVED && SEQG(DTY(dtype2 + 3))) { error(155, 3, gbl.lineno, "Cannot EXTEND SEQUENCE derived type", SYMNAME(sym)); } else if (SST_CVALG(RHS(2)) & 0x1) { error(155, 3, gbl.lineno, "EXTENDS may not be used with BIND(C) " "derived type", SYMNAME(sym)); } PARENTP(sptr, sym); } else { /* type extension */ PARENTP(sptr, 0); } if (SST_CVALG(RHS(2)) & 0x8) { /* abstract type */ ABSTRACTP(sptr, 1); } #endif if (SST_CVALG(RHS(2)) & 0x1) /* BIND present? */ CFUNCP(sptr, 1); if (entity_attr.access == 'v') { /* we can set the private bit immediately here, * since it doesn't get overwritten later */ PRIVATEP(sptr, 1); } else if (entity_attr.access == 'u') { /* if the default access mode for the module is private, * the private bit gets overwritten in semfin.do_access() * We need to remember to reset this to public */ accessp = (ACCL *)getitem(3, sizeof(ACCL)); accessp->sptr = sptr; accessp->type = entity_attr.access; accessp->oper = ' '; accessp->next = sem.accl.next; sem.accl.next = accessp; } if (INSIDE_STRUCT) error(117, 3, gbl.lineno, STSK_ENT(0).type == 'd' ? "derived type" : "STRUCTURE", CNULL); /* Get a structure stack entry */ sem.stsk_depth++; NEED(sem.stsk_depth, sem.stsk_base, STSK, sem.stsk_size, sem.stsk_depth + 12); stsk = &STSK_ENT(0); /* Save structure information in structure stack */ stsk->type = 'd'; stsk->mem_access = 0; stsk->dtype = dtype; stsk->sptr = sptr; stsk->last = NOSYM; stsk->ict_beg = stsk->ict_end = NULL; sem.type_mode = 1; SST_ASTP(LHS, 0); link_parents(stsk, PARENTG(sptr)); break; /* * ::= ENDTYPE | */ case DECLARATION22: if (INSIDE_STRUCT) { /* Check out structure, get its length */ stsk = &STSK_ENT(0); if (stsk->type != 'd') { errsev(160); break; } dtype = stsk->dtype; sptr = stsk->sptr; chkstruct(dtype); if (dtype && SST_SYMG(RHS(2)) && DTY(dtype + 3) && strcmp(SYMNAME(DTY(dtype + 3)), SYMNAME(SST_SYMG(RHS(2)))) != 0) { error(155, 3, gbl.lineno, "Name on END TYPE statement does not" " match name on corresponding TYPE statement", CNULL); } if (PARENTG(DTY(dtype + 1)) && DINITG(DTY(dtype + 1))) { /* Type extension - make sure we initialize any parent components * that require initialization. */ build_typedef_init_tree(DTY(dtype + 1), DDTG(DTYPEG(DTY(dtype + 1)))); } if (ALLOCFLDG(sptr)) { init_allocatable_typedef_components(sptr); } save_typedef_init(sptr, dtype); build_typedef_init_tree(sptr, dtype); queue_type_param(0, dtype, 0, 2); put_default_kind_type_param(dtype, 0, 1); queue_type_param(0, 0, 0, 0); queue_tbp(sptr, 0, 0, dtype, TBP_INHERIT); queue_tbp(sptr, 0, 0, dtype, TBP_ADD_TO_DTYPE); if (!IN_MODULE) queue_tbp(0, 0, 0, 0, TBP_COMPLETE_ENDTYPE); /* Call get_static_type_descriptor() to ensure creation of type * descriptor at its definition point. This is especially important * for derived types defined in a subprogram and referenced in a * contains subprogram. */ if (gbl.internal <= 1) get_static_type_descriptor(sptr); if (0 && size_of(dtype) == 0 && DTY(dtype + 1) <= NOSYM) { int mem, oldsptr, tag; tag = DTY(DTYPEG(sptr) + 3); if (!UNLPOLYG(tag)) { /* Create "empty" typedef. */ oldsptr = sptr; get_static_type_descriptor(sptr); sptr = insert_sym(sptr); sptr = declsym(sptr, ST_TYPEDEF, TRUE); dtype = get_type(6, TY_DERIVED, NOSYM); DTYPEP(sptr, dtype); DTY(dtype + 1) = NOSYM; DTY(dtype + 2) = 0; /* will be filled in */ DTY(dtype + 3) = sptr; DTY(dtype + 5) = 0; SDSCP(sptr, SDSCG(oldsptr)); DCLDP(sptr, DCLDG(oldsptr)); chkstruct(dtype); } } chk_initialization_with_kind_parm(dtype); } else error(70, 2, gbl.lineno, "(END TYPE ignored)", CNULL); sem.type_mode = 0; sem.tbp_access_stmt = 0; entity_attr.access = ' '; /* Reset access spec of types */ SST_ASTP(LHS, 0); break; /* * ::= VOLATILE | */ case DECLARATION23: SST_ASTP(LHS, 0); break; /* * ::= POINTER */ case DECLARATION24: SST_ASTP(LHS, 0); break; /* * ::= ALLOCATABLE */ case DECLARATION25: SST_ASTP(LHS, 0); break; /* * ::= :: | */ case DECLARATION26: if (entity_attr.exist & ET_B(ET_PARAMETER)) { seen_parameter = TRUE; if (sem.interface == 0) end_param(); } SST_ASTP(LHS, 0); in_entity_typdcl = FALSE; entity_attr.exist = 0; entity_attr.access = ' '; bind_attr.exist = -1; bind_attr.altname = 0; break; /* * ::= | */ case DECLARATION27: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "An INTENT", CNULL); count = 0; for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) { sptr = refsym(itemp->t.sptr, OC_OTHER); INTENTP(sptr, entity_attr.intent); if (sem.interface) { if (SCG(sptr) != SC_DUMMY) error(134, 3, gbl.lineno, "- intent specified for nondummy argument", SYMNAME(sptr)); } else { /* defer checking of storage class until semfin */ itemp1 = (ITEM *)getitem(3, sizeof(ITEM)); itemp1->next = sem.intent_list; sem.intent_list = itemp1; itemp1->t.sptr = sptr; itemp1->ast = gbl.lineno; } if (bind_attr.altname && (++count > 1)) error(280, 2, gbl.lineno, "BIND: allowed only in module", 0); if (bind_attr.exist != -1) { process_bind(sptr); } } bind_attr.exist = -1; bind_attr.altname = 0; SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION28: count = 0; for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) { sptr1 = sptr = itemp->t.sptr; if (STYPEG(sptr) != ST_OPERATOR && STYPEG(sptr) != ST_USERGENERIC) sptr = refsym(sptr, OC_OTHER); if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr)) error(84, 3, gbl.lineno, SYMNAME(sptr), "- must not be an automatic array"); else { accessp = (ACCL *)getitem(3, sizeof(ACCL)); accessp->sptr = sptr1; accessp->type = entity_attr.access; accessp->next = sem.accl.next; accessp->oper = ' '; if (itemp->ast == 1) accessp->oper = 'o'; sem.accl.next = accessp; } if (bind_attr.altname && (++count > 1)) error(84, 3, gbl.lineno, SYMNAME(bind_attr.altname), "- too many variables bound to name"); if (bind_attr.exist != -1) { if (!IN_MODULE) error(280, 2, gbl.lineno, "BIND: allowed only in module", 0); process_bind(sptr); } } entity_attr.access = ' '; bind_attr.exist = -1; bind_attr.altname = 0; SST_ASTP(LHS, 0); break; /* * ::= OPTIONAL | */ case DECLARATION29: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "An OPTIONAL", CNULL); for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) { sptr = refsym(itemp->t.sptr, OC_OTHER); OPTARGP(sptr, 1); } SST_ASTP(LHS, 0); break; /* * ::= TARGET | */ case DECLARATION30: SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION31: SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION32: SST_ASTP(LHS, 0); break; /* * ::= USE */ case DECLARATION33: close_module(); SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION34: if (INSIDE_STRUCT) { if (STSK_ENT(0).type != 'd') { error(155, 3, gbl.lineno, "PUBLIC/PRIVATE may only be used in derived types", ""); break; } if (entity_attr.access == 'u') { ERR310("PUBLIC may not appear in a derived type definition", CNULL); } else { stsk = &STSK_ENT(0); sptr = DTY(stsk->dtype + 3); /* tag sptr */ if (stsk->last != NOSYM) { if (sem.type_mode == 2 && IN_MODULE_SPEC) { if (queue_tbp(0, 0, 0, stsk->dtype, TBP_STATUS)) { error(155, 3, gbl.lineno, "Incorrect sequence of PRIVATE and type bound " "procedures in", SYMNAME(sptr)); } if (sem.tbp_access_stmt) { error(155, 3, gbl.lineno, "Redundant PRIVATE statement in type bound " "procedure section of", SYMNAME(sptr)); } else { sem.tbp_access_stmt = 1; } } else if (!PARENTG(stsk->last) || PARENTG(stsk->last) != stsk->last) /* error - private statement appears after member */ error(155, 3, gbl.lineno, "PRIVATE statement must appear before " "components of derived type", SYMNAME(sptr)); } else { if (sem.type_mode == 2 && IN_MODULE_SPEC) { if (sem.tbp_access_stmt) { error(155, 3, gbl.lineno, "Redundant PRIVATE statement in type bound " "procedure section of", SYMNAME(sptr)); } else { sem.tbp_access_stmt = 1; } } else if (stsk->mem_access) { error(155, 3, gbl.lineno, "Redundant PRIVATE statement in derived type", SYMNAME(sptr)); } /* set PUBLIC/PRIVATE here. link_members() will apply it to the components of this derived type. */ stsk->mem_access = entity_attr.access; } } } else { /* not INSIDE_STRUCT */ if (sem.accl.type) { if (sem.accl.type == entity_attr.access) error(155, 2, gbl.lineno, "Redundant PUBLIC/PRIVATE statement", CNULL); else error(155, 3, gbl.lineno, "Conflicting PUBLIC/PRIVATE statement", CNULL); } else sem.accl.type = entity_attr.access; } SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION35: SST_ASTP(LHS, 0); break; /* * ::= ( ) | */ case DECLARATION36: for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) { sptr = itemp->t.sptr; /* ST_CMBLK */ if (sptr == 0) continue; THREADP(sptr, 1); if (STYPEG(sptr) != ST_CMBLK && !DCLDG(sptr) && !SAVEG(sptr) && !in_save_scope(sptr)) { error(38, 3, gbl.lineno, SYMNAME(sptr), CNULL); } else if (STYPEG(sptr) != ST_CMBLK && ALLOCATTRG(sptr)) { get_static_descriptor(sptr); get_all_descriptors(sptr); } } SST_ASTP(LHS, 0); break; /* * ::= */ case DECLARATION37: SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION38: SST_ASTP(LHS, 0); break; /* * ::= AUTOMATIC | */ case DECLARATION39: uf("AUTOMATIC"); break; /* * ::= STATIC */ case DECLARATION40: uf("STATIC"); break; /* * ::= BIND | */ case DECLARATION41: { int ii; ii = 1; count = 0; /* go through ths bind list and call process_bind for each */ if (bind_attr.exist != -1) { for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) { if (bind_attr.altname && (++count > 1)) error(84, 3, gbl.lineno, SYMNAME(bind_attr.altname), "- too many variables bound to name"); if (!IN_MODULE) error(84, 2, gbl.lineno, "BIND: allowed only in module", 0); process_bind(itemp->t.sptr); } bind_attr.exist = -1; bind_attr.altname = 0; } } SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION42: SST_ASTP(LHS, 0); break; /* * ::= ENUM , BIND ( ) | */ case DECLARATION43: np = scn.id.name + SST_CVALG(RHS(7)); if (sem_strcmp(np, "c") == 0) { sem.in_enum = TRUE; } else error(4, 3, gbl.lineno, "Illegal BIND -", np); next_enum = 0; SST_ASTP(LHS, 0); break; /* * ::= ENUMERATOR | */ case DECLARATION44: SST_ASTP(LHS, 0); break; /* * ::= ENDENUM | */ case DECLARATION45: sem.in_enum = FALSE; SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION46: SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION47: SST_ASTP(LHS, 0); break; /* * ::= ATTRIBUTES ( ) | */ case DECLARATION48: if (!cuda_enabled("attributes")) { SST_ASTP(LHS, 0); break; } SST_ASTP(LHS, 0); break; /* * ::= TCONTAINS | */ case DECLARATION49: dtype = stsk->dtype; if (DTY(dtype) == TY_DERIVED) { int tag = DTY(dtype + 3); if (SEQG(tag)) { error(155, 3, gbl.lineno, "Type bound procedure part not allowed " "for SEQUENCE type", SYMNAME(tag)); } if (CFUNCG(tag)) { error(155, 3, gbl.lineno, "Type bound procedure part not allowed " "for BIND(C) type", SYMNAME(tag)); } } sem.type_mode = 2; SST_ASTP(LHS, 0); break; /* * ::= PROTECTED */ case DECLARATION50: if (!IN_MODULE_SPEC) { error(155, 3, gbl.lineno, "PROTECTED may only appear in the specification part of a MODULE", CNULL); } for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) { sptr = ref_ident_inscope(itemp->t.sptr); PROTECTEDP(sptr, 1); } SST_ASTP(LHS, 0); break; /* * ::= ASYNCHRONOUS */ case DECLARATION51: for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) { sptr = ref_ident_inscope(itemp->t.sptr); if (sem.block_scope && sptr < sem.scope_stack[sem.block_scope].symavl && !ASYNCG(sptr)) error(1219, ERR_Severe, gbl.lineno, "ASYNCHRONOUS statement in a BLOCK construct", CNULL); ASYNCP(sptr, true); } SST_ASTP(LHS, 0); break; /* * ::= ACCDECL */ case DECLARATION52: SST_ASTP(LHS, 0); break; /* * ::= DECLARE | */ case DECLARATION53: SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION54: break; /* * ::= | */ case DECLARATION55: break; /* * ::= CONTIGUOUS */ case DECLARATION56: break; /* * ::= ROUTINE */ case DECLARATION57: SST_ASTP(LHS, 0); break; /* * ::= ROUTINE * ( ) | */ case DECLARATION58: SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION59: if (INSIDE_STRUCT && STSK_ENT(0).type == 'd' && SST_CVALG(RHS(1)) == 's') { stsk = &STSK_ENT(0); sptr = DTY(stsk->dtype + 3); /* tag sptr */ if (stsk->last != NOSYM) { /* error - SEQUENCE statement appears after member */ error( 155, 3, gbl.lineno, "SEQUENCE statement must appear before components of derived type", SYMNAME(sptr)); } else { if (SEQG(sptr)) { error(155, 3, gbl.lineno, "Redundant SEQUENCE statement in derived type", SYMNAME(sptr)); } SEQP(sptr, 1); /* set SEQ on the tag of derived type */ if (PARENTG(sptr)) { error(155, 3, gbl.lineno, "SEQUENCE may not appear in a derived type with " "EXTENDS keyword", CNULL); } } } SST_ASTP(LHS, 0); break; /* * ::= | */ case DECLARATION60: break; /* * ::= VALUE */ case DECLARATION61: if (sem.block_scope) error(1218, ERR_Severe, gbl.lineno, "A VALUE", CNULL); for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) { sptr = ref_ident_inscope(itemp->t.sptr); PASSBYVALP(sptr, 1); PASSBYREFP(sptr, 0); } SST_ASTP(LHS, 0); break; /* * ::= */ case DECLARATION62: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_DP_STMTS1: break; /* * ::= */ case ACCEL_DP_STMTS2: break; /* ------------------------------------------------------------------ */ /* * ::= ACCSHAPE */ case ACCEL_SHAPE_DECLSTMT1: break; /* ------------------------------------------------------------------ */ /* * ::= ( ) | */ case ACCEL_SHAPE_DIR1: /* * ::= ( ) | */ case ACCEL_SHAPE_DIR2: break; /* * ::= '<' '>' ( ) | */ case ACCEL_SHAPE_DIR3: /* * ::= '<' '>' ( ) */ case ACCEL_SHAPE_DIR4: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_SHAPE_ATTRS1: break; /* * ::= */ case ACCEL_SHAPE_ATTRS2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_SHAPE_ATTR1: break; /* * ::= | */ case ACCEL_SHAPE_ATTR2: break; /* * ::= */ case ACCEL_SHAPE_ATTR3: break; /* ------------------------------------------------------------------ */ /* * ::= DEFAULT ( ) */ case ACCEL_DPDEFAULT_ATTR1: break; /* ------------------------------------------------------------------ */ /* * ::= INIT_NEEDED ( ) */ case ACCEL_DPINIT_NEEDED_ATTR1: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ACCEL_DPINITVAR_LIST1: /* * ::= */ case ACCEL_DPINITVAR_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= TYPE ( ) */ case ACCEL_DPTYPE_ATTR1: break; /* ------------------------------------------------------------------ */ /* * ::= ACCPOLICY */ case ACCEL_POLICY_DECLSTMT1: break; /* ------------------------------------------------------------------ */ /* * ::= '<' '>' | */ case ACCEL_POLICY_NAME1: /* * ::= '<' : '>' */ case ACCEL_POLICY_NAME2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case ACCEL_POLICY_DIR1: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_POLICY_ATTR_LIST1: break; /* * ::= */ case ACCEL_POLICY_ATTR_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= CREATE ( ) | */ case ACCEL_POLICY_ATTR1: break; /* * ::= NO_CREATE ( ) | */ case ACCEL_POLICY_ATTR2: break; /* * ::= COPYIN ( ) | */ case ACCEL_POLICY_ATTR3: break; /* * ::= COPYOUT ( ) | */ case ACCEL_POLICY_ATTR4: break; /* * ::= COPY ( ) | */ case ACCEL_POLICY_ATTR5: break; /* * ::= UPDATE ( ) | */ case ACCEL_POLICY_ATTR6: break; /* * ::= DEVICEPTR ( ) | */ case ACCEL_POLICY_ATTR7: break; /* * ::= | */ case ACCEL_POLICY_ATTR8: break; /* * ::= */ case ACCEL_POLICY_ATTR9: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_DPVARLIST1: break; /* * ::= */ case ACCEL_DPVARLIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_DPVAR1: /* * ::= '<' '>' | */ case ACCEL_DPVAR2: /* * ::= ( ) | */ case ACCEL_DPVAR3: /* * ::= '<' '>' ( ) */ case ACCEL_DPVAR4: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ACCEL_DPVAR_BNDS1: break; /* * ::= */ case ACCEL_DPVAR_BNDS2: break; /* ------------------------------------------------------------------ */ /* * ::= : | */ case ACCEL_DPVAR_BND1: break; /* * ::= */ case ACCEL_DPVAR_BND2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case ACCEL_DP_BND1: break; /* * ::= | */ case ACCEL_DP_BND2: break; /* * ::= */ case ACCEL_DP_BND3: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_DP_BNDEXP1: break; /* * ::= */ case ACCEL_DP_BNDEXP2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case ACCEL_DP_ADDEXP1: break; /* ------------------------------------------------------------------ */ /* * ::= */ case ACCEL_DP_MULEXP1: break; /* ------------------------------------------------------------------ */ /* * ::= + | */ case ACCEL_ADD_OPR1: break; /* * ::= - */ case ACCEL_ADD_OPR2: break; /* ------------------------------------------------------------------ */ /* * ::= * | */ case ACCEL_MUL_OPR1: break; /* * ::= / */ case ACCEL_MUL_OPR2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case ACCEL_DP_BNDEXP11: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_DP_SBND1: break; /* * ::= */ case ACCEL_DP_SBND2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ROUTINE_ID_LIST1: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(1)); SST_BEGP(LHS, itemp); SST_ENDP(LHS, itemp); break; /* * ::= , */ case ROUTINE_ID_LIST2: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(3)); SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= */ case FINAL1: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_TPSL1: break; /* * ::= ( ) */ case OPT_TPSL2: sem.param_offset = 0; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TYPE_PARAM_SPEC_LIST1: rhstop = 3; goto tpsl_shared; /* * ::= */ case TYPE_PARAM_SPEC_LIST2: rhstop = 1; tpsl_shared: sptr = SST_SYMG(RHS(rhstop)); if (sem.extends && sem.param_offset == 0) { sem.param_offset = get_highest_param_offset(DTYPEG(sem.extends)); } sem.param_offset += 1; queue_type_param(sptr, 0, sem.param_offset, 1); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_DERIVED_TYPE_SPEC1: /* fall thru */ /* * ::= ( ) */ case OPT_DERIVED_TYPE_SPEC2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case TYPE_PARAM_DECL_LIST1: break; /* * ::= , */ case TYPE_PARAM_DECL_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= * | */ case TYPE_PARAM_VALUE5: sem.param_assume_sz = 1; sem.param_defer_len = 0; goto param_comm; /* * ::= : | */ case TYPE_PARAM_VALUE3: sem.param_assume_sz = 0; sem.param_defer_len = 1; goto param_comm; /* * ::= | */ case TYPE_PARAM_VALUE1: sem.param_assume_sz = 0; sem.param_defer_len = 0; param_comm: if (sem.param_offset < 0) { error(155, 3, gbl.lineno, "A non keyword = type parameter specifier " "cannot follow a keyword = type parameter " "specifier", NULL); } else { sem.param_offset += 1; if (!sem.param_assume_sz && !sem.param_defer_len) { mkexpr(RHS(1)); ast = SST_ASTG(RHS(1)); } else { ast = 0; } if (A_TYPEG(ast) == A_CNST) { defer_put_kind_type_param(sem.param_offset, SST_CVALG(RHS(1)), NULL, 0, ast, 1); } else { defer_put_kind_type_param(sem.param_offset, -1, NULL, 0, ast, 1); } } break; /* * ::= = * */ case TYPE_PARAM_VALUE6: sem.param_assume_sz = 1; sem.param_defer_len = 0; goto param_kwd_comm; /* * ::= = : */ case TYPE_PARAM_VALUE4: sem.param_assume_sz = 0; sem.param_defer_len = 1; goto param_kwd_comm; /* * ::= = */ case TYPE_PARAM_VALUE2: sem.param_assume_sz = 0; sem.param_defer_len = 0; param_kwd_comm: np = scn.id.name + SST_CVALG(RHS(1)); sem.param_offset = -1; if (!sem.param_assume_sz && !sem.param_defer_len) { mkexpr(RHS(3)); ast = SST_ASTG(RHS(3)); } else { ast = 0; } if (A_TYPEG(ast) == A_CNST) { defer_put_kind_type_param(sem.param_offset, SST_CVALG(RHS(3)), np, 0, ast, 1); } else { defer_put_kind_type_param(sem.param_offset, -1, np, 0, ast, 1); } /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_COMMA1: break; /* * ::= , */ case OPT_COMMA2: break; break; /* ------------------------------------------------------------------ */ /* * ::= DIMENSION | */ case DIMKEYWORD1: /* disallow DIMENSION in a structure */ if (INSIDE_STRUCT && (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) { error(117, 3, gbl.lineno, STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL); sem.ignore_stmt = TRUE; } break; /* * ::= */ case DIMKEYWORD2: /* disallow DIMENSION in a structure */ if (INSIDE_STRUCT && (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) { error(117, 3, gbl.lineno, STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL); sem.ignore_stmt = TRUE; } scn.stmtyp = TK_DIMENSION; break; /* ------------------------------------------------------------------ */ /* * ::= */ case NIS1: /* "not inside structure" test; if inside a structure emit error * message and set flag to tell parser to skip over the current * statement. */ /* need to allow SEQUENCE (a hpf spec) in derived types */ if (INSIDE_STRUCT && (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) { error(117, 3, gbl.lineno, STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL); sem.ignore_stmt = TRUE; } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DATA_TYPE1: rhstop = 2; goto data_type_shared; /* * ::= ( ) | */ case DATA_TYPE2: rhstop = 3; data_type_shared: if (sem.deferred_func_len || sem.deferred_func_kind) { /* probably defined in a USEd module, wait until USE stmts have been * processed */ break; } set_len_attributes(RHS(rhstop), 0); sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[0].kind, lenspec[0].len, 0, 0); break; /* * ::= CLASS ( * ) */ case DATA_TYPE5: sptr = get_unl_poly_sym(0); #if DEBUG assert(DTY(DTYPEG(sptr)) == TY_DERIVED && UNLPOLYG(DTY(DTYPEG(sptr) + 3)), "semant1: Invalid dtype for CLASS(*)", 0, 3); #endif sem.class = 1; goto type_common; /* * ::= CLASS ( ) */ case DATA_TYPE4: sptr = refsym((int)SST_SYMG(RHS(4)), OC_OTHER); sem.class = 1; goto type_common; /* * ::= TYPE ( ) */ case DATA_TYPE3: sptr = refsym((int)SST_SYMG(RHS(3)), OC_OTHER); type_common: if (STYPEG(sptr) != ST_TYPEDEF) { np = SYMNAME(sptr); if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) { sptr = GTYPEG(sptr); } else if (STYPEG(sptr) == ST_UNKNOWN && sem.pgphase == PHASE_INIT) { sem.deferred_dertype = sptr; sem.deferred_kind_len_lineno = gbl.lineno; sptr = declsym(sptr, ST_TYPEDEF, TRUE); } else if (STYPEG(sptr) == ST_UNKNOWN && (scn.stmtyp == TK_IMPLICIT || (INSIDE_STRUCT && STSK_ENT(0).type == 'd'))) { /* assume a forward reference -- legal if the type * appears in an implicit statement or is a component * declaration with the POINTER attribute or if phase is * PHASE_INIT (in which case it could be a function return * type). */ sptr = declsym(sptr, ST_TYPEDEF, TRUE); dtype = get_type(6, TY_DERIVED, NOSYM); DTYPEP(sptr, dtype); DTY(dtype + 2) = 0; /* will be filled in */ DTY(dtype + 3) = sptr; DTY(dtype + 5) = 0; } else { /* recover by creating an empty typedef */ error(155, 3, gbl.lineno, "Derived type has not been declared -", SYMNAME(sptr)); sptr = insert_sym(sptr); sptr = declsym(sptr, ST_TYPEDEF, TRUE); dtype = get_type(6, TY_DERIVED, NOSYM); DTYPEP(sptr, dtype); DTY(dtype + 2) = 0; /* will be filled in */ DTY(dtype + 3) = sptr; DTY(dtype + 5) = 0; } } else if (DTY(DTYPEG(sptr) + 1) <= NOSYM && (!INSIDE_STRUCT || STSK_ENT(0).type != 'd')) { int mem, oldsptr, tag; tag = DTY(DTYPEG(sptr) + 3); } else if (!sem.class && ABSTRACTG(sptr)) { error(155, 3, gbl.lineno, "illegal use of abstract type", SYMNAME(sptr)); } if (!sem.type_mode || sem.stag_dtype != DTYPEG(sptr)) { /* Do not call defer_put_kind_type_param() if this declaration * is part of a recursively typed component. The * defer_put_kind_type_param() call below processes all type parameters. * But in this case, the type has not yet been fully defined. So, we * need to handle this later. */ sem.stag_dtype = DTYPEG(sptr); sem.gdtype = sem.ogdtype = sem.stag_dtype; defer_put_kind_type_param(0, 0, NULL, sem.stag_dtype, 0, 2); } else { sem.stag_dtype = DTYPEG(sptr); sem.gdtype = sem.ogdtype = sem.stag_dtype; } defer_put_kind_type_param(0, 0, NULL, 0, 0, 0); if (!sem.new_param_dt && has_type_parameter(sem.stag_dtype) /*&& defer_pt_decl(0, 2)*/ /*AOCC*/) { /* In this case we're using just the default type * of a parameterized derived type. We need to make sure we * create another instance of it so we don't pollute the * default type that's shared across all instances of the type * (e.g., type(t) :: x may pollute type(t(5)) :: y ). */ sem.new_param_dt = create_parameterized_dt(sem.stag_dtype, 0); } put_default_kind_type_param( (sem.new_param_dt) ? sem.new_param_dt : sem.stag_dtype, 0, 0); put_length_type_param( (sem.new_param_dt) ? sem.new_param_dt : sem.stag_dtype, 0); break; /* ------------------------------------------------------------------ */ /* * ::= */ case TYPE_SPEC1: break; /* * ::= */ case TYPE_SPEC2: SST_DTYPEP(LHS, sem.gdtype); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case INTRINSIC_TYPE1: rhstop = 2; if (sem.gdtype == DT_CHAR || sem.gdtype == DT_NCHAR) { if (SST_IDG(RHS(2)) == 0) { if (SST_ASTG(RHS(2))) sem.gcvlen = SST_ASTG(RHS(2)); else if (SST_SYMG(RHS(2)) == -2 || SST_SYMG(RHS(2)) == -1) sem.gcvlen = astb.i1; else sem.gcvlen = mk_cval(SST_SYMG(RHS(2)), DT_INT4); } else { sem.gcvlen = SST_ASTG(RHS(2)); } } goto intrinsic_type_shared; /* * ::= ( ) */ case INTRINSIC_TYPE2: rhstop = 3; if (sem.gdtype == DT_CHAR || sem.gdtype == DT_NCHAR) { if (SST_IDG(RHS(3)) == 0) { if (SST_ASTG(RHS(3))) sem.gcvlen = SST_ASTG(RHS(3)); else if (SST_SYMG(RHS(3)) == -2 || SST_SYMG(RHS(3)) == -1) sem.gcvlen = astb.i1; else sem.gcvlen = mk_cval(SST_SYMG(RHS(3)), DT_INT4); } else { sem.gcvlen = SST_ASTG(RHS(3)); } } intrinsic_type_shared: if (is_exe_stmt && sem.which_pass == 0) break; if (sem.deferred_func_len) { /* probably defined in a USEd module, wait USE stmts have been processed */ break; } set_aclen(RHS(rhstop), 1, 1); sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len, lenspec[1].propagated, 0); SST_DTYPEP(LHS, sem.gdtype); set_aclen(RHS(rhstop), 1, 0); SST_IDP(LHS, 0); break; /* ------------------------------------------------------------------ */ /* * ::= INTEGER | */ case BASE_TYPE1: sem.gdtype = sem.ogdtype = stb.user.dt_int; sem.gty = TY_INT; break; /* * ::= REAL | */ case BASE_TYPE2: sem.gdtype = sem.ogdtype = stb.user.dt_real; sem.gty = TY_REAL; break; /* * ::= DOUBLEPRECISION | */ case BASE_TYPE3: sem.gdtype = sem.ogdtype = DT_DBLE; sem.gty = TY_DBLE; if (XBIT(57, 0x10) && DTY(sem.gdtype) == TY_QUAD) { error(437, 2, gbl.lineno, "DOUBLE PRECISION", "REAL"); sem.gdtype = DT_REAL; } break; /* * ::= COMPLEX | */ case BASE_TYPE4: sem.gdtype = sem.ogdtype = stb.user.dt_cmplx; sem.gty = TY_CMPLX; break; /* * ::= DOUBLECOMPLEX | */ case BASE_TYPE5: if (flg.standard) error(171, 2, gbl.lineno, "DOUBLECOMPLEX", CNULL); sem.gdtype = sem.ogdtype = DT_DCMPLX; sem.gty = TY_DCMPLX; if (XBIT(57, 0x10) && DTY(sem.gdtype) == TY_DCMPLX) { error(437, 2, gbl.lineno, "DOUBLE COMPLEX", "COMPLEX"); sem.gdtype = DT_CMPLX; } break; /* * ::= LOGICAL | */ case BASE_TYPE6: sem.gdtype = sem.ogdtype = stb.user.dt_log; sem.gty = TY_LOG; break; /* * ::= CHARACTER | */ case BASE_TYPE7: sem.gdtype = sem.ogdtype = DT_CHAR; sem.gty = TY_CHAR; break; /* * ::= NCHARACTER | */ case BASE_TYPE8: if (flg.standard) error(171, 2, gbl.lineno, "NCHARACTER", CNULL); sem.gdtype = sem.ogdtype = DT_NCHAR; sem.gty = TY_NCHAR; break; /* * ::= BYTE */ case BASE_TYPE9: if (flg.standard) error(171, 2, gbl.lineno, "BYTE", CNULL); sem.gdtype = sem.ogdtype = DT_BINT; sem.gty = TY_BINT; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_LEN_SPEC1: SST_IDP(LHS, 0); SST_SYMP(LHS, -1); SST_ASTP(LHS, 0); SST_DTYPEP(LHS, sem.gdtype); break; /* * ::= * */ case OPT_LEN_SPEC2: *LHS = *RHS(2); if (sem.ogdtype != DT_CHAR && flg.standard) errwarn(173); break; /* * ::= : */ case OPT_LEN_SPEC3: *LHS = *RHS(2); if (sem.ogdtype != DT_CHAR && flg.standard) errwarn(173); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case LEN_SPEC1: /* constant value set by scan */ SST_IDP(LHS, 0); /* flag that an expression was seen */ SST_ASTP(LHS, 0); goto len_spec; /* * ::= ( ) | */ case LEN_SPEC2: *LHS = *RHS(2); char_len_spec: if (sem.ogdtype != DT_CHAR && sem.ogdtype != DT_NCHAR) SST_SYMP(LHS, 0); len_spec: if (is_exe_stmt && sem.which_pass == 0) break; if (sem.ogdtype == DT_CHAR || sem.ogdtype == DT_NCHAR) { if (SST_IDG(LHS) == 0) { if (SST_CVALG(LHS) <= 0) { /* zero-size character - set flag */ SST_SYMP(LHS, -2); } } break; } if (SST_IDG(LHS) == 0 && SST_SYMG(LHS) <= 0) { /* Cause error message to print later when context is known, * ensure that illegal value -1 doesn't map to internal * flag -1 for no length spec. */ SST_SYMP(LHS, 99); /* cause error message displayed later */ } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case TPV1: if (is_exe_stmt && sem.which_pass == 0) break; if (chk_kind_parm(RHS(1))) { mkexpr(RHS(1)); /* Needed for type parameter */ ast = SST_ASTG(RHS(1)); switch (A_TYPEG(ast)) { case A_ID: case A_LABEL: case A_ENTRY: case A_SUBSCR: case A_SUBSTR: case A_MEM: /* Mark possible use of type parameter */ sptr = sym_of_ast(ast); KINDP(sptr, -1); break; } } rhstop = 5; if (sem.ogdtype != DT_CHAR && sem.ogdtype != DT_NCHAR) { int offset; if (sem.pgphase <= PHASE_USE) { if (SST_IDG(top) == S_IDENT && STYPEG(SST_SYMG(top)) == ST_UNKNOWN) { /* probably defined in a USEd module, wait until USE stmts * have been processed */ ast = SST_ASTG(RHS(1)); if (!ast) { ast = mk_id(SST_SYMG(top)); } sem.deferred_func_kind = ast; sem.deferred_kind_len_lineno = gbl.lineno; break; } else if (SST_IDG(top) == S_EXPR) { sem.deferred_func_kind = SST_ASTG(RHS(1)); sem.deferred_kind_len_lineno = gbl.lineno; break; } } offset = chk_kind_parm(RHS(1)); if (offset) { /* TO DO: Save length expression candidate like in DT_CHAR case */ sem.type_param_candidate = offset; SST_SYMP(LHS, 4); /* place holder */ sem.kind_candidate = (ITEM *)getitem(0, sizeof(ITEM)); sem.kind_candidate->t.stkp = (SST *)getitem(0, sizeof(SST)); *(sem.kind_candidate->t.stkp) = *RHS(1); } else SST_SYMP(LHS, chkcon(RHS(1), DT_INT4, TRUE)); } else { int offset; offset = chk_kind_parm(RHS(1)); if (offset) { sem.type_param_candidate = offset; sem.len_candidate = (ITEM *)getitem(0, sizeof(ITEM)); sem.len_candidate->t.stkp = (SST *)getitem(0, sizeof(SST)); *(sem.len_candidate->t.stkp) = *RHS(1); SST_SYMP(LHS, 1); /* place holder */ SST_IDP(LHS, 0); /* flag that a constant was seen */ SST_ASTP(LHS, 0); /* not expression */ break; } sem.len_candidate = 0; constant_lvalue(RHS(1)); if (SST_IDG(RHS(1)) == S_CONST) { SST_SYMP(LHS, chkcon(RHS(1), DT_INT4, TRUE)); } else { (void)chktyp(RHS(1), DT_INT, TRUE); ast = SST_ASTG(RHS(1)); /* flag that an expression was seen: id field is 1, sym field * is non-zero, and ast field is the ast of the expression. */ if (sem.pgphase == PHASE_INIT) { if (SST_IDG(top) == S_IDENT && STYPEG(SST_SYMG(top)) == ST_UNKNOWN) { /* probably defined in a USEd module, * wait until USE stmts have been processed */ if (!ast) { ast = mk_id(SST_SYMG(top)); } sem.deferred_func_len = ast; sem.deferred_kind_len_lineno = gbl.lineno; break; } else if (SST_IDG(top) == S_EXPR) { sem.deferred_func_len = SST_ASTG(RHS(1)); sem.deferred_kind_len_lineno = gbl.lineno; break; } } SST_IDP(LHS, 1); SST_SYMP(LHS, _INF_CLEN); SST_ASTP(LHS, SST_ASTG(RHS(1))); break; } } SST_IDP(LHS, 0); /* flag that a constant was seen */ SST_ASTP(LHS, 0); /* not expression */ break; /* * ::= * */ case TPV2: /* flag that a '*' was seen: id field is 1, sym field is zero. */ asz_string = 1; SST_IDP(LHS, 1); SST_SYMP(LHS, 0); SST_ASTP(LHS, 0); /* not expression */ break; /* * ::= : */ case TPV3: /* flag that a ':' was seen: id field is 1, sym field is -1. */ SST_IDP(LHS, 1); SST_SYMP(LHS, -1); SST_ASTP(LHS, 0); /* not expression */ break; /* ------------------------------------------------------------------ */ /* * ::= | */ case LEN_KIND1: if (is_exe_stmt && sem.which_pass == 0) break; if (sem.deferred_func_kind) { /* probably defined in a USEd module, wait USE stmts have been processed */ break; } if (sem.gdtype != DT_CHAR && sem.gdtype != DT_NCHAR) { sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(1))); SST_SYMP(LHS, -1); break; } goto len_spec; /* * ::= | */ case LEN_KIND2: if (is_exe_stmt && sem.which_pass == 0) break; switch (SST_FLAGG(RHS(1))) { case 0: /* error */ break; case 1: /* LEN = */ if (sem.ogdtype == DT_CHAR) goto char_len_spec; error(81, 3, gbl.lineno, "- LEN = cannot be specified with non-character type", CNULL); break; case 2: /* KIND = */ sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(1))); break; } SST_SYMP(LHS, -1); break; /* * ::= , | */ case LEN_KIND3: /* len, kind = ... */ if (is_exe_stmt && sem.which_pass == 0) break; if (sem.ogdtype != DT_CHAR) { error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL); SST_SYMP(LHS, -1); /* an error occurred - null processing */ break; } switch (SST_FLAGG(RHS(3))) { case 0: /* error */ break; case 1: /* LEN = */ error(81, 3, gbl.lineno, "- Repeated LEN", CNULL); break; case 2: /* KIND = */ sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(3))); break; } goto char_len_spec; /* * ::= , | */ case LEN_KIND4: /* len, kind */ if (is_exe_stmt && sem.which_pass == 0) break; if (sem.ogdtype != DT_CHAR) { error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL); SST_SYMP(LHS, -1); /* an error occurred - null processing */ break; } sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(3))); goto char_len_spec; /* * ::= , */ case LEN_KIND5: /* len = .., kind = ... or kind = ..., len = ... */ if (is_exe_stmt && sem.which_pass == 0) break; if (sem.ogdtype != DT_CHAR) { error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL); SST_SYMP(LHS, -1); /* an error occurred - null processing */ break; } switch (SST_FLAGG(RHS(1))) { default: /* error */ break; case 1: /* LEN = */ switch (SST_FLAGG(RHS(3))) { case 0: /* error */ break; case 1: /* LEN = */ error(81, 3, gbl.lineno, "- Repeated LEN =", CNULL); break; case 2: /* KIND = */ sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(3))); goto char_len_spec; } break; case 2: /* KIND = */ switch (SST_FLAGG(RHS(3))) { case 0: /* error */ break; case 1: /* LEN = */ sem.gdtype = select_kind(sem.gdtype, sem.gty, (INT)SST_SYMG(RHS(1))); *LHS = *RHS(3); goto char_len_spec; case 2: /* KIND = */ error(81, 3, gbl.lineno, "- Repeated KIND =", CNULL); break; } break; } SST_SYMP(LHS, -1); /* an error occurred - null processing */ break; /* ------------------------------------------------------------------ */ /* * ::= = */ case LEN_KIND_SPEC1: np = scn.id.name + SST_CVALG(RHS(1)); *LHS = *RHS(3); if (is_exe_stmt && sem.which_pass == 0) break; SST_FLAGP(LHS, 0); if (sem_strcmp(np, "len") == 0) { SST_FLAGP(LHS, 1); if (sem.type_param_candidate && sem.len_candidate) { sem.len_type_param = sem.type_param_candidate; sem.type_param_candidate = 0; mkexpr(sem.len_candidate->t.stkp); ast = SST_ASTG(sem.len_candidate->t.stkp); if (A_TYPEG(ast) != A_CNST) { /* set ignore flag on any len type parameters to prevent * "implicit none" errors */ chk_len_parm_expr(ast, 0, 1); } } } else if (sem_strcmp(np, "kind") == 0) { sem.kind_type_param = sem.type_param_candidate; sem.type_param_candidate = 0; if (!sem.deferred_func_kind) { if (SST_IDG(RHS(3))) { if (SST_ASTG(RHS(3))) errsev(87); else error(81, 3, gbl.lineno, "- KIND = *", CNULL); } else SST_FLAGP(LHS, 2); } } else { error(34, 3, gbl.lineno, np, CNULL); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPTIONAL_COMMA1: break; /* * ::= , */ case OPTIONAL_COMMA2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_ATTR1: break; /* * ::= :: */ case OPT_ATTR2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TYPDCL_LIST1: break; /* * ::= */ case TYPDCL_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= / / | */ case TYPDCL_ITEM1: if (flg.standard) errwarn(174); inited = TRUE; goto typ_dcl_item; /* * ::= */ case TYPDCL_ITEM2: inited = FALSE; typ_dcl_item: sptr = SST_SYMG(RHS(1)); if (flg.xref) xrefput(sptr, 'd'); dtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len, lenspec[1].propagated, sptr); if (!DCLDG(sptr)) { switch (STYPEG(sptr)) { /* any cases for which a type must be identical to the variable's * implicit type. */ case ST_PARAM: if (DTYPEG(sptr) != dtype) error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL); break; default: break; } } common_typespecs: if (DCLDG(sptr)) { switch (STYPEG(sptr)) { /* any cases for which a data type does not apply */ case ST_MODULE: case ST_NML: error(44, 3, gbl.lineno, SYMNAME(sptr), CNULL); break; default: /* data type for ident has already been specified */ if (DDTG(DTYPEG(sptr)) == dtype) error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL); else if (DTY(DTYPEG(sptr)) == TY_PTR && DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC && DTY(DTY(DTYPEG(sptr) + 1) + 1) == DT_NONE && DTY(DTY(DTYPEG(sptr) + 1) + 2) == 0) { /* ptr to procedure, return dtype is DT_NONE, no interface; just * update the return dtype (no longer assume it's a pointer to a * subroutine). */ DTY(DTY(DTYPEG(sptr) + 1) + 1) = dtype; } else { error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } break; /* to avoid setting symbol table entry's stype field */ } DCLDP(sptr, TRUE); /* Procedure pointer without a declared type (combination of "external" and * "pointer" attributes) */ if (is_procedure_ptr_dtype(DTYPEG(sptr))) { set_proc_ptr_result_dtype(DTYPEG(sptr), dtype); /* Avoid the rest */ break; } /* Procedure without a type ("external" attribute) */ if (is_procedure_dtype(DTYPEG(sptr))) { set_proc_result_dtype(DTYPEG(sptr), dtype); /* Avoid the rest */ break; } set_char_attributes(sptr, &dtype); //AOCC Begin if (sem.new_param_dt) { dtype = DTYPEG(sptr); if (DTY(dtype) == TY_ARRAY) { DTY(dtype + 1) = sem.new_param_dt; } else { DTYPEP(sptr, sem.new_param_dt); } fix_type_param_members(sptr, sem.new_param_dt); } //AOCC End else { if (DTY(DTYPEG(sptr)) == TY_ARRAY) { DTY(DTYPEG(sptr) + 1) = dtype; if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) && DISTMEMG(DTY(dtype + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } else { DTYPEP(sptr, dtype); } } if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr)) { #if DEBUG interr("semant1: data type set for ST_ENTRY with FVAL", sptr, 3); #endif DCLDP(FVALG(sptr), TRUE); DTYPEP(FVALG(sptr), DTYPEG(sptr)); set_char_attributes(FVALG(sptr), &dtype); } if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER && RESULTG(sptr)) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } if (inited) { /* check if symbol is data initialized */ gen_dinit(sptr, RHS(3)); } else if (DTY(DDTG(dtype)) == TY_DERIVED && !POINTERG(sptr) && !ADJARRG(sptr) && !ALLOCG(sptr) && SCG(sptr) != SC_DUMMY) { int dt_dtype = DDTG(dtype); if (INSIDE_STRUCT) { /* Uninitialized declaration of a derived type data item. * Check for and handle any component intializations defined * for this derived type */ build_typedef_init_tree(sptr, dt_dtype); } else if (DTY(dt_dtype + 5) && SCOPEG(sptr) && SCOPEG(sptr) == stb.curr_scope && STYPEG(stb.curr_scope) == ST_MODULE) { /* * a derived type module variable has component initializers, * so generate inits. */ build_typedef_init_tree(sptr, dt_dtype); } } break; /* * ::= %FILL */ case TYPDCL_ITEM3: if (flg.standard) error(176, 2, gbl.lineno, "%FILL", CNULL); if (sem.stsk_depth == 0) errwarn(145); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case DCL_ID_LIST1: rhstop = 3; goto dcl_id_list; /* * ::= | */ case DCL_ID_LIST2: rhstop = 1; /* Shared by DIMENSION and COMMON statements */ dcl_id_list: sptr = SST_SYMG(RHS(rhstop)); if (lenspec[1].kind) error(32, 2, gbl.lineno, SYMNAME(sptr), CNULL); if (flg.xref) xrefput(sptr, 'd'); if (scn.stmtyp == TK_COMMON) { /* COMMON block defn: link symbol into list */ { itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = sptr; if (rhstop == 1) /* adding first common block item to list: */ SST_BEGP(LHS, itemp); else SST_ENDG(RHS(1))->next = itemp; } SST_ENDP(LHS, itemp); } else { #if DEBUG assert(scn.stmtyp == TK_DIMENSION, "semant:unexp.stmt-dcl_id_lis", scn.stmtyp, 3); #endif } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DCL_ID1: set_len_attributes(RHS(2), 1); stype = ST_IDENT; sptr = SST_SYMG(RHS(1)); if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr)) sptr = FVALG(sptr); if (test_scope(sptr) == sem.scope_level && STYPEG(sptr) != ST_MEMBER) { dtype = DTYPEG(sptr); } else { dtype = 0; } sem.dinit_count = 1; goto dcl_shared; /* * ::= ) */ case DCL_ID2: /* Send len spec up with ident on semantic stack */ if (SST_SYMG(RHS(6)) != -1) { if (SST_SYMG(RHS(2)) != -1) errsev(46); set_len_attributes(RHS(6), 1); } else set_len_attributes(RHS(2), 1); stype = ST_ARRAY; dtype = SST_DTYPEG(RHS(4)); ad = AD_DPTR(dtype); if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad) || sem.interface) sem.dinit_count = -1; else sem.dinit_count = ad_val_of(sym_of_ast(AD_NUMELM(AD_DPTR(dtype)))); dcl_shared: sptr = SST_SYMG(RHS(1)); if (!(entity_attr.exist & ET_B(ET_BIND))) { sptr = block_local_sym(SST_SYMG(RHS(1))); SST_SYMP(RHS(1), sptr); } if (!sem.which_pass && gbl.internal > 1) { decr_ident_use(sptr, ident_host_sub); } if (!sem.kind_type_param && !sem.len_type_param && sem.type_param_candidate) { sem.kind_type_param = sem.type_param_candidate; sem.type_param_candidate = 0; } if (INSIDE_STRUCT) { if (STYPEG(sptr) != ST_UNKNOWN) SST_SYMP(LHS, (sptr = insert_sym(sptr))); if (sem.kind_type_param) { USEKINDP(sptr, 1); KINDP(sptr, sem.kind_type_param); if (sem.kind_candidate) { /* Save kind expression in component */ mkexpr(sem.kind_candidate->t.stkp); KINDASTP(sptr, SST_ASTG(sem.kind_candidate->t.stkp)); } } if (sem.len_type_param) { USELENP(sptr, 1); LENP(sptr, sem.len_type_param); } SYMLKP(sptr, NOSYM); STYPEP(sptr, ST_MEMBER); /* if the dtype was determined from the symbol table entry then it * is incorrect (because we got a new symbol entry above). */ if (stype == ST_IDENT) dtype = sem.gdtype; if (sem.gdtype != -1 && DTY(sem.gdtype) == TY_DERIVED && (STSK_ENT(0).type == 'd')) { stsk = &STSK_ENT(0); /* if outer derived type has SEQUENCE then nested one should */ if (SEQG(DTY(stsk->dtype + 3)) && !SEQG(DTY(sem.gdtype + 3))) { error(155, 3, gbl.lineno, "SEQUENCE must be set for nested derived type", SYMNAME(DTY(sem.gdtype + 3))); } if (DTY(stsk->dtype + 3) == DTY(sem.gdtype + 3)) { error(155, 3, gbl.lineno, "Derived type component must have the POINTER attribute -", SYMNAME(sptr)); } else if (!DCLDG(DTY(sem.gdtype + 3))) error(155, 3, gbl.lineno, "Derived type has not been declared -", SYMNAME(DTY(sem.gdtype + 3))); } DTYPEP(sptr, dtype); /* must be done before link members */ /* link field-namelist into member list at this level */ stsk = &STSK_ENT(0); link_members(stsk, sptr); if (stype == ST_ARRAY && STSK_ENT(0).type != 'd' && (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); if (DTY(dtype) == TY_ARRAY) { int d; d = DTY(dtype + 1); if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) { if (!ALLOCG(sptr) && AD_ADJARR(ad)) { int bndast, bnd_sptr, badArray, offset; int numdim = AD_NUMDIM(ad); for (badArray = i = 0; i < numdim; i++) { bndast = AD_LWAST(ad, i); badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0); if (!badArray) { bndast = AD_UPAST(ad, i); badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0); if (!badArray) { ADJARRP(sptr, 1); USELENP(sptr, 1); break; } } } if (badArray) { for (badArray = i = 0; i < numdim; i++) { bndast = AD_LWAST(ad, i); badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0); if (badArray) { badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1); if (!badArray) { ADJARRP(sptr, 1); USELENP(sptr, 1); break; } } if (badArray) goto illegal_array_member; bndast = AD_UPAST(ad, i); badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0); if (badArray) { badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1); if (!badArray) { ADJARRP(sptr, 1); USELENP(sptr, 1); break; } } else if (A_TYPEG(bndast) != A_ID && A_TYPEG(bndast) != A_CNST) { ADJARRP(sptr, 1); USELENP(sptr, 1); if (!chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1)) { USEKINDP(sptr, 1); } break; } if (badArray) goto illegal_array_member; } } } else if (!ALLOCG(sptr)) { illegal_array_member: error(134, 3, gbl.lineno, "- deferred shape array must have the POINTER " "attribute in a derived type", SYMNAME(sptr)); ALLOCP(sptr, 1); } } } if (XBIT(58, 0x10000) && !F90POINTERG(sptr)) { /* we are processing a member, and we must handle all pointers * do we need descriptors for this member? */ if (POINTERG(sptr) || ALLOCG(sptr) || #ifdef USELENG USELENG(sptr) || #endif (STYPEG(sptr) != ST_MEMBER && (ADJARRG(sptr) || RUNTIMEG(sptr)))) { get_static_descriptor(sptr); get_all_descriptors(sptr); SCP(sptr, SC_BASED); } } } else { sptr = create_var(sptr); SST_SYMP(LHS, sptr); stype1 = STYPEG(sptr); if (sem.kind_type_param) { USEKINDP(sptr, 1); KINDP(sptr, sem.kind_type_param); } if (sem.len_type_param) { USELENP(sptr, 1); LENP(sptr, sem.len_type_param); } if (DTY(sem.stag_dtype) == TY_DERIVED && sem.class) { /* TBD - Probably need to fix this condition when we * support unlimited polymorphic entities. */ if (SCG(sptr) == SC_DUMMY || POINTERG(sptr) || ALLOCG(sptr)) { CLASSP(sptr, 1); /* mark polymorphic variable */ if (PASSBYVALG(sptr)) { error(155, 3, gbl.lineno, "Polymorphic variable cannot have VALUE " "attribute -", SYMNAME(sptr)); } if (DTY(sem.stag_dtype) == TY_DERIVED) { int tag = DTY(sem.stag_dtype + 3); if (CFUNCG(tag)) { error(155, 3, gbl.lineno, "Polymorphic variable cannot be declared " "with a BIND(C) derived type - ", SYMNAME(sptr)); } if (SEQG(tag)) { error(155, 3, gbl.lineno, "Polymorphic variable cannot be declared " "with a SEQUENCE derived type - ", SYMNAME(sptr)); } } } else { error(155, 3, gbl.lineno, "Polymorphic variable must be a pointer, " "allocatable, or dummy object - ", SYMNAME(sptr)); } } if (DTY(sem.stag_dtype) == TY_DERIVED && sem.which_pass && !(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) && SCG(sptr) != SC_DUMMY && !FVALG(sptr) && (gbl.rutype != RU_PROG || CONSTRUCTSYMG(sptr))) { add_auto_finalize(sptr); } if (dtype == 0) dtype = DTYPEG(sptr); /* Assertion: * stype = stype we want to make symbol {ARRAY,STRUCT,or IDENT} * stype1 = symbol's current stype */ if (stype == ST_ARRAY) { if (IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to ARRAY */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore type decl */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; } else switch (stype1) { case ST_UNKNOWN: case ST_IDENT: case ST_VAR: case ST_STRUCT: break; case ST_ENTRY: if (DTY(DTYPEG(sptr)) != TY_ARRAY) break; error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); goto dcl_shared_end; case ST_ARRAY: { /* if symbol is already an array, check if the * dimension specifiers are identical. */ ADSC *ad1, *ad2; int ndim; ad1 = AD_DPTR(DTYPEG(sptr)); ad2 = AD_DPTR(dtype); ndim = AD_NUMDIM(ad1); if (ndim != AD_NUMDIM(ad2)) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); goto dcl_shared_end; } for (i = 0; i < ndim; i++) if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) || AD_UPBD(ad1, i) != AD_UPBD(ad2, i)) break; if (i < ndim) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); goto dcl_shared_end; } } error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL); break; default: error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); goto dcl_shared_end; } DTY(dtype + 1) = DTYPEG(sptr); } else if (stype == ST_STRUCT) { if (IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to STRUCT */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore type decl */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; } else if (stype1 == ST_ARRAY && DCLDG(sptr) == 0) { /* this case is OK */ } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } } else if ((scn.stmtyp == TK_COMMON || scn.stmtyp == TK_POINTER) && IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to IDENT in COMMON/POINTER */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore in COMMON */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; dtype = DTYPEG(sptr); } else if (IN_MODULE_SPEC && !sem.interface && IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to IDENT in module specification */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore in COMMON */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; dtype = DTYPEG(sptr); } /* * The symbol's stype and data type can only be changed if * it is new or if the type is changing from an identifier or * structure to an array. The latter can occur because of the * separation of type/record declarations from DIMENSION/COMMON * statements. If the symbol is a record, its stype can change * only if it's an identifier; note, that its dtype will be * set (and checked) by the semantic actions for record. */ if (stype1 == ST_UNKNOWN || (stype == ST_ARRAY && (stype1 == ST_IDENT || stype1 == ST_VAR || stype1 == ST_STRUCT))) { STYPEP(sptr, stype); DTYPEP(sptr, dtype); if (DTY(dtype) == TY_ARRAY) { int d; d = DTY(dtype + 1); if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } if (stype == ST_ARRAY) { if (POINTERG(sptr)) { if (!AD_DEFER(ad) || AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); if (SCG(sptr) != SC_DUMMY) ALLOCP(sptr, 1); if (!F90POINTERG(sptr)) { get_static_descriptor(sptr); get_all_descriptors(sptr); } } else if (AD_ASSUMSZ(ad)) { if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY && SCG(sptr) != SC_BASED) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); ASUMSZP(sptr, 1); SEQP(sptr, 1); } if (AD_ADJARR(ad)) { ADJARRP(sptr, 1); /* * mark the adjustable array if the declaration * occurs after an ENTRY statement. */ if (entry_seen) AFTENTP(sptr, 1); } else if (!POINTERG(sptr) && AD_DEFER(ad)) { if (SCG(sptr) == SC_CMBLK) error(43, 3, gbl.lineno, "deferred shape array", SYMNAME(sptr)); if (SCG(sptr) == SC_DUMMY) { mk_assumed_shape(sptr); ASSUMSHPP(sptr, 1); if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); } else { if (AD_ASSUMSHP(ad)) { /* this is an error if it isn't a dummy; the * declaration could occur before its entry, so * the check needs to be performed in semfin. */ ASSUMSHPP(sptr, 1); if (!XBIT(54, 2)) SDSCS1P(sptr, 1); } ALLOCP(sptr, 1); mk_defer_shape(sptr); } } } } else if (sem.gdtype != -1 && DTY(sem.gdtype) == TY_DERIVED) { if (stype1 == ST_ENTRY) { if (FVALG(sptr)) { /* should not reach this point */ #if DEBUG interr("semant1: trying to set data type of ST_ENTRY", sptr, 3); #endif sptr = FVALG(sptr); } else { error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr)); sptr = insert_sym(sptr); } } if (stype == ST_ARRAY && RESULTG(sptr)) { DTYPEP(sptr, dtype); if (POINTERG(sptr)) { if (!AD_DEFER(ad) || AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); } else if (AD_ASSUMSZ(ad)) { ASUMSZP(sptr, 1); SEQP(sptr, 1); } else if (AD_ADJARR(ad)) ADJARRP(sptr, 1); else if (AD_DEFER(ad)) { mk_assumed_shape(sptr); ASSUMSHPP(sptr, 1); if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); AD_ASSUMSHP(ad) = 1; } copy_type_to_entry(sptr); } } else if (stype == ST_STRUCT && stype1 == ST_IDENT) STYPEP(sptr, ST_STRUCT); else if (stype == ST_ARRAY) { if (stype1 == ST_ENTRY) { if (FVALG(sptr)) { /* should not reach this point */ #if DEBUG interr("semant1: trying to set data type of ST_ENTRY", sptr, 3); #endif sptr = FVALG(sptr); } else { error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr)); sptr = insert_sym(sptr); } } if (RESULTG(sptr)) { DTYPEP(sptr, dtype); if (POINTERG(sptr)) { if (!AD_DEFER(ad) || AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); } else if (AD_ASSUMSZ(ad)) { ASUMSZP(sptr, 1); SEQP(sptr, 1); } else if (AD_ADJARR(ad)) ADJARRP(sptr, 1); else if (AD_DEFER(ad)) { mk_assumed_shape(sptr); ASSUMSHPP(sptr, 1); if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); AD_ASSUMSHP(ad) = 1; } copy_type_to_entry(sptr); } } } dcl_shared_end: if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER && RESULTG(sptr)) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } break; /* ------------------------------------------------------------------ */ /* * ::= ( */ case DIM_BEG1: sem.in_dim = 1; sem.arrdim.ndim = 0; sem.arrdim.ndefer = 0; break; /* ------------------------------------------------------------------ */ /* * ::= */ case DIMENSION_LIST1: sem.in_dim = 0; dtype = mk_arrdsc(); /* semutil2.c */ SST_DTYPEP(LHS, dtype); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case DIM_LIST1: break; /* * ::= */ case DIM_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DIM_SPEC1: break; /* * ::= : * | */ case DIM_SPEC2: rhstop = 3; SST_IDP(RHS(3), S_STAR); goto dim_spec; /* * ::= * */ case DIM_SPEC3: rhstop = 1; SST_IDP(RHS(1), S_STAR); //AOCC begin // For Assumed size arrays save the lhs and rhs sst if (seen_parameter || is_parameter_context()) { *asz_sst = *top; *asz_rhssst = *RHS(1); asz_arrdsc = aux.arrdsc_avl; asz_status = 1; } //AOCC end dim_spec: if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); break; } /* check upper bound expression */ constarraysize = 1; arraysize = 0; constant_lvalue(RHS(rhstop)); if (SST_IDG(RHS(rhstop)) == S_CONST) { sem.bounds[sem.arrdim.ndim].uptype = S_CONST; if (flg.standard) { int uptyp; uptyp = SST_DTYPEG(RHS(rhstop)); if (!DT_ISINT(uptyp)) { error(170, 2, gbl.lineno, "array upper bound", "is not integer"); } } arraysize = sem.bounds[sem.arrdim.ndim].upb = chkcon_to_isz(RHS(rhstop), FALSE); sem.bounds[sem.arrdim.ndim].upast = mk_bnd_int(SST_ASTG(RHS(rhstop))); } else if (SST_IDG(RHS(rhstop)) == S_STAR) { constarraysize = 0; sem.bounds[sem.arrdim.ndim].uptype = S_STAR; sem.bounds[sem.arrdim.ndim].upb = 0; sem.bounds[sem.arrdim.ndim].upast = 0; } else { constarraysize = 0; sem.bounds[sem.arrdim.ndim].uptype = S_EXPR; sem.bounds[sem.arrdim.ndim].upb = chk_arr_extent(RHS(rhstop), "array upper bound"); ast = SST_ASTG(RHS(rhstop)); if (A_ALIASG(ast)) { ast = mk_bnd_int(A_ALIASG(ast)); sem.bounds[sem.arrdim.ndim].uptype = S_CONST; sem.bounds[sem.arrdim.ndim].upb = get_isz_cval(A_SPTRG(ast)); } else { /* When we have an AST with A_CONV, we want to skip the type conversion AST in order to process the real intrinsic-call AST.*/ if (A_TYPEG(ast) == A_CONV) { if (A_LOPG(ast) && A_TYPEG(A_LOPG(ast)) == A_INTR) ast = A_LOPG(ast); } if (*astb.atypes[A_TYPEG(ast)] == 'i' && DT_ISINT(A_DTYPEG(ast)) && ast_isparam(ast)) { INT conval; ACL *acl = construct_acl_from_ast(ast, A_DTYPEG(ast), 0); if (acl) { acl = eval_init_expr(acl); conval = cngcon(acl->conval, acl->dtype, A_DTYPEG(ast)); ast = mk_cval1(conval, (int)A_DTYPEG(ast)); SST_IDP(RHS(1), S_CONST); SST_LSYMP(RHS(1), 0); SST_ASTP(RHS(1), ast); SST_ACLP(RHS(1), 0); if (DT_ISWORD(A_DTYPEG(ast))) SST_SYMP(RHS(1), CONVAL2G(A_SPTRG(ast))); else SST_SYMP(RHS(1), A_SPTRG(ast)); } } } sem.bounds[sem.arrdim.ndim].upast = ast; } /* check lower bound expression */ if (rhstop == 1) { /* set default lower bound */ sem.bounds[sem.arrdim.ndim].lowtype = S_CONST; sem.bounds[sem.arrdim.ndim].lowb = 1; sem.bounds[sem.arrdim.ndim].lwast = 0; } else { constant_lvalue(RHS(1)); if (SST_IDG(RHS(1)) == S_CONST) { sem.bounds[sem.arrdim.ndim].lowtype = S_CONST; if (flg.standard) { int lowtyp; lowtyp = SST_DTYPEG(RHS(1)); if (!DT_ISINT(lowtyp)) { error(170, 2, gbl.lineno, "array lower bound", "is not integer"); } } sem.bounds[sem.arrdim.ndim].lowb = chkcon_to_isz(RHS(1), FALSE); if (constarraysize) arraysize -= (sem.bounds[sem.arrdim.ndim].lowb - 1); sem.bounds[sem.arrdim.ndim].lwast = mk_bnd_int(SST_ASTG(RHS(1))); } else { constarraysize = 0; sem.bounds[sem.arrdim.ndim].lowtype = S_EXPR; sem.bounds[sem.arrdim.ndim].lowb = chk_arr_extent(RHS(1), "array lower bound"); ast = SST_ASTG(RHS(1)); if (A_ALIASG(ast)) { ast = mk_bnd_int(A_ALIASG(ast)); sem.bounds[sem.arrdim.ndim].lowtype = S_CONST; sem.bounds[sem.arrdim.ndim].lowb = get_isz_cval(A_SPTRG(ast)); } sem.bounds[sem.arrdim.ndim].lwast = ast; } } if (constarraysize && arraysize <= 0) { error(435, 2, gbl.lineno, "", CNULL); if (arraysize < 0) { /* * fix the upper bound to be lowb-1 so that the extent * evaluates to 0 so that the relatively new error #219, * 'Array too large' produced by dtypeutl.c:size_of_sym() * is avoided. */ sem.bounds[sem.arrdim.ndim].upb = sem.bounds[sem.arrdim.ndim].lowb - 1; sem.bounds[sem.arrdim.ndim].upast = mk_isz_cval(sem.bounds[sem.arrdim.ndim].upb, astb.bnd.dtype); } } sem.arrdim.ndim++; break; /* * ::= : | */ case DIM_SPEC4: if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); break; } sem.bounds[sem.arrdim.ndim].lowtype = 0; sem.arrdim.ndim++; sem.arrdim.ndefer++; break; /* * ::= : | */ case DIM_SPEC5: if (sem.arrdim.ndim >= get_legal_maxdim()) { /* AOCC */ error(47, 3, gbl.lineno, CNULL, CNULL); break; } sem.bounds[sem.arrdim.ndim].lowtype = S_EXPR; (void)chk_scalartyp(RHS(1), astb.bnd.dtype, FALSE); sem.bounds[sem.arrdim.ndim].lwast = SST_ASTG(RHS(1)); sem.arrdim.ndim++; sem.arrdim.ndefer++; break; /* * ::= .. */ case DIM_SPEC6: sem.arrdim.ndim++; sem.arrdim.ndefer++; sem.arrdim.assumedrank = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= : | */ case EXPLICIT_SHAPE1: rhstop = 3; goto dim_spec; /* * ::= */ case EXPLICIT_SHAPE2: rhstop = 1; goto dim_spec; /* ------------------------------------------------------------------ */ /* * ::= | */ case IMPLICIT_TYPE1: break; /* * ::= NONE */ case IMPLICIT_TYPE2: if (sem.none_implicit & host_present) errwarn(55); if (seen_implicit || seen_parameter) error(70, 3, gbl.lineno, ": implicit none", CNULL); else symutl.none_implicit = sem.none_implicit |= host_present; newimplicitnone(); if (sem.interface == 0) { ast_implicit(0, 0, 0); if (IN_MODULE_SPEC) mod_implicit(0, 0, 0); } break; /* ------------------------------------------------------------------ */ /* * ::= , * ) | */ case IMPLICIT_LIST1: /* * ::= ) */ case IMPLICIT_LIST2: if (sem.none_implicit & host_present) errwarn(56); seen_implicit = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case RANGE_LIST1: rhstop = 3; goto range_list; /* * ::= */ case RANGE_LIST2: rhstop = 1; range_list: begin = SST_RNG1G(RHS(rhstop)); end = SST_RNG2G(RHS(rhstop)); if (begin > end) { errwarn(36); end = begin; } if (flg.standard && (begin == '$' || begin == '_' || end == 0)) errwarn(175); newimplicit(begin, end, sem.gdtype); if (sem.interface == 0) { ast_implicit(begin, end, sem.gdtype); if (IN_MODULE_SPEC) mod_implicit(begin, end, sem.gdtype); } /* adjust dtype of function and dummy arguments if necessary */ for (sptr = gbl.currsub; sptr && sptr != NOSYM; sptr = SYMLKG(sptr)) { if (gbl.rutype == RU_FUNC) { if (FVALG(sptr) && !DCLDG(FVALG(sptr))) { setimplicit(FVALG(sptr)); copy_type_to_entry(FVALG(sptr)); } } count = PARAMCTG(sptr); i = DPDSCG(sptr); while (count--) { sptr2 = *(aux.dpdsc_base + i + count); if (!DCLDG(sptr2)) setimplicit(sptr2); } } break; /* ------------------------------------------------------------------ */ /* * ::= - | */ case RANGE1: begin = SST_RNG1G(RHS(1)); end = SST_RNG1G(RHS(3)); if (begin == '$' || begin == '_' || end == '$' || end == '_') { /* cause an error and no action at the next production up */ end = 0; } SST_RNG2P(LHS, end); break; /* * ::= */ case RANGE2: SST_RNG2P(LHS, SST_RNG1G(RHS(1))); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case COMMON_LIST1: break; /* * ::= */ case COMMON_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case INIT_COM_DCL1: /* * ::= , | */ case INIT_COM_DCL2: rhsptr = 1; goto blank_common; /* * ::= */ case INIT_COM_DCL3: break; /* ------------------------------------------------------------------ */ /* * ::= '//' | */ case COM_DCL1: rhsptr = 2; goto blank_common; /* * ::= / / | */ case COM_DCL2: rhsptr = 3; goto blank_common; blank_common: if (ignore_common_decl()) { break; } sptr = getsymbol("_BLNK_"); sptr = refsym_inscope(sptr, OC_CMBLK); if (flg.xref) xrefput(sptr, 'd'); if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, ST_CMBLK); SCOPEP(sptr, stb.curr_scope); SAVEP(sptr, 1); BLANKCP(sptr, 1); } goto com_dcl; /* * ::= */ case COM_DCL3: if (ignore_common_decl()) { break; } rhsptr = 2; sptr = SST_SYMG(RHS(1)); com_dcl: if (CMEMFG(sptr) == 0) { /* first definition of this common block */ { SYMLKP(sptr, gbl.cmblks); /* link into list of common blocks */ gbl.cmblks = sptr; } i = 0; CMEMFP(sptr, NOSYM); CMEMLP(sptr, NOSYM); } else i = CMEMLG(sptr); /* last element of common block so far */ /* loop thru dcl id list linking together symbol table entries */ for (itemp = SST_BEGG(RHS(rhsptr)); itemp != ITEM_END; itemp = itemp->next) { sptr2 = itemp->t.sptr; stype = STYPEG(sptr2); if (IS_INTRINSIC(stype)) { /* * an intrinsic which can be changed due to its appearance in a * COMMON statement has already been processed in dcl_shared. * Getting here implies that the intrinsic is frozen, and * therefore, it will be ignored in the COMMON stmt. */ error(40, 3, gbl.lineno, SYMNAME(sptr2), CNULL); break; } else if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_VAR && stype != ST_ARRAY && stype != ST_STRUCT && (!POINTERG(sptr2))) { error(40, 3, gbl.lineno, SYMNAME(sptr2), CNULL); reinit_sym(sptr2); STYPEP(sptr2, ST_VAR); DTYPEP(sptr2, DT_INT); SCP(sptr2, SC_LOCAL); } if (SCG(sptr2) == SC_CMBLK || SCG(sptr2) == SC_DUMMY) error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr2)); else if (stype == ST_ARRAY && (ASUMSZG(sptr2) || ADJARRG(sptr2))) error(50, 3, gbl.lineno, SYMNAME(sptr2), CNULL); else if (SAVEG(sptr2)) { error(39, 2, gbl.lineno, SYMNAME(sptr2), " and a COMMON statement"); SAVEP(sptr2, 0); } else { SCP(sptr2, SC_CMBLK); CMBLKP(sptr2, sptr); if (i == 0) CMEMFP(sptr, sptr2); else SYMLKP(i, sptr2); SYMLKP(sptr2, NOSYM); } i = sptr2; } CMEMLP(sptr, i); /* point to last element of common block */ break; /* ------------------------------------------------------------------ */ /* * ::= / / */ case COMMON1: if (ignore_common_decl()) { SST_SYMP(LHS, 0); break; } sptr = refsym_inscope((int)SST_SYMG(RHS(2)), OC_CMBLK); if (STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, ST_CMBLK); SCOPEP(sptr, stb.curr_scope); } SST_SYMP(LHS, sptr); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case SAVE_LIST1: if (flg.xref) xrefput((int)SST_SYMG(RHS(3)), 'd'); break; /* * ::= */ case SAVE_LIST2: if (flg.xref) xrefput((int)SST_SYMG(RHS(1)), 'd'); break; /* ------------------------------------------------------------------ */ /* * ::= */ case SAVE_ID1: sptr = SST_SYMG(RHS(1)); if (sem.block_scope) { error(39, 3, gbl.lineno, SYMNAME(sptr), CNULL); break; } SAVEP(sptr, 1); break; /* * ::= */ case SAVE_ID2: sptr = block_local_sym(ref_ident_inscope((int)SST_SYMG(RHS(1)))); stype = STYPEG(sptr); /* must be a variable or an array; it cannot be a dummy * argument or common block member. */ if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) { if (ASUMSZG(sptr)) error(155, 3, gbl.lineno, "An assumed-size array cannot have the SAVE attribute -", SYMNAME(sptr)); else if (SCG(sptr) == SC_DUMMY) error(155, 3, gbl.lineno, "An adjustable array cannot have the SAVE attribute -", SYMNAME(sptr)); else error(155, 3, gbl.lineno, "An automatic array cannot have the SAVE attribute -", SYMNAME(sptr)); } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL || SCG(sptr) == SC_BASED) && (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT || stype == ST_IDENT)) { sem.savloc = TRUE; SAVEP(sptr, 1); /* SCP(sptr, SC_LOCAL); * SAVE is now an attribute and may appear allocatable; the * appearance of a variable in a SAVE statement is no longer * sufficient to define the variable's storage class. */ } else error(39, 2, gbl.lineno, SYMNAME(sptr), CNULL); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case IDEQC_LIST1: rhstop = 5; goto common_ideqc; /* * ::= */ case IDEQC_LIST2: rhstop = 3; common_ideqc: SST_IDP(RHS(rhstop - 2), S_IDENT); sptr = SST_SYMG(RHS(rhstop - 2)); fixup_param_vars(RHS(rhstop - 2), RHS(rhstop)); if (DTY(DTYPEG(sptr)) == TY_ARRAY || DTY(DTYPEG(sptr)) == TY_DERIVED) { sptr1 = CONVAL1G(sptr); construct_acl_for_sst(RHS(rhstop), DTYPEG(sptr1)); if (!SST_ACLG(RHS(rhstop))) { goto end_ideqc; } CONVAL2P(sptr, put_getitem_p(save_acl(SST_ACLG(RHS(rhstop))))); ast = mk_id(sptr1); SST_ASTP(RHS(rhstop - 2), ast); SST_DTYPEP(RHS(rhstop - 2), DTYPEG(sptr1)); SST_SHAPEP(RHS(rhstop - 2), A_SHAPEG(ast)); ivl = dinit_varref(RHS(rhstop - 2)); dinit(ivl, SST_ACLG(RHS(rhstop))); } end_ideqc: if (flg.xref) xrefput(sptr, 'i'); sem.dinit_data = FALSE; break; /* ------------------------------------------------------------------ */ /* * ::= = */ case INIT_BEG1: /* AOCC begin */ case INIT_BEG2: /* AOCC end */ sem.dinit_data = TRUE; sem.equal_initializer = true; break; /* ------------------------------------------------------------------ */ /* * ::= , = | */ case VXEQC_LIST1: rhstop = 5; goto common_vxeqc; /* * ::= = */ case VXEQC_LIST2: rhstop = 3; common_vxeqc: sptr = declsym((int)SST_SYMG(RHS(rhstop - 2)), ST_PARAM, TRUE); dtype = SST_DTYPEG(RHS(rhstop)); if (DCLDG(sptr) && dtype != DTYPEG(sptr)) error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); if (SCG(sptr) != SC_NONE) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } constant_lvalue(RHS(rhstop)); if (SST_IDG(RHS(rhstop)) == S_CONST) conval = SST_CVALG(RHS(rhstop)); else { errsev(87); dtype = DT_INT; conval = 1; } TYPDP(sptr, DCLDG(sptr)); /* appeared in a type statement */ CONVAL2P(sptr, SST_ASTG(RHS(rhstop))); /* ast of */ DTYPEP(sptr, dtype); DCLDP(sptr, TRUE); CONVAL1P(sptr, conval); VAXP(sptr, 1); /* vax-style parameter */ if (sem.interface == 0) add_param(sptr); /* create an ast for the parameter; set the alias field of the ast * so that we don't have to set the alias field whenever the parameter * is referenced. */ ast = mk_id(sptr); alias = mk_cval1(CONVAL1G(sptr), (int)DTYPEG(sptr)); A_ALIASP(ast, alias); if (flg.xref) xrefput(sptr, 'i'); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ENUMS1: break; /* * ::= */ case ENUMS2: break; /* ------------------------------------------------------------------ */ /* * ::= = | */ case ENUM1: rhstop = 3; constant_lvalue(RHS(rhstop)); conval = chkcon(RHS(rhstop), DT_INT4, TRUE); goto common_enum; /* * ::= */ case ENUM2: conval = next_enum; common_enum: dtype = DT_INT4; ast = mk_cval(conval, dtype); sptr = declsym(block_local_sym((int)SST_SYMG(RHS(1))), ST_PARAM, TRUE); if (DCLDG(sptr) || SCG(sptr) != SC_NONE) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } TYPDP(sptr, DCLDG(sptr)); /* appeared in a type statement */ CONVAL2P(sptr, ast); /* ast of */ DTYPEP(sptr, dtype); DCLDP(sptr, TRUE); CONVAL1P(sptr, conval); ast = mk_id(sptr); alias = mk_cval1(CONVAL1G(sptr), (int)DTYPEG(sptr)); A_ALIASP(ast, alias); next_enum = conval + 1; if (flg.xref) xrefput(sptr, 'i'); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case EQUIV_GROUPS1: break; /* * ::= */ case EQUIV_GROUPS2: break; /* ------------------------------------------------------------------ */ /* * ::= ( ) */ case EQUIV_GROUP1: /* * equivalence groups are linked together using the same field * used to link equivalence items within a single group. * A single equiv group is defined by the list beginning with an * EQVV item with a non-zero line number and ending with the item * preceding the next EQVV item with a non-zero line number (or * ending with the last item in the list). The remaining * members in the group have line number fields which are zero. */ if (sem.interface) /* HACK - throw away if in an interface block*/ break; EQV(SST_NMLENDG(RHS(2))).next = sem.eqvlist; sem.eqvlist = SST_NMLBEGG(RHS(2)); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case EQUIV_LIST1: rhstop = 3; goto common_equiv; /* * ::= */ case EQUIV_LIST2: rhstop = 1; common_equiv: if (sem.interface) /* HACK - throw away if in an interface block*/ break; evp = sem.eqv_avail; ++sem.eqv_avail; NEED(sem.eqv_avail, sem.eqv_base, EQVV, sem.eqv_size, sem.eqv_size + 20); EQV(evp).sptr = SST_SYMG(RHS(rhstop)); EQV(evp).subscripts = SST_SUBSCRIPTG(RHS(rhstop)); EQV(evp).substring = SST_SUBSTRINGG(RHS(rhstop)); EQV(evp).byte_offset = SST_OFFSETG(RHS(rhstop)); EQV(evp).next = 0; /* SEQP(evp->sptr, 1); -- SEQ flag set in semfin.c */ if (flg.xref) xrefput(EQV(evp).sptr, 'e'); if (rhstop == 1) { EQV(evp).lineno = gbl.lineno; EQV(evp).is_first = 1; SST_NMLBEGP(LHS, evp); } else { EQV(evp).lineno = 0; EQV(evp).is_first = 0; EQV(SST_NMLENDG(RHS(1))).next = evp; } SST_NMLENDP(LHS, evp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case EQUIV_VAR1: sptr = ref_ident_inscope((int)SST_SYMG(RHS(1))); SST_SYMP(LHS, sptr); SST_SUBSCRIPTP(LHS, 0); /* No subscripting */ SST_OFFSETP(LHS, 0); /* No substringing */ SST_SUBSTRINGP(LHS, 0); /* No substringing - ast */ break; /* * ::= ( ) | */ case EQUIV_VAR2: /* Validate that the subscripts are constant expressions, and build * an item list of them in long term (until end of program) storage. */ sptr = SST_SYMG(RHS(1)); itemp = SST_BEGG(RHS(3)); if (itemp->next == ITEM_END && SST_IDG(itemp->t.stkp) == S_TRIPLE) { if (SST_IDG(SST_E3G(itemp->t.stkp)) == S_NULL) { /* This is a possible form of a substring. Vector triplet * notation is illegal in any form. */ if (SST_OFFSETG(RHS(1))) error(144, 3, gbl.lineno, "Ugly equivalence ", "1"); if (SST_IDG(SST_E1G(itemp->t.stkp)) == S_NULL) { i = 1; SST_SUBSTRINGP(LHS, 0); } else { i = chkcon(SST_E1G(itemp->t.stkp), DT_INT4, TRUE); if (i <= 0) { error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL); i = 0; } SST_SUBSTRINGP(LHS, SST_ASTG(SST_E1G(itemp->t.stkp))); } SST_OFFSETP(LHS, i); break; } } if (SST_SUBSCRIPTG(RHS(1)) != 0) { error(144, 3, gbl.lineno, "Ugly equivalence 3", CNULL); break; } ss = 0; numss = 0; for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) { if (ss == 0) { numss = 1; ss = sem.eqv_ss_avail; sem.eqv_ss_avail += 2; NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size, sem.eqv_ss_size + 50); SST_SUBSCRIPTP(LHS, ss); /* Save begin of subscript list */ EQV_NUMSS(ss) = numss; } else { ++sem.eqv_ss_avail; NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size, sem.eqv_ss_size + 50); ++numss; EQV_NUMSS(ss) = numss; } if (SST_IDG(itemp->t.stkp) == S_KEYWORD) { /* = is illegal just use part */ errsev(79); SST_SUBSCRIPTP(LHS, 0); } else if (SST_IDG(itemp->t.stkp) == S_TRIPLE) { /* Legally this can only mean character substringing. Vector * triplet notation is not allowable in equivalencing. */ error(155, 3, gbl.lineno, "Subscript triplet not allowed in EQUIVALENCE -", SYMNAME(sptr)); SST_SUBSCRIPTP(LHS, 0); } else { (void)chkcon_to_isz(itemp->t.stkp, TRUE); EQV_SS(ss, numss - 1) = SST_ASTG(itemp->t.stkp); } } break; /* * ::= . */ case EQUIV_VAR3: SST_IDP(LHS, S_IDENT); SST_SYMP(LHS, 0); SST_SUBSCRIPTP(LHS, 0); /* No subscripting */ SST_OFFSETP(LHS, 0); /* No substringing */ SST_SUBSTRINGP(LHS, 0); /* No substringing - ast */ error(155, 3, gbl.lineno, "Member cannot be equivalenced -", SYMNAME(SST_SYMG(RHS(3)))); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case NAMELIST_GROUPS1: break; /* * ::= */ case NAMELIST_GROUPS2: break; /* ------------------------------------------------------------------ */ /* * ::= / / */ case NAMELIST_GROUP1: sptr = declref((int)SST_SYMG(RHS(2)), ST_NML, 'd'); if (DCLDG(sptr)) NML_NEXT(CMEMLG(sptr)) = SST_NMLBEGG(RHS(4)); else { SYMLKP(sptr, sem.nml); sem.nml = sptr; CMEMFP(sptr, SST_NMLBEGG(RHS(4))); DCLDP(sptr, TRUE); /* create the array representing the namelist group */ (void)get_nml_array(sptr); } CMEMLP(sptr, SST_NMLENDG(RHS(4))); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case NAMELIST_LIST1: rhstop = 2; goto nml_list; /* * ::= */ case NAMELIST_LIST2: rhstop = 1; nml_list: i = aux.nml_avl++; NEED(aux.nml_avl, aux.nml_base, NMLDSC, aux.nml_size, aux.nml_size + 100); NML_SPTR(i) = SST_SYMG(RHS(rhstop)); NML_NEXT(i) = 0; NML_LINENO(i) = gbl.lineno; if (rhstop == 1) /* first item in the list */ SST_NMLBEGP(LHS, i); else /* add item to the end of the list */ NML_NEXT(SST_NMLENDG(RHS(1))) = i; SST_NMLENDP(LHS, i); /* item is now the end of the list */ break; /* ------------------------------------------------------------------ */ /* * ::= */ case NAMELIST_VAR1: sptr = ref_ident((int)SST_SYMG(RHS(1))); SST_SYMP(LHS, sptr); /* equivalence processing is done before the namelist processing; * this order is necessary to accomodate adding members to a * common block by equivalencing. For SC_LOCALs the namelist * processing switches the storage class to SC_STATIC; therefore, * the equivalence processor needs to know that a variable appeared * as a namelist item. */ NMLP(sptr, 1); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case STRUCT_BEGIN11: sem.stag_dtype = get_type(6, TY_STRUCT, NOSYM); DTY(sem.stag_dtype + 3) = 0; /* no tag */ if (sem.stsk_depth == 0) error(135, 2, gbl.lineno, CNULL, CNULL); break; /* * ::= / / */ case STRUCT_BEGIN12: sptr = declsym((int)SST_SYMG(RHS(2)), ST_STAG, TRUE); sem.stag_dtype = get_type(6, TY_STRUCT, NOSYM); DTYPEP(sptr, sem.stag_dtype); /* give tag its dtype */ DTY(sem.stag_dtype + 3) = sptr; /* give dtype its tag */ DTY(sem.stag_dtype + 5) = 0; /* ict pointer */ NESTP(sptr, INSIDE_STRUCT); /* nested structure */ /* NOTE: we don't set DCLD here; see ENDSTRUCTURE */ break; /* ------------------------------------------------------------------ */ /* * ::= | */ case STRUCT_BEGIN21: SST_RNG2P(LHS, NOSYM); break; /* * ::= */ case STRUCT_BEGIN22: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case FIELD_NAMELIST1: SYMLKP(SST_SYMG(RHS(1)), SST_SYMG(RHS(3))); SST_SYMP(LHS, SST_SYMG(RHS(3))); break; /* * ::= */ case FIELD_NAMELIST2: /* Save ptr to 1st field name in field namelist */ SST_RNG2P(LHS, SST_SYMG(RHS(1))); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case FIELD_NAME1: dtype = sem.stag_dtype; goto field_name; /* * ::= ) */ case FIELD_NAME2: dtype = SST_DTYPEG(RHS(3)); ad = AD_DPTR(dtype); if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) error(50, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL); field_name: stype = ST_MEMBER; sptr = SST_SYMG(RHS(1)); if (STYPEG(sptr) != ST_UNKNOWN) SST_SYMP(LHS, (sptr = insert_sym(sptr))); SYMLKP(sptr, NOSYM); if (DTY(dtype) == TY_ARRAY) DTY(dtype + 1) = sem.stag_dtype; STYPEP(sptr, stype); DTYPEP(sptr, dtype); FNMLP(sptr, 1); /* declaration due to field name */ break; /* ------------------------------------------------------------------ */ /* * ::= | */ case RECORD_LIST1: break; /* * ::= */ case RECORD_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= / / */ case RECORD1: break; /* ------------------------------------------------------------------ */ /* * ::= */ case STRUCT_NAME1: /* Make sure sym ptr on stack is to a structure tag */ SST_SYMP(LHS, (sptr = declref((int)SST_SYMG(RHS(1)), ST_STAG, 'r'))); if (!DCLDG(sptr)) { error(139, 3, gbl.lineno, SYMNAME(sptr), CNULL); dtype = get_type(6, TY_STRUCT, NOSYM); DTY(dtype + 2) = 1; /* size */ DTY(dtype + 3) = sptr; /* tag */ DTY(dtype + 5) = 0; /* ict pointer */ DTYPEP(sptr, dtype); DCLDP(sptr, TRUE); } sem.stag_dtype = DTYPEG(sptr); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case RECORD_NAMELIST1: sptr = SST_SYMG(RHS(2)); goto record_dcl; /* * ::= */ case RECORD_NAMELIST2: sptr = SST_SYMG(RHS(1)); record_dcl: dtype = sem.stag_dtype; inited = FALSE; ict1 = (ACL *)get_getitem_p(DTY(dtype + 5)); if (ict1) { /* Need to build an initializer constant tree */ ict = GET_ACL(15); *ict = *ict1; ict->sptr = sptr; if (DTY(DTYPEG(sptr)) == TY_ARRAY) ict->repeatc = AD_NUMELM(AD_PTR(sptr)); else ict->repeatc = astb.i1; if (INSIDE_STRUCT) { if (stsk->ict_end) stsk->ict_end->next = ict; else stsk->ict_beg = ict; stsk->ict_end = ict; } else if (SCG(sptr) != SC_DUMMY) { /* * NOTE: it's legal to use a STRUCTURE which contains * dinits to declare a dummy argument */ dinit((VAR *)NULL, ict); } } goto common_typespecs; /* ------------------------------------------------------------------ */ /* * ::= | */ case RECORD_DCL1: stype = ST_STRUCT; dtype = sem.stag_dtype; goto dcl_shared; /* * ::= ) */ case RECORD_DCL2: stype = ST_ARRAY; dtype = SST_DTYPEG(RHS(3)); ad = AD_DPTR(dtype); goto dcl_shared; /* ------------------------------------------------------------------ */ /* * ::= , | */ case VOL_LIST1: break; /* * ::= */ case VOL_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case VOL_ID1: sptr = SST_SYMG(RHS(1)); VOLP(sptr, 1); break; /* * ::= */ case VOL_ID2: sptr = ref_ident_inscope((int)SST_SYMG(RHS(1))); if (sem.block_scope && sptr < sem.scope_stack[sem.block_scope].symavl && !VOLG(sptr)) error(1219, ERR_Severe, gbl.lineno, "VOLATILE statement in a BLOCK construct", CNULL); VOLP(sptr, true); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DINIT_LIST1: break; /* * ::= */ case DINIT_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= / / */ case DINIT1: /* call dinit to write data initialization records */ if (!sem.dinit_error) { SST_CLBEGP(RHS(3), rewrite_acl(SST_CLBEGG(RHS(3)), SST_CLBEGG(RHS(3))->dtype, 0)); dinit(SST_VLBEGG(RHS(1)), SST_CLBEGG(RHS(3))); } sem.dinit_error = FALSE; sem.dinit_data = FALSE; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case DINIT_VAR_LIST1: /* append entry to end of dinit var list */ ((SST_VLENDG(RHS(1))))->next = SST_VLBEGG(RHS(3)); SST_VLENDP(LHS, SST_VLENDG(RHS(3))); break; /* * ::= */ case DINIT_VAR_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DINIT_VAR1: (void)mklvalue(RHS(1), 2); /* ILM pointer of var ref */ dtype = SST_DTYPEG(RHS(1)); { /* build an element for the dinit var list */ ivl = dinit_varref(RHS(1)); if (ivl == NULL) { /* an array section was initialized -- dinit_varref() * transforms this into an implied do or a nested * implied do. */ break; } } sem.dinit_data = TRUE; if (ivl->u.varref.id == S_LVALUE && SCG(SST_LSYMG(RHS(1))) == SC_BASED) { error(116, 3, gbl.lineno, SYMNAME(SST_LSYMG(RHS(1))), "(DATA)"); sem.dinit_error = TRUE; } SST_VLBEGP(LHS, SST_VLENDP(LHS, ivl)); break; /* * ::= ( , = , * ) */ case DINIT_VAR2: (void)chk_scalartyp(RHS((9)), DT_INT, TRUE); /* build a doend element for the dinit var list */ ivl = (VAR *)getitem(15, sizeof(VAR)); SST_VLENDP(LHS, ivl); SST_VLENDG(RHS(2))->next = ivl; ivl->id = Doend; ivl->next = NULL; /* Create the dostart element, link it to the doend element, and * link all in the order dostart, , then doend */ ivl->u.doend.dostart = (VAR *)getitem(15, sizeof(VAR)); ivl = ivl->u.doend.dostart; ivl->id = Dostart; sptr = refsym((int)SST_SYMG(RHS(4)), OC_OTHER); if (!DCLDG(sptr)) IGNOREP(sptr, TRUE); SST_SYMP(RHS(4), sptr); (void)chktyp(RHS(4), DT_INT, TRUE); ivl->u.dostart.indvar = SST_ASTG(RHS(4)); (void)chk_scalartyp(RHS(6), DT_INT, TRUE); ivl->u.dostart.lowbd = SST_ASTG(RHS(6)); (void)chk_scalartyp(RHS(8), DT_INT, TRUE); ivl->u.dostart.upbd = SST_ASTG(RHS(8)); ivl->u.dostart.step = SST_ASTG(RHS(9)); ivl->next = SST_VLBEGG(RHS(2)); SST_VLBEGP(LHS, ivl); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case E31: SST_IDP(LHS, S_CONST); SST_CVALP(LHS, 1); SST_DTYPEP(LHS, DT_INT); SST_ASTP(LHS, 0); break; /* * ::= , */ case E32: *LHS = *RHS(2); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case DINIT_CONST_LIST1: if (SST_CLBEGG(RHS(3)) != NULL) { SST_CLENDG(RHS(1))->next = SST_CLBEGG(RHS(3)); SST_CLENDP(LHS, SST_CLENDG(RHS(3))); } break; /* * ::= */ case DINIT_CONST_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DATA_ITEM1: conval = 1; /* default repeat count */ ast = 0; goto common_data_item; /* * ::= * */ case DATA_ITEM2: ast = SST_ASTG(RHS(1)); conval = SST_CVALG(RHS(1)); *RHS(1) = *RHS(3); common_data_item: /* * Check for too many constant initializers here! Why here and not in * dinit? Because for structures and type decl stmts we want the error * flagged on the structure stmt not the record stmt which may occur * many times and much later. */ if (!sem.dinit_data) { /* Don't do this if in DATA stmt */ if (sem.dinit_count < conval) { if (sem.dinit_count >= 0) errsev(67); if (sem.dinit_count <= 0) { /* Error already handled */ SST_CLBEGP(LHS, SST_CLENDP(LHS, NULL)); break; } conval = sem.dinit_count; /* Put out as many as possible */ sem.dinit_count = -1; /* Prevent further error msgs */ } sem.dinit_count -= conval; } if (SST_IDG(RHS(1)) == S_SCONST) { ict = dinit_struct_vals(SST_ACLG(RHS(1)), SST_DTYPEG(RHS(1)), NOSYM); if (!ict) { break; } ict->repeatc = ast; SST_CLBEGP(LHS, SST_CLENDP(LHS, ict)); break; } /* allocate and init an Initializer Constant Tree entry */ ict = GET_ACL(15); ict->id = AC_AST; ict->next = NULL; ict->subc = NULL; ict->u1.ast = SST_ASTG(RHS(1)); ict->repeatc = ast; ict->sptr = 0; ict->dtype = SST_DTYPEG(RHS(1)); SST_CLBEGP(LHS, SST_CLENDP(LHS, ict)); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DATA_RPT1: conval = SST_CVALG(RHS(1)); ast = mk_cval(SST_CVALG(RHS(1)), DT_INT4); goto common_rpt; /* * ::= | */ case DATA_RPT2: /* token value of is an ST_CONST entry */ conval = get_int_cval(SST_CVALG(RHS(1))); ast = mk_cnst(SST_CVALG(RHS(1))); goto common_rpt; /* * ::= */ case DATA_RPT3: dtype = SST_DTYPEG(RHS(1)); if (dtype == DT_INT8 || dtype == DT_LOG8) conval = get_int_cval(SST_CVALG(RHS(1))); else conval = SST_CVALG(RHS(1)); ast = SST_ASTG(RHS(1)); common_rpt: if (conval < 0) { errsev(65); conval = 0; } SST_CVALP(LHS, conval); SST_ASTP(LHS, ast); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DATA_CONSTANT1: SST_IDP(LHS, S_CONST); break; /* * ::= | */ case DATA_CONSTANT2: SST_IDP(RHS(2), S_CONST); goto addop_data_constant; /* * ::= | */ case DATA_CONSTANT3: break; /* * ::= | */ case DATA_CONSTANT4: addop_data_constant: opc = SST_OPTYPEG(RHS(1)); *LHS = *RHS(2); if (opc == OP_SUB) { SST_CVALP(LHS, negate_const(SST_CVALG(RHS(2)), (int)SST_DTYPEG(RHS(2)))); ast = mk_unop(OP_SUB, SST_ASTG(RHS(2)), SST_DTYPEG(LHS)); SST_ASTP(LHS, ast); mk_alias(ast, mk_cval1(SST_CVALG(LHS), (int)SST_DTYPEG(LHS))); } break; /* * ::= ( ) | */ case DATA_CONSTANT5: sptr = SST_SYMG(RHS(1)); dtype = SST_DTYPEG(RHS(1)); if (sem.in_struct_constr) { /* create head AC_SCONST for element list */ aclp = GET_ACL(15); aclp->id = AC_SCONST; aclp->next = NULL; aclp->subc = (ACL *)SST_BEGG(RHS(3)); aclp->dtype = dtype = DTYPEG(sem.in_struct_constr); SST_IDP(LHS, S_SCONST); SST_DTYPEP(LHS, dtype); SST_ACLP(LHS, aclp); if (is_empty_typedef(dtype)) { error(155, 3, gbl.lineno, "Structure constructor specified" " for empty derived type", SYMNAME(sptr)); } else chk_struct_constructor(aclp); SST_SYMP(LHS, sem.in_struct_constr); /* use tag as SYM */ sem.in_struct_constr = SST_TMPG(LHS); /*restore old value */ break; } sem.in_struct_constr = SST_TMPG(LHS); /* restore old value */ if (STYPEG(sptr) == ST_PARAM && DTY(dtype) == TY_NCHAR) { SST *sp; itemp = SST_BEGG(RHS(3)); sp = itemp->t.stkp; if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL || itemp->next != ITEM_END) { error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL); SST_DTYPEP(LHS, DT_NCHAR); val[0] = getstring(" ", 1); val[1] = 0; SST_CVALP(LHS, getcon(val, DT_NCHAR)); SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS))); SST_SHAPEP(LHS, 0); break; } SST_IDP(LHS, S_CONST); SST_CVALP(LHS, CONVAL1G(sptr)); /* get constant sptr */ SST_DTYPEP(LHS, dtype); SST_ASTP(LHS, CONVAL2G(sptr)); /* constant's ast */ SST_SHAPEP(LHS, 0); SST_ERRSYMP(LHS, sptr); /* save for error tracing */ ch_substring(LHS, SST_E1G(sp), SST_E2G(sp)); goto check_data_substring; } if (STYPEG(sptr) == ST_PARAM && DTY(dtype) == TY_CHAR) { SST *sp; itemp = SST_BEGG(RHS(3)); sp = itemp->t.stkp; if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL || itemp->next != ITEM_END) { error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL); SST_DTYPEP(LHS, DT_CHAR); SST_CVALP(LHS, getstring(" ", 1)); SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS))); SST_SHAPEP(LHS, 0); break; } SST_IDP(LHS, S_CONST); SST_CVALP(LHS, CONVAL1G(sptr)); /* get constant sptr */ SST_DTYPEP(LHS, dtype); SST_ASTP(LHS, CONVAL2G(sptr)); /* constant's ast */ SST_SHAPEP(LHS, 0); SST_ERRSYMP(LHS, sptr); /* save for error tracing */ ch_substring(LHS, SST_E1G(sp), SST_E2G(sp)); goto check_data_substring; } else { errsev(87); sem.dinit_error = TRUE; } break; /* * ::= ( ) | */ case DATA_CONSTANT6: if (STYPEG(SST_SYMG(RHS(1))) != ST_PD || PDNUMG(SST_SYMG(RHS(1))) != PD_null) { dtype = SST_DTYPEG(RHS(1)); if (sem.in_struct_constr && is_empty_typedef(dtype)) { /* Ignore empty struct constructor for an * empty typedef */ sem.dinit_error = TRUE; break; } errsev(87); sem.dinit_error = TRUE; break; } SST_IDP(RHS(1), S_IDENT); (void)mkvarref(RHS(1), ITEM_END); break; /* * ::= */ case DATA_CONSTANT7: dtype = SST_DTYPEG(RHS(1)); check_data_substring: constant_lvalue(RHS(1)); if (SST_IDG(RHS(1)) != S_CONST) { errsev(87); sem.dinit_error = TRUE; if (DTY(dtype) == TY_NCHAR) { SST_DTYPEP(LHS, DT_NCHAR); val[0] = getstring(" ", 1); val[1] = 0; SST_CVALP(LHS, getcon(val, DT_NCHAR)); SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS))); SST_SHAPEP(LHS, 0); break; } SST_DTYPEP(LHS, DT_CHAR); SST_CVALP(LHS, getstring(" ", 1)); SST_ASTP(LHS, mk_cnst(SST_CVALG(LHS))); SST_SHAPEP(LHS, 0); } break; /* * ::= */ case IDENT_SSA1: sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER); dtype = DTYPEG(sptr); SST_SYMP(LHS, sptr); SST_DTYPEP(LHS, dtype); SST_TMPP(LHS, sem.in_struct_constr); /* save old value */ /* set a flag for ssa list processing */ if (STYPEG(sptr) == ST_TYPEDEF && DTY(dtype) == TY_DERIVED) { sem.in_struct_constr = sptr; } else sem.in_struct_constr = 0; break; /* * ::= */ case IDENT_CONSTANT1: sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER); SST_IDP(LHS, S_CONST); if (STYPEG(sptr) == ST_PARAM) { /* resolve constant */ SST_DTYPEP(LHS, DTYPEG(sptr)); SST_CVALP(LHS, CONVAL1G(sptr)); ast = mk_id(sptr); if (!XBIT(49, 0x10)) /* preserve PARAMETER? */ ast = A_ALIASG(ast); } else if (flg.standard) goto ident_constant_error; else { np = SYMNAME(sptr); if (*np == 't') { if (DTY(stb.user.dt_log) == TY_LOG8) { if (gbl.ftn_true == -1) val[0] = val[1] = -1; else { val[0] = 0; val[1] = 1; } SST_CVALP(LHS, getcon(val, DT_LOG8)); ast = mk_cval1(SST_CVALG(LHS), DT_LOG); } else { SST_CVALP(LHS, SCFTN_TRUE); ast = mk_cval(SCFTN_TRUE, DT_LOG); } SST_DTYPEP(LHS, DT_LOG); } else if (*np == 'f') { if (DTY(stb.user.dt_log) == TY_LOG8) { val[0] = val[1] = 0; SST_CVALP(LHS, getcon(val, DT_LOG8)); ast = mk_cval1(SST_CVALG(LHS), DT_LOG); } else { SST_CVALP(LHS, SCFTN_FALSE); ast = mk_cval(SCFTN_FALSE, DT_LOG); } SST_DTYPEP(LHS, DT_LOG); } else goto ident_constant_error; } SST_ASTP(LHS, ast); break; ident_constant_error: errsev(87); SST_CVALP(LHS, stb.i0); SST_DTYPEP(LHS, DT_INT4); ast = mk_id(sptr); sem.dinit_error = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case PTR_LIST1: break; /* * ::= */ case PTR_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= ( , ) | */ case PTR_ASSOC1: sptr = declsym((int)SST_SYMG(RHS(2)), ST_VAR, FALSE); if (flg.standard) error(171, 2, gbl.lineno, "- Cray POINTER statement", CNULL); if (XBIT(124, 0x10)) { /* -i8 */ if (DCLDG(sptr) && DTYPEG(sptr) != DT_INT8) error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL); DTYPEP(sptr, DT_INT8); } else { if (DCLDG(sptr) && DTYPEG(sptr) != DT_PTR) error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL); DTYPEP(sptr, DT_PTR); } DCLDP(sptr, TRUE); PTRVP(sptr, 1); sptr1 = SST_SYMG(RHS(4)); if (VOLG(sptr1) || SCG(sptr1) != SC_NONE) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr1)); break; } SCP(sptr1, SC_BASED); MIDNUMP(sptr1, sptr); if (SAVEG(sptr1)) error(39, 2, gbl.lineno, SYMNAME(sptr1), CNULL); if (STYPEG(sptr1) == ST_ARRAY) { int dtype; ADSC *ad; if (ADJARRG(sptr1) || RUNTIMEG(sptr1)) { if (entry_seen) AFTENTP(sptr1, 1); } } while (TRUE) { if (SCG(sptr) == SC_BASED) { if (sptr == sptr1) { error(155, 3, gbl.lineno, "Recursive POINTER declaration of", SYMNAME(sptr1)); MIDNUMP(sptr1, 0); SCP(sptr1, SC_NONE); break; } sptr = MIDNUMG(sptr); } else break; } break; /* * ::= */ case PTR_ASSOC2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ALLOC_ID_LIST1: break; /* * ::= */ case ALLOC_ID_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ALLOC_ID1: sptr = SST_SYMG(RHS(1)); sptr = create_var(sptr); SST_SYMP(LHS, sptr); if (STYPEG(sptr) == ST_UNKNOWN) STYPEP(sptr, ST_IDENT); stype1 = STYPEG(sptr); if (IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to ARRAY */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore type decl */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; } else if (stype1 == ST_ENTRY) { if (DTY(DTYPEG(sptr)) == TY_ARRAY) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR && stype1 != ST_ARRAY) { /* Add special handling for procedure pointers * * The only two ways we can get here is either through pointer or through * allocatable declaration. Pointer attribute can be applied to * procedures, but not allocatable attribute. */ if ((scn.stmtyp != TK_POINTER) || (stype1 != ST_PROC)) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } } if (scn.stmtyp == TK_POINTER) { POINTERP(sptr, TRUE); if (STYPEG(sptr) == ST_PROC) { LOGICAL declared; sptr = SST_SYMG(RHS(1)); /* Save "declared" flag to preserve implicit types */ declared = DCLDG(sptr); /* Generate proper procedure symbol */ sptr = insert_sym(sptr); sptr = setup_procedure_sym(sptr, proc_interf_sptr, ET_B(ET_POINTER), entity_attr.access); SST_SYMP(RHS(1), sptr); /* Restore "declared" flag */ DCLDP(sptr, declared); } if (sem.contiguous) CONTIGATTRP(sptr, 1); if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) { F90POINTERP(sptr, TRUE); } if (DTY(DTYPEG(sptr)) == TY_ARRAY) { dtype = DTYPEG(sptr); ad = AD_DPTR(dtype); if (SCG(sptr) != SC_DUMMY) { if (!AD_DEFER(ad) || AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); ALLOCP(sptr, 1); } else { if (!AD_DEFER(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); /* may have assumed the array was assumed-shape; * now we know better, it's an array pointer */ ASSUMSHPP(sptr, 0); SDSCS1P(sptr, 0); AD_ASSUMSHP(ad) = 0; } if (!F90POINTERG(sptr)) { get_static_descriptor(sptr); get_all_descriptors(sptr); } } } else if ((stype1 != ST_ARRAY && stype1 != ST_IDENT /* Allow ST_IDENT here. It happens when an * ALLOCATABLE statement precedes the DIMENSION statement. * If the allocatable is still an ST_IDENT in semfin.c, * we'll call it an error at that time. */ ) || (!ALLOCG(sptr) && stype1 != ST_IDENT) || SCG(sptr) != SC_NONE) error(84, 3, gbl.lineno, SYMNAME(sptr), "- must be a deferred shape array"); else ALLOCATTRP(sptr, 1); if (RESULTG(sptr)) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } break; /* * ::= ) */ case ALLOC_ID2: sptr = SST_SYMG(RHS(1)); sptr = create_var(sptr); SST_SYMP(LHS, sptr); if (STYPEG(sptr) == ST_UNKNOWN) STYPEP(sptr, ST_IDENT); stype1 = STYPEG(sptr); if (IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to ARRAY */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore type decl */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; } else if (stype1 == ST_ENTRY) { if (DTY(DTYPEG(sptr)) == TY_ARRAY) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } STYPEP(sptr, ST_ARRAY); dtype = SST_DTYPEG(RHS(3)); ad = AD_DPTR(dtype); DTY(dtype + 1) = DTYPEG(sptr); DTYPEP(sptr, dtype); if (DTY(dtype) == TY_ARRAY) { int d; d = DTY(dtype + 1); if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } if (scn.stmtyp == TK_POINTER) { if (!AD_DEFER(ad) || AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); if (SCG(sptr) != SC_DUMMY) ALLOCP(sptr, 1); POINTERP(sptr, TRUE); if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) { F90POINTERP(sptr, TRUE); } if (SDSCG(sptr) == 0 && !F90POINTERG(sptr)) { get_static_descriptor(sptr); get_all_descriptors(sptr); } } else if (AD_DEFER(ad) == 0) error(84, 3, gbl.lineno, SYMNAME(sptr), "- must be a deferred shape array"); else { ALLOCP(sptr, 1); ALLOCATTRP(sptr, 1); if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) { F90POINTERP(sptr, TRUE); } } if (RESULTG(sptr)) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_ATTR_LIST1: /* * ::= , */ case OPT_ATTR_LIST2: in_entity_typdcl = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ATTR_LIST1: /* fall thru */ /* * ::= */ case ATTR_LIST2: if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) { if (!(et_type == ET_DIMENSION || et_type == ET_POINTER || et_type == ET_ACCESS || et_type == ET_ALLOCATABLE || et_type == ET_CONTIGUOUS || et_type == ET_KIND || et_type == ET_LEN)) error(134, 3, gbl.lineno, et[et_type].name, "for derived type component"); } if (entity_attr.exist & ET_B(et_type)) error(134, 3, gbl.lineno, "- duplicate", et[et_type].name); else if (entity_attr.exist & et[et_type].no) error(134, 3, gbl.lineno, "- conflict with", et[et_type].name); else { entity_attr.exist |= ET_B(et_type); } break; /* ------------------------------------------------------------------ */ /* * ::= PARAMETER | */ case ATTR1: et_type = ET_PARAMETER; break; /* * ::= | */ case ATTR2: et_type = ET_ACCESS; break; /* * ::= ALLOCATABLE | */ case ATTR3: et_type = ET_ALLOCATABLE; break; /* * ::= ) | */ case ATTR4: et_type = ET_DIMENSION; entity_attr.dimension = SST_DTYPEG(RHS(3)); /* save bounds information just in case the dimension attribute * is used more than once */ BCOPY(entity_attr.bounds, sem.bounds, char, sizeof(sem.bounds)); BCOPY(entity_attr.arrdim, &sem.arrdim, char, sizeof(sem.arrdim)); break; /* * ::= EXTERNAL | */ case ATTR5: et_type = ET_EXTERNAL; break; /* * ::= | */ case ATTR6: et_type = ET_INTENT; break; /* * ::= INTRINSIC | */ case ATTR7: et_type = ET_INTRINSIC; break; /* * ::= OPTIONAL | */ case ATTR8: et_type = ET_OPTIONAL; break; /* * ::= POINTER | */ case ATTR9: et_type = ET_POINTER; break; /* * ::= SAVE | */ case ATTR10: et_type = ET_SAVE; break; /* * ::= TARGET | */ case ATTR11: et_type = ET_TARGET; break; /* * ::= AUTOMATIC | */ case ATTR12: et_type = ET_AUTOMATIC; break; /* * ::= STATIC | */ case ATTR13: et_type = ET_STATIC; break; /* * ::= BIND | */ case ATTR14: et_type = ET_BIND; break; /* * ::= VALUE | */ case ATTR15: et_type = ET_VALUE; break; /* * ::= VOLATILE | */ case ATTR16: et_type = ET_VOLATILE; break; /* * ::= DEVICE | */ case ATTR17: if (cuda_enabled("device")) et_type = ET_DEVICE; else et_type = 0; break; /* * ::= PINNED | */ case ATTR18: if (cuda_enabled("pinned")) et_type = ET_PINNED; else et_type = 0; break; /* * ::= SHARED | */ case ATTR19: et_type = 0; #ifdef CUDAG if (cuda_enabled("shared")) { if ((gbl.currsub && CUDAG(gbl.currsub) && !(CUDAG(gbl.currsub) & CUDA_HOST)) || (gbl.currmod && !gbl.currsub)) { /* device routine, or module declaration part */ et_type = ET_SHARED; } else { error(134, 3, gbl.lineno, et[ET_SHARED].name, "not allowed in host subprograms"); } } #endif break; /* * ::= CONSTANT | */ case ATTR20: et_type = 0; #ifdef CUDAG if (cuda_enabled("constant")) { if ((gbl.currsub && CUDAG(gbl.currsub) && !(CUDAG(gbl.currsub) & CUDA_HOST)) || (gbl.currmod && !gbl.currsub)) { /* device routine, or module declaration part */ et_type = ET_CONSTANT; } else { error(134, 3, gbl.lineno, et[ET_CONSTANT].name, "not allowed in host subprograms"); } } #endif break; /* * ::= PROTECTED | */ case ATTR21: et_type = ET_PROTECTED; if (!IN_MODULE_SPEC) { error(155, 3, gbl.lineno, "PROTECTED may only appear in the specification part of a MODULE", CNULL); } break; /* * ::= ASYNCHRONOUS */ case ATTR22: et_type = ET_ASYNCHRONOUS; break; /* * ::= ABSTRACT | */ case ATTR23: /* anything here? */ break; /* * ::= TEXTURE */ case ATTR24: if (cuda_enabled("texture")) et_type = ET_TEXTURE; else et_type = 0; break; /* * ::= KIND | */ case ATTR25: et_type = ET_KIND; break; /* * ::= LEN | */ case ATTR26: et_type = ET_LEN; break; /* * ::= CONTIGUOUS | */ case ATTR27: et_type = ET_CONTIGUOUS; break; /* * ::= MANAGED | */ case ATTR28: et_type = 0; if (cuda_enabled("managed")) { #if defined(TARGET_OSX) /* not supported */ error(538, 3, gbl.lineno, CNULL, CNULL); #else /* supported */ et_type = ET_MANAGED; #endif } break; /* ------------------------------------------------------------------ */ /* * ::= ( ) | */ case BIND_ATTR1: /* see also FUNC_SUFFIX2 for a copy of this processing */ bind_attr.exist = -1; bind_attr.altname = 0; np = scn.id.name + SST_CVALG(RHS(2)); if (sem_strcmp(np, "c") != 0) { error(4, 3, gbl.lineno, "Illegal BIND -", np); } else { bind_attr.exist = DA_B(DA_C); } break; /* * ::= ( , = ) */ case BIND_ATTR2: np = scn.id.name + SST_CVALG(RHS(4)); if (sem_strcmp(np, "name") != 0) { error(4, 3, gbl.lineno, "Illegal BIND syntax. Expecting: NAME Got:", np); } bind_attr.exist = -1; bind_attr.altname = 0; np = scn.id.name + SST_CVALG(RHS(2)); if (sem_strcmp(np, "c") != 0) { error(4, 3, gbl.lineno, "Illegal BIND -", np); } else { bind_attr.exist = DA_B(DA_C) | DA_B(DA_ALIAS); bind_attr.altname = SST_SYMG(RHS(6)); // altname may be "" } break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case BIND_LIST1: rhstop = 3; goto add_sym_to_bind_list; break; /* * ::= */ case BIND_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case BIND_ENTRY1: /* fall through */ /* * ::= */ case BIND_ENTRY2: rhstop = 1; add_sym_to_bind_list: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(rhstop)); itemp->ast = SST_ASTG(RHS(rhstop)); /* copied for rules */ if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_TYPE_SPEC1: entity_attr.access = ' '; SST_CVALP(LHS, 0); break; /* * ::= , */ case OPT_TYPE_SPEC2: SST_CVALP(LHS, SST_CVALG(RHS(2))); SST_LSYMP(LHS, SST_LSYMG(RHS(2))); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TYPE_ATTR_LIST1: switch (SST_CVALG(RHS(1)) & SST_CVALG(RHS(3))) { case 0x1: error(134, 3, gbl.lineno, "- duplicate", et[ET_BIND].name); SST_CVALP(RHS(3), 0); break; case 0x2: error(134, 3, gbl.lineno, "- duplicate", et[ET_ACCESS].name); SST_CVALP(RHS(3), 0); break; case 0x4: /* type extension */ error(134, 3, gbl.lineno, "- duplicate", et[ET_ACCESS].name); SST_CVALP(RHS(3), 0); break; } SST_CVALP(LHS, SST_CVALG(RHS(1)) | SST_CVALG(RHS(3))); if (SST_CVALG(RHS(3)) & 0x4) SST_LSYMP(LHS, SST_LSYMG(RHS(3))); break; /* * ::= */ case TYPE_ATTR_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= BIND | */ case TYPE_ATTR1: /* struct types are already properly aligned for C compatibility; * pass up presence of BIND so that the type can be marked as * BIND(C) with the flag CFUNC. */ SST_CVALP(LHS, 0x1); break; /* * ::= */ case TYPE_ATTR2: SST_CVALP(LHS, 0x2); break; /* * ::= EXTENDS ( ) | */ case TYPE_ATTR3: /* type extension */ SST_CVALP(LHS, 0x4); sptr = SST_SYMG(RHS(3)); while (STYPEG(sptr) == ST_ALIAS) sptr = SYMLKG(sptr); if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) { sptr = GTYPEG(sptr); } if (sptr > NOSYM && STYPEG(sptr) != ST_TYPEDEF) { int sym = findByNameStypeScope(SYMNAME(sptr), ST_TYPEDEF, -1); if (sym > NOSYM) sptr = sym; } if (DTY(DTYPEG(sptr)) != TY_DERIVED) { error(155, 4, gbl.lineno, "Invalid type extension", NULL); } else { /* Check for private type extension */ int tag = DTY(DTYPEG(sptr) + 3); int tag_scope = SCOPEG(tag); int host_scope = stb.curr_scope; if (PRIVATEG(tag)) { if (STYPEG(tag_scope) == ST_MODULE && STYPEG(host_scope) != ST_MODULE) host_scope = SCOPEG(host_scope); if (tag_scope != host_scope) error(155, 3, gbl.lineno, "Cannot extend type with PRIVATE attribute -", SYMNAME(tag)); } } sem.extends = sptr; SST_LSYMP(LHS, sptr); break; /* * ::= ABSTRACT | */ case TYPE_ATTR4: SST_CVALP(LHS, 0x8); break; /* ------------------------------------------------------------------ */ /* * ::= PUBLIC | */ case ACCESS_SPEC1: entity_attr.access = 'u'; if (!IN_MODULE_SPEC) ERR310("PUBLIC/PRIVATE may only appear in a MODULE scoping unit", CNULL); break; /* * ::= PRIVATE */ case ACCESS_SPEC2: if (sem.type_mode == 2 && IN_MODULE_SPEC) { /* private seen in type bound procedure "contains" section */ entity_attr.access = '0'; } else entity_attr.access = 'v'; if (!IN_MODULE_SPEC) ERR310("PUBLIC/PRIVATE may only appear in a MODULE scoping unit", CNULL); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ACCESS_LIST1: rhstop = 3; goto add_sym_to_list; /* * ::= */ case ACCESS_LIST2: rhstop = 1; goto add_sym_to_list; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCESS1: SST_ASTP(LHS, 0); break; /* * ::= ( ) | */ case ACCESS2: np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "operator") == 0) SST_SYMP(LHS, SST_LSYMG(RHS(3))); else { error(34, 3, gbl.lineno, np, CNULL); SST_SYMP(LHS, getsymbol(".34")); } SST_ASTP(LHS, 1); /* mark this as being from OPERATOR stmt */ break; /* * ::= ( = ) */ case ACCESS3: np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "assignment") == 0) { sptr = get_intrinsic_opr(OP_ST, 0); SST_SYMP(LHS, sptr); } else { error(34, 3, gbl.lineno, np, CNULL); SST_SYMP(LHS, getsymbol(".34")); } SST_ASTP(LHS, 1); /* treat as if from OPERATOR stmt */ break; /* ------------------------------------------------------------------ */ /* * ::= SEQUENCE | */ case SEQ1: if (!INSIDE_STRUCT || STSK_ENT(0).type != 'd') { error(155, 3, gbl.lineno, "SEQUENCE must appear in a derived type definition", CNULL); } SST_CVALP(LHS, 's'); break; /* * ::= NOSEQUENCE */ case SEQ2: error(34, 3, gbl.lineno, "NOSEQUENCE", CNULL); SST_CVALP(LHS, 'n'); break; /* ------------------------------------------------------------------ */ /* * ::= INTENT ( ) | */ case INTENT1: np = scn.id.name + SST_CVALG(RHS(3)); if (sem_strcmp(np, "in") == 0) entity_attr.intent = INTENT_IN; else if (sem_strcmp(np, "out") == 0) entity_attr.intent = INTENT_OUT; else if (sem_strcmp(np, "inout") == 0) entity_attr.intent = INTENT_INOUT; else { error(81, 3, gbl.lineno, "- illegal intent", np); entity_attr.intent = INTENT_DFLT; } break; /* * ::= INTENT ( ) */ case INTENT2: np = scn.id.name + SST_CVALG(RHS(3)); if (sem_strcmp(np, "in") == 0) { np = scn.id.name + SST_CVALG(RHS(4)); if (sem_strcmp(np, "out") == 0) entity_attr.intent = INTENT_INOUT; else { error(81, 3, gbl.lineno, "- illegal intent in", np); entity_attr.intent = INTENT_DFLT; } } else { error(81, 3, gbl.lineno, "- illegal intent", np); entity_attr.intent = INTENT_DFLT; } break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ENTITY_DECL_LIST1: rhstop = 3; goto add_entity_to_list; /* * ::= */ case ENTITY_DECL_LIST2: rhstop = 1; add_entity_to_list: if (in_entity_typdcl) { /* only pass up list if hpf decls */ SST_BEGP(LHS, ITEM_END); break; } itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(rhstop)); if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ENTITY_DECL1: /* only pass up sym if hpf decls */ if (!in_entity_typdcl) break; inited = FALSE; goto entity_decl_shared; /* * ::= | */ case ENTITY_DECL2: if (!in_entity_typdcl) { error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL); break; } sptr = SST_SYMG(RHS(1)); stype1 = STYPEG(sptr); if (IS_INTRINSIC(stype1)) { if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore in COMMON */ break; SST_SYMP(LHS, sptr); } //AOCC begin //assumed size arrays. modify the saved lhs SST using the rhs sst if (asz_status) { sptras = SST_SYMG(top); dtypeas = DTYPEG(sptras); adas = AD_DPTR(dtypeas); if (entity_attr.exist & ET_B(ET_PARAMETER)) { // check if array is a parameter if (AD_ASSUMSZ(adas)) { //check if array is an assumed size array /* the size of the assumed size array when * its elements are variables */ if (asz_count == 0 && asz_id_elem_count_tot != 0) { asz_count = asz_id_elem_count_tot; } sptras = SST_SYMG(asz_sst); SST_LSYMP(asz_sst, 0); SST_DTYPEP(asz_sst, DT_INT); SST_DTYPEP(asz_rhssst, DT_INT); SST_ACLP(asz_sst, 0); SST_CVALP(asz_sst, asz_count); SST_CVALP(asz_rhssst, asz_count); asz_ast = mk_cval1(SST_CVALG(asz_sst), (int)SST_DTYPEG(asz_sst)); SST_SHAPEP(asz_sst, 0); SST_IDP(asz_rhssst, S_CONST); SST_PARENP(LHS, 0); SST_ASTP(asz_rhssst, 0); arraysize = 0; if (SST_IDG(asz_rhssst) == S_CONST) { sem.bounds[sem.arrdim.ndim].uptype = S_CONST; int uptyp; uptyp = SST_DTYPEG(asz_rhssst); if (!DT_ISINT(uptyp)) { error(170, 2, gbl.lineno, "array upper bound", "is not integer"); } // assign the lhs using the size of array computed from the rhs arraysize = sem.bounds[sem.arrdim.ndim].upb = chkcon_to_isz(asz_rhssst, FALSE); asz_ast = sem.bounds[sem.arrdim.ndim].upast = mk_bnd_int(SST_ASTG(asz_rhssst)); asz_sptr = A_SPTRG(sem.bounds[sem.arrdim.ndim].upast - 1); CONVAL2P(asz_sptr, arraysize); SST_ASTP(asz_rhssst, asz_ast); SST_ASTP(asz_sst, asz_ast); } int savedsc_val = aux.arrdsc_avl; if (asz_status) aux.arrdsc_avl = asz_arrdsc ; dtypeas = mk_arrdsc(); // update the lhs array descriptor SST_DTYPEP(asz_sst, dtypeas); aux.arrdsc_avl = savedsc_val; } } asz_status = 0; asz_id_elem_count_tot = 0; } //AOCC end inited = TRUE; sem.dinit_data = FALSE; asz_string = 0; // AOCC: reset the assumed size computation status asz_count = 0; goto entity_decl_shared; /* * ::= '=>' ( ) */ case ENTITY_DECL3: if (!in_entity_typdcl) { error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL); break; } sptr = SST_SYMG(RHS(1)); stype1 = STYPEG(sptr); if (IS_INTRINSIC(stype1)) { if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore in COMMON */ break; SST_SYMP(LHS, sptr); } sptr = SST_SYMG(RHS(3)); sptr = refsym(sptr, OC_OTHER); SST_SYMP(RHS(3), sptr); SST_IDP(RHS(3), S_IDENT); sem.dinit_data = TRUE; (void)mkvarref(RHS(3), ITEM_END); sem.dinit_data = FALSE; inited = TRUE; entity_decl_shared: sptr = SST_SYMG(RHS(1)); if (!(entity_attr.exist & ET_B(ET_BIND))) { sptr = block_local_sym(SST_SYMG(RHS(1))); SST_SYMP(RHS(1), sptr); } SST_SYMP(RHS(1), sptr); if (sem.new_param_dt) { dtype = DTYPEG(sptr); if (DTY(dtype) == TY_ARRAY) { DTY(dtype + 1) = sem.new_param_dt; } else { DTYPEP(sptr, sem.new_param_dt); } fix_type_param_members(sptr, sem.new_param_dt); } if (!sem.interface) add_type_param_initialize(sptr); if (sem.class && sem.type_mode && !(entity_attr.exist & (ET_B(ET_ALLOCATABLE) | ET_B(ET_POINTER)))) { error(155, 3, gbl.lineno, "CLASS component must be " "allocatable or pointer -", SYMNAME(sptr)); } sem.gdtype = SST_GDTYPEG(RHS(1)); sem.gty = SST_GTYG(RHS(1)); if (flg.xref) xrefput(sptr, 'd'); dtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len, lenspec[1].propagated, sptr); if (DCLDG(sptr) && !RESULTG(sptr) && !IS_INTRINSIC(STYPEG(sptr))) { switch (STYPEG(sptr)) { /* any cases for which a data type does not apply */ case ST_MODULE: case ST_NML: error(44, 3, gbl.lineno, SYMNAME(sptr), CNULL); break; default: /* data type for ident has already been specified */ if (DDTG(DTYPEG(sptr)) == dtype) error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL); else error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL); } /* to avoid setting symbol table entry's stype field */ goto entity_decl_end; } else { switch (STYPEG(sptr)) { /* any cases for which a type must be identical to the variable's * implicit type. */ case ST_PARAM: if (!(entity_attr.exist & ET_B(ET_PARAMETER)) && DTYPEG(sptr) != dtype) error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL); break; default: break; } } /* * Finalize the dtype of the variable. * Determine the tentative stype we want give to the variable if * it's still ST_UNKNOWN or ST_IDENT. */ DCLDP(sptr, TRUE); set_char_attributes(sptr, &dtype); if (DTY(DTYPEG(sptr)) == TY_ARRAY) { if (sem.new_param_dt && has_type_parameter(DTY(DTYPEG(sptr) + 1))) { /* Make sure we use the new parameterized dtype */ dtype = sem.new_param_dt; } DTY(DTYPEG(sptr) + 1) = dtype; if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) && DISTMEMG(DTY(dtype + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } dtype = DTYPEG(sptr); } else if (DTY(DTYPEG(sptr)) == TY_PTR && DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC) { /* ptr to a function, set the func return value and the pointer flag */ int func_dtype = DTY(DTYPEG(sptr) + 1); DTY(func_dtype + 5) = dtype; } else if (!USELENG(sptr) && !LENG(sptr)) { /* parameterized derived type TBD: array case???? */ DTYPEP(sptr, (!sem.new_param_dt) ? dtype : sem.new_param_dt); if (SCG(sptr) == SC_DUMMY) { put_length_type_param(DTYPEG(sptr), 3); } } if (DTY(dtype) == TY_ARRAY) is_array = TRUE; else is_array = FALSE; is_member = FALSE; stype = STYPEG(sptr); if (stype == ST_MEMBER) { stype = 0; is_member = TRUE; } else if (stype == ST_ENTRY) stype = 0; else if (is_array) stype = ST_ARRAY; else if (DTY(dtype) == TY_STRUCT) stype = ST_STRUCT; no_init = FALSE; et_type = 0; et_bitv = entity_attr.exist; /* Loop through all assigned attributes */ for (; et_bitv; et_bitv >>= 1, et_type++) { if ((et_bitv & 0x0001) == 0) continue; switch (et_type) { default: continue; case ET_ACCESS: if (sptr == ST_ARRAY && ADJARRG(sptr)) error(84, 3, gbl.lineno, SYMNAME(sptr), "- must not be an automatic array"); else if (is_member) { if (entity_attr.access == 'v') PRIVATEP(sptr, 1); else PRIVATEP(sptr, 0); } else { accessp = (ACCL *)getitem(3, sizeof(ACCL)); accessp->sptr = sptr; accessp->type = entity_attr.access; accessp->next = sem.accl.next; accessp->oper = ' '; sem.accl.next = accessp; } break; case ET_ALLOCATABLE: if (is_array) { ad = AD_DPTR(dtype); if (AD_DEFER(ad) == 0) error(84, 3, gbl.lineno, SYMNAME(sptr), "- must be a deferred shape array"); else { if (AD_ASSUMSHP(ad)) { /* this is an error if it isn't a dummy; the * declaration could occur before its entry, so * the check needs to be performed in semfin. */ ASSUMSHPP(sptr, 1); if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); } mk_defer_shape(sptr); } } ALLOCP(sptr, 1); ALLOCATTRP(sptr, 1); if (STYPEG(sptr) == ST_MEMBER) { ALLOCFLDP(DTY(ENCLDTYPEG(sptr) + 3), 1); } dtype = DTYPEG(sptr); if (DTY(dtype) == TY_ARRAY) { dtype = DTY(dtype + 1); if (sem.class) CLASSP(sptr, 1); } if (STYPEG(sptr) == ST_MEMBER && DTY(dtype) == TY_DERIVED && has_finalized_component(sptr)) { FINALIZEDP(sptr, 1); } if (!(DTY(DTYPEG(sptr)) == TY_ARRAY && STYPEG(sptr) == ST_MEMBER) && DTY(dtype) == TY_DERIVED) { /* Note: Do not execute this case for array * components since they already have a full array descriptor * embedded in the derived type. */ if (sem.class) CLASSP(sptr, 1); set_descriptor_rank(TRUE); get_static_descriptor(sptr); set_descriptor_rank(FALSE); get_all_descriptors(sptr); if (SCG(sptr) != SC_DUMMY) SCP(sptr, SC_BASED); ALLOCDESCP(sptr, TRUE); } else if (SCG(sptr) == SC_DUMMY) { get_static_descriptor(sptr); get_all_descriptors(sptr); } else if (!INSIDE_STRUCT && SDSCG(sptr) == 0 && (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR || DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) { if (SCG(sptr) != SC_DUMMY) SCP(sptr, SC_BASED); /* Don't change dummy */ get_static_descriptor(sptr); get_all_descriptors(sptr); ALLOCDESCP(sptr, TRUE); } else { SCP(sptr, SC_BASED); } no_init = TRUE; break; case ET_CONTIGUOUS: #ifdef CONTIGATTRP CONTIGATTRP(sptr, 1); #endif break; case ET_DIMENSION: break; case ET_EXTERNAL: if (DTY(DTYPEG(sptr)) == TY_ARRAY) { /* conflict with EXTERNAL */ error(134, 3, gbl.lineno, "- array bounds not allowed with external", SYMNAME(sptr)); } /* Produce procedure symbol based on attributes */ sptr = decl_procedure_sym(sptr, 0, entity_attr.exist); sptr = setup_procedure_sym(sptr, 0, entity_attr.exist, entity_attr.access); if (!TYPDG(sptr)) { TYPDP(sptr, 1); if (SCG(sptr) == SC_DUMMY) { IS_PROC_DUMMYP(sptr, 1); } } stype = 0; no_init = TRUE; break; case ET_INTENT: INTENTP(sptr, entity_attr.intent); if (sem.interface) { if (SCG(sptr) != SC_DUMMY) { error(134, 3, gbl.lineno, "- intent specified for nondummy argument", SYMNAME(sptr)); } else if (POINTERG(sptr)) { error(134, 3, gbl.lineno, "- intent specified for pointer argument", SYMNAME(sptr)); } else if (STYPEG(sptr) == ST_PROC) { error(134, 3, gbl.lineno, "- intent specified for dummy subprogram argument", SYMNAME(sptr)); } } else { /* defer checking of storage class until semfin */ itemp1 = (ITEM *)getitem(3, sizeof(ITEM)); itemp1->next = sem.intent_list; sem.intent_list = itemp1; itemp1->t.sptr = sptr; itemp1->ast = gbl.lineno; } break; case ET_INTRINSIC: stype = STYPEG(sptr); if (IS_INTRINSIC(stype)) { EXPSTP(sptr, 1); /* Freeze as an intrinsic */ TYPDP(sptr, 1); /* appeared in INTRINSIC statement */ } else error(126, 3, gbl.lineno, SYMNAME(sptr), CNULL); stype = 0; no_init = TRUE; break; case ET_OPTIONAL: OPTARGP(sptr, 1); break; case ET_PARAMETER: break; /* handle after scanning all attributes */ case ET_POINTER: POINTERP(sptr, TRUE); if (sem.contiguous) CONTIGATTRP(sptr, 1); if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) { F90POINTERP(sptr, TRUE); } if (is_array) { ad = AD_DPTR(dtype); if (AD_DEFER(ad) == 0) error(84, 3, gbl.lineno, SYMNAME(sptr), "- must be a deferred shape array"); } dtype = DTYPEG(sptr); if (DTY(dtype) == TY_ARRAY) { dtype = DTY(dtype + 1); if (sem.class) CLASSP(sptr, 1); } if (STYPEG(sptr) == ST_MEMBER && DTY(dtype) == TY_DERIVED && has_finalized_component(sptr)) { FINALIZEDP(sptr, 1); } if (!(DTY(DTYPEG(sptr)) == TY_ARRAY && STYPEG(sptr) == ST_MEMBER) && DTY(dtype) == TY_DERIVED) { int sav_sc; if (sem.class) CLASSP(sptr, TRUE); set_descriptor_rank(TRUE); sav_sc = 0; if (IN_MODULE && in_save_scope(sptr)) { /* SAVE is set, so we need to set our descriptor * to SC_STATIC here instead of later (in do_save() of * semfin.c). Otherwise, we may get unresolved symbol * link errors because we save descriptor early on in * the module. */ /* Note: The SC_STATIC fix is only required for polymorphic * objects. For non-polymorphic objects, we can safely use * SC_LOCAL since the type does not mutate. */ sav_sc = get_descriptor_sc(); set_descriptor_sc(sem.class ? SC_STATIC : SC_LOCAL); } if (sem.class || has_tbp_or_final(dtype) || STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY) { ALLOCDESCP(sptr, TRUE); } get_static_descriptor(sptr); set_descriptor_rank(FALSE); if (IN_MODULE && in_save_scope(sptr)) { set_descriptor_sc(sav_sc); } if (!sem.class) CCSYMP(SDSCG(sptr), TRUE); } else if (!INSIDE_STRUCT && SDSCG(sptr) == 0 && (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR || DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) { if (SCG(sptr) != SC_DUMMY) /* Can't change dummy */ SCP(sptr, SC_BASED); get_static_descriptor(sptr); get_all_descriptors(sptr); } break; case ET_SAVE: /* must be a variable or an array; it cannot be a dummy * argument or common block member. */ if (stype == 0) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) { if (ASUMSZG(sptr)) error(155, 3, gbl.lineno, "An assumed-size array cannot have the SAVE attribute -", SYMNAME(sptr)); else if (SCG(sptr) == SC_DUMMY) error(155, 3, gbl.lineno, "An adjustable array cannot have the SAVE attribute -", SYMNAME(sptr)); else error(155, 3, gbl.lineno, "An automatic array cannot have the SAVE attribute -", SYMNAME(sptr)); } else if (flg.standard && gbl.currsub && !is_impure(gbl.currsub)) { error(170, 2, gbl.lineno, sem.block_scope ? "SAVE attribute for a BLOCK variable of a PURE subroutine" : "SAVE attribute for a local variable of a PURE subroutine", CNULL); } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL || SCG(sptr) == SC_BASED) && (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT || stype == ST_IDENT)) { sem.savloc = TRUE; SAVEP(sptr, 1); /* SCP(sptr, SC_LOCAL); * SAVE is now an attribute and may appear allocatable; the * appearance of a variable in a SAVE statement is no longer * sufficient to define the variable's storage class. */ } else error(39, 2, gbl.lineno, SYMNAME(sptr), CNULL); break; case ET_TARGET: TARGETP(sptr, 1); if( XBIT(58, 0x400000) && SCG(sptr) == SC_DUMMY && ASSUMSHPG(sptr) ) SDSCS1P(sptr,0); break; case ET_AUTOMATIC: /* must be a variable or an array; it cannot be a dummy * argument or common block member. */ if (stype == 0) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); else if (flg.standard) error(171, 2, gbl.lineno, "AUTOMATIC", CNULL); else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL || SCG(sptr) == SC_BASED) && (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT || stype == ST_IDENT)) { if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) symatterr(2, sptr, "AUTOMATIC"); else if (gbl.rutype != RU_PROG || CONSTRUCTSYMG(sptr)) { sem.autoloc = TRUE; /* TBD -- need to resolve SC_BASED vs SC_LOCAL & SCFXD * DON'T FORGET the AUTOMATIC & STATIC statements. */ SCP(sptr, SC_LOCAL); SCFXDP(sptr, 1); } } else symatterr(2, sptr, "AUTOMATIC"); break; case ET_STATIC: /* must be a variable or an array; it cannot be a dummy * argument or common block member. */ if (stype == 0) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); else if (flg.standard) error(171, 2, gbl.lineno, "STATIC", CNULL); else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL || SCG(sptr) == SC_BASED) && (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT || stype == ST_IDENT)) { if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) symatterr(2, sptr, "STATIC"); /* just use the save semantics */ sem.savloc = TRUE; SAVEP(sptr, 1); } else symatterr(2, sptr, "STATIC"); break; case ET_BIND: if (!IN_MODULE) error(280, 2, gbl.lineno, "BIND: allowed only in module", 0); process_bind(sptr); break; case ET_VALUE: if (CLASSG(sptr)) { error(155, 3, gbl.lineno, "Polymorphic variable" " cannot have VALUE attribute -", SYMNAME(sptr)); } if ((DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR) && string_length(DTYPEG(sptr)) != 1) { error(155, 3, gbl.lineno, "Multi-CHARACTER strings can not have the VALUE attribue - ", SYMNAME(sptr)); } PASSBYVALP(sptr, 1); PASSBYREFP(sptr, 0); break; case ET_VOLATILE: VOLP(sptr, 1); break; case ET_ASYNCHRONOUS: /* * do we need a specific flag set a flag? OR, just hit it * with VOLP? Wait until it really matters. */ #ifdef ASYNCP /* Yes, flag is needed so we can check * characteristics of dummy arguments for type bound * procedures. */ ASYNCP(sptr, 1); #endif break; case ET_PROTECTED: PROTECTEDP(sptr, 1); break; case ET_KIND: #ifdef KINDP if (!DT_ISINT(DTYPEG(sptr))) { error(155, 3, gbl.lineno, "derived type parameter must be an INTEGER -", SYMNAME(sptr)); } KINDP(sptr, -1); #endif break; case ET_LEN: #ifdef KINDP if (!DT_ISINT(DTYPEG(sptr))) { error(155, 3, gbl.lineno, "derived type parameter must be an INTEGER -", SYMNAME(sptr)); } KINDP(sptr, -1); LENPARMP(sptr, 1); #endif break; } } if (sem.new_param_dt) chk_new_param_dt(sptr, sem.new_param_dt); if ((DTYPEG(sptr) == DT_DEFERCHAR || DTYPEG(sptr) == DT_DEFERNCHAR) && (!POINTERG(sptr) && !ALLOCATTRG(sptr))) { error(155, 3, gbl.lineno, "Object with deferred character length" " (:) must be a pointer or an allocatable -", SYMNAME(sptr)); } if ((entity_attr.exist & ET_B(ET_PARAMETER)) || do_fixup_param_vars_for_derived_arrays(inited, sptr, SST_IDG(RHS(3)))) { if (inited) { fixup_param_vars(top, RHS(3)); if (DTY(dtype) != TY_DERIVED && (DTY(dtype) != TY_ARRAY)) { /* don't build ACLs for scalar parameters */ goto entity_decl_end; } } else { error(143, 3, gbl.lineno, SYMNAME(sptr), CNULL); goto entity_decl_end; } } if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } if (stype) { if (stype != STYPEG(sptr) && STYPEG(sptr) != ST_PARAM) { if (STYPEG(sptr) == ST_VAR && stype == ST_ARRAY) { /* HACK: if the item being defined has an initializer * that contains an intrinsic call that uses the item * as an argument, then the argument handling may have * changed the item's STYPE to ST_VAR. If the item is * an array, change its STYPE to ST_IDENT so declsym * will function correctly. */ STYPEP(sptr, ST_IDENT); } sptr = declsym(sptr, stype, TRUE); } if (stype == ST_ARRAY && !F90POINTERG(sptr)) { if (POINTERG(sptr) || MDALLOCG(sptr) || (ALLOCATTRG(sptr) && STYPEG(sptr) == ST_MEMBER)) { int dty = DTYPEG(sptr); get_static_descriptor(sptr); get_all_descriptors(sptr); if (DTY(dty) == TY_ARRAY) { dty = DTY(dty + 1); } if (DTY(dty) == TY_DERIVED && SCG(sptr) != SC_DUMMY) { /* initialize the type field in the descriptor */ int astnew, type; type = get_static_type_descriptor(DTY(dty + 3)); astnew = mk_set_type_call(mk_id(SDSCG(sptr)), mk_id(type), FALSE); add_stmt(astnew); } } } } if (INSIDE_STRUCT && XBIT(58, 0x10000) && !F90POINTERG(sptr)) { /* we are processing a member, and we must handle all pointers */ /* do we need descriptors for this member? */ if (POINTERG(sptr) || ALLOCG(sptr) || ADJARRG(sptr) || RUNTIMEG(sptr)) { set_preserve_descriptor(ALLOCDESCG(sptr)); get_static_descriptor(sptr); get_all_descriptors(sptr); SCP(sptr, SC_BASED); set_preserve_descriptor(0); } } if (inited) { /* check if symbol is data initialized */ if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) { if (no_init) { error(114, 3, gbl.lineno, SYMNAME(sptr), CNULL); goto entity_decl_end; } stsk = &STSK_ENT(0); if (SST_IDG(RHS(3)) == S_LVALUE || SST_IDG(RHS(3)) == S_EXPR || SST_IDG(RHS(3)) == S_IDENT || SST_IDG(RHS(3)) == S_CONST) { mkexpr(RHS(3)); ast = SST_ASTG(RHS(3)); if (has_kind_parm_expr(ast, stsk->dtype, 1)) { if (chk_kind_parm_expr(ast, stsk->dtype, 1, 1)) { INITKINDP(sptr, 1); PARMINITP(sptr, ast); } } else if (DTY(DTYPEG(sptr)) == TY_ARRAY) { int dim; ad = AD_DPTR(DTYPEG(sptr)); for (dim = 0; dim < AD_NUMDIM(ad); ++dim) { int lb = AD_LWAST(ad, dim); int ub = AD_UPAST(ad, dim); if (has_kind_parm_expr(lb, stsk->dtype, 1) || has_kind_parm_expr(ub, stsk->dtype, 1)) { INITKINDP(sptr, 1); PARMINITP(sptr, ast); break; } } } } if (!INITKINDG(sptr)) construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1)))); if (!SST_ACLG(RHS(3))) { goto entity_decl_end; } ict = SST_ACLG(RHS(3)); ict->sptr = sptr; /* field/component sptr */ save_struct_init(ict); stsk = &STSK_ENT(0); if (stsk->ict_beg) { (stsk->ict_end)->next = SST_ACLG(RHS(3)); stsk->ict_end = SST_ACLG(RHS(3)); } else { stsk->ict_beg = SST_ACLG(RHS(3)); stsk->ict_end = SST_ACLG(RHS(3)); } } else { /* Data item (not TYPE component) initialization */ if (no_init) { error(114, 3, gbl.lineno, SYMNAME(sptr), CNULL); goto entity_decl_end; } if (DTY(DTYPEG(sptr)) == TY_ARRAY && !POINTERG(sptr)) { if (ADD_DEFER(DTYPEG(sptr)) || ADD_NOBOUNDS(DTYPEG(sptr))) { error(155, 3, gbl.lineno, "Cannot initialize deferred-shape array", SYMNAME(sptr)); goto entity_decl_end; } } if (POINTERG(sptr)) { /* have * ... :: => NULL() * $p, $o, $sd will be needed */ dtype = DTYPEG(sptr); if (DTY(dtype) == TY_ARRAY) { dtype = DTY(dtype + 1); } if ((DTY(DTYPEG(sptr)) != TY_ARRAY || STYPEG(sptr) != ST_MEMBER) && DTY(dtype) == TY_DERIVED && (sem.class || has_tbp_or_final(dtype) || STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY)) set_descriptor_rank(1); get_static_descriptor(sptr); if ((DTY(DTYPEG(sptr)) != TY_ARRAY || STYPEG(sptr) != ST_MEMBER) && DTY(dtype) == TY_DERIVED && (sem.class || has_tbp_or_final(dtype) || STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY)) set_descriptor_rank(0); get_all_descriptors(sptr); } if (SST_IDG(RHS(3)) == S_ACONST) { if (DTY(DTYPEG(sptr)) == TY_ARRAY) { if (AD_NUMDIM(AD_DPTR(DTYPEG(sptr))) != AD_NUMDIM(AD_DPTR(SST_DTYPEG(RHS(3))))) { if (size_of_array(DTYPEG(sptr)) == 0 && DTY(SST_DTYPEG(RHS(3))) != TY_ARRAY) { /* i.e., a(0) == (/integer::/) */ goto entity_decl_end; } error(155, 3, gbl.lineno, "Shape of initializer does not match shape of", SYMNAME(sptr)); goto entity_decl_end; } } else if (POINTERG(sptr) || ALLOCATTRG(sptr)) { errsev(457); goto entity_decl_end; } } /* AOCC begin */ if (flg.std == F2008) { if (POINTERG(sptr) && !IN_MODULE_SPEC) { ast = assign_pointer(RHS(1), RHS(3)); add_stmt(ast); SST_ASTP(RHS(1), ast); goto entity_decl_end; } } /* AOCC end */ construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1)))); if (!SST_ACLG(RHS(3))) { goto entity_decl_end; } dtype = DTYPEG(sptr); if (STYPEG(sptr) == ST_PARAM) { if (DTY(dtype) == TY_ARRAY || DTY(dtype) == TY_DERIVED) { CONVAL2P(sptr, put_getitem_p(save_acl(SST_ACLG(RHS(3))))); sptr = CONVAL1G(sptr); } } else if (DTY(dtype) == TY_DERIVED && !POINTERG(sptr)) { /* This used to be done in dinit_struct_constr. It is necessary */ /* to get ADDRESS (i.e., offset into STATICS) set */ if (STYPEG(sptr) == ST_IDENT || STYPEG(sptr) == ST_UNKNOWN) { STYPEP(sptr, ST_VAR); } if (SCG(sptr) == SC_NONE) SCP(sptr, SC_LOCAL); DINITP(sptr, 1); sym_is_refd(sptr); } ast = mk_id(sptr); SST_ASTP(RHS(1), ast); SST_DTYPEP(RHS(1), DTYPEG(SST_SYMG(RHS(1)))); SST_SHAPEP(RHS(1), A_SHAPEG(ast)); ivl = dinit_varref(RHS(1)); dinit(ivl, SST_ACLG(RHS(3))); } } else if (DTY(DDTG(dtype)) == TY_DERIVED && !POINTERG(sptr) && !ALLOCG(sptr) && !ADJARRG(sptr)) { int dt_dtype = DDTG(dtype); if (INSIDE_STRUCT) { /* Uninitialized declaration of a derived type data item. * Check for and handle any component intializations defined * for this derived type */ build_typedef_init_tree(sptr, dt_dtype); } else if (DTY(dt_dtype + 5) && SCOPEG(sptr) && SCOPEG(sptr) == stb.curr_scope && STYPEG(stb.curr_scope) == ST_MODULE) { /* * a derived type module variable has component initializers, * so generate inits. */ build_typedef_init_tree(sptr, dt_dtype); } } else { if (POINTERG(sptr)) { /* have * ... :: * $p, $o, $sd will be needed */ if (!SDSCG(sptr)) get_static_descriptor(sptr); if (!PTROFFG(sptr)) get_all_descriptors(sptr); } } entity_decl_end: sem.dinit_error = FALSE; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ENTITY_ID1: set_len_attributes(RHS(2), 1); stype = ST_IDENT; dtype = -1; dtypeset = 0; sem.dinit_count = 1; if (entity_attr.exist & ET_B(ET_DIMENSION)) { if (entity_attr.dimension) { /* allow just one use of this data type record */ dtype = entity_attr.dimension; dtypeset = 1; entity_attr.dimension = 0; } else { /* create a new array dtype record from the bounds information * saved earlier */ BCOPY(sem.bounds, entity_attr.bounds, char, sizeof(sem.bounds)); BCOPY(&sem.arrdim, entity_attr.arrdim, char, sizeof(sem.arrdim)); dtype = mk_arrdsc(); dtypeset = 1; } ad = AD_DPTR(dtype); if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) sem.dinit_count = -1; stype = ST_ARRAY; } else ad = NULL; goto entity_id_shared; /* * ::= ) */ case ENTITY_ID2: /* Send len spec up with ident on semantic stack */ if (SST_SYMG(RHS(6)) != -1) { if (SST_SYMG(RHS(2)) != -1) errsev(46); set_len_attributes(RHS(6), 1); } else set_len_attributes(RHS(2), 1); stype = ST_ARRAY; dtype = SST_DTYPEG(RHS(4)); dtypeset = 1; ad = AD_DPTR(dtype); if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad) || sem.interface) sem.dinit_count = -1; else sem.dinit_count = ad_val_of(sym_of_ast(AD_NUMELM(ad))); entity_id_shared: sptr = SST_SYMG(RHS(1)); if (!(entity_attr.exist & ET_B(ET_BIND))) { sptr = block_local_sym(SST_SYMG(RHS(1))); SST_SYMP(RHS(1), sptr); } if (!sem.kind_type_param && !sem.len_type_param && sem.type_param_candidate) { sem.kind_type_param = sem.type_param_candidate; sem.type_param_candidate = 0; } if (INSIDE_STRUCT) { /* this may be an HPF directive in a derived type */ stsk = &STSK_ENT(0); if (sem.is_hpf && STYPEG(sptr) == ST_MEMBER && ENCLDTYPEG(sptr) == stsk->dtype) { /* do nothing */ } else { if (STYPEG(sptr) != ST_UNKNOWN) SST_SYMP(LHS, (sptr = insert_sym(sptr))); SYMLKP(sptr, NOSYM); STYPEP(sptr, ST_MEMBER); if (!dtypeset) dtype = sem.gdtype; DTYPEP(sptr, dtype); /* must be done before link members */ if (sem.kind_type_param) { USEKINDP(sptr, 1); if (sem.kind_candidate) { /* Save kind expression in component */ mkexpr(sem.kind_candidate->t.stkp); KINDASTP(sptr, SST_ASTG(sem.kind_candidate->t.stkp)); } KINDP(sptr, sem.kind_type_param); } if (sem.len_type_param) { USELENP(sptr, 1); LENP(sptr, sem.len_type_param); } if (sem.len_candidate) { int ty = DTY(DTYPEG(sptr)); if (ty == TY_CHAR || ty == TY_NCHAR) { ast = SST_ASTG((SST *)sem.len_candidate->t.stkp); ty = get_type(2, ty, ast); DTYPEP(sptr, ty); USELENP(sptr, 1); sem.len_candidate = 0; chk_len_parm_expr(ast, stsk->dtype, 1); } } if (DTY(dtype) == TY_ARRAY) { int d; d = DTY(dtype + 1); if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } /* link field-namelist into member list at this level */ link_members(stsk, sptr); if (stype == ST_ARRAY && STSK_ENT(0).type != 'd' && (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))) { error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); } if (stype == ST_ARRAY) { if (entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) { ALLOCP(sptr, 1); } else if (STSK_ENT(0).type == 'd') { /* error message wasn't issued above for derived type. * issue one now */ if (AD_DEFER(ad)) { error(84, 3, gbl.lineno, SYMNAME(sptr), "- deferred shape array must have the POINTER " "or ALLOCATABLE attribute in a derived type"); entity_attr.exist |= ET_B(ET_POINTER); } else if (AD_ASSUMSZ(ad) || AD_ADJARR(ad)) { if (AD_ADJARR(ad)) { int bndast, bnd_sptr, badArray, offset; int numdim = AD_NUMDIM(ad); for (badArray = i = 0; i < numdim; i++) { bndast = AD_LWAST(ad, i); badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0); if (!badArray) { bndast = AD_UPAST(ad, i); badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0); if (!badArray) { ADJARRP(sptr, 1); USELENP(sptr, 1); break; } } } if (badArray) { for (badArray = i = 0; i < numdim; i++) { bndast = AD_LWAST(ad, i); badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0); if (badArray) { badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1); if (!badArray) { ADJARRP(sptr, 1); USELENP(sptr, 1); break; } } if (badArray) { goto illegal_array; } bndast = AD_UPAST(ad, i); badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0); if (badArray) { badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1); if (!badArray) { ADJARRP(sptr, 1); USELENP(sptr, 1); break; } } else if (A_TYPEG(bndast) != A_ID && A_TYPEG(bndast) != A_CNST) { ADJARRP(sptr, 1); USELENP(sptr, 1); if (chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0)) { USEKINDP(sptr, 1); } break; } if (badArray) { goto illegal_array; } } } } else { illegal_array: error(84, 3, gbl.lineno, SYMNAME(sptr), "- array must have constant bounds " "in a derived type"); entity_attr.exist |= ET_B(ET_POINTER); } } } if (DTY(dtype) == TY_ARRAY) { int d; d = DTY(dtype + 1); if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) { error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } } if (DTY(sem.gdtype) == TY_DERIVED && (stsk->type == 'd')) { /* outer derived type has SEQUENCE, nested one should too */ if (SEQG(DTY(stsk->dtype + 3)) && DCLDG(DTY(sem.gdtype + 3)) && !SEQG(DTY(sem.gdtype + 3))) { error(155, 3, gbl.lineno, "SEQUENCE must be set for nested derived type", SYMNAME(DTY(sem.gdtype + 3))); } if (DTY(stsk->dtype + 3) == DTY(sem.gdtype + 3)) { if ((entity_attr.exist & ET_B(ET_POINTER)) == 0) { error(155, 3, gbl.lineno, "Derived type component must " "have the POINTER attribute -", SYMNAME(sptr)); } } else if ((entity_attr.exist & ET_B(ET_POINTER)) == 0 && !DCLDG(DTY(sem.gdtype + 3))) error(155, 4, gbl.lineno, "Derived type has not been declared -", SYMNAME(DTY(sem.gdtype + 3))); } } } else { sptr = create_var(sptr); if (sem.kind_type_param) { USEKINDP(sptr, 1); KINDP(sptr, sem.kind_type_param); } if (sem.len_type_param) { USELENP(sptr, 1); LENP(sptr, sem.len_type_param); } if (DTY(sem.stag_dtype) == TY_DERIVED && sem.class) { /* TBD - Probably need to fix this condition when we * support unlimited polymorphic entities. */ if (SCG(sptr) == SC_DUMMY || entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) { CLASSP(sptr, 1); /* mark polymorphic variable */ if (PASSBYVALG(sptr)) { error(155, 3, gbl.lineno, "Polymorphic variable cannot have VALUE" " attribute -", SYMNAME(sptr)); } if (DTY(sem.stag_dtype) == TY_DERIVED) { int tag = DTY(sem.stag_dtype + 3); if (CFUNCG(tag)) { error(155, 3, gbl.lineno, "Polymorphic variable cannot be declared " "with a BIND(C) derived type - ", SYMNAME(sptr)); } if (SEQG(tag)) { error(155, 3, gbl.lineno, "Polymorphic variable cannot be declared " "with a SEQUENCE derived type - ", SYMNAME(sptr)); } } } else { error(155, 3, gbl.lineno, "Polymorphic variable must be a pointer, " "allocatable, or dummy object - ", SYMNAME(sptr)); } } if (DTY(sem.stag_dtype) == TY_DERIVED && sem.which_pass && !(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) && SCG(sptr) != SC_DUMMY && !FVALG(sptr) && (gbl.rutype != RU_PROG || CONSTRUCTSYMG(sptr))) { add_auto_finalize(sptr); } if (STYPEG(sptr) == ST_PROC && SCOPEG(sptr) && SCOPEG(sptr) == stb.curr_scope && sem.which_pass && gbl.rutype == RU_FUNC) { /* sptr is the ST_PROC for an ENTRY statement to appear later. * make a new sptr */ sptr = insert_sym(sptr); } SST_SYMP(LHS, sptr); stype1 = STYPEG(sptr); /* Assertion: * stype = stype we want to make symbol {ARRAY or IDENT} * stype1 = symbol's current stype */ if (stype == ST_ARRAY) { if (IS_INTRINSIC(stype1)) { /* Changing intrinsic symbol to ARRAY */ if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore type decl */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; } else if (stype1 == ST_ENTRY) { if (DTY(DTYPEG(sptr)) == TY_ARRAY) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } } else if (stype1 == ST_ARRAY) { /* if symbol is already an array, check if the dimension * specifiers are identical. */ ADSC *ad1, *ad2; int ndim; ad1 = AD_DPTR(DTYPEG(sptr)); /* dtype must be set */ assert(dtypeset, "semant: dtype was not set", dtype, 3); ad2 = AD_DPTR(dtype); ndim = AD_NUMDIM(ad1); if (ndim != AD_NUMDIM(ad2)) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } for (i = 0; i < ndim; i++) if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) || AD_UPBD(ad1, i) != AD_UPBD(ad2, i)) break; if (i < ndim) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } //AOCC begin // Removing the following line as it produces duplicate warnings // error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL); //AOCC end } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); break; } DTY(dtype + 1) = DTYPEG(sptr); } else if (IS_INTRINSIC(stype1) && (entity_attr.exist & ET_B(ET_INTRINSIC)) == 0) { /* Changing intrinsic symbol to IDENT in COMMON */ if (IN_MODULE_SPEC || entity_attr.exist || sem.interface) { if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore in COMMON */ break; SST_SYMP(LHS, sptr); /* Cause STYPE and DTYPE to change AFTER fixing dtype */ stype1 = ST_UNKNOWN; dtype = DTYPEG(sptr); dtypeset = 1; } } /* * The symbol's stype and data type can only be changed if * it is new or if the type is changing from an identifier or * structure to an array. The latter can occur because of the * separation of type/record declarations from DIMENSION/COMMON * statements. If the symbol is a record, its stype can change * only if it's an identifier; note, that its dtype will be * set (and checked) by the semantic actions for record. */ if (stype1 == ST_UNKNOWN || (stype == ST_ARRAY && (stype1 == ST_IDENT || stype1 == ST_VAR))) { if (in_entity_typdcl) STYPEP(sptr, ST_IDENT); /* stype will be filled in later*/ /* ...else stype will be set by the actions for */ if (!dtypeset) dtype = sem.gdtype; if (dtype > 0) DTYPEP(sptr, dtype); if (stype == ST_ARRAY) { if ((entity_attr.exist & ET_B(ET_POINTER)) || POINTERG(sptr)) { if (AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); if (SCG(sptr) != SC_DUMMY) ALLOCP(sptr, 1); } else if (AD_ASSUMSZ(ad)) { if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY && SCG(sptr) != SC_BASED) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); ASUMSZP(sptr, 1); SEQP(sptr, 1); } if (AD_ADJARR(ad)) { ADJARRP(sptr, 1); if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY && SCG(sptr) != SC_BASED) error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL); else { /* * mark the adjustable array if the declaration * occurs after an ENTRY statement. */ if (entry_seen) AFTENTP(sptr, 1); } } else if (!(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) && AD_DEFER(ad)) { if (SCG(sptr) == SC_CMBLK) error(43, 3, gbl.lineno, "deferred shape array", SYMNAME(sptr)); if (SCG(sptr) == SC_DUMMY) { mk_assumed_shape(sptr); ASSUMSHPP(sptr, 1); if (sem.arrdim.assumedrank) { ASSUMRANKP(sptr, 1); } if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); } else { if (AD_ASSUMSHP(ad)) { /* this is an error if it isn't a dummy; the * declaration could occur before its entry, so * the check needs to be performed in semfin. */ ASSUMSHPP(sptr, 1); if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); } ALLOCP(sptr, 1); mk_defer_shape(sptr); } } } } else if (stype == ST_ARRAY) { if (stype1 == ST_ENTRY) { if (FVALG(sptr)) { #if DEBUG interr("semant1: trying to set data type of ST_ENTRY", sptr, 3); #endif sptr = FVALG(sptr); } else { error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr)); sptr = insert_sym(sptr); } } if (RESULTG(sptr)) { assert(dtypeset, "semant: dtype was not set (2)", dtype, 3); DTYPEP(sptr, dtype); if ((entity_attr.exist & ET_B(ET_POINTER)) || POINTERG(sptr)) { if (!AD_DEFER(ad) || AD_ASSUMSHP(ad)) error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL); } else if (AD_ASSUMSZ(ad)) { ASUMSZP(sptr, 1); SEQP(sptr, 1); } else if (AD_ADJARR(ad)) ADJARRP(sptr, 1); else if (AD_DEFER(ad)) { mk_assumed_shape(sptr); ASSUMSHPP(sptr, 1); if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) SDSCS1P(sptr, 1); AD_ASSUMSHP(ad) = 1; } copy_type_to_entry(sptr); } } } if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } /* store gdtype, gty so that we can retrieve later to get * dtype for each declared variable, sem.gdtype an sem.gty * may get overwritten if variable is initialized with f2003 * feature. */ SST_GDTYPEP(RHS(1), sem.gdtype); SST_GTYP(RHS(1), sem.gty); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TARGET_LIST1: break; /* * ::= */ case TARGET_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case TARGET1: TARGETP(SST_SYMG(RHS(1)), 1); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case INTERFACE1: push_scope_level(sem.next_unnamed_scope++, SCOPE_INTERFACE); break; /* * ::= */ case INTERFACE2: push_scope_level(sem.next_unnamed_scope++, SCOPE_INTERFACE); if (sem.interf_base[sem.interface - 1].abstract) { error(155, 3, gbl.lineno, "A generic specifier cannot be present in an", "ABSTRACT INTERFACE"); } break; /* ------------------------------------------------------------------ */ /* * ::= INTERFACE | */ case BEGININTERFACE1: i = 0; goto begininterf; /* * ::= ABSTRACT INTERFACE */ case BEGININTERFACE2: i = 1; begininterf: if (IN_MODULE_SPEC && get_seen_contains()) { error(155, 3, gbl.lineno, "Interface-block may not appear in a" " module after the CONTAINS statement unless it is inside" " a module subprogram", CNULL); } NEED(sem.interface + 1, sem.interf_base, INTERF, sem.interf_size, sem.interf_size + 2); save_host(&sem.interf_base[sem.interface]); sem.interf_base[sem.interface].generic = 0; sem.interf_base[sem.interface].operator= 0; sem.interf_base[sem.interface].opval = 0; sem.interf_base[sem.interface].abstract = i; sem.interf_base[sem.interface].hpfdcl = sem.hpfdcl; sem.interface++; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case GENERIC_SPEC1: if (scn.stmtyp != TK_ENDINTERFACE) { /* If we have a previously defined symbol with * same name as a generic type bound procedure, delay declaring * the generic type bound procedure until we process the entire * module (see queue_tbp() function, flag == 3 case for the * call to declsym). */ int oldsptr; sptr = (int)SST_SYMG(RHS(1)); oldsptr = sptr; if (STYPEG(sptr) == ST_TYPEDEF) { sptr = insert_sym(sptr); /* Overloaded type */ } if (!sem.generic_tbp || !STYPEG(sptr) || SCOPEG(sptr) != stb.curr_scope) { if (STYPEG(sptr) == ST_PROC && VTOFFG(sptr) && !sem.generic_tbp) { /* Type bound procedure and generic interface can co-exist */ sptr = insert_sym(sptr); } else if (STYPEG(sptr) && STYPEG(sptr) != ST_USERGENERIC) { sptr = insert_sym(sptr); } else if (STYPEG(sptr) == ST_USERGENERIC && IS_TBP(sptr)) { sptr = insert_sym(sptr); } sptr = declsym(sptr, ST_USERGENERIC, FALSE); if (STYPEG(oldsptr) != ST_TYPEDEF) { /* Check for the case where we overload the * type-name with a binding-name in a type bound procedure. */ int oldsptr2 = oldsptr; for (; STYPEG(oldsptr2) == ST_ALIAS; oldsptr2 = SYMLKG(oldsptr2)) ; if (STYPEG(oldsptr2) == ST_PROC && CLASSG(oldsptr2) && VTOFFG(oldsptr2)) { oldsptr2 = findByNameStypeScope(SYMNAME(oldsptr2), ST_TYPEDEF, SCOPEG(oldsptr2)); } if (STYPEG(oldsptr2) == ST_TYPEDEF) oldsptr = oldsptr2; } if (STYPEG(oldsptr) == ST_TYPEDEF) { GTYPEP(sptr, oldsptr); /* Store overloaded type */ } else { /* Check for overloaded type in scope */ oldsptr = findByNameStypeScope(SYMNAME(oldsptr), ST_TYPEDEF, SCOPEG(sptr)); if (oldsptr) GTYPEP(sptr, oldsptr); } } if (SCOPEG(sptr) != stb.curr_scope) { int oldsptr = sptr; sptr = insert_sym(sptr); STYPEP(sptr, ST_USERGENERIC); SCOPEP(sptr, stb.curr_scope); copy_specifics(oldsptr, sptr); IGNOREP(oldsptr, TRUE); } EXPSTP(sptr, 1); sem.interf_base[sem.interface - 1].generic = sptr; } /*else * SST_SYMP(LHS, SST_SYMG(RHS(1))); */ break; /* * ::= OPERATOR ( ) */ case GENERIC_SPEC2: if (scn.stmtyp != TK_ENDINTERFACE) { sem.interf_base[sem.interface - 1].operator= SST_LSYMG(RHS(3)); sem.interf_base[sem.interface - 1].opval = SST_OPTYPEG(RHS(3)); } else { SST_SYMP(LHS, SST_LSYMG(RHS(3))); } break; /* * ::= ASSIGNMENT ( = ) */ case GENERIC_SPEC3: if (scn.stmtyp != TK_ENDINTERFACE) { sptr = get_intrinsic_opr(OP_ST, 0); sem.interf_base[sem.interface - 1].operator= sptr; sem.interf_base[sem.interface - 1].opval = OP_ST; } else { sptr = get_intrinsic_oprsym(OP_ST, 0); SST_SYMP(LHS, sptr); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case GENERIC_NAME1: break; /* * ::= OPERATOR | */ case GENERIC_NAME2: sptr = getsymbol("operator"); SST_SYMP(LHS, sptr); break; /* * ::= ASSIGNMENT */ case GENERIC_NAME3: sptr = getsymbol("assignment"); SST_SYMP(LHS, sptr); break; /* * ::= ( ) */ case GENERIC_NAME4: i = sem.defined_io_type; if (strcmp(SYMNAME(SST_SYMG(RHS(1))), "read") == 0) { if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "formatted") == 0) { sem.defined_io_type = 1; } else if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "unformatted") == 0) { sem.defined_io_type = 2; } else { error(155, 3, gbl.lineno, "(FORMATTED) or (UNFORMATTED) " "must follow defined READ", CNULL); sem.defined_io_type = 0; } } else if (strcmp(SYMNAME(SST_SYMG(RHS(1))), "write") == 0) { if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "formatted") == 0) { sem.defined_io_type = 3; } else if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "unformatted") == 0) { sem.defined_io_type = 4; } else { error(155, 3, gbl.lineno, "(FORMATTED) or (UNFORMATTED) " "follow defined WRITE", CNULL); sem.defined_io_type = 0; } } else { error(155, 3, gbl.lineno, "Invalid generic specification -", SYMNAME(SST_SYMG(RHS(1)))); sem.defined_io_type = 0; } if (i && sem.defined_io_type && i != sem.defined_io_type) { char *name_cpy; name_cpy = getitem(0, strlen(SYMNAME(SST_SYMG(RHS(1)))) + strlen(SYMNAME(SST_SYMG(RHS(3)))) + 1); sprintf(name_cpy, "%s(%s)", SYMNAME(SST_SYMG(RHS(1))), SYMNAME(SST_SYMG(RHS(3)))); error(155, 3, gbl.lineno, "Generic name for INTERFACE statement " "does not match generic name for END INTERFACE ", name_cpy); } else if (!i && sem.defined_io_type) { sptr = getsymf(".%s", SYMNAME(SST_SYMG(RHS(1)))); IGNOREP(sptr, TRUE); SST_SYMP(LHS, sptr); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPERATOR1: if (scn.stmtyp != TK_ENDINTERFACE) sptr1 = get_intrinsic_opr(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1))); else sptr1 = get_intrinsic_oprsym(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1))); sptr = block_local_sym(sptr1); STYPEP(sptr, STYPEG(sptr1)); SST_IDP(LHS, 1); SST_LSYMP(LHS, sptr); break; /* * ::= . . */ case OPERATOR2: sptr = block_local_sym(SST_SYMG(RHS(2))); STYPEP(sptr, STYPEG(SST_SYMG(RHS(2)))); if (!sem.generic_tbp || !STYPEG(sptr) || SCOPEG(sptr) != stb.curr_scope) { if (STYPEG(sptr) == ST_PROC && VTOFFG(sptr) && !sem.generic_tbp) { /* Type bound procedure and generic operator can co-exist */ sptr = insert_sym(sptr); } sptr = declsym(sptr, ST_OPERATOR, FALSE); } SST_IDP(LHS, 1); SST_LSYMP(LHS, sptr); if (scn.stmtyp == TK_INTERFACE) { char *anm; anm = NULL; if (strcmp(SYMNAME(sptr), "x") == 0) anm = ".x."; else if (strcmp(SYMNAME(sptr), "xor") == 0) anm = ".xor."; else if (strcmp(SYMNAME(sptr), "o") == 0) anm = ".o."; else if (strcmp(SYMNAME(sptr), "n") == 0) anm = ".n."; if (anm) { error(155, 1, gbl.lineno, "Predefined intrinsic operator loses intrinsic property -", anm); } } break; /* * ::= */ case OPERATOR3: sptr = block_local_sym(SST_SYMG(RHS(1))); STYPEP(sptr, STYPEG(SST_SYMG(RHS(1)))); SST_IDP(LHS, 1); SST_LSYMP(LHS, sptr); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case INTRINSIC_OP1: SST_IDP(LHS, 0); SST_LSYMP(LHS, 3); /* unary and binary */ break; /* * ::= | */ case INTRINSIC_OP2: SST_IDP(LHS, 0); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= ** | */ case INTRINSIC_OP3: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_XTOI); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= | */ case INTRINSIC_OP4: break; /* * ::= .OR. | */ case INTRINSIC_OP5: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_LOR); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= .O. | */ case INTRINSIC_OP6: SST_IDP(LHS, TK_ORX); SST_OPTYPEP(LHS, OP_LOR); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= .AND. | */ case INTRINSIC_OP7: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_LAND); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= .NOT. | */ case INTRINSIC_OP8: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_LNOT); SST_LSYMP(LHS, 1); /* unary */ break; /* * ::= .N. | */ case INTRINSIC_OP9: SST_IDP(LHS, TK_NOTX); SST_OPTYPEP(LHS, OP_LNOT); SST_LSYMP(LHS, 1); /* unary */ break; /* * ::= | */ case INTRINSIC_OP10: SST_IDP(LHS, 0); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= '//' */ case INTRINSIC_OP11: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_CAT); SST_LSYMP(LHS, 2); /* binary */ break; /* ------------------------------------------------------------------ */ /* * ::= .EQV. | */ case N_EQV_OP1: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_LEQV); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= .NEQV. | */ case N_EQV_OP2: SST_IDP(LHS, 0); SST_OPTYPEP(LHS, OP_LNEQV); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= .X. | */ case N_EQV_OP3: SST_IDP(LHS, TK_XORX); SST_OPTYPEP(LHS, OP_LNEQV); SST_LSYMP(LHS, 2); /* binary */ break; /* * ::= .XOR. */ case N_EQV_OP4: SST_IDP(LHS, TK_XOR); SST_OPTYPEP(LHS, OP_LNEQV); SST_LSYMP(LHS, 2); /* binary */ break; /* ------------------------------------------------------------------ */ /* * ::= ENDINTERFACE | */ case END_INTERFACE1: rhstop = 1; goto end_interface_shared; /* * ::= ENDINTERFACE */ case END_INTERFACE2: rhstop = 2; end_interface_shared: if (sem.interface == 0) { error(302, 3, gbl.lineno, "INTERFACE", CNULL); SST_ASTP(LHS, 0); break; } if (gbl.currsub) { error(303, 2, gbl.lineno, SYMNAME(gbl.currsub), CNULL); pop_subprogram(); pop_scope_level(SCOPE_NORMAL); } sem.interface--; restore_host(&sem.interf_base[sem.interface], FALSE); sptr = sem.interf_base[sem.interface].generic; if (sptr) check_generic(sptr); else if ((sptr = sem.interf_base[sem.interface].operator)) check_generic(sptr); if (sem.scope_stack[sem.scope_level].kind == SCOPE_INTERFACE) { pop_scope_level(SCOPE_INTERFACE); } if (sptr && rhstop == 2 && !sem.defined_io_type) { sptr1 = SST_SYMG(RHS(2)); if (strcmp(SYMNAME(sptr), SYMNAME(sptr1))) error(309, 3, gbl.lineno, SYMNAME(sptr1), CNULL); } sem.defined_io_type = 0; break; /* * ::= MODULE PROCEDURE | * MODULE PROCEDURE :: */ case MODULE_PROCEDURE_STMT1: rhstop = 3; goto module_procedure_stmt; case MODULE_PROCEDURE_STMT2: rhstop = 4; module_procedure_stmt: if (IN_MODULE && !sem.interface && (itemp = SST_BEGG(RHS(rhstop))) != ITEM_END && itemp->next == ITEM_END) { /* MODULE PROCEDURE - begin separate module subprogram */ sptr = itemp->t.sptr; /* C1548: checking MODULE prefix for subprograms that were declared as separate module procedures */ if (!sem.interface && !SEPARATEMPG(sptr) && !SEPARATEMPG(ref_ident(sptr))) { error(1056, ERR_Severe, gbl.lineno, NULL, NULL); DCLDP(sptr, true); } gbl.currsub = instantiate_interface(sptr); sem.module_procedure = TRUE; gbl.rutype = FVALG(sptr) > NOSYM ? RU_FUNC : RU_SUBR; push_scope_level(sptr, SCOPE_NORMAL); push_scope_level(sptr, SCOPE_SUBPROGRAM); sem.pgphase = PHASE_HEADER; SST_ASTP(LHS, 0); break; } gnr = sem.interf_base[sem.interface - 1].generic; if (gnr == 0) { gnr = sem.interf_base[sem.interface - 1].operator; if (gnr == 0) { error(195, 3, gbl.lineno, "- MODULE PROCEDURE requires a generic INTERFACE", CNULL); break; } } count = 0; for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; itemp = itemp->next) { sptr = itemp->t.sptr; /* Temporarily open the interface scope. */ sem.scope_stack[sem.scope_level].closed = FALSE; if (!IN_MODULE) { sptr = refsym(sptr, OC_OTHER); if (STYPEG(sptr) != ST_PROC) error(195, 3, gbl.lineno, "- Unable to access module procedure", CNULL); if (ENCLFUNCG(sptr) == 0 || STYPEG(ENCLFUNCG(sptr)) != ST_MODULE) { error(454, 3, gbl.lineno, SYMNAME(sptr), CNULL); } } else { if (STYPEG(sptr) == ST_PROC && !sem.which_pass && !INMODULEG(sptr)) { error(454, 3, gbl.lineno, SYMNAME(sptr), CNULL); } sptr = declsym(sptr, ST_MODPROC, FALSE); if (SYMLKG(sptr) == NOSYM) SYMLKP(sptr, 0); /* rescope modproc to 'module' scope */ SCOPEP(sptr, sem.scope_stack[sem.scope_level - 1].sptr); i = add_symitem(gnr, SYMIG(sptr)); SYMIP(sptr, i); } /* Reclose the interface scope. */ sem.scope_stack[sem.scope_level].closed = TRUE; add_overload(gnr, sptr); if (STYPEG(SCOPEG(sptr)) == ST_MODULE) { /* make sure we include module name when generating * the symbol name. */ INMODULEP(sptr, 1); } if (bind_attr.altname && (++count > 1)) error(280, 2, gbl.lineno, "BIND: allowed only in module", 0); if (bind_attr.exist != -1) { process_bind(sptr); } } bind_attr.exist = -1; bind_attr.altname = 0; break; /* * ::= PROCEDURE | * PROCEDURE :: */ case PROCEDURE_STMT1: rhstop = 2; goto procedure_stmt; case PROCEDURE_STMT2: rhstop = 3; procedure_stmt: if (sem.interface == 0) { error(155, 3, gbl.lineno, "PROCEDURE must appear in an INTERFACE", CNULL); break; } gnr = sem.interf_base[sem.interface - 1].generic; if (gnr == 0) { gnr = sem.interf_base[sem.interface - 1].operator; if (gnr == 0) { error(195, 3, gbl.lineno, "- PROCEDURE requires a generic INTERFACE", CNULL); break; } } count = 0; for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; itemp = itemp->next) { sptr = itemp->t.sptr; /* Temporarily open the interface scope. */ sem.scope_stack[sem.scope_level].closed = FALSE; sptr = refsym(sptr, OC_OTHER); if (STYPEG(sptr) != ST_PROC) { if (STYPEG(sptr) == ST_USERGENERIC) { sptr = insert_sym(sptr); } sptr = declsym(sptr, ST_PROC, FALSE); if (SYMLKG(sptr) == NOSYM) SYMLKP(sptr, 0); /* rescope proc to 'host' scope */ SCOPEP(sptr, sem.scope_stack[sem.scope_level - 1].sptr); i = add_symitem(gnr, SYMIG(sptr)); SYMIP(sptr, i); } /* Reclose the interface scope. */ sem.scope_stack[sem.scope_level].closed = TRUE; add_overload(gnr, sptr); } bind_attr.exist = -1; bind_attr.altname = 0; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case USE1: add_use_stmt(); break; /* * ::= , | */ case USE2: break; /* * ::= , : | */ case USE3: /* fall thru */ /* * ::= , : */ case USE4: np = scn.id.name + SST_CVALG(RHS(3)); if (sem_strcmp(np, "only") != 0) error(34, 3, gbl.lineno, np, CNULL); break; /* ------------------------------------------------------------------ */ /* * * ::= , :: | */ case GET_MODULE2: sptr = SST_SYMG(RHS(4)); /* Undo context sensitive scanner confusion. This is a use statement, even though it contains a TK_INTRINSIC token This allows us to move into PHASE_USE. */ if ((scn.stmtyp == TK_INTRINSIC) || (scn.stmtyp == TK_NON_INTRINSIC)) scn.stmtyp = TK_USE; /* check and enable ISO_C_BINDING INTRINSICS HERE? */ if (SST_IDG(RHS(2))) { /* use, intrinsic :: the only one we support is iso_c_binding */ } else { if (strcmp(SYMNAME(sptr), "iso_c_binding") == 0) error(4, 3, gbl.lineno, "invalid non-intrinsic module", SYMNAME(sptr)); } goto common_module; break; /* * ::= :: */ case GET_MODULE3: sptr = SST_SYMG(RHS(2)); goto common_module; break; /* * ::= | */ case GET_MODULE1: sptr = SST_SYMG(RHS(1)); common_module: sem.use_seen = 1; init_use_stmts(); if (XBIT(68, 0x1)) { /* Append "_la" to the names of some modules. */ static const char *names[] = {"ieee_exceptions", "ieee_arithmetic", "cudafor", "openacc", "accel_lib", NULL}; int j; for (j = 0; names[j]; ++j) { if (strcmp(SYMNAME(sptr), names[j]) == 0) { sptr = getsymf("%s", SYMNAME(sptr)); break; } } } if (IN_MODULE && strcmp(SYMNAME(sem.mod_sym), SYMNAME(sptr)) == 0) { error(4, 3, gbl.lineno, "MODULE cannot contain USE of itself -", SYMNAME(sptr)); break; } if (sptr >= stb.firstusym && STYPEG(sptr) != ST_UNKNOWN && STYPEG(sptr) != ST_MODULE) { int nsptr; /* see if this is really an error, or just an overloaded symbol */ nsptr = sym_in_scope(sptr, stb.ovclass[ST_MODULE], NULL, NULL, 0); if (nsptr > 0 && (nsptr < stb.firstusym || STYPEG(nsptr) == ST_UNKNOWN || STYPEG(nsptr) == ST_MODULE)) { sptr = nsptr; } else { sptr = insert_sym(sptr); } } open_module(sptr); break; /* ------------------------------------------------------------------ */ /* * ::= INTRINSIC | */ case MODULE_NATURE1: SST_IDP(LHS, 1); break; /* * ::= NON_INTRINSIC */ case MODULE_NATURE2: SST_IDP(LHS, 0); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case RENAME_LIST1: break; /* * ::= */ case RENAME_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= '=>' | */ case RENAME1: add_use_stmt(); sptr = SST_SYMG(RHS(3)); sptr = add_use_rename((int)SST_SYMG(RHS(1)), sptr, 0); SST_SYMP(RHS(3), sptr); break; /* * ::= ( ) '=>' ( ) */ case RENAME2: add_use_stmt(); np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "operator") == 0) { np = scn.id.name + SST_CVALG(RHS(6)); if (sem_strcmp(np, "operator")) { error(34, 3, gbl.lineno, np, CNULL); break; } } else { error(34, 3, gbl.lineno, np, CNULL); break; } /* local (RHS(3)) => global (RHS(8)) */ sptr = add_use_rename(SST_SYMG(RHS(3)), SST_SYMG(RHS(8)), 1); break; /* ------------------------------------------------------------------ */ /* * ::= . . | */ case RENAME_OPERATOR1: SST_SYMP(LHS, SST_SYMG(RHS(2))); break; /* * ::= */ case RENAME_OPERATOR2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ONLY_LIST1: break; /* * ::= */ case ONLY_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ONLY1: sptr = SST_SYMG(RHS(1)); sptr = add_use_rename(0, sptr, 0); SST_SYMP(RHS(1), sptr); break; /* * ::= '=>' | */ case ONLY2: sptr = SST_SYMG(RHS(3)); sptr = add_use_rename((int)SST_SYMG(RHS(1)), sptr, 0); SST_SYMP(RHS(3), sptr); break; /* * ::= ( ) | */ case ONLY3: np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "operator") == 0) { sptr = add_use_rename(0, SST_SYMG(RHS(3)), 1); SST_SYMP(RHS(3), sptr); } else error(34, 3, gbl.lineno, np, CNULL); break; /* * ::= ( = ) */ case ONLY4: np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "assignment") == 0) { sptr = get_intrinsic_oprsym(OP_ST, 0); add_use_rename(0, sptr, 1); } else error(34, 3, gbl.lineno, np, CNULL); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ONLY_OPERATOR1: sptr = get_intrinsic_oprsym(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1))); SST_SYMP(LHS, sptr); break; /* * ::= . . | */ case ONLY_OPERATOR2: SST_SYMP(LHS, SST_SYMG(RHS(2))); break; /* * ::= */ case ONLY_OPERATOR3: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TP_LIST1: rhstop = 3; goto add_tp_to_list; /* * ::= */ case TP_LIST2: rhstop = 1; add_tp_to_list: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(rhstop)); if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case TP_ITEM1: break; /* * ::= */ case TP_ITEM2: sptr = refsym(SST_SYMG(RHS(1)), OC_OTHER); SST_SYMP(LHS, sptr); break; /* ------------------------------------------------------------------ */ /* * ::= ATTRIBUTES :: | */ case DEC_DECLARATION1: for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) { int da_bitv; sptr = itemp->t.sptr; if (sptr == 0) continue; if (STYPEG(sptr) != ST_CMBLK) sptr = refsym_inscope(sptr, OC_OTHER); da_type = 0; for (da_bitv = dec_attr.exist; da_bitv; da_bitv >>= 1, da_type++) { if ((da_bitv & 1) == 0) continue; switch (da_type) { case DA_ALIAS: #if defined(TARGET_WIN) /* silently disallow ALIAS of winmain : it conflicts with our crt0.obj glue */ if (strcmp(SYMNAME(sptr), "winmain") == 0) break; #endif ALTNAMEP(sptr, dec_attr.altname); goto global_attrs; case DA_C: CFUNCP(sptr, 1); STDCALLP(sptr, 1); /* args must be passed by value */ if (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY) { MSCALLP(sptr, 0); } goto global_attrs; case DA_STDCALL: STDCALLP(sptr, 1); #ifdef CREFP CREFP(sptr, 0); MSCALLP(sptr, 1); #endif goto global_attrs; case DA_REFERENCE: if ((STYPEG(sptr) == ST_ENTRY) || (STYPEG(sptr) == ST_PROC)) ss = sptr; else ss = gbl.currsub; PASSBYVALP(sptr, 0); PASSBYREFP(sptr, 1); #ifdef CREFP if (CFUNCG(sptr)) { MSCALLP(sptr, 0); CREFP(sptr, 1); } #endif goto global_attrs; case DA_VALUE: if ((STYPEG(sptr) == ST_ENTRY) || (STYPEG(sptr) == ST_PROC)) ss = sptr; else ss = gbl.currsub; PASSBYVALP(sptr, 1); PASSBYREFP(sptr, 0); goto global_attrs; case DA_DLLEXPORT: if (IN_MODULE && sem.interface == 0 && STYPEG(sptr) != ST_CMBLK) { sem.mod_dllexport = TRUE; if (sptr == gbl.currmod) break; } else { DLLP(sptr, DLL_EXPORT); } goto global_attrs; case DA_DLLIMPORT: DLLP(sptr, DLL_IMPORT); goto global_attrs; case DA_DECORATE: DECORATEP(sptr, 1); goto global_attrs; case DA_NOMIXEDSLA: #ifdef CREFP NOMIXEDSTRLENP(sptr, 1); #endif /* fall thru */ global_attrs: switch (STYPEG(sptr)) { case ST_CMBLK: case ST_ENTRY: case ST_PROC: case ST_UNKNOWN: /* allow undeclared identifiers */ break; case ST_IDENT: case ST_VAR: case ST_ARRAY: case ST_STRUCT: if (da_type == DA_DLLEXPORT) { if (IN_MODULE && sem.interface == 0) { if ((SCG(sptr) == SC_CMBLK && !HCCSYMG(CMBLKG(sptr))) || SCOPEG(sptr) != gbl.currmod) { error(84, 3, gbl.lineno, SYMNAME(sptr), "- ATTRIBUTES items must be global"); } break; } } else if ((da_type == DA_VALUE) || (da_type == DA_REFERENCE)) { break; } /* fall thru */ default: error(84, 3, gbl.lineno, SYMNAME(sptr), "- must be defined for ATTRIBUTES"); } break; default: break; } } } dec_attr.exist = 0; break; /* * ::= ALIAS , */ case DEC_DECLARATION2: /* * ::= ALIAS : */ case DEC_DECLARATION3: sptr = refsym_inscope((int)SST_SYMG(RHS(2)), OC_OTHER); ALTNAMEP(sptr, SST_SYMG(RHS(4))); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case MSATTR_LIST1: /* fall thru */ /* * ::= */ case MSATTR_LIST2: if (da_type == -1) break; if (dec_attr.exist & DA_B(da_type)) error(134, 3, gbl.lineno, "- duplicate", da[da_type].name); else if (dec_attr.exist & da[da_type].no) error(134, 3, gbl.lineno, "- conflict with", da[da_type].name); else dec_attr.exist |= DA_B(da_type); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case MSATTR1: da_type = -1; np = scn.id.name + SST_CVALG(RHS(1)); if (strcmp(np, "alias") == 0) { error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np); } else if (strcmp(np, "c") == 0) da_type = DA_C; else if (strcmp(np, "stdcall") == 0) da_type = DA_STDCALL; else if (sem_strcmp(np, "dllexport") == 0) da_type = DA_DLLEXPORT; else if (sem_strcmp(np, "dllimport") == 0) da_type = DA_DLLIMPORT; else if (sem_strcmp(np, "value") == 0) da_type = DA_VALUE; else if (sem_strcmp(np, "reference") == 0) da_type = DA_REFERENCE; else if (sem_strcmp(np, "decorate") == 0) da_type = DA_DECORATE; else if (sem_strcmp(np, "nomixed_str_len_arg") == 0) da_type = DA_NOMIXEDSLA; else error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np); break; /* * ::= : */ case MSATTR2: da_type = -1; np = scn.id.name + SST_CVALG(RHS(1)); if (strcmp(np, "alias") == 0) { da_type = DA_ALIAS; dec_attr.altname = SST_SYMG(RHS(3)); } else error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ALT_NAME1: break; /* * ::= */ case ALT_NAME2: /* NEED TO UPCASE the name */ for (np = scn.id.name + SST_CVALG(RHS(1)); (i = *np); np++) { if (i >= 'a' && i <= 'z') *np = i + ('A' - 'a'); } np = scn.id.name + SST_CVALG(RHS(1)); sptr = getstring(np, strlen(np)); SST_SYMP(LHS, sptr); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case CMN_IDENT_LIST1: rhstop = 3; goto add_cmn_to_list; /* * ::= */ case CMN_IDENT_LIST2: rhstop = 1; add_cmn_to_list: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = SST_SYMG(RHS(rhstop)); if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case CMN_IDENT1: sptr = SST_SYMG(RHS(1)); if (sem.which_pass && CMEMFG(sptr) == 0) error(38, 3, gbl.lineno, SYMNAME(sptr), CNULL); break; /* * ::= */ case CMN_IDENT2: sptr = SST_SYMG(RHS(1)); if (STYPEG(sptr) == ST_CMBLK) { sptr = refsym(sptr, OC_OTHER); SST_SYMP(LHS, sptr); } break; /* ------------------------------------------------------------------ */ /* * ::= LOCAL ( ) | */ case PRAGMA_DECLARATION1: break; /* * ::= | */ case PRAGMA_DECLARATION2: if (!sem.interface && !(IN_MODULE && gbl.currsub)) { error(155, 3, gbl.lineno, "IGNORE_TKR can only appear in an interface body" " or a module procedure", CNULL); } break; /* * ::= DEFAULTKIND | */ case PRAGMA_DECLARATION3: break; /* * ::= MOVEDESC */ case PRAGMA_DECLARATION4: #if defined(MVDESCP) np = scn.id.name + SST_CVALG(RHS(3)); if (gbl.currsub && sem_strcmp(np, SYMNAME(gbl.currsub)) == 0) { MVDESCP(gbl.currsub, 1); } #endif break; /* ------------------------------------------------------------------ */ /* * ::= IGNORE_TKR | */ case IGNORE_TKR1: if (sem.interface || (IN_MODULE && gbl.currsub)) { /* must be in interface -- if not, an error will be reported* later */ count = PARAMCTG(gbl.currsub); i = DPDSCG(gbl.currsub); while (count--) { sptr = *(aux.dpdsc_base + i + count); /* IGNORE_TKR_ALL includes all of the IGNORE_ values plus * an indicater except for IGNORE_C */ IGNORE_TKRP(sptr, IGNORE_TKR_ALL); } } break; /* * ::= IGNORE_TKR */ case IGNORE_TKR2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TKR_ID_LIST1: break; /* * ::= */ case TKR_ID_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case TKR_ID1: sptr = refsym(SST_SYMG(RHS(2)), OC_OTHER); if (sem.interface || (IN_MODULE && gbl.currsub)) { /* must be in interface -- if not, an error will be reported* later */ if (SCG(sptr) == SC_DUMMY) IGNORE_TKRP(sptr, IGNORE_TKRG(sptr) | SST_CVALG(RHS(1))); else error(134, 3, gbl.lineno, "- IGNORE_TKR specified for nondummy argument", SYMNAME(sptr)); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case TKR_SPEC1: /* NOT IGNORE_C */ SST_CVALP(LHS, IGNORE_T | IGNORE_K | IGNORE_R | IGNORE_D | IGNORE_M); break; /* * ::= ( ) */ case TKR_SPEC2: np = scn.id.name + SST_CVALG(RHS(2)); conval = 0; count = strlen(np); for (i = 0; i < count; i++) { switch (np[i]) { case 't': case 'T': conval |= IGNORE_T; break; case 'k': case 'K': conval |= IGNORE_K; break; case 'r': case 'R': conval |= IGNORE_R; break; case 'a': case 'A': conval |= IGNORE_TKR_ALL; break; case 'd': case 'D': conval |= IGNORE_D; break; case 'm': case 'M': conval |= IGNORE_M; break; case 'c': case 'C': conval |= IGNORE_C; break; default: error(155, 3, gbl.lineno, "Illegal IGNORE_TKR specifier", CNULL); conval = 0; goto end_tkr_spec; } } end_tkr_spec: SST_CVALP(LHS, conval); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case DFLT1: #ifdef DFLTP if (gbl.currsub) { DFLTP(gbl.currsub, 1); } #endif break; /* * ::= ( ) */ case DFLT2: #ifdef DFLTP for (itemp = SST_BEGG(RHS(2)); itemp != ITEM_END; itemp = itemp->next) { sptr = getocsym(itemp->t.sptr, OC_OTHER, FALSE); if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) { DFLTP(sptr, 1); } } #endif break; /* ------------------------------------------------------------------ */ /* * ::= IMPORT | */ case IMPORT1: if (!sem.interface) { error(155, 3, gbl.lineno, "IMPORT can only appear in an interface body", CNULL); } else { sem.seen_import = TRUE; } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_IMPORT1: if (sem.interface) { /* * The current context is: * interface * ... * subroutine/function ... * IMPORT * end subroutine/function * ... * end interface * * There should be three scope entries corresponding to this * context: * * scope_level-2 : SCOPE_INTERFACE * scope_level-1 : SCOPE_NORMAL * scope_level : SCOPE_SUBPROGRAM * * For IMPORT without a list, open the SCOPE_NORMAL to make host * symbols visible. */ for (i = sem.scope_level - 1; i >= 4; i--) { if (sem.scope_stack[i].kind == SCOPE_NORMAL) { sem.scope_stack[i].closed = FALSE; break; } } } break; /* * ::= */ case OPT_IMPORT2: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case IMPORT_NAME_LIST1: break; /* * ::= */ case IMPORT_NAME_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= */ case IMPORT_NAME1: if (sem.interface) { /* * The current context is: * interface * ... * subroutine/function ... * IMPORT xxxx * end subroutine/function * ... * end interface * * There should be three scope entries corresponding to this * context: * * scope_level-2 : SCOPE_INTERFACE * scope_level-1 : SCOPE_NORMAL * scope_level : SCOPE_SUBPROGRAM * * add the host-associcated symbols to the import list of * the SCOPE_NORMAL entry. */ sem_import_sym(SST_SYMG(RHS(1))); } break; /* ------------------------------------------------------------------ */ /* * ::= */ case PROCEDURE_DECLARATION1: entity_attr.exist = 0; bind_attr.exist = -1; bind_attr.altname = 0; break; /* ------------------------------------------------------------------ */ /* * ::= PROCEDURE ( ) */ case PROCEDURE1: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case PROC_INTERF1: sem.gdtype = -1; proc_interf_sptr = 0; break; /* * ::= | */ case PROC_INTERF2: proc_interf_sptr = resolve_sym_aliases(SST_SYMG(RHS(1))); break; /* * ::= */ case PROC_INTERF3: proc_interf_sptr = 0; break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_PROC_ATTR1: break; /* * ::= , */ case OPT_PROC_ATTR2: if ((entity_attr.exist & ET_B(ET_PROTECTED)) && !(entity_attr.exist & ET_B(ET_POINTER))) error(134, 3, gbl.lineno, et[ET_PROTECTED].name, "for procedure"); break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case PROC_ATTR_LIST1: /* * ::= */ case PROC_ATTR_LIST2: if (entity_attr.exist & ET_B(et_type)) error(134, 3, gbl.lineno, "- duplicate", et[et_type].name); if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) { if (ET_B(et_type) & ~(ET_B(ET_POINTER) | ET_B(ET_PASS) | ET_B(ET_NOPASS) | ET_B(ET_ACCESS))) { error(134, 3, gbl.lineno, et[et_type].name, "for procedure component"); } else entity_attr.exist |= ET_B(et_type); } else { if (ET_B(et_type) & ~(ET_B(ET_ACCESS) | ET_B(ET_BIND) | ET_B(ET_INTENT) | ET_B(ET_OPTIONAL) | ET_B(ET_POINTER) | ET_B(ET_SAVE) | ET_B(ET_PROTECTED))) error(134, 3, gbl.lineno, et[et_type].name, "for procedure"); else entity_attr.exist |= ET_B(et_type); } break; /* ------------------------------------------------------------------ */ /* * ::= | */ case PROC_ATTR1: et_type = ET_ACCESS; break; /* * ::= BIND | */ case PROC_ATTR2: et_type = ET_BIND; break; /* * ::= | */ case PROC_ATTR3: et_type = ET_INTENT; break; /* * ::= OPTIONAL | */ case PROC_ATTR4: et_type = ET_OPTIONAL; break; /* * ::= POINTER | */ case PROC_ATTR5: et_type = ET_POINTER; break; /* * ::= SAVE | */ case PROC_ATTR6: et_type = ET_SAVE; break; /* * ::= PASS | */ case PROC_ATTR7: et_type = ET_PASS; entity_attr.pass_arg = 0; /* PASS without argname */ break; /* * ::= PASS ( ) | */ case PROC_ATTR8: et_type = ET_PASS; entity_attr.pass_arg = SST_SYMG(RHS(3)); /* PASS with argname */ break; /* * ::= NOPASS | */ case PROC_ATTR9: et_type = ET_NOPASS; break; /* * ::= PROTECTED */ case PROC_ATTR10: et_type = ET_PROTECTED; break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case PROC_DCL_LIST1: break; /* * ::= */ case PROC_DCL_LIST2: break; /* * ::= '=>' */ case PROC_DCL3: sptr = SST_SYMG(RHS(3)); sem.proc_initializer = true; // AOCC begin if (INMODULEG(SST_SYMG(RHS(3)))) { sptr = SST_SYMG(RHS(1)); sem.proc_initializer = true; sptr = decl_procedure_sym(sptr, proc_interf_sptr, entity_attr.exist); sptr = setup_procedure_sym(sptr, proc_interf_sptr, entity_attr.exist, entity_attr.access); if (!TYPDG(sptr)) { TYPDP(sptr, 1); if (SCG(sptr) == SC_DUMMY) { IS_PROC_DUMMYP(sptr, 1); } } sem.dinit_data = FALSE; inited = TRUE; SST_IDP(RHS(3), S_IDENT); get_static_descriptor(sptr); get_all_descriptors(sptr); if (POINTERG(sptr) && (!IN_MODULE_SPEC)) { ast = assign_pointer(RHS(1), RHS(3)); add_stmt(ast); SST_ASTP(RHS(1), ast); goto entity_decl_end; } break; } // AOCC end goto proc_dcl_init; /* ------------------------------------------------------------------ */ /* * ::= | */ case PROC_DCL1: inited = FALSE; goto proc_dcl_shared; /* * ::= '=>' ( ) */ case PROC_DCL2: sptr = SST_SYMG(RHS(3)); if (sptr <= NOSYM || strcmp(SYMNAME(sptr),"null") != 0) { errsev(87); } proc_dcl_init: sptr = refsym(sptr, OC_OTHER); SST_SYMP(RHS(3), sptr); SST_IDP(RHS(3), S_IDENT); sem.dinit_data = TRUE; (void)mkvarref(RHS(3), ITEM_END); sem.dinit_data = FALSE; inited = TRUE; proc_dcl_shared: sptr = SST_SYMG(RHS(1)); { /* Hide, so we can modify attribute list without exposing it */ int attr = entity_attr.exist; if (!POINTERG(sptr) && !(attr & ET_B(ET_POINTER)) && proc_interf_sptr > NOSYM && SCG(sptr) != SC_DUMMY) { /* Check to see if we have a dummy argument with a name that overloads * another symbol name (such as a procedure name). */ SPTR sym; get_next_hash_link(sptr, 0); while ((sym = get_next_hash_link(sptr, 2)) > NOSYM) { if (!POINTERG(sym) && SCG(sym) == SC_DUMMY && SCOPEG(sym) == stb.curr_scope) { sptr = sym; break; } } } if (!POINTERG(sptr) && !(attr & ET_B(ET_POINTER)) && proc_interf_sptr > NOSYM && SCG(sptr) == SC_DUMMY) { IS_PROC_DUMMYP(sptr, 1); } if (POINTERG(sptr)) { attr |= ET_B(ET_POINTER); } if (!IS_PROC_DUMMYG(sptr) && IS_INTERFACEG(proc_interf_sptr) && !IS_PROC_PTR_IFACEG(proc_interf_sptr)) { /* Create a unique symbol for the interface so it does not conflict with * an external procedure symbol. For non-procedure dummy arguments, * we need a unique symbol for the interface in order to preserve * the interface flag (IS_PROC_PTR_IFACE). We need the interface flag in * the back-end so we properly generate the procedure descriptor * actual arguments on the call-site (when we call the procedure pointer). * This is only needed by the LLVM back-end because the bridge uses the * interface to generate the LLVM IR for the actual arguments. */ char * buf; int len; SPTR sym; /* First, let's see if we aleady have a unique interface symbol */ len = strlen(SYMNAME(proc_interf_sptr)) + strlen("iface") + 1; buf = getitem(0, len); sprintf(buf,"%s$iface",SYMNAME(proc_interf_sptr)); sym = findByNameStypeScope(buf, ST_PROC, 0); if (sym > NOSYM && !cmp_interfaces_strict(sym, proc_interf_sptr, 0)) { /* The interface is not compatible. We will now try to find one that * is compatible in the symbol table. */ SPTR sym2 = sym; get_next_hash_link(sym2, 0); while ((sym2=get_next_hash_link(sym2, 1)) > NOSYM) { if (cmp_interfaces_strict(sym2, proc_interf_sptr, 0)) { break; } } sym = sym2; } if (sym <= NOSYM) { /* We don't yet have a unique interface symbol, so create it now */ sym = get_next_sym(SYMNAME(proc_interf_sptr), "iface"); /* Propagate flags from the original symbol to the new symbol */ copy_sym_flags(sym, proc_interf_sptr); HCCSYMP(sym, 1); IS_PROC_PTR_IFACEP(sym, 1); INTERFACEP(sym, 1); } proc_interf_sptr = sym; } sptr = decl_procedure_sym(sptr, proc_interf_sptr, attr); sptr = setup_procedure_sym(sptr, proc_interf_sptr, attr, entity_attr.access); } /* Error while creating proc symbol */ if (sptr == 0) break; SST_SYMP(RHS(1), sptr); stype = STYPEG(sptr); if (inited) { /* check if symbol is data initialized */ if (stype == ST_PROC) { error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL); goto proc_decl_end; } if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) { get_static_descriptor(sptr); get_all_descriptors(sptr); SCP(sptr, SC_BASED); ast = SST_ASTG(RHS(3)); if (A_TYPEG(ast) == A_FUNC) { gen_unique_func_ast(ast, sptr, RHS(3)); } construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1)))); if (!SST_ACLG(RHS(3))) { goto proc_decl_end; } ict = SST_ACLG(RHS(3)); ict->sptr = sptr; /* field/component sptr */ save_struct_init(ict); stsk = &STSK_ENT(0); if (stsk->ict_beg) { (stsk->ict_end)->next = SST_ACLG(RHS(3)); stsk->ict_end = SST_ACLG(RHS(3)); } else { stsk->ict_beg = SST_ACLG(RHS(3)); stsk->ict_end = SST_ACLG(RHS(3)); } } else { /* Data item (not TYPE component) initialization */ /* have * ... :: => NULL() * $p, $o, $sd will be needed */ get_static_descriptor(sptr); get_all_descriptors(sptr); ast = SST_ASTG(RHS(3)); if (A_TYPEG(ast) == A_FUNC) { gen_unique_func_ast(ast, sptr, RHS(3)); } construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1)))); if (!SST_ACLG(RHS(3))) { goto proc_decl_end; } ast = mk_id(sptr); SST_ASTP(RHS(1), ast); SST_DTYPEP(RHS(1), DTYPEG(SST_SYMG(RHS(1)))); SST_SHAPEP(RHS(1), 0); ivl = dinit_varref(RHS(1)); dinit(ivl, SST_ACLG(RHS(3))); } } else if (POINTERG(sptr)) { get_static_descriptor(sptr); get_all_descriptors(sptr); } proc_decl_end: if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER && RESULTG(sptr)) { /* set the type for the entry point as well */ copy_type_to_entry(sptr); } sem.dinit_error = FALSE; break; /* ------------------------------------------------------------------ */ /* * ::= */ case TYPE_BOUND_PROCEDURE1: dtype = /*sem.stag_dtype*/ stsk->dtype; if (SST_FIRSTG(RHS(1)) & 0x2) { /* nopass */ queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_NOPASS); } if (SST_FIRSTG(RHS(1)) & 0x4) { /* non_overridable */ queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_NONOVERRIDABLE); } if (SST_FIRSTG(RHS(1)) & 0x8) { /* deferred */ if (!ABSTRACTG(DTY(dtype + 3))) { error(155, 3, gbl.lineno, "Specifying a deferred type bound procedure in " "non-abstract type", SYMNAME(DTY(dtype + 3))); } if (!sem.tbp_interface) { error(155, 3, gbl.lineno, "Specifying a deferred type bound procedure without" " an interface-name in", SYMNAME(DTY(dtype + 3))); } queue_tbp(sem.tbp_interface, SST_SYMG(RHS(3)), 0, dtype, TBP_DEFERRED); } if (SST_FIRSTG(RHS(1)) & 0x10) { /* private */ queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_PRIVATE); } else if (SST_FIRSTG(RHS(1)) & 0x20) { /* public */ queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_PUBLIC); } if (SST_FIRSTG(RHS(1)) & 0x1) { sptr = SST_LSYMG(RHS(1)); if (sptr) { /* pass */ sptr = getsym(LOCAL_SYMNAME(sptr), strlen(SYMNAME(sptr))); if (STYPEG(sptr) != ST_IDENT || DTYPEG(sptr) != dtype) { sptr = insert_sym(sptr); sptr = declsym(sptr, ST_IDENT, TRUE); DTYPEP(sptr, dtype); SCP(sptr, SC_DUMMY); IGNOREP(sptr, TRUE); } queue_tbp(sptr, SST_SYMG(RHS(3)), 0, dtype, TBP_PASS); } } sem.tbp_interface = 0; break; /* ------------------------------------------------------------------ */ /* * ::= TPROCEDURE */ case TPROCEDURE1: SST_FIRSTP(LHS, SST_FIRSTG(RHS(3))); if (SST_FIRSTG(RHS(3)) & 0x1) SST_LSYMP(LHS, SST_LSYMG(RHS(3))); SST_ASTP(LHS, 0); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_INTERFACE_NAME1: break; /* * ::= ( ) */ case OPT_INTERFACE_NAME2: sem.tbp_interface = SST_SYMG(RHS(2)); dtype = /*sem.stag_dtype*/ stsk->dtype; queue_tbp(SST_SYMG(RHS(2)), 0, 0, dtype, TBP_ADD_INTERFACE); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case OPT_BINDING_ATTR_LIST1: SST_FIRSTP(LHS, 0); SST_LSYMP(LHS, 0); break; /* * ::= , */ case OPT_BINDING_ATTR_LIST2: SST_FIRSTP(LHS, SST_FIRSTG(RHS(2))); if (SST_FIRSTG(RHS(2)) & 0x1) { SST_LSYMP(LHS, SST_LSYMG(RHS(2))); } break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case BINDING_ATTR_LIST1: switch (SST_FIRSTG(RHS(1)) & SST_FIRSTG(RHS(3))) { case 0x1: error(134, 3, gbl.lineno, "- duplicate", "PASS"); break; case 0x2: error(134, 3, gbl.lineno, "- duplicate", "NOPASS"); break; case 0x4: error(134, 3, gbl.lineno, "- duplicate", "NON_OVERRIDABLE"); break; case 0x8: error(134, 3, gbl.lineno, "- duplicate", "DEFERRED"); break; case 0x10: error(134, 3, gbl.lineno, "- duplicate", "PRIVATE"); break; case 0x20: error(134, 3, gbl.lineno, "- duplicate", "PUBLIC"); break; } if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x1) && ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x2)) { error(155, 3, gbl.lineno, "PASS and NOPASS may not appear " "in same type bound procedure", CNULL); } else if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x4) && ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x8)) { error(155, 3, gbl.lineno, "DEFERRED and NON_OVERRIDABLE " "may not appear in same type bound procedure", CNULL); } else if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x10) && ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x20)) { error(155, 3, gbl.lineno, "PRIVATE and PUBLIC " "may not appear in same type bound procedure", CNULL); } SST_FIRSTP(LHS, SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))); if (SST_FIRSTG(RHS(3)) & 0x1 && SST_LSYMG(RHS(3))) SST_LSYMP(RHS(1), SST_LSYMG(RHS(3))); /* * ::= */ case BINDING_ATTR_LIST2: if (SST_FIRSTG(RHS(1)) & 0x1) SST_LSYMP(LHS, SST_LSYMG(RHS(1))); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case BINDING_ATTR1: /* * Not using keywords to enumerate the attributes; may be: * PASS NOPASS NON_OVERRIDABLE DEFERRED PRIVATE PUBLIC */ SST_LSYMP(LHS, 0); np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "pass") == 0) { SST_FIRSTP(LHS, 0x1); } else if (sem_strcmp(np, "nopass") == 0) { SST_FIRSTP(LHS, 0x2); } else if (sem_strcmp(np, "non_overridable") == 0) { SST_FIRSTP(LHS, 0x4); } else if (sem_strcmp(np, "deferred") == 0) { SST_FIRSTP(LHS, 0x8); } else if (sem_strcmp(np, "private") == 0) { SST_FIRSTP(LHS, 0x10); } else if (sem_strcmp(np, "public") == 0) { SST_FIRSTP(LHS, 0x20); } else { error(34, 3, gbl.lineno, np, CNULL); } break; /* * ::= ( ) */ case BINDING_ATTR2: /* * Not using keywords to enumerate the attributes; this must be * PASS ( arg-name ) */ np = scn.id.name + SST_CVALG(RHS(1)); if (sem_strcmp(np, "pass") == 0) { SST_FIRSTP(LHS, 0x1); SST_LSYMP(LHS, SST_SYMG(RHS(3))); } else { error(34, 3, gbl.lineno, np, CNULL); } break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case BINDING_NAME_LIST1: break; /* * ::= */ case BINDING_NAME_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case BINDING_NAME1: rhstop = 1; goto binding_name_common; /* * ::= '=>' */ case BINDING_NAME2: { SPTR tag, sptr3, sptr2, orig_sptr; char *name, *name_cpy, *name_cpy2; DTYPE parent; SPTR sym; int vtoff, len; int stype; if (strcmp(SYMNAME(SST_SYMG(RHS(1))), SYMNAME(SST_SYMG(RHS(3)))) == 0) { rhstop = 1; } else { rhstop = 3; } binding_name_common: tag = DTY(stsk->dtype + 3); orig_sptr = sptr = SST_SYMG(RHS(1)); if (sem.tbp_interface > NOSYM) { sptr2 = sem.tbp_interface; } else { sptr2 = refsym(SST_SYMG(RHS(rhstop)), OC_OTHER); } if (SEPARATEMPG(sptr2)) TBP_BOUND_TO_SMPP(sptr2, TRUE); if (bindingNameRequiresOverloading(sptr)) { sptr = insert_sym(sptr); } parent = DTYPEG(PARENTG(tag)); vtoff = 0; for (sym = get_struct_members(parent); sym > NOSYM; sym = SYMLKG(sym)) { if (is_tbp(sym)) { len = strlen(SYMNAME(BINDG(sym))) + 1; name_cpy = getitem(0, len); strcpy(name_cpy, SYMNAME(BINDG(sym))); name = strstr(name_cpy, "$tbp"); if (name) *name = '\0'; if (strcmp(name_cpy, SYMNAME(sptr)) == 0) { vtoff = VTOFFG(BINDG(sym)); VTOFFP(sptr, vtoff); break; } } } if (rhstop == 1) { if (STYPEG(sptr2) && STYPEG(sptr2) != ST_PROC) { sptr2 = insert_sym(sptr2); } sptr = getsymf("%s$tbp", SYMNAME(sptr)); if (STYPEG(sptr) > 0) { sptr = insert_sym(sptr); } } if (TBPLNKG(sptr) && !eq_dtype2(TBPLNKG(sptr), stsk->dtype, 1)) { sptr3 = insert_sym(sptr); STYPEP(sptr3, STYPEG(sptr)); IGNOREP(sptr3, IGNOREG(sptr)); sptr = sptr3; parent = DTYPEG(PARENTG(tag)); sym = DTY(parent + 1); vtoff = 0; for (sym = get_struct_members(parent); sym > NOSYM; sym = SYMLKG(sym)) { if (CCSYMG(sym) && BINDG(sym)) { len = strlen(SYMNAME(BINDG(sym))) + 1; name_cpy = getitem(0, len); strcpy(name_cpy, SYMNAME(BINDG(sym))); name = strstr(name_cpy, "$tbp"); if (name) *name = '\0'; len = strlen(SYMNAME(sptr)) + 1; name_cpy2 = getitem(0, len); strcpy(name_cpy2, SYMNAME(sptr)); name = strstr(name_cpy2, "$tbp"); if (name) *name = '\0'; if (strcmp(name_cpy, name_cpy2) == 0) { vtoff = VTOFFG(BINDG(sym)); VTOFFP(sptr, vtoff); break; } } } } /* Ignore temporary binding name only if we're overloading * a binding name with a derived type name or if stype is 0. */ if (STYPEG(orig_sptr) != ST_PD && STYPEG(sptr) != ST_PROC) { /* when found a binding name has a parameter attribute, don't ignore it * as we need to export this sptr into a *.mod file. */ if (STYPEG(orig_sptr) != ST_PARAM) IGNOREP(sptr, TRUE); sptr = insert_sym(sptr); sptr = declsym(sptr, ST_PROC, FALSE); IGNOREP(sptr, TRUE); /* Needed for overloading */ } if (vtoff) { VTOFFP(sptr, vtoff); } if (!VTOFFG(tag) && PARENTG(tag) && VTOFFG(PARENTG(tag))) { VTOFFP(tag, VTOFFG(PARENTG(tag))); /*initialize offset*/ } if (!VTOFFG(sptr) && !VTOFFG(tag) && (vtoff = get_vtoff(0, stsk->dtype)) > 0) { /* Set vtable offset based on dtype and its parents */ VTOFFP(sptr, vtoff + 1); VTOFFP(tag, vtoff + 1); CLASSP(sptr, 1); } if (!VTOFFG(sptr)) { /* Give this type bound procedure (tbp) an offset by incrementing * the tag's offset count and storing it in the tbp's PARENT field. */ VTOFFP(tag, VTOFFG(tag) + 1); VTOFFP(sptr, VTOFFG(tag)); CLASSP(sptr, 1); } /* keep track of pass object type in tbp by storing the "least extended" * type extension in TBPLNK field. */ if (!TBPLNKG(sptr)) { TBPLNKP(sptr, /*sem.stag_dtype*/ stsk->dtype); } else if (eq_dtype2(/*DTYPEG*/ (TBPLNKG(sptr)), /*sem.stag_dtype*/ stsk->dtype, 1)) { TBPLNKP(sptr, /*sem.stag_dtype*/ stsk->dtype); } queue_tbp(sptr2, sptr, VTOFFG(sptr), /*sem.stag_dtype*/ stsk->dtype, (rhstop == 1) ? TBP_ADD_SIMPLE : TBP_ADD_IMPL); /* If we pushed the binding name into the symbol table, * we might have to remove it now, as it might be masking * a previous name (e.g., a parameter). */ if (!STYPEG(sptr) || (orig_sptr > NOSYM && HASHLKG(sptr) == orig_sptr && STYPEG(orig_sptr))) { pop_sym(sptr); } } break; /* ------------------------------------------------------------------ */ /* * ::= */ case ACCEL_DECL_BEGIN1: parstuff_init(); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_DECL_LIST1: break; /* * ::= */ case ACCEL_DECL_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= COPYIN ( ) | */ case ACCEL_DECL_ATTR1: break; /* * ::= COPYOUT ( ) | */ case ACCEL_DECL_ATTR2: break; /* * ::= LOCAL ( ) | */ case ACCEL_DECL_ATTR3: break; /* * ::= COPY ( ) | */ case ACCEL_DECL_ATTR4: break; /* * ::= MIRROR ( ) | */ case ACCEL_DECL_ATTR5: break; /* * ::= REFLECTED ( ) | */ case ACCEL_DECL_ATTR6: break; /* * ::= CREATE ( ) | */ case ACCEL_DECL_ATTR7: break; /* * ::= PRESENT ( ) | */ case ACCEL_DECL_ATTR8: break; /* * ::= PCOPY ( ) | */ case ACCEL_DECL_ATTR9: break; /* * ::= PCOPYIN ( ) | */ case ACCEL_DECL_ATTR10: break; /* * ::= PCOPYOUT ( ) | */ case ACCEL_DECL_ATTR11: break; /* * ::= PLOCAL ( ) | */ case ACCEL_DECL_ATTR12: break; /* * ::= PCREATE ( ) | */ case ACCEL_DECL_ATTR13: break; /* * ::= DEVICEPTR ( ) | */ case ACCEL_DECL_ATTR14: break; /* * ::= DEVICE_RESIDENT ( ) | */ case ACCEL_DECL_ATTR15: break; /* * ::= LINK ( ) | */ case ACCEL_DECL_ATTR16: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ACCEL_DECL_DATA_LIST1: accel_decl_data_list1: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->ast = SST_ASTG(RHS(3)); SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* * ::= */ case ACCEL_DECL_DATA_LIST2: accel_decl_data_list2: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->ast = SST_ASTG(RHS(1)); SST_BEGP(LHS, itemp); SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= ( ) | */ case ACCEL_DECL_DATA1: /*###*/ accel_decl_data1: sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER); switch (STYPEG(sptr)) { case ST_ARRAY: itemp = SST_BEGG(RHS(3)); (void)mkvarref(RHS(1), itemp); SST_PARENP(LHS, 0); /* ? */ break; default: error(155, 3, gbl.lineno, "Unknown symbol used in data clause -", SYMNAME(sptr)); break; } break; /* * ::= | */ /*###*/ case ACCEL_DECL_DATA2: accel_decl_data2: sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER); mkident(LHS); SST_SYMP(LHS, sptr); SST_DTYPEP(LHS, DTYPEG(sptr)); SST_ASTP(LHS, mk_id(sptr)); break; /* * ::= | */ case ACCEL_DECL_DATA3: /*###*/ break; /* * ::= */ case ACCEL_DECL_DATA4: sptr = SST_SYMG(RHS(1)); SST_SYMP(LHS, sptr); SST_DTYPEP(LHS, 0); SST_ASTP(LHS, mk_id(sptr)); break; /* ------------------------------------------------------------------ */ /* * ::= ( ) *| */ case ACCEL_MDECL_DATA1: goto accel_decl_data1; /* * ::= */ case ACCEL_MDECL_DATA2: goto accel_decl_data2; /* * ::= */ case ACCEL_MDECL_DATA3: break; /* ------------------------------------------------------------------ */ /* * ::= , *| */ case ACCEL_MDECL_DATA_LIST1: goto accel_decl_data_list1; /* * ::= */ case ACCEL_MDECL_DATA_LIST2: goto accel_decl_data_list2; /* ------------------------------------------------------------------ */ /* * ::= , | */ case ACCEL_DECL_SUB_LIST1: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.stkp = SST_E1G(RHS(3)); SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* * ::= */ case ACCEL_DECL_SUB_LIST2: itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.stkp = SST_E1G(RHS(1)); SST_BEGP(LHS, itemp); SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= GENERIC :: * */ case GENERIC_TYPE_PROCEDURE1: sptr = sem.interf_base[sem.interface - 1].generic; if (!sptr) { sptr = sem.interf_base[sem.interface - 1].operator; sem.generic_tbp = ST_OPERATOR; } else { sem.generic_tbp = ST_USERGENERIC; } switch (SST_FIRSTG(RHS(2))) { case 0x10: i = TBP_CHECK_PRIVATE; /* private */ break; case 0x20: i = TBP_CHECK_PUBLIC; /* public */ break; case 0x0: default: i = TBP_CHECK_CHILD; } for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) { int tag; dtype = stsk->dtype; tag = DTY(dtype + 3); if (!VTOFFG(sptr)) { int vt = VTOFFG(tag); if (!vt && PARENTG(tag) && VTOFFG(PARENTG(tag))) { /* Seed the vtable offset field of derived type tag with its parent's * vtable offset. It will get updated in * ::= '=>' production. */ vt = VTOFFG(PARENTG(tag)); VTOFFP(tag, vt); } /* Set offset of binding name to next offset. */ VTOFFP(sptr, vt + 1); if (STYPEG(sptr) == ST_OPERATOR) { /* Set CLASS flag so we can properly handle its * access in semfin.c do_access(). We don't set it for * ST_USERGENERIC here because a USERGENERIC can overload * a type name (including the type name of the type defining * the generic tbp). */ CLASSP(sptr, 1); } } /* offset needs to be same as overloaded tbp */ queue_tbp(itemp->t.sptr, sptr, VTOFFG(sptr), stsk->dtype, i); } sem.interface--; sem.generic_tbp = 0; sem.defined_io_type = 0; break; /* * ::= | */ case OPT_GEN_ACCESS_SPEC1: SST_FIRSTP(LHS, 0x0); goto gen_access_spec_common; /* * ::= , */ case OPT_GEN_ACCESS_SPEC2: SST_FIRSTP(LHS, SST_FIRSTG(RHS(2))); gen_access_spec_common: sem.generic_tbp = 1; NEED(sem.interface + 1, sem.interf_base, INTERF, sem.interf_size, sem.interf_size + 2); sem.interf_base[sem.interface].generic = 0; sem.interf_base[sem.interface].operator= 0; sem.interf_base[sem.interface].opval = 0; sem.interf_base[sem.interface].abstract = 0; sem.interf_base[sem.interface].hpfdcl = sem.hpfdcl; sem.interface++; break; /* * ::= */ case GEN_ACCESS_SPEC1: np = scn.id.name + SST_CVALG(RHS(1)); sptr = getsymbol(np); if (strcmp(SYMNAME(sptr), "private") == 0) SST_FIRSTP(LHS, 0x10); else if (strcmp(SYMNAME(sptr), "public") == 0) SST_FIRSTP(LHS, 0x20); else error(155, 3, gbl.lineno, "Invalid access specifier in generic" " type bound procedure", CNULL); break; /* ------------------------------------------------------------------ */ /* * ::= : | */ case ACCEL_DECL_SUB1: e1 = (SST *)getitem(sem.ssa_area, sizeof(SST)); SST_IDP(e1, S_TRIPLE); SST_E1P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST))); *(SST_E1G(e1)) = *RHS(1); SST_E2P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST))); *(SST_E2G(e1)) = *RHS(3); SST_E3P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST))); SST_IDP(SST_E3G(e1), S_NULL); SST_E1P(LHS, e1); SST_E2P(LHS, 0); break; /* * ::= */ case ACCEL_DECL_SUB2: e1 = (SST *)getitem(sem.ssa_area, sizeof(SST)); *e1 = *RHS(1); SST_E1P(LHS, e1); SST_E2P(LHS, 0); break; /* ------------------------------------------------------------------ */ /* * ::= | */ case ACCEL_ROUTINE_LIST1: break; /* * ::= GANG | */ case ACCEL_ROUTINE_LIST2: break; /* * ::= WORKER | */ case ACCEL_ROUTINE_LIST3: break; /* * ::= VECTOR | */ case ACCEL_ROUTINE_LIST4: break; /* * ::= SEQ | */ case ACCEL_ROUTINE_LIST5: break; /* * ::= NOHOST | */ case ACCEL_ROUTINE_LIST6: break; /* * ::= BIND ( *) | */ case ACCEL_ROUTINE_LIST7: break; /* * ::= BIND ( ) | */ case ACCEL_ROUTINE_LIST8: break; /* * ::= DEVICE_TYPE ( * ) */ case ACCEL_ROUTINE_LIST9: break; /* * ::= GANG ( *: ) */ case ACCEL_ROUTINE_LIST10: break; /* * ::= EXCLUDE */ case ACCEL_ROUTINE_LIST11: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case DEVTYPE_LIST1: break; /* * ::= */ case DEVTYPE_LIST2: break; /* ------------------------------------------------------------------ */ /* * ::= * | */ case DEVTYPE_ATTR1: break; /* * ::= */ case DEVTYPE_ATTR2: break; /* ------------------------------------------------------------------ */ /* * ::= '=>' */ case GENERIC_BINDING1: sptr = sem.interf_base[sem.interface - 1].generic; if (!sptr) { sptr = sem.interf_base[sem.interface - 1].operator; } TBPLNKP(sptr, stsk->dtype); SST_BEGP(LHS, SST_BEGG(RHS(3))); break; /* ------------------------------------------------------------------ */ /* * ::= */ case GENERIC_BINDING_NAME1: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case GENERIC_BINDING_LIST1: rhstop = 1; goto shared_generic_binding; /* * ::= , */ case GENERIC_BINDING_LIST2: rhstop = 3; shared_generic_binding: sptr = SST_SYMG(RHS(rhstop)); itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = sptr; if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= FINAL */ case FINAL_SUBROUTINES1: if (sem.type_mode < 2) { error(155, 3, gbl.lineno, "a FINAL subroutine statement can only appear" " within the type bound procedure part of a derived type", CNULL); } for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) { int tag; dtype = stsk->dtype; sptr = itemp->t.sptr; queue_tbp(sptr, 0, 0, dtype, TBP_ADD_FINAL); /*queue_tbp(sptr, 0, 0, dtype, TBP_ADD_TO_DTYPE);*/ } break; /* ------------------------------------------------------------------ */ /* * ::= */ case FINAL_LIST2: rhstop = 1; goto shared_final_sub; /* ------------------------------------------------------------------ */ /* * ::= , | */ case FINAL_LIST1: rhstop = 3; shared_final_sub: sptr = SST_SYMG(RHS(rhstop)); itemp = (ITEM *)getitem(0, sizeof(ITEM)); itemp->next = ITEM_END; itemp->t.sptr = sptr; if (rhstop == 1) /* adding first item to list */ SST_BEGP(LHS, itemp); else /* adding subsequent items to list */ SST_ENDG(RHS(1))->next = itemp; SST_ENDP(LHS, itemp); break; /* ------------------------------------------------------------------ */ /* * ::= */ case MP_DECL_BEGIN1: break; /* ------------------------------------------------------------------ */ /* * ::= | */ case MP_DECL1: #ifdef OMP_OFFLOAD_LLVM if(flg.omptarget) { error(1200, ERR_Severe, gbl.lineno, "declare simd", NULL); } #endif break; /* * ::= */ case MP_DECL2: #ifdef OMP_OFFLOAD_LLVM // AOCC Begin #ifndef OMP_OFFLOAD_AMD if(flg.omptarget) { error(1200, ERR_Severe, gbl.lineno, "declare target", NULL); } #endif if(flg.omptarget) { int ast = mk_stmt(A_MP_TARGETDECLARE, 0); (void)add_stmt(ast); } // AOCC End #endif break; // AOCC Begin /* * ::= ( ) | */ case MP_DECL3: break; /* * ::= | */ case MP_DECL4: break; // AOCC End /* * ::= */ case MP_DECL5: break; /* ------------------------------------------------------------------ */ /* * ::= */ case DECLARERED_BEGIN1: if (sem.which_pass == 0) error(155, 2, gbl.lineno, "Unimplemented feature - DECLARE REDUCTION", NULL); sem.ignore_stmt = TRUE; break; /* ------------------------------------------------------------------ */ /* * ::= ( : : ) */ case DECLARE_REDUCTION1: break; /* ------------------------------------------------------------------ */ /* * ::= , | */ case TYPE_LIST1: break; /* * ::= */ case TYPE_LIST2: break; /* ------------------------------------------------------------------ */ default: interr("semant1:bad rednum", rednum, 3); break; } } /** Make a unique func ast with a unique sptr (and name) so we can set its associated pointer field. The unique sptr is a placeholder for the pointer target so it does not conflict with the original ST_PROC symbol. We hold the original pointer target in the PTR_TARGET field. */ static void gen_unique_func_ast(int ast, SPTR sptr, SST *stkptr) { SPTR sym, orig_sym = sym_of_ast(ast); sym = get_next_sym(SYMNAME(orig_sym), "tgt"); STYPEP(sym, STYPEG(orig_sym)); SCP(sym, SCG(orig_sym)); SCOPEP(sym, SC_NONE); ASSOC_PTRP(sym, sptr); PTR_TARGETP(sym, orig_sym); PTR_TARGETP(sptr, orig_sym); DINITP(sym, 1); ast = replace_memsym_of_ast(ast, sym); SST_ASTP(stkptr, ast); if (STYPEG(SCOPEG(orig_sym)) == ST_MODULE) { INMODULEP(orig_sym, 1); } } static void gen_dinit(int sptr, SST *stkptr) { switch (STYPEG(sptr)) { /* change symbol type if necessary */ case ST_UNKNOWN: case ST_IDENT: STYPEP(sptr, ST_VAR); case ST_VAR: case ST_ARRAY: if (SCG(sptr) == SC_NONE) SCP(sptr, SC_LOCAL); if (!dinit_ok(sptr)) return; break; case ST_STAG: case ST_STRUCT: case ST_MEMBER: break; case ST_GENERIC: case ST_INTRIN: case ST_PD: if ((sptr = newsym(sptr)) == 0) /* Symbol frozen as an intrinsic, ignore data initialization */ return; break; default: error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL); return; } if (flg.xref) xrefput(sptr, 'i'); if (SCG(sptr) == SC_DUMMY) { /* Dummy variables may not be initialized */ error(41, 3, gbl.lineno, SYMNAME(sptr), CNULL); sem.dinit_error = TRUE; } if (sem.dinit_count > 0) { errsev(66); sem.dinit_error = TRUE; } /* Call dinit to generate dinit records */ if (INSIDE_STRUCT) { /* In structure so accumulate Initializer Constant Tree * in the structure stack. */ /* Set first constant to point to variable needing init'd */ (SST_CLBEGG(stkptr))->sptr = sptr; stsk = &STSK_ENT(0); if (stsk->ict_beg) { (stsk->ict_end)->next = SST_CLBEGG(stkptr); stsk->ict_end = SST_CLENDG(stkptr); } else { stsk->ict_beg = SST_CLBEGG(stkptr); stsk->ict_end = SST_CLENDG(stkptr); } } else { /* Not in structure so generate dinit records */ if (!sem.dinit_error) { SST tmpsst; VAR *ivl; mkident(&tmpsst); SST_SYMP(&tmpsst, sptr); SST_DTYPEP(&tmpsst, DTYPEG(sptr)); SST_SHAPEP(&tmpsst, 0); SST_ASTP(&tmpsst, mk_id(sptr)); SST_SHAPEP(&tmpsst, A_SHAPEG(SST_ASTG(&tmpsst))); ivl = dinit_varref(&tmpsst); dinit(ivl, SST_CLBEGG(stkptr)); } sem.dinit_error = FALSE; } } static void pop_subprogram(void) { int scope; if (sem.none_implicit) { int i, arg; int *dscptr; dscptr = aux.dpdsc_base + DPDSCG(gbl.currsub); for (i = PARAMCTG(gbl.currsub); i > 0; i--) if ((arg = *dscptr++)) { /* any implicit typing needs to be explicit */ switch (STYPEG(arg)) { case ST_VAR: case ST_ARRAY: DCLCHK(arg); DCLDP(arg, TRUE); break; case ST_PROC: if (FUNCG(arg)) { DCLCHK(arg); DCLDP(arg, TRUE); } break; default: break; } } } if (gbl.rutype == RU_FUNC) { DCLCHK(gbl.currsub); DCLDP(gbl.currsub, TRUE); /* any implicit typing needs to be explicit */ } STYPEP(gbl.currsub, ST_PROC); if (sem.interface && SCG(gbl.currsub) == SC_DUMMY) { /* if this is a interface block definition of a subprogram * for a dummy argument, force it to appear in an external statement */ TYPDP(gbl.currsub, 1); IS_PROC_DUMMYP(gbl.currsub, 1); } /* if this is an interface block for the program we are compiling, * ignore this symbol henceforth */ scope = SCOPEG(gbl.currsub); if (scope && NMPTRG(gbl.currsub) == NMPTRG(scope)) { IGNOREP(gbl.currsub, TRUE); pop_sym(gbl.currsub); } gbl.currsub = 0; gbl.rutype = 0; sem.module_procedure = FALSE; sem.pgphase = PHASE_INIT; symutl.none_implicit = sem.none_implicit = flg.dclchk; seen_implicit = FALSE; seen_parameter = FALSE; } static void set_len_attributes(SST *stkptr, int lvl) { /* lenspec[].kind */ /* 0 - length not present * 1 - constant length * 2 - length is '*' * 3 - length is zero * 4 - length is adjustable * 5 - length is ':' */ /* lenspec[].len */ /* -1 if length not present; * -2 if zero length; * -3 if ':'; * 0 if '*'; * constant value if length is constant; * ast of adjustable length expression. */ if (SST_IDG(stkptr) == 0) { lenspec[lvl].len = SST_SYMG(stkptr); switch (lenspec[lvl].len) { case -1: lenspec[lvl].kind = 0; break; case -2: lenspec[lvl].kind = _LEN_ZERO; break; default: lenspec[lvl].kind = _LEN_CONST; } } else { lenspec[lvl].len = SST_ASTG(stkptr); if (lenspec[lvl].len == 0 && SST_SYMG(stkptr) == -1) { lenspec[lvl].kind = _LEN_DEFER; } else if (lenspec[lvl].len == 0) lenspec[lvl].kind = _LEN_ASSUM; else lenspec[lvl].kind = _LEN_ADJ; } if (lvl == 0 || (lenspec[1].kind == 0 && lenspec[0].kind)) { /* propagate the global length attributes if: * 1. the global attributes are being set, or * 2. the augmented attributes were not present and the global * attributes were present. */ lenspec[1] = lenspec[0]; lenspec[1].propagated = 1; } else { lenspec[lvl].propagated = 0; } } static void set_char_attributes(int sptr, int *pdtype) { int dtype; dtype = *pdtype; if (DTY(dtype) != TY_CHAR && DTY(dtype) != TY_NCHAR) return; if (lenspec[1].kind == _LEN_ADJ) { ADJLENP(sptr, 1); } if (lenspec[1].kind == _LEN_ASSUM) { ASSUMLENP(sptr, 1); } } static void set_aclen(SST *stkptr, int ivl, int flag) { static int kind0, kind1, propagate0, propagate1; static INT len0, len1; if (flag) { len0 = lenspec[0].len; kind0 = lenspec[0].kind; propagate0 = lenspec[0].propagated; len1 = lenspec[1].len; kind1 = lenspec[1].kind; propagate1 = lenspec[1].propagated; lenspec[0].len = 0; lenspec[0].kind = 0; lenspec[0].propagated = 0; lenspec[1].len = 0; lenspec[1].kind = 0; lenspec[1].propagated = 0; set_len_attributes(stkptr, ivl); } else { lenspec[0].len = len0; lenspec[0].kind = kind0; lenspec[0].propagated = propagate0; lenspec[1].len = len1; lenspec[1].kind = kind1; lenspec[1].propagated = propagate1; } } static int get_actype(SST *stkptr, int ivl) { sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[ivl].kind, lenspec[ivl].len, lenspec[ivl].propagated, 0); return sem.gdtype; } static void ctte(int entry, int sptr) { int dtype; ADJARRP(entry, ADJARRG(sptr)); ADJLENP(entry, ADJLENG(sptr)); ALLOCP(entry, ALLOCG(sptr)); ASSUMSHPP(entry, ASSUMSHPG(sptr)); ASUMSZP(entry, ASUMSZG(sptr)); DCLDP(entry, DCLDG(sptr)); DTYPEP(entry, DTYPEG(sptr)); POINTERP(entry, POINTERG(sptr)); F90POINTERP(entry, F90POINTERG(sptr)); SEQP(entry, SEQG(sptr)); /* check that the datatype is a legal function datatype */ dtype = DTYPEG(sptr); if (POINTERG(sptr)) { /* cannot be a character(len=*) */ if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) { error(155, 3, gbl.lineno, "Function result cannot be assumed-length character pointer -", SYMNAME(sptr)); POINTERP(sptr, FALSE); POINTERP(entry, FALSE); } } if (DTY(dtype) == TY_ARRAY) { /* cannot be a character(len=*) */ if (DTY(dtype + 1) == DT_ASSCHAR || DTY(dtype + 1) == DT_ASSNCHAR) { error(155, 3, gbl.lineno, "Function result cannot be assumed-length character array -", SYMNAME(sptr)); DTYPEP(sptr, DTY(dtype + 1)); DTYPEP(entry, DTY(dtype + 1)); dtype = DTY(dtype + 1); } } } /* ctte */ static void copy_type_to_entry(int sptr) { if (RESULTG(sptr)) { if (sem.interface) { /* find the entry symbol in the interface block */ int sl, e; for (sl = sem.scope_level; sl > 0; --sl) { e = sem.scope_stack[sl].sptr; if (STYPEG(e) == ST_ENTRY || STYPEG(e) == ST_PROC) { if (FVALG(e) == sptr) ctte(e, sptr); } if (sem.scope_stack[sl].kind == SCOPE_INTERFACE) break; } for (e = sem.scope_stack[sl].symavl; e < stb.stg_avail; ++e) { if (STYPEG(e) == ST_ENTRY || STYPEG(e) == ST_PROC) { if (FVALG(e) == sptr) ctte(e, sptr); } } } else { int e; /* scan all entries. NOTE: gbl.entries not yet set */ for (e = gbl.currsub; e > NOSYM; e = SYMLKG(e)) { if (FVALG(e) == sptr) ctte(e, sptr); } } } } /* copy_type_to_entry */ static void save_host(INTERF *state) { state->currsub = gbl.currsub; state->rutype = gbl.rutype; state->module_procedure = sem.module_procedure; state->pgphase = sem.pgphase; state->none_implicit = sem.none_implicit; state->seen_implicit = seen_implicit; state->seen_parameter = seen_parameter; state->gnr_rutype = 0; state->nml = sem.nml; gbl.currsub = 0; gbl.rutype = 0; sem.module_procedure = false; sem.pgphase = PHASE_INIT; symutl.none_implicit = sem.none_implicit = flg.dclchk; seen_implicit = FALSE; seen_parameter = FALSE; save_implicit(FALSE); /* save host's implicit state */ } static void restore_host(INTERF *state, LOGICAL keep_implicit) { gbl.currsub = state->currsub; gbl.rutype = state->rutype; sem.module_procedure = state->module_procedure; sem.pgphase = state->pgphase; symutl.none_implicit = sem.none_implicit = state->none_implicit; seen_implicit = state->seen_implicit; seen_parameter = state->seen_parameter; sem.nml = state->nml; restore_implicit(); /* restore host's implicit state */ if (keep_implicit) { save_implicit(TRUE); /* in a contained subprogram, ignore host's implicit/parameter stmts */ seen_implicit = FALSE; seen_parameter = FALSE; } } /* return TRUE if the name on the end is different from the name * of the routine */ static LOGICAL wrong_name(SPTR endname) { if (endname == 0) return FALSE; if (UNAMEG(gbl.currsub)) { /* compare to the original name */ char *uname = stb.n_base + UNAMEG(gbl.currsub); return strcmp(uname, SYMNAME(endname)) != 0; } return strcmp(SYMNAME(gbl.currsub), SYMNAME(endname)) != 0; } /* wrong_name */ /** Reset scopes and related set ups after processing and subroutine */ static void do_end_subprogram(SST *top, RU_TYPE rutype) { fix_iface(gbl.currsub); if (sem.interface && IN_MODULE) { do_iface_module(); } if (sem.which_pass && !sem.interface) { fix_class_args(gbl.currsub); } if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) { queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END); queue_tbp(0, 0, 0, 0, TBP_CLEAR); } defer_pt_decl(0, 0); dummy_program(); check_end_subprogram(rutype, SST_SYMG(RHS(2))); SST_IDP(LHS, 1); /* mark as end of subprogram unit */ if (IN_MODULE && sem.interface == 0) mod_end_subprogram(); pop_scope_level(SCOPE_NORMAL); check_defined_io(); if (!IN_MODULE && !sem.interface) clear_ident_list(); fix_proc_ptr_dummy_args(); sem.seen_import = FALSE; } static void check_end_subprogram(RU_TYPE rutype, int sym) { if (gbl.currsub == 0) { if (sem.pgphase == PHASE_INIT && gbl.internal) { /* end of subprogram containing internal subprograms */ restore_host(&host_state, TRUE); gbl.internal = 0; check_end_subprogram(rutype, sym); end_of_host = gbl.currsub; gbl.currsub = 0; if (sem.which_pass) end_contained(); if (scn.currlab && sem.which_pass == 0) /* The end statement of the host subprogram is labeled. * Save its number for when the host's CONTAINS statement is * processed during the second pass. */ sem.end_host_labno = scn.labno; return; } if (gbl.internal && sem.pgphase == PHASE_END && sem.which_pass == 0) { /* end of module subprogram containing internal subprograms */ restore_host(&host_state, TRUE); gbl.internal = 0; sem.pgphase = PHASE_INIT; return; } error(302, 3, gbl.lineno, name_of_rutype(rutype), CNULL); gbl.internal = 0; } else if (gbl.rutype != rutype) { error(302, 3, gbl.lineno, name_of_rutype(rutype), CNULL); } else if (sym && wrong_name(sym)) error(309, 3, gbl.lineno, SYMNAME(sym), CNULL); enforce_denorm(); } static const char * name_of_rutype(RU_TYPE rutype) { switch (rutype) { case RU_SUBR: return "SUBROUTINE"; case RU_FUNC: return "FUNCTION"; case RU_PROC: return "PROCEDURE"; case RU_PROG: return "PROGRAM"; case RU_BDATA: return "BLOCKDATA"; } return ""; } /* If an intrinsic is declared in a host subprogram and not otherwise used, * convert it to an identifier for the internal subprograms to share. */ static void convert_intrinsics_to_idents() { SPTR sptr; assert(gbl.currsub && gbl.internal == 0, "only applicable for non-internal subprogram", 0, ERR_Severe); for (sptr = NOSYM + 1; sptr < stb.firstusym; ++sptr) { if (DCLDG(sptr) && !EXPSTG(sptr) && IS_INTRINSIC(STYPEG(sptr))) { SPTR new_sptr = newsym(sptr); STYPEP(new_sptr, ST_IDENT); } } } /* * In certain contexts, a new symbol must be created immediately * if the identifier is an intrinsic rather than relying on newsym(). * For example, calling newsym() on a formal argument in an interface * block creates a new symbol as expected, but the effects of the * appearance of the intrinsic name in a type statement in an outer * scope are applied to the new symbol: * integer cos <- sets the DCLD flag of the generic * interface * subroutine sub(cos) * integer cos <- newsym, but generic's DCLD flag is applied * endsubroutine * endinterface * call sub(cos) <- the first type statement no longer applies */ static int chk_intrinsic(int first, LOGICAL now, LOGICAL settype) { int oldsptr; int sptr; sptr = getocsym(first, OC_OTHER, FALSE); if (IS_INTRINSIC(STYPEG(sptr))) { if ((sem.interface && DCLDG(sptr)) || now) { error(35, 1, gbl.lineno, SYMNAME(sptr), CNULL); oldsptr = sptr; sptr = insert_sym(sptr); if (now && settype && DCLDG(oldsptr)) { DTYPEP(sptr, DTYPEG(oldsptr)); DCLDP(sptr, TRUE); } } } return sptr; } /* * Create a ST_ENTRY for a function ENTRY. Must be aware of the situation * where a variable named the same as the entry already exists. */ static int create_func_entry(int sptr) { int func_result = chk_func_entry_result(sptr); if (func_result > NOSYM) { sptr = 0; if (sem.which_pass && IN_MODULE) { /* if in a module, we have already seen the ENTRY during * which_pass == 0; get THAT symbol */ for (sptr = first_hash(func_result); sptr > NOSYM; sptr = HASHLKG(sptr)) { if (NMPTRG(sptr) == NMPTRG(func_result) && STYPEG(sptr) == ST_PROC && FVALG(sptr) == func_result) { break; } if (NMPTRG(sptr) == NMPTRG(func_result) && STYPEG(sptr) == ST_ALIAS && STYPEG(SYMLKG(sptr)) == ST_PROC && SCOPEG(SYMLKG(sptr)) == SCOPEG(func_result)) { break; } } } /* sptr is the old symbol for the entry point, now an ST_PROC */ if (sptr) { int fval; if (STYPEG(sptr) == ST_ALIAS) { fval = FVALG(SYMLKG(sptr)); } else { fval = FVALG(sptr); } if (fval) { STYPEP(fval, ST_UNKNOWN); IGNOREP(fval, TRUE); HIDDENP(fval, TRUE); FVALP(sptr, 0); } } else { /* A variable is already defined in the same scope of * the entry and assume that the variable's declaration * is for the entry. Create a new symbol as the * ST_ENTRY; make the variable found by chk_func_entry_result * the function result of the ST_ENTRY. */ sptr = insert_sym(func_result); } SCP(func_result, SC_DUMMY); RESULTP(func_result, TRUE); pop_sym(func_result); sptr = declsym(sptr, ST_ENTRY, TRUE); DTYPEP(sptr, DTYPEG(func_result)); ADJLENP(sptr, ADJLENG(func_result)); DCLDP(sptr, DCLDG(func_result)); FVALP(sptr, func_result); return sptr; } sptr = declsym(sptr, ST_ENTRY, TRUE); if (SCG(sptr) != SC_NONE) error(43, 3, gbl.lineno, SYMNAME(sptr), CNULL); return sptr; } /* * Create the result variable for a function ENTRY. Must be aware of the * situation where a variable named the same as the 'result' already exists. */ static int create_func_entry_result(int sptr) { int func_result = chk_func_entry_result(sptr); if (func_result > NOSYM) { /* A variable is already defined in the same scope of * the entry and assume that the variable's declaration * is for the entry. Just use the variable as the * result of the entry. */ SCP(func_result, SC_DUMMY); RESULTP(func_result, TRUE); return func_result; } sptr = declsym(sptr, ST_IDENT, TRUE); SCP(sptr, SC_DUMMY); return sptr; } /* * Retrieve/create a variable in the current scope. Must be aware of * the situation where a variable is a function in which case, its * result variable must be used. */ static int create_var(int sym) { int sptr; sptr = refsym_inscope(sym, OC_OTHER); switch (STYPEG(sptr)) { case ST_ENTRY: if (gbl.rutype != RU_FUNC) { error(43, 3, gbl.lineno, "subprogram or entry name", SYMNAME(sptr)); sptr = insert_sym(sptr); } else { /* should we specify the RESULT name? */ if (RESULTG(sptr)) { error(43, 3, gbl.lineno, SYMNAME(sptr), "- you must specify the RESULT name"); } sptr = FVALG(sptr); } break; case ST_MODULE: if (!DCLDG(sptr)) { /* * if the module is indirectly USEd (DCLD is not set) * it's ok to create a new symbol when used. * Otherwise, the module name is stll visible. */ sptr = insert_sym(sptr); } break; default:; } return sptr; } /* * For entries, the variable specified in the result clause or * the variable implied by the entry name may have already been * declared in the same scope; also, the variable may have already * been referenced. Determine if a variable has already been declared * whose name is the same as the entry or the result variable. */ static int chk_func_entry_result(int sptr) { int sptr2; sptr = refsym(sptr, OC_OTHER); switch (STYPEG(sptr)) { case ST_IDENT: case ST_VAR: case ST_ARRAY: switch (SCG(sptr)) { case SC_NONE: case SC_LOCAL: sptr2 = SCOPEG(sptr); if (sptr2 == 0) break; if (STYPEG(sptr2) == ST_ALIAS) sptr2 = SYMLKG(sptr2); if (sptr2 == gbl.currsub) { /* A variable is already defined in the same scope of * the entry and assume that the variable's declaration * is for the entry or the result. */ return sptr; } break; default:; } break; default:; } /* a variable with the same name doesn't exist in the same scope: */ return 0; } static void get_param_alias_const(SST *stkp, int param_sptr, int dtype) { int ast; int alias; INT conval; SST s; ACL *aclp; if (SST_IDG(stkp) == S_EXPR) { aclp = construct_acl_from_ast(SST_ASTG(stkp), dtype, 0); if (sem.dinit_error || !aclp) { return; } aclp = eval_init_expr(aclp); conval = cngcon(aclp->conval, aclp->dtype, dtype); } else if (SST_IDG(stkp) == S_LVALUE && stkp->value.cnval.acl) { construct_acl_for_sst(stkp, dtype); aclp = SST_ACLG(stkp); if (sem.dinit_error || !aclp) { return; } aclp = eval_init_expr(aclp); conval = cngcon(aclp->conval, aclp->dtype, dtype); } else { conval = chkcon(stkp, dtype, FALSE); } CONVAL1P(param_sptr, conval); if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR || dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR) DTYPEP(param_sptr, DTYPEG(CONVAL1G(param_sptr))); alias = mk_cval1(conval, (int)DTYPEG(param_sptr)); CONVAL2P(param_sptr, alias); /* ast of */ if (sem.interface == 0) add_param(param_sptr); /* create an ast for the parameter; set the alias field of the ast * so that we don't have to set the alias field whenever the */ ast = mk_id(param_sptr); A_ALIASP(ast, alias); } /* get the char length from the initialization expression */ static void set_string_type_from_init(int sptr, ACL *init_acl) { int sdtype = DTYPEG(sptr); int ndtype = init_acl->dtype; if (DTY(ndtype) == TY_ARRAY) ndtype = DTY(ndtype + 1); /* get the new char length */ if (DTY(sdtype) == TY_ARRAY) { /* make array type with new char subtype, same bounds */ ndtype = get_type(3, TY_ARRAY, ndtype); DTY(ndtype + 2) = DTY(sdtype + 2); } DTYPEP(sptr, ndtype); } static void fixup_param_vars(SST *var, SST *init) { int sptr; int sptr1; int dtype; ADSC *ad; int sdtype; ACL *aclp; sptr = SST_SYMG(var); PARAMP(sptr, 1); if (SST_IDG(init) == S_EXPR && A_TYPEG(SST_ASTG(init)) == A_INTR && DTY(SST_DTYPEG(init)) == TY_ARRAY) { aclp = construct_acl_from_ast(SST_ASTG(init), SST_DTYPEG(init), 0); dinit_struct_param(sptr, aclp, SST_DTYPEG(init)); sdtype = DTYPEG(sptr); if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR || DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) { set_string_type_from_init(sptr, aclp); } } else if (SST_IDG(init) == S_SCONST) { construct_acl_for_sst(init, SST_DTYPEG(init)); dinit_struct_param(sptr, SST_ACLG(init), SST_DTYPEG(init)); sdtype = DTYPEG(sptr); if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR || DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) { set_string_type_from_init(sptr, SST_ACLG(init)); } } else if (SST_IDG(init) == S_ACONST || (SST_IDG(init) == S_IDENT && (STYPEG(SST_SYMG(init)) == ST_PARAM || PARAMG(SST_SYMG(init))))) { sdtype = DTYPEG(sptr); if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR || DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERCHAR) { set_string_type_from_init(sptr, SST_ACLG(init)); } dinit_struct_param(sptr, SST_ACLG(init), DTYPEG(sptr)); } else if (DTY(DTYPEG(sptr)) == TY_ARRAY && SST_IDG(init) == S_CONST && (DDTG(DTYPEG(sptr)) == DT_ASSCHAR || DDTG(DTYPEG(sptr)) == DT_ASSNCHAR)) { aclp = construct_acl_from_ast(SST_ASTG(init), SST_DTYPEG(init), 0); set_string_type_from_init(sptr, aclp); } else if (DTY(DTYPEG(sptr)) == TY_ARRAY && SST_IDG(init) == S_CONST) { aclp = construct_acl_from_ast(SST_ASTG(init), SST_DTYPEG(init), 0); dinit_struct_param(sptr, aclp, SST_DTYPEG(init)); } if ((STYPEG(sptr) == ST_ARRAY) && SCG(sptr) == SC_NONE && SCOPEG(sptr) == stb.curr_scope) { STYPEP(sptr, ST_PARAM); if (flg.xref) xrefput(sptr, 'd'); } else if (STYPEG(sptr) == ST_VAR && DTY(DTYPEG(sptr)) == TY_ARRAY && SCOPEG(sptr) == stb.curr_scope) { /* HACK: if the named constant being defined has an initializer * that contains an intrinsic call that uses the named constant * as an argument, then the argument handling may have * changed the item's STYPE to ST_VAR when array. Change it back to * an ST_PARAM. */ STYPEP(sptr, ST_PARAM); if (flg.xref) xrefput(sptr, 'd'); } else if (STYPEG(sptr) == ST_VAR && SCOPEG(sptr) == stb.curr_scope && KINDG(sptr)) { /* Overloaded type parameter */ STYPEP(sptr, ST_PARAM); if (flg.xref) xrefput(sptr, 'd'); } else if (STYPEG(sptr) == ST_IDENT && SCOPEG(sptr) == stb.curr_scope) { STYPEP(sptr, ST_PARAM); if (flg.xref) xrefput(sptr, 'd'); } else { sptr = declsym(sptr, ST_PARAM, TRUE); if (SCG(sptr) != SC_NONE) { error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr)); return; } } dtype = DTYPEG(sptr); if (DTY(dtype) == TY_DERIVED) { sptr1 = get_param_alias_var(sptr, dtype); } else if (DTY(dtype) == TY_ARRAY) { ad = AD_DPTR(dtype); if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) { error(84, 3, gbl.lineno, SYMNAME(sptr), "- a named constant array must have constant extents"); return; } sptr1 = get_param_alias_var(sptr, dtype); STYPEP(sptr1, ST_ARRAY); if (sem.interface == 0) { init_named_array_constant(sptr, gbl.currsub); } } else { get_param_alias_const(init, sptr, dtype); sdtype = DTYPEG(sptr); if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR || DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) { set_string_type_from_init(sptr, SST_ACLG(init)); } } } static void save_typedef_init(int sptr, int dtype) { ACL *ict; if (!stsk->ict_beg) { DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */ /* Pop out to parent structure (if any) */ sem.stsk_depth--; stsk = &STSK_ENT(0); return; } if (sem.stsk_depth == 1 && stsk->ict_beg != NULL) { /* This is the outer most structure, fix up top subc ict entry */ ict = GET_ACL(15); ict->id = AC_TYPEINIT; ict->next = NULL; ict->subc = stsk->ict_beg; ict->repeatc = astb.i1; ict->sptr = sptr; ict->dtype = dtype; stsk->ict_beg = ict; } df_dinit(NULL, ict); DTY(dtype + 5) = put_getitem_p(stsk->ict_beg); DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */ /* Pop out to parent structure (if any) */ sem.stsk_depth--; stsk = &STSK_ENT(0); } void build_typedef_init_tree(int sptr, int dtype) { ACL *ict; ACL *ict1; int td_dtype; td_dtype = DDTG(dtype); ict1 = (ACL *)get_getitem_p(DTY(td_dtype + 5)); if (ict1) { /* Need to build an initializer constant tree */ ict = GET_ACL(15); *ict = *ict1; ict->sptr = sptr; if (DTY(DTYPEG(sptr)) == TY_ARRAY) ict->repeatc = AD_NUMELM(AD_PTR(sptr)); else ict->repeatc = astb.i1; if (ict->sptr) save_struct_init(ict); if (INSIDE_STRUCT) { if (stsk->ict_end) stsk->ict_end->next = ict; else stsk->ict_beg = ict; stsk->ict_end = ict; } else { /* For initialized sptr, don't create init list */ if (DINITG(sptr) && DTY(td_dtype) == TY_DERIVED && !SAVEG(sptr)) return; dinit_no_dinitp((VAR *)NULL, ict); } } } static void init_allocatable_typedef_components(SPTR td_sptr) { DTYPE td_dtype = DTYPEG(td_sptr); SPTR sptr = 0; SPTR fld_sptr; ACL *td_aclp; ACL **aclpp; int init_ict = get_struct_initialization_tree(td_dtype); if (init_ict) { td_aclp = get_getitem_p(init_ict); } else { td_aclp = GET_ACL(15); td_aclp->id = AC_TYPEINIT; td_aclp->sptr = td_sptr; td_aclp->dtype = td_dtype; } aclpp = &td_aclp->subc; for (fld_sptr = DTY(td_dtype + 1); fld_sptr > NOSYM; fld_sptr = SYMLKG(fld_sptr)) { ACL *aclp = NULL; DTYPE fld_dtype = DTYPEG(fld_sptr); if (is_array_dtype(fld_dtype)) fld_dtype = array_element_dtype(fld_dtype); /* position the init list ptr */ if (*aclpp) { for (sptr = td_sptr; sptr > NOSYM && sptr != fld_sptr && sptr != (*aclpp)->sptr; sptr = SYMLKG(sptr)) continue; if (sptr == (*aclpp)->sptr) { /* this field already has an initializer */ aclpp = &(*aclpp)->next; continue; } } if (DTY(fld_dtype) == TY_DERIVED && ALLOCFLDG(sptr)) { init_allocatable_typedef_components(fld_sptr); aclp = get_getitem_p(get_struct_initialization_tree(fld_dtype)); } else if (ALLOCATTRG(fld_sptr)) { aclp = mk_init_intrinsic(AC_I_null); } if (aclp) { aclp->sptr = MIDNUMG(fld_sptr); aclp->next = *aclpp; *aclpp = aclp; aclpp = &aclp->next; } } df_dinit(NULL, td_aclp); if (!init_ict) { /* this is the "initialization tree" field */ DTY(td_dtype + 5) = put_getitem_p(td_aclp); } } static void symatterr(int sev, int sptr, char *att) { char buf[100]; snprintf(buf, sizeof buf, "Attribute '%s' cannot be applied to symbol", att); buf[sizeof buf - 1] = '\0'; /* Windows snprintf bug workaround */ error(155, sev, gbl.lineno, buf, SYMNAME(sptr)); } static void fixup_function_return_type(int retdtype, int dtsptr) { dtsptr = lookupsymbol(SYMNAME(dtsptr)); if (dtsptr && dtsptr != DTY(retdtype + 3)) { DTYPEP(gbl.currsub, DTYPEG(dtsptr)); DTYPEP(FVALG(gbl.currsub), DTYPEG(dtsptr)); } else if (sem.pgphase > PHASE_SPEC) { error(4, 3, FUNCLINEG(gbl.currsub), "Function return type has not been declared", CNULL); DTYPEP(gbl.currsub, DTYPEG(dtsptr)); DTYPEP(FVALG(gbl.currsub), DTYPEG(dtsptr)); } } static int fixup_KIND_expr(int ast) { int newast = ast; int tmp_ast1 = 0; int tmp_ast2 = 0; int sptr; int newsptr; int ndim; int subs[MAXRANK]; int argt; int i; int changed; float f; switch (A_TYPEG(ast)) { case A_CNST: if (DT_ISREAL(A_DTYPEG(ast))) { newast = mk_convert(ast, DT_INT); } break; case A_SUBSCR: /* NECESSARY? */ sptr = A_SPTRG(A_LOPG(ast)); ndim = ADD_NUMDIM(DTYPEG(sptr)); argt = A_ARGSG(ast); changed = tmp_ast1 = fixup_KIND_expr(A_LOPG(ast)); tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast); for (i = 0; i < ndim; i++) { changed |= tmp_ast2 = fixup_KIND_expr(ARGT_ARG(argt, i)); subs[i] = tmp_ast2 ? tmp_ast2 : ARGT_ARG(argt, i); } if (changed) { newast = mk_subscr(tmp_ast1, subs, ndim, A_DTYPEG(ast)); } break; case A_MEM: /* NECESSARY? */ tmp_ast1 = fixup_KIND_expr(A_PARENTG(ast)); tmp_ast2 = fixup_KIND_expr(A_MEMG(ast)); if (tmp_ast1 || tmp_ast2) { tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast); tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(ast); newast = mk_member(tmp_ast1, tmp_ast2, A_DTYPEG(ast)); } break; case A_UNOP: tmp_ast1 = fixup_KIND_expr(A_LOPG(ast)); if (tmp_ast1) { newast = mk_unop(A_OPTYPEG(ast), tmp_ast1, A_DTYPEG(ast)); } break; case A_BINOP: tmp_ast1 = fixup_KIND_expr(A_LOPG(ast)); tmp_ast2 = fixup_KIND_expr(A_ROPG(ast)); if (tmp_ast1 || tmp_ast2) { tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast); tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(ast); newast = mk_binop(A_OPTYPEG(ast), tmp_ast1, tmp_ast2, DT_INT); } break; case A_FUNC: /* could be an subscripted array expr */ sptr = findByNameStypeScope(SYMNAME(A_SPTRG(A_LOPG(ast))), ST_PARAM, 0); if (sptr && DTY(DTYPEG(sptr)) == TY_ARRAY) { tmp_ast1 = mk_id(CONVAL1G(sptr)); ndim = ADD_NUMDIM(DTYPEG(sptr)); if (ndim != A_ARGCNTG(ast)) break; argt = A_ARGSG(ast); for (i = 0; i < ndim; i++) { subs[i] = ARGT_ARG(argt, i); } newast = mk_subscr(tmp_ast1, subs, ndim, DTYPEG(sptr)); } break; case A_ID: sptr = A_SPTRG(ast); if (!SCOPEG(sptr) || sem.pgphase == PHASE_USE) { newsptr = findByNameStypeScope(SYMNAME(A_SPTRG(ast)), ST_PARAM, 0); if (newsptr != sptr) { if (STYPEG(newsptr) == ST_CONST) { /* MORE can this happen, A_ID&ST_CONST */ newast = mk_cnst(newsptr); } else if (STYPEG(newsptr) == ST_PARAM) { newast = CONVAL2G(newsptr); } else { newast = 0; } } } break; } return newast; } static int eval_KIND_expr(int ast, int *val, int *dtyp) { int val1; int val2; int tmp_ast1; int tmp_ast2; int sptr; int success = 0; if (!ast) return 0; if (A_ALIASG(ast)) { *dtyp = A_DTYPEG(ast); ast = A_ALIASG(ast); } switch (A_TYPEG(ast)) { case A_CNST: *dtyp = A_DTYPEG(ast); *val = CONVAL2G(A_SPTRG(ast)); success = 1; break; case A_UNOP: if (eval_KIND_expr(A_LOPG(ast), &val1, dtyp)) { if (A_OPTYPEG(ast) == OP_SUB) *val = negate_const(val1, A_DTYPEG(ast)); if (A_OPTYPEG(ast) == OP_LNOT) *val = ~(val1); *dtyp = A_DTYPEG(ast); success = 1; } break; case A_BINOP: if (eval_KIND_expr(A_LOPG(ast), &val1, dtyp) && eval_KIND_expr(A_ROPG(ast), &val2, dtyp)) { *val = const_fold(A_OPTYPEG(ast), val1, val2, A_DTYPEG(ast)); *dtyp = A_DTYPEG(ast); success = 1; } break; case A_SUBSCR: case A_MEM: tmp_ast1 = complex_alias(ast); if (eval_KIND_expr(tmp_ast1, &val1, dtyp)) { *val = val1; success = 1; } break; } return success; } static void get_retval_KIND_value() { int sptr; int sav_gbl_lineno = gbl.lineno; int val = -1; int dtyp; int l_ast1; gbl.lineno = sem.deferred_kind_len_lineno; /* Handle deferred KIND spec */ if (A_TYPEG(sem.deferred_func_kind) == A_ID) { sptr = findByNameStypeScope(SYMNAME(A_SPTRG(sem.deferred_func_kind)), ST_PARAM, 0); if (sptr) { dtyp = DTYPEG(sptr); val = CONVAL1G(sptr); if (STYPEG(A_SPTRG(sem.deferred_func_kind)) == ST_UNKNOWN) { IGNOREP(A_SPTRG(sem.deferred_func_kind), TRUE); HIDDENP(A_SPTRG(sem.deferred_func_kind), TRUE); } } } else if (A_ISEXPR(A_TYPEG(sem.deferred_func_kind))) { l_ast1 = fixup_KIND_expr(sem.deferred_func_kind); if (!eval_KIND_expr(l_ast1, &val, &dtyp)) { val = -1; } } if (val < 0) { errsev(87); goto exit; } if (dtyp != DT_INT4) { errwarn(91); goto exit; } if ((dtyp = select_kind(DTYPEG(gbl.currsub), DTY(DTYPEG(gbl.currsub)), val))) { DTYPEP(gbl.currsub, dtyp); DTYPEP(FVALG(gbl.currsub), dtyp); if ((sptr = findByNameStypeScope(SYMNAME(gbl.currsub), ST_ALIAS, 0))) { DTYPEP(sptr, dtyp); } } exit: gbl.lineno = sav_gbl_lineno; sem.deferred_func_kind = 0; if (!sem.deferred_func_len) sem.deferred_kind_len_lineno = 0; } static void get_retval_LEN_value() { int sptr; int sav_gbl_lineno = gbl.lineno; int val = -1; int dtyp = 0; int l_ast1; gbl.lineno = sem.deferred_kind_len_lineno; /* Handle deferred LEN spec */ l_ast1 = fixup_KIND_expr(sem.deferred_func_len); if (A_TYPEG(l_ast1) == A_CNST) { dtyp = mod_type(sem.ogdtype, DTY(sem.ogdtype), 1, CONVAL2G(A_SPTRG(l_ast1)), 0, gbl.currsub); if (dtyp) { DTYPEP(gbl.currsub, dtyp); DTYPEP(FVALG(gbl.currsub), dtyp); } } else { dtyp = mod_type(sem.ogdtype, DTY(sem.ogdtype), 4, l_ast1, 0, gbl.currsub); if (dtyp) { DTYPEP(gbl.currsub, dtyp); ADJLENP(gbl.currsub, 1); DTYPEP(FVALG(gbl.currsub), dtyp); ADJLENP(FVALG(gbl.currsub), 1); } } exit: gbl.lineno = sav_gbl_lineno; sem.deferred_func_len = 0; sem.deferred_kind_len_lineno = 0; } static void get_retval_derived_type() { int sptr; LOGICAL found = FALSE; if (gbl.rutype == RU_FUNC) { for (sptr = first_hash(sem.deferred_dertype); sptr > NOSYM; sptr = HASHLKG(sptr)) { if (sptr == sem.deferred_dertype) continue; if (STYPEG(sptr) == ST_TYPEDEF && STYPEG(SCOPEG(sptr)) == ST_MODULE) { pop_sym(sem.deferred_dertype); found = TRUE; break; } } } if (found) { DTYPEP(gbl.currsub, DTYPEG(sptr)); DTYPEP(FVALG(gbl.currsub), DTYPEG(sptr)); } else { error(155, 3, sem.deferred_kind_len_lineno, "Derived type has not been declared -", SYMNAME(sem.deferred_dertype)); } exit: sem.deferred_dertype = 0; sem.deferred_kind_len_lineno = 0; } static void process_bind(int sptr) { int b_type; int b_bitv; int need_altname = 0; char *np; char *w32_name; int wsptr; /* A module routine without an explicit C name uses the routine name. */ if (!XBIT(58,0x200000)) { if ((bind_attr.exist & DA_B(DA_C)) && !bind_attr.altname && INMODULEG(sptr) && (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY)) { char *np = SYMNAME(sptr); bind_attr.exist |= DA_B(DA_ALIAS); bind_attr.altname = getstring(np, strlen(np)); } } b_type = 0; for (b_bitv = bind_attr.exist; b_bitv; b_bitv >>= 1, b_type++) { if ((b_bitv & 1) == 0) continue; switch (b_type) { case DA_ALIAS: /* An altname can't be empty. Exit early to use a "normal" mangled * variant of the primary symbol name. */ np = stb.n_base + CONVAL1G(bind_attr.altname); if (!*np) return; ALTNAMEP(sptr, bind_attr.altname); break; case DA_C: #if defined(TARGET_OSX) /* add underscore to OSX common block names */ if (STYPEG(sptr) == ST_CMBLK) need_altname = 1; #endif /* NEW CFUNCP and REFERENCEP */ CFUNCP(sptr, 1); if ((STYPEG(sptr) == ST_PROC) || (STYPEG(sptr) == ST_ENTRY)) { PASSBYREFP(sptr, 1); MSCALLP(sptr, 0); } break; } /* end switch */ } /* end for */ if ((need_altname) && ALTNAMEG(sptr) == 0) { /* set default altname, so that no underbar gets added */ ALTNAMEP(sptr, getstring(SYMNAME(sptr), strlen(SYMNAME(sptr)))); } } /* process_bind */ static void clear_ident_list() { IDENT_LIST *curr, *curr_next; IDENT_PROC_LIST *curr_proc, *curr_proc_next; long hashval; if (!sem.which_pass || !dirty_ident_base || gbl.internal > 1) { return; } for (hashval = 0; hashval < HASHSIZE; ++hashval) { for (curr = ident_base[hashval]; curr;) { for (curr_proc = curr->proc_list; curr_proc;) { curr_proc_next = curr_proc->next; FREE(curr_proc); curr_proc = curr_proc_next; } curr->proc_list = 0; curr_next = curr->next; FREE(curr); curr = curr_next; } ident_base[hashval] = 0; } dirty_ident_base = FALSE; } /** \brief Emit a warning if a duplicate subproblem prefix is used. */ static void check_duplicate(bool checker, const char *op) { if (checker) error(1054, ERR_Warning, gbl.lineno, op, NULL); } /** \brief Reset subprogram prefixes to zeroes */ static void clear_subp_prefix_settings(struct subp_prefix_t *subp) { BZERO(subp, struct subp_prefix_t, 1); } /** \brief MODULE prefix checking for subprograms C1547: cannot be inside a an abstract interface */ static void check_module_prefix() { if (sem.interface && subp_prefix.module && sem.interf_base[sem.interface - 1].abstract) error(1055, ERR_Severe, gbl.lineno, NULL, NULL); } static void decr_ident_use(int ident, int proc) { long hashval; IDENT_LIST *curr; IDENT_PROC_LIST *curr_proc; if (sem.which_pass || !dirty_ident_base || gbl.internal <= 1) { return; } HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident))) for (curr = ident_base[hashval]; curr; curr = curr->next) { if (strcmp(curr->ident, SYMNAME(ident)) == 0) { for (curr_proc = curr->proc_list; curr_proc; curr_proc = curr_proc->next) { if (strcmp(SYMNAME(proc), curr_proc->proc_name) == 0) { curr_proc->usecnt -= 1; } } } } } static void defer_ident_list(int ident, int proc) { long hashval; IDENT_LIST *curr; IDENT_PROC_LIST *curr_proc; if (STYPEG(ident) && SCOPEG(ident) == gbl.currsub && SCOPEG(ident) != proc) { /* Note: if STYPEG(ident) == 0, then this is an implicitly defined symbol */ proc = SCOPEG(ident); } HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident))); for (curr = ident_base[hashval]; curr; curr = curr->next) { if (strcmp(curr->ident, SYMNAME(ident)) != 0) continue; for (curr_proc = curr->proc_list; curr_proc; curr_proc = curr_proc->next) { if (strcmp(SYMNAME(proc), curr_proc->proc_name) == 0) { curr_proc->usecnt += 1; return; /* identifier and procedure already added */ } } /* add procedure name */ dirty_ident_base = TRUE; NEW(curr_proc, IDENT_PROC_LIST, 1); NEW(curr_proc->proc_name, char, strlen(SYMNAME(proc)) + 1); strcpy(curr_proc->proc_name, SYMNAME(proc)); curr_proc->next = curr->proc_list; curr->proc_list = curr_proc; curr_proc->usecnt = 1; return; } /* add identifier and create new procedure list */ NEW(curr, IDENT_LIST, 1); NEW(curr->ident, char, strlen(SYMNAME(ident)) + 1); strcpy(curr->ident, SYMNAME(ident)); NEW(curr_proc, IDENT_PROC_LIST, 1); NEW(curr_proc->proc_name, char, strlen(SYMNAME(proc)) + 1); strcpy(curr_proc->proc_name, SYMNAME(proc)); curr->proc_list = curr_proc; curr_proc->next = 0; curr_proc->usecnt = 1; curr->next = ident_base[hashval]; ident_base[hashval] = curr; dirty_ident_base = TRUE; } int internal_proc_has_ident(int ident, int proc) { long hashval; IDENT_LIST *curr; IDENT_PROC_LIST *curr_proc; if (!dirty_ident_base) return 0; HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident))); for (curr = ident_base[hashval]; curr; curr = curr->next) { if (strcmp(curr->ident, SYMNAME(ident)) == 0) { for (curr_proc = curr->proc_list; curr_proc; curr_proc = curr_proc->next) { if (strcmp(curr_proc->proc_name, SYMNAME(proc)) == 0 && curr_proc->usecnt > 0) { return 1; } } } } return 0; } #ifdef GSCOPEP static void prop_reqgs(int ast) { switch (A_TYPEG(ast)) { case A_ID: GSCOPEP(A_SPTRG(ast), 1); break; case A_SUBSCR: case A_SUBSTR: case A_UNOP: prop_reqgs(A_LOPG(ast)); break; case A_MEM: prop_reqgs(A_PARENTG(ast)); break; case A_BINOP: prop_reqgs(A_LOPG(ast)); prop_reqgs(A_ROPG(ast)); break; } } static void fixup_ident_bounds(int sptr) { int dtype, numdim, i; ADSC *ad; if (GSCOPEG(sptr)) { dtype = DTYPEG(sptr); if (DTY(dtype) != TY_ARRAY) return; ad = AD_DPTR(dtype); numdim = AD_NUMDIM(ad); prop_reqgs(AD_NUMELM(ad)); prop_reqgs(AD_ZBASE(ad)); for (i = 0; i < numdim; ++i) { prop_reqgs(AD_LWAST(ad, i)); prop_reqgs(AD_UPAST(ad, i)); prop_reqgs(AD_EXTNTAST(ad, i)); prop_reqgs(AD_MLPYR(ad, i)); } } } void fixup_reqgs_ident(int sptr) { if (GSCOPEG(sptr)) { if (SDSCG(sptr)) { GSCOPEP(SDSCG(sptr), 1); } if (PTRVG(sptr)) { GSCOPEP(PTRVG(sptr), 1); } if (MIDNUMG(sptr)) { GSCOPEP(MIDNUMG(sptr), 1); } if (DTY(DTYPEG(sptr)) == TY_ARRAY) { fixup_ident_bounds(sptr); } } } #endif static void defer_iface(int iface, int dtype, int proc, int mem) { int pass, len, tag; iface_avail++; NEED(iface_avail, iface_base, IFACE, iface_size, iface_avail + 50); iface_base[iface_avail - 1].iface = iface; iface_base[iface_avail - 1].dtype = dtype; iface_base[iface_avail - 1].proc = proc; iface_base[iface_avail - 1].scope = SCOPEG(mem); iface_base[iface_avail - 1].internal = gbl.internal; /* Need to save which sem pass created this iface */ iface_base[iface_avail - 1].sem_pass = sem.which_pass; len = strlen(SYMNAME(iface)) + 1; NEW(iface_base[iface_avail - 1].iface_name, char, len); strcpy(iface_base[iface_avail - 1].iface_name, SYMNAME(iface)); iface_base[iface_avail - 1].tag_name = 0; iface_base[iface_avail - 1].pass_class = 0; if (mem && STYPEG(mem) == ST_MEMBER) { iface_base[iface_avail - 1].mem = mem; pass = PASSG(mem); if (pass && DTYPEG(pass) != stsk->dtype) { /* assume dtype of pass argument is same as enclosed dtype. * We do this since PASS will get written to a module before * we can fix it after we've seen the procedure/interface. * If the pass argument differs from enclosed dtype, we will * catch it in do_iface(). */ DTYPEP(pass, stsk->dtype); } } else { iface_base[iface_avail - 1].mem = 0; } iface_base[iface_avail - 1].proc_var = mem; iface_base[iface_avail - 1].lineno = gbl.lineno; } /** \brief This routine sets the PASS field in a procedure pointer for * semantic pass 0 prior to call to end_module(). * * This is needed, otherwise we may incorrectly write the procedure pointer * module info without PASS set. */ static void fix_iface0() { int i, iface, proc, mem; char *name; if (sem.which_pass) return; for (i = 0; i < iface_avail; i++) { mem = iface_base[i].mem; name = iface_base[i].iface_name; if (!name || !mem) continue; iface = findByNameStypeScope(name, ST_PROC, 0); iface_base[i].stype = STYPEG(iface); /* need to save stype */ if (iface && !PASSG(mem) && !NOPASSG(mem)) { int arg_sptr = aux.dpdsc_base[DPDSCG(iface)]; PASSP(mem, arg_sptr); } } } static void fix_iface(int sptr) { int len, tag, i, iface, proc, mem, dtype; int *dscptr; char *name; for (i = 0; i < iface_avail; i++) { iface = iface_base[i].iface; proc = iface_base[i].proc; mem = iface_base[i].mem; name = iface_base[i].iface_name; dtype = iface_base[i].dtype; if (!iface && mem && dtype && !NOPASSG(mem) && strcmp(name, SYMNAME(sptr)) == 0) { iface = sptr; iface_base[i].iface = sptr; } if (iface && sptr && strcmp(name, SYMNAME(sptr)) == 0) { iface_base[i].iface = sptr; if (!PASSG(mem) && !NOPASSG(mem)) { dscptr = aux.dpdsc_base + DPDSCG(iface); PASSP(mem, *dscptr); } else if (PASSG(mem)) { int j = find_dummy_position(iface, PASSG(mem)); if (j > 0) PASSP(mem, aux.dpdsc_base[DPDSCG(iface) + j - 1]); } #ifdef CLASSG if (CLASSG(PASSG(mem))) { iface_base[i].pass_class = 1; tag = DTYPEG(PASSG(mem)); tag = DTY(tag + 3); len = strlen(SYMNAME(tag)) + 1; NEW(iface_base[iface_avail - 1].tag_name, char, len); strcpy(iface_base[iface_avail - 1].tag_name, SYMNAME(tag)); } #endif } } } /* Called during sem pass 0 at the end of the subroutine/function. We attempt * to share compatible procedure pointer dtypes found in argument descriptors. * This fixes a problem exhibited in the Whizard code where we perform an * argument check on a call to a forward referenced internal procedure. In * this case, the argument's DT_PROC dtype has not yet been seen. */ static void fix_proc_ptr_dummy_args() { int paramct, dpdsc, i; if (sem.which_pass) return; proc_arginfo(gbl.currsub, ¶mct, &dpdsc, NULL); for (i = 0; i < paramct; ++i) { int sptr = aux.dpdsc_base[dpdsc + i]; if (is_procedure_ptr(sptr) && SCG(sptr) == SC_DUMMY) { char *symname = SYMNAME(sptr); int len = strlen(symname); int hash, hptr; HASH_ID(hash, symname, len); for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) { if (is_procedure_ptr(hptr) && strcmp(symname, SYMNAME(hptr)) == 0) { if (hptr != sptr && test_scope(hptr) >= 0) { DTYPE d1 = DTYPEG(sptr); DTYPE d2 = DTYPEG(hptr); if (cmp_interfaces(DTY(d1 + 2), DTY(d2 + 2), TRUE)) { DTYPEP(sptr, d2); break; } } } } } } } static void do_iface(int iface_state) { int i; for (i = 0; i < iface_avail; i++) { _do_iface(iface_state, i); } if (iface_state) { iface_avail = 0; } } static void do_iface_module(void) { /* * processing interfaces while in a module-contained subprogram; * need to process those interfaces which are not module procedures. */ int i; int iface; assert(IN_MODULE, "must be in module", 0, ERR_Fatal); if (sem.interface && !get_seen_contains()) { /* in an interface block in a module specification, if the iface is from * this module, defer until the end of the module */ for (i = 0; i < iface_avail; i++) { iface = iface_base[i].iface; if ((!iface || STYPEG(iface) == ST_UNKNOWN) && !sem.which_pass) continue; _do_iface(/*1*/ sem.which_pass, i); iface_base[i].iface = 0; } } else { if (!gbl.currsub) { /* IN_MODULE_SPEC */ for (i = 0; i < iface_avail; i++) { iface = iface_base[i].iface; if (!iface) continue; switch (STYPEG(iface)) { case ST_UNKNOWN: case ST_MODPROC: continue; case ST_ALIAS: if (SCOPEG(iface) == gbl.currmod) continue; break; default:; } _do_iface(/*1*/ sem.which_pass, i); iface_base[i].iface = 0; } } for (i = 0; i < iface_avail; i++) { iface = iface_base[i].iface; if (iface) { int scp; scp = SCOPEG(iface); if (scp && (scp == gbl.currsub || scp == SCOPEG(gbl.currsub)) && !INMODULEG(iface)) { _do_iface(1, i); iface_base[i].iface = 0; } else if (sem.which_pass) { switch (STYPEG(iface)) { case ST_MODPROC: case ST_ALIAS: break; default: if (scp == gbl.currmod) { _do_iface(sem.which_pass, i); iface_base[i].iface = 0; } else if (scp != gbl.currmod && NEEDMODG(scp)) { _do_iface(sem.which_pass, i); iface_base[i].iface = 0; } } } else if (gbl.currsub && scp && (!INMODULEG(iface) || ABSTRACTG(iface))) { switch (STYPEG(iface)) { case ST_MODPROC: case ST_ALIAS: break; default: if (scp == ENCLFUNCG(gbl.currsub)) { _do_iface(1, i); iface_base[i].iface = 0; } else if (scp != SCOPEG(gbl.currsub)) { _do_iface(1, i); iface_base[i].iface = 0; } } } } } } } /** * Called by _do_iface() as part of error clean-up. We need to clear the * next attempt to use an erroneous interface specified in the iface argument * starting at the "i + 1" element in iface_base. */ static void clear_iface(int i, SPTR iface) { int j; for (j = i + 1; j < iface_avail; j++) { if (iface_base[j].iface && sem_strcmp(SYMNAME(iface), SYMNAME(iface_base[j].iface)) == 0) { /* inhibit the next attempt to use the same interface */ iface_base[j].iface = 0; } } } static void _do_iface(int iface_state, int i) { SPTR sptr, orig, fval; int dpdsc, paramct; LOGICAL pass_notfound; SPTR passed_object; /* passed-object dummy argument */ int j; SPTR iface = iface_base[i].iface; SPTR ptr_scope = iface_base[i].scope; const char *name = iface_base[i].iface_name; DTYPE dtype = iface_base[i].dtype; SPTR proc = iface_base[i].proc; SPTR mem = iface_base[i].mem; int lineno = iface_base[i].lineno; LOGICAL class = iface_base[i].pass_class; const char *dt_name = iface_base[i].tag_name; SPTR proc_var = iface_base[i].proc_var; int internal = iface_base[i].internal; if (!iface) { return; } if (dtype > 0) { if (DTY(dtype) == TY_ARRAY) { dtype = DTY(dtype + 1); } if (DTY(dtype) == TY_PTR) { dtype = DTY(dtype+1); } if (DTY(dtype) != TY_PROC) { return; } } if (ptr_scope && STYPEG(ptr_scope) != ST_MODULE && ptr_scope != stb.curr_scope && (gbl.internal <= 1 || (gbl.internal > 1 && gbl.outersub != ptr_scope))) { /* This procedure pointer is not in scope. So, we skip it to avoid * overwriting another dtype. */ return; } if (internal > 1 && gbl.internal != internal) { /* This procedure variable/pointer was declared in an internal procedure * that differs from the current procedure. So, skip it to avoid * overwriting it with another dtype. */ return; } if (proc) { DTYPEP(proc, DTYPEG(iface)); } if (!STYPEG(iface)) { if (sem.which_pass) { SPTR hptr; char *symname = SYMNAME(iface); int len = strlen(symname); int hash; HASH_ID(hash, symname, len); for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) { if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) { int scope = test_scope(hptr); if (scope && scope <= test_scope(iface)) { iface = hptr; break; } } } if (!STYPEG(iface)) { /* Check to see if we saw this iface in the first pass. * If so, do not generate an error. */ int j; for (j = 0; j < iface_avail; j++) { if (iface_base[j].sem_pass == 0 && strcmp(iface_base[j].iface_name, name) == 0 && iface_base[j].stype == ST_PROC) { return; } } orig = iface; goto iface_err; } } if (proc <= NOSYM) return; } if (strcmp(SYMNAME(iface), name) != 0) iface = getsymbol(name); if (sem.interface <= 1) { sptr = refsym(iface, OC_OTHER); } else { sptr = refsym_inscope(iface, OC_OTHER); } if (DTY(dtype) == TY_PROC && STYPEG(DTY(dtype + 2)) == ST_MEMBER) { iface = sptr; DTY(dtype + 2) = iface; } if ((!sem.which_pass || STYPEG(sptr)) && (STYPEG(iface) != ST_ENTRY || sptr != FVALG(iface))) { iface = sptr; } orig = iface; switch (STYPEG(iface)) { case ST_IDENT: if (RESULTG(iface)) /* Interface not seen yet */ return; goto iface_err; case ST_GENERIC: iface = GSAMEG(iface); case ST_INTRIN: case ST_PD: iface = iface_intrinsic(iface); if (!iface) { goto iface_err; } /* fall thru */ case ST_ENTRY: case ST_PROC: paramct = PARAMCTG(iface); dpdsc = DPDSCG(iface); break; case ST_MEMBER: if (DTY(DTYPEG(iface)) == TY_PTR) { /* Procedure pointer that's a component of a derived type. */ break; } goto iface_err; default: iface_err: if (!STYPEG(iface) && (!sem.which_pass || iface_state == 0 || (IN_MODULE && !sem.seen_end_module))) { /* Do not generate error on semantic pass 0. May not have seen the * entire module yet. Return only if we have seen an IMPORT stmt. */ return; } error(155, 3, lineno, "Illegal procedure interface -", SYMNAME(orig)); clear_iface(i, orig); return; } if (ELEMENTALG(orig) && !IS_INTRINSIC(STYPEG(orig)) && POINTERG(proc_var)) { error(1010, ERR_Severe, lineno, SYMNAME(proc_var), CNULL); clear_iface(i, orig); } passed_object = 0; pass_notfound = mem && PASSG(mem); fval = FVALG(iface); if (paramct || fval) { SPTR *dscptr; int j; if (fval) dpdsc = ++aux.dpdsc_avl; else dpdsc = aux.dpdsc_avl; NEED(aux.dpdsc_avl + paramct, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_size + paramct + 100); dscptr = aux.dpdsc_base + DPDSCG(iface); if (paramct && mem && !NOPASSG(mem) && !PASSG(mem)) { passed_object = *dscptr; /* passed-object default */ } for (j = 0; j < paramct; j++) { SPTR arg = *dscptr++; aux.dpdsc_base[dpdsc + j] = arg; if (pass_notfound && sem_strcmp(SYMNAME(arg), SYMNAME(PASSG(mem))) == 0) { pass_notfound = FALSE; passed_object = arg; } } if (fval) { aux.dpdsc_base[dpdsc - 1] = fval; FUNCP(mem, TRUE); } aux.dpdsc_avl += paramct; } else { dpdsc = 0; } if (proc) { DTYPEP(proc, DTYPEG(iface)); PARAMCTP(proc, paramct); DPDSCP(proc, dpdsc); FVALP(proc, fval); PUREP(proc, PUREG(iface)); ELEMENTALP(proc, ELEMENTALG(iface)); CFUNCP(proc, CFUNCG(iface)); } else { /* dtype locates the TY_PROC data type record */ if (mem && paramct == 0 && !NOPASSG(mem)) { error(155, 3, lineno, "NOPASS attribute must be present for", SYMNAME(mem)); NOPASSP(mem, TRUE); passed_object = 0; } DTY(dtype + 1) = DTYPEG(iface); DTY(dtype + 2) = iface; DTY(dtype + 3) = paramct; DTY(dtype + 4) = dpdsc; DTY(dtype + 5) = fval; if (pass_notfound) { error(155, 3, lineno, "Passed-object dummy argument not found -", SYMNAME(PASSG(mem))); } if (passed_object && iface_state) { DTYPE dt; if (dt_name) { dt = DTYPEG(getsymbol(dt_name)); } else dt = DTYPEG(passed_object); if (DTY(dt) != TY_DERIVED || DTY(dt + 3) == 0) { error(155, 3, lineno, "Passed-object dummy argument must be a derived type scalar -", SYMNAME(passed_object)); } else { SPTR tdf = DTY(dt + 3); if (dt != ENCLDTYPEG(mem)) { error(155, 3, lineno, "Incompatible passed-object dummy argument for ", SYMNAME(iface)); } else if (!SEQG(tdf) && !class) { error(155, 3, lineno, "Passed-object dummy argument is not polymorphic -", SYMNAME(passed_object)); } if (POINTERG(passed_object) || ALLOCATTRG(passed_object)) error(155, 3, lineno, "Passed-object dummy argument must not be " "POINTER or ALLOCATABLE -", SYMNAME(passed_object)); } PASSP(mem, passed_object); /* default or specified */ } } } /** \brief Sets up type parameters used in parameterized derived types (PDTs) */ int queue_type_param(int sptr, int dtype, int offset, int flag) { /* linked list of type parameters for a particular derived type */ typedef struct tp { char *name; /* name of parameter */ int dtype; /* derived type holding this type parameter */ int offset; /* parameter's position in list parm list */ struct tp *next; /* next record */ } TP; static TP *tp_queue = 0; TP *prev, *curr, *new_tp; char *c; int tag, parent, mem, i, j, mem2, pmem, pmem2; int prevmem, firstuse, parentuse; if (flag == 0) { /* init/clear entries */ for (prev = curr = tp_queue; curr;) { FREE(curr->name); prev = curr; curr = curr->next; FREE(prev); } tp_queue = 0; return 1; } else if (flag == 1) { /* add entry */ c = SYMNAME(sptr); /* step 1 - check for duplicate type parameter in this type */ for (curr = tp_queue; curr; curr = curr->next) { if (curr->dtype == dtype && strcmp(curr->name, c) == 0) { error(155, 3, gbl.lineno, "Duplicate type parameter -", c); return 0; } } /* step 2 - add type parameter to queue */ NEW(new_tp, TP, 1); BZERO(new_tp, TP, 1); NEW(new_tp->name, char, strlen(c) + 1); strcpy(new_tp->name, c); new_tp->dtype = dtype; new_tp->offset = offset; new_tp->next = tp_queue; tp_queue = new_tp; return 1; } else if (flag == 3) { tag = DTY(dtype + 3); parent = DTYPEG(PARENTG(tag)); if (parent) { i = queue_type_param(sptr, parent, offset, 3); if (i) return i; } for (curr = tp_queue; curr; curr = curr->next) { if (curr->dtype == dtype) { c = curr->name; if (strcmp(c, SYMNAME(sptr)) == 0) return curr->offset; } } return 0; } else if (flag == 2) { /* fill in dtype into type param fields, check parent type params, * check to make sure defined params have corresponding components * in the the dtype, and reorder (if necessary) params. */ int mem1, prev, prev1; for (curr = tp_queue; curr; curr = curr->next) { if (curr->dtype == 0) curr->dtype = dtype; } tag = DTY(dtype + 3); parent = DTYPEG(PARENTG(tag)); if (parent) { for (curr = tp_queue; curr; curr = curr->next) { if (curr->dtype == dtype) { c = curr->name; for (mem = DTY(parent + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), c) == 0) { error(155, 3, gbl.lineno, "Duplicate type parameter " "(in parent type) -", c); } } } } } for (curr = tp_queue; curr; curr = curr->next) { if (curr->dtype == dtype) { c = curr->name; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), c) == 0) { KINDP(mem, curr->offset); break; } } if (mem <= NOSYM) { error(155, 3, gbl.lineno, "Missing type parameter specification -", c); } } } /* check for extraneous kind type parameters */ for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (!USEKINDG(mem) && KINDG(mem) == -1) { error(155, 3, gbl.lineno, "Kind type parameter component does not have " "a corresponding type parameter specifier -", SYMNAME(mem)); } } /* For now, place length type parameters at the beginning of the dtype * to improve processing of them later. * Also fix up recursively typed components. */ firstuse = parentuse = 0; for (prevmem = mem = DTY(dtype + 1); mem > NOSYM;) { int bt; bt = DTYPEG(mem); if ((POINTERG(mem) || ALLOCATTRG(mem)) && DTY(bt) == TY_DERIVED) { bt = DTY(bt + 3); bt = BASETYPEG(bt); if (bt && bt == ENCLDTYPEG(mem)) { /* This is a recursively typed component. We need to set * this component's type to the enclosed type since this component * was added before the enclosed type was fully defined. Otherwise, * this component's type is incomplete and may not have all of its * components. Recursively typed components must have POINTER * attribute in F2003. In F2008, they can have POINTER or * ALLOCTABLE attribute. */ DTYPEP(mem, bt); } } if (PARENTG(mem)) { parentuse = mem; } else if (!firstuse && !LENPARMG(mem) && USELENG(mem)) { firstuse = mem; } else if (firstuse && LENPARMG(mem)) { SYMLKP(prevmem, SYMLKG(mem)); if (!parentuse) { SYMLKP(mem, DTY(dtype + 1)); DTY(dtype + 1) = mem; } else { SYMLKP(mem, SYMLKG(parentuse)); SYMLKP(parentuse, mem); } mem = SYMLKG(prevmem); continue; } prevmem = mem; mem = SYMLKG(mem); } /* ditto with kind type parameters */ firstuse = parentuse = 0; for (prevmem = mem = DTY(dtype + 1); mem > NOSYM;) { if (PARENTG(mem)) { parentuse = mem; } else if (!firstuse && !LENPARMG(mem) && USEKINDG(mem) && A_TYPEG(KINDASTG(mem)) != A_CNST && A_TYPEG(KINDASTG(mem)) != A_ID) { firstuse = mem; } else if (firstuse && KINDG(mem) && !USEKINDG(mem) && !KINDASTG(mem)) { SYMLKP(prevmem, SYMLKG(mem)); if (!parentuse) { SYMLKP(mem, DTY(dtype + 1)); DTY(dtype + 1) = mem; } else { SYMLKP(mem, SYMLKG(parentuse)); SYMLKP(parentuse, mem); } mem = SYMLKG(prevmem); continue; } prevmem = mem; mem = SYMLKG(mem); } return 1; } return 0; } static void search_kind(int ast, int *offset) { int sptr, rslt; if (!offset || *offset) return; if (A_TYPEG(ast) == A_ID) { sptr = A_SPTRG(ast); if (sptr) { rslt = queue_type_param(sptr, 0, 0, 3); if (!rslt && sem.stsk_depth && stsk == &STSK_ENT(0)) { rslt = get_kind_parm(sptr, stsk->dtype); } if (rslt) { *offset = rslt; return; } } } } static int chk_kind_parm(SST *stkp) { int offset; int sptr; int ast; sptr = 0; switch (SST_IDG(stkp)) { case S_IDENT: sptr = SST_SYMG(stkp); break; case S_LVALUE: sptr = SST_LSYMG(stkp); break; case S_EXPR: ast = SST_ASTG(stkp); offset = 0; ast_visit(1, 1); ast_traverse(ast, NULL, search_kind, &offset); ast_unvisit(); return offset; } if (!sptr) return 0; /* Check to see if this is a kind type parameter */ offset = queue_type_param(sptr, 0, 0, 3); if (!offset && INSIDE_STRUCT && stsk == &STSK_ENT(0) && stsk->type == 'd') { offset = get_kind_parm(sptr, stsk->dtype); } if (offset) IGNOREP(sptr, TRUE); /* needed for "implicit none" */ return offset; } static int get_kind_parm(int sptr, int dtype) { int rslt, tag, parent, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_kind_parm(sptr, DTYPEG(mem)); if (rslt) return rslt; } if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) return KINDG(mem); } return 0; } static int get_kind_parm_strict(int sptr, int dtype) { int rslt, tag, parent, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_kind_parm(sptr, DTYPEG(mem)); if (rslt) return rslt; } if (!USEKINDG(mem) && !LENPARMG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) { return KINDG(mem); } } return 0; } /** \brief search a derived type for a kind type parameter with a specified * name. * * \param np is the name we're search for * \param dtype is the derived type record that we are searching * * \return integer > 0 for the parameter number, else 0 if not found. */ int get_kind_parm_by_name(char *np, int dtype) { int rslt, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_kind_parm_by_name(np, DTYPEG(mem)); if (rslt) return rslt; } if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), np) == 0) return KINDG(mem); } return 0; } /** \brief search derived type for a type parameter in the same position as * specified by offset. * * \param offset is the desired parameter position * \param dtype is the derived type record to search in * * \return symbol table pointer of the parameter component in the derived * type; else 0 if not found. */ int get_parm_by_number(int offset, int dtype) { int rslt, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_parm_by_number(offset, DTYPEG(mem)); if (rslt) return rslt; } if (!USEKINDG(mem) && KINDG(mem) == offset) return mem; } return 0; } /** \brief search a derived type for a kind or length type parameter with a * specified name. * * \param np is the name we're search for * \param dtype is the derived type record that we are searching * * \return integer > 0 for the parameter number, else 0 if not found. */ int get_parm_by_name(char *np, int dtype) { int rslt, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_parm_by_name(np, DTYPEG(mem)); if (rslt) return rslt; } if (!USEKINDG(mem) && KINDG(mem) && strcmp(np, SYMNAME(mem)) == 0) return mem; } return 0; } /** Should be called when we parse ENDTYPE. This function goes * through a derived type's members and makes sure there are * no length type parameters in the initialization part of a * member. */ static void chk_initialization_with_kind_parm(int dtype) { int mem; if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); if (DTY(dtype) != TY_DERIVED) return; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { chk_initialization_with_kind_parm(DTYPEG(mem)); } if (INITKINDG(mem) && PARMINITG(mem) && !chk_kind_parm_expr(PARMINITG(mem), dtype, 0, 1)) { error(155, 3, gbl.lineno, "Initialization must be a constant" " expression for component", SYMNAME(mem)); } } } int chk_kind_parm_expr(int ast, int dtype, int flag, int strict_flag) { int sptr, offset, rslt, i; if (!ast) return 0; switch (A_TYPEG(ast)) { case A_INTR: switch (A_OPTYPEG(ast)) { case I_INT1: case I_INT2: case I_INT4: case I_INT8: case I_INT: i = A_ARGSG(ast); return chk_kind_parm_expr(ARGT_ARG(i, 0), dtype, flag, strict_flag); } break; case A_CONV: return chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag); case A_CNST: return 1; case A_ID: sptr = A_SPTRG(ast); offset = (!strict_flag) ? get_kind_parm(sptr, dtype) : get_kind_parm_strict(sptr, dtype); if (flag && !offset && (!strict_flag || !get_kind_parm(sptr, dtype))) { /* we might be in the middle of a derived type definition, so see if * there's a match in the type parameter queue. */ offset = queue_type_param(sptr, 0, 0, 3); } if (!offset) return 0; IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */ KINDP(sptr, offset); return offset; case A_UNOP: return chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag); case A_BINOP: rslt = chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag); if (!rslt) return 0; rslt = chk_kind_parm_expr(A_ROPG(ast), dtype, flag, strict_flag); if (!rslt) return 0; return rslt; } return 0; } static int has_kind_parm_expr(int ast, int dtype, int flag) { int sptr, offset, rslt, i; if (!ast) return 0; switch (A_TYPEG(ast)) { case A_INTR: switch (A_OPTYPEG(ast)) { case I_INT1: case I_INT2: case I_INT4: case I_INT8: case I_INT: i = A_ARGSG(ast); return has_kind_parm_expr(ARGT_ARG(i, 0), dtype, flag); } break; case A_CONV: return has_kind_parm_expr(A_LOPG(ast), dtype, flag); case A_CNST: return 0; case A_ID: sptr = A_SPTRG(ast); offset = get_kind_parm_strict(sptr, dtype); if (flag && !offset) { /* we might be in the middle of a derived type definition, so see if * there's a match in the type parameter queue. */ offset = queue_type_param(sptr, 0, 0, 3); } if (!offset) return 0; IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */ KINDP(sptr, offset); return offset; case A_UNOP: return has_kind_parm_expr(A_LOPG(ast), dtype, flag); case A_BINOP: rslt = has_kind_parm_expr(A_LOPG(ast), dtype, flag); if (rslt) return rslt; rslt = has_kind_parm_expr(A_ROPG(ast), dtype, flag); return rslt; } return 0; } static int chk_asz_deferlen(int ast, int dtype) { int sptr, mem, rslt; if (!ast) return 0; switch (A_TYPEG(ast)) { case A_ID: sptr = A_SPTRG(ast); rslt = 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = chk_asz_deferlen(ast, DTYPEG(mem)); if (rslt < 0) return rslt; continue; } if (strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) { rslt = sptr = mem; break; } } if (rslt) { if (DEFERLENG(sptr)) return -1; else if (ASZG(sptr)) return -2; } break; case A_BINOP: rslt = chk_asz_deferlen(A_LOPG(ast), dtype); if (rslt != 0) { return rslt; } rslt = chk_asz_deferlen(A_ROPG(ast), dtype); if (rslt != 0) { return rslt; } } return 0; } static int get_len_parm(int sptr, int dtype) { int rslt, tag, parent, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_len_parm(sptr, DTYPEG(mem)); if (rslt) return rslt; } if (LENPARMG(mem) && !USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) return KINDG(mem); } return 0; } int chk_len_parm_expr(int ast, int dtype, int flag) { int sptr, offset, rslt; if (!ast) return 0; switch (A_TYPEG(ast)) { case A_CNST: return 1; case A_ID: sptr = A_SPTRG(ast); offset = get_len_parm(sptr, dtype); if (flag && !offset) { /* we might be in the middle of a derived type definition, so see if * there's a match in the type parameter queue. */ offset = queue_type_param(sptr, 0, 0, 3); } if (offset) { IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */ if (ST_ISVAR(STYPEG(sptr)) || STYPEG(sptr) == ST_IDENT) { /* This symbol is a len parameter place holder. */ LENPHP(sptr, 1); } } return offset; case A_UNOP: return chk_len_parm_expr(A_LOPG(ast), dtype, flag); case A_BINOP: rslt = chk_len_parm_expr(A_LOPG(ast), dtype, flag); if (!rslt) return 0; rslt = chk_len_parm_expr(A_ROPG(ast), dtype, flag); if (!rslt) return 0; return rslt; } return 0; } static int fix_kind_parm_expr(int ast, int dtype, int offset, int value) { int sptr, rslt, newast, i; switch (A_TYPEG(ast)) { case A_CNST: break; case A_ID: sptr = A_SPTRG(ast); if (KINDG(sptr) == offset) { ast = mk_cval1(value, DT_INT); } break; case A_UNOP: newast = fix_kind_parm_expr(A_LOPG(ast), dtype, offset, value); A_LOPP(ast, newast); break; case A_BINOP: newast = fix_kind_parm_expr(A_LOPG(ast), dtype, offset, value); A_LOPP(ast, newast); newast = fix_kind_parm_expr(A_ROPG(ast), dtype, offset, value); A_ROPP(ast, newast); break; } return ast; } int get_len_set_parm_by_name(char *np, int dtype, int *val) { int rslt, tag, parent, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { rslt = get_len_set_parm_by_name(np, DTYPEG(mem), val); if (rslt) return rslt; } if (LENPARMG(mem) && SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), np) == 0) { *val = LENG(mem); return KINDG(mem); } } return 0; } int cmp_len_parms(int ast1, int ast2) { int sptr1, sptr2; int rslt; if (A_TYPEG(ast1) != A_TYPEG(ast2)) return 0; switch (A_TYPEG(ast1)) { case A_CNST: if (CONVAL2G(A_SPTRG(ast1)) == CONVAL2G(A_SPTRG(ast2))) return 1; return 0; case A_ID: sptr1 = A_SPTRG(ast1); sptr2 = A_SPTRG(ast2); return sptr1 == sptr2; case A_UNOP: if (A_OPTYPEG(ast1) != A_OPTYPEG(ast2)) return 0; return cmp_len_parms(A_LOPG(ast1), A_LOPG(ast2)); case A_BINOP: if (A_OPTYPEG(ast1) != A_OPTYPEG(ast2)) return 0; rslt = cmp_len_parms(A_LOPG(ast1), A_LOPG(ast2)); if (!rslt) return 0; rslt = cmp_len_parms(A_ROPG(ast1), A_ROPG(ast2)); if (!rslt) return 0; return 1; } return 0; } /** \brief Store dtypes of parameterized derived types in which a parameter was explicitly declared (as opposed to using just the default values). */ int defer_pt_decl(int dtype, int flag) { typedef struct ptList { int dtype; struct ptList *next; } PL; static PL *pl = NULL; PL *curr, *newpl, *prev; int rslt; rslt = 0; if (flag == 0 && !sem.interface && sem.which_pass) { /* delete all entries from list */ for (curr = pl; curr;) { prev = curr; curr = curr->next; FREE(prev); rslt = 1; } pl = NULL; } else if (flag == 1 && !sem.which_pass) { /* add entry */ NEW(newpl, PL, 1); newpl->dtype = dtype; newpl->next = pl; pl = newpl; rslt = 1; } else if (flag == 2 && sem.which_pass) { /* is this list non-empty? */ rslt = (pl != NULL); } return rslt; } static void defer_put_kind_type_param(int offset, int value, char *name, int dtype, int ast, int flag) { typedef struct parmList { int offset; int value; char *name; int ast; int is_defer_len; int is_assume_sz; struct parmList *next; } PL; static PL *pl = NULL; PL *curr, *newpl, *prev; int i; int rslt; int flag2; rslt = 0; if (flag == 0) { /* delete all entries from list */ for (curr = pl; curr;) { prev = curr; curr = curr->next; FREE(prev); rslt = 1; } pl = NULL; } else if (flag == 1) { /* add entry */ NEW(newpl, PL, 1); newpl->offset = offset; newpl->value = value; newpl->name = name; newpl->ast = ast; newpl->is_defer_len = sem.param_defer_len; newpl->is_assume_sz = sem.param_assume_sz; newpl->next = pl; pl = newpl; rslt = 1; } else if (flag == 2) { /* process type params */ if (DTY(dtype) != TY_DERIVED) { return; } for (curr = pl; curr; curr = curr->next) { rslt = 1; if (sem.new_param_dt == 0) { sem.new_param_dt = create_parameterized_dt(dtype, 0); } if (curr->is_defer_len) { flag2 = -1; } else if (curr->is_assume_sz) { flag2 = -2; } else flag2 = 0; if (!curr->name) { i = put_kind_type_param(sem.new_param_dt, curr->offset, curr->value, curr->ast, flag2); if (!i) { error(155, 3, gbl.lineno, "Too many type parameter specifiers", NULL); } } else { i = get_kind_parm_by_name(curr->name, sem.new_param_dt); if (i) { put_kind_type_param(sem.new_param_dt, i, curr->value, curr->ast, flag2); } else { error(155, 3, gbl.lineno, "Undefined type parameter", curr->name); } } } check_kind_type_param(sem.new_param_dt); } } void put_default_kind_type_param(int dtype, int flag, int flag2) { typedef struct dtyList { int dtype; struct dtyList *next; } DL; static DL *dl = NULL; DL *curr, *newdl, *prev; int mem_dtype, offset, val, mem; if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype)) return; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { mem_dtype = DTYPEG(mem); if (PARENTG(mem)) { NEW(newdl, DL, 1); BZERO(newdl, DL, 1); newdl->dtype = dtype; newdl->next = dl; dl = newdl; put_default_kind_type_param(mem_dtype, 1, flag2); } else if (!SETKINDG(mem) && !USEKINDG(mem) && (offset = KINDG(mem)) && (val = PARMINITG(mem))) { put_kind_type_param(dtype, offset, val, 0, flag2); for (curr = dl; curr; curr = curr->next) { put_kind_type_param(curr->dtype, offset, val, 0, flag2); } } } if (!flag) { for (curr = dl; curr;) { prev = curr; curr = curr->next; FREE(prev); } dl = NULL; } chkstruct(dtype); } void put_length_type_param(DTYPE dtype, int flag) { typedef struct dtyList { DTYPE dtype; struct dtyList *next; } DL; typedef struct char_info { DTYPE dtype; int situation; int ast; struct char_info *next; } CL; static DL *dl = NULL; DL *curr, *newdl, *prev; static CL *cl = NULL; CL *ccl, *newcl, *pcl; int mem; if (flag == 2) { for (pcl = ccl = cl; ccl;) { ccl = ccl->next; FREE(pcl); pcl = ccl; } cl = NULL; return; } if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype)) return; if (!sem.new_param_dt) { dtype = sem.new_param_dt = create_parameterized_dt(dtype, 0); } for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { DTYPE mem_dtype = DTYPEG(mem); if (PTRVG(mem) || DESCARRAYG(mem)) { continue; } if (PARENTG(mem)) { NEW(newdl, DL, 1); BZERO(newdl, DL, 1); newdl->dtype = dtype; newdl->next = dl; dl = newdl; put_length_type_param(mem_dtype, flag + 1); } if (DTY(mem_dtype) == TY_CHAR || DTY(mem_dtype) == TY_NCHAR) { int ast = DTY(mem_dtype + 1); if (flag >= 3) continue; for (ccl = cl; ccl; ccl = ccl->next) { if (ccl->dtype == mem_dtype && ccl->situation) { goto do_assume_sz; } } if (A_TYPEG(ast) != A_CNST) { int i = chk_kind_parm_set_expr(ast, dtype); if (i > 0) { if (A_TYPEG(i) == A_CNST) { int con = CONVAL2G(A_SPTRG(i)); if (con < 0) { i = chk_asz_deferlen(ast, dtype); if (i == -1 || i == -2) { i = sym_get_scalar(SYMNAME(mem), "len", DT_INT); DTY(mem_dtype + 1) = mk_id(i); do_assume_sz: LENP(mem, ast); NEW(newcl, CL, 1); newcl->dtype = mem_dtype; newcl->situation = 2; newcl->ast = LENG(mem); newcl->next = cl; cl = newcl; ALLOCATTRP(mem, 1); TPALLOCP(mem, 1); goto shared_alloc_char; } else { interr("put_length_type_param: unexpected len type param", 0, 3); LENP(mem, astb.i0); DTY(mem_dtype + 1) = astb.i0; } } else { DTY(mem_dtype + 1) = i; } } else if (A_TYPEG(i) != A_CNST) { DTY(mem_dtype + 1) = i; LENP(mem, i); shared_alloc_char: if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem)) TPALLOCP(mem, 1); ALLOCP(mem, TRUE); USELENP(mem, TRUE); DTYPEP(mem, (DTY(mem_dtype) == TY_CHAR) ? DT_DEFERCHAR : DT_DEFERNCHAR); if (SDSCG(mem) || STYPEG(SDSCG(mem)) != ST_MEMBER) { ENCLDTYPEP(mem, dtype); SDSCP(mem, sym_get_sdescr(mem, 0)); get_all_descriptors(mem); } ALLOCDESCP(mem, TRUE); } else DTY(mem_dtype + 1) = i; } } } if (DTY(mem_dtype) == TY_ARRAY && !DESCARRAYG(mem)) { int numdim, i, num_ast; ADSC *ad; mem_dtype = dup_array_dtype(mem_dtype); DTYPEP(mem, mem_dtype); ad = AD_DPTR(mem_dtype); numdim = AD_NUMDIM(ad); num_ast = 0; for (i = 0; i < numdim; i++) { int lb, ub, bndast, con; if (SDSCG(mem) != 0) { /* replace the descriptor in the bounds expressions with the descriptor created for mem in get_parameterized_dt() */ replace_sdsc_in_bounds(SDSCG(mem), ad, i); } lb = bndast = AD_LWAST(ad, i); if (bndast != 0 && A_ALIASG(bndast) == 0) { int ast = chk_kind_parm_set_expr(bndast, dtype); if (ast > 0) { lb = AD_LWAST(ad, i) = ast; if (A_TYPEG(ast) != A_CNST) { if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem)) TPALLOCP(mem, TRUE); ALLOCP(mem, TRUE); USELENP(mem, TRUE); ADJARRP(mem, TRUE); if (!SDSCG(mem)) { ENCLDTYPEP(mem, dtype); get_static_descriptor(mem); get_all_descriptors(mem); } } } } ub = bndast = AD_UPAST(ad, i); con = USEDEFERG(mem) && A_TYPEG(ub) == A_BINOP ? 0 : chk_asz_deferlen(bndast, dtype); if (con == -1) { USEDEFERP(mem, TRUE); if (A_TYPEG(ub) == A_BINOP && flag < 3) { continue; } } if (!USEDEFERG(mem) && A_TYPEG(ub) == A_BINOP) { ub = mk_stmt(A_BINOP, 0); A_OPTYPEP(ub, A_OPTYPEG(bndast)); A_LOPP(ub, A_LOPG(bndast)); A_ROPP(ub, A_ROPG(bndast)); A_DTYPEP(ub, A_DTYPEG(bndast)); bndast = AD_UPAST(ad, i) = ub; } if (bndast != 0 && A_ALIASG(bndast) == 0) { int ast = chk_kind_parm_set_expr(bndast, dtype); if (ast <= 0 || A_TYPEG(ast) == A_CNST) { int con2 = ast <= 0 ? ast : CONVAL2G(A_SPTRG(ast)); if (con2 <= 0 && (con == -1 || con == -2)) ast = bndast; } if (ast > 0) { ub = AD_UPAST(ad, i) = ast; if (USELENG(mem)) { if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem)) TPALLOCP(mem, TRUE); ALLOCP(mem, TRUE); USELENP(mem, TRUE); ADJARRP(mem, TRUE); if (!SDSCG(mem) || STYPEG(SDSCG(mem)) != ST_MEMBER) { ENCLDTYPEP(mem, dtype); get_static_descriptor(mem); get_all_descriptors(mem); } if (USEDEFERG(mem)) { int mem2, mem3; int mem1 = SYMLKG(mem); int sdsc_mem = mem1; if (sdsc_mem == MIDNUMG(mem) || PTRVG(sdsc_mem)) { sdsc_mem = mem2 = SYMLKG(sdsc_mem); } if (PTRVG(sdsc_mem) || !DESCARRAYG(sdsc_mem)) { sdsc_mem = mem3 = SYMLKG(sdsc_mem); } if (DESCARRAYG(sdsc_mem)) { if (mem1 > NOSYM) USEDEFERP(mem1, TRUE); if (mem2 > NOSYM) USEDEFERP(mem2, TRUE); if (mem3 > NOSYM) USEDEFERP(mem3, TRUE); } } } } } AD_LWAST(ad, i) = mk_bnd_int(lb); AD_UPAST(ad, i) = mk_bnd_int(ub); bndast = mk_binop(OP_SUB, AD_UPAST(ad, i), AD_LWAST(ad, i), astb.bnd.dtype); bndast = mk_binop(OP_ADD, bndast, mk_isz_cval(1, astb.bnd.dtype), astb.bnd.dtype); if (!SDSCG(mem)) { AD_EXTNTAST(ad, i) = bndast; } else { AD_EXTNTAST(ad, i) = get_extent(SDSCG(mem), i); AD_MLPYR(ad, i) = get_local_multiplier(SDSCG(mem), i); } if (!num_ast) { num_ast = bndast; } else { num_ast = mk_binop(OP_MUL, num_ast, bndast, astb.bnd.dtype); } } if (num_ast) { ADD_NUMELM(mem_dtype) = num_ast; } } } if (flag > 0) { for (curr = dl; curr;) { prev = curr; curr = curr->next; FREE(prev); } dl = NULL; } chkstruct(dtype); } /* Replace sdsc in the ASTs for each bound */ static void replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i) { int ast = replace_sdsc_in_ast(sdsc, AD_LWAST(ad, i)); if (ast != 0) { AD_LWAST(ad, i) = ast; } ast = replace_sdsc_in_ast(sdsc, AD_LWBD(ad, i)); if (ast != 0) { AD_LWBD(ad, i) = ast; } ast = replace_sdsc_in_ast(sdsc, AD_UPAST(ad, i)); if (ast != 0) { AD_UPAST(ad, i) = ast; } ast = replace_sdsc_in_ast(sdsc, AD_UPBD(ad, i)); if (ast != 0) { AD_UPBD(ad, i) = ast; } } /* If there is an ID node in the ast tree that matches the name of this descriptor, replace it with the sdsc symbol. Return 0 if unchanged. */ static int replace_sdsc_in_ast(int sdsc, int ast) { int lop, rop, sptr; switch (A_TYPEG(ast)) { case A_ID: sptr = A_SPTRG(ast); if (DESCARRAYG(sptr) && sdsc != sptr && strcmp(SYMNAME(sdsc), SYMNAME(sptr)) == 0) { return mk_id(sdsc); } break; case A_BINOP: lop = replace_sdsc_in_ast(sdsc, A_LOPG(ast)); rop = replace_sdsc_in_ast(sdsc, A_ROPG(ast)); if (lop != 0 || rop != 0) { return mk_binop(A_OPTYPEG(ast), lop != 0 ? lop : A_LOPG(ast), rop != 0 ? rop : A_ROPG(ast), A_DTYPEG(ast)); } break; case A_SUBSCR: lop = replace_sdsc_in_ast(sdsc, A_LOPG(ast)); if (lop != 0) { return mk_subscr_copy(lop, A_ASDG(ast), A_DTYPEG(ast)); } break; } return 0; } int get_len_parm_by_number(int num, int dtype, int flag) { int mem, i; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { i = get_len_parm_by_number(num, DTYPEG(PARENTG(mem)), flag); if (i) return i; } if (LENPARMG(mem) == num) { if (!flag || DEFERLENG(mem) || ASZG(mem)) { return mk_id(mem); } else { INT val[2]; val[0] = 0; val[1] = PARMINITG(mem); return mk_cnst(getcon(val, DT_INT)); } } } return 0; } /** \brief Return 0 if there's at least one length type parameter that is not assumed. Otherwise return 1. */ int all_len_parms_assumed(int dtype) { int i, mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { i = all_len_parms_assumed(DTYPEG(PARENTG(mem))); if (!i) return 0; } if (LENPARMG(mem) && !ASZG(mem)) return 0; } return 1; } static void check_kind_type_param(int dtype) { int mem, mem_dtype; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { mem_dtype = DTYPEG(mem); if (PARENTG(mem)) { check_kind_type_param(mem_dtype); } if (!SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) && !LENPARMG(mem) && !PARMINITG(mem)) { error(155, 3, gbl.lineno, "Missing constant value for kind type parameter", SYMNAME(mem)); } } } LOGICAL put_kind_type_param(DTYPE dtype, int offset, int value, int expr, int flag) { int mem; LOGICAL found = FALSE; if (DTY(dtype) != TY_DERIVED) { return FALSE; } for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { DTYPE mem_dtype = DTYPEG(mem); if (PARENTG(mem)) { if (is_pdt_dtype(mem_dtype)) { found = put_kind_type_param(mem_dtype, offset, value, expr, flag); } } else if (USEKINDG(mem) && KINDG(mem) == offset) { if (expr && A_TYPEG(expr) != A_CNST) { error(155, ERR_Severe, gbl.lineno, "Kind type parameter value must be a compile-time constant" " for component", SYMNAME(mem)); } if (DTY(mem_dtype) != TY_ARRAY) { int ast; DTYPE out_dtype; int ty; if (DT_ISINT(mem_dtype)) ty = TY_INT; else if (DT_ISREAL(mem_dtype)) ty = TY_REAL; else if (DT_ISCMPLX(mem_dtype)) ty = TY_CMPLX; else ty = DTY(mem_dtype); /* Evaluate the kind expression. If we're processing the * default dtype, then ast is -1. */ ast = chk_kind_parm_set_expr(KINDASTG(mem), dtype); if (ast > 0 && A_TYPEG(ast) == A_CNST) { value = CONVAL2G(A_SPTRG(ast)); } else if (ast > 0) { error(155, ERR_Severe, gbl.lineno, "Kind type parameter value must be a compile-time constant" " for component", SYMNAME(mem)); } if (ast > 0 || value == 1 || value == 2 || value == 4 || value == 8) { out_dtype = select_kind(mem_dtype, ty, value); } else { out_dtype = mem_dtype; } ty = DTY(out_dtype); if (ty == TY_CHAR || ty == TY_NCHAR) { int sym; out_dtype = get_type(2, ty, DTY(mem_dtype + 1)); ast = DTY(mem_dtype + 1); switch (A_TYPEG(ast)) { case A_ID: case A_LABEL: case A_ENTRY: case A_SUBSCR: case A_SUBSTR: case A_MEM: sym = sym_of_ast(ast); break; default: sym = 0; } if (!get_len_parm(sym, dtype) && LENG(mem) && USELENG(mem)) { ast = get_len_parm_by_number(LENG(mem), dtype, sem.type_mode || sem.new_param_dt); } } else { ast = 0; } if (ast) DTY(mem_dtype + 1) = ast; DTYPEP(mem, out_dtype); } else { int ast; DTYPE out_dtype; DTYPE base_dtype = DTY(mem_dtype + 1); int ty; if (DT_ISINT(base_dtype)) ty = TY_INT; else if (DT_ISREAL(base_dtype)) ty = TY_REAL; else if (DT_ISCMPLX(base_dtype)) ty = TY_CMPLX; else ty = DTY(base_dtype); out_dtype = select_kind(base_dtype, ty, value); if (ty == TY_CHAR || ty == TY_NCHAR) { out_dtype = get_type(2, ty, DTY(base_dtype + 1)); ast = DTY(base_dtype + 1); } else { ast = 0; } DTY(mem_dtype + 1) = out_dtype; if (ast) DTY(base_dtype + 1) = ast; } found = TRUE; } else if (flag <= 0 && !SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) == offset) { if (flag == -1) DEFERLENP(mem, TRUE); if (flag == -2) { ASZP(mem, TRUE); } KINDP(mem, value); SETKINDP(mem, TRUE); if (LENPARMG(mem)) { LENP(mem, expr); } if (flag == 0 && !LENPARMG(mem) && expr && !chk_kind_parm_expr(expr, dtype, 0, 1)) { error(155, 3, gbl.lineno, "Constant expression required for KIND type" " parameter", SYMNAME(mem)); } found = TRUE; } } return found; } static void chk_new_param_dt(int sptr, int dtype) { int mem; if (DTY(dtype) != TY_DERIVED) return; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (DEFERLENG(mem)) { if (!LENPARMG(mem)) { error(155, 3, gbl.lineno, "Deferred type parameter (:) cannot be used with non-length type " "parameter", SYMNAME(mem)); } if (!ALLOCATTRG(sptr) && !POINTERG(sptr)) { error(155, 3, gbl.lineno, "A deferred type parameter (:) must be used with " " an allocatable or pointer object", SYMNAME(sptr)); } } if (ASZG(mem)) { if (!LENPARMG(mem)) { error(155, 3, gbl.lineno, "Assumed type parameter (*) cannot be used with non-length type " "parameter", SYMNAME(mem)); } if (SCG(sptr) != SC_DUMMY) { error(155, 3, gbl.lineno, "An assumed type parameter (*) cannot be used with non-dummy " "argument", SYMNAME(sptr)); } } } } static int get_vtoff(int vtoff, DTYPE dtype) { SPTR sym = get_struct_members(dtype); for (; sym > NOSYM; sym = SYMLKG(sym)) { if (PARENTG(sym)) { int parent_vtoff = VTOFFG(get_struct_tag_sptr(DTYPEG(sym))); if (parent_vtoff > vtoff) { vtoff = parent_vtoff; } vtoff = get_vtoff(vtoff, DTYPEG(sym)); } if (is_tbp(sym)) { if (VTOFFG(BINDG(sym)) > vtoff) { vtoff = VTOFFG(BINDG(sym)); } } } return vtoff; } int get_unl_poly_sym(int mem_dtype) { int mem, dtype, i; int sptr = getsymf("_f03_unl_poly$%d", mem_dtype); if (STYPEG(sptr) == ST_UNKNOWN) { sptr = declsym(sptr, ST_TYPEDEF, TRUE); CCSYMP(sptr, 1); dtype = get_type(6, TY_DERIVED, NOSYM); DTYPEP(sptr, dtype); DTY(dtype + 1) = NOSYM; DTY(dtype + 2) = 0; /* will be filled in */ DTY(dtype + 3) = sptr; DTY(dtype + 5) = 0; UNLPOLYP(sptr, 1); DCLDP(sptr, TRUE); if (!sem.interface) get_static_type_descriptor(sptr); if (mem_dtype) { mem = getccsym_sc('d', sem.dtemps++, ST_MEMBER, SC_NONE); DTYPEP(mem, mem_dtype); SYMLKP(mem, DTY(dtype + 1)); DTY(dtype + 1) = mem; } } else { dtype = DTYPEG(sptr); if (DTY(dtype) == TY_DERIVED) { DTY(dtype + 3) = sptr; UNLPOLYP(sptr, 1); CCSYMP(sptr, 1); get_static_type_descriptor(sptr); } } return sptr; } /** \brief Returns true if dtype is a derived type that has a type parameter or * if it has a component that has a type parameter. * * This function also takes into account recursive components. */ static int has_type_parameter2(int dtype, int visit_flag) { typedef struct visitDty { int dty; struct visitDty *next; } VISITDTY; static VISITDTY *visit_list = 0; VISITDTY *curr, *new_visit, *prev; int rslt; int dty = dtype; int member, dty2; if (DTY(dty) == TY_ARRAY) dty = DTY(dty + 1); if (DTY(dty) != TY_DERIVED) { return 0; } if (visit_list) { for (curr = visit_list; curr; curr = curr->next) { if (curr->dty == dty) { return 0; } } } NEW(new_visit, VISITDTY, 1); new_visit->dty = dty; new_visit->next = visit_list; visit_list = new_visit; for (rslt = 0, member = DTY(dty + 1); member > NOSYM; member = SYMLKG(member)) { if (!USEKINDG(member) && KINDG(member)) { rslt = 1; break; } if (has_type_parameter2(DTYPEG(member), 1)) { rslt = 1; break; } } if (!visit_flag && visit_list) { for (prev = curr = visit_list; curr;) { curr = curr->next; FREE(prev); prev = curr; } visit_list = 0; } return rslt; } /** \brief checks to see if derived type record, dtype, has any type * parameters (kind or length type parameters). * * \param dtype is the derived type record we're searching * * \return integer > 0 if dtype has type parameters; else 0. */ int has_type_parameter(int dtype) { return has_type_parameter2(dtype, 0); } static int has_length_type_parameter(int dtype) { int mem; if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem) && has_length_type_parameter(DTYPEG(mem))) return 1; if (!USEKINDG(mem) && KINDG(mem) && LENPARMG(mem)) { return 1; } } return 0; } int has_length_type_parameter_use(int dtype) { int mem; if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); if (DTY(dtype) != TY_DERIVED) return 0; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem) && has_length_type_parameter_use(DTYPEG(mem))) return 1; if (USELENG(mem)) { return 1; } } return 0; } static int get_highest_param_offset(int dtype) { int mem, start, p; if (DTY(dtype) != TY_DERIVED) return -1; for (start = 0, mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { start = get_highest_param_offset(DTYPEG(PARENTG(mem))); } if (!USEKINDG(mem) && (p = KINDG(mem))) { if (p > start) start = p; } } return start; } /** \brief Create a parameterized derived type based on dtype. If force is not set and dtype is already a PDT, return DT_NONE. */ DTYPE create_parameterized_dt(DTYPE dtype, LOGICAL force) { int mem; int prev_mem; if (!has_type_parameter(dtype)) { return DT_NONE; } if (!force && is_pdt_dtype(dtype)) { return DT_NONE; } dtype = get_parameterized_dt(dtype); prev_mem = NOSYM; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { if (PARENTG(mem)) { DTYPE new_dtype = create_parameterized_dt(DTYPEG(mem), force); if (new_dtype) { int new_mem = insert_dup_sym(mem); DTYPEP(new_mem, new_dtype); if (prev_mem == NOSYM) { DTY(dtype + 1) = new_mem; } else { SYMLKP(prev_mem, new_mem); } } break; } prev_mem = mem; } return dtype; } /** \brief Duplicate \a dtype by creating a new derived type with a $pt suffix. For use with processing parameterized derived type. */ DTYPE get_parameterized_dt(DTYPE dtype) { int tag, mem, sptr; int first_mem = NOSYM; int curr_mem = NOSYM; DTYPE new_dtype; ACL *ict; assert(DTY(dtype) == TY_DERIVED, "expected TY_DERIVED", DTY(dtype), ERR_Fatal); tag = DTY(dtype + 3); sptr = get_next_sym(SYMNAME(tag), "pt"); DINITP(sptr, DINITG(tag)); sptr = declsym(sptr, ST_TYPEDEF, TRUE); BASETYPEP(sptr, dtype); CCSYMP(sptr, 1); new_dtype = get_type(6, TY_DERIVED, NOSYM); DTYPEP(sptr, new_dtype); DTY(new_dtype + 2) = 0; /* will be filled in */ DTY(new_dtype + 3) = sptr; for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { int new_mem = insert_dup_sym(mem); VARIANTP(new_mem, curr_mem); ENCLDTYPEP(new_mem, new_dtype); ADDRESSP(new_mem, 0); if (first_mem == NOSYM) { first_mem = new_mem; } else { SYMLKP(curr_mem, new_mem); } curr_mem = new_mem; } DTY(new_dtype + 1) = first_mem; for (mem = first_mem; mem > NOSYM; mem = SYMLKG(mem)) { int descr; if (MIDNUMG(mem) && STYPEG(MIDNUMG(mem)) == ST_MEMBER) { int mid_mem = SYMLKG(mem); if (PTRVG(mid_mem) && strcmp(SYMNAME(mid_mem), SYMNAME(MIDNUMG(mem))) == 0) { int off_mem; MIDNUMP(mem, mid_mem); off_mem = SYMLKG(mid_mem); if (PTROFFG(mem) && STYPEG(PTROFFG(mem)) == ST_MEMBER) PTROFFP(mem, off_mem); } } if (SDSCG(mem) && STYPEG(mem) == ST_MEMBER) { /* Always dup the component descriptor's array dtype */ int sdsc_mem = get_member_descriptor(mem); if (sdsc_mem > NOSYM && DESCARRAYG(sdsc_mem)) { DTYPEP(sdsc_mem, dup_array_dtype(DTYPEG(sdsc_mem))); SDSCP(mem, sdsc_mem); } } descr = DESCRG(mem); if (descr != 0) { /* duplicate the descr */ int new_descr = insert_dup_sym(descr); DESCRP(mem, new_descr); SECDSCP(new_descr, match_memname(SECDSCG(new_descr), first_mem)); ARRAYP(new_descr, match_memname(ARRAYG(new_descr), first_mem)); } } ict = get_getitem_p(DTY(dtype + 5)); if (ict != 0) { ACL *newict = dup_acl(ict, sptr); DTY(new_dtype + 5) = put_getitem_p(newict); } else { DTY(new_dtype + 5) = 0; } chkstruct(new_dtype); return new_dtype; } static ACL * dup_acl(ACL *src, int sptr) { ACL *subc = src->subc; ACL *next = src->next; ACL *dst = GET_ACL(15); *dst = *src; dst->sptr = sptr; if (DTY(src->dtype) == TY_DERIVED) { dst->dtype = DTYPEG(sptr); } if (subc != 0) { dst->subc = dup_acl(subc, match_memname(subc->sptr, DTY(DTYPEG(sptr) + 1))); } if (next != 0) { dst->next = dup_acl(next, match_memname(next->sptr, SYMLKG(sptr))); } return dst; } /* Return the symbol in mem list (linked through SYMLK) whose name matches sptr. Return sptr if there is none. */ static int match_memname(int sptr, int mem) { for (; mem > NOSYM; mem = SYMLKG(mem)) { if (NMPTRG(sptr) == NMPTRG(mem)) { return mem; } } return sptr; } /* Return TRUE if dtype represents a parameterized derived type. */ static LOGICAL is_pdt_dtype(DTYPE dtype) { return DTY(dtype) == TY_DERIVED && strstr(SYMNAME(DTY(dtype + 3)), "$pt") != 0; } /** \brief allow other source files to check whether we're processing a * parameter construct. */ int is_parameter_context() { return (entity_attr.exist & ET_B(ET_PARAMETER)); } static int mystrcasecmp(char *a, char *b) { while (*a && *b) { char aa = *a++, bb = *b++; if (aa >= 'A' && aa <= 'Z') aa = aa - 'A' + 'a'; if (bb >= 'A' && bb <= 'Z') bb = bb - 'A' + 'a'; if (aa != bb) return aa - bb; } return 0; } /* mystrcasecmp */ static LOGICAL ignore_common_decl(void) { if (sem.which_pass == 0) { if (sem.mod_cnt && gbl.currsub) { /* * Do not process the common declaration if in a module subroutine */ return TRUE; } } return FALSE; } /** \brief Return the predicate: current entity has the INTRINSIC attribute. */ bool in_intrinsic_decl(void) { return (entity_attr.exist & ET_B(ET_INTRINSIC)) != 0; } /** \brief provide the current entity's access to other source files. */ int get_entity_access() { return entity_attr.access; } /** \brief provide mscall variable state to other source files. */ int getMscall() { return mscall; } /** \brief provide cref variable state to other source files. */ int getCref() { return cref; } /** \brief Determine procedure symbol type for a set of attributes * * \param attr attribute mask * * \return symbol type index, zero on error */ static int get_procedure_stype(int attr) { if (attr & ET_B(ET_POINTER)) { if (!INSIDE_STRUCT) { return ST_VAR; } return ST_MEMBER; } if (INSIDE_STRUCT) { return 0; } return ST_PROC; } /** \brief Declare a procedure symbol * * Perform check nesessary for a declaration or procedure and produce a new * symbol that matches procedure interface and attributes * * \param sptr symbol table index for the symbol * \param proc_interf_sptr symbol table entry for procedure interface * \param attr attributes (bit vector), same as entity_attr.exist * * \return symbol table index for created symbol */ static int decl_procedure_sym(int sptr, int proc_interf_sptr, int attr) { /* First get expected symbol type */ int stype = get_procedure_stype(attr); if (!stype) { /* TODO better place for this error message? */ error(155, 3, gbl.lineno, "PROCEDURE component must have the POINTER attribute -", SYMNAME(sptr)); return 0; } /* Create a new symbol */ if (stype != ST_MEMBER) { sptr = declsym(sptr, stype, FALSE); } else { if (STYPEG(sptr) != ST_UNKNOWN) sptr = insert_sym(sptr); SYMLKP(sptr, NOSYM); STYPEP(sptr, ST_MEMBER); if (attr & ET_B(ET_NOPASS)) { NOPASSP(sptr, 1); } else { if (!proc_interf_sptr) { error(155, 3, gbl.lineno, "The NOPASS attribute must be present for", SYMNAME(sptr)); } if (attr & ET_B(ET_PASS)) { PASSP(sptr, entity_attr.pass_arg); if (IN_MODULE_SPEC) { /* Pop the pass arg so it does not pollute * other dummy arguments with same name in module. * That's because we do not rewrite the pass arg when * it's encountered in the contains subroutine. We only * write out new symbols. The pass arg does not get its * STYPE and CLASS fields, for example, set until we * process the contains subroutine. Later, when we use * the module, we pull in the uninitialized pass argument * which leads to problems if arg is declared CLASS and * it does not have CLASS set. */ pop_sym(entity_attr.pass_arg); } } } } return sptr; } /** \brief Process procedure declaration * * Modify symbol table entry for a procedure declaration, producing the right * datatype for procedure pointers or members. * * \param sptr symbol table index for the symbol * \param proc_interf_sptr symbol table entry for procedure interface * \param attr attributes (bit vector), same as entity_attr.exist * \param access access level, same as entity_attr.access * * \return index of produced symbol table entry, 0 if error * */ static int setup_procedure_sym(int sptr, int proc_interf_sptr, int attr, char access) { int ast; int stype; int dtype; ACL *ict; VAR *ivl; /* ********** Determine symbol type ********** */ stype = get_procedure_stype(attr); /* * Check for required attributes */ if (!stype) { /* TODO better place for this error message? */ error(155, 3, gbl.lineno, "PROCEDURE component must have the POINTER attribute -", SYMNAME(sptr)); return 0; } if ((stype != ST_MEMBER) && (attr & (ET_B(ET_SAVE) | ET_B(ET_INTENT)))) { if (!(attr & ET_B(ET_POINTER))) { error(155, 3, gbl.lineno, "The POINTER attribute must be present for", SYMNAME(sptr)); return sptr; } } STYPEP(sptr, stype); if (sem.gdtype != -1) { dtype = sem.gdtype; } else if (proc_interf_sptr) { dtype = DTYPEG(proc_interf_sptr); } else { dtype = DTYPEG(sptr); } DCLDP(sptr, TRUE); if (stype == ST_PROC) { if (proc_interf_sptr && (!gbl.currsub || SCG(sptr))) { defer_iface(proc_interf_sptr, 0, sptr, 0); } else if (scn.stmtyp == TK_PROCEDURE) /* have a procedure without an interface, i.e., * procedure() [...] :: foo * Assume 'subroutine' */ dtype = DT_NONE; } else { /* stype == ST_MEMBER or ST_VAR => have an entity-style declaration with * the POINTER attribute */ dtype = get_type(6, TY_PROC, dtype); DTY(dtype + 2) = 0; /* interface */ DTY(dtype + 3) = 0; /* PARAMCT */ DTY(dtype + 4) = 0; /* DPDSC */ DTY(dtype + 5) = 0; /* FVAL */ if (proc_interf_sptr) { DTY(dtype + 2) = proc_interf_sptr; /* Set interface */ defer_iface(proc_interf_sptr, dtype, 0, sptr); } else if (sem.gdtype == -1) /* * Have procedure( ), pointer [...] :: foo k * If a type appears as the interface name, sem.gdtype will be set to * that type. */ DTY(dtype + 1) = DT_NONE; dtype = get_type(2, TY_PTR, dtype); if (STYPEG(sptr) != ST_VAR || !IS_PROC_DUMMYG(sptr)) POINTERP(sptr, TRUE); if (access == 'v' || (sem.accl.type == 'v' && access != 'u')) { /* Set PRIVATE here for procedure pointers. */ PRIVATEP(sptr, 1); } } DTYPEP(sptr, dtype); /* ********** Add any additional attributes and return ********** */ if (stype == ST_MEMBER) { stsk = &STSK_ENT(0); /* link field-namelist into member list at this level */ link_members(stsk, sptr); } if (attr & ET_B(ET_SAVE)) SAVEP(sptr, 1); if (attr & ET_B(ET_OPTIONAL)) OPTARGP(sptr, 1); if (attr & ET_B(ET_PROTECTED)) PROTECTEDP(sptr, 1); if (attr & ET_B(ET_BIND)) process_bind(sptr); return sptr; } static void record_func_result(int func_sptr, int func_result_sptr, LOGICAL in_ENTRY) { if (gbl.rutype != RU_FUNC) return; /* can't have a RESULT clause unless a function */ if (in_ENTRY && FVALG(func_sptr) != 0) { if (func_result_sptr) error(155, 3, gbl.lineno, "The ENTRY cannot have a result name -", SYMNAME(func_sptr)); return; } if (func_result_sptr != 0) { /* result variable from RESULT(func_result_sptr) clause */ RESULTP(func_sptr, TRUE); if (in_ENTRY) DCLDP(func_sptr, TRUE); } else { /* insert a dummy variable with the name of the function */ func_result_sptr = insert_sym(func_sptr); pop_sym(func_result_sptr); STYPEP(func_result_sptr, ST_IDENT); SCOPEP(func_result_sptr, stb.curr_scope); SCP(func_result_sptr, SC_DUMMY); if (!in_ENTRY && sem.interface) { NODESCP(func_result_sptr, TRUE); IGNOREP(func_result_sptr, TRUE); } } if (in_ENTRY && RESULTG(func_result_sptr) != 0) { /* create_func_entry_result() discovered that a variable * named the same as the result-name was already declared. * transfer data type to entry */ DTYPEP(func_sptr, DTYPEG(func_result_sptr)); } else { if (DTYPEG(func_sptr)) { /* transfer data type from FUNCTION statement to func_result_sptr */ DTYPEP(func_result_sptr, DTYPEG(func_sptr)); ADJLENP(func_result_sptr, ADJLENG(func_sptr)); } RESULTP(func_result_sptr, TRUE); } FVALP(func_sptr, func_result_sptr); if (DCLDG(func_sptr)) DCLDP(func_result_sptr, TRUE); } /** \brief Determine if a type bound procedure (tbp) binding name requires * overloading. * * This is called by the ::= '=>' production * above. After the tbp is set up, we perform additional overloading checks * in resolveBind() of semtbp.c. * * \pararm sptr is the binding name that we are checking. * * \return true if it is an overloaded binding name, else false. */ static bool bindingNameRequiresOverloading(SPTR sptr) { if (STYPEG(sptr) == ST_PD) { /* Overloaded intrinsic with same name. */ return true; } if (STYPEG(sptr) == ST_PROC) { if (SCOPEG(sptr) != stb.curr_scope) { /* Another use associated symbol with same name. */ return true; } if (IN_MODULE_SPEC && TBPLNKG(sptr) == 0) { /* Another symbol in module specification section with same name and * same scope. * This is possibly a procedure with the same name declared in an * interface block. */ return true; } } return false; } const char * sem_pgphase_name() { switch (sem.pgphase) { case PHASE_END_MODULE: return "END_MODULE"; case PHASE_INIT: return "INIT"; case PHASE_HEADER: return "HEADER"; case PHASE_USE: return "USE"; case PHASE_IMPORT: return "IMPORT"; case PHASE_IMPLICIT: return "IMPLICIT"; case PHASE_SPEC: return "SPEC"; case PHASE_EXEC: return "EXEC"; case PHASE_CONTAIN: return "CONTAIN"; case PHASE_INTERNAL: return "INTERNAL"; case PHASE_END: return "END"; default: return "unknown"; } } /** \brief To re-initialize an array of derived types when found the * following conditions are satisfied: 1. the element of the array is a derived type. 2. the array has been initialized before and needs to be re-initialized. 3. none of any entity attributes used for array definition. */ static bool do_fixup_param_vars_for_derived_arrays(bool inited, SPTR sptr, int sst_idg) { return sem.dinit_count > 0 && inited && !entity_attr.exist && STYPEG(sptr) == ST_IDENT && sst_idg == S_ACONST && DTY(DTYPEG(sptr)) == TY_ARRAY && DTYG(DTYPEG(sptr)) == TY_DERIVED && /* found the tag has been initialized already with a valid sptr*/ DINITG(DTY(DTY(DTYPEG(sptr)+1)+3)); }