Merge branch 'topic/1036' into 'master'

Implement defaults for generic formal functions Closes #1036 See merge request eng/libadalang/libadalang!1627
AdaCore · Apr 18, 2024 · 2d6b738 · 2d6b738
2 parents 70a549f + fe467e5
commit 2d6b738
Show file tree

Hide file tree

Showing 27 changed files with 3,151 additions and 3,051 deletions.
diff --git a/ada/ast.py b/ada/ast.py
@@ -12914,6 +12914,7 @@ class FormalSubpDecl(ClassicSubpDecl):
 
     defining_names = Property(Entity.subp_spec.name.singleton)
 
+    xref_entry_point = Property(True)
     xref_equation = Property(
         Entity.default_expr.then(lambda e: e.match(
             lambda _=T.NullLiteral: LogicTrue(),
@@ -13070,9 +13071,6 @@ class GenericFormal(BaseFormalParamDecl):
     defining_names = Property(Entity.decl.defining_names)
     type_expression = Property(Entity.decl.type_expression)
 
-    xref_entry_point = Property(True)
-    xref_equation = Property(Entity.decl.xref_equation)
-
 
 class GenericFormalObjDecl(GenericFormal):
     """
@@ -23738,9 +23736,6 @@ def discriminants_list(
         ignore(stop_recurse_at)
         return Entity.discriminants.abstract_formal_params
 
-    xref_stop_resolution = Property(True)
-    xref_equation = Property(LogicTrue())
-
 
 class IncompleteTaggedTypeDecl(IncompleteTypeDecl):
     """
@@ -23760,13 +23755,7 @@ class IncompleteFormalTypeDecl(IncompleteTypeDecl):
     default_type = Field(type=T.Name)
 
     is_tagged_type = Property(Not(Self.is_tagged.is_null))
-
-    xref_stop_resolution = Property(Self.default_type.is_null)
-    xref_equation = Property(If(
-        Entity.xref_stop_resolution,
-        Entity.super(),
-        Entity.default_type.sub_equation
-    ))
+    xref_equation = Property(Entity.default_type.sub_equation)
 
 
 class Params(AdaNode):

diff --git a/ada/grammar.py b/ada/grammar.py
@@ -412,7 +412,7 @@ def end_named_block():
         A.pragma,
         GenericFormalObjDecl(A.object_decl),
         GenericFormalTypeDecl(A.formal_type_decl),
-        GenericFormalSubpDecl(A.formal_subp_decl),
+        GenericFormalSubpDecl("with", A.formal_subp_decl),
         GenericFormalPackage("with", A.generic_instantiation)
     ),
 
@@ -443,16 +443,19 @@ def end_named_block():
 
     formal_subp_decl=Or(
         AbstractFormalSubpDecl(
-            "with", Overriding.alt_unspecified(), A.subp_spec,
+            Overriding.alt_unspecified(), A.subp_spec,
             "is", res("abstract"),
             Opt(Or(A.box_expr, A.name, A.null_literal)),
             A.aspect_spec, sc()
         ),
         ConcreteFormalSubpDecl(
-            "with", Overriding.alt_unspecified(), A.subp_spec,
+            Overriding.alt_unspecified(), A.subp_spec,
             Opt("is", Or(A.box_expr, A.name, A.null_literal)),
             A.aspect_spec, ";"
         ),
+        # In the case of generic formal functions with a default expression, we
+        # just use an expression function node.
+        A.expr_fn,
     ),
 
     renaming_clause=RenamingClause("renames", A.name),

diff --git a/extensions/default_unparsing_config.json b/extensions/default_unparsing_config.json
@@ -1170,38 +1170,29 @@
     },
     "ConcreteFormalSubpDecl": {
       "node": {
-        "kind": "align",
-        "width": 2,
-        "contents": {
-          "kind": "group",
-          "document": [
-            {
-              "kind": "text",
-              "text": "with"
-            },
-            "line",
-            {
-              "kind": "recurse_field",
-              "field": "f_overriding"
-            },
-            {
-              "kind": "recurse_field",
-              "field": "f_subp_spec"
-            },
-            {
-              "kind": "recurse_field",
-              "field": "f_default_expr"
-            },
-            {
-              "kind": "recurse_field",
-              "field": "f_aspects"
-            },
-            {
-              "kind": "text",
-              "text": ";"
-            }
-          ]
-        }
+        "kind": "group",
+        "document": [
+          {
+            "kind": "recurse_field",
+            "field": "f_overriding"
+          },
+          {
+            "kind": "recurse_field",
+            "field": "f_subp_spec"
+          },
+          {
+            "kind": "recurse_field",
+            "field": "f_default_expr"
+          },
+          {
+            "kind": "recurse_field",
+            "field": "f_aspects"
+          },
+          {
+            "kind": "text",
+            "text": ";"
+          }
+        ]
       },
       "fields": {
         "f_aspects": [
@@ -2581,13 +2572,22 @@
     },
     "GenericFormalSubpDecl": {
       "node": {
-        "kind": "group",
-        "document": [
-          {
-            "kind": "recurse_field",
-            "field": "f_decl"
-          }
-        ]
+        "kind": "align",
+        "width": 2,
+        "contents": {
+          "kind": "group",
+          "document": [
+            {
+              "kind": "text",
+              "text": "with"
+            },
+            "line",
+            {
+              "kind": "recurse_field",
+              "field": "f_decl"
+            }
+          ]
+        }
       }
     },
     "GenericFormalTypeDecl": {

diff --git a/testsuite/tests/name_resolution/attr_function_renaming/test.adb b/testsuite/tests/name_resolution/attr_function_renaming/test.adb
@@ -4,7 +4,7 @@ procedure Test is
 
    generic
       with procedure Bar (X : Integer) return String is Integer'Image;
-      pragma Test_Statement;
+      pragma Test_Block;
    package Test is
    end Test;
 begin

diff --git a/testsuite/tests/name_resolution/attr_function_renaming/test.out b/testsuite/tests/name_resolution/attr_function_renaming/test.out
@@ -17,8 +17,8 @@ Expr: <Id "Image" test.adb:2:61-2:66>
   type:          None
   expected type: None
 
-Resolving xrefs for node <GenericFormalSubpDecl ["Bar"] test.adb:6:7-6:71>
-**************************************************************************
+Resolving xrefs for node <ConcreteFormalSubpDecl ["Bar"] test.adb:6:12-6:71>
+****************************************************************************
 
 Expr: <AttributeRef test.adb:6:57-6:70>
   references:    <SyntheticDefiningName "image" __standard:4:3-4:54>
@@ -33,5 +33,21 @@ Expr: <Id "Image" test.adb:6:65-6:70>
   type:          None
   expected type: None
 
+Resolving xrefs for node <SubpSpec test.adb:6:12-6:53>
+******************************************************
+
+Expr: <Id "String" test.adb:6:47-6:53>
+  references:    <DefiningName "String" __standard:105:8-105:14>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <ParamSpec ["X"] test.adb:6:27-6:38>
+*************************************************************
+
+Expr: <Id "Integer" test.adb:6:31-6:38>
+  references:    <DefiningName "Integer" __standard:4:8-4:15>
+  type:          None
+  expected type: None
+
 
 Done.
diff --git a/testsuite/tests/name_resolution/formal_pkg_with_box_expr/test.out b/testsuite/tests/name_resolution/formal_pkg_with_box_expr/test.out
@@ -1,10 +1,6 @@
 Analyzing test.adb
 ##################
 
-Resolving xrefs for node <GenericFormalPackage ["P_Inst"] test.adb:9:7-9:52>
-****************************************************************************
-
-
 Resolving xrefs for node <GenericPackageInstantiation ["P_Inst"] test.adb:9:12-9:52>
 ************************************************************************************
 

diff --git a/testsuite/tests/name_resolution/formal_procedure_with_default/test.adb b/testsuite/tests/name_resolution/formal_procedure_with_default/test.adb
@@ -11,7 +11,7 @@ procedure What is
       type T is private;
       with package Bla is new Boo (T);
       with procedure Whatever (Self : T) is Bla.Baa;
-      pragma Test_Statement;
+      pragma Test_Block;
    package Wat is
    end Wat;
 begin

diff --git a/testsuite/tests/name_resolution/formal_procedure_with_default/test.out b/testsuite/tests/name_resolution/formal_procedure_with_default/test.out
@@ -1,8 +1,8 @@
 Analyzing test.adb
 ##################
 
-Resolving xrefs for node <GenericFormalSubpDecl ["Whatever"] test.adb:13:7-13:53>
-*********************************************************************************
+Resolving xrefs for node <ConcreteFormalSubpDecl ["Whatever"] test.adb:13:12-13:53>
+***********************************************************************************
 
 Expr: <DottedName test.adb:13:45-13:52>
   references:    <| DefiningName "Baa" test.adb:7:17-7:20 [test.adb:12:12] |>
@@ -17,5 +17,17 @@ Expr: <Id "Baa" test.adb:13:49-13:52>
   type:          None
   expected type: None
 
+Resolving xrefs for node <SubpSpec test.adb:13:12-13:41>
+********************************************************
+
+
+Resolving xrefs for node <ParamSpec ["Self"] test.adb:13:32-13:40>
+******************************************************************
+
+Expr: <Id "T" test.adb:13:39-13:40>
+  references:    <DefiningName "T" test.adb:11:12-11:13>
+  type:          None
+  expected type: None
+
 
 Done.
diff --git a/testsuite/tests/name_resolution/generic_formal_fn_default_val/test.ads b/testsuite/tests/name_resolution/generic_formal_fn_default_val/test.ads
@@ -0,0 +1,6 @@
+generic
+   type T;
+   with function Copy (Self : T) return T is (Self);
+   pragma Test_Block;
+package Test is
+end Test;
diff --git a/testsuite/tests/name_resolution/generic_formal_fn_default_val/test.out b/testsuite/tests/name_resolution/generic_formal_fn_default_val/test.out
@@ -0,0 +1,32 @@
+Analyzing test.ads
+##################
+
+Resolving xrefs for node <ExprFunction ["Copy"] test.ads:3:9-3:53>
+******************************************************************
+
+Expr: <ParenExpr test.ads:3:46-3:52>
+  type:          <IncompleteFormalTypeDecl ["T"] test.ads:2:4-2:11>
+  expected type: <IncompleteFormalTypeDecl ["T"] test.ads:2:4-2:11>
+Expr: <Id "Self" test.ads:3:47-3:51>
+  references:    <DefiningName "Self" test.ads:3:24-3:28>
+  type:          <IncompleteFormalTypeDecl ["T"] test.ads:2:4-2:11>
+  expected type: <IncompleteFormalTypeDecl ["T"] test.ads:2:4-2:11>
+
+Resolving xrefs for node <SubpSpec test.ads:3:9-3:42>
+*****************************************************
+
+Expr: <Id "T" test.ads:3:41-3:42>
+  references:    <DefiningName "T" test.ads:2:9-2:10>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <ParamSpec ["Self"] test.ads:3:24-3:32>
+****************************************************************
+
+Expr: <Id "T" test.ads:3:31-3:32>
+  references:    <DefiningName "T" test.ads:2:9-2:10>
+  type:          None
+  expected type: None
+
+
+Done.
diff --git a/testsuite/tests/name_resolution/generic_formal_fn_default_val/test.yaml b/testsuite/tests/name_resolution/generic_formal_fn_default_val/test.yaml
@@ -0,0 +1,2 @@
+driver: name-resolution
+input_sources: [test.ads]
diff --git a/testsuite/tests/name_resolution/generic_formal_subp_decl/test.adb b/testsuite/tests/name_resolution/generic_formal_subp_decl/test.adb
@@ -2,9 +2,9 @@ procedure Test is
    generic
       type T is (<>);
       with function FI (I: T) return String is T'Image;
-      pragma Test_Statement;
+      pragma Test_Block;
       with function FV (S: String) return T is T'Value;
-      pragma Test_Statement;
+      pragma Test_Block;
    package P is
       procedure P is null;
    end P;

diff --git a/testsuite/tests/name_resolution/generic_formal_subp_decl/test.out b/testsuite/tests/name_resolution/generic_formal_subp_decl/test.out
@@ -1,8 +1,8 @@
 Analyzing test.adb
 ##################
 
-Resolving xrefs for node <GenericFormalSubpDecl ["FI"] test.adb:4:7-4:56>
-*************************************************************************
+Resolving xrefs for node <ConcreteFormalSubpDecl ["FI"] test.adb:4:12-4:56>
+***************************************************************************
 
 Expr: <AttributeRef test.adb:4:48-4:55>
   references:    <SyntheticDefiningName "image" test.adb:3:7-3:22>
@@ -17,8 +17,24 @@ Expr: <Id "Image" test.adb:4:50-4:55>
   type:          None
   expected type: None
 
-Resolving xrefs for node <GenericFormalSubpDecl ["FV"] test.adb:6:7-6:56>
-*************************************************************************
+Resolving xrefs for node <SubpSpec test.adb:4:12-4:44>
+******************************************************
+
+Expr: <Id "String" test.adb:4:38-4:44>
+  references:    <DefiningName "String" __standard:105:8-105:14>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <ParamSpec ["I"] test.adb:4:25-4:29>
+*************************************************************
+
+Expr: <Id "T" test.adb:4:28-4:29>
+  references:    <DefiningName "T" test.adb:3:12-3:13>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <ConcreteFormalSubpDecl ["FV"] test.adb:6:12-6:56>
+***************************************************************************
 
 Expr: <AttributeRef test.adb:6:48-6:55>
   references:    <SyntheticDefiningName "value" test.adb:3:7-3:22>
@@ -33,5 +49,21 @@ Expr: <Id "Value" test.adb:6:50-6:55>
   type:          None
   expected type: None
 
+Resolving xrefs for node <SubpSpec test.adb:6:12-6:44>
+******************************************************
+
+Expr: <Id "T" test.adb:6:43-6:44>
+  references:    <DefiningName "T" test.adb:3:12-3:13>
+  type:          None
+  expected type: None
+
+Resolving xrefs for node <ParamSpec ["S"] test.adb:6:25-6:34>
+*************************************************************
+
+Expr: <Id "String" test.adb:6:28-6:34>
+  references:    <DefiningName "String" __standard:105:8-105:14>
+  type:          None
+  expected type: None
+
 
 Done.