From d1d9de6b35bfed23b6662da18d9912a524e4a5e4 Mon Sep 17 00:00:00 2001
From: Daniel Mercier <mercier@adacore.com>
Date: Fri, 15 Sep 2023 14:38:40 +0200
Subject: [PATCH] Keep gpr_project alive when creating an analysis context from
 it

Issue: eng/libadalang/libadalang#1054
---
 extensions/ocaml_api/module_struct            |  4 +-
 .../ocaml_api/project_unit_provider/p.gpr     |  2 +-
 .../project_unit_provider/src3/a.ads          |  5 +++
 .../project_unit_provider/src3/b.ads          |  3 ++
 .../ocaml_api/project_unit_provider/test.ml   | 41 ++++++++++++++++++-
 .../ocaml_api/project_unit_provider/test.out  |  1 +
 6 files changed, 53 insertions(+), 3 deletions(-)
 create mode 100644 testsuite/tests/ocaml_api/project_unit_provider/src3/a.ads
 create mode 100644 testsuite/tests/ocaml_api/project_unit_provider/src3/b.ads

diff --git a/extensions/ocaml_api/module_struct b/extensions/ocaml_api/module_struct
index 0ad8153a9..8b83bbabe 100644
--- a/extensions/ocaml_api/module_struct
+++ b/extensions/ocaml_api/module_struct
@@ -166,7 +166,9 @@ module GPRProject = struct
       gpr_project : analysis_context =
     if tab_stop < 1 then
       raise (Invalid_argument "Invalid tab_stop (positive integer expected)") ;
-    let c_context = AnalysisContextStruct.allocate_analysis_context () in
+    let c_context =
+      AnalysisContextStruct.allocate_analysis_context ~keep:gpr_project ()
+    in
     gpr_project_initialize_context
       gpr_project
       c_context
diff --git a/testsuite/tests/ocaml_api/project_unit_provider/p.gpr b/testsuite/tests/ocaml_api/project_unit_provider/p.gpr
index 07e43d1a7..7b3eb6da9 100644
--- a/testsuite/tests/ocaml_api/project_unit_provider/p.gpr
+++ b/testsuite/tests/ocaml_api/project_unit_provider/p.gpr
@@ -1,5 +1,5 @@
 project P is
-   type Src_Dir_Type is ("src1", "src2");
+   type Src_Dir_Type is ("src1", "src2", "src3");
    Src_Dir : Src_Dir_Type := external ("SRC_DIR");
    for Source_Dirs use (Src_Dir);
 end P;
diff --git a/testsuite/tests/ocaml_api/project_unit_provider/src3/a.ads b/testsuite/tests/ocaml_api/project_unit_provider/src3/a.ads
new file mode 100644
index 000000000..3d61ef30e
--- /dev/null
+++ b/testsuite/tests/ocaml_api/project_unit_provider/src3/a.ads
@@ -0,0 +1,5 @@
+with B;
+
+package A is
+   X : Integer := B.Y;
+end A;
diff --git a/testsuite/tests/ocaml_api/project_unit_provider/src3/b.ads b/testsuite/tests/ocaml_api/project_unit_provider/src3/b.ads
new file mode 100644
index 000000000..73bb2b13d
--- /dev/null
+++ b/testsuite/tests/ocaml_api/project_unit_provider/src3/b.ads
@@ -0,0 +1,3 @@
+package B is
+   Y : Integer := 42;
+end B;
diff --git a/testsuite/tests/ocaml_api/project_unit_provider/test.ml b/testsuite/tests/ocaml_api/project_unit_provider/test.ml
index 8b5a67a69..803687e24 100644
--- a/testsuite/tests/ocaml_api/project_unit_provider/test.ml
+++ b/testsuite/tests/ocaml_api/project_unit_provider/test.ml
@@ -1,5 +1,11 @@
 open Libadalang
 
+let value_exn = function
+  | Some x ->
+      x
+  | None ->
+      raise (Invalid_argument "Some expected, got None")
+
 let format_exc_message msg =
   (* For exceptions with no explicit message (e.g. Invalid_Project exceptions
    * from gnatcoll-projects.adb), hide the line number, which is out of our
@@ -67,4 +73,37 @@ let test_src src_dir =
     (Format.pp_print_list pp_node)
     matching_nodes
 
-let () = test_src "src1" ; test_src "src2"
+let analysis_context () =
+  let open GPRProject in
+  let gpr = load ~scenario_vars:[("SRC_DIR", "src3")] "p.gpr" in
+  create_analysis_context gpr
+
+let test_gpr_project_context () =
+  let ctx = analysis_context () in
+  (* At this point gpr is out of scope, call GC.full_major to hopefully trigger
+     a valgrind issue in case gpr has been gced (we want it to stay alive
+     because the context uses it *)
+  Gc.full_major () ;
+  let u = AnalysisContext.get_from_file ctx "src3/a.ads" in
+  let root =
+    match AnalysisUnit.root u with
+    | Some n ->
+        n
+    | None ->
+        Format.printf "@[<v>Cannot get root node for file a.ads@ @]" ;
+        exit 1
+  in
+  let name =
+    AdaNode.find ObjectDecl root
+    |> ObjectDecl.f_default_expr
+    |> value_exn
+    |> AdaNode.as_a Name
+    |> value_exn
+  in
+  let ref = Name.p_referenced_decl name |> value_exn in
+  Format.printf "%s referenced_decl is %s@."
+    (AdaNode.image name)
+    (AdaNode.image ref)
+
+
+let () = test_src "src1" ; test_src "src2"; test_gpr_project_context ()
diff --git a/testsuite/tests/ocaml_api/project_unit_provider/test.out b/testsuite/tests/ocaml_api/project_unit_provider/test.out
index d4bf23269..bf46a05cd 100644
--- a/testsuite/tests/ocaml_api/project_unit_provider/test.out
+++ b/testsuite/tests/ocaml_api/project_unit_provider/test.out
@@ -12,3 +12,4 @@ For SRC_DIR=src1
 For SRC_DIR=src2
 <SubtypeIndication p2.ads:5:8-5:22> resolves to:
   <ConcreteTypeDecl ["Record_Type"] p1.ads:3:4-5:15>
+<DottedName a.ads:4:19-4:22> referenced_decl is <ObjectDecl ["Y"] b.ads:2:4-2:22>