diff --git a/graphify/extractors/fortran.py b/graphify/extractors/fortran.py index a3c962480..51a388cc3 100644 --- a/graphify/extractors/fortran.py +++ b/graphify/extractors/fortran.py @@ -101,6 +101,11 @@ def extract_fortran(path: Path) -> dict: file_nid = _make_id(str(path)) add_node(file_nid, path.name, 1) + # (type_nid, implementing_procedure_name, line) for every type-bound + # procedure. Resolved after the whole tree is walked, once the module's + # internal procedures have their nodes. + type_bound_procs: list[tuple[str, str, int]] = [] + def _fortran_name(stmt_node) -> str | None: """Extract name from a *_statement node. Fortran is case-insensitive; lowercase.""" for child in stmt_node.children: @@ -179,6 +184,23 @@ def extract_fortran(path: Path) -> dict: if tgt != fn_nid: add_edge(fn_nid, tgt, "references", var_line, context="return_type") + def _type_bound_impl_name(proc_stmt) -> str | None: + """The module procedure implementing a type-bound `procedure` statement. + + `procedure :: area => circle_area` binds the method name `area` to the + implementation `circle_area` (a `binding` node with a `method_name` + child); `procedure :: scale` binds `scale` to a same-named procedure + (a bare `method_name` child).""" + binding = next((c for c in proc_stmt.children if c.type == "binding"), None) + if binding is not None: + mn = next((c for c in binding.children if c.type == "method_name"), None) + if mn is not None: + return _read_text(mn, source).lower() + mn = next((c for c in proc_stmt.children if c.type == "method_name"), None) + if mn is not None: + return _read_text(mn, source).lower() + return None + def walk_calls(node, scope_nid: str) -> None: if node is None: return @@ -253,6 +275,20 @@ def extract_fortran(path: Path) -> dict: line = node.start_point[0] + 1 add_node(type_nid, type_name, line) add_edge(scope_nid, type_nid, "defines", line) + # Type-bound procedures in the `contains` section bind the + # derived type to the module procedures that implement its + # methods. Without this the binding was dropped and the type + # sat in the graph with no link to its own methods. + procs = next((c for c in node.children + if c.type == "derived_type_procedures"), None) + if procs is not None: + for stmt in procs.children: + if stmt.type != "procedure_statement": + continue + impl = _type_bound_impl_name(stmt) + if impl: + type_bound_procs.append( + (type_nid, impl, stmt.start_point[0] + 1)) return if t == "subroutine": @@ -299,6 +335,15 @@ def extract_fortran(path: Path) -> dict: walk(root, file_nid) + # Link each derived type to the procedures bound as its methods, now that + # the module's internal procedures have been given nodes. A binding to a + # procedure imported from another module resolves to a sourceless stub the + # corpus rewire can collapse (same treatment as parameter/return types). + for type_nid, impl_name, line in type_bound_procs: + tgt = ensure_named_node(impl_name, line) + if tgt != type_nid: + add_edge(type_nid, tgt, "method", line, context="type_bound_procedure") + _stmt_headers = { "subroutine_statement", "function_statement", "program_statement", "module_statement", diff --git a/tests/test_languages.py b/tests/test_languages.py index 62017376b..a5aaaf1dc 100644 --- a/tests/test_languages.py +++ b/tests/test_languages.py @@ -2421,6 +2421,68 @@ def test_fortran_capital_F_parses_preprocessed(): assert any("compute_volume" in l for l in labels) +def test_fortran_type_bound_procedures_link_to_the_type(tmp_path): + """A derived type's `contains` section binds procedures as its methods. + + Both the renaming form (`procedure :: area => circle_area`) and the plain + form (`procedure :: scale`) must connect the type to the module procedure + that implements it; before this the whole binding was dropped and the type + had no link to its own methods. + """ + src = tmp_path / "geom.f90" + src.write_text( + "module geom\n" + " type :: circle\n" + " real :: radius\n" + " contains\n" + " procedure :: area => circle_area\n" + " procedure :: scale\n" + " end type circle\n" + "contains\n" + " real function circle_area(self)\n" + " class(circle), intent(in) :: self\n" + " circle_area = 3.14159 * self%radius**2\n" + " end function circle_area\n" + " subroutine scale(self, f)\n" + " class(circle), intent(inout) :: self\n" + " real, intent(in) :: f\n" + " self%radius = self%radius * f\n" + " end subroutine scale\n" + "end module geom\n", + encoding="utf-8", + ) + r = extract_fortran(src) + assert "error" not in r + methods = _edge_labels(r, "method", "type_bound_procedure") + assert ("circle", "circle_area") in methods + assert ("circle", "scale") in methods + + +def test_fortran_type_bound_procedure_from_other_module_is_sourceless(tmp_path): + """A binding to a procedure implemented in another module resolves to a + sourceless stub the corpus rewire can collapse, never a dangling edge.""" + src = tmp_path / "shape.f90" + src.write_text( + "module shape\n" + " use draw_mod\n" + " type :: widget\n" + " contains\n" + " procedure :: render => external_render\n" + " end type widget\n" + "end module shape\n", + encoding="utf-8", + ) + r = extract_fortran(src) + node_ids = {n["id"] for n in r["nodes"]} + # the binding still produced an edge... + assert ("widget", "external_render") in _edge_labels(r, "method", "type_bound_procedure") + # ...with a resolvable target node and no dangling endpoints + for e in r["edges"]: + assert e["source"] in node_ids and e["target"] in node_ids, e + stub = next(n for n in r["nodes"] if n["label"] == "external_render") + assert stub["source_file"] == "" + + # ── PowerShell ─────────────────────────────────────────────────────────────── def test_powershell_no_error():