2012 lines
58 KiB
C
2012 lines
58 KiB
C
/*********************************************************************/
|
|
/* pC++/Sage++ Copyright (C) 1993 */
|
|
/* Indiana University University of Oregon University of Rennes */
|
|
/*********************************************************************/
|
|
|
|
|
|
/*
|
|
* sym.c -- hash table routines
|
|
*/
|
|
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include "compatible.h"
|
|
#ifdef SYS5
|
|
#include <string.h>
|
|
#else
|
|
#include <strings.h>
|
|
#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:
|
|
if (type != TYNULL)
|
|
var_sym_entry->type = type;
|
|
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(!strcmp(source->ident, "***"))
|
|
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);
|
|
} |