#include <fstream>

#include <iostream>

#include <map>

#include <memory>

#include <string>

#include <cmath>

#include <limits>

#include <lpython/ast.h>

#include <libasr/asr.h>

#include <libasr/asr_utils.h>

#include <libasr/asr_verify.h>

#include <libasr/exception.h>

#include <lpython/semantics/asr_implicit_cast_rules.h>

#include <lpython/semantics/ast_common_visitor.h>

#include <lpython/semantics/ast_to_asr.h>

#include <lpython/parser/parser_stype.h>

#include <libasr/string_utils.h>

#include <lpython/utils.h>

namespace LFortran {

template <typename T>

void extract_bind(T &x, ASR::abiType &abi_type, char *&bindc_name) {

if (x.m_bind) {

AST::Bind_t *bind = AST::down_cast<AST::Bind_t>(x.m_bind);

if (bind->n_args == 1) {

if (AST::is_a<AST::Name_t>(*bind->m_args[0])) {

AST::Name_t *name = AST::down_cast<AST::Name_t>(

bind->m_args[0]);

if (to_lower(std::string(name->m_id)) == "c") {

abi_type=ASR::abiType::BindC;

} else {

throw SemanticError("Unsupported language in bind()",

x.base.base.loc);

}

} else {

throw SemanticError("Language name must be specified in bind() as plain text",

x.base.base.loc);

}

} else {

throw SemanticError("At least one argument needed in bind()",

x.base.base.loc);

}

if (bind->n_kwargs == 1) {

char *arg = bind->m_kwargs[0].m_arg;

AST::expr_t *value = bind->m_kwargs[0].m_value;

if (to_lower(std::string(arg)) == "name") {

if (AST::is_a<AST::String_t>(*value)) {

AST::String_t *name = AST::down_cast<AST::String_t>(value);

bindc_name = name->m_s;

} else {

throw SemanticError("The value of the 'name' keyword argument in bind(c) must be a string",

x.base.base.loc);

}

} else {

throw SemanticError("Unsupported keyword argument in bind()",

x.base.base.loc);

}

}

}

}

class SymbolTableVisitor : public CommonVisitor<SymbolTableVisitor> {

public:

SymbolTable *global_scope;

std::map<std::string, std::vector<std::string>> generic_procedures;

std::map<std::string, std::map<std::string, std::vector<std::string>>> generic_class_procedures;

std::map<AST::intrinsicopType, std::vector<std::string>> overloaded_op_procs;

std::map<std::string, std::vector<std::string>> defined_op_procs;

std::map<std::string, std::map<std::string, std::string>> class_procedures;

std::vector<std::string> assgn_proc_names;

std::string dt_name;

ASR::accessType dflt_access = ASR::Public;

ASR::presenceType dflt_presence = ASR::presenceType::Required;

std::map<std::string, ASR::accessType> assgnd_access;

std::map<std::string, ASR::presenceType> assgnd_presence;

bool in_module = false;

bool in_submodule = false;

bool is_interface = false;

std::string interface_name = "";

bool is_derived_type = false;

Vec<char*> data_member_names;

std::vector<std::string> current_procedure_args;

ASR::abiType current_procedure_abi_type = ASR::abiType::Source;

std::map<SymbolTable*, std::map<AST::decl_attribute_t*, AST::simple_attributeType>> overloaded_ops;

std::map<SymbolTable*, ASR::accessType> assgn;

ASR::symbol_t *current_module_sym;

std::vector<std::string> excluded_from_symtab;

std::map<AST::intrinsicopType, std::string> intrinsic2str = {

{AST::intrinsicopType::STAR, "~mul"},

{AST::intrinsicopType::PLUS, "~add"},

{AST::intrinsicopType::EQ, "~eq"},

{AST::intrinsicopType::NOTEQ, "~noteq"},

{AST::intrinsicopType::LT, "~lt"},

{AST::intrinsicopType::LTE, "~lte"},

{AST::intrinsicopType::GT, "~gt"},

{AST::intrinsicopType::GTE, "~gte"}

};

SymbolTableVisitor(Allocator &al, SymbolTable *symbol_table,

diag::Diagnostics &diagnostics)

: CommonVisitor(al, symbol_table, diagnostics), is_derived_type{false} {}

ASR::symbol_t* resolve_symbol(const Location &loc, const std::string &sub_name) {

SymbolTable *scope = current_scope;

ASR::symbol_t *sub = scope->resolve_symbol(sub_name);

if (!sub) {

throw SemanticError("Symbol '" + sub_name + "' not declared", loc);

}

return sub;

}

void visit_TranslationUnit(const AST::TranslationUnit_t &x) {

if (!current_scope) {

current_scope = al.make_new<SymbolTable>(nullptr);

}

LFORTRAN_ASSERT(current_scope != nullptr);

global_scope = current_scope;

// Create the TU early, so that asr_owner is set, so that

// ASRUtils::get_tu_symtab() can be used, which has an assert

// for asr_owner.

ASR::asr_t *tmp0 = ASR::make_TranslationUnit_t(al, x.base.base.loc,

current_scope, nullptr, 0);

for (size_t i=0; i<x.n_items; i++) {

AST::astType t = x.m_items[i]->type;

if (t != AST::astType::expr && t != AST::astType::stmt) {

visit_ast(*x.m_items[i]);

}

}

global_scope = nullptr;

tmp = tmp0;

}

void visit_Procedure(const AST::Procedure_t&) {

// To Be Implemented

}

void visit_Private(const AST::Private_t&) {

// To Be Implemented

}

void visit_FinalName(const AST::FinalName_t&) {

// To Be Implemented

}

template <typename T, typename R>

void visit_ModuleSubmoduleCommon(const T &x, std::string parent_name="") {

SymbolTable *parent_scope = current_scope;

current_scope = al.make_new<SymbolTable>(parent_scope);

current_module_dependencies.reserve(al, 4);

generic_procedures.clear();

ASR::asr_t *tmp0 = ASR::make_Module_t(al, x.base.base.loc,

/* a_symtab */ current_scope,

/* a_name */ s2c(al, to_lower(x.m_name)),

nullptr,

0,

false, false);

current_module_sym = ASR::down_cast<ASR::symbol_t>(tmp0);

if( x.class_type == AST::modType::Submodule ) {

std::string rl_path = get_runtime_library_dir();

ASR::symbol_t* submod_parent = (ASR::symbol_t*)(ASRUtils::load_module(al, global_scope,

parent_name, x.base.base.loc, false,

rl_path, true,

[&](const std::string &msg, const Location &loc) { throw SemanticError(msg, loc); }

));

ASR::Module_t *m = ASR::down_cast<ASR::Module_t>(submod_parent);

std::string unsupported_sym_name = import_all(m);

if( !unsupported_sym_name.empty() ) {

throw LFortranException("'" + unsupported_sym_name + "' is not supported yet for declaring with use.");

}

}

for (size_t i=0; i<x.n_use; i++) {

visit_unit_decl1(*x.m_use[i]);

}

for (size_t i=0; i<x.n_decl; i++) {

visit_unit_decl2(*x.m_decl[i]);

}

for (size_t i=0; i<x.n_contains; i++) {

visit_program_unit(*x.m_contains[i]);

}

current_module_sym = nullptr;

add_generic_procedures();

add_overloaded_procedures();

add_class_procedures();

add_generic_class_procedures();

add_assignment_procedures();

tmp = tmp0;

// Add module dependencies

R *m = ASR::down_cast2<R>(tmp);

m->m_dependencies = current_module_dependencies.p;

m->n_dependencies = current_module_dependencies.n;

std::string sym_name = to_lower(x.m_name);

if (parent_scope->scope.find(sym_name) != parent_scope->scope.end()) {

throw SemanticError("Module already defined", tmp->loc);

}

parent_scope->scope[sym_name] = ASR::down_cast<ASR::symbol_t>(tmp);

current_scope = parent_scope;

}

void visit_Module(const AST::Module_t &x) {

in_module = true;

visit_ModuleSubmoduleCommon<AST::Module_t, ASR::Module_t>(x);

in_module = false;

}

void visit_Submodule(const AST::Submodule_t &x) {

in_submodule = true;

visit_ModuleSubmoduleCommon<AST::Submodule_t, ASR::Module_t>(x, std::string(x.m_id));

in_submodule = false;

}

void visit_Program(const AST::Program_t &x) {

SymbolTable *parent_scope = current_scope;

current_scope = al.make_new<SymbolTable>(parent_scope);

current_module_dependencies.reserve(al, 4);

for (size_t i=0; i<x.n_use; i++) {

visit_unit_decl1(*x.m_use[i]);

}

for (size_t i=0; i<x.n_decl; i++) {

visit_unit_decl2(*x.m_decl[i]);

}

for (size_t i=0; i<x.n_contains; i++) {

visit_program_unit(*x.m_contains[i]);

}

tmp = ASR::make_Program_t(

al, x.base.base.loc,

/* a_symtab */ current_scope,

/* a_name */ s2c(al, to_lower(x.m_name)),

current_module_dependencies.p,

current_module_dependencies.n,

/* a_body */ nullptr,

/* n_body */ 0);

std::string sym_name = to_lower(x.m_name);

if (parent_scope->scope.find(sym_name) != parent_scope->scope.end()) {

throw SemanticError("Program already defined", tmp->loc);

}

parent_scope->scope[sym_name] = ASR::down_cast<ASR::symbol_t>(tmp);

current_scope = parent_scope;

}

void visit_Subroutine(const AST::Subroutine_t &x) {

ASR::accessType s_access = dflt_access;

ASR::deftypeType deftype = ASR::deftypeType::Implementation;

SymbolTable *parent_scope = current_scope;

current_scope = al.make_new<SymbolTable>(parent_scope);

for (size_t i=0; i<x.n_args; i++) {

char *arg=x.m_args[i].m_arg;

current_procedure_args.push_back(to_lower(arg));

}

current_procedure_abi_type = ASR::abiType::Source;

char *bindc_name=nullptr;

extract_bind(x, current_procedure_abi_type, bindc_name);

for (size_t i=0; i<x.n_decl; i++) {

visit_unit_decl2(*x.m_decl[i]);

}

for (size_t i=0; i<x.n_contains; i++) {

visit_program_unit(*x.m_contains[i]);

}

Vec<ASR::expr_t*> args;

args.reserve(al, x.n_args);

for (size_t i=0; i<x.n_args; i++) {

char *arg=x.m_args[i].m_arg;

std::string arg_s = to_lower(arg);

if (current_scope->scope.find(arg_s) == current_scope->scope.end()) {

throw SemanticError("Dummy argument '" + arg_s + "' not defined", x.base.base.loc);

}

ASR::symbol_t *var = current_scope->scope[arg_s];

args.push_back(al, LFortran::ASRUtils::EXPR(ASR::make_Var_t(al, x.base.base.loc,

var)));

}

std::string sym_name = to_lower(x.m_name);

if (assgnd_access.count(sym_name)) {

s_access = assgnd_access[sym_name];

}

if (is_interface){

deftype = ASR::deftypeType::Interface;

}

bool is_pure = false, is_module = false;

for( size_t i = 0; i < x.n_attributes; i++ ) {

switch( x.m_attributes[i]->type ) {

case AST::decl_attributeType::SimpleAttribute: {

AST::SimpleAttribute_t* simple_attr = AST::down_cast<AST::SimpleAttribute_t>(x.m_attributes[i]);

if( simple_attr->m_attr == AST::simple_attributeType::AttrPure ) {

is_pure = true;

} else if( simple_attr->m_attr == AST::simple_attributeType::AttrModule ) {

is_module = true;

}

break;

}

default: {

// Continue with the original behaviour

// of not processing unrequired attributes

break;

}

}

}

if (parent_scope->scope.find(sym_name) != parent_scope->scope.end()) {

ASR::symbol_t *f1 = parent_scope->scope[sym_name];

ASR::Subroutine_t *f2 = nullptr;

if( f1->type == ASR::symbolType::Subroutine ) {

f2 = ASR::down_cast<ASR::Subroutine_t>(f1);

}

if ((f1->type == ASR::symbolType::ExternalSymbol && in_submodule) ||

f2->m_abi == ASR::abiType::Interactive) {

// Previous declaration will be shadowed

parent_scope->scope.erase(sym_name);

} else {

throw SemanticError("Subroutine already defined", tmp->loc);

}

}

if( sym_name == interface_name ) {

parent_scope->scope.erase(sym_name);

sym_name = "~" + sym_name;

}

tmp = ASR::make_Subroutine_t(

al, x.base.base.loc,

/* a_symtab */ current_scope,

/* a_name */ s2c(al, to_lower(sym_name)),

/* a_args */ args.p,

/* n_args */ args.size(),

/* a_body */ nullptr,

/* n_body */ 0,

current_procedure_abi_type,

s_access, deftype, bindc_name,

is_pure, is_module);

parent_scope->scope[sym_name] = ASR::down_cast<ASR::symbol_t>(tmp);

current_scope = parent_scope;

/* FIXME: This can become incorrect/get cleared prematurely, perhaps

in nested functions, and also in callback.f90 test, but it may not

matter since we would have already checked the intent */

current_procedure_args.clear();

current_procedure_abi_type = ASR::abiType::Source;

}

AST::AttrType_t* find_return_type(AST::decl_attribute_t** attributes,

size_t n, const Location &loc) {

AST::AttrType_t* r = nullptr;

bool found = false;

for (size_t i=0; i<n; i++) {

if (AST::is_a<AST::AttrType_t>(*attributes[i])) {

if (found) {

throw SemanticError("Return type declared twice", loc);

} else {

r = AST::down_cast<AST::AttrType_t>(attributes[i]);

found = true;

}

}

}

return r;

}

void visit_Function(const AST::Function_t &x) {

// Extract local (including dummy) variables first

ASR::accessType s_access = dflt_access;

ASR::deftypeType deftype = ASR::deftypeType::Implementation;

SymbolTable *parent_scope = current_scope;

current_scope = al.make_new<SymbolTable>(parent_scope);

for (size_t i=0; i<x.n_args; i++) {

char *arg=x.m_args[i].m_arg;

current_procedure_args.push_back(to_lower(arg));

}

// Determine the ABI (Source or BindC for now)

current_procedure_abi_type = ASR::abiType::Source;

char *bindc_name=nullptr;

extract_bind(x, current_procedure_abi_type, bindc_name);

for (size_t i=0; i<x.n_decl; i++) {

visit_unit_decl2(*x.m_decl[i]);

}

for (size_t i=0; i<x.n_contains; i++) {

visit_program_unit(*x.m_contains[i]);

}

// Convert and check arguments

Vec<ASR::expr_t*> args;

args.reserve(al, x.n_args);

for (size_t i=0; i<x.n_args; i++) {

char *arg=x.m_args[i].m_arg;

std::string arg_s = to_lower(arg);

if (current_scope->scope.find(arg_s) == current_scope->scope.end()) {

throw SemanticError("Dummy argument '" + arg_s + "' not defined", x.base.base.loc);

}

ASR::symbol_t *var = current_scope->scope[arg_s];

args.push_back(al, LFortran::ASRUtils::EXPR(ASR::make_Var_t(al, x.base.base.loc,

var)));

}

// Handle the return variable and type

// First determine the name of the variable: either the function name

// or result(...)

std::string return_var_name;

if (x.m_return_var) {

if (x.m_return_var->type == AST::exprType::Name) {

return_var_name = to_lower(((AST::Name_t*)(x.m_return_var))->m_id);

} else {

throw SemanticError("Return variable must be an identifier",

x.m_return_var->base.loc);

}

} else {

return_var_name = to_lower(x.m_name);

}

// Determine the type of the variable, the type is either specified as

// integer function f()

// or in local variables as

// integer :: f

ASR::asr_t *return_var;

AST::AttrType_t *return_type = find_return_type(x.m_attributes,

x.n_attributes, x.base.base.loc);

if (current_scope->scope.find(return_var_name) == current_scope->scope.end()) {

// The variable is not defined among local variables, extract the

// type from "integer function f()" and add the variable.

if (!return_type) {

throw SemanticError("Return type not specified",

x.base.base.loc);

}

ASR::ttype_t *type;

int a_kind = 4;

int a_len = -10;

if (return_type->m_kind != nullptr) {

if (return_type->n_kind == 1) {

visit_expr(*return_type->m_kind->m_value);

ASR::expr_t* kind_expr = LFortran::ASRUtils::EXPR(tmp);

if (return_type->m_type == AST::decl_typeType::TypeCharacter) {

a_len = ASRUtils::extract_len<SemanticError>(kind_expr, x.base.base.loc);

} else {

a_kind = ASRUtils::extract_kind<SemanticError>(kind_expr, x.base.base.loc);

}

} else {

throw SemanticError("Only one kind item supported for now", x.base.base.loc);

}

}

switch (return_type->m_type) {

case (AST::decl_typeType::TypeInteger) : {

type = LFortran::ASRUtils::TYPE(ASR::make_Integer_t(al, x.base.base.loc, a_kind, nullptr, 0));

break;

}

case (AST::decl_typeType::TypeReal) : {

type = LFortran::ASRUtils::TYPE(ASR::make_Real_t(al, x.base.base.loc, a_kind, nullptr, 0));

break;

}

case (AST::decl_typeType::TypeComplex) : {

type = LFortran::ASRUtils::TYPE(ASR::make_Complex_t(al, x.base.base.loc, a_kind, nullptr, 0));

break;

}

case (AST::decl_typeType::TypeLogical) : {

type = LFortran::ASRUtils::TYPE(ASR::make_Logical_t(al, x.base.base.loc, 4, nullptr, 0));

break;

}

case (AST::decl_typeType::TypeCharacter) : {

type = LFortran::ASRUtils::TYPE(ASR::make_Character_t(al, x.base.base.loc, 1, a_len, nullptr, nullptr, 0));

break;

}

default :

throw SemanticError("Return type not supported",

x.base.base.loc);

}

// Add it as a local variable:

return_var = ASR::make_Variable_t(al, x.base.base.loc,

current_scope, s2c(al, return_var_name), LFortran::ASRUtils::intent_return_var, nullptr, nullptr,

ASR::storage_typeType::Default, type,

current_procedure_abi_type, ASR::Public, ASR::presenceType::Required,

false);

current_scope->scope[return_var_name]

= ASR::down_cast<ASR::symbol_t>(return_var);

} else {

if (return_type) {

throw SemanticError("Cannot specify the return type twice",

x.base.base.loc);

}

// Extract the variable from the local scope

return_var = (ASR::asr_t*) current_scope->scope[return_var_name];

ASR::down_cast2<ASR::Variable_t>(return_var)->m_intent = LFortran::ASRUtils::intent_return_var;

}

ASR::asr_t *return_var_ref = ASR::make_Var_t(al, x.base.base.loc,

ASR::down_cast<ASR::symbol_t>(return_var));

// Create and register the function

std::string sym_name = to_lower(x.m_name);

if (assgnd_access.count(sym_name)) {

s_access = assgnd_access[sym_name];

}

if (is_interface) {

deftype = ASR::deftypeType::Interface;

}

tmp = ASR::make_Function_t(

al, x.base.base.loc,

/* a_symtab */ current_scope,

/* a_name */ s2c(al, to_lower(x.m_name)),

/* a_args */ args.p,

/* n_args */ args.size(),

/* a_body */ nullptr,

/* n_body */ 0,

/* a_return_var */ LFortran::ASRUtils::EXPR(return_var_ref),

current_procedure_abi_type, s_access, deftype, bindc_name);

if (parent_scope->scope.find(sym_name) != parent_scope->scope.end()) {

ASR::symbol_t *f1 = parent_scope->scope[sym_name];

ASR::Function_t *f2 = nullptr;

if( f1->type == ASR::symbolType::Function ) {

f2 = ASR::down_cast<ASR::Function_t>(f1);

}

if ((f1->type == ASR::symbolType::ExternalSymbol && in_submodule) ||

f2->m_abi == ASR::abiType::Interactive) {

// Previous declaration will be shadowed

parent_scope->scope.erase(sym_name);

} else {

throw SemanticError("Function already defined", tmp->loc);

}

}

parent_scope->scope[sym_name] = ASR::down_cast<ASR::symbol_t>(tmp);

current_scope = parent_scope;

current_procedure_args.clear();

current_procedure_abi_type = ASR::abiType::Source;

}

void process_dims(Allocator &al, Vec<ASR::dimension_t> &dims,

AST::dimension_t *m_dim, size_t n_dim) {

LFORTRAN_ASSERT(dims.size() == 0);

dims.reserve(al, n_dim);

for (size_t i=0; i<n_dim; i++) {

ASR::dimension_t dim;

dim.loc = m_dim[i].loc;

if (m_dim[i].m_start) {

this->visit_expr(*m_dim[i].m_start);

dim.m_start = LFortran::ASRUtils::EXPR(tmp);

} else {

dim.m_start = nullptr;

}

if (m_dim[i].m_end) {

this->visit_expr(*m_dim[i].m_end);

dim.m_end = LFortran::ASRUtils::EXPR(tmp);

} else {

dim.m_end = nullptr;

}

dims.push_back(al, dim);

}

}

ASR::accessType get_asr_simple_attr(AST::simple_attributeType simple_attr) {

ASR::accessType access_type = ASR::accessType::Public;

switch( simple_attr ) {

case AST::simple_attributeType::AttrPublic: {

access_type = ASR::accessType::Public;

break;

}

case AST::simple_attributeType::AttrPrivate: {

access_type = ASR::accessType::Private;

break;

}

default:

LFORTRAN_ASSERT(false);

}

return access_type;

}

void visit_Declaration(const AST::Declaration_t &x) {

if (x.m_vartype == nullptr &&

x.n_attributes == 1 &&

AST::is_a<AST::AttrNamelist_t>(*x.m_attributes[0])) {

//char *name = down_cast<AttrNamelist_t>(x.m_attributes[0])->m_name;

throw SemanticError("Namelists not implemented yet", x.base.base.loc);

}

for (size_t i=0; i<x.n_attributes; i++) {

if (AST::is_a<AST::AttrType_t>(*x.m_attributes[i])) {

throw SemanticError("Type must be declared first",

x.base.base.loc);

};

}

if (x.m_vartype == nullptr) {

// Examples:

// private

// public

// private :: x, y, z

if (x.n_attributes == 0) {

throw SemanticError("No attribute specified",

x.base.base.loc);

}

if (x.n_attributes > 1) {

throw SemanticError("Only one attribute can be specified if type is missing",

x.base.base.loc);

}

LFORTRAN_ASSERT(x.n_attributes == 1);

if (AST::is_a<AST::SimpleAttribute_t>(*x.m_attributes[0])) {

AST::SimpleAttribute_t *sa =

AST::down_cast<AST::SimpleAttribute_t>(x.m_attributes[0]);

if (x.n_syms == 0) {

// Example:

// private

if (sa->m_attr == AST::simple_attributeType

::AttrPrivate) {

dflt_access = ASR::accessType::Private;

} else if (sa->m_attr == AST::simple_attributeType

::AttrPublic) {

// Do nothing (public access is the default)

LFORTRAN_ASSERT(dflt_access == ASR::accessType::Public);

} else if (sa->m_attr == AST::simple_attributeType

::AttrSave) {

if (in_module) {

// Do nothing (all variables implicitly have the

// save attribute in a module/main program)

} else {

throw SemanticError("Save Attribute not "

"supported yet", x.base.base.loc);

}

} else if (sa->m_attr == AST::simple_attributeType

::AttrSequence) {

// TODO: Implement it for CPP backend

} else {

throw SemanticError("Attribute declaration not "

"supported yet", x.base.base.loc);

}

} else {

// Example:

// private :: x, y, z

for (size_t i=0; i<x.n_syms; i++) {

AST::var_sym_t &s = x.m_syms[i];

if (s.m_name == nullptr) {

if (s.m_spec->type == AST::decl_attributeType::AttrIntrinsicOperator) {

// Operator Overloading Encountered

if( sa->m_attr != AST::simple_attributeType::AttrPublic &&

sa->m_attr != AST::simple_attributeType::AttrPrivate ) {

overloaded_ops[current_scope][s.m_spec] = AST::simple_attributeType::AttrPublic;

} else {

overloaded_ops[current_scope][s.m_spec] = sa->m_attr;

}

} else if( s.m_spec->type == AST::decl_attributeType::AttrAssignment ) {

// Assignment Overloading Encountered

if( sa->m_attr != AST::simple_attributeType::AttrPublic &&

sa->m_attr != AST::simple_attributeType::AttrPrivate ) {

assgn[current_scope] = ASR::Public;

} else {

assgn[current_scope] = get_asr_simple_attr(sa->m_attr);

}

} else if (s.m_spec->type == AST::decl_attributeType::AttrDefinedOperator) {

//std::string op_name = to_lower(AST::down_cast<AST::AttrDefinedOperator_t>(s.m_spec)->m_op_name);

// Custom Operator Overloading Encountered

if( sa->m_attr != AST::simple_attributeType::AttrPublic &&

sa->m_attr != AST::simple_attributeType::AttrPrivate ) {

overloaded_ops[current_scope][s.m_spec] = AST::simple_attributeType::AttrPublic;

} else {

overloaded_ops[current_scope][s.m_spec] = sa->m_attr;

}

} else {

throw SemanticError("Attribute type not implemented yet.", x.base.base.loc);

}

} else {

std::string sym = to_lower(s.m_name);

if (sa->m_attr == AST::simple_attributeType

::AttrPrivate) {

assgnd_access[sym] = ASR::accessType::Private;

} else if (sa->m_attr == AST::simple_attributeType

::AttrPublic) {

assgnd_access[sym] = ASR::accessType::Public;

} else if (sa->m_attr == AST::simple_attributeType

::AttrOptional) {

assgnd_presence[sym] = ASR::presenceType::Optional;

} else if(sa->m_attr == AST::simple_attributeType

::AttrIntrinsic) {

// Ignore Intrinsic attribute

} else {

throw SemanticError("Attribute declaration not "

"supported", x.base.base.loc);

}

}

}

}

} else {

throw SemanticError("Attribute declaration not supported",

x.base.base.loc);

}

} else {

// Example

// real(dp), private :: x, y(3), z

for (size_t i=0; i<x.n_syms; i++) {

AST::var_sym_t &s = x.m_syms[i];

std::string sym = to_lower(s.m_name);

ASR::accessType s_access = dflt_access;

ASR::presenceType s_presence = dflt_presence;

bool value_attr = false;

AST::AttrType_t *sym_type =

AST::down_cast<AST::AttrType_t>(x.m_vartype);

if (assgnd_access.count(sym)) {

s_access = assgnd_access[sym];

}

if (assgnd_presence.count(sym)) {

s_presence = assgnd_presence[sym];

}

ASR::storage_typeType storage_type =

ASR::storage_typeType::Default;

bool is_pointer = false;

if (current_scope->scope.find(sym) !=

current_scope->scope.end()) {

if (current_scope->parent != nullptr) {

// re-declaring a global scope variable is allowed

// Otherwise raise an error

ASR::symbol_t *orig_decl = current_scope->scope[sym];

throw SemanticError(diag::Diagnostic(

"Symbol is already declared in the same scope",

diag::Level::Error, diag::Stage::Semantic, {

diag::Label("redeclaration", {s.loc}),

diag::Label("original declaration", {orig_decl->base.loc}, false),

}));

}

}

ASR::intentType s_intent;

if (std::find(current_procedure_args.begin(),

current_procedure_args.end(), to_lower(s.m_name)) !=

current_procedure_args.end()) {

s_intent = LFortran::ASRUtils::intent_unspecified;

} else {

s_intent = LFortran::ASRUtils::intent_local;

}

Vec<ASR::dimension_t> dims;

dims.reserve(al, 0);

// location for dimension(...) if present

Location dims_attr_loc;

if (x.n_attributes > 0) {

for (size_t i=0; i < x.n_attributes; i++) {

AST::decl_attribute_t *a = x.m_attributes[i];

if (AST::is_a<AST::SimpleAttribute_t>(*a)) {

AST::SimpleAttribute_t *sa =

AST::down_cast<AST::SimpleAttribute_t>(a);

if (sa->m_attr == AST::simple_attributeType

::AttrPrivate) {

s_access = ASR::accessType::Private;

} else if (sa->m_attr == AST::simple_attributeType

::AttrPublic) {

s_access = ASR::accessType::Public;

} else if (sa->m_attr == AST::simple_attributeType

::AttrParameter) {

storage_type = ASR::storage_typeType::Parameter;

} else if( sa->m_attr == AST::simple_attributeType

::AttrAllocatable ) {

storage_type = ASR::storage_typeType::Allocatable;

} else if (sa->m_attr == AST::simple_attributeType

::AttrPointer) {

is_pointer = true;

} else if (sa->m_attr == AST::simple_attributeType

::AttrOptional) {

s_presence = ASR::presenceType::Optional;

} else if (sa->m_attr == AST::simple_attributeType

::AttrTarget) {

// Do nothing for now

} else if (sa->m_attr == AST::simple_attributeType

::AttrAllocatable) {

// TODO

} else if (sa->m_attr == AST::simple_attributeType

::AttrValue) {

value_attr = true;

} else if(sa->m_attr == AST::simple_attributeType

::AttrIntrinsic) {

excluded_from_symtab.push_back(sym);

} else {

throw SemanticError("Attribute type not implemented yet",

x.base.base.loc);

}

} else if (AST::is_a<AST::AttrIntent_t>(*a)) {

AST::AttrIntent_t *ai =

AST::down_cast<AST::AttrIntent_t>(a);

switch (ai->m_intent) {

case (AST::attr_intentType::In) : {

s_intent = LFortran::ASRUtils::intent_in;

break;

}

case (AST::attr_intentType::Out) : {

s_intent = LFortran::ASRUtils::intent_out;

break;

}

case (AST::attr_intentType::InOut) : {

s_intent = LFortran::ASRUtils::intent_inout;

break;

}

default : {

s_intent = LFortran::ASRUtils::intent_unspecified;

break;

}

}

} else if (AST::is_a<AST::AttrDimension_t>(*a)) {

AST::AttrDimension_t *ad =

AST::down_cast<AST::AttrDimension_t>(a);

if (dims.size() > 0) {

throw SemanticError("Dimensions specified twice",

x.base.base.loc);

}

dims_attr_loc = ad->base.base.loc;

process_dims(al, dims, ad->m_dim, ad->n_dim);

} else {

throw SemanticError("Attribute type not implemented yet",

x.base.base.loc);

}

}

}

if (s.n_dim > 0) {

if (dims.size() > 0) {

// This happens for:

// integer, private, dimension(2,2) :: a(2,2)

diag.semantic_warning_label(

"Dimensions are specified twice",

{dims_attr_loc, s.loc}, // dimension(2,2), a(2,2)

"help: consider specifying it just one way or the other"

);

dims.n = 0;

}

process_dims(al, dims, s.m_dim, s.n_dim);

}

ASR::ttype_t *type;

int a_kind = 4;

if (sym_type->m_type != AST::decl_typeType::TypeCharacter &&

sym_type->m_kind != nullptr &&

sym_type->m_kind->m_value != nullptr) {

visit_expr(*sym_type->m_kind->m_value);

ASR::expr_t* kind_expr = LFortran::ASRUtils::EXPR(tmp);

a_kind = ASRUtils::extract_kind<SemanticError>(kind_expr, x.base.base.loc);

}

if (sym_type->m_type == AST::decl_typeType::TypeReal) {

type = LFortran::ASRUtils::TYPE(ASR::make_Real_t(al, x.base.base.loc,

a_kind, dims.p, dims.size()));

if (is_pointer) {

type = LFortran::ASRUtils::TYPE(ASR::make_Pointer_t(al, x.base.base.loc,

type));

}

} else if (sym_type->m_type == AST::decl_typeType::TypeDoublePrecision) {

a_kind = 8;

type = LFortran::ASRUtils::TYPE(ASR::make_Real_t(al, x.base.base.loc,

a_kind, dims.p, dims.size()));

if (is_pointer) {

type = LFortran::ASRUtils::TYPE(ASR::make_Pointer_t(al, x.base.base.loc,

type));

}

} else if (sym_type->m_type == AST::decl_typeType::TypeInteger) {

type = LFortran::ASRUtils::TYPE(ASR::make_Integer_t(al, x.base.base.loc,

a_kind, dims.p, dims.size()));

if (is_pointer) {

type = LFortran::ASRUtils::TYPE(ASR::make_Pointer_t(al, x.base.base.loc,

type));

}

} else if (sym_type->m_type == AST::decl_typeType::TypeLogical) {

type = LFortran::ASRUtils::TYPE(ASR::make_Logical_t(al, x.base.base.loc, 4,

dims.p, dims.size()));

if (is_pointer) {

type = LFortran::ASRUtils::TYPE(ASR::make_Pointer_t(al, x.base.base.loc,

type));

}

} else if (sym_type->m_type == AST::decl_typeType::TypeComplex) {

type = LFortran::ASRUtils::TYPE(ASR::make_Complex_t(al, x.base.base.loc,

a_kind, dims.p, dims.size()));

if (is_pointer) {

type = LFortran::ASRUtils::TYPE(ASR::make_Pointer_t(al, x.base.base.loc,

type));

}

} else if (sym_type->m_type == AST::decl_typeType::TypeCharacter) {

int a_len = -10;

ASR::expr_t *len_expr = nullptr;

// TODO: take into account m_kind->m_id and all kind items

if (sym_type->m_kind != nullptr) {

switch (sym_type->m_kind->m_type) {

case (AST::kind_item_typeType::Value) : {

LFORTRAN_ASSERT(sym_type->m_kind->m_value != nullptr);

visit_expr(*sym_type->m_kind->m_value);

ASR::expr_t* len_expr0 = LFortran::ASRUtils::EXPR(tmp);

a_len = ASRUtils::extract_len<SemanticError>(len_expr0, x.base.base.loc);

if (a_len == -3) {

len_expr = len_expr0;

}

break;

}

case (AST::kind_item_typeType::Star) : {

LFORTRAN_ASSERT(sym_type->m_kind->m_value == nullptr);

a_len = -1;

break;

}

case (AST::kind_item_typeType::Colon) : {

LFORTRAN_ASSERT(sym_type->m_kind->m_value == nullptr);

a_len = -2;

break;

}

}

} else {

a_len = 1; // The default len of "character :: x" is 1

}

LFORTRAN_ASSERT(a_len != -10)

type = LFortran::ASRUtils::TYPE(ASR::make_Character_t(al, x.base.base.loc, 1, a_len, len_expr,

dims.p, dims.size()));

} else if (sym_type->m_type == AST::decl_typeType::TypeType) {

LFORTRAN_ASSERT(sym_type->m_name);

std::string derived_type_name = to_lower(sym_type->m_name);

ASR::symbol_t *v = current_scope->resolve_symbol(derived_type_name);

if (!v) {

throw SemanticError("Derived type '"

+ derived_type_name + "' not declared", x.base.base.loc);

}

type = LFortran::ASRUtils::TYPE(ASR::make_Derived_t(al, x.base.base.loc, v,

dims.p, dims.size()));

} else if (sym_type->m_type == AST::decl_typeType::TypeClass) {

std::string derived_type_name;

if( !sym_type->m_name ) {

derived_type_name = "~abstract_type";

} else {

derived_type_name = to_lower(sym_type->m_name);

}

ASR::symbol_t *v = current_scope->resolve_symbol(derived_type_name);

if( !v ) {

if( derived_type_name != "~abstract_type" ) {

throw SemanticError("Derived type '" + derived_type_name

+ "' not declared", x.base.base.loc);

}

SymbolTable *parent_scope = current_scope;

current_scope = al.make_new<SymbolTable>(parent_scope);

ASR::asr_t* dtype = ASR::make_DerivedType_t(al, x.base.base.loc, current_scope,

s2c(al, to_lower(derived_type_name)), nullptr, 0,

ASR::abiType::Source, dflt_access, nullptr);

v = ASR::down_cast<ASR::symbol_t>(dtype);

parent_scope->scope[derived_type_name] = v;

current_scope = parent_scope;

}

type = LFortran::ASRUtils::TYPE(ASR::make_Class_t(al,

x.base.base.loc, v, dims.p, dims.size()));

} else {

throw SemanticError("Type not implemented yet.",

x.base.base.loc);

}

ASR::expr_t* init_expr = nullptr;

ASR::expr_t* value = nullptr;

if (s.m_initializer != nullptr) {

this->visit_expr(*s.m_initializer);

init_expr = LFortran::ASRUtils::EXPR(tmp);

ASR::ttype_t *init_type = LFortran::ASRUtils::expr_type(init_expr);

ImplicitCastRules::set_converted_value(al, x.base.base.loc, &init_expr, init_type, type);

LFORTRAN_ASSERT(init_expr != nullptr);

if (storage_type == ASR::storage_typeType::Parameter) {

value = ASRUtils::expr_value(init_expr);

if (value == nullptr) {

throw SemanticError("Value of a parameter variable must evaluate to a compile time constant",

x.base.base.loc);

}

if (sym_type->m_type == AST::decl_typeType::TypeCharacter) {

ASR::Character_t *lhs_type = ASR::down_cast<ASR::Character_t>(type);

ASR::Character_t *rhs_type = ASR::down_cast<ASR::Character_t>(ASRUtils::expr_type(value));

int lhs_len = lhs_type->m_len;

int rhs_len = rhs_type->m_len;

if (rhs_len >= 0) {

if (lhs_len == -1) {

// The RHS len is known at compile time

// and the LHS is inferred length

lhs_len = rhs_len;

} else if (lhs_len >= 0) {

if (lhs_len != rhs_len) {

// Note: this might be valid, perhaps

// change this to a warning

throw SemanticError("The LHS character len="

+ std::to_string(lhs_len)

+ " and the RHS character len="

+ std::to_string(rhs_len)

+ " are not equal.", x.base.base.loc);

}

} else {

LFORTRAN_ASSERT(lhs_len == -2)

throw SemanticError("The LHS character len must not be allocatable in a parameter declaration",

x.base.base.loc);

}

} else {

throw SemanticError("The RHS character len must be known at compile time",

x.base.base.loc);

}

LFORTRAN_ASSERT(lhs_len == rhs_len)

LFORTRAN_ASSERT(lhs_len >= 0)

lhs_type->m_len = lhs_len;

}

}

}

if( std::find(excluded_from_symtab.begin(), excluded_from_symtab.end(), sym) == excluded_from_symtab.end() ) {

ASR::asr_t *v = ASR::make_Variable_t(al, s.loc, current_scope,

s2c(al, to_lower(s.m_name)), s_intent, init_expr, value, storage_type, type,

current_procedure_abi_type, s_access, s_presence,

value_attr);

current_scope->scope[sym] = ASR::down_cast<ASR::symbol_t>(v);

if( is_derived_type ) {

data_member_names.push_back(al, s2c(al, to_lower(s.m_name)));

}

}

} // for m_syms

}

}

void visit_DerivedType(const AST::DerivedType_t &x) {

SymbolTable *parent_scope = current_scope;

current_scope = al.make_new<SymbolTable>(parent_scope);

data_member_names.reserve(al, 0);

is_derived_type = true;