diff --git a/pyproject.toml b/pyproject.toml index 170bed599f..b3710c7b23 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -91,11 +91,11 @@ test = [ "pytest-cov", "pytest-xdist", "tree-sitter", - "tree-sitter-fortran" + "tree-sitter-fortran==0.6.0" ] treesitter = [ "tree-sitter", - "tree-sitter-fortran" + "tree-sitter-fortran==0.6.0" ] [project.urls] diff --git a/src/psyclone/psyir/backend/fortran.py b/src/psyclone/psyir/backend/fortran.py index 42e8810cb2..6b80e23529 100644 --- a/src/psyclone/psyir/backend/fortran.py +++ b/src/psyclone/psyir/backend/fortran.py @@ -1649,8 +1649,8 @@ def codeblock_node(self, node): for line in node.get_fortran_lines(): result += f"{self._nindent}{line}\n" elif node.structure == CodeBlock.Structure.EXPRESSION: - for ast_node in node.parse_tree_nodes: - result += str(ast_node) + # No indent or newlines + result = "".join(node.get_fortran_lines()) else: raise VisitorError( f"Unsupported CodeBlock Structure '{node.structure}' found.") diff --git a/src/psyclone/psyir/frontend/fortran_treesitter_reader.py b/src/psyclone/psyir/frontend/fortran_treesitter_reader.py index ca0410dc80..f147419347 100644 --- a/src/psyclone/psyir/frontend/fortran_treesitter_reader.py +++ b/src/psyclone/psyir/frontend/fortran_treesitter_reader.py @@ -5,18 +5,39 @@ # See the full LICENSE file in the project root for details. # ----------------------------------------------------------------------------- -''' PSyIR TreeSitter Fortran reader ''' +''' + +PSyIR frontend for the TreeSitter Fortran parser generator. + +The structure of the expected fortran parse tree can be found in the +'rules' section of: +https://github.com/stadelmanma/tree-sitter-fortran/blob/master/grammar.js + +Note that psyclone is pinned to a particular version of treesitter (in +pyproject.toml), use that branch instead of master to follow the grammar. + +To interpret the rules use: +https://tree-sitter.github.io/tree-sitter/creating-parsers/ +2-the-grammar-dsl.html + +''' import codecs +from contextlib import contextmanager +from dataclasses import dataclass +from enum import Enum, auto import logging -from typing import TYPE_CHECKING, Iterable, Union, Callable +from typing import Callable, Iterable, Optional, TYPE_CHECKING, Union +from collections.abc import Generator, Container -from psyclone.psyir import nodes +from psyclone.errors import InternalError +from psyclone.psyir import nodes, symbols from psyclone.psyir.nodes.codeblock import TreeSitterCodeBlock, CodeBlock if TYPE_CHECKING: # Purposely inside typechecking because at runtime we want to lazily - # import the parser (only if it is actually used) + # import the parser only when it is actually used (import inside + # generate_parse_tree_from_source) from tree_sitter import Node as TSNode @@ -47,18 +68,85 @@ def to_str(node: 'TSNode') -> str: return node.text.decode('utf8') if node.text else "" +def children_of_type( + tsnode: Optional['TSNode'], types: Union[str, Container[str]] +) -> Generator['TSNode']: + ''' Provides a generator to iterate over the provided tsnode + children of the given type(s). + + :param tsnode: tree-sitter node whose children are searched. + :param node_type: tree-sitter type to find. + + :yields: matching child, or ``None`` if no child matches. + ''' + check_types = (types,) if isinstance(types, str) else types + if tsnode: + for child in tsnode.children: + if child.type in check_types: + yield child + + +@dataclass(frozen=True) +class _CommonDeclAttributes: + ''' Properties shared by all entities of a fortran declaration (the lhs + of ::). + + :param datatype: common PSyIR datatype or ``None`` if unsupported. + :param intent: common PSyIR argument access. + :param qualifiers: names of all declaration qualifiers. + :param unsupported: qualifiers not represented directly in PSyIR. + :param prefix: string preceding ``::`` (this is needed in case the + entities end up as UnsupportedFortranType). + ''' + + datatype: Union[symbols.DataType, symbols.DataTypeSymbol, None] + intent: symbols.ArgumentInterface.Access + qualifiers: frozenset[str] + unsupported: frozenset[str] + prefix: str + + +class _NodeExpectation(Enum): + '''Expected result of processing tree-sitter nodes.''' + + #: Expect a list (of zero, one or multiple) PSyIR nodes + LIST = auto() + #: Expect no resulting node + NONE = auto() + #: Expect no resulting node, NotImplemented should be UnsupportedTypes + SPECS = auto() + #: Expect exactly one node + ONE = auto() + #: Expect exactly one node that is a DataNode + EXPRESSION = auto() + + class FortranTreeSitterReader(): - ''' Processes the TreeSitter parse_tree and converts it to PSyIR. + ''' Generate TreeSitter parse_trees and convert them to PSyIR nodes. + + The Reader works mostly by traversing the parse_tree with recursive + calls to the _process_nodes dispatching method. This method calls + the appropriate node handler for the given treesitter node. + + When Fortran scopes are found these are managed by the _using_scope + context manager, this utility keeps a stack of nested scopes with a + global reference to the top of the stack, this reference can be used + everywhere to access the current scope. - Note: this class is in development, currently only generates - top-level Modules and CodeBlocks. + Generally, handlers can raise 3 types of errors: + - NotImplementedError, if they find valid Fortran that is currently + not supported. A parent node should catch it an convert it to a + CodeBlock or an UnsupportedType declaration. + - ValueError, if invalid Fortran is found. + - InternalError, if an unexpected state is found that likely points + to a bug in the Reader. - The structure of the expected fortran parse tree can be found in the - 'rules' section of: - https://github.com/stadelmanma/tree-sitter-fortran/blob/master/grammar.js - To interpret the rules use: - https://tree-sitter.github.io/tree-sitter/creating-parsers/ - 2-the-grammar-dsl.html + Note that the implementation is incomplete, its main limitations are + that: + - the Reader parameters are ignored. + - fparser is still not isolated, so the performance penalty of importing + fparser is still paid when using treesitter. + - the coverage of Fortran supported is more limited than in fparser. :param ignore_directives: Whether directives should be ignored or not (default True). Currently ignored. @@ -70,12 +158,59 @@ class FortranTreeSitterReader(): Defaults to False. Currently ignored. :param ignore_comments: whether to let the parser ignore comments. :param free_form: whether to parse using Fortran free_form syntax. - :param ignore_directives: whether to ignore directives while parsing. :param conditional_openmp: whether to parse conditional OpenMP statements. - - :raises TypeError: if any constructor argument is not of the expected type. ''' + _UNARY_OPERATORS = { + "+": nodes.UnaryOperation.Operator.PLUS, + "-": nodes.UnaryOperation.Operator.MINUS, + ".not.": nodes.UnaryOperation.Operator.NOT, + } + _BINARY_OPERATORS = { + "+": nodes.BinaryOperation.Operator.ADD, + "-": nodes.BinaryOperation.Operator.SUB, + "*": nodes.BinaryOperation.Operator.MUL, + "/": nodes.BinaryOperation.Operator.DIV, + "**": nodes.BinaryOperation.Operator.POW, + "==": nodes.BinaryOperation.Operator.EQ, + ".eq.": nodes.BinaryOperation.Operator.EQ, + "/=": nodes.BinaryOperation.Operator.NE, + ".ne.": nodes.BinaryOperation.Operator.NE, + "<": nodes.BinaryOperation.Operator.LT, + ".lt.": nodes.BinaryOperation.Operator.LT, + "<=": nodes.BinaryOperation.Operator.LE, + ".le.": nodes.BinaryOperation.Operator.LE, + ">": nodes.BinaryOperation.Operator.GT, + ".gt.": nodes.BinaryOperation.Operator.GT, + ">=": nodes.BinaryOperation.Operator.GE, + ".ge.": nodes.BinaryOperation.Operator.GE, + ".and.": nodes.BinaryOperation.Operator.AND, + ".or.": nodes.BinaryOperation.Operator.OR, + ".eqv.": nodes.BinaryOperation.Operator.EQV, + ".neqv.": nodes.BinaryOperation.Operator.NEQV, + } + _INTENT_ACCESS = { + "in": symbols.ArgumentInterface.Access.READ, + "out": symbols.ArgumentInterface.Access.WRITE, + "inout": symbols.ArgumentInterface.Access.READWRITE, + } + + # Some tree-sitter node types share the same handler. + _HANDLER_REDIRECTIONS = { + "subroutine": "_procedure_handler", + "function": "_procedure_handler", + "program": "_procedure_handler", + "unary_expression": "_operation", + "logical_expression": "_operation", + "relational_expression": "_operation", + "math_expression": "_operation", + "allocate_statement": "_memory_statement", + "deallocate_statement": "_memory_statement", + "nullify_statement": "_memory_statement", + } + + # These arguments intentionally mirror the other Fortran reader API. + # pylint: disable=too-many-arguments,too-many-positional-arguments def __init__( self, ignore_directives: bool = True, @@ -85,6 +220,7 @@ def __init__( free_form: bool = True, conditional_openmp: bool = True, ): + ''' Create a Fortran tree-sitter reader. ''' # TODO #3083: Arguments are currently not used nor typechecked, but if # we decide this is the common reader interface, this can be done in a # super class instead of duplicate it here. @@ -94,15 +230,10 @@ def __init__( self._ignore_comments = ignore_comments self._free_form = free_form self._conditional_openmp = conditional_openmp - # TODO #3083: Currently this reader uses a cursor pointer instead of - # passing around a parent argument all the time (like fparser's), but - # this can be re-evaluated if necessary. - self._psyir_cursor = None - # Map from treesitter node types to their handler routine - self.handlers = { - 'translation_unit': self._translation_unit, - 'module': self._module_handler, - } + # Keep a reference to the symbol table currently in scope, instead of + # having it as argument everywhere. The initial one here is a + # disposable instance (but prevents having to deal with the None type) + self._current_scope: symbols.SymbolTable = symbols.SymbolTable() def generate_parse_tree_from_file(self, file_path) -> 'TSNode': ''' @@ -163,36 +294,169 @@ def generate_psyir(self, parse_tree: 'TSNode') -> nodes.Node: :returns: the equivalent PSyIR Node. ''' - return self.process_nodes(parse_tree)[0] + # This is the public entry point, reset the scoping pointer + self._current_scope = symbols.SymbolTable() + return self._process_nodes(parse_tree, _NodeExpectation.ONE) + + @contextmanager + def _using_scope( + self, symtab: symbols.SymbolTable + ) -> Generator[None]: + ''' Make the given symtab the new parsing scope, but keep a reference + to the previous scope in order to restore it when leaving this new + scope (by a graceful exit or an exception). - def process_nodes(self, tsnodes: Union["TSNode", Iterable["TSNode"]]): + :param symtab: symbol table for the scope being translated. + + :yields: while ``symtab`` is the reader's current scope. ''' - Create the PSyIR that represents the supplied treesitter nodes. + previous_scope = self._current_scope + self._current_scope = symtab + try: + yield + finally: + self._current_scope = previous_scope - :param nodes: the list of nodes to process, for convenience it accepts - a single node or a list of them. + @contextmanager + def _using_temporary_scope( + self, parent: nodes.ScopingNode, + scope: Optional[nodes.ScopingNode] = None + ) -> Generator[None]: + ''' + Like `_using_scope`, but soft-link the scope of the supplied parent + or a disposable ScopingNode if none is provided. This is useful when + the resulting PSyIR does not need the scope but lookup must still reach + the parent. For example in the body of a derived type: - :returns: the equivalent PSyIR Node. + .. code-block:: fortran + + module m + integer, parameter :: size = 10 + type myt + integer, dimension(size) :: array + end type + end module + + :param parent: real scope used for lexical lookup. + :param scope: existing orphan scope to use, or ``None`` to create a + disposable one. + + :yields: while the provided or a disposable scope is soft-linked + to provide a temporary current scope. + + :raises ValueError: if the supplied scope already has a parent. + ''' + if scope: + if scope.parent is not None: + raise InternalError("The supplied scope must be an orphan") + else: + scope = nodes.ScopingNode(symbol_table=symbols.SymbolTable()) + + previous_scope = self._current_scope + # Intentionally bypass bidirectional link and child validation. + # pylint: disable=protected-access + scope._parent = parent + self._current_scope = scope.symbol_table + try: + yield + finally: + # Remove soft link + scope._parent = None + self._current_scope = previous_scope + + def _process_nodes( + self, + tsnodes: Union["TSNode", Iterable["TSNode"]], + expect: _NodeExpectation, + ) -> Optional[Union[list[nodes.Node], nodes.Node]]: + ''' + The tsnodes handler dispatcher. Unsupported syntax is deliberately + caught here rather than in individual handlers so that continuous + unsupported nodes can be placed in a single CodeBlock. + + :param tsnodes: one tree-sitter node or an iterable of nodes. + :param expect: expected number and kind of result nodes. + + :returns: PSyIR nodes produced from the supplied tree-sitter nodes. ''' + if expect not in _NodeExpectation: + raise InternalError( + f"Unsupported node expectation '{expect}'") list_of_nodes = tsnodes if isinstance(tsnodes, Iterable) else [tsnodes] children = [] for tsnode in list_of_nodes: try: - handler = self.get_handler(tsnode) - children.append(handler(tsnode)) + handler = self._get_handler(tsnode) + result = handler(tsnode) + if result is not None: + children.append(result) except NotImplementedError as err: - # TODO #3083: Add support for expression codeblocks and - # aggregating contiguous codeblocks into a single one. - structure = CodeBlock.Structure.STATEMENT - code_block = TreeSitterCodeBlock(tsnode, structure) - code_block.append_preceding_comment( - f"PSyclone CodeBlock (unsupported code) reason:\n" - f"- {err}" + if expect is _NodeExpectation.SPECS: + # If it reaches this point it means we haven't even + # identified its name, but to not lose the statement + # we still add it in the symtab as an UnsupportedType + symbol = self._current_scope.new_symbol( + root_name="PSYCLONE_UNSUPPORTED", + symbol_type=symbols.DataSymbol, + datatype=symbols.UnsupportedFortranType(to_str(tsnode)) + ) + # TODO #3083: We need to hardcode the type_text until we + # remove the Fparser2 logic from that class + symbol.datatype._type_text = to_str(tsnode) + else: + # Everything else we store as Codeblocks + # TODO #3083: Aggregate contiguous CodeBlocks. + structure = (CodeBlock.Structure.EXPRESSION + if expect is _NodeExpectation.EXPRESSION + else CodeBlock.Structure.STATEMENT) + children.append( + self._create_codeblock(tsnode, str(err), structure)) + + # Validate that the parsed nodes match the expectations of the caller + if expect in (_NodeExpectation.ONE, _NodeExpectation.EXPRESSION): + if len(children) != 1: + raise InternalError( + f"Only one node was expected in this location but got:\n" + f"{[type(c).__name__ for c in children]}" + ) + if expect is _NodeExpectation.EXPRESSION: + if not isinstance(children[0], nodes.DataNode): + raise InternalError( + f"A DataNode was expected in this location but got: " + f"{type(children[0]).__name__}" + ) + return children[0] + if expect in (_NodeExpectation.NONE, _NodeExpectation.SPECS): + if len(children) != 0: + raise InternalError( + f"No node was expected in this location but got:\n" + f"{[type(c).__name__ for c in children]}" ) - children.append(code_block) + return None return children - def get_handler(self, tsnode: 'TSNode') -> Callable: + @staticmethod + def _create_codeblock( + tsnode: 'TSNode', reason: str, + structure: CodeBlock.Structure = CodeBlock.Structure.STATEMENT + ) -> TreeSitterCodeBlock: + '''Create a CodeBlock for unsupported valid Fortran. + + :param tsnode: tree-sitter node containing unsupported Fortran. + :param reason: human-readable explanation of the limitation. + :param structure: whether the unsupported code is a statement or an + expression. + + :returns: CodeBlock retaining the original tree-sitter node. + ''' + code_block = TreeSitterCodeBlock(tsnode, structure) + code_block.append_preceding_comment( + f"PSyclone CodeBlock (unsupported code) reason:\n" + f"- {reason}" + ) + return code_block + + def _get_handler(self, tsnode: 'TSNode') -> Callable: ''' :param tsnode: a given treesitter node. @@ -201,13 +465,23 @@ def get_handler(self, tsnode: 'TSNode') -> Callable: :raises NotImplementedError: if the given node type does not have a handler for it. ''' - handler = self.handlers.get(tsnode.type) - if not handler: - raise NotImplementedError( - f"Unsupported '{tsnode.type}' tree-sitter node.") - return handler + # Some nodes use a common handler + redirection = self._HANDLER_REDIRECTIONS.get(tsnode.type) + if redirection: + return getattr(self, redirection) + + # Otherwise use the handler that matches its name + handler = getattr(self, f"_{tsnode.type}_handler", None) + if handler is not None: + return handler - def _translation_unit(self, tsnode: 'TSNode') -> nodes.Node: + # If at this point we still don't have a handler, it is unsupported + raise NotImplementedError( + f"Unsupported '{tsnode.type}' tree-sitter node.") from None + + def _translation_unit_handler( + self, tsnode: 'TSNode' + ) -> nodes.Node: ''' Handle treesitter 'translation_unit' node. :param tsnode: the treesitter node the process. @@ -215,41 +489,1792 @@ def _translation_unit(self, tsnode: 'TSNode') -> nodes.Node: :returns: the equivalent PSyIR Node. ''' file_container = nodes.FileContainer("") - self._psyir_cursor = file_container - file_container.children.extend(self.process_nodes(tsnode.children)) + with self._using_scope(file_container.symbol_table): + file_container.children.extend( + self._process_nodes(tsnode.children, _NodeExpectation.LIST) + ) return file_container - def _module_handler(self, tsnode: 'TSNode') -> nodes.Node: + def _module_handler( + self, tsnode: 'TSNode' + ) -> nodes.Node: ''' Handle a treesitter 'module' node. :param tsnode: the treesitter node the process. :returns: the equivalent PSyIR Node. - :raises NotImplementedError: if the module has an unsupported child. - :raises NotImplementedError: if the module permits implicit variables. ''' - module_name = None - internal_proc = None - implicit_statement = False + statement = next( + children_of_type(tsnode, "module_statement"), None) + name = next(children_of_type(statement, "name"), None) + container = nodes.Container(to_str(name) if name else "") + + with self._using_scope(container.symbol_table): + visibility_map = self._process_access_statements(tsnode.children) + + # This nodes are already processed + skip = { + "module_statement", "end_module_statement", + "implicit_statement", "internal_procedures", + "public_statement", "private_statement" + } + # Parse the specification part + self._process_nodes( + [child for child in tsnode.children + if child.type not in skip], _NodeExpectation.SPECS) + + # Parse the execution part + internal = next( + children_of_type(tsnode, "internal_procedures"), None) + if internal: + self._predeclare_routines(internal.children) + container.children.extend( + self._process_nodes( + [child for child in internal.children + if child.type != "contains_statement"], + _NodeExpectation.LIST)) + self._apply_visibility(visibility_map) + return container + + def _procedure_handler( + self, tsnode: 'TSNode' + ) -> nodes.Routine: + '''Handler shared by programs, subroutines and functions. + + :param tsnode: the procedure treesitter node. + :returns: translated PSyIR Routine. + ''' + routine_kind = tsnode.type + signature = next(children_of_type( + tsnode, f"{routine_kind}_statement"), None) + name_node = next(children_of_type(signature, "name"), None) + name = to_str(name_node) if name_node else routine_kind + parameters = next( + children_of_type(signature, "parameters"), None) + argument_names = tuple( + to_str(child) for child in parameters.children + if child.type == "identifier") if parameters else () + return_name, return_type = self._function_return_info( + signature, name, routine_kind) + + # Insert arguments before declarations so specify_argument_list() can + # retain source order. Declarations later complete these placeholders. + routine_table = symbols.SymbolTable() + for arg_name in argument_names: + routine_table.add(symbols.DataSymbol( + arg_name, symbols.UnresolvedType(), + interface=symbols.ArgumentInterface())) + if return_name and return_name not in routine_table: + routine_table.add(symbols.DataSymbol( + return_name, return_type or symbols.UnresolvedType())) + + rsymbol = self._create_routine_symbol( + name, signature, return_type) + qualifiers = { + to_str(child).lower().replace("-", "_") + for child in signature.children + if child.type == "procedure_qualifier"} + is_recursive = (True if "recursive" in qualifiers else + False if "non_recursive" in qualifiers else None) + routine = nodes.Routine( + rsymbol, is_program=routine_kind == "program", + is_recursive=is_recursive, + symbol_table=routine_table) + + # A routine must be parsed inside a scope as it is also a declaration + parent_symtab = self._current_scope + parent = parent_symtab.node if parent_symtab else None + if not isinstance(parent, nodes.ScopingNode): + raise InternalError( + "A Routine must be translated within a PSyIR scope") + + with self._using_temporary_scope(parent, routine): + vis_map = self._process_access_statements(tsnode.children) + # This nodes are already processed + skip = { + f"{routine_kind}_statement", + f"end_{routine_kind}_statement", + "implicit_statement" + } + routine.children.extend(self._process_nodes( + [child for child in tsnode.children + if child.type not in skip], _NodeExpectation.LIST)) + + args = [routine.symbol_table.lookup(name) + for name in argument_names] + routine.symbol_table.specify_argument_list(args) + if return_name: + routine.return_symbol = routine.symbol_table.lookup( + return_name) + self._apply_visibility(vis_map) + + # PSyIR cannot represent implicitly declared data. Leave + # unresolved names alone only when a wildcard import or a + # CodeBlock could contain their declaration, matching the + # conditions under which the Fortran backend can preserve them. + fallback_context = ( + routine.symbol_table.wildcard_imports() or + routine.walk(nodes.CodeBlock)) + for symbol in routine.symbol_table.datasymbols: + if not isinstance(symbol.datatype, symbols.UnresolvedType): + continue + if (isinstance(symbol.interface, + symbols.UnresolvedInterface) and + fallback_context): + continue + raise NotImplementedError( + f"Implicit declaration of '{symbol.name}' is not " + "supported") + return routine + + def _function_return_info( + self, signature: 'TSNode', routine_name: str, routine_kind: str + ) -> tuple[Optional[str], Optional[symbols.DataType]]: + '''Extract result name and datatype from a function statement. + + :param statement: node containing the function signature. + :param routine_name: name of the program unit. + :param routine_kind: one of ``program``, ``subroutine`` or + ``function``. + + :returns: result-symbol name and datatype, both ``None`` for a + non-function. + ''' + if routine_kind != "function": + return None, None + + result = next( + children_of_type(signature, "function_result"), None) + result_name = next(children_of_type(result, "identifier"), None) + return_name = to_str(result_name) if result_name else routine_name + type_node = next( + (child for child in signature.children + if child.type in ("intrinsic_type", "derived_type")), None) + if not type_node: + return return_name, None + try: + return return_name, self._datatype_from_type(type_node) + except (NotImplementedError, KeyError, TypeError): + # UnsupportedFortranType must contain a valid entity declaration. + # A function prefix is not one, so retaining it on the result + # symbol makes the backend fail. Preserve the complete procedure + # as a CodeBlock instead. + raise NotImplementedError( + "Function return type is not supported") from None + + def _predeclare_routines(self, tsnodes: Iterable['TSNode']): + '''Create symbols for contained procedures before translating bodies. + + This makes calls in an earlier procedure resolve to the same symbol as + a procedure whose implementation occurs later in the source. + + :param tsnodes: children of an internal-procedures node. + ''' + symtab = self._current_scope + for procedure in tsnodes: + if procedure.type not in ("subroutine", "function"): + continue + signature = next(children_of_type( + procedure, f"{procedure.type}_statement"), None) + name_node = next(children_of_type(signature, "name"), None) + name = to_str(name_node) + try: + _, return_type = self._function_return_info( + signature, name, procedure.type) + except NotImplementedError: + # Still establish identity for calls. Translation of the + # procedure itself will subsequently preserve its source. + return_type = None + routine_symbol = self._create_routine_symbol( + name, signature, return_type) + if name not in symtab: + symtab.add(routine_symbol) + + def _create_routine_symbol( + self, name: str, signature: 'TSNode', return_type + ) -> symbols.RoutineSymbol: + '''Create or complete the RoutineSymbol for a program unit. + + An interface block may create the symbol before its implementation is + visited. Reusing it ensures interface members and the Routine node + refer to the same object. + + :param name: routine name. + :param signature: the signature node of the routine. + :param return_type: translated function return type, if any. + + :returns: RoutineSymbol representing the program unit. + ''' + qualifiers = { + to_str(child).lower().replace("-", "_") + for child in signature.children + if child.type == "procedure_qualifier"} + is_elemental = "elemental" in qualifiers + is_pure = ("pure" in qualifiers or + (is_elemental and "impure" not in qualifiers)) + visibility = self._current_scope.default_visibility + try: + routine_symbol = self._current_scope.lookup(name) + except KeyError: + routine_symbol = None + if isinstance(routine_symbol, symbols.RoutineSymbol): + routine_symbol.datatype = ( + return_type or routine_symbol.datatype) + routine_symbol.is_pure = is_pure + routine_symbol.is_elemental = is_elemental + routine_symbol.visibility = visibility + return routine_symbol + return symbols.RoutineSymbol( + name, datatype=return_type or symbols.UnresolvedType(), + is_pure=is_pure, + is_elemental=is_elemental, + visibility=visibility) + + def _number_literal_handler( + self, tsnode: 'TSNode' + ) -> nodes.Literal: + '''Translate an integer or real literal. + + :param tsnode: number-literal tree-sitter node. + + :returns: PSyIR integer or real Literal. + ''' + text = to_str(tsnode).lower() + value, _, kind = text.partition("_") + is_real = any(char in value for char in ".ed") + # PSyIR stores all real exponents using ``e`` notation while the + # Fortran ``d`` exponent also specifies double precision. + has_double_exponent = "d" in value + if has_double_exponent: + value = value.replace("d", "e", 1) + datatype = ( + symbols.ScalarType.real_double_type() + if has_double_exponent else + symbols.ScalarType.real_type() + if is_real else symbols.ScalarType.integer_type()) + if kind: + # A numeric Fortran KIND value is processor-specific and is not + # equivalent to either a byte size or PSyIR relative precision. + precision = (int(kind) if kind.isdigit() + else nodes.Reference(self._kind_symbol(kind))) + datatype = symbols.ScalarType( + datatype.intrinsic, precision) + return nodes.Literal(value, datatype) + + def _string_literal_handler( + self, tsnode: 'TSNode' + ) -> nodes.Literal: + '''Translate a character literal. + + :param tsnode: string-literal tree-sitter node. + + :returns: PSyIR character Literal. + ''' + text = to_str(tsnode) + quote_position = min(position for position in + (text.find("'"), text.find('"')) + if position >= 0) + quote = text[quote_position] + + prefix = text[:quote_position] + datatype = symbols.ScalarType.character_type() + if prefix: + kind = prefix[:-1].lower() + precision = (int(kind) if kind.isdigit() else + nodes.Reference(self._kind_symbol(kind))) + datatype = symbols.ScalarType( + symbols.ScalarType.Intrinsic.CHARACTER, precision) + value = text[quote_position + 1:-1].replace(quote * 2, quote) + return nodes.Literal(value, datatype) + + def _boolean_literal_handler( + self, tsnode: 'TSNode' + ) -> nodes.Literal: + '''Translate a logical literal. + + :param tsnode: boolean-literal tree-sitter node. + + :returns: PSyIR boolean Literal. + ''' + value = to_str(tsnode).lower().strip(".") + return nodes.Literal(value, symbols.ScalarType.boolean_type()) + + def _variable_declaration_handler( + self, tsnode: 'TSNode' + ) -> None: + '''Translate every entity in a variable declaration. + + :param tsnode: variable-declaration tree-sitter node. + ''' + # A declaration has properties shared by every entity (type and + # attributes) followed by one or more entity-specific declarators. + type_node = next((child for child in tsnode.children + if child.type in + ("intrinsic_type", "derived_type"))) + + qualifiers = [child for child in tsnode.children + if child.type == "type_qualifier"] + qualifier_names = frozenset( + child.children[0].type + for child in qualifiers if child.children) + supported_qualifiers = { + "allocatable", "dimension", "intent", "parameter", "private", + "public", "save" + } + # If we find anything else it will be UnsupportedType + unsupported = qualifier_names.difference(supported_qualifiers) + try: + datatype = self._datatype_from_type(type_node) + except (NotImplementedError, KeyError, TypeError): + datatype = None + + dimension = next( + (next(children_of_type(item, "argument_list"), None) + for item in qualifiers + if item.children and item.children[0].type == "dimension"), None) + is_allocatable = "allocatable" in qualifier_names + if datatype and dimension: + try: + shape = self._shape_from_node(dimension, is_allocatable) + datatype = symbols.ArrayType(datatype, shape) + except (NotImplementedError, TypeError): + datatype = None + + intent_node = next( + (item for item in qualifiers + if item.children and item.children[0].type == "intent"), None) + intent = symbols.ArgumentInterface.Access.UNKNOWN + if intent_node: + intent = next( + (self._INTENT_ACCESS[child.type] + for child in intent_node.children + if child.type in self._INTENT_ACCESS), intent) + common_attr = _CommonDeclAttributes( + datatype, intent, qualifier_names, + frozenset(unsupported), + to_str(tsnode).split("::", maxsplit=1)[0].strip()) + + for declarator in tsnode.children: + if declarator.type in ( + "identifier", "sized_declarator", "init_declarator"): + self._declare_entity(declarator, common_attr) + + def _declare_entity( + self, declarator: 'TSNode', common_attr: _CommonDeclAttributes + ): + '''Translate one entity and add it to the current symbol table. + + :param declarator: identifier or entity-declarator tree-sitter node. + :param common_attr: properties shared by the complete declaration. + ''' + id_node = (declarator if declarator.type == "identifier" + else next(children_of_type( + declarator, "identifier"), None)) + name = to_str(id_node) + datatype, initial_value = self._declarator_datatype( + declarator, common_attr) + + visibility = self._current_scope.default_visibility + if "public" in common_attr.qualifiers: + visibility = symbols.Symbol.Visibility.PUBLIC + elif "private" in common_attr.qualifiers: + visibility = symbols.Symbol.Visibility.PRIVATE + + kwargs = {"visibility": visibility} + interface = self._declaration_interface( + name, common_attr, initial_value is not None) + if interface is not None: + kwargs["interface"] = interface + if initial_value is not None: + kwargs["initial_value"] = initial_value + if "parameter" in common_attr.qualifiers: + kwargs["is_constant"] = True + declared_symbol = symbols.DataSymbol(name, datatype, **kwargs) + self._add_or_update_datasymbol(declared_symbol) + + def _declarator_datatype( + self, declarator: 'TSNode', common_attr: _CommonDeclAttributes + ): + '''Translate one entity's datatype and initial value. + + Entity-specific syntax must be handled independently. In particular, + an unsupported initializer on one entity must not make its siblings + unsupported. + + :param declarator: entity-declarator tree-sitter node. + :param common_attr: properties shared by the complete declaration. + + :returns: entity datatype and optional initial-value expression. + ''' + is_unsupported = bool(common_attr.unsupported) + initial_value = None + if declarator.type == "init_declarator": + expressions = [ + child for child in declarator.children + if child.type not in ("identifier", "=")] + if expressions: + try: + initial_value = self._process_nodes( + expressions[-1], _NodeExpectation.EXPRESSION) + except NotImplementedError: + is_unsupported = True + + # An entity-specific shape takes precedence over a shared DIMENSION + # attribute. The latter has already been translated into an ArrayType, + # from which the elemental type can be recovered. + datatype = common_attr.datatype + shape_node = next(children_of_type(declarator, "size"), None) + is_allocatable = "allocatable" in common_attr.qualifiers + if datatype and shape_node: + try: + elemental_type = ( + datatype.elemental_type + if isinstance(datatype, symbols.ArrayType) else datatype) + if isinstance(elemental_type, symbols.DataType): + elemental_type = elemental_type.copy() + shape = self._shape_from_node( + shape_node, is_allocatable) + datatype = symbols.ArrayType(elemental_type, shape) + except (NotImplementedError, TypeError): + datatype = None + elif is_allocatable and not isinstance(datatype, symbols.ArrayType): + datatype = None + elif isinstance(datatype, symbols.DataType): + # A datatype can contain PSyIR expressions (e.g. array bounds or + # character length), which must not be shared between symbols. + datatype = datatype.copy() + + # UnsupportedFortranType is preferable to losing a declaration. + # Keep only this entity in the saved text to avoid duplicating sibling + # names when the Fortran backend emits the symbols. + if datatype is None or is_unsupported: + entity = to_str(declarator).strip() + datatype = symbols.UnsupportedFortranType( + f"{common_attr.prefix} :: {entity}") + return datatype, initial_value + + def _declaration_interface( + self, name: str, common_attr: _CommonDeclAttributes, + has_initial_value: bool = False + ): + '''Return the PSyIR interface for one declared entity. + + Interfaces describe where a symbol is defined and how a dummy argument + may be accessed. They are independent of its datatype. + + :param name: declared entity name. + :param common_attr: properties shared by the complete declaration. + :param has_initial_value: whether the entity has an initializer. + + :returns: symbol interface, or ``None`` for an automatic local. + ''' + symtab = self._current_scope + if name in symtab and symtab.lookup(name).is_argument: + return symbols.ArgumentInterface(common_attr.intent) + if (has_initial_value or + {"save", "parameter"}.intersection(common_attr.qualifiers)): + return symbols.StaticInterface() + if isinstance(symtab.node, nodes.Container): + return symbols.DefaultModuleInterface() + return None + + def _add_or_update_datasymbol( + self, declared_symbol: symbols.DataSymbol + ): + '''Add a declared symbol or complete a dummy-argument placeholder. + + Routine arguments are inserted before declarations are processed so + their source order is known. Their later declaration therefore updates + the placeholder, while ordinary local declarations create a new + DataSymbol. + + :param declared_symbol: fully translated symbol for the entity. + + :raises ValueError: if the name is already used for an imported + module. + :raises NotImplementedError: if an existing symbol is not a + DataSymbol. + ''' + symtab = self._current_scope + if declared_symbol.name in symtab: + symbol = symtab.lookup(declared_symbol.name) + if isinstance(symbol, symbols.ContainerSymbol): + raise ValueError( + f"USE module '{symbol.name}' conflicts with another " + f"symbol") + if not isinstance(symbol, symbols.DataSymbol): + raise NotImplementedError( + f"'{declared_symbol.name}' is already declared as a " + f"non-data symbol") + symbol.datatype = declared_symbol.datatype + symbol.visibility = declared_symbol.visibility + if not isinstance( + declared_symbol.interface, symbols.AutomaticInterface): + symbol.interface = declared_symbol.interface + if declared_symbol.initial_value is not None: + # The initial value belongs to the temporary symbol created + # for this declaration. Give the existing symbol its own + # expression tree when completing a forward reference. + symbol.initial_value = declared_symbol.initial_value.copy() + if declared_symbol.is_constant: + symbol.is_constant = True + return + symtab.add(declared_symbol) + + def _datatype_from_type( + self, tsnode: 'TSNode' + ): + '''Return a PSyIR datatype for a tree-sitter type specification. + + :param tsnode: intrinsic- or derived-type tree-sitter node. + + :returns: translated PSyIR datatype. + + :raises NotImplementedError: if PSyIR cannot represent the type. + ''' + symtab = self._current_scope + if tsnode.type == "derived_type": + keyword = tsnode.children[0].type + name_node = next( + children_of_type(tsnode, "type_name"), None) + name = to_str(name_node) + if keyword == "class": + raise NotImplementedError( + "Polymorphic CLASS declarations are not supported") + try: + return self._current_scope.lookup(name) + except KeyError: + datatype = symbols.DataTypeSymbol( + name, symbols.UnresolvedType()) + symtab.add(datatype) + return datatype + + intrinsic = tsnode.children[0].type + mapping = { + "integer": symbols.ScalarType.Intrinsic.INTEGER, + "real": symbols.ScalarType.Intrinsic.REAL, + "logical": symbols.ScalarType.Intrinsic.BOOLEAN, + "character": symbols.ScalarType.Intrinsic.CHARACTER, + } + if intrinsic not in mapping: + if to_str(tsnode).lower().replace(" ", "_") == "double_precision": + return symbols.ScalarType.real_double_type() + raise NotImplementedError( + f"Intrinsic type '{intrinsic}' has no PSyIR representation") + precision = symbols.ScalarType.Precision.UNDEFINED + length = None + kind_node = next(children_of_type(tsnode, "kind"), None) + if kind_node: + values = [child for child in kind_node.children + if child.type not in ("(", ")", ",")] + for value in values: + if value.type == "keyword_argument": + key = to_str(value.children[0]).lower() + value = value.children[-1] + if key == "len": + length = self._process_nodes( + value, _NodeExpectation.EXPRESSION) + else: + precision = self._precision(value) + elif intrinsic == "character": + length = self._process_nodes( + value, _NodeExpectation.EXPRESSION) + else: + precision = self._precision(value) + return symbols.ScalarType(mapping[intrinsic], precision, length) + + def _precision(self, tsnode: 'TSNode'): + '''Translate a kind expression into a ScalarType precision value. + + :param tsnode: tree-sitter node containing the kind expression. + + :returns: precision enumeration, integer or PSyIR Reference. + + :raises NotImplementedError: if the kind expression is unsupported. + ''' + expr = self._process_nodes(tsnode, _NodeExpectation.EXPRESSION) + if isinstance(expr, nodes.Literal) and expr.value.isdigit(): + # Keep numeric KIND selectors as PSyIR expressions. An integer + # precision would instead mean a byte size to PSyIR backends. + return expr + if isinstance(expr, nodes.Reference): + # pylint: disable=unidiomatic-typecheck + if type(expr.symbol) is symbols.Symbol: + # All precisions must be integers + expr.symbol.specialise( + symbols.DataSymbol, + datatype=symbols.ScalarType.integer_type()) + return expr + raise NotImplementedError("kind expressions are not supported") + + def _kind_symbol( + self, name: str + ) -> symbols.DataSymbol: + '''Look up or create a symbol used as a kind parameter. + + :param name: name of the kind parameter. + + :returns: DataSymbol representing the kind parameter. + + :raises NotImplementedError: if the name resolves to another symbol + type. + ''' + symtab = self._current_scope + try: + symbol = self._current_scope.lookup(name) + except KeyError: + symbol = symbols.DataSymbol( + name, symbols.ScalarType.integer_type(), + interface=symbols.UnresolvedInterface()) + symtab.add(symbol) + return symbol + + @staticmethod + def _split_extent( + tsnode: 'TSNode' + ) -> tuple[list['TSNode'], list['TSNode'], bool]: + ''' Split the children of a ``lower:upper``-style construct. + + :param tsnode: tree-sitter node containing an optional colon. + + :returns: children before the colon, children after it, and whether a + colon was present. + ''' + colon = next((idx for idx, child in enumerate(tsnode.children) + if child.type == ":"), None) + if colon is None: + return list(tsnode.children), [], False + return (list(tsnode.children[:colon]), + list(tsnode.children[colon + 1:]), True) + + def _shape_from_node( + self, tsnode: 'TSNode', is_allocatable: bool = False + ) -> list: + '''Translate a declaration size or argument list into an array + shape. + + :param tsnode: size or argument-list tree-sitter node. + :param is_allocatable: whether open bounds are deferred rather than + assumed shape. + + :returns: PSyIR ArrayType shape entries. + ''' + result = [] for child in tsnode.children: - if child.type == "module_statement": - _module_keyword, module_name = child.children - elif child.type == "end_module_statement": - pass - elif child.type == "internal_procedures": - internal_proc = child - elif child.type == "implicit_statement": - implicit_statement = True + if child.type in ("(", ")", ","): + continue + if child.type == "extent_specifier": + before, after, _ = self._split_extent(child) + if not before and not after: + result.append(symbols.ArrayType.Extent.DEFERRED + if is_allocatable else + symbols.ArrayType.Extent.ATTRIBUTE) + elif before and not after: + if is_allocatable: + # PSyIR cannot currently distinguish a deferred upper + # bound with an explicit lower bound from an assumed- + # shape bound, so preserve the declaration verbatim. + raise NotImplementedError( + "An allocatable bound with an explicit lower " + "bound is not supported") + result.append( + (self._process_nodes( + before[0], _NodeExpectation.EXPRESSION), + symbols.ArrayType.Extent.ATTRIBUTE)) + elif after and not before: + result.append(self._process_nodes( + after[0], _NodeExpectation.EXPRESSION)) + else: + result.append((self._process_nodes( + before[0], _NodeExpectation.EXPRESSION), + self._process_nodes( + after[0], _NodeExpectation.EXPRESSION))) else: + result.append(self._process_nodes( + child, _NodeExpectation.EXPRESSION)) + return result + + def _process_access_statements( + self, tsnodes: Iterable['TSNode'] + ) -> dict[str, symbols.Symbol.Visibility]: + '''Record default and name-specific visibility for a scope. + + :param tsnodes: tree-sitter children of the current scope. + + :returns: explicit visibility indexed by normalised symbol name. + ''' + symtab = self._current_scope + visibility_map = {} + for tsnode in tsnodes: + if tsnode.type not in ("public_statement", "private_statement"): + continue + # Access rules for defined operators and assignment cannot be + # represented in a SymbolTable. Reject the containing scope so + # that it is preserved verbatim as a CodeBlock. Module handlers + # otherwise skip access statements after this pre-processing + # pass, so relying on the statement handler alone would silently + # discard these forms. + self._public_statement_handler(tsnode) + visibility = (symbols.Symbol.Visibility.PUBLIC + if tsnode.type == "public_statement" else + symbols.Symbol.Visibility.PRIVATE) + names = [to_str(child) for child in tsnode.children + if child.type in ("identifier", "name", "type_name", + "method_name")] + if names: + visibility_map.update({name.lower(): visibility + for name in names}) + elif not any(child.type == "::" for child in tsnode.children): + symtab.default_visibility = visibility + return visibility_map + + def _public_statement_handler(self, tsnode: 'TSNode') -> None: + '''Retain access-id forms that PSyIR cannot represent.''' + if any(child.type in ("operator", "assignment") + for child in tsnode.children): + raise NotImplementedError( + "Named operator and assignment access rules are not " + "supported") + + def _private_statement_handler(self, tsnode: 'TSNode') -> None: + '''Retain access-id forms that PSyIR cannot represent.''' + self._public_statement_handler(tsnode) + + def _apply_visibility( + self, visibility_map: dict[str, symbols.Symbol.Visibility] + ): + '''Apply name-specific access rules after a scope is populated. + + Fortran access statements apply irrespective of source order. Delaying + this step until all declarations and contained routines have been + processed means the map remains local to its scope handler. + + :param visibility_map: explicit visibility indexed by symbol name. + ''' + symtab = self._current_scope + for name, visibility in visibility_map.items(): + # An unsupported specification may survive only as a CodeBlock and + # therefore have no symbol to update. + if name in symtab: + symtab.lookup( + name, scope_limit=symtab.node).visibility = visibility + + def _use_statement_handler( + self, tsnode: 'TSNode' + ) -> None: + '''Translate a USE statement into container and imported symbols. + + :param tsnode: use-statement tree-sitter node. + + :raises ValueError: if the module name conflicts with an + existing non-container symbol. + ''' + symtab = self._current_scope + module_node = next( + children_of_type(tsnode, "module_name"), None) + module_name = to_str(module_node) + intrinsic = any(child.type == "intrinsic" for child in tsnode.children) + included = next( + children_of_type(tsnode, "included_items"), None) + wildcard = included is None + try: + container = symtab.lookup(module_name) + except KeyError: + container = symbols.ContainerSymbol( + module_name, wildcard_import=wildcard, + is_intrinsic=intrinsic, + visibility=symtab.default_visibility) + symtab.add(container) + if not isinstance(container, symbols.ContainerSymbol): + raise ValueError( + f"USE module '{module_name}' conflicts with another symbol") + # Multiple USE statements for the same module are cumulative. An + # ONLY list must therefore not undo a wildcard import seen earlier. + container.wildcard_import = container.wildcard_import or wildcard + + import_items = list(included.children) if included else [] + # A rename list without ONLY is represented directly beneath the USE + # statement rather than inside ``included_items``. + import_items.extend( + child for child in tsnode.children + if child.type in ("rename", "use_rename", "use_alias")) + for child in import_items: + if child.type == "identifier": + local_name = to_str(child) + self._add_imported_symbol( + local_name, local_name, container) + elif child.type in ("rename", "use_rename", "use_alias"): + names = [item for item in child.children + if item.type in + ("identifier", "name", "local_name")] + if len(names) == 2: + self._add_imported_symbol( + to_str(names[0]), to_str(names[1]), container) + + def _add_imported_symbol( + self, local_name: str, remote_name: str, + container: symbols.ContainerSymbol + ): + '''Add one symbol imported from a container. + + :param local_name: name used for the symbol in this scope. + :param remote_name: original name in the imported container. + :param container: symbol representing the imported module. + ''' + symtab = self._current_scope + interface = symbols.ImportInterface( + container, orig_name=(remote_name + if remote_name != local_name else None)) + try: + existing = symtab.lookup(local_name) + except KeyError: + symtab.add(symbols.Symbol( + local_name, visibility=symtab.default_visibility, + interface=interface)) + else: + if existing is not container: + existing.interface = interface + + def _derived_type_definition_handler( + self, tsnode: 'TSNode' + ) -> None: + '''Translate a simple Fortran derived-type definition. + + :param tsnode: derived-type-definition tree-sitter node. + + :raises ValueError: if the type name conflicts with an + existing non-datatype symbol. + ''' + symtab = self._current_scope + statement = next( + children_of_type(tsnode, "derived_type_statement"), None) + name_node = next( + children_of_type(statement, "type_name"), None) + name = to_str(name_node) + unsupported = ( + any(child.type == "derived_type_procedures" + for child in tsnode.children) or + any(child.type in ("base_type_specifier", "language_binding") + for child in statement.children) or + any(child.type == "sequence_statement" + for child in tsnode.children)) + datatype = None + if not unsupported: + parent = symtab.node + if not isinstance(parent, nodes.ScopingNode): + raise InternalError( + "A derived type must be translated within a PSyIR scope") + with self._using_temporary_scope(parent): + visibility_map = self._process_access_statements( + tsnode.children) + try: + for declaration in children_of_type( + tsnode, "variable_declaration"): + self._variable_declaration_handler(declaration) + self._apply_visibility(visibility_map) + datatype = symbols.StructureType() + for component in self._current_scope.datasymbols: + datatype.add( + component.name, component.datatype, + component.visibility, + component.initial_value) + except (NotImplementedError, TypeError, ValueError): + datatype = None + if datatype is None: + datatype = self._unsupported_derived_type( + tsnode, statement, name) + + visibility = symtab.default_visibility + access = next( + children_of_type(statement, "access_specifier"), None) + if access: + visibility = (symbols.Symbol.Visibility.PRIVATE + if "private" in to_str(access).lower() else + symbols.Symbol.Visibility.PUBLIC) + try: + existing = symtab.lookup(name) + except KeyError: + symtab.add(symbols.DataTypeSymbol( + name, datatype, visibility=visibility)) + else: + if not isinstance(existing, symbols.DataTypeSymbol): + raise ValueError( + f"Derived type '{name}' conflicts with another symbol") + existing.datatype = datatype + existing.visibility = visibility + + @staticmethod + def _unsupported_derived_type( + tsnode: 'TSNode', statement: 'TSNode', name: str + ) -> symbols.UnsupportedFortranType: + '''Create a backend-compatible unsupported derived-type definition. + + :param tsnode: complete derived-type definition. + :param statement: opening derived-type statement. + :param name: derived-type name. + + :returns: unsupported datatype containing an equivalent definition. + ''' + declaration = to_str(tsnode).strip() + statement_text = to_str(statement).strip() + if "::" not in statement_text: + # The backend needs the separator in order to add visibility to + # an unsupported declaration. It is optional in this form of a + # Fortran derived-type statement, so add an equivalent one. + prefix = statement_text[:-len(name)].rstrip() + replacement = f"{prefix} :: {name}" + declaration = replacement + declaration[len(statement_text):] + return symbols.UnsupportedFortranType(declaration) + + def _interface_handler( + self, tsnode: 'TSNode' + ) -> None: + '''Translate a named interface containing procedure declarations. + + :param tsnode: interface tree-sitter node. + + :raises NotImplementedError: if the interface form or a member is + unsupported. + ''' + symtab = self._current_scope + statement = next( + children_of_type(tsnode, "interface_statement"), None) + name_node = next(children_of_type(statement, "name"), None) + if not name_node: + raise NotImplementedError( + "Abstract and operator interfaces are not supported") + name = to_str(name_node) + routines = [] + for procedure in children_of_type(tsnode, "procedure_statement"): + from_container = "module" in [ + child.type for child in procedure.children[0].children] + for method in children_of_type(procedure, "method_name"): + routine_name = to_str(method) + try: + routine = symtab.lookup(routine_name) + except KeyError: + routine = symbols.RoutineSymbol(routine_name) + symtab.add(routine) + if not isinstance(routine, symbols.RoutineSymbol): + raise NotImplementedError( + f"Interface member '{routine_name}' is not a routine") + routines.append((routine, from_container)) + if not routines: + raise NotImplementedError( + "Interfaces containing routine bodies are not supported") + symtab.add(symbols.GenericInterfaceSymbol( + name, routines, visibility=symtab.default_visibility)) + + def _identifier_handler( + self, tsnode: 'TSNode' + ) -> nodes.Reference: + '''Translate an identifier into a symbol reference. + + :param tsnode: identifier tree-sitter node. + + :returns: PSyIR Reference to the resolved symbol. + ''' + symtab = self._current_scope + name = to_str(tsnode).lower() + try: + symbol = self._current_scope.lookup(name) + except KeyError: + symbol = symbols.DataSymbol( + name, symbols.UnresolvedType(), + interface=symbols.UnresolvedInterface()) + symtab.add(symbol) + return nodes.Reference(symbol) + + def _parenthesized_expression_handler( + self, tsnode: 'TSNode' + ): + '''Discard parentheses while preserving the enclosed expression. + + :param tsnode: parenthesized-expression tree-sitter node. + + :returns: translated expression inside the parentheses. + + ''' + content = [child for child in tsnode.children + if child.type not in ("(", ")")] + return self._process_nodes( + content[0], _NodeExpectation.EXPRESSION) + + def _operation( + self, tsnode: 'TSNode' + ): + '''Translate a unary or binary operation node. + + :param tsnode: operation tree-sitter node. + + :returns: PSyIR UnaryOperation or BinaryOperation. + + ''' + if len(tsnode.children) == 2: + operator = to_str(tsnode.children[0]).lower() + return nodes.UnaryOperation.create( + self._UNARY_OPERATORS[operator], + self._process_nodes( + tsnode.children[1], _NodeExpectation.EXPRESSION)) + operator = to_str(tsnode.children[1]).lower() + return nodes.BinaryOperation.create( + self._BINARY_OPERATORS[operator], + self._process_nodes( + tsnode.children[0], _NodeExpectation.EXPRESSION), + self._process_nodes( + tsnode.children[2], _NodeExpectation.EXPRESSION)) + + def _call_expression_handler( + self, tsnode: 'TSNode' + ): + '''Translate an array reference, intrinsic, or function call. + + Tree-sitter uses the same syntactic node for all three forms. The + symbol datatype resolves the ambiguity: a declared array produces an + ArrayReference, a recognised intrinsic produces an IntrinsicCall, and + other names produce a Call. + + :param tsnode: call-expression tree-sitter node. + + :returns: PSyIR ArrayReference, IntrinsicCall, StructureReference or + Call. + + :raises NotImplementedError: if the expression cannot be classified + or its argument form is unsupported. + ''' + symtab = self._current_scope + name_node = tsnode.children[0] + if name_node.type == "derived_type_member_expression": + return self._structure_reference( + name_node, + trailing_arguments=next( + children_of_type(tsnode, "argument_list"), None)) + name = to_str(name_node).lower() + argument_list = next( + children_of_type(tsnode, "argument_list"), None) + try: + symbol = self._current_scope.lookup(name) + except KeyError: + symbol = None + + if isinstance(symbol, symbols.DataSymbol) and isinstance( + symbol.datatype, symbols.ArrayType): + indices = self._arguments( + argument_list, array_symbol=symbol) + if any(isinstance(arg, tuple) for arg in indices): + raise NotImplementedError( + "Named subscripts are not supported") + return nodes.ArrayReference.create(symbol, indices) + + arguments = self._arguments(argument_list) + + # Explicit imports initially create a bare Symbol. Once it is used as + # a function, specialise it in the same way as for a CALL statement. + # pylint: disable=unidiomatic-typecheck + if type(symbol) is symbols.Symbol: + symbol.specialise(symbols.RoutineSymbol) + + # Resolve declared routines (including generic interfaces) before + # considering intrinsic names since Fortran permits an intrinsic to + # be shadowed by a user procedure. + if isinstance(symbol, symbols.RoutineSymbol): + return nodes.Call.create(symbol, arguments) + + intrinsic = next( + (item for item in nodes.IntrinsicCall.Intrinsic + if item.name.lower() == name), None) + if intrinsic: + try: + return nodes.IntrinsicCall.create(intrinsic, arguments) + except (TypeError, ValueError): + # Preserve parsed intrinsics even if the current PSyIR + # signature validation is stricter than the grammar. raise NotImplementedError( - f"Module has an unsupported '{child.type}' node") + f"Unsupported argument form for intrinsic '{name}'" + ) from None - if not implicit_statement: + if symbol is not None and not isinstance( + symbol, symbols.DataTypeSymbol): raise NotImplementedError( - "Modules that allow implicit variables are not supported") - container = nodes.Container(to_str(module_name) if module_name else "") - self._psyir_cursor = container - if internal_proc: - container.children.extend(self.process_nodes(internal_proc)) - return container + f"'{name}(...)' cannot be classified as an array or call") + symbol = symbols.RoutineSymbol(name) + if name not in symtab: + symtab.add(symbol) + return nodes.Call.create(symbol, arguments) + + def _arguments( + self, tsnode: Optional['TSNode'], + array_symbol: Optional[symbols.DataSymbol] = None + ) -> list: + '''Translate an argument or array-subscript list. + + :param tsnode: argument-list tree-sitter node, or ``None``. + :param array_symbol: array being indexed when ranges are permitted. + + :returns: positional expressions and ``(name, expression)`` tuples. + + :raises NotImplementedError: if a range occurs outside an array + reference. + ''' + if tsnode is None: + return [] + result = [] + dimension = 0 + for child in tsnode.children: + if child.type in ("(", ")", ","): + continue + dimension += 1 + if child.type == "keyword_argument": + key = to_str(child.children[0]) + result.append((key, self._process_nodes( + child.children[-1], _NodeExpectation.EXPRESSION))) + elif child.type == "extent_specifier": + if array_symbol is None: + raise NotImplementedError( + "Ranges are only supported in array references") + result.append(self._range( + child, array_symbol, dimension)) + else: + result.append(self._process_nodes( + child, _NodeExpectation.EXPRESSION)) + return result + + def _range( + self, tsnode: 'TSNode', symbol: symbols.DataSymbol, dimension: int + ) -> nodes.Range: + '''Translate an array-section triplet. + + Omitted bounds are made explicit with LBOUND and UBOUND calls because + a PSyIR Range always has start, stop and step children. + + :param tsnode: extent-specifier tree-sitter node. + :param symbol: DataSymbol for the indexed array. + :param dimension: one-based array dimension being indexed. + + :returns: PSyIR Range with explicit bounds. + + ''' + before, after, _ = self._split_extent(tsnode) + # Preserve the field separated by a second colon. In particular, an + # absent upper bound in ``lower::step`` must not cause the step to be + # interpreted as the stop expression. + second_colon = next( + (idx for idx, child in enumerate(after) if child.type == ":"), + None) + if second_colon is None: + upper = after + step_nodes = [] + else: + upper = after[:second_colon] + step_nodes = after[second_colon + 1:] + dim = nodes.Literal(str(dimension), + symbols.ScalarType.integer_type()) + start = (self._process_nodes( + before[0], _NodeExpectation.EXPRESSION) if before else + nodes.IntrinsicCall.create( + nodes.IntrinsicCall.Intrinsic.LBOUND, + [nodes.Reference(symbol), ("dim", dim.copy())])) + stop = (self._process_nodes( + upper[0], _NodeExpectation.EXPRESSION) if upper else + nodes.IntrinsicCall.create( + nodes.IntrinsicCall.Intrinsic.UBOUND, + [nodes.Reference(symbol), ("dim", dim.copy())])) + step = (self._process_nodes( + step_nodes[0], _NodeExpectation.EXPRESSION) + if step_nodes else None) + return nodes.Range.create(start, stop, step) + + def _derived_type_member_expression_handler( + self, tsnode: 'TSNode' + ): + '''Translate a structure-component reference. + + :param tsnode: derived-type-member-expression tree-sitter node. + + :returns: PSyIR structure reference. + ''' + return self._structure_reference(tsnode) + + def _structure_reference( + self, tsnode: 'TSNode', + trailing_arguments: Optional['TSNode'] = None + ): + '''Translate nested and indexed structure-component references. + + :param tsnode: tree-sitter node describing the structure access. + :param trailing_arguments: optional indices attached outside + ``tsnode`` by a wrapping call-expression node. + + :returns: StructureReference or ArrayOfStructuresReference. + + :raises NotImplementedError: if the access or base symbol is + unsupported. + ''' + symtab = self._current_scope + name, indices, members = self._decompose_structure(tsnode) + if trailing_arguments: + arguments = self._arguments(trailing_arguments) + if not members or any(isinstance(arg, tuple) + for arg in arguments): + raise NotImplementedError( + "Unsupported structure member array access") + members[-1] = (members[-1], arguments) + try: + symbol = self._current_scope.lookup(name) + except KeyError: + symbol = symbols.DataSymbol( + name, symbols.UnresolvedType(), + interface=symbols.UnresolvedInterface()) + symtab.add(symbol) + if not isinstance(symbol, symbols.DataSymbol): + raise NotImplementedError( + "A structure base must be a data symbol") + if indices: + return nodes.ArrayOfStructuresReference.create( + symbol, indices, members) + return nodes.StructureReference.create(symbol, members) + + def _decompose_structure( + self, tsnode: 'TSNode' + ) -> tuple[str, list, list]: + '''Return base name, base indices and member descriptors. + + Tree-sitter nests call-expression and member-expression nodes for + accesses such as ``items(i)%vector(2)%x``. Flattening that syntax into + the descriptor format expected by PSyIR keeps node construction out of + this recursive routine. + + :param tsnode: identifier, call or member-expression tree-sitter node. + + :returns: base name, base indices and PSyIR member descriptors. + + :raises NotImplementedError: if the access shape is unsupported. + ''' + if tsnode.type == "identifier": + return to_str(tsnode).lower(), [], [] + if tsnode.type == "call_expression": + base = tsnode.children[0] + name, indices, members = self._decompose_structure(base) + arguments = self._arguments( + next(children_of_type(tsnode, "argument_list"), None)) + if any(isinstance(arg, tuple) for arg in arguments): + raise NotImplementedError( + "Named arguments in structure accesses are not supported") + if members: + members[-1] = (members[-1], arguments) + else: + indices = arguments + return name, indices, members + name, indices, members = self._decompose_structure( + tsnode.children[0]) + member = next(children_of_type(tsnode, "type_member"), None) + members.append(to_str(member).lower()) + return name, indices, members + + def _array_literal_handler( + self, tsnode: 'TSNode' + ): + '''Translate a simple array constructor. + + :param tsnode: array-literal tree-sitter node. + + :returns: PSyIR ArrayConstructor. + + :raises NotImplementedError: for an implied-DO constructor. + ''' + if next(children_of_type( + tsnode, "implied_do_loop_expression"), None): + raise NotImplementedError( + "Array constructors with implied-DO loops are not supported") + if any(child.type in ("intrinsic_type", "derived_type") + for child in tsnode.children): + raise NotImplementedError( + "Typed array constructors are not supported") + elems = [self._process_nodes(child, _NodeExpectation.EXPRESSION) + for child in tsnode.children + if child.type not in ("[", "]", "(/", "/)", ",")] + return nodes.ArrayConstructor.create(elems) + + def _comment_handler( + self, tsnode: 'TSNode' + ) -> None: + '''Ignore comments. + + :param tsnode: comment tree-sitter node. + + ''' + del tsnode + + def _assignment_statement_handler( + self, tsnode: 'TSNode' + ) -> nodes.Assignment: + '''Translate an intrinsic assignment. + + :param tsnode: assignment-statement tree-sitter node. + + :returns: PSyIR Assignment. + + ''' + return nodes.Assignment.create( + self._process_nodes( + tsnode.children[0], _NodeExpectation.EXPRESSION), + self._process_nodes( + tsnode.children[2], _NodeExpectation.EXPRESSION)) + + def _pointer_association_statement_handler( + self, tsnode: 'TSNode' + ) -> nodes.Assignment: + '''Translate a simple pointer assignment. + + :param tsnode: pointer-association-statement tree-sitter node. + + :returns: pointer-annotated PSyIR Assignment. + + ''' + assignment = nodes.Assignment(is_pointer=True) + assignment.children = [ + self._process_nodes( + tsnode.children[0], _NodeExpectation.EXPRESSION), + self._process_nodes( + tsnode.children[2], _NodeExpectation.EXPRESSION)] + return assignment + + def _subroutine_call_handler( + self, tsnode: 'TSNode' + ): + '''Translate a CALL statement. + + :param tsnode: subroutine-call tree-sitter node. + + :returns: PSyIR Call. + + :raises NotImplementedError: if the called object is unsupported. + ''' + name_node = next((child for child in tsnode.children + if child.type == "identifier"), None) + if not name_node: + raise NotImplementedError( + "Calls through type-bound procedures are not supported") + symtab = self._current_scope + name = to_str(name_node).lower() + try: + symbol = self._current_scope.lookup(name) + except KeyError: + symbol = symbols.RoutineSymbol(name, datatype=symbols.NoType()) + symtab.add(symbol) + # As above, only a bare forward-reference Symbol may be specialised. + # pylint: disable=unidiomatic-typecheck + if type(symbol) is symbols.Symbol: + symbol.specialise(symbols.RoutineSymbol, + datatype=symbols.NoType()) + if not isinstance(symbol, symbols.RoutineSymbol): + raise NotImplementedError( + f"Called object '{name}' is not a routine") + args = self._arguments(next( + children_of_type(tsnode, "argument_list"), None)) + return nodes.Call.create(symbol, args) + + def _keyword_statement_handler( + self, tsnode: 'TSNode' + ): + '''Translate a no-argument keyword statement. + + :param tsnode: keyword-statement tree-sitter node. + + :returns: PSyIR Return for a RETURN statement. + + :raises NotImplementedError: if the keyword has no PSyIR node. + ''' + keyword = tsnode.children[0].type + if keyword == "return": + return nodes.Return() + raise NotImplementedError( + f"Fortran '{keyword.upper()}' has no PSyIR node") + + def _if_statement_handler( + self, tsnode: 'TSNode' + ) -> nodes.IfBlock: + '''Translate block and single-line IF statements. + + :param tsnode: if-statement tree-sitter node. + + :returns: root PSyIR IfBlock. + + ''' + condition_node = next(children_of_type( + tsnode, "parenthesized_expression"), None) + structural = { + "if", "parenthesized_expression", "then", + "end_if_statement", "else_clause", "elseif_clause" + } + body_nodes = [child for child in tsnode.children + if child.type not in structural] + else_clause = next(children_of_type(tsnode, "else_clause"), None) + else_ifs = list(children_of_type(tsnode, "elseif_clause")) + annotations = [] + if not next(children_of_type( + tsnode, "end_if_statement"), None): + annotations.append("was_single_stmt") + if_body = self._process_nodes(body_nodes, _NodeExpectation.LIST) + else_body = None + if else_clause: + else_body = self._process_nodes( + [child for child in else_clause.children + if child.type != "else"], _NodeExpectation.LIST) + for else_if in reversed(else_ifs): + else_body = [self._if_clause(else_if, else_body)] + result = nodes.IfBlock.create( + self._process_nodes(condition_node, _NodeExpectation.EXPRESSION), + if_body, else_body) + result.annotations.extend(annotations) + return result + + def _if_clause( + self, tsnode: 'TSNode', + final_else: Optional[list[nodes.Node]] = None + ) -> nodes.IfBlock: + '''Translate an ELSE IF clause recursively. + + :param tsnode: elseif-clause tree-sitter node. + :param final_else: PSyIR statements for a following ELSE clause. + + :returns: annotated PSyIR IfBlock. + ''' + condition = next(children_of_type( + tsnode, "parenthesized_expression"), None) + structural = {"else", "if", "parenthesized_expression", "then", + "else_clause", "elseif_clause"} + body = self._process_nodes( + [child for child in tsnode.children + if child.type not in structural], _NodeExpectation.LIST) + trailing = next( + children_of_type(tsnode, "elseif_clause"), None) + else_clause = next(children_of_type(tsnode, "else_clause"), None) + otherwise = ( + [self._if_clause(trailing, final_else)] if trailing else + self._process_nodes( + [child for child in + (else_clause.children if else_clause else []) + if child.type != "else"], _NodeExpectation.LIST) + or final_else) + result = nodes.IfBlock.create( + self._process_nodes(condition, _NodeExpectation.EXPRESSION), + body, otherwise) + result.annotations.append("was_elseif") + return result + + def _do_loop_handler( + self, tsnode: 'TSNode' + ): + '''Translate counted, conditional and unconditional DO loops. + + :param tsnode: do-loop tree-sitter node. + + :returns: PSyIR Loop for counted DO, otherwise WhileLoop. + + :raises NotImplementedError: if counted-loop control is unsupported. + ''' + statement = next(children_of_type(tsnode, "do_statement"), None) + if next(children_of_type( + statement, "concurrent_statement"), None): + raise NotImplementedError("DO CONCURRENT is not supported") + control = next(children_of_type( + statement, "loop_control_expression"), None) + while_node = next( + children_of_type(statement, "while_statement"), None) + body = self._process_nodes( + [child for child in tsnode.children + if child.type not in ("do_statement", + "end_do_loop_statement")], + _NodeExpectation.LIST) + if control: + parts = [child for child in control.children + if child.type not in ("=", ",")] + variable_ref = self._identifier_handler(parts[0]) + variable = variable_ref.symbol + if not isinstance(variable, symbols.DataSymbol): + raise NotImplementedError( + "A DO variable must be a data symbol") + if not isinstance(variable.datatype, symbols.ScalarType): + if isinstance(variable.datatype, symbols.UnresolvedType): + variable.datatype = symbols.ScalarType.integer_type() + else: + raise NotImplementedError( + "A DO variable must be a scalar integer") + step = (self._process_nodes( + parts[3], _NodeExpectation.EXPRESSION) if len(parts) == 4 + else nodes.Literal( + "1", symbols.ScalarType.integer_type())) + return nodes.Loop.create( + variable, + self._process_nodes(parts[1], _NodeExpectation.EXPRESSION), + self._process_nodes(parts[2], _NodeExpectation.EXPRESSION), + step, body) + if while_node: + condition = next(children_of_type( + while_node, "parenthesized_expression"), None) + return nodes.WhileLoop.create( + self._process_nodes(condition, _NodeExpectation.EXPRESSION), + body) + result = nodes.WhileLoop.create( + nodes.Literal("true", symbols.ScalarType.boolean_type()), body) + result.annotations.append("was_unconditional") + return result + + def _where_statement_handler( + self, tsnode: 'TSNode' + ) -> nodes.IfBlock: + '''Translate block and single-statement WHERE constructs. + + :param tsnode: where-statement tree-sitter node. + + :returns: annotated PSyIR IfBlock. + ''' + condition = next(children_of_type( + tsnode, "parenthesized_expression"), None) + structural = {"where", "parenthesized_expression", + "elsewhere_clause", "end_where_statement"} + body = self._process_nodes( + [child for child in tsnode.children + if child.type not in structural], _NodeExpectation.LIST) + elsewhere_clauses = list(children_of_type( + tsnode, "elsewhere_clause")) + other = None + # Masked ELSEWHERE clauses have ELSE-IF semantics and are represented + # by nested IfBlocks. Constructing the chain backwards makes the + # following clause the else-body of the current masked clause. + for elsewhere in reversed(elsewhere_clauses): + mask = next(children_of_type( + elsewhere, "parenthesized_expression"), None) + clause_body = self._process_nodes( + [child for child in elsewhere.children + if child.type not in + ("elsewhere", "parenthesized_expression")], + _NodeExpectation.LIST) + if mask: + nested = nodes.IfBlock.create( + self._process_nodes( + mask, _NodeExpectation.EXPRESSION), + clause_body, other) + nested.annotations.append("was_where") + other = [nested] + else: + if other is not None: + raise NotImplementedError( + "An unmasked ELSEWHERE must be the final clause") + other = clause_body + result = nodes.IfBlock.create( + self._process_nodes(condition, _NodeExpectation.EXPRESSION), + body, other) + result.annotations.extend( + ["was_where"] if next(children_of_type( + tsnode, "end_where_statement"), None) else + ["was_where", "was_single_stmt"]) + return result + + def _select_case_statement_handler( + self, tsnode: 'TSNode' + ): + '''Translate SELECT CASE into a nested annotated IF tree. + + Each non-default CASE becomes an IfBlock in the preceding block's + else-body. CASE DEFAULT becomes the final else-body. + + :param tsnode: select-case-statement tree-sitter node. + + :returns: root annotated PSyIR IfBlock. + + :raises NotImplementedError: if no conditional CASE can be produced. + ''' + selector_syntax = next( + children_of_type(tsnode, "selector"), None) + selector_node = next( + children_of_type(selector_syntax, "identifier"), None) + if selector_node is None: + selector = self._process_nodes( + [child for child in + selector_syntax.children + if child.type not in ("(", ")")][0], + _NodeExpectation.EXPRESSION) + else: + selector = self._process_nodes( + selector_node, _NodeExpectation.EXPRESSION) + if selector.walk(nodes.Call) or isinstance(selector, nodes.CodeBlock): + raise NotImplementedError( + "SELECT CASE selectors containing calls are not supported") + cases = list(children_of_type(tsnode, "case_statement")) + default_body = None + normal = [] + for case in cases: + if next(children_of_type(case, "default"), None): + default_body = self._process_nodes( + [child for child in case.children + if child.type not in ("case", "default")], + _NodeExpectation.LIST) + else: + values = next(children_of_type( + case, "case_value_range_list"), None) + structural = {"case", "(", ")", "case_value_range_list"} + body = self._process_nodes( + [child for child in case.children + if child.type not in structural], _NodeExpectation.LIST) + normal.append((values, body)) + current = default_body + for values, body in reversed(normal): + condition = self._case_condition(selector, values) + block = nodes.IfBlock.create( + condition, body, current) + block.annotations.append("was_case") + current = [block] + if normal and current and len(current) == 1: + return current[0] + raise NotImplementedError( + "SELECT CASE with only a default clause has no PSyIR equivalent") + + def _case_condition( + self, selector, values: 'TSNode' + ): + '''Build a condition for one CASE value/range list. + + :param selector: translated SELECT CASE selector expression. + :param values: case-value-range-list tree-sitter node. + + :returns: PSyIR condition combining values with OR and range bounds + with AND. + ''' + conditions = [] + for child in values.children: + if child.type == ",": + continue + if child.type == "extent_specifier": + before, after, _ = self._split_extent(child) + parts = [] + if before: + parts.append(nodes.BinaryOperation.create( + nodes.BinaryOperation.Operator.GE, selector.copy(), + self._process_nodes( + before[0], _NodeExpectation.EXPRESSION))) + if after: + parts.append(nodes.BinaryOperation.create( + nodes.BinaryOperation.Operator.LE, selector.copy(), + self._process_nodes( + after[0], _NodeExpectation.EXPRESSION))) + condition = parts[0] if len(parts) == 1 else ( + nodes.BinaryOperation.create( + nodes.BinaryOperation.Operator.AND, + parts[0], parts[1])) + else: + condition = nodes.BinaryOperation.create( + nodes.BinaryOperation.Operator.EQ, selector.copy(), + self._process_nodes( + child, _NodeExpectation.EXPRESSION)) + conditions.append(condition) + result = conditions[0] + for condition in conditions[1:]: + result = nodes.BinaryOperation.create( + nodes.BinaryOperation.Operator.OR, result, condition) + return result + + def _memory_statement( + self, tsnode: 'TSNode' + ): + '''Translate operands of allocation-related statements. + + ALLOCATE shape specifications become ArrayReference indices whose + Range children retain the requested lower and upper bounds. + + :param tsnode: allocation-related statement tree-sitter node. + :returns: PSyIR IntrinsicCall. + + :raises NotImplementedError: if an object, bound or option is + unsupported. + ''' + intrinsic = { + "allocate_statement": nodes.IntrinsicCall.Intrinsic.ALLOCATE, + "deallocate_statement": nodes.IntrinsicCall.Intrinsic.DEALLOCATE, + "nullify_statement": nodes.IntrinsicCall.Intrinsic.NULLIFY, + }[tsnode.type] + args = [] + for child in tsnode.children: + if child.type in ( + "allocate", "deallocate", "nullify", "(", ")", ","): + continue + if child.type == "keyword_argument": + args.append((to_str(child.children[0]), + self._process_nodes( + child.children[-1], + _NodeExpectation.EXPRESSION))) + elif child.type == "sized_allocation": + args.append(self._allocation_reference(child)) + else: + args.append(self._process_nodes( + child, _NodeExpectation.EXPRESSION)) + try: + return nodes.IntrinsicCall.create(intrinsic, args) + except (TypeError, ValueError): + raise NotImplementedError( + f"Unsupported operands for {intrinsic.name}") from None + + def _allocation_reference( + self, tsnode: 'TSNode' + ) -> nodes.ArrayReference: + '''Translate an ALLOCATE object with explicit shape bounds. + + PSyIR represents the requested allocation shape as ArrayReference + Range indices. This is an allocation request rather than an ordinary + array access, but the representation permits the backend to reproduce + the original bounds. + + :param tsnode: sized-allocation tree-sitter node. + + :returns: ArrayReference containing one Range per allocated dimension. + + :raises NotImplementedError: if the object is not a data symbol. + ''' + ident = next(children_of_type(tsnode, "identifier"), None) + if ident is None: + raise NotImplementedError( + "Allocations of structure components are not supported") + reference = self._identifier_handler(ident) + if not isinstance(reference.symbol, symbols.DataSymbol): + raise NotImplementedError( + "An ALLOCATE object must be a data symbol") + size = next(children_of_type(tsnode, "size"), None) + indices = [ + self._allocation_extent(extent) + for extent in size.children + if extent.type not in ("(", ")", ",")] + return nodes.ArrayReference.create(reference.symbol, indices) + + def _allocation_extent( + self, tsnode: 'TSNode' + ) -> nodes.Range: + '''Translate one requested allocation extent. + + Fortran's ``allocate(a(n))`` is equivalent to ``allocate(a(1:n))``; + the implicit lower bound is therefore made explicit in PSyIR. + + :param tsnode: extent or extent-specifier tree-sitter node. + + :returns: Range containing explicit lower and upper bounds. + + :raises NotImplementedError: if the allocation bound is malformed. + ''' + lower = nodes.Literal( + "1", symbols.ScalarType.integer_type()) + if tsnode.type != "extent_specifier": + return nodes.Range.create( + lower, self._process_nodes( + tsnode, _NodeExpectation.EXPRESSION)) + + before, after, _ = self._split_extent(tsnode) + if before: + lower = self._process_nodes( + before[0], _NodeExpectation.EXPRESSION) + if not after: + raise NotImplementedError( + "Allocation upper bound is required") + return nodes.Range.create( + lower, self._process_nodes( + after[0], _NodeExpectation.EXPRESSION)) diff --git a/src/psyclone/psyir/nodes/codeblock.py b/src/psyclone/psyir/nodes/codeblock.py index faa890b839..c7e7b60aa8 100644 --- a/src/psyclone/psyir/nodes/codeblock.py +++ b/src/psyclone/psyir/nodes/codeblock.py @@ -379,7 +379,9 @@ def get_fortran_lines(self) -> list[str]: ''' output = [] for node in self._parse_tree_nodes: - output.extend(node.tofortran().split("\n")) + output.extend( + node if isinstance(node, str) else + node.tofortran().split("\n")) return output diff --git a/src/psyclone/tests/psyir/frontend/fortran_treesitter_reader/ftr_test.py b/src/psyclone/tests/psyir/frontend/fortran_treesitter_reader/ftr_test.py index c97184fd29..3d074e5cfd 100644 --- a/src/psyclone/tests/psyir/frontend/fortran_treesitter_reader/ftr_test.py +++ b/src/psyclone/tests/psyir/frontend/fortran_treesitter_reader/ftr_test.py @@ -6,17 +6,38 @@ # ----------------------------------------------------------------------------- ''' Performs tests on the treesitter PSyIR front-end ''' - import logging import pytest from tree_sitter import Node as TSNode -from psyclone.psyir.frontend.fortran_treesitter_reader import \ - FortranTreeSitterReader -from psyclone.psyir.nodes import FileContainer, CodeBlock, Container +from psyclone.errors import InternalError +from psyclone.psyir.frontend.fortran_treesitter_reader import ( + FortranTreeSitterReader, _NodeExpectation) +from psyclone.psyir import nodes as psyir_nodes, symbols as psyir_symbols from psyclone.tests.utilities import min_version_3_10 +# TODO #3416: Skip treesitter tests below 3.10 as they're unsupported by +# treesitter. +pytestmark = min_version_3_10 + + +def _first_tsnode(tsnode, node_type): + ''' + :param tsnode: the tree-sitter tree to search. + :param node_type: the type to search. + + :returns: the first tree-sitter node of the requested type. + + ''' + if tsnode.type == node_type: + return tsnode + for child in tsnode.children: + result = _first_tsnode(child, node_type) + if result: + return result + return None + def test_constructor(): ''' Test the constructor and its arguments ''' @@ -41,9 +62,6 @@ def test_constructor(): # TODO #3083: Typecheck arguments -# TODO #3416: Skip treesitter tests below 3.10 as they're unsupported by -# treesitter. -@min_version_3_10 def test_generate_parse_tree(tmpdir_factory, caplog): ''' Test that generate_parse_tree returns treesitter trees or appropriate @@ -90,9 +108,6 @@ def test_generate_parse_tree(tmpdir_factory, caplog): assert isinstance(ptree, TSNode) -# TODO #3416: Skip treesitter tests below 3.10 as they're unsupported by -# treesitter. -@min_version_3_10 def test_generate_psyir(): ''' Test that generate_psyir transforms treesitter parse trees to @@ -109,57 +124,2429 @@ def test_generate_psyir(): end module test """ ptree = processor.generate_parse_tree_from_source(valid_code) - psyir = processor.generate_psyir(ptree) + root = processor.generate_psyir(ptree) - assert isinstance(psyir, FileContainer) - assert isinstance(psyir.children[0], Container) - assert isinstance(psyir.children[0].children[0], CodeBlock) + assert isinstance(root, psyir_nodes.FileContainer) + assert isinstance(root.children[0], psyir_nodes.Container) + assert isinstance(root.children[0].children[0], psyir_nodes.Routine) + assert root.children[0].children[0].name == "mysub" -# TODO #3416: Skip treesitter tests below 3.10 as they're unsupported by -# treesitter. -@min_version_3_10 -def test_codeblock_generation_and_messages(): - ''' - Test that NotImplementedErrors are caught and converted to CodeBlocks - with the appropriate associated comment - ''' +def test_process_node_expectation_errors(): + '''Test defensive validation of dispatcher result expectations.''' + valid_code = """ + subroutine assignment(first, second) + ! This comment produces no PSyIR node. + integer :: first, second + first = second + second = 1 + end subroutine assignment + """ processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + assignment = _first_tsnode(parse_tree, "assignment_statement") + comment = _first_tsnode(parse_tree, "comment") + number = _first_tsnode(parse_tree, "number_literal") - unsupported_code = """ - module test - contains + with pytest.raises(InternalError, match="Only one node was expected"): + processor._process_nodes([], _NodeExpectation.ONE) + with pytest.raises(InternalError, match="A DataNode was expected"): + processor._process_nodes(assignment, _NodeExpectation.EXPRESSION) + with pytest.raises(InternalError, match="Unsupported node expectation"): + processor._process_nodes([], None) + assert processor._process_nodes( + comment, _NodeExpectation.NONE) is None + with pytest.raises(InternalError, match="No node was expected"): + processor._process_nodes(number, _NodeExpectation.NONE) + + +def test_program(): + '''Test a main-program unit.''' + processor = FortranTreeSitterReader() + valid_code = """ + program main + implicit none + end program main + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + assert isinstance(routine, psyir_nodes.Routine) + assert routine.is_program + assert routine.name == "main" + + +def test_routines_nodes(): + ''' Test that routine nodes create a node and delcare a symbol ''' + processor = FortranTreeSitterReader() + + valid_code = """ subroutine mysub() end subroutine - end module test + subroutine mysub2() + end subroutine mysub2 """ - ptree = processor.generate_parse_tree_from_source(unsupported_code) - psyir = processor.generate_psyir(ptree) + ptree = processor.generate_parse_tree_from_source(valid_code) + root = processor.generate_psyir(ptree) - assert isinstance(psyir, FileContainer) - assert isinstance(psyir.children[0], CodeBlock) - expected = ( - "PSyclone CodeBlock (unsupported code) reason:\n" - "- Modules that allow implicit variables are not supported" - ) - assert psyir.children[0].preceding_comment == expected + # Check the tree is as expected + assert len(root.children) == 2 + assert isinstance(root.children[0], psyir_nodes.Routine) + assert root.children[0].name == "mysub" + assert isinstance(root.children[1], psyir_nodes.Routine) + assert root.children[1].name == "mysub2" - unsupported_code = """ - module test - implicit none - integer :: a + # Check that the symbols have been added to the symbol table + assert len(root.symbol_table.symbols) == 2 + rsymbol1 = root.symbol_table.lookup("mysub") + rsymbol2 = root.symbol_table.lookup("mysub2") + assert root.children[0].symbol is rsymbol1 + assert root.children[1].symbol is rsymbol2 + assert isinstance(rsymbol1, psyir_symbols.RoutineSymbol) + assert isinstance(rsymbol2, psyir_symbols.RoutineSymbol) + + +def test_implicitly_declared_argument_falls_back(): + '''A valid implicitly typed argument is preserved in a procedure + CodeBlock because PSyIR cannot declare its type safely. + ''' + valid_code = """ + subroutine implicit_argument(value) + value = value + 1.0 + end subroutine implicit_argument + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + codeblock = root.children[0] + + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "Implicit declaration of 'value'" in codeblock.preceding_comment + + +def test_routine_symbol_association(): + '''Test that a contained routine resolves a symbol from its parent.''' + processor = FortranTreeSitterReader() + valid_code = """ + module host + implicit none + integer :: count contains - subroutine mysub() - end subroutine - end module test + subroutine work() + count = count + 1 + end subroutine work + end module host """ - ptree = processor.generate_parse_tree_from_source(unsupported_code) - psyir = processor.generate_psyir(ptree) + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + container = root.children[0] + routine = container.children[0] + count = container.symbol_table.lookup("count") + assert "count" not in routine.symbol_table + assert [ref.symbol for ref in routine.walk(psyir_nodes.Reference)] == [ + count, count] - assert isinstance(psyir, FileContainer) - assert isinstance(psyir.children[0], CodeBlock) - expected = ( - "PSyclone CodeBlock (unsupported code) reason:\n" - "- Module has an unsupported 'variable_declaration' node" - ) - assert psyir.children[0].preceding_comment == expected + +def test_function_result(): + '''Test a named function-result symbol.''' + processor = FortranTreeSitterReader() + valid_code = """ + real function square(value) result(answer) + real :: value + answer = value * value + end function square + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + assert routine.return_symbol.name == "answer" + assert routine.return_symbol.datatype == \ + psyir_symbols.ScalarType.real_type() + + +def test_function_return_type_variants(): + '''Test different types of expressing return types.''' + valid_code = """ + real function signature_type() + end function + function inner_type() + integer :: inner_type + end function inner_type + complex function unsupported() + end function unsupported + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + assert root.children[0].return_symbol.name == "signature_type" + assert (root.children[0].return_symbol.datatype == + psyir_symbols.ScalarType.real_type()) + + assert root.children[1].return_symbol.name == "inner_type" + assert (root.children[1].return_symbol.datatype == + psyir_symbols.ScalarType.integer_type()) + + assert isinstance(root.children[2], psyir_nodes.CodeBlock) + + +def test_argument_order(): + '''Test the order of routine arguments.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine update(first, second) + real :: first, second + end subroutine update + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + assert [symbol.name for symbol in table.argument_list] == [ + "first", "second"] + + +@pytest.mark.parametrize("intent,access", [ + ("in", psyir_symbols.ArgumentInterface.Access.READ), + ("out", psyir_symbols.ArgumentInterface.Access.WRITE), + ("inout", psyir_symbols.ArgumentInterface.Access.READWRITE), +]) +def test_argument_intent(intent, access): + '''Test an INTENT attribute on a routine argument.''' + processor = FortranTreeSitterReader() + valid_code = f""" + subroutine update(value) + real, intent({intent}) :: value + end subroutine update + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + value = root.children[0].symbol_table.lookup("value") + assert value.interface.access == access + + +def test_pure_function(): + '''Test the PURE function qualifier.''' + processor = FortranTreeSitterReader() + valid_code = """ + pure real function identity(value) + real :: value + identity = value + end function identity + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + assert root.children[0].symbol.is_pure is True + + +def test_elemental_function(): + '''Test the ELEMENTAL function qualifier.''' + processor = FortranTreeSitterReader() + valid_code = """ + elemental real function identity(value) + real :: value + identity = value + end function identity + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + assert root.children[0].symbol.is_elemental is True + assert root.children[0].symbol.is_pure is True + + +def test_recursive_qualifier(): + '''An explicit RECURSIVE prefix is retained on the Routine.''' + valid_code = """ + recursive subroutine recurse() + end subroutine recurse + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + assert root.children[0].is_recursive is True + + +def test_declarations(): + ''' Test simple declarations ''' + processor = FortranTreeSitterReader() + + valid_code = """ + module test + implicit none + integer :: a + real :: b + end module + """ + ptree = processor.generate_parse_tree_from_source(valid_code) + root = processor.generate_psyir(ptree) + module = root.children[0] + + # Declarations do not add children nodes + assert len(module.children) == 0 + + # Check that the symbols have been added to the symbol table + assert len(module.symbol_table.symbols) == 2 + assert "a" in module.symbol_table + assert "b" in module.symbol_table + + +def test_forward_reference_completed_by_parameter_declaration(): + '''A named constant declaration completes a DataSymbol first created by + its use in an earlier array bound. + ''' + valid_code = """ + subroutine declarations() + integer :: values(extent) + integer, parameter :: extent = 10 + end subroutine declarations + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + extent = table.lookup("extent") + + assert extent.is_constant + assert extent.initial_value.value == "10" + assert isinstance(extent.interface, psyir_symbols.StaticInterface) + assert table.lookup("values").datatype.shape[0].upper.symbol is extent + + +def test_unsupported_module_specifications_are_preserved(): + '''Unsupported module specification statements become symbols with + UnsupportedFortranType + ''' + valid_code = """ + module specifications + integer :: value + save + common /block/ value + namelist /group/ value + end module specifications + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + num_of_unsupported = 0 + for symbol in root.children[0].symbol_table.symbols: + if isinstance(symbol.datatype, psyir_symbols.UnsupportedFortranType): + num_of_unsupported += 1 + # Each have a placeholder unsupported name and the correc type_text + if symbol.name == "PSYCLONE_UNSUPPORTED": + symbol.datatype.type_text == "save" + elif symbol.name == "PSYCLONE_UNSUPPORTED_1": + symbol.datatype.type_text == "common /block/ value" + elif symbol.name == "PSYCLONE_UNSUPPORTED_2": + symbol.datatype.type_text == "namelist /group/ value" + assert num_of_unsupported == 3 + + +def test_parameter_declaration(): + '''Test a named constant declaration.''' + processor = FortranTreeSitterReader() + valid_code = """ + program main + implicit none + integer, parameter :: count = 4 + end program main + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + count = root.children[0].symbol_table.lookup("count") + assert count.is_constant + assert count.initial_value.value == "4" + + +def test_save_attribute(): + '''Test the SAVE declaration attribute.''' + processor = FortranTreeSitterReader() + valid_code = """ + module declarations + implicit none + double precision, save :: accumulator + end module declarations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + accumulator = root.children[0].symbol_table.lookup("accumulator") + assert accumulator.datatype == \ + psyir_symbols.ScalarType.real_double_type() + assert isinstance(accumulator.interface, psyir_symbols.StaticInterface) + + +def test_initialized_local_has_static_interface(): + '''Fortran initialization implies SAVE for a local variable.''' + valid_code = """ + subroutine initialise() + integer :: value = 1 + end subroutine initialise + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + value = root.children[0].symbol_table.lookup("value") + + assert isinstance(value.interface, psyir_symbols.StaticInterface) + + +@pytest.mark.parametrize("qualifier", ["pointer", "protected"]) +def test_unsupported_qualifier_datatype(qualifier): + '''Test entity-specific unsupported declaration qualifiers, including + those that are not in a predefined list. + ''' + processor = FortranTreeSitterReader() + valid_code = f""" + module declarations + implicit none + integer, {qualifier} :: first, second + end module declarations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + for name in ("first", "second"): + datatype = table.lookup(name).datatype + assert isinstance(datatype, psyir_symbols.UnsupportedFortranType) + assert datatype.declaration == f"integer, {qualifier} :: {name}" + + +def test_unsupported_complex_datatype(): + '''Test the unsupported complex datatype.''' + processor = FortranTreeSitterReader() + valid_code = """ + module declarations + implicit none + complex :: coefficient + end module declarations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + coefficient = root.children[0].symbol_table.lookup("coefficient") + assert isinstance(coefficient.datatype, + psyir_symbols.UnsupportedFortranType) + assert coefficient.datatype.declaration == "complex :: coefficient" + + +def test_class_declaration_is_unsupported(): + '''Test that a polymorphic declaration uses the unsupported fallback.''' + valid_code = """ + subroutine polymorphic(value) + class(item) :: value + end subroutine polymorphic + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + assert isinstance(root.children[0].symbol_table.lookup("value").datatype, + psyir_symbols.UnsupportedFortranType) + + +def test_unsupported_initialisation_is_entity_specific(): + '''Test that one unsupported initializer does not affect its sibling.''' + processor = FortranTreeSitterReader() + valid_code = """ + module declarations + implicit none + integer :: first = [(i, i=1,2)], second = 2 + end module declarations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + first = table.lookup("first") + second = table.lookup("second") + assert isinstance(first.datatype, psyir_symbols.ScalarType) + assert isinstance(first.initial_value, psyir_nodes.CodeBlock) + assert first.initial_value.structure == \ + psyir_nodes.CodeBlock.Structure.EXPRESSION + assert isinstance(second.datatype, psyir_symbols.ScalarType) + assert second.initial_value.value == "2" + + +def test_unsupported_initializer_translation(monkeypatch): + '''Test the declaration fallback if expression processing itself fails.''' + valid_code = """ + module declarations + integer :: value = 1 + end module declarations + """ + processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + original = processor._process_nodes + + def unsupported_number(tsnodes, expect): + '''Reject the initializer while processing everything else normally.''' + if (getattr(tsnodes, "type", None) == "number_literal" and + expect is _NodeExpectation.EXPRESSION): + raise NotImplementedError("unsupported test initializer") + return original(tsnodes, expect) + + monkeypatch.setattr(processor, "_process_nodes", unsupported_number) + root = processor.generate_psyir(parse_tree) + + assert isinstance(root.children[0].symbol_table.lookup("value").datatype, + psyir_symbols.UnsupportedFortranType) + + +@pytest.mark.parametrize("fortran_type,intrinsic,kind", [ + ("integer", psyir_symbols.ScalarType.Intrinsic.INTEGER, None), + ("integer(kind=4)", psyir_symbols.ScalarType.Intrinsic.INTEGER, "4"), + ("integer(8)", psyir_symbols.ScalarType.Intrinsic.INTEGER, "8"), + ("real", psyir_symbols.ScalarType.Intrinsic.REAL, None), + ("real(4)", psyir_symbols.ScalarType.Intrinsic.REAL, "4"), + ("real(kind=8)", psyir_symbols.ScalarType.Intrinsic.REAL, "8"), + ("logical", psyir_symbols.ScalarType.Intrinsic.BOOLEAN, None), + ("character", psyir_symbols.ScalarType.Intrinsic.CHARACTER, None), +]) +def test_declarations_datatypes(fortran_type, intrinsic, kind): + ''' Test base declaration datatypes ''' + processor = FortranTreeSitterReader() + + valid_code = f""" + module test + implicit none + {fortran_type} :: a + end module + """ + ptree = processor.generate_parse_tree_from_source(valid_code) + root = processor.generate_psyir(ptree) + module = root.children[0] + datatype = module.symbol_table.lookup("a").datatype + assert datatype.intrinsic == intrinsic + if kind: + assert isinstance(datatype.precision, psyir_nodes.Literal) + assert datatype.precision.value == kind + else: + assert datatype.precision == \ + psyir_symbols.ScalarType.Precision.UNDEFINED + + +def test_datatype_kind_variants(): + '''Test symbolic, literal and unsupported kinds.''' + valid_code = """ + subroutine declarations() + integer, parameter :: named_kind = 4 + integer(named_kind) :: symbolic + integer(16) :: wide + integer(1 + 1) :: unsupported_kind + end subroutine declarations + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert isinstance(table.lookup("named_kind"), psyir_symbols.DataSymbol) + assert table.lookup("wide").datatype.precision.value == "16" + assert isinstance(table.lookup("unsupported_kind").datatype, + psyir_symbols.UnsupportedFortranType) + + # Also check symbolic links are connected + valid_code = """ + program main + use kinds, only: local_kind + implicit none + integer(local_kind) :: value + end program main + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + kind = table.lookup("local_kind") + assert isinstance(kind, psyir_symbols.DataSymbol) + assert table.lookup("value").datatype.precision.symbol is kind + + +def test_numeric_kind_selectors_round_trip(): + '''Numeric KIND selectors remain KIND expressions for declarations and + integer values for literal suffixes. + ''' + valid_code = """ + subroutine kinds() + integer(kind=8) :: integer_value = 1_4 + real(kind=16) :: real_value = 1.0_8 + end subroutine kinds + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert table.lookup("integer_value").datatype.precision.value == "8" + assert table.lookup("real_value").datatype.precision.value == "16" + assert table.lookup("integer_value").initial_value.datatype.precision == 4 + assert table.lookup("real_value").initial_value.datatype.precision == 8 + + +def test_character_length(): + '''Test a character-length specification.''' + processor = FortranTreeSitterReader() + valid_code = """ + program main + implicit none + character(len=12) :: label + end program main + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + label = root.children[0].symbol_table.lookup("label") + assert label.datatype.length.value == "12" + + +def test_character_length_and_kind_selectors(): + '''LEN and KIND are both retained, irrespective of their order.''' + valid_code = """ + subroutine characters() + character(len=3, kind=2) :: first + character(kind=2, len=3) :: second + end subroutine characters + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + for name in ("first", "second"): + datatype = table.lookup(name).datatype + assert datatype.length.value == "3" + assert datatype.precision.value == "2" + + +def test_logical_literal(): + '''Test a logical literal used as an initial value.''' + processor = FortranTreeSitterReader() + valid_code = """ + module declarations + implicit none + logical :: enabled = .true. + end module declarations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + enabled = root.children[0].symbol_table.lookup("enabled") + assert enabled.initial_value.value == "true" + + +def test_literal_kind_variants_and_string(): + '''Test literal kind suffixes and a character literal.''' + valid_code = ''' + subroutine literals() + integer, parameter :: wp = 16 + integer :: single = 1_4, double = 1_8 + integer :: explicit = 1_16, symbolic = 1_wp + character(5) :: text = "hello" + end subroutine literals + ''' + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert table.lookup("single").initial_value.datatype.precision == 4 + assert table.lookup("double").initial_value.datatype.precision == 8 + assert table.lookup("explicit").initial_value.datatype.precision == 16 + precision = table.lookup("symbolic").initial_value.datatype.precision + assert precision.symbol is table.lookup("wp") + assert table.lookup("text").initial_value.value == "hello" + + +def test_double_exponent_and_character_literal_kinds(): + '''Test normalisation of D exponents and kind-prefixed strings.''' + valid_code = """ + subroutine literals() + integer, parameter :: char_kind = 2 + real(kind=8) :: value + character(3) :: first, second + value = 1.0d0 + first = char_kind_'one' + second = 4_'two' + end subroutine literals + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + double = routine.children[0].rhs + assert double.value == "1.0e0" + assert double.datatype.precision == \ + psyir_symbols.ScalarType.Precision.DOUBLE + symbolic = routine.children[1].rhs + assert symbolic.value == "one" + assert symbolic.datatype.precision.symbol is \ + routine.symbol_table.lookup("char_kind") + numeric = routine.children[2].rhs + assert numeric.value == "two" + assert numeric.datatype.precision == 4 + + +def test_character_literal_doubled_delimiters(): + '''Doubled quote delimiters represent one quote in a character value.''' + valid_code = ''' + subroutine strings(first, second) + character(5) :: first, second + first = 'don''t' + second = "a ""word""" + end subroutine strings + ''' + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + assert routine.children[0].rhs.value == "don't" + assert routine.children[1].rhs.value == 'a "word"' + + +def test_new_literal_kind_symbol(): + '''Test that a named literal kind creates an unresolved kind symbol.''' + valid_code = """ + subroutine literal_kind() + integer :: value = 1_new_kind + end subroutine literal_kind + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert isinstance(table.lookup("new_kind"), psyir_symbols.DataSymbol) + assert isinstance(table.lookup("new_kind").interface, + psyir_symbols.UnresolvedInterface) + assert table.lookup("value").initial_value.datatype.precision.symbol is \ + table.lookup("new_kind") + + +@pytest.mark.parametrize("shape_string, extent", [ + ("(:)", psyir_symbols.ArrayType.Extent.ATTRIBUTE), + ("(10)", "10"), +]) +def test_declarations_arrays_datatypes(shape_string, extent): + ''' Test array datatypes and its dimensions. ''' + processor = FortranTreeSitterReader() + + valid_code = f""" + module test + implicit none + integer(4), dimension{shape_string} :: a + end module + """ + ptree = processor.generate_parse_tree_from_source(valid_code) + root = processor.generate_psyir(ptree) + module = root.children[0] + + array_symbol = module.symbol_table.lookup("a") + assert isinstance(array_symbol.datatype, psyir_symbols.ArrayType) + assert array_symbol.datatype.elemental_type.intrinsic == \ + psyir_symbols.ScalarType.Intrinsic.INTEGER + assert array_symbol.datatype.elemental_type.precision.value == "4" + shape = array_symbol.datatype.shape[0] + if isinstance(extent, str): + assert shape.upper.value == extent + assert shape.lower.value == "1" + else: + assert shape == extent + + +def test_allocatable_declaration(): + '''Test an allocatable-array declaration.''' + processor = FortranTreeSitterReader() + valid_code = """ + program main + implicit none + real, allocatable :: values(:) + end program main + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + values = root.children[0].symbol_table.lookup("values") + assert values.datatype.shape == [ + psyir_symbols.ArrayType.Extent.DEFERRED] + + +def test_allocatable_with_explicit_lower_bound_is_preserved(): + '''PSyIR cannot distinguish a lower-bounded deferred extent from an + assumed-shape extent, so preserve this declaration verbatim. + ''' + valid_code = """ + subroutine declarations() + real, allocatable :: values(2:) + end subroutine declarations + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + values = root.children[0].symbol_table.lookup("values") + + assert isinstance(values.datatype, + psyir_symbols.UnsupportedFortranType) + assert values.datatype.declaration == \ + "real, allocatable :: values(2:)" + + +def test_multidimensional_and_lower_bounded_arrays(): + '''Test explicit lower bounds in a multidimensional shape.''' + processor = FortranTreeSitterReader() + valid_code = """ + module array_shapes + implicit none + real :: field(-2:10, 20) + end module array_shapes + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + datatype = root.children[0].symbol_table.lookup("field").datatype + assert isinstance(datatype, psyir_symbols.ArrayType) + assert len(datatype.shape) == 2 + assert datatype.shape[0].lower.operator == \ + psyir_nodes.UnaryOperation.Operator.MINUS + assert datatype.shape[0].lower.children[0].value == "2" + assert datatype.shape[0].upper.value == "10" + assert datatype.shape[1].lower.value == "1" + assert datatype.shape[1].upper.value == "20" + + +def test_assumed_shape_explicit_lower_and_upper_bounds(): + '''Test the individual open-bound forms accepted in assumed-shape array + declarations. + ''' + valid_code = """ + subroutine shapes(lower_open, upper_open) + real :: lower_open(2:), upper_open(:10) + end subroutine shapes + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + lower_open = table.lookup("lower_open").datatype.shape[0] + upper_open = table.lookup("upper_open").datatype.shape[0] + + assert lower_open.lower.value == "2" + assert lower_open.upper == psyir_symbols.ArrayType.Extent.ATTRIBUTE + assert upper_open.lower.value == "1" + assert upper_open.upper.value == "10" + + +def test_shared_dimension_is_given_to_all_entities(): + '''Test that a shared DIMENSION are copied for each declared entity. + ''' + processor = FortranTreeSitterReader() + valid_code = """ + module test + implicit none + integer, parameter :: extent = 10 + real, dimension(extent) :: first, second + end module + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + first_type = table.lookup("first").datatype + second_type = table.lookup("second").datatype + + # They are not the same object, but copies + assert first_type is not second_type + assert first_type.shape[0].upper is not second_type.shape[0].upper + assert first_type.shape[0].upper.symbol is table.lookup("extent") + assert second_type.shape[0].upper.symbol is table.lookup("extent") + + +def test_entity_dimension_overrides_shared_dimension(): + '''Test handling of an entity shape together with DIMENSION.''' + processor = FortranTreeSitterReader() + valid_code = """ + module test + implicit none + real, dimension(10) :: field(20) + end module + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + datatype = root.children[0].symbol_table.lookup("field").datatype + + assert isinstance(datatype, psyir_symbols.ArrayType) + assert datatype.shape[0].upper.value == "20" + + +@pytest.mark.parametrize("valid_code", [ + """ + module declarations + real, dimension(10) :: values + end module declarations + """, + """ + module declarations + real :: values(10) + end module declarations + """, +]) +def test_unsupported_shape_translation(valid_code, monkeypatch): + '''Test failure translating shared and entity-specific array shapes.''' + processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + + def unsupported_shape(*_args, **_kwargs): + '''Stand in for an unsupported bound expression.''' + raise NotImplementedError("unsupported test shape") + + monkeypatch.setattr(processor, "_shape_from_node", unsupported_shape) + root = processor.generate_psyir(parse_tree) + + assert isinstance(root.children[0].symbol_table.lookup("values").datatype, + psyir_symbols.UnsupportedFortranType) + + +def test_direct_extent_and_argument_helpers(): + '''Test extent splitting and absent argument handling.''' + valid_code = """ + subroutine shape(values) + integer :: values(10) + end subroutine shape + """ + processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + number = _first_tsnode(parse_tree, "number_literal") + + before, after, has_colon = processor._split_extent(number) + assert not before + assert not after + assert not has_colon + assert not processor._arguments(None) + + +def test_default_visibility(): + '''Test a module's default visibility.''' + processor = FortranTreeSitterReader() + valid_code = """ + module visibility + implicit none + private + contains + subroutine hidden() + end subroutine hidden + end module visibility + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + container = root.children[0] + assert container.symbol_table.default_visibility == \ + psyir_symbols.Symbol.Visibility.PRIVATE + assert container.symbol_table.lookup("hidden").visibility == \ + psyir_symbols.Symbol.Visibility.PRIVATE + + +def test_named_visibility(): + '''Test name-specific visibility for a contained routine.''' + processor = FortranTreeSitterReader() + valid_code = """ + module visibility + implicit none + private + public :: exposed + contains + subroutine exposed() + end subroutine exposed + end module visibility + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + exposed = root.children[0].symbol_table.lookup("exposed") + assert exposed.visibility == psyir_symbols.Symbol.Visibility.PUBLIC + + +@pytest.mark.parametrize("access_id", ["operator(+)", "assignment(=)"]) +def test_named_operator_access_is_preserved(access_id): + '''An unsupported access-id does not become default module visibility.''' + valid_code = f""" + module visibility + private :: {access_id} + integer :: value + end module visibility + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + assert isinstance(root.children[0], psyir_nodes.CodeBlock) + + +def test_visibility_of_declared_and_unsupported_names(): + '''An access list updates declared symbols and safely ignores names whose + unsupported declarations did not create symbols. + ''' + valid_code = """ + module visibility + public :: exposed, unsupported_name + integer :: exposed + end module visibility + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert table.lookup("exposed").visibility == \ + psyir_symbols.Symbol.Visibility.PUBLIC + assert "unsupported_name" not in table + + +def test_declaration_visibility_and_allocatable_scalar(): + '''Test declaration access attributes and unsupported scalar + ALLOCATABLE.''' + valid_code = """ + module declarations + integer, public :: exposed + integer, private :: hidden + contains + subroutine local() + real, allocatable :: scalar + end subroutine local + end module declarations + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + container = root.children[0] + + assert container.symbol_table.lookup("exposed").visibility == \ + psyir_symbols.Symbol.Visibility.PUBLIC + assert container.symbol_table.lookup("hidden").visibility == \ + psyir_symbols.Symbol.Visibility.PRIVATE + assert isinstance(container.children[0].symbol_table.lookup( + "scalar").datatype, psyir_symbols.UnsupportedFortranType) + + +def test_use_rename(): + '''Test a renamed symbol in a USE ONLY statement.''' + processor = FortranTreeSitterReader() + valid_code = """ + program main + use kinds, only: local_kind => remote_kind + implicit none + end program main + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + container = table.lookup("kinds") + imported = table.lookup("local_kind") + assert isinstance(container, psyir_symbols.ContainerSymbol) + assert imported.interface.container_symbol is container + assert imported.interface.orig_name == "remote_kind" + + +def test_use_rename_without_only(): + '''A rename-list alias directly beneath USE is retained as a wildcard + import with an explicit renamed symbol. + ''' + valid_code = """ + subroutine imports(value) + use source, local_value => remote_value + integer :: value + value = local_value + end subroutine imports + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + table = routine.symbol_table + container = table.lookup("source") + imported = table.lookup("local_value") + + assert container.wildcard_import + assert imported.interface.container_symbol is container + assert imported.interface.orig_name == "remote_value" + assert routine.children[0].rhs.symbol is imported + + +def test_wildcard_and_identity_import(): + '''Test a wildcard import and importing a container under its own name.''' + valid_code = """ + module imports + use wildcard_source + end module imports + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + container = table.lookup("wildcard_source") + assert container.wildcard_import + + processor._current_scope = table + processor._add_imported_symbol( + "wildcard_source", "wildcard_source", container) + assert table.lookup("wildcard_source") is container + + +def test_repeated_use_preserves_wildcard_import(): + '''An ONLY import does not undo an earlier wildcard import from the same + module. + ''' + valid_code = """ + subroutine imports() + use source + use source, only: value + end subroutine imports + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert table.lookup("source").wildcard_import + assert table.lookup("value").interface.container_symbol is \ + table.lookup("source") + + +def test_repeated_use_updates_existing_import_interface(): + '''A repeated explicit import updates the existing local symbol's remote + name while retaining its container. + ''' + valid_code = """ + subroutine imports() + use source, only: value + use source, only: value => remote_value + end subroutine imports + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + imported = table.lookup("value") + + assert imported.interface.container_symbol is table.lookup("source") + assert imported.interface.orig_name == "remote_value" + + +def test_declaration_conflicts_with_import(): + '''Test that redeclaring an imported bare Symbol is localised.''' + valid_code = """ + subroutine conflict() + use other, only: value + integer :: value + end subroutine conflict + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + codeblock = root.children[0].children[0] + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "already declared as a non-data symbol" in \ + codeblock.preceding_comment + + +def test_name_conflict(): + '''Test that name conflicts in different declarations on the same scope + are invalid.''' + valid_code = """ + module conflict + use other + integer :: other + end module conflict + """ + processor = FortranTreeSitterReader() + + message = "USE module 'other' conflicts with another symbol" + with pytest.raises(ValueError, match=message): + processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + +def test_use_conflicts_with_preceding_declaration(): + '''A USE statement cannot reuse the name of an existing data symbol.''' + valid_code = """ + subroutine conflict() + integer :: source + use source + end subroutine conflict + """ + processor = FortranTreeSitterReader() + + with pytest.raises(ValueError, match="USE module 'source' conflicts"): + processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + +def test_derived_type_definition(): + '''Test a simple derived-type definition.''' + processor = FortranTreeSitterReader() + valid_code = """ + module geometry + implicit none + type :: point + real :: x + end type point + end module geometry + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + point = root.children[0].symbol_table.lookup("point") + assert isinstance(point, psyir_symbols.DataTypeSymbol) + assert isinstance(point.datatype, psyir_symbols.StructureType) + assert list(point.datatype.components) == ["x"] + assert point.datatype.components["x"].datatype == \ + psyir_symbols.ScalarType.real_type() + + +def test_derived_type_component_host_association(): + '''Test that a component datatype resolves a kind from its host.''' + processor = FortranTreeSitterReader() + valid_code = """ + module geometry + implicit none + integer, parameter :: wp = 8 + type :: point + real(kind=wp) :: x + end type point + end module geometry + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + wp = table.lookup("wp") + point = table.lookup("point") + x_type = point.datatype.components["x"].datatype + assert x_type.precision.symbol is wp + + +def test_unsupported_and_forward_declared_derived_types(): + '''Test unsupported type procedures and completion of a forward type.''' + valid_code = """ + module types + type :: with_procedure + contains + procedure :: method + end type with_procedure + type(forward) :: instance + type, private :: forward + integer :: value + end type forward + end module types + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + table = root.children[0].symbol_table + + assert isinstance(table.lookup("with_procedure").datatype, + psyir_symbols.UnsupportedFortranType) + forward = table.lookup("forward") + assert isinstance(forward.datatype, psyir_symbols.StructureType) + assert forward.visibility == psyir_symbols.Symbol.Visibility.PRIVATE + + +@pytest.mark.parametrize("definition, marker", [ + ("type, extends(parent) :: child", "extends(parent)"), + ("type, bind(c) :: child", "bind(c)"), + ("type child\n sequence", "sequence")]) +def test_derived_type_attributes_are_preserved(definition, marker): + '''Attributes without StructureType representations retain their source.''' + valid_code = f""" + module types + {definition} + integer :: value + end type child + end module types + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + datatype = root.children[0].symbol_table.lookup("child").datatype + + assert isinstance(datatype, psyir_symbols.UnsupportedFortranType) + + +def test_invalid_derived_type_component_falls_back(): + '''Test a component-name conflict makes the whole type unsupported.''' + valid_code = """ + module types + type :: invalid + type(component_type) :: value + integer :: component_type + end type invalid + end module types + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + assert isinstance(root.children[0].symbol_table.lookup("invalid").datatype, + psyir_symbols.UnsupportedFortranType) + + +def test_derived_type_name_conflict(): + '''A derived type whose name is already used by a data symbol is + rejected as an invalid name conflict. + ''' + valid_code = """ + module conflict + integer :: item + type :: item + integer :: value + end type item + end module conflict + """ + processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + + with pytest.raises(ValueError, + match="Derived type 'item' conflicts with another"): + processor.generate_psyir(parse_tree) + + +def test_generic_interface(): + '''Test a named generic interface.''' + processor = FortranTreeSitterReader() + valid_code = """ + module dispatch + implicit none + interface apply + module procedure apply_integer, apply_real + end interface apply + end module dispatch + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + generic = root.children[0].symbol_table.lookup("apply") + assert isinstance(generic, psyir_symbols.GenericInterfaceSymbol) + assert [info.symbol.name for info in generic.routines] == [ + "apply_integer", "apply_real"] + assert all(info.from_container for info in generic.routines) + + +def test_interface_routine_symbol_are_consistent(): + '''Test that a routine declared by an interface is reused by its body.''' + valid_code = """ + module routines + interface generic + module procedure implementation + end interface generic + contains + pure integer function implementation() + implementation = 1 + end function implementation + end module routines + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + container = root.children[0] + routine = container.children[0] + + assert routine.symbol is container.symbol_table.lookup("implementation") + assert routine.symbol.is_pure + assert routine.symbol.datatype == \ + psyir_symbols.ScalarType.integer_type() + + +@pytest.mark.parametrize("valid_code", [ + """ + module interfaces + abstract interface + subroutine method() + end subroutine method + end interface + end module interfaces + """, + """ + module interfaces + integer :: method + interface generic + module procedure method + end interface generic + end module interfaces + """, + """ + module interfaces + interface generic + subroutine method() + end subroutine method + end interface generic + end module interfaces + """, +]) +def test_unsupported_interface_forms(valid_code): + '''Unsupported interface forms are preserved in declaration context.''' + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + symtab = root.children[0].symbol_table + assert len(root.children[0].children) == 0 + assert len(symtab.symbols) in (1, 2) + assert "end interface" in symtab.symbols[-1].datatype.type_text + + +def test_unary_operation(): + '''Test a unary arithmetic operation.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine operations(value) + real :: value + value = -value + end subroutine operations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + expression = root.children[0].children[0].rhs + assert expression.operator == psyir_nodes.UnaryOperation.Operator.MINUS + + +def test_binary_operation(): + '''Test a binary arithmetic operation.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine operations(value) + real :: value + value = value + 1.0 + end subroutine operations + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + expression = root.children[0].children[0].rhs + assert expression.operator == psyir_nodes.BinaryOperation.Operator.ADD + + +def test_unsupported_expression_codeblock(): + '''An unsupported expression becomes an expression CodeBlock without + replacing its enclosing statement. + ''' + processor = FortranTreeSitterReader() + valid_code = ''' + subroutine concatenate(value) + character(*) :: value + value = value // "suffix" + end subroutine concatenate + ''' + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + assignment = root.children[0].children[0] + assert isinstance(assignment, psyir_nodes.Assignment) + assert isinstance(assignment.rhs, psyir_nodes.CodeBlock) + assert assignment.rhs.structure == \ + psyir_nodes.CodeBlock.Structure.EXPRESSION + assert "Unsupported 'concatenation_expression'" in \ + assignment.rhs.preceding_comment + + +def test_explicit_array_section(): + '''Test an array section with explicit start, stop and step.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine section(array) + real :: array(10) + array(2:8:2) = 0.0 + end subroutine section + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + section = root.children[0].children[0].lhs.indices[0] + assert isinstance(section, psyir_nodes.Range) + assert section.start.value == "2" + assert section.stop.value == "8" + assert section.step.value == "2" + + +def test_implicit_array_section_bounds(): + '''Test synthesized bounds for a whole-array section.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine section(array) + real :: array(10) + array(:) = array(:) + end subroutine section + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + assignment = root.children[0].children[0] + for reference in (assignment.lhs, assignment.rhs): + section = reference.indices[0] + assert section.start.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.LBOUND + assert section.stop.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.UBOUND + + +def test_array_section_omitted_upper_bound_with_step(): + '''A step remains the third triplet field when the upper bound is + omitted. + ''' + valid_code = """ + subroutine section(array) + real :: array(10) + array(1::2) = 0.0 + array(::-1) = 1.0 + end subroutine section + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + first = root.children[0].children[0].lhs.indices[0] + second = root.children[0].children[1].lhs.indices[0] + + assert first.start.value == "1" + assert first.stop.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.UBOUND + assert first.step.value == "2" + assert second.start.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.LBOUND + assert second.stop.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.UBOUND + assert second.step.operator == psyir_nodes.UnaryOperation.Operator.MINUS + assert second.step.children[0].value == "1" + + +def test_array_constructor(): + '''Test a simple array constructor.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine constructor(values) + real :: values(3) + values = [1.0, 2.0, 3.0] + end subroutine constructor + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + constructor = root.children[0].children[0].rhs + assert isinstance(constructor, psyir_nodes.ArrayConstructor) + assert [element.value for element in constructor.children] == [ + "1.0", "2.0", "3.0"] + + +def test_typed_array_constructor_codeblock(): + '''A typed constructor is preserved as one expression CodeBlock.''' + valid_code = """ + subroutine constructor(values) + integer :: values(2) + values = [integer :: 1, 2] + end subroutine constructor + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + constructor = root.children[0].children[0].rhs + + assert isinstance(constructor, psyir_nodes.CodeBlock) + assert constructor.parse_tree_nodes[0].type == "array_literal" + + +def test_implied_do_codeblock(): + '''Test the localized fallback for an implied-DO array constructor.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine constructor(values) + real :: values(3) + integer :: index + values = [(real(index), index=1,3)] + end subroutine constructor + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + assignment = root.children[0].children[0] + assert isinstance(assignment, psyir_nodes.Assignment) + codeblock = assignment.rhs + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert codeblock.structure == psyir_nodes.CodeBlock.Structure.EXPRESSION + assert ("Array constructors with implied-DO loops are not supported" in + codeblock.preceding_comment) + + +def test_unresolved_identifiers_and_call_forms(): + '''Test unresolved names, empty calls, ranges and invalid scalar calls.''' + valid_code = """ + subroutine expressions(result, scalar) + integer :: result, scalar + result = unknown + result = function_without_arguments() + result = function_with_range(1:2) + result = scalar(1) + end subroutine expressions + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + assert routine.children[0].rhs.symbol.name == "unknown" + assert isinstance(routine.children[1].rhs, psyir_nodes.Call) + assert routine.children[1].rhs.arguments == () + for assignment in routine.children[2:]: + assert isinstance(assignment.rhs, psyir_nodes.CodeBlock) + + +def test_named_call_argument(): + '''Test a named subroutine-call argument.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine caller(value) + integer :: value + call update(value, result=value) + end subroutine caller + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + call = root.children[0].children[0] + assert isinstance(call, psyir_nodes.Call) + assert call.argument_names == [None, "result"] + + +def test_intrinsic_call(): + '''Test an intrinsic function call.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine intrinsic(value) + real :: value + value = sin(value) + end subroutine intrinsic + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + call = root.children[0].children[0].rhs + assert isinstance(call, psyir_nodes.IntrinsicCall) + assert call.intrinsic == psyir_nodes.IntrinsicCall.Intrinsic.SIN + + +def test_imported_function_call_specialises_symbol(): + '''A bare Symbol created by an explicit import becomes a RoutineSymbol + when used in a function call. + ''' + valid_code = """ + subroutine caller(result) + use procedures, only: imported + real :: result + result = imported() + end subroutine caller + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + assert isinstance(routine.children[0].rhs, psyir_nodes.Call) + assert isinstance(routine.symbol_table.lookup("imported"), + psyir_symbols.RoutineSymbol) + + +def test_user_routine_resolved_before_intrinsic_name(): + '''A declared procedure whose name matches an intrinsic remains a user + call. + ''' + valid_code = """ + module routines + interface sin + module procedure user_sin + end interface sin + contains + real function user_sin() + user_sin = 0.0 + end function user_sin + subroutine caller(result) + real :: result + result = sin() + end subroutine caller + end module routines + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + call = root.children[0].children[1].children[0].rhs + + assert isinstance(call, psyir_nodes.Call) + assert not isinstance(call, psyir_nodes.IntrinsicCall) + assert isinstance(call.routine.symbol, + psyir_symbols.GenericInterfaceSymbol) + + +def test_invalid_array_and_intrinsic_arguments(): + '''Test named array subscripts and an invalid intrinsic signature.''' + valid_code = """ + subroutine expressions(array, result) + integer :: array(10), result + result = array(dim=1) + result = sin() + end subroutine expressions + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + assert all(isinstance(assignment.rhs, psyir_nodes.CodeBlock) + for assignment in root.children[0].children) + assert "Named subscripts" in \ + root.children[0].children[0].rhs.preceding_comment + assert "Unsupported argument form" in \ + root.children[0].children[1].rhs.preceding_comment + + +def test_existing_routine_and_local_type_calls(): + '''Test calls resolved to an existing routine or local datatype name.''' + valid_code = """ + module routines + interface generic + module procedure existing + end interface generic + contains + integer function existing() + existing = 1 + end function existing + subroutine caller(result) + integer :: result + type(local_type) :: value + result = existing() + value = local_type(1) + end subroutine caller + end module routines + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + caller = root.children[0].children[1] + + assert caller.children[0].rhs.routine.symbol.name == "existing" + assert isinstance(caller.symbol_table.lookup("local_type"), + psyir_symbols.DataTypeSymbol) + assert isinstance(caller.children[1].rhs, psyir_nodes.Call) + + +def test_later_contained_routine_is_predeclared(): + '''A call to a later contained routine uses its container symbol.''' + valid_code = """ + module routines + contains + subroutine caller() + call later() + end subroutine caller + pure subroutine later() + end subroutine later + end module routines + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + container = root.children[0] + caller, later = container.children + call = caller.children[0] + + assert "later" not in caller.symbol_table + assert call.routine.symbol is later.symbol + assert call.routine.symbol is container.symbol_table.lookup("later") + assert call.routine.symbol.is_pure is True + + +def test_predeclare_unsupported_routine(): + '''A routine with an unsupported return type is still predeclared with an + unresolved type. + ''' + valid_code = """ + module routines + contains + complex function unsupported() + end function unsupported + end module routines + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + container = root.children[0] + symbol = container.symbol_table.lookup("unsupported") + + assert isinstance(symbol, psyir_symbols.RoutineSymbol) + assert isinstance(symbol.datatype, psyir_symbols.UnresolvedType) + assert isinstance(container.children[0], psyir_nodes.CodeBlock) + + +def test_call_statement_edge_cases(): + '''Test imported-symbol specialisation and invalid call targets.''' + valid_code = """ + subroutine calls(object) + use procedures, only: imported + type(item_type) :: object + integer :: data + call imported() + call data() + call object%method() + end subroutine calls + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + assert isinstance(routine.children[0], psyir_nodes.Call) + assert isinstance(routine.symbol_table.lookup("imported"), + psyir_symbols.RoutineSymbol) + assert all(isinstance(node, psyir_nodes.CodeBlock) + for node in routine.children[1:]) + + +def test_structure_reference(): + '''Test a scalar structure-component reference.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine get_x(item, value) + type(point) :: item + real :: value + value = item%x + end subroutine get_x + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + reference = root.children[0].children[0].rhs + assert isinstance(reference, psyir_nodes.StructureReference) + assert reference.symbol.name == "item" + assert reference.member.name == "x" + + +def test_array_of_structures_reference(): + '''Test an indexed array-of-structures component reference.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine get_value(items, value) + type(point) :: items(2) + real :: value + value = items(1)%vector(2) + end subroutine get_value + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + reference = root.children[0].children[0].rhs + assert isinstance(reference, + psyir_nodes.ArrayOfStructuresReference) + assert reference.indices[0].value == "1" + assert reference.member.name == "vector" + assert reference.member.indices[0].value == "2" + + +def test_structure_reference_edge_cases(): + '''Test unknown, nested, named-index and non-data structure bases.''' + valid_code = """ + module structures + type :: item_type + integer :: field + end type item_type + contains + subroutine references(items, result) + type(item_type) :: items(2) + integer :: result + result = unknown%field + result = items(1)%vector(2)%field + result = items(dim=1)%field + result = item_type%field + end subroutine references + end module structures + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + statements = root.children[0].children[0].children + + assert isinstance(statements[0].rhs, psyir_nodes.StructureReference) + assert statements[0].rhs.symbol.name == "unknown" + assert isinstance(statements[1].rhs, + psyir_nodes.ArrayOfStructuresReference) + assert statements[1].rhs.member.member.name == "field" + assert isinstance(statements[2].rhs, psyir_nodes.CodeBlock) + assert isinstance(statements[3].rhs, psyir_nodes.CodeBlock) + + +def test_named_trailing_structure_index(): + '''Test a named index on the final component of a structure access.''' + valid_code = """ + subroutine structure(result) + integer :: result + result = item%values(dim=1) + end subroutine structure + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + codeblock = root.children[0].children[0].rhs + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "Unsupported structure member array access" in \ + codeblock.preceding_comment + + +def test_ignored_comment(): + '''Test that an ignored comment does not create a CodeBlock.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine commented(value) + integer :: value + ! This comment must not create a CodeBlock. + value = 1 + end subroutine commented + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + assert len(routine.children) == 1 + assert isinstance(routine.children[0], psyir_nodes.Assignment) + + +def test_pointer_assignment(): + '''Test a pointer assignment.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine associate(target, pointer) + integer, target :: target + integer, pointer :: pointer + pointer => target + end subroutine associate + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + assignment = root.children[0].children[0] + assert isinstance(assignment, psyir_nodes.Assignment) + assert assignment.is_pointer + + +def test_nullify_statement(): + '''Test a NULLIFY statement.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine clear(pointer) + integer, pointer :: pointer + nullify(pointer) + end subroutine clear + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + nullify = root.children[0].children[0] + assert nullify.intrinsic == psyir_nodes.IntrinsicCall.Intrinsic.NULLIFY + + +def test_allocate_statement(): + '''Test an ALLOCATE statement.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine allocate_array(array, extent, status) + integer :: extent, status + real, allocatable :: array(:) + allocate(array(extent), stat=status) + end subroutine allocate_array + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + allocate = root.children[0].children[0] + assert allocate.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.ALLOCATE + assert isinstance(allocate.arguments[0], psyir_nodes.ArrayReference) + assert allocate.argument_names == [None, "stat"] + + +def test_structure_component_allocation_falls_back(): + '''An allocation whose object is a structure component becomes a + statement CodeBlock instead of raising an unexpected exception. + ''' + valid_code = """ + module types + type :: item_type + real, allocatable :: values(:) + end type item_type + contains + subroutine allocate_component(object, extent) + type(item_type) :: object + integer :: extent + allocate(object%values(extent)) + end subroutine allocate_component + end module types + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + codeblock = root.children[0].children[0].children[0] + + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "Allocations of structure components" in \ + codeblock.preceding_comment + + +def test_allocate_bounds_and_invalid_object(): + '''Test explicit allocation bounds, missing upper bound and an import.''' + valid_code = """ + subroutine bounds(first, second, third) + real, allocatable :: first(:), second(:), third(:) + allocate(first(2:10), second(:10)) + allocate(third(2:)) + end subroutine bounds + subroutine imported_object() + use source, only: array + allocate(array(2)) + end subroutine imported_object + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + allocation = root.children[0].children[0] + + assert allocation.arguments[0].indices[0].start.value == "2" + assert allocation.arguments[0].indices[0].stop.value == "10" + assert allocation.arguments[1].indices[0].start.value == "1" + assert isinstance(root.children[0].children[1], psyir_nodes.CodeBlock) + assert isinstance(root.children[1].children[0], psyir_nodes.CodeBlock) + + +def test_deallocate_statement(): + '''Test a DEALLOCATE statement.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine deallocate_array(array, status) + integer :: status + real, allocatable :: array(:) + deallocate(array, stat=status) + end subroutine deallocate_array + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + deallocate = root.children[0].children[0] + assert deallocate.intrinsic == \ + psyir_nodes.IntrinsicCall.Intrinsic.DEALLOCATE + assert deallocate.argument_names == [None, "stat"] + + +def test_stop_codeblock(): + '''Test the localized fallback for a STOP statement.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine stop_execution() + stop 1 + end subroutine stop_execution + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + codeblock = root.children[0].children[0] + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "Unsupported 'stop_statement'" in codeblock.preceding_comment + + +def test_if_construct(): + '''Test IF, ELSE IF and ELSE clauses.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine conditional(value) + integer :: value + if (value < 0) then + value = -value + else if (value == 0) then + value = 1 + else + value = value + 1 + end if + end subroutine conditional + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + # Top if construct + ifblock = root.children[0].children[0] + assert isinstance(ifblock, psyir_nodes.IfBlock) + + # Elseif + nested = ifblock.else_body.children[0] + assert isinstance(nested, psyir_nodes.IfBlock) + assert "was_elseif" in nested.annotations + + # Check final else body + assert nested.else_body.children[0].rhs.operator == \ + psyir_nodes.BinaryOperation.Operator.ADD + + +def test_single_statement_if(): + '''Test the single-statement IF annotation.''' + valid_code = """ + subroutine control(value) + integer :: value + if (value > 0) value = 1 + end subroutine control + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + assert "was_single_stmt" in routine.children[0].annotations + + +def test_do_loop(): + '''Test a DO loop.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine counted(limit) + integer :: limit, index + do index = 1, limit, 2 + limit = limit - 1 + end do + end subroutine counted + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + loop = root.children[0].children[0] + assert isinstance(loop, psyir_nodes.Loop) + assert loop.variable.name == "index" + assert loop.start_expr.value == "1" + assert loop.stop_expr.symbol.name == "limit" + assert loop.step_expr.value == "2" + + +def test_do_while_loop(): + '''Test a DO WHILE loop.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine conditional(value) + integer :: value + do while (value > 0) + value = value - 1 + end do + end subroutine conditional + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + loop = root.children[0].children[0] + assert isinstance(loop, psyir_nodes.WhileLoop) + assert loop.condition.operator == \ + psyir_nodes.BinaryOperation.Operator.GT + + +def test_unconditional_do_loop(): + '''Test an unconditional DO loop.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine unconditional() + do + return + end do + end subroutine unconditional + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + loop = root.children[0].children[0] + assert isinstance(loop, psyir_nodes.WhileLoop) + assert "was_unconditional" in loop.annotations + + +def test_do_concurrent_is_preserved(): + '''DO CONCURRENT is not mistaken for an unconditional DO.''' + valid_code = """ + subroutine concurrent_loop(limit) + integer :: limit, index + do concurrent(index=1:limit) + limit = limit - 1 + end do + end subroutine concurrent_loop + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + loop = root.children[0].children[0] + + assert isinstance(loop, psyir_nodes.CodeBlock) + + +def test_do_variable_variants(): + '''Test implicit, imported and non-scalar DO variables.''' + valid_code = """ + subroutine implicit_variable() + do index = 1, 10 + end do + end subroutine implicit_variable + subroutine imported_variable() + use source, only: index + do index = 1, 10 + end do + end subroutine imported_variable + subroutine array_variable() + integer :: index(2) + do index = 1, 10 + end do + end subroutine array_variable + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + implicit = root.children[0] + assert isinstance(implicit.children[0], psyir_nodes.Loop) + assert implicit.symbol_table.lookup("index").datatype == \ + psyir_symbols.ScalarType.integer_type() + assert isinstance(root.children[1].children[0], psyir_nodes.CodeBlock) + assert isinstance(root.children[2].children[0], psyir_nodes.CodeBlock) + + +def test_keyword_statement(): + '''Test that an unsupported CYCLE is represented by a CodeBlock.''' + valid_code = """ + subroutine control() + do + cycle + end do + end subroutine control + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + routine = root.children[0] + + assert isinstance(routine.children[0].loop_body.children[0], + psyir_nodes.CodeBlock) + + +def test_where_construct(): + '''Test a WHERE construct with ELSEWHERE.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine mask(array) + real :: array(10) + where (array > 0.0) + array = sqrt(array) + elsewhere + array = 0.0 + end where + end subroutine mask + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + where = root.children[0].children[0] + assert isinstance(where, psyir_nodes.IfBlock) + assert where.annotations == ["was_where"] + assert where.else_body.children[0].rhs.value == "0.0" + + +def test_masked_and_repeated_elsewhere_clauses(): + '''Masked ELSEWHERE clauses form a nested conditional chain and may be + followed by a final unmasked clause. + ''' + valid_code = """ + subroutine mask(array, first, second) + real :: array(10) + logical :: first(10), second(10) + where (first) + array = 1.0 + elsewhere (.not. first) + array = 2.0 + elsewhere (second) + array = 3.0 + elsewhere + array = 4.0 + end where + end subroutine mask + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + where = root.children[0].children[0] + first_masked = where.else_body.children[0] + second_masked = first_masked.else_body.children[0] + + assert isinstance(first_masked, psyir_nodes.IfBlock) + assert isinstance(second_masked, psyir_nodes.IfBlock) + assert first_masked.annotations == ["was_where"] + assert second_masked.annotations == ["was_where"] + assert first_masked.if_body.children[0].rhs.value == "2.0" + assert second_masked.if_body.children[0].rhs.value == "3.0" + assert second_masked.else_body.children[0].rhs.value == "4.0" + + +def test_unmasked_elsewhere_must_be_final(): + '''An unmasked ELSEWHERE followed by another clause is preserved as an + unsupported statement instead of constructing incorrect PSyIR. + ''' + valid_code = """ + subroutine mask(array, condition) + real :: array(10) + logical :: condition(10) + where (condition) + array = 1.0 + elsewhere + array = 2.0 + elsewhere (condition) + array = 3.0 + end where + end subroutine mask + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + codeblock = root.children[0].children[0] + + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "unmasked ELSEWHERE must be the final clause" in \ + codeblock.preceding_comment + + +def test_select_case_construct(): + '''Test SELECT CASE lowering.''' + processor = FortranTreeSitterReader() + valid_code = """ + subroutine select_value(selector) + integer :: selector + select case(selector) + case(1) + selector = 2 + case(3:5, 8) + selector = 3 + case default + selector = 0 + end select + end subroutine select_value + """ + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + case = root.children[0].children[0] + assert case.annotations == ["was_case"] + assert case.condition.operator == \ + psyir_nodes.BinaryOperation.Operator.EQ + second = case.else_body.children[0] + assert second.condition.operator == psyir_nodes.BinaryOperation.Operator.OR + assert second.else_body.children[0].rhs.value == "0" + + +def test_select_case_expression_and_open_ranges(): + '''Test an expression selector and lower- or upper-open CASE ranges.''' + valid_code = """ + subroutine selection(value) + integer :: value + select case(value + 1) + case(:5) + value = 1 + case(8:) + value = 2 + end select + end subroutine selection + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + first = root.children[0].children[0] + second = first.else_body.children[0] + + assert first.condition.operator == psyir_nodes.BinaryOperation.Operator.LE + assert second.condition.operator == \ + psyir_nodes.BinaryOperation.Operator.GE + + +def test_select_case_call_selector_is_preserved(): + '''A selector call is not copied into multiple IF conditions.''' + valid_code = """ + subroutine selection(value) + integer :: value + select case(next_value()) + case(1, 2:3) + value = 1 + case(4) + value = 2 + end select + end subroutine selection + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + selection = root.children[0].children[0] + + assert isinstance(selection, psyir_nodes.CodeBlock) + + +def test_select_case_with_only_default_is_unsupported(): + '''A default-only SELECT CASE remains a CodeBlock so evaluation of an + impure selector is not discarded. + ''' + valid_code = """ + subroutine selection(value) + integer :: value + select case(next_value()) + case default + value = 1 + end select + end subroutine selection + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + codeblock = root.children[0].children[0] + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "SELECT CASE selectors containing calls" in \ + codeblock.preceding_comment + + +def test_select_case_with_only_default_and_simple_selector(): + '''A default-only SELECT CASE with a simple selector is unsupported.''' + valid_code = """ + subroutine selection(value) + integer :: value + select case(value) + case default + value = 1 + end select + end subroutine selection + """ + processor = FortranTreeSitterReader() + root = processor.generate_psyir( + processor.generate_parse_tree_from_source(valid_code)) + + codeblock = root.children[0].children[0] + assert isinstance(codeblock, psyir_nodes.CodeBlock) + assert "only a default clause" in codeblock.preceding_comment + + +def test_invalid_memory_intrinsic_signature(monkeypatch): + '''Test handling of a memory intrinsic rejected by PSyIR validation.''' + valid_code = """ + subroutine guards(array) + real, allocatable :: array(:) + allocate(array(10)) + end subroutine guards + """ + processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + allocate = _first_tsnode(parse_tree, "allocate_statement") + + def invalid_intrinsic(*_args, **_kwargs): + '''Simulate rejection by PSyIR intrinsic signature validation.''' + raise TypeError("invalid test operands") + + monkeypatch.setattr(psyir_nodes.IntrinsicCall, "create", + invalid_intrinsic) + with pytest.raises(NotImplementedError, match="Unsupported operands"): + processor._memory_statement(allocate) + + +def test_scope_and_handler_defensive_errors(): + '''Test scope ownership defensive checks.''' + valid_code = """ + subroutine routine() + end subroutine routine + module types + private :: operator(+) + type :: item + integer :: value + end type item + end module types + """ + processor = FortranTreeSitterReader() + parse_tree = processor.generate_parse_tree_from_source(valid_code) + routine = _first_tsnode(parse_tree, "subroutine") + derived = _first_tsnode(parse_tree, "derived_type_definition") + unsupported_access = _first_tsnode(parse_tree, "private_statement") + with pytest.raises(NotImplementedError, match="Named operator"): + processor._private_statement_handler(unsupported_access) + + parent = psyir_nodes.ScopingNode(symbol_table=psyir_symbols.SymbolTable()) + attached = psyir_nodes.ScopingNode( + symbol_table=psyir_symbols.SymbolTable()) + attached._parent = parent + with pytest.raises(InternalError, match="must be an orphan"): + with processor._using_temporary_scope(parent, attached): + pass + attached._parent = None + + with pytest.raises(InternalError, match="Routine must be translated"): + processor._procedure_handler(routine) + with pytest.raises(InternalError, match="derived type must be translated"): + processor._derived_type_definition_handler(derived)