/*********************************************************************/ /* pC++/Sage++ Copyright (C) 1993 */ /* Indiana University University of Oregon University of Rennes */ /*********************************************************************/ /* * sym.c -- hash table routines */ #include #include #include "compatible.h" #ifdef SYS5 #include #else #include #endif #include "defs.h" #include "symb.h" #include "defines.h" #include "bif.h" #include "extern.h" #include "fdvm.h" /*f90.h 10.03.03*/ #include "tokdefs.h" extern int hash(), ndim; extern PTR_BFND cur_bfnd, pred_bfnd, last_bfnd, global_bfnd; extern PTR_TYPE vartype, global_default, impltype[], make_type(); extern PTR_LLND make_llnd(); extern PTR_SYMB make_symb(); /* added for FORTRAN 90 */ extern PTR_LLND first_unresolved_call; extern PTR_LLND last_unresolved_call; extern void err(), errstr(); char *chkalloc(); void warn1(); extern PTR_HASH hash_table[]; extern int warn_all; extern int privateall; /* Scope table variables */ PTR_BFND scope_table[1000]; PTR_TYPE * scope_implicit[1000]; int top_scope_level; int scope_starts[10]; int top_scope_starts; struct operand { int opval; char *opname; } oplist [] = { {PLUS, "+"}, {MINUS, "-"}, {ASTER, "*"}, {DASTER, "**"}, {SLASH, "/"}, {DSLASH, "//"}, {AND, ".and."}, {OR, ".or."}, {XOR, ".xor."}, {NOT, ".not."}, {EQ, ".eq."}, {NE, ".ne."}, {GT, ".gt."}, {GE, ".ge."}, {LT, ".lt."}, {LE, ".le."}, {NEQV, ".neqv."}, {EQV, ".eqv."}, {0, 0} }; void store_implicit() {PTR_TYPE *impl,*it,*ip; int i; /*fprintf(stderr,"%s\n",scope_table[top_scope_level]->entry.Template.symbol->ident);*/ impl = (PTR_TYPE * ) calloc(26, sizeof(PTR_TYPE)); it=impltype; ip=impl; i=26; while(--i >= 0) *ip++ = *it++; /*return(impl)*/; scope_implicit[top_scope_level] = impl; } void restore_implicit() {PTR_TYPE *impl; int i; /*fprintf(stderr,"restore%s\n",scope_table[top_scope_level]->entry.Template.symbol->ident);*/ impl = scope_implicit[top_scope_level]; for(i=0; i<26; i++) impltype[i] = *impl++; /* it=impltype; i=26; while(--i >= 0) *it++ = *impl++;*/ } void init_scope_table() { scope_table[0] = global_bfnd; top_scope_level = 0; scope_starts[0]= 0; top_scope_starts = 0; scope_implicit[0] = NULL; } PTR_BFND cur_scope() { return (scope_table[top_scope_level]); } PTR_BFND parent_scope(present_scope_level) int present_scope_level; { if (present_scope_level >= 0) return (scope_table[--present_scope_level]); else err("Requested scope level non-existent", 314); return 0; } void add_scope_level(new_scope, due_to_use_stat) PTR_BFND new_scope; int due_to_use_stat; { PTR_BFND tmp; if (due_to_use_stat) { tmp = scope_table[top_scope_level]; scope_table[top_scope_level] = new_scope; scope_table[++top_scope_level] = tmp; } else { if(top_scope_level>0 && !scope_implicit[top_scope_level]) store_implicit(); scope_table[++top_scope_level] = new_scope; scope_starts[++top_scope_starts] = top_scope_level; } } void delete_beyond_scope_level(level) PTR_BFND level; { scope_implicit[top_scope_level] = NULL; top_scope_level = scope_starts[top_scope_starts] - 1; top_scope_starts --; if (top_scope_level < 0) err("Requested scope level non-existent", 314); if(top_scope_level>0) restore_implicit(); } int cur_scope_level() { return (top_scope_level); } PTR_BFND scope_at_level(level) int level; { if (level >= 0) return (scope_table[level]); else errstr("Requested scope non-existent", 315); return 0; } /* look_up_sym(string) : lookup string in the hash table. If a hash table entry having string as it's name, in curent scope is found then return the hash table entry, else make a hash table entry with string as it's name and return it. */ PTR_HASH look_up_sym(string) register char *string; { int i, index, cur_scope_level(); register PTR_HASH entry; PTR_HASH make_hash_entry(); PTR_BFND parent_scope(), scope_at_level(), p; i = hash(string); for (index = cur_scope_level(); index >= 0; index--) { p = scope_at_level(index); for (entry = hash_table[i]; entry; entry = entry->next_entry) { if (!strcmp(string, entry->ident) && (entry->id_attr) && (entry->id_attr->scope == p)) { return (entry); } } } return (make_hash_entry(string)); } PTR_HASH just_look_up_sym_in_scope(scope, string) PTR_BFND scope; register char *string; { int i, cur_scope_level(); register PTR_HASH entry; PTR_HASH make_hash_entry(); PTR_BFND parent_scope(), scope_at_level(), p; i = hash(string); p = scope; for (entry = hash_table[i]; entry; entry = entry->next_entry) { if (!strcmp(string, entry->ident) && (entry->id_attr) && (entry->id_attr->scope == p)) { return (entry); } } return (HSNULL); } PTR_HASH look_up_op(operator) int operator; { struct operand *p; for (p = oplist; p->opname; p++) if (p->opval == operator) return (look_up_sym(p->opname)); errstr("Unknown operator %d", operator, 316); return (HSNULL); } PTR_HASH just_look_up_sym(string) register char *string; { int i, index, cur_scope_level(); register PTR_HASH entry; PTR_HASH make_hash_entry(); PTR_BFND parent_scope(), scope_at_level(), p; i = hash(string); p = cur_scope(); for (index = cur_scope_level(); index >= 0; index--) { p = scope_at_level(index); for (entry = hash_table[i]; entry; entry = entry->next_entry) { if (!strcmp(string, entry->ident) && (entry->id_attr) && (entry->id_attr->scope == p)) { return (entry); } } } return (HSNULL); } PTR_HASH make_hash_entry(string) register char *string; { int i; register PTR_HASH entry; i = hash(string); entry = (struct hash_entry *) chkalloc(sizeof(struct hash_entry)); entry->ident = copys(string); entry->next_entry = hash_table[i]; hash_table[i] = entry; return (entry); } PTR_SYMB make_sym_entry(var_hash_entry, variant, type, scope, kind) PTR_HASH var_hash_entry; int variant, kind; PTR_TYPE type; PTR_BFND scope; { PTR_SYMB var_sym_entry; PTR_SYMB list; /* If type is undefined, then obtain type from implicit type table. */ if ((variant != PROGRAM_NAME) && (variant != DEFAULT) && (variant != MODULE_NAME) && (variant != PROCEDURE_NAME) && (variant != PROCESS_NAME) && (variant != INTERFACE_NAME)) { if (type == TYNULL) { if ((*var_hash_entry->ident - 'a') >= 0) type = impltype[*var_hash_entry->ident - 'a']; } else if ((type->variant == T_ARRAY) && (type->entry.ar_decl.base_type == TYNULL)) { if ((*var_hash_entry->ident-'a') < 0) type->entry.ar_decl.base_type = 0; else type->entry.ar_decl.base_type = impltype[*var_hash_entry->ident - 'a']; } if ((type == TYNULL) || ((type->variant == T_ARRAY) && (type->entry.ar_decl.base_type == TYNULL) && (strcmp(var_hash_entry->ident, "_PROCESSORS") != 0))) { /* errstr("type unknown of %s", var_hash_entry->ident); */ type = global_default; } } var_sym_entry = make_symb(fi, variant, var_hash_entry->ident); /* Point the hash entry to the symbol table entry */ var_hash_entry->id_attr = var_sym_entry; var_sym_entry->variant = variant; var_sym_entry->type = type; var_sym_entry->scope = scope; var_sym_entry->id_list = SMNULL; switch (variant) { case VARIABLE_NAME: /* if not a formal parameter, then mark it as local. */ if (var_sym_entry->entry.var_decl.local != IO) var_sym_entry->entry.var_decl.local = kind; break; case FUNCTION_NAME: case PROCEDURE_NAME: case PROCESS_NAME: var_sym_entry->entry.proc_decl.seen = kind; break; default: break; } /* initialize administrative stuff */ var_sym_entry->outer = SMNULL; var_sym_entry->parent = var_hash_entry; /* var_sym_entry->decl = HARD; */ if(scope == cur_scope() && scope->variant == MODULE_STMT ){ if(privateall) var_sym_entry->attr = var_sym_entry->attr | PRIVATE_BIT; list = scope->entry.Template.symbol->entry.Template.next; /* adding to list of all the identifiers of module */ scope->entry.Template.symbol->entry.Template.next = var_sym_entry; var_sym_entry->entry.Template.next = list; } return(var_sym_entry); } PTR_SYMB make_constant(var_hash_entry, type) PTR_HASH var_hash_entry; PTR_TYPE type; { PTR_SYMB var_sym_entry; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, CONST_NAME, type, cur_scope(), 0)); var_variant = var_sym_entry->variant; if (var_sym_entry->scope == global_bfnd) return (make_sym_entry(make_hash_entry(var_hash_entry->ident), CONST_NAME, type, cur_scope(), 0)); if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: var_sym_entry->variant = CONST_NAME; /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_STRING: case T_ARRAY: if (type != TYNULL) var_sym_entry->type->entry.ar_decl.base_type = type; return (var_sym_entry); case (T_POINTER): if (type != TYNULL) var_sym_entry->type->entry.Template.base_type = type; return (var_sym_entry); case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_STRUCT: case T_DERIVED_TYPE: if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); } break; case CONST_NAME: if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); default: errstr("Inconsistent constant declaration %s", var_hash_entry->ident, 17); return (var_sym_entry);/*return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), CONST_NAME, type, cur_scope(), 0)); } /* Occurence of Function name in it's body not properly taken care of. */ PTR_SYMB make_scalar(var_hash_entry, type, kind) PTR_HASH var_hash_entry; PTR_TYPE type; int kind; { PTR_SYMB var_sym_entry, cur_scope_sym_ptr; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, VARIABLE_NAME, type, cur_scope(), kind)); var_variant = var_sym_entry->variant; cur_scope_sym_ptr = cur_scope()->entry.Template.symbol; if (var_sym_entry->scope != cur_scope()){ /*(var_sym_entry->scope == global_bfnd)*/ if ((cur_scope()->variant == FUNC_HEDR) && (!(strcmp(var_hash_entry->ident, cur_scope_sym_ptr->ident)))) if (type == TYNULL) return (var_sym_entry); else { cur_scope_sym_ptr->type = type; /* result_sym_ptr = cur_scope_sym_ptr->entry.Template.declared_name; if (result_sym_ptr) result_sym_ptr->type = type; */ /*19.03.03*/ return (var_sym_entry); } else return (make_sym_entry(make_hash_entry(var_hash_entry->ident), VARIABLE_NAME, type, cur_scope(), kind)); } if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_STRING: case T_ARRAY: if (type != TYNULL) var_sym_entry->type->entry.ar_decl.base_type = type; return (var_sym_entry); case T_POINTER: if (type != TYNULL) var_sym_entry->type->entry.Template.base_type = type; return (var_sym_entry); case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_STRUCT: case T_DERIVED_TYPE: if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); } break; case CONST_NAME: if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); case ROUTINE_NAME: case FUNCTION_NAME: if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); case LABEL_VAR: return (var_sym_entry); case TYPE_NAME: case PROCEDURE_NAME: case INTERFACE_NAME: case NAMELIST_NAME: return (var_sym_entry); default: errstr("Inconsistent declaration of identifier %s",var_hash_entry->ident,16); return (var_sym_entry); /* return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), VARIABLE_NAME, type, cur_scope(), kind)); } /* make_array(var_hash_entry:PTR_HASH, base_type: PTR_TYPE, dcl_type:int, ranges: PTR_LLND, ndim : int) makes a array symbol table entry. */ PTR_SYMB make_array(var_hash_entry, base_type, ranges, ndim, kind) PTR_HASH var_hash_entry; PTR_TYPE base_type; PTR_LLND ranges; int ndim, kind; { PTR_SYMB var_sym_entry, cur_scope_sym_ptr; PTR_TYPE array_type; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { array_type = make_type(fi, T_ARRAY); array_type->entry.ar_decl.base_type = base_type; array_type->entry.ar_decl.num_dimensions = ndim; return (make_sym_entry(var_hash_entry, VARIABLE_NAME, array_type, cur_scope(), kind)); } var_variant = var_sym_entry->variant; cur_scope_sym_ptr = cur_scope()->entry.Template.symbol; if (var_sym_entry->scope != cur_scope()){ /*(var_sym_entry->scope == global_bfnd)*/ if ((cur_scope()->variant == FUNC_HEDR) && (!(strcmp(var_hash_entry->ident, cur_scope_sym_ptr->ident)))) if (base_type == TYNULL) return (var_sym_entry); else { array_type = make_type(fi, T_ARRAY); array_type->entry.ar_decl.base_type = base_type; array_type->entry.ar_decl.num_dimensions = ndim; cur_scope_sym_ptr->type = array_type; /*result_sym_ptr = cur_scope_sym_ptr->entry.Template.declared_name; if (result_sym_ptr) result_sym_ptr->type = array_type; *//*19.03.03*/ return (var_sym_entry); } else /*return (make_sym_entry(make_hash_entry(var_hash_entry->ident), VARIABLE_NAME, type, cur_scope(), kind));*/ /* if (var_sym_entry->scope == global_bfnd)*/ { array_type = make_type(fi, T_ARRAY); array_type->entry.ar_decl.base_type = base_type; array_type->entry.ar_decl.num_dimensions = ndim; return (make_sym_entry(make_hash_entry(var_hash_entry->ident), VARIABLE_NAME, array_type, cur_scope(), kind));/*7.03.03*/ } } if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_ARRAY: if (base_type != TYNULL) var_sym_entry->type->entry.ar_decl.base_type = base_type; if (ndim) var_sym_entry->type->entry.ar_decl.num_dimensions = ndim; return (var_sym_entry); case T_STRING: case T_POINTER: case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_DCOMPLEX: case T_BOOL: case T_STRUCT: case T_DERIVED_TYPE: { array_type = make_type(fi, T_ARRAY); if (base_type == TYNULL) array_type->entry.ar_decl.base_type = var_sym_entry->type; else array_type->entry.ar_decl.base_type = base_type; array_type->entry.ar_decl.num_dimensions = ndim; var_sym_entry->type = array_type; return (var_sym_entry); } default: return (var_sym_entry); } default: errstr("Inconsistent array declaration of identifier %s", var_hash_entry->ident,18); return (var_sym_entry);/*return (SMNULL);*/ } array_type = make_type(fi, T_ARRAY); array_type->entry.ar_decl.base_type = base_type; array_type->entry.ar_decl.num_dimensions = ndim; return (make_sym_entry(make_hash_entry(var_hash_entry->ident), VARIABLE_NAME, array_type, cur_scope(), kind)); /*7.03.03*/ } PTR_SYMB make_pointer(var_hash_entry, base_type, kind) PTR_HASH var_hash_entry; PTR_TYPE base_type; int kind; { PTR_SYMB var_sym_entry; PTR_TYPE pointer_type; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { pointer_type = make_type(fi, T_POINTER); pointer_type->entry.Template.base_type = base_type; return (make_sym_entry(var_hash_entry, VARIABLE_NAME, pointer_type, cur_scope(), kind)); } var_variant = var_sym_entry->variant; if (var_sym_entry->scope == global_bfnd) { pointer_type = make_type(fi, T_POINTER); pointer_type->entry.Template.base_type = base_type; return (make_sym_entry(var_hash_entry, VARIABLE_NAME, pointer_type, cur_scope(), kind)); } if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_POINTER: if (base_type != TYNULL) var_sym_entry->type->entry.Template.base_type = base_type; return (var_sym_entry); case T_STRING: case T_ARRAY: case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_STRUCT: case T_DERIVED_TYPE: { pointer_type = make_type(fi, T_POINTER); if (base_type == TYNULL) pointer_type->entry.Template.base_type = var_sym_entry->type; else pointer_type->entry.Template.base_type = base_type; var_sym_entry->type = pointer_type; return (var_sym_entry); } default: return (var_sym_entry); } default: errstr("Inconsistent declaration of identifier %s",var_hash_entry->ident,16); return (var_sym_entry); /* return (SMNULL);*/ } pointer_type = make_type(fi, T_POINTER); pointer_type->entry.Template.base_type = base_type; return (make_sym_entry(var_hash_entry, VARIABLE_NAME, pointer_type, cur_scope(), kind)); } PTR_SYMB make_function(var_hash_entry, type, kind) PTR_HASH var_hash_entry; PTR_TYPE type; int kind; { PTR_SYMB var_sym_entry; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL){ if (kind == LOCAL) return (make_sym_entry(var_hash_entry, FUNCTION_NAME, type, cur_scope(), kind)); else return (make_sym_entry(var_hash_entry, FUNCTION_NAME, type, global_bfnd, kind)); } var_variant = var_sym_entry->variant; if (var_sym_entry->scope == global_bfnd) { if (var_variant == FUNCTION_NAME) { if (kind == LOCAL) return (make_sym_entry(var_hash_entry, FUNCTION_NAME, type, cur_scope(), kind)); else return var_sym_entry; } else if (var_variant == ROUTINE_NAME) { var_sym_entry->variant = FUNCTION_NAME;/* FB Modified == before*/ return var_sym_entry; } else if (var_variant == INTERFACE_NAME) return var_sym_entry; else if (var_variant == DEFAULT){ /* intrinsic function can have same name as a common block name */ if(warn_all) warn1("Function has the same name as a common block %s.",var_hash_entry->ident, 24); var_sym_entry->variant = FUNCTION_NAME; return var_sym_entry; } else if (var_variant == VARIABLE_NAME) { var_sym_entry->variant = FUNCTION_NAME; /* FB Modified == before*/ return var_sym_entry; } else { errstr("Inconsistent function declaration %s", var_hash_entry->ident, 19); return (var_sym_entry); /* return (SMNULL);*/ } } if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_STRING: case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_POINTER: case T_STRUCT: case T_DERIVED_TYPE: /* if not a formal parameter, convert it into a global function. */ if (var_sym_entry->entry.var_decl.local != IO) { var_sym_entry->variant = FUNCTION_NAME; /* if (kind != LOCAL) var_sym_entry->scope = global_bfnd; */ /*podd 02.02.23*/ } if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); case T_ARRAY: if (kind == LOCAL) { errstr("Inconsistent function declaration %s",var_hash_entry->ident,19); return (var_sym_entry);/* return (SMNULL);*/ } else return (var_sym_entry); } case FUNCTION_NAME: var_sym_entry->variant = FUNCTION_NAME; return (var_sym_entry); case ROUTINE_NAME: var_sym_entry->variant = FUNCTION_NAME; return (var_sym_entry); case INTERFACE_NAME: return (var_sym_entry); default: errstr("Inconsistent function declaration %s", var_hash_entry->ident, 19); return (var_sym_entry); /* return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), FUNCTION_NAME, type, cur_scope(), kind)); } PTR_SYMB make_external(var_hash_entry, type) PTR_HASH var_hash_entry; PTR_TYPE type; { PTR_SYMB var_sym_entry; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, ROUTINE_NAME, type, cur_scope(), NO)); var_variant = var_sym_entry->variant; /* if (var_sym_entry->scope == global_bfnd) { if ((var_variant == FUNCTION_NAME) || (var_variant == PROCEDURE_NAME) || (var_variant == PROCESS_NAME)) return var_sym_entry; else if (var_variant == ROUTINE_NAME) { return var_sym_entry; } else { errstr("Inconsistent procedure declaration %s", var_hash_entry->ident, 20); return (var_sym_entry); } } */ if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_STRING: case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_POINTER: case T_STRUCT: case T_ARRAY: case T_DERIVED_TYPE: /* if not a formal parameter, convert it into a global function. */ if (var_sym_entry->entry.var_decl.local != IO) var_sym_entry->variant = ROUTINE_NAME; if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); } case ROUTINE_NAME: return (var_sym_entry); default: errstr("Inconsistent procedure declaration %s", var_hash_entry->ident, 20); return (var_sym_entry); /*return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), ROUTINE_NAME, type, cur_scope(), NO)); } PTR_SYMB make_intrinsic(var_hash_entry, type) PTR_HASH var_hash_entry; PTR_TYPE type; { PTR_SYMB var_sym_entry; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, ROUTINE_NAME, type, cur_scope(), LOCAL)); var_variant = var_sym_entry->variant; if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ switch (var_sym_entry->type->variant) { case T_STRING: case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_POINTER: case T_STRUCT: case T_ARRAY: case T_DERIVED_TYPE: /* if not a formal parameter, convert it into a global function. */ if (var_sym_entry->entry.var_decl.local != IO)/*7.03.03*/ var_sym_entry->variant = ROUTINE_NAME; if (type != TYNULL) var_sym_entry->type = type; return (var_sym_entry); } case FUNCTION_NAME: case PROCEDURE_NAME: case ROUTINE_NAME: return (var_sym_entry); default: errstr("Inconsistent procedure declaration %s", var_hash_entry->ident, 20); return (var_sym_entry); /* return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), ROUTINE_NAME, type, cur_scope(), LOCAL)); } PTR_SYMB make_procedure(var_hash_entry, kind) PTR_HASH var_hash_entry; int kind; { PTR_SYMB var_sym_entry; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { if (kind == LOCAL) return (make_sym_entry(var_hash_entry, PROCEDURE_NAME, TYNULL, cur_scope(), kind)); else return (make_sym_entry(var_hash_entry, PROCEDURE_NAME, TYNULL, global_bfnd, kind)); } if (var_sym_entry->scope == global_bfnd) { if (var_sym_entry->variant == PROCEDURE_NAME){ if (kind == LOCAL) /*10.03.03*/ return (make_sym_entry(make_hash_entry(var_hash_entry->ident), PROCEDURE_NAME, TYNULL, cur_scope(), kind)); else return var_sym_entry; /* if (var_sym_entry->variant == PROCEDURE_NAME) return (var_sym_entry);*/ } else if (var_sym_entry->variant == PROCESS_NAME) { var_sym_entry->variant = PROCEDURE_NAME; return var_sym_entry; } else if (var_sym_entry->variant == ROUTINE_NAME) { var_sym_entry->variant = PROCEDURE_NAME; return var_sym_entry; } else if (var_sym_entry->variant == INTERFACE_NAME) return var_sym_entry; else { errstr("Inconsistent subroutine declaration %s", var_hash_entry->ident, 21); return (var_sym_entry); /* return (SMNULL);*/ } } if (var_sym_entry->scope == cur_scope()) switch(var_sym_entry->variant) { case PROCEDURE_NAME: return (var_sym_entry); case VARIABLE_NAME: /* if not a formal parameter, convert it into a global procedure. */ if (var_sym_entry->entry.var_decl.local != IO) { var_sym_entry->variant = PROCEDURE_NAME; /* if(kind != LOCAL) var_sym_entry->scope = global_bfnd; */ /*podd 02.02.23*/ } return (var_sym_entry); case PROCESS_NAME: var_sym_entry->variant = PROCEDURE_NAME; return (var_sym_entry); case ROUTINE_NAME: var_sym_entry->variant = PROCEDURE_NAME; return (var_sym_entry); case INTERFACE_NAME: return (var_sym_entry); default: errstr("Inconsistent subroutine declaration %s", var_hash_entry->ident, 21); return (var_sym_entry); /* return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), PROCEDURE_NAME, TYNULL, cur_scope(), kind)); } PTR_SYMB /* make_process added for FORTRAN M */ make_process(var_hash_entry, kind) PTR_HASH var_hash_entry; int kind; { PTR_SYMB var_sym_entry; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { if (kind == LOCAL) return (make_sym_entry(var_hash_entry, PROCESS_NAME, TYNULL, cur_scope(), kind)); else return (make_sym_entry(var_hash_entry, PROCESS_NAME, TYNULL, global_bfnd, kind)); } if (var_sym_entry->scope == global_bfnd) { if (var_sym_entry->variant == PROCESS_NAME) return (var_sym_entry); else if (var_sym_entry->variant == PROCEDURE_NAME) { var_sym_entry->variant = PROCESS_NAME; return var_sym_entry; } else if (var_sym_entry->variant == ROUTINE_NAME) { var_sym_entry->variant = PROCESS_NAME; return var_sym_entry; } else if (var_sym_entry->variant == INTERFACE_NAME) return var_sym_entry; else { errstr("Inconsistent process %s %d", var_hash_entry->ident, var_sym_entry->variant, 317); return (SMNULL); } } if (var_sym_entry->scope == cur_scope()) switch(var_sym_entry->variant) { case PROCESS_NAME: return (var_sym_entry); case VARIABLE_NAME: /* if not a formal parameter, convert it into a global procedure. */ if (var_sym_entry->entry.var_decl.local != IO) { var_sym_entry->variant = PROCESS_NAME; var_sym_entry->scope = global_bfnd; } return (var_sym_entry); case PROCEDURE_NAME: var_sym_entry->variant = PROCESS_NAME; return (var_sym_entry); case ROUTINE_NAME: var_sym_entry->variant = PROCESS_NAME; return (var_sym_entry); case INTERFACE_NAME: return (var_sym_entry); default: errstr("Inconsistent process %s", var_hash_entry->ident,317); return (SMNULL); } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), PROCESS_NAME, TYNULL, global_bfnd, kind)); } PTR_SYMB make_program(var_hash_entry) PTR_HASH var_hash_entry; { PTR_SYMB var_sym_entry; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, PROGRAM_NAME, TYNULL, global_bfnd, 0)); if (var_sym_entry->scope == global_bfnd) { errstr("Inconsistent program declaration %s", var_hash_entry->ident, 22); return (var_sym_entry); /*return (SMNULL);*/ } if (var_sym_entry->scope == cur_scope()) { errstr("Inconsistent program declaration %s", var_hash_entry->ident, 22); return (var_sym_entry); /* return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), PROGRAM_NAME, TYNULL, global_bfnd, 0)); } PTR_SYMB make_module(var_hash_entry) PTR_HASH var_hash_entry; { PTR_SYMB var_sym_entry; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, MODULE_NAME, TYNULL, global_bfnd, 0)); if (var_sym_entry->scope == global_bfnd) { errstr("Inconsistent module declaration %s", var_hash_entry->ident, 331); return (var_sym_entry); /* return (SMNULL);*/ } if (var_sym_entry->scope == cur_scope()) { errstr("Inconsistent module declaration %s", var_hash_entry->ident, 331); return (var_sym_entry); /* return (SMNULL);*/ } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), MODULE_NAME, TYNULL, global_bfnd, 0)); } PTR_SYMB make_common(var_hash_entry) PTR_HASH var_hash_entry; { PTR_SYMB var_sym_entry; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, DEFAULT, TYNULL, global_bfnd, 0)); if (var_sym_entry->scope == global_bfnd) { if (var_sym_entry->variant == DEFAULT) return (var_sym_entry); else { if(var_sym_entry->variant == FUNCTION_NAME){ /* intrinsic function can have same name as a common block name */ if(warn_all) warn1("Common block have same name as a function %s", var_hash_entry->ident, 25); return (var_sym_entry); } else errstr("Inconsistent common declaration %s", var_hash_entry->ident, 23); return (var_sym_entry); /* return (SMNULL);*/ } } /* A local entity can have same name as a common block name. So, ignore the local entity. */ return (make_sym_entry(make_hash_entry(var_hash_entry->ident), DEFAULT, TYNULL, global_bfnd, 0)); } PTR_SYMB make_parallel_region(var_hash_entry) /*SPF*/ PTR_HASH var_hash_entry; { PTR_SYMB var_sym_entry; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) return (make_sym_entry(var_hash_entry, SPF_REGION_NAME, TYNULL, global_bfnd, 0)); if (var_sym_entry->scope == global_bfnd) { if (var_sym_entry->variant != SPF_REGION_NAME) errstr("Inconsistent region declaration %s", var_hash_entry->ident, 630); return (var_sym_entry); } return (make_sym_entry(make_hash_entry(var_hash_entry->ident), SPF_REGION_NAME, TYNULL, global_bfnd, 0)); } PTR_TYPE make_type_node(typespec, lengspec) PTR_TYPE typespec; PTR_LLND lengspec; { PTR_TYPE t; t = typespec; if (lengspec != LLNULL) { t = make_type(fi, typespec->variant); if(typespec->variant == T_STRING) t->entry.Template.dummy1 = typespec->entry.Template.dummy1; /* dummy1=2 for string constant inclosing " */ if(lengspec->variant == LEN_OP) { t->entry.Template.ranges = lengspec; t->entry.Template.kind_len = typespec->entry.Template.kind_len; } else t->entry.Template.kind_len = lengspec; } return (t); } PTR_SYMB make_derived_type(var_hash_entry, type, kind) PTR_HASH var_hash_entry; PTR_TYPE type; int kind; { PTR_SYMB var_sym_entry; PTR_TYPE struct_type; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { struct_type = make_type(fi, T_STRUCT); return (make_sym_entry(var_hash_entry, TYPE_NAME, struct_type, cur_scope(), kind)); } var_variant = var_sym_entry->variant; if (var_sym_entry->scope == global_bfnd) { struct_type = make_type(fi, T_STRUCT); return (make_sym_entry(make_hash_entry(var_hash_entry->ident), TYPE_NAME, struct_type, cur_scope(), kind));/*16.03.03*/ } if (var_sym_entry->scope == cur_scope()) switch(var_variant) { case VARIABLE_NAME: /* var_sym_entry's type */ var_sym_entry->variant = TYPE_NAME; switch (var_sym_entry->type->variant) { case T_STRING: case T_ARRAY: if (type != TYNULL) var_sym_entry->type->entry.ar_decl.base_type = type; return (var_sym_entry); case T_INT: case T_FLOAT: case T_DOUBLE: case T_COMPLEX: case T_BOOL: case T_POINTER: case T_STRUCT: { struct_type = make_type(fi, T_STRUCT); var_sym_entry->type = struct_type; return (var_sym_entry); } default: return (var_sym_entry); } case TYPE_NAME: /*added 24.04.12*/ { struct_type = make_type(fi, T_STRUCT); var_sym_entry->type = struct_type; return (var_sym_entry); } default: errstr("Inconsistent struct declaration of identifier %s", var_hash_entry->ident,318); return (var_sym_entry); /* return (SMNULL);*/ } struct_type = make_type(fi, T_STRUCT); return (make_sym_entry(make_hash_entry(var_hash_entry->ident), TYPE_NAME, struct_type, cur_scope(), kind)); /*16.03.03*/ } PTR_SYMB make_local_entity(var_hash_entry, variant, type, kind) PTR_HASH var_hash_entry; PTR_TYPE type; int variant, kind; { PTR_SYMB var_sym_entry; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { return (make_sym_entry(var_hash_entry, variant, type, cur_scope(), kind)); } var_variant = var_sym_entry->variant; if (var_sym_entry->scope == global_bfnd) { return (make_sym_entry(make_hash_entry(var_hash_entry->ident), variant, type, cur_scope(), kind)); /*16.03.03*/ } if (var_sym_entry->scope == cur_scope()) switch(var_variant) { default: if (variant == var_variant) return(var_sym_entry); else { errstr("Inconsistent declaration of identifier %s", var_hash_entry->ident, 16); return (var_sym_entry); /*return (SMNULL);*/ } }; return (make_sym_entry(make_hash_entry(var_hash_entry->ident), variant, type, cur_scope(), kind));/*16.03.03*/ } PTR_SYMB make_global_entity(var_hash_entry, variant, type, kind) PTR_HASH var_hash_entry; PTR_TYPE type; int variant, kind; { PTR_SYMB var_sym_entry; int var_variant; var_sym_entry = var_hash_entry->id_attr; if (var_sym_entry == SMNULL) { return (make_sym_entry(var_hash_entry, variant, type, global_bfnd, kind)); } var_variant = var_sym_entry->variant; if (var_sym_entry->scope == global_bfnd) switch(var_variant) { default: if (variant == var_variant) return(var_sym_entry); else { errstr("Inconsistent declaration of identifier %s", var_hash_entry->ident, 16); return (var_sym_entry); /* return (SMNULL);*/ } }; errstr("Inconsistent declaration of identifier %s", var_hash_entry->ident, 16); return (var_sym_entry); /*return (SMNULL);*/ } void process_type(type_var, type_fields_end) PTR_SYMB type_var; PTR_BFND type_fields_end; { PTR_SYMB sym_temp, last_field; PTR_LLND ll_temp; PTR_BFND temp; PTR_BLOB blob_temp; int count = 0; temp = cur_scope(); blob_temp = temp->entry.Template.bl_ptr1; while(blob_temp->ref->variant != VAR_DECL) blob_temp = blob_temp->next; /*last_field = blob_temp->ref->entry.Template.ll_ptr1->entry.list.item->entry.Template.symbol;*/ type_var->type->variant = T_STRUCT; type_var->type->name = type_var; /*18.03.03*/ /* The field derived class is a constraint put by the design. Maybe instead of T_STRUCT, T_RECORD might be better. But then it would be inconsistent with C++. */ /*type_var->type->entry.derived_class.first = last_field;*/ last_field = SMNULL; while (blob_temp && (blob_temp->ref != type_fields_end)) { ll_temp = blob_temp->ref->entry.Template.ll_ptr1; while (ll_temp != LLNULL) { count++; if(ll_temp->entry.list.item->variant == ASSGN_OP || ll_temp->entry.list.item->variant == POINTST_OP)/*2.07.03*/ sym_temp = ll_temp->entry.list.item->entry.Template.ll_ptr1->entry.Template.symbol; else sym_temp = ll_temp->entry.list.item->entry.Template.symbol; /* sym_temp->entry.Template.tag = FIELD_NAME;*/ sym_temp->entry.field.tag = sym_temp->variant; sym_temp->variant = FIELD_NAME; sym_temp->entry.field.base_name = type_var; if(last_field){ last_field->entry.field.next = sym_temp; last_field = sym_temp; } else { last_field = sym_temp; type_var->type->entry.derived_class.first = last_field; } ll_temp = ll_temp->entry.list.next; } blob_temp = blob_temp->next; } type_var->type->entry.derived_class.num_fields = count; last_field->entry.field.next = SMNULL; } void process_interface(end_of_interface) PTR_BFND end_of_interface; { PTR_SYMB sym_temp, last_symbol, interface_symbol; PTR_BFND temp; PTR_BLOB blob_temp; PTR_LLND list; temp = pred_bfnd; blob_temp = temp->entry.Template.bl_ptr1; interface_symbol = pred_bfnd->entry.Template.symbol; if (interface_symbol == SMNULL) return; if((pred_bfnd->variant != INTERFACE_STMT)) return; if(!blob_temp->ref) return; last_symbol = SMNULL; while (blob_temp && (blob_temp->ref != end_of_interface)) { sym_temp = blob_temp->ref->entry.Template.symbol; if(sym_temp != SMNULL){ if(last_symbol) { last_symbol->entry.Template.declared_name = sym_temp; last_symbol = sym_temp; } else { last_symbol = sym_temp; interface_symbol->entry.Template.symb_list = last_symbol;/*19.03.03*/ } blob_temp = blob_temp->next; continue; } /* MODULE_PROC_STMT(module procedure statement)*/ list = blob_temp->ref->entry.Template.ll_ptr1; while(list){ sym_temp = list->entry.Template.ll_ptr1->entry.Template.symbol; if(last_symbol) { last_symbol->entry.Template.declared_name = sym_temp; last_symbol = sym_temp; } else { last_symbol = sym_temp; interface_symbol->entry.Template.symb_list = last_symbol;/*19.03.03*/ } list = list->entry.Template.ll_ptr2; } blob_temp = blob_temp->next; } last_symbol->entry.Template.declared_name = SMNULL; } /* void process_interface(end_of_interface) PTR_BFND end_of_interface; { PTR_SYMB sym_temp, last_symbol, interface_symbol; PTR_BFND temp; PTR_BLOB blob_temp; temp = pred_bfnd; blob_temp = temp->entry.Template.bl_ptr1; interface_symbol = pred_bfnd->entry.Template.symbol; if (interface_symbol == SMNULL) return; if((pred_bfnd->variant != INTERFACE_STMT)) return; if(!blob_temp->ref) return; last_symbol = blob_temp->ref->entry.Template.symbol; interface_symbol->entry.Template.declared_name = last_symbol; while (blob_temp && (blob_temp->ref != end_of_interface)) { sym_temp = blob_temp->ref->entry.Template.symbol; last_symbol->entry.Template.declared_name = sym_temp; blob_temp = blob_temp->next; last_symbol = sym_temp; } last_symbol->entry.Template.declared_name = SMNULL; } */ PTR_TYPE lookup_type(name) PTR_HASH name; { /* PTR_HASH hash_temp; */ PTR_SYMB sym_temp; PTR_TYPE ty_temp; /* hash_temp = just_look_up_sym(name->ident); */ /*05.04.17*/ /* if (hash_temp && (sym_temp = hash_temp->id_attr) && (sym_temp->variant == TYPE_NAME)) { ty_temp = make_type(fi, T_DERIVED_TYPE); ty_temp->name = sym_temp; ty_temp->entry.derived_type.symbol = sym_temp; return (ty_temp); } errstr("Undefined type %s", name->ident,319); return (TYNULL); */ /*24.04.12*/ if (name && (sym_temp = name->id_attr) && (sym_temp->variant == TYPE_NAME)) ; else sym_temp = make_sym_entry(name, TYPE_NAME, TYNULL, cur_scope(), LOCAL); ty_temp = make_type(fi, T_DERIVED_TYPE); ty_temp->name = sym_temp; ty_temp->entry.derived_type.symbol = sym_temp; return (ty_temp); } PTR_SYMB component(type_sym_entry, fieldname) PTR_SYMB type_sym_entry; char *fieldname; { int i; register PTR_HASH entry; register PTR_SYMB t; PTR_SYMB OriginalSymbol(); i = hash(fieldname); for (entry = hash_table[i]; entry; entry = entry->next_entry) { t = entry->id_attr; if (!strcmp(fieldname, entry->ident) && t && (t->variant == FIELD_NAME) && OriginalSymbol(t->entry.field.base_name) == OriginalSymbol(type_sym_entry)) /*type_sym_entry->type->name*/ /*BaseSymbol(type_sym_entry)*//*(!strcmp(t->entry.field.base_name->ident, type_sym_entry->ident)) */ return (t); } return (SMNULL); } PTR_SYMB lookup_type_symbol(type_sym_entry) PTR_SYMB type_sym_entry; { int i; register PTR_HASH entry; register PTR_SYMB s; if (type_sym_entry == NULL) return (SMNULL); if (type_sym_entry->type->variant == T_STRUCT && type_sym_entry->type->name) return (type_sym_entry); i = hash(type_sym_entry->ident); for (entry = hash_table[i]; entry; entry = entry->next_entry) { s = entry->id_attr; if (!strcmp(type_sym_entry->ident, entry->ident) && s) if (s->variant == TYPE_NAME && s->type->variant == T_STRUCT && s->type->name) return (s); } return (SMNULL); } PTR_LLND deal_with_options(name, type, attributes, dims, ndim, value, spec_dims) PTR_HASH name; PTR_TYPE type; int attributes, ndim; PTR_LLND dims, value, spec_dims; { PTR_SYMB s; PTR_LLND l; PTR_TYPE t; l = LLNULL; s = SMNULL; t = TYNULL; if ((attributes & DIMENSION_BIT) && (dims != LLNULL)) { t = make_type(fi, T_ARRAY); t->entry.ar_decl.base_type = type; t->entry.ar_decl.num_dimensions = ndim; t->entry.ar_decl.ranges = dims; } else t = type; if (attributes & PARAMETER_BIT) { s = make_constant(name, type); s->entry.const_value = value; if(!value) errstr("An initialization expression is missing: %s", s->ident,267 ); s->attr = s->attr | attributes; if((t->variant==T_STRING) || (t->variant==T_ARRAY)) l = make_llnd(fi, ARRAY_REF, spec_dims, LLNULL, s); else l = make_llnd(fi, CONST_REF, LLNULL, LLNULL, s); s->type = t; /*7.03.03*/ return (l); } if (attributes & EXTERNAL_BIT) { s = make_scalar(name, type, NO); s->attr = s->attr | attributes; /*s->variant = ROUTINE_NAME;*//*7.02.03*/ l = make_llnd(fi, VAR_REF, LLNULL, LLNULL, s); return (l); } if (attributes & INTRINSIC_BIT) { s = make_intrinsic(name, type); /*make_function(name, type, NO);*/ s->attr = s->attr | attributes; l = make_llnd(fi, VAR_REF, LLNULL, LLNULL, s); return (l); } s = make_scalar(name, type, LOCAL); s->attr = s->attr | attributes; if ((attributes & DIMENSION_BIT) && (dims != LLNULL)) { s->type = t; /*s = make_array(name, type, dims, ndim, LOCAL);*/ l = make_llnd(fi, ARRAY_REF, spec_dims, LLNULL, s); /*s->type->entry.ar_decl.ranges = dims;*/ } if (l == LLNULL) { l = make_llnd(fi, VAR_REF, LLNULL, LLNULL, s); } if (value != LLNULL){ if(value->variant == POINTST_OP) { value->entry.Template.ll_ptr1 = l; l = value; } else l = make_llnd(fi, ASSGN_OP, l, value, SMNULL); s->attr = s->attr | DATA_BIT; /*7.03.03*/ } return (l); } /* PTR_LLND deal_with_options(name, type, attributes, dims, ndim, value, spec_dims) PTR_HASH name; PTR_TYPE type; int attributes, ndim; PTR_LLND dims, value, spec_dims; { PTR_SYMB s; PTR_LLND l; l = LLNULL; if (attributes & PARAMETER_BIT) { s = make_constant(name, type); s->entry.const_value = value; s->attr = s->attr | attributes; l = make_llnd(fi, CONST_REF, LLNULL, LLNULL, s); * return (l);**7.03.03* } if (attributes & EXTERNAL_BIT) { s = make_scalar(name, type, NO); s->attr = s->attr | attributes; *s->variant = ROUTINE_NAME;**7.02.03* l = make_llnd(fi, VAR_REF, LLNULL, LLNULL, s); return (l); } if (attributes & INTRINSIC_BIT) { s = make_intrinsic(name, type); *make_function(name, type, NO);* s->attr = s->attr | attributes; l = make_llnd(fi, VAR_REF, LLNULL, LLNULL, s); return (l); } if ((attributes & DIMENSION_BIT) && (dims != LLNULL)) { s = make_array(s->parent, TYNULL, dims, ndim, LOCAL); l = make_llnd(fi, ARRAY_REF, spec_dims, LLNULL, s); s->type->entry.ar_decl.ranges = dims; else s = make_scalar(name, type, LOCAL); s->attr = s->attr | attributes; if (l == LLNULL) { l = make_llnd(fi, VAR_REF, LLNULL, LLNULL, s); } if (value != LLNULL){ l = make_llnd(fi, ASSGN_OP, l, value, SMNULL); s->attr = s->attr | DATA_BIT; *7.03.03* } return (l); } */ /* PTR_BFND parent_scope(p) register PTR_BFND p; { for (p = p->control_parent; (p != BFNULL) && (p->variant != PROG_HEDR) && (p->variant != PROC_HEDR) && (p->variant != PROS_HEDR) && (p->variant != FUNC_HEDR) && (p->variant != BLOCK_DATA) && (p->variant != FORALL_NODE) && (p->variant != GLOBAL) && (p->variant != CDOALL_NODE) && (p->variant != SDOALL_NODE) && (p->variant != DOACROSS_NODE) && (p->variant != CDOACROSS_NODE) && (p->variant != STRUCT_DECL); p = p->control_parent) ; return (p); } */ int is_array_section_ref(list) PTR_LLND list; { int num_triplets = 0; PTR_LLND p; PTR_TYPE t; p = list; while (p != LLNULL) { /* subscript range */ if (p->entry.Template.ll_ptr1->variant == DDOT) num_triplets++; if ((t = list->entry.Template.ll_ptr1->type)) { if (t->variant == KEYWORD_ARG) return (0); /* vector subscript */ if ((t->variant == T_ARRAY) && (t->entry.ar_decl.base_type->variant == T_INT)) num_triplets++; } p = p->entry.Template.ll_ptr2; } return (num_triplets); } int is_substring_ref(list) PTR_LLND list; { PTR_LLND l1; l1 = list->entry.Template.ll_ptr1; if (l1->variant == KEYWORD_ARG) return (0); if (list && (list->entry.Template.ll_ptr2 == LLNULL) && l1 && (l1->variant == DDOT) && (l1->entry.Template.ll_ptr1->variant == DDOT)) return (1); else return (0); } void bind() { PTR_SYMB s, sym; PTR_LLND tmp; PTR_HASH hash_node; while (first_unresolved_call != LLNULL) { s = first_unresolved_call->entry.Template.symbol; if (s->decl == 0) { hash_node = just_look_up_sym_in_scope(s->scope->control_parent, s->ident); if (hash_node == HSNULL) { s->scope = global_bfnd; } else if ((hash_node->id_attr->variant == s->variant) || (hash_node->id_attr->variant == VARIABLE_NAME)) { sym = hash_node->id_attr; /* remove s from symbol table. */ s->parent->id_attr = SMNULL; first_unresolved_call->entry.Template.symbol = sym; } else errstr("Inconsistent call %s", s->ident, 320); } tmp = first_unresolved_call; first_unresolved_call = tmp->entry.Template.ll_ptr2; tmp->entry.Template.ll_ptr2 = LLNULL; } } void late_bind_if_needed(ll_node) PTR_LLND ll_node; { PTR_SYMB s; s = ll_node->entry.Template.symbol; if ((s->entry.var_decl.local == IO) || (s->decl == YES)) return; else { if (first_unresolved_call == LLNULL) last_unresolved_call = first_unresolved_call = ll_node; else { last_unresolved_call->entry.Template.ll_ptr2 = ll_node; last_unresolved_call = ll_node; } } } void redefine_func_arg_type() {PTR_BFND hedr; PTR_SYMB arg,proc,res; hedr = cur_scope(); if((hedr->variant == FUNC_HEDR) ||(hedr->variant == PROC_HEDR)) proc = hedr->entry.Template.symbol; else return; if((hedr->variant == FUNC_HEDR) && (hedr->entry.Template.ll_ptr2 == LLNULL)){ if (proc->type->variant == T_ARRAY) proc->type->entry.ar_decl.base_type = impltype[*proc->ident - 'a']; else proc->type = impltype[*proc->ident - 'a']; if (hedr->entry.Template.ll_ptr1 != LLNULL){ res = hedr->entry.Template.ll_ptr1->entry.Template.symbol; res->type = impltype[*res->ident - 'a']; } } for(arg = proc->entry.proc_decl.in_list; arg; arg=arg->entry.var_decl.next_in) if (arg->type->variant == T_ARRAY) arg->type->entry.ar_decl.base_type = impltype[*arg->ident - 'a']; else { if (*arg->ident - 'a' >= 0) arg->type = impltype[*arg->ident - 'a']; } } int in_rename_list(symb,list) PTR_SYMB symb; PTR_LLND list; { PTR_SYMB s; PTR_LLND l; for(l = list; l ; l = l->entry.Template.ll_ptr2){ s = l->entry.Template.ll_ptr1->entry.Template.ll_ptr2->entry.Template.symbol; if(!strcmp(symb->ident,s->ident)) return(1); } return(0); } void copy_sym_data(source, dest) PTR_SYMB source, dest; {PTR_SYMB BaseSymbol(); if(source->variant == CONST_NAME) {/* named constant */ /*16.03.03 */ dest->entry.const_value = source->entry.const_value; dest->entry.Template.base_name = BaseSymbol(source); /*27.01.12*/ dest->attr = source->attr; /*06.11.12*/ return; } if(dest->entry.Template.seen == BY_USE) return; dest->attr = source->attr; /* source->attr & (~PRIVATE_BIT) & (~PUBLIC_BIT);*/ dest->attr = dest->attr & (~PRIVATE_BIT); dest->attr = dest->attr & (~PUBLIC_BIT); if(privateall) dest->attr = dest->attr | PRIVATE_BIT; dest->entry.Template.seen = BY_USE; /*source->entry.Template.seen;*/ dest->entry.Template.num_input = source->entry.Template.num_input; dest->entry.Template.num_output = source->entry.Template.num_output; dest->entry.Template.num_io = source->entry.Template.num_io; dest->entry.Template.in_list = source->entry.Template.in_list; dest->entry.Template.out_list = source->entry.Template.out_list; dest->entry.Template.symb_list = source->entry.Template.symb_list; dest->entry.Template.local_size = source->entry.Template.local_size; dest->entry.Template.label_list = source->entry.Template.label_list; dest->entry.Template.func_hedr = source->entry.Template.func_hedr; dest->entry.Template.call_list = source->entry.Template.call_list; dest->entry.Template.tag = source->entry.Template.tag; dest->entry.Template.offset = source->entry.Template.offset; dest->entry.Template.declared_name = source->entry.Template.declared_name; /*dest->entry.Template.next = source->entry.Template.next;*/ /*dest->entry.Template.base_name = source->entry.Template.base_name;*/ dest->entry.Template.base_name = BaseSymbol(source); /*25.03.03*/ /*source;*/ } void delete_symbol(symb) PTR_SYMB symb; { /* PTR_SYMB symb_scope, s, s_pre; symb_scope = symb->scope->entry.Template.symbol; for(s=symb_scope->thread,s_pre=symb_scope; s; s_pre=s,s=s->thread) { if(s==symb) { s_pre->thread = s->thread; return; } } */ /* symb->parent = BFNULL; */ symb->ident = "***"; symb->scope = BFNULL; symb->type = TYNULL; return; } int copy_is(sym_mod) PTR_SYMB sym_mod; { //looking for a USE-ststement with sym_mod symbol without ONLY-clause PTR_BFND st; for(st=cur_scope()->thread; st!=last_bfnd; st=st->thread) { if(st->variant==USE_STMT && st->entry.Template.ll_ptr1 && st->entry.Template.ll_ptr1->variant==ONLY_NODE) continue; if(st->variant==USE_STMT && !strcmp(st->entry.Template.symbol->ident,sym_mod->ident)) return (1); } return (0); } void copy_module_scope(sym_mod,list) PTR_SYMB sym_mod; PTR_LLND list; { PTR_SYMB new_symb, source; PTR_HASH copy; if(copy_is(sym_mod)) return; for(source=sym_mod->entry.Template.next; source; source=source->entry.Template.next) { if((source->attr & PRIVATE_BIT) && (!(source->attr & PUBLIC_BIT)) ) continue; if(source->variant == FUNCTION_NAME && source->decl != YES) /* intrinsic function called from specification expression */ /* podd 24.02.24 */ continue; if(list && in_rename_list(source,list)) continue; if((copy=just_look_up_sym_in_scope(cur_scope(),source->ident)) && copy->id_attr && copy->id_attr->entry.Template.tag==sym_mod->entry.Template.func_hedr->id) continue; new_symb = make_local_entity(source->parent, source->variant, source->type, LOCAL); copy_sym_data(source,new_symb); new_symb->entry.Template.tag = sym_mod->entry.Template.func_hedr->id; /* if(new_symb->entry.Template.seen != BY_USE) { copy_sym_data(source,new_symb); new_symb->entry.Template.base_name = source; } */ } return; } PTR_SYMB BaseSymbol(sym) PTR_SYMB sym; { PTR_SYMB s; s = sym; while(s && s->entry.Template.seen == BY_USE) s = s->entry.Template.base_name; return(s); } PTR_SYMB OriginalSymbol(sym) PTR_SYMB sym; { if(sym && sym->entry.Template.base_name) return(sym->entry.Template.base_name); else return(sym); } int isResultVar(sym) PTR_SYMB sym; { PTR_BFND curstmt; curstmt = cur_scope(); if ((sym->variant == FUNCTION_NAME) &&(curstmt->variant == FUNC_HEDR) && (!curstmt->entry.Template.ll_ptr1) && (!(strcmp(sym->parent->ident, curstmt->entry.Template.symbol->ident)))) return(1); /* function name is a result variable name */ else return(0); } void replace_symbol_in_expr(PTR_LLND expr, PTR_SYMB symb) { if(!expr) return; if(expr->variant == VAR_REF) if(!strcmp(expr->entry.Template.symbol->ident, symb->ident)) expr->entry.Template.symbol = symb; replace_symbol_in_expr(expr->entry.Template.ll_ptr1,symb); replace_symbol_in_expr(expr->entry.Template.ll_ptr2,symb); }