#2642 Edits wrt Andy's second review (all except class(*))

src/psyclone/psyir/frontend/fparser2.py

@@ -1957,6 +1957,7 @@ def _process_derived_type_decln(self, parent, decl, visibility_map):
         # Look for any private-components-stmt (R447) within the type
         # decln. In the absence of this, the default visibility of type
         # components is public.
+        # This only concerns data components, i.e. not procedure ones.
         private_stmts = walk(decl, Fortran2003.Private_Components_Stmt)
         if private_stmts:
             default_compt_visibility = Symbol.Visibility.PRIVATE
@@ -2090,69 +2091,73 @@ def _process_derived_type_contains_block(self, parent, decl, tsymbol):
         :param tsymbol: the DataTypeSymbol representing the derived-type.
         :type tsymbol: :py:class:`psyclone.psyir.symbols.DataTypeSymbol`
 
-        :returns: None
-
         '''
-
         contains_blocks = walk(decl, Fortran2003.Type_Bound_Procedure_Part)
-        if contains_blocks:
-            # Get it.
-            contains = contains_blocks[0]
-            # Get all procedures in the CONTAINS section.
-            procedures = walk(contains, Fortran2003.Specific_Binding)
-
-            # Process each procedure.
-            for procedure in procedures:
-                supported = True
-                # We do not support interfaces.
-                if procedure.items[0] is not None:
-                    supported = False
-                # We do not support 'pass', 'nopass', 'deferred', etc.
-                if procedure.items[1] is not None:
-                    supported = False
-
-                # Get the name, look it up in the symbol table and
-                # get its datatype or create it if it does not exist.
-                procedure_name = procedure.items[3].string
-                procedure_symbol = parent.symbol_table.lookup(
-                    procedure_name,
-                    otherwise=None)
-                if procedure_symbol and supported:
-                    procedure_datatype = procedure_symbol.datatype
-                else:
-                    procedure_datatype = UnsupportedFortranType(
-                                            procedure.string,
-                                            None)
-
-                # Get the visibility of the procedure.
-                procedure_vis = tsymbol.visibility
-                if procedure.items[1] is not None:
-                    access_spec = walk(procedure.items[1],
-                                       Fortran2003.Access_Spec)
-                    if access_spec:
-                        procedure_vis = _process_access_spec(
-                            access_spec[0])
-
-                # Deal with the optional initial value.
-                # This could be, e.g., `null` in `procedure, name => null()` or
-                # `testkern_code` in `procedure :: code => testkern_code`
-                if procedure.items[4] is not None:
-                    initial_value_name = procedure.items[4].string
-                    initial_value_symbol = parent.symbol_table.lookup(
-                        initial_value_name, otherwise=None)
-                    if not initial_value_symbol:
-                        initial_value_symbol = RoutineSymbol(
-                            initial_value_name,
-                            UnresolvedType())
-                    initial_value = Reference(initial_value_symbol)
-                else:
-                    initial_value = None
+        if not contains_blocks:
+            return
+
+        # Get it.
+        contains = contains_blocks[0]
 
-                # Add this procedure as a component of the derived type
-                tsymbol.datatype.add_procedure_component(procedure_name,
-                                                         procedure_datatype,
-                                                         procedure_vis,
-                                                         initial_value)
+        # Look for any binding-private-stmt (R449) within the
+        # Specific_Binding part of decln. In the absence of this, the default
+        # visibility of procedure components is public.
+        # This only concerns procedure components, i.e. not data ones.
+        private_stmts = walk(contains, Fortran2003.Binding_Private_Stmt)
+        if private_stmts:
+            default_proc_visibility = Symbol.Visibility.PRIVATE
+        else:
+            default_proc_visibility = Symbol.Visibility.PUBLIC
+
+        # Get all procedures in the CONTAINS section.
+        procedures = walk(contains, Fortran2003.Specific_Binding)
+
+        # Process each procedure.
+        for procedure in procedures:
+            supported = True
+            # We do not support interfaces.
+            if procedure.items[0] is not None:
+                supported = False
+            # We do not support 'pass', 'nopass', 'deferred', etc.
+            if procedure.items[1] is not None:
+                supported = False
+
+            # Get the name, look it up in the symbol table and
+            # get its datatype or create it if it does not exist.
+            procedure_name = procedure.items[3].string
+            procedure_symbol = parent.symbol_table.lookup(procedure_name,
+                                                          otherwise=None)
+            if procedure_symbol and supported:
+                procedure_datatype = procedure_symbol.datatype
+            else:
+                procedure_datatype = UnsupportedFortranType(procedure.string,
+                                                            None)
+
+            # Get the visibility of the procedure.
+            procedure_vis = default_proc_visibility
+            if procedure.items[1] is not None:
+                access_spec = walk(procedure.items[1],
+                                   Fortran2003.Access_Spec)
+                if access_spec:
+                    procedure_vis = _process_access_spec(access_spec[0])
+
+            # Deal with the optional initial value.
+            # This could be, e.g., `null` in `procedure, name => null()` or
+            # `testkern_code` in `procedure :: code => testkern_code`
+            if procedure.items[4] is not None:
+                initial_value_name = procedure.items[4].string
+                initial_value_symbol = parent.symbol_table.find_or_create(
+                    initial_value_name, allow_renaming=False,
+                    symbol_type=RoutineSymbol, datatype=UnresolvedType())
+                initial_value = Reference(initial_value_symbol)
+            else:
+                initial_value = None
+
+            # Add this procedure as a component of the derived type
+            tsymbol.datatype.add_procedure_component(procedure_name,
+                                                     procedure_datatype,
+                                                     procedure_vis,
+                                                     initial_value)
 
     def _get_partial_datatype(self, node, scope, visibility_map):
         '''Try to obtain partial datatype information from node by removing
@@ -3395,8 +3400,6 @@ def _add_target_attribute(var_name, table):
             (e.g. a routine argument or an imported symbol).
 
         '''
-        # pylint: disable=import-outside-toplevel
-
         try:
             symbol = table.lookup(var_name)
         except KeyError as err:
@@ -3426,6 +3429,7 @@ def _add_target_attribute(var_name, table):
             # in order to add the 'TARGET' attribute to the declaration.
 
             # Import here to avoid circular dependencies.
+            # pylint: disable-next=import-outside-toplevel
             from psyclone.psyir.backend.fortran import FortranWriter
             dummy_code = (
                 f"subroutine dummy()\n"

src/psyclone/psyir/symbols/datatypes.py

@@ -1150,7 +1150,7 @@ def lookup_procedure_component(self, name):
     def replace_procedure_component_initial_value(self, old_value_name,
                                                   new_value):
         '''
-        Replace the initial value of the procedure component with
+        Replace the initial values of the procedure components with
         "old_value_name" as initial value with the supplied new value.
 
         :param str old_value_name: the name of the initial value to replace.
@@ -1161,8 +1161,6 @@ def replace_procedure_component_initial_value(self, old_value_name,
         :raises TypeError: if the new value is not a Reference to a
                            RoutineSymbol.
 
-        :returns: None
-
         '''
         # pylint: disable=import-outside-toplevel
         # These imports must be placed here to avoid circular dependencies.
@@ -1201,7 +1199,6 @@ def replace_procedure_component_initial_value(self, old_value_name,
                     new_datatype,
                     procedure_component.visibility,
                     new_value)
-                return
 
             # Or it is enough to replace the initial value.
             if (not procedure_component.initial_value
@@ -1213,7 +1210,6 @@ def replace_procedure_component_initial_value(self, old_value_name,
                 procedure_component.datatype,
                 procedure_component.visibility,
                 new_value)
-            return
 
     def __eq__(self, other):
         '''

src/psyclone/tests/psyGen_test.py

@@ -668,9 +668,8 @@ def test_codedkern__rename_psyir_unsupported_procedure_datatype():
     ''' Check that the CodedKern rename method renames the kernel in the PSyIR
     tree. '''
     # pylint: disable=protected-access, too-many-statements
-    _, invoke_info = parse(os.path.join(BASE_PATH, "1_single_invoke.f90"),
-                           api="lfric")
-    psy = PSyFactory("lfric", distributed_memory=False).create(invoke_info)
+    psy, _ = get_invoke("1_single_invoke.f90", "lfric",
+                        idx=0, dist_mem=False)
     schedule = psy.invokes.invoke_list[0].schedule
     kern = schedule.children[0].loop_body[0]
     assert isinstance(kern, CodedKern)
@@ -713,9 +712,8 @@ def test_codedkern__rename_psyir_supported_procedure_datatype():
     ''' Check that the CodedKern rename method renames the kernel in the PSyIR
     tree. '''
     # pylint: disable=protected-access, too-many-statements
-    _, invoke_info = parse(os.path.join(BASE_PATH, "1_single_invoke.f90"),
-                           api="lfric")
-    psy = PSyFactory("lfric", distributed_memory=False).create(invoke_info)
+    psy, _ = get_invoke("1_single_invoke.f90", "lfric",
+                        idx=0, dist_mem=False)
     schedule = psy.invokes.invoke_list[0].schedule
     kern = schedule.children[0].loop_body[0]
     assert isinstance(kern, CodedKern)
@@ -738,9 +736,8 @@ def test_codedkern__rename_psyir_supported_procedure_datatype():
                       UnsupportedFortranType)
 
     # Make the procedure component of the structure type be of a supported type
-    _, invoke_info = parse(os.path.join(BASE_PATH, "1_single_invoke.f90"),
-                           api="lfric")
-    psy = PSyFactory("lfric", distributed_memory=False).create(invoke_info)
+    psy, _ = get_invoke("1_single_invoke.f90", "lfric",
+                        idx=0, dist_mem=False)
     schedule = psy.invokes.invoke_list[0].schedule
     kern = schedule.children[0].loop_body[0]
     assert isinstance(kern, CodedKern)
@@ -786,9 +783,8 @@ def test_codedkern__rename_psyir_unsupported_datatypesymbol_datatype():
     ''' Check that the CodedKern rename method renames the kernel in the PSyIR
     tree. '''
     # pylint: disable=protected-access, too-many-statements
-    _, invoke_info = parse(os.path.join(BASE_PATH, "1_single_invoke.f90"),
-                           api="lfric")
-    psy = PSyFactory("lfric", distributed_memory=False).create(invoke_info)
+    psy, _ = get_invoke("1_single_invoke.f90", "lfric",
+                        idx=0, dist_mem=False)
     schedule = psy.invokes.invoke_list[0].schedule
     kern = schedule.children[0].loop_body[0]
     assert isinstance(kern, CodedKern)
@@ -811,9 +807,8 @@ def test_codedkern__rename_psyir_unsupported_datatypesymbol_datatype():
                       UnsupportedFortranType)
 
     # Make the DataTypeSymbol be of UnsupportedFortranType
-    _, invoke_info = parse(os.path.join(BASE_PATH, "1_single_invoke.f90"),
-                           api="lfric")
-    psy = PSyFactory("lfric", distributed_memory=False).create(invoke_info)
+    psy, _ = get_invoke("1_single_invoke.f90", "lfric",
+                        idx=0, dist_mem=False)
     schedule = psy.invokes.invoke_list[0].schedule
     kern = schedule.children[0].loop_body[0]
     assert isinstance(kern, CodedKern)

src/psyclone/tests/psyad/domain/lfric/test_lfric_adjoint_harness.py

@@ -546,6 +546,7 @@ def test_generate_lfric_adjoint_harness_invalid_code(fortran_reader):
     "  use kinds_mod, only: i_def, r_def\n"
     "  use kernel_mod, only: kernel_type, arg_type, gh_field, gh_real, "
     "gh_write, w3, cell_column\n"
+    "  use argument_mod, only: func_type, gh_quadrature_xyoz\n"
     "  type, extends(kernel_type) :: testkern_type\n"
     "     type(arg_type), dimension(2) :: meta_args =          & \n"
     "          (/ arg_type(gh_scalar, gh_real, gh_read),       & \n"
@@ -619,8 +620,6 @@ def test_generate_lfric_adjoint_harness(fortran_reader, fortran_writer):
             "    inner2 = inner2 + field_field_input_inner_prod\n" in gen)
 
 
-@pytest.mark.xfail(reason="func_type and gh_quadrature_xyoz are neither "
-                          "declared nor imported in the TL code.")
 def test_generate_lfric_adj_test_quadrature(fortran_reader):
     '''Check that input copies of quadrature arguments are not created.'''
     # Change the metadata so that it requires quadrature.

src/psyclone/tests/psyir/backend/fortran_gen_decls_test.py

@@ -47,7 +47,7 @@
     RoutineSymbol, ScalarType, Symbol, SymbolTable, UnresolvedType,
     StructureType, ImportInterface, UnresolvedInterface, ArgumentInterface,
     INTEGER_TYPE, REAL_TYPE, StaticInterface, PreprocessorInterface,
-    CHARACTER_TYPE)
+    CHARACTER_TYPE, UnsupportedFortranType)
 
 
 def test_gen_param_decls_dependencies(fortran_writer):
@@ -364,3 +364,71 @@ def test_gen_interfacedecl(fortran_writer):
   procedure :: sub1
 end interface subx
 ''')
+
+
+def test_fw_gen_proceduredecl(fortran_writer):
+    '''Test the FortranWriter class gen_proceduredecl method produces the
+    expected declarations and raises the expected exceptions.
+    '''
+    with pytest.raises(VisitorError) as err:
+        fortran_writer.gen_proceduredecl(None)
+    assert ("gen_proceduredecl() expects a 'DataSymbol' or "
+            "'StructureType.ComponentType' as its first "
+            "argument but got 'NoneType'" in str(err.value))
+
+    # A DataSymbol of UnupportedFortranType
+    symbol = DataSymbol("my_sub", UnsupportedFortranType(
+        "procedure, private :: my_unsupported_procedure"))
+    assert (fortran_writer.gen_proceduredecl(symbol) ==
+            "procedure, private :: my_unsupported_procedure\n")
+
+    # A StructureType.ComponentType with 'public' visibility and no initial
+    # value
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        Symbol.Visibility.PUBLIC, None)
+    assert (fortran_writer.gen_proceduredecl(dtype) ==
+            "procedure, public :: my_procedure\n")
+
+    # A StructureType.ComponentType with 'public' visibility and an initial
+    # value
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        Symbol.Visibility.PUBLIC,
+                                        Reference(RoutineSymbol("other",
+                                                                REAL_TYPE)))
+    assert (fortran_writer.gen_proceduredecl(dtype) ==
+            "procedure, public :: my_procedure => other\n")
+
+    # A StructureType.ComponentType with 'private' visibility and no initial
+    # value
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        Symbol.Visibility.PRIVATE, None)
+    assert fortran_writer.gen_proceduredecl(dtype) == (
+        "procedure, private :: my_procedure\n")
+
+    # A StructureType.ComponentType with 'private' visibility and an initial
+    # value
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        Symbol.Visibility.PRIVATE,
+                                        Reference(RoutineSymbol("other",
+                                                                REAL_TYPE)))
+    assert fortran_writer.gen_proceduredecl(dtype) == (
+        "procedure, private :: my_procedure => other\n")
+
+    # Check that visibility is not included in the output if include_visibility
+    # is False
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        Symbol.Visibility.PUBLIC, None)
+    assert (fortran_writer.gen_proceduredecl(dtype, include_visibility=False)
+            == ("procedure :: my_procedure\n"))
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        Symbol.Visibility.PRIVATE, None)
+    assert (fortran_writer.gen_proceduredecl(dtype, include_visibility=False)
+            == ("procedure :: my_procedure\n"))
+
+    # Check exception is raised if visibility is not 'public' or 'private'
+    dtype = StructureType.ComponentType("my_procedure", REAL_TYPE,
+                                        "wrong", None)
+    with pytest.raises(InternalError) as err:
+        fortran_writer.gen_proceduredecl(dtype)
+    assert ("A Symbol must be either public or private but symbol "
+            "'my_procedure' has visibility 'wrong'" in str(err.value))