diff --git a/compiler/ast_schema.json b/compiler/ast_schema.json index b9c755d..795e94c 100644 --- a/compiler/ast_schema.json +++ b/compiler/ast_schema.json @@ -104,6 +104,7 @@ "fields": [ { "name": "is_public", "type": "Boolean", "optional": false }, { "name": "name", "type": "Identifier", "optional": false }, + { "name": "generic_formals", "type": "Option>", "optional": true }, { "name": "discriminant_part", "type": "Option", "optional": true }, { "name": "type_definition", "type": "NodeRef", "optional": false }, { "name": "span", "type": "Span", "optional": false } @@ -626,6 +627,7 @@ "source_section": "8.6", "fields": [ { "name": "identifier", "type": "Identifier", "optional": false }, + { "name": "generic_arguments", "type": "Option>", "optional": true }, { "name": "span", "type": "Span", "optional": false } ] }, @@ -658,10 +660,21 @@ "fields": [ { "name": "prefix", "type": "NodeRef", "optional": false }, { "name": "selector", "type": "Identifier", "optional": false }, + { "name": "generic_arguments", "type": "Option>", "optional": true }, { "name": "resolved_kind", "type": "Option", "optional": true, "note": "Populated during semantic analysis: RecordField, Attribute, PackageMember, ImplicitDereference. The parser creates SelectedComponent for all X.Y forms; semantic analysis classifies each case per the resolution rule in spec/02-restrictions.md section 2.4.1." }, { "name": "span", "type": "Span", "optional": false } ] }, + { + "node_type": "GenericFormal", + "production": "generic_formal", + "source_section": "8.8", + "fields": [ + { "name": "name", "type": "Identifier", "optional": false }, + { "name": "constraint_name", "type": "Option", "optional": true }, + { "name": "span", "type": "Span", "optional": false } + ] + }, { "node_type": "TypeConversion", "production": "type_conversion", @@ -1226,6 +1239,7 @@ "source_section": "8.8", "fields": [ { "name": "name", "type": "Identifier", "optional": false }, + { "name": "generic_formals", "type": "Option>", "optional": true }, { "name": "receiver", "type": "Option", "optional": true }, { "name": "formal_part", "type": "Option", "optional": true }, { "name": "span", "type": "Span", "optional": false } @@ -1237,6 +1251,7 @@ "source_section": "8.8", "fields": [ { "name": "name", "type": "Identifier", "optional": false }, + { "name": "generic_formals", "type": "Option>", "optional": true }, { "name": "receiver", "type": "Option", "optional": true }, { "name": "formal_part", "type": "Option", "optional": true }, { "name": "return_type", "type": "NodeRef", "optional": false }, diff --git a/compiler_impl/src/safe_frontend-ada_emit.adb b/compiler_impl/src/safe_frontend-ada_emit.adb index f16255f..b6c1275 100644 --- a/compiler_impl/src/safe_frontend-ada_emit.adb +++ b/compiler_impl/src/safe_frontend-ada_emit.adb @@ -6817,7 +6817,8 @@ package body Safe_Frontend.Ada_Emit is end Add_From_Statements; begin for Item of Unit.Types loop - if Has_Text (Item.Name) + if Item.Generic_Formals.Is_Empty + and then Has_Text (Item.Name) and then not Contains_Name (Seen, FT.To_String (Item.Name)) then Seen.Append (Item.Name); @@ -6832,7 +6833,9 @@ package body Safe_Frontend.Ada_Emit is end loop; for Item of Unit.Types loop - Add_From_Info (Item); + if Item.Generic_Formals.Is_Empty then + Add_From_Info (Item); + end if; end loop; for Item of Unit.Objects loop Add_From_Info (Item.Type_Info); @@ -6982,7 +6985,9 @@ package body Safe_Frontend.Ada_Emit is end Add_From_Statements; begin for Item of Unit.Types loop - Add_From_Info (Item); + if Item.Generic_Formals.Is_Empty then + Add_From_Info (Item); + end if; end loop; for Item of Unit.Objects loop Add_From_Info (Item.Type_Info); @@ -7095,7 +7100,9 @@ package body Safe_Frontend.Ada_Emit is end Add_From_Statements; begin for Item of Unit.Types loop - Add_From_Info (Item); + if Item.Generic_Formals.Is_Empty then + Add_From_Info (Item); + end if; end loop; for Item of Unit.Objects loop Add_From_Info (Item.Type_Info); @@ -18668,7 +18675,9 @@ package body Safe_Frontend.Ada_Emit is end if; for Subprogram of Unit.Subprograms loop - if not Subprogram.Is_Interface_Template then + if not Subprogram.Is_Interface_Template + and then not Subprogram.Is_Generic_Template + then declare Name_Text : constant String := FT.To_String (Subprogram.Name); begin @@ -19053,7 +19062,9 @@ package body Safe_Frontend.Ada_Emit is end if; for Type_Item of Unit.Types loop - if FT.To_String (Type_Item.Kind) /= "interface" then + if Type_Item.Generic_Formals.Is_Empty + and then FT.To_String (Type_Item.Kind) /= "interface" + then Append_Line (Spec_Inner, Render_Type_Decl (Unit, Document, Type_Item, State), 1); if FT.To_String (Type_Item.Kind) = "record" then Append_Line (Spec_Inner); @@ -19143,25 +19154,58 @@ package body Safe_Frontend.Ada_Emit is if not Unit.Subprograms.Is_Empty then for Subprogram of Unit.Subprograms loop - if not Subprogram.Is_Interface_Template then + if not Subprogram.Is_Interface_Template + and then not Subprogram.Is_Generic_Template + then declare Expression_Image : constant String := - Render_Expression_Function_Image - (Unit, Document, Subprogram, State); + (if Subprogram.Force_Body_Emission + then "" + else + Render_Expression_Function_Image + (Unit, Document, Subprogram, State)); begin - Append_Line - (Spec_Inner, - Render_Ada_Subprogram_Keyword (Subprogram) - & " " - & FT.To_String (Subprogram.Name) - & Render_Subprogram_Params (Unit, Document, Subprogram.Params) - & Render_Subprogram_Return (Unit, Document, Subprogram) - & (if Expression_Image'Length > 0 - then " is (" & Expression_Image & ")" - else "") - & Render_Subprogram_Aspects (Unit, Document, Subprogram, Bronze, State) - & ";", - 1); + if Expression_Image'Length = 0 then + Append_Line + (Spec_Inner, + Render_Ada_Subprogram_Keyword (Subprogram) + & " " + & FT.To_String (Subprogram.Name) + & Render_Subprogram_Params (Unit, Document, Subprogram.Params) + & Render_Subprogram_Return (Unit, Document, Subprogram) + & Render_Subprogram_Aspects (Unit, Document, Subprogram, Bronze, State) + & ";", + 1); + end if; + end; + end if; + end loop; + + for Subprogram of Unit.Subprograms loop + if not Subprogram.Is_Interface_Template + and then not Subprogram.Is_Generic_Template + then + declare + Expression_Image : constant String := + (if Subprogram.Force_Body_Emission + then "" + else + Render_Expression_Function_Image + (Unit, Document, Subprogram, State)); + begin + if Expression_Image'Length > 0 then + Append_Line + (Spec_Inner, + Render_Ada_Subprogram_Keyword (Subprogram) + & " " + & FT.To_String (Subprogram.Name) + & Render_Subprogram_Params (Unit, Document, Subprogram.Params) + & Render_Subprogram_Return (Unit, Document, Subprogram) + & " is (" & Expression_Image & ")" + & Render_Subprogram_Aspects (Unit, Document, Subprogram, Bronze, State) + & ";", + 1); + end if; end; end if; end loop; @@ -19250,7 +19294,9 @@ package body Safe_Frontend.Ada_Emit is Append_Line (Body_Inner); for Type_Item of Unit.Types loop - if FT.To_String (Type_Item.Kind) /= "interface" then + if Type_Item.Generic_Formals.Is_Empty + and then FT.To_String (Type_Item.Kind) /= "interface" + then Render_Growable_Array_Helper_Body (Body_Inner, Unit, Document, Type_Item, State); end if; @@ -19300,7 +19346,10 @@ package body Safe_Frontend.Ada_Emit is for Subprogram of Unit.Subprograms loop if not Subprogram.Is_Interface_Template - and then Render_Expression_Function_Image (Unit, Document, Subprogram, State)'Length = 0 + and then not Subprogram.Is_Generic_Template + and then + (Subprogram.Force_Body_Emission + or else Render_Expression_Function_Image (Unit, Document, Subprogram, State)'Length = 0) then Render_Subprogram_Body (Body_Inner, Unit, Document, Subprogram, State); end if; diff --git a/compiler_impl/src/safe_frontend-check_emit.adb b/compiler_impl/src/safe_frontend-check_emit.adb index 885dd48..002b3c4 100644 --- a/compiler_impl/src/safe_frontend-check_emit.adb +++ b/compiler_impl/src/safe_frontend-check_emit.adb @@ -4,6 +4,7 @@ with Ada.Strings; with Ada.Strings.Fixed; with Ada.Strings.Unbounded; with Safe_Frontend.Json; +with Safe_Frontend.Source; with Safe_Frontend.Mir_Model; with Safe_Frontend.Types; @@ -11,6 +12,7 @@ package body Safe_Frontend.Check_Emit is package GM renames Safe_Frontend.Mir_Model; package FT renames Safe_Frontend.Types; package JS renames Safe_Frontend.Json; + package FS renames Safe_Frontend.Source; package US renames Ada.Strings.Unbounded; use type CM.Unit_Kind; @@ -27,6 +29,7 @@ package body Safe_Frontend.Check_Emit is use type CM.Type_Decl_Kind; use type CM.Type_Spec_Kind; use type CM.Type_Spec_Access; + use type FT.Source_Span; function Package_Item_Node (Item : CM.Package_Item; @@ -59,6 +62,10 @@ package body Safe_Frontend.Check_Emit is Span : FT.Source_Span) return String; function Subprogram_Spec_Node (Spec : CM.Subprogram_Spec) return String; + function Generic_Formals_Node + (Formals : CM.Generic_Formal_Vectors.Vector) return String; + function Generic_Arguments_Node + (Args : CM.Type_Spec_Access_Vectors.Vector) return String; function Operator_String (Value : FT.UString) return String is begin @@ -141,6 +148,48 @@ package body Safe_Frontend.Check_Emit is return US.To_String (Result); end Join_Object_Fields; + function Source_Slice + (Content : String; + Span : FT.Source_Span) return String + is + Line : Positive := 1; + Column : Positive := 1; + Start_Index : Natural := 0; + End_Index : Natural := 0; + begin + if Span = FT.Null_Span or else Content'Length = 0 then + return ""; + end if; + + for Index in Content'Range loop + if Start_Index = 0 + and then Line = Span.Start_Pos.Line + and then Column = Span.Start_Pos.Column + then + Start_Index := Index; + end if; + + if Line = Span.End_Pos.Line and then Column = Span.End_Pos.Column then + End_Index := Index; + end if; + + if Content (Index) = Ada.Characters.Latin_1.LF then + Line := Line + 1; + Column := 1; + else + Column := Column + 1; + end if; + end loop; + + if Start_Index = 0 then + return ""; + elsif End_Index = 0 then + End_Index := Content'Last; + end if; + + return Content (Start_Index .. End_Index); + end Source_Slice; + function Quoted_Names (Names : FT.UString_Vectors.Vector) return String is Result : String_Vectors.Vector; begin @@ -190,8 +239,10 @@ package body Safe_Frontend.Check_Emit is end Package_Name_Node; function Name_From_String - (Name : String; - Span : FT.Source_Span) return String + (Name : String; + Span : FT.Source_Span; + Generic_Args : CM.Type_Spec_Access_Vectors.Vector := + CM.Type_Spec_Access_Vectors.Empty_Vector) return String is Parts : String_Vectors.Vector; Start : Positive := Name'First; @@ -199,7 +250,7 @@ package body Safe_Frontend.Check_Emit is begin if Name'Length = 0 then return - "{""node_type"":""DirectName"",""identifier"":"""",""span"":" + "{""node_type"":""DirectName"",""identifier"":"""",""generic_arguments"":null,""span"":" & JS.Span_Object (Span) & "}"; end if; @@ -220,6 +271,10 @@ package body Safe_Frontend.Check_Emit is US.To_Unbounded_String ("{""node_type"":""DirectName"",""identifier"":" & JS.Quote (Parts (Parts.First_Index)) + & ",""generic_arguments"":" + & (if Natural (Parts.Length) = 1 and then not Generic_Args.Is_Empty + then Generic_Arguments_Node (Generic_Args) + else "null") & ",""span"":" & JS.Span_Object (Span) & "}"); @@ -232,6 +287,10 @@ package body Safe_Frontend.Check_Emit is & US.To_String (Result) & ",""selector"":" & JS.Quote (Parts (Index)) + & ",""generic_arguments"":" + & (if Index = Parts.Last_Index and then not Generic_Args.Is_Empty + then Generic_Arguments_Node (Generic_Args) + else "null") & ",""resolved_kind"":null,""span"":" & JS.Span_Object (Span) & "}"); @@ -240,6 +299,53 @@ package body Safe_Frontend.Check_Emit is return US.To_String (Result); end Name_From_String; + function Generic_Formals_Node + (Formals : CM.Generic_Formal_Vectors.Vector) return String + is + Items : String_Vectors.Vector; + begin + if not Formals.Is_Empty then + for Formal of Formals loop + Items.Append + ("{""node_type"":""GenericFormal"",""name"":" + & JS.Quote (Formal.Name) + & ",""constraint_name"":" + & (if Formal.Has_Constraint + then Name_From_String + (FT.To_String (Formal.Constraint_Name), + Formal.Span) + else "null") + & ",""span"":" + & JS.Span_Object (Formal.Span) + & "}"); + end loop; + end if; + return Json_List (Items); + end Generic_Formals_Node; + + function Generic_Arguments_Node + (Args : CM.Type_Spec_Access_Vectors.Vector) return String + is + Items : String_Vectors.Vector; + begin + if not Args.Is_Empty then + for Arg of Args loop + Items.Append (Object_Type_Node (Arg.all)); + end loop; + end if; + return Json_List (Items); + end Generic_Arguments_Node; + + function Generic_Formals_Field + (Formals : CM.Generic_Formal_Vectors.Vector) return String is + begin + return + ",""generic_formals"":" + & (if Formals.Is_Empty + then "null" + else Generic_Formals_Node (Formals)); + end Generic_Formals_Field; + function Name_Node (Expr : CM.Expr_Access) return String; function Type_Target_Node (Expr : CM.Expr_Access) return String; function Subtype_Mark_Node (Spec : CM.Type_Spec) return String; @@ -291,6 +397,9 @@ package body Safe_Frontend.Check_Emit is return "{""node_type"":""DirectName"",""identifier"":" & JS.Quote (Expr.Name) + & ",""generic_arguments"":" + & (if Expr.Generic_Args.Is_Empty then "null" + else Generic_Arguments_Node (Expr.Generic_Args)) & ",""span"":" & JS.Span_Object (Expr.Span) & "}"; @@ -300,6 +409,9 @@ package body Safe_Frontend.Check_Emit is & Name_Node (Expr.Prefix) & ",""selector"":" & JS.Quote (Expr.Selector) + & ",""generic_arguments"":" + & (if Expr.Generic_Args.Is_Empty then "null" + else Generic_Arguments_Node (Expr.Generic_Args)) & ",""resolved_kind"":" & Selector_Kind & ",""span"":" @@ -456,7 +568,8 @@ package body Safe_Frontend.Check_Emit is elsif Bit_Width /= 0 then return Binary_Type_Definition_Node (Positive (Bit_Width), Spec.Span); end if; - return Name_From_String (FT.To_String (Spec.Name), Spec.Span); + return Name_From_String + (FT.To_String (Spec.Name), Spec.Span, Spec.Generic_Args); end Subtype_Mark_Node; function Constraint_Node @@ -1247,6 +1360,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""span"":" & JS.Span_Object (Decl.Span) & "}"; @@ -1256,6 +1370,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""SignedIntegerTypeDefinition"",""low_bound"":" @@ -1273,6 +1388,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":" @@ -1286,6 +1402,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""FloatingPointDefinition"",""digits_expr"":" @@ -1314,6 +1431,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""EnumerationTypeDefinition"",""enumerators"":" @@ -1340,6 +1458,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""ConstrainedArrayDefinition"",""index_ranges"":" @@ -1367,6 +1486,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""UnconstrainedArrayDefinition"",""index_subtypes"":" @@ -1386,6 +1506,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""GrowableArrayDefinition"",""element_type"":" @@ -1409,6 +1530,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":null,""type_definition"":{""node_type"":""InterfaceTypeDefinition"",""members"":" & Json_List (Members) & ",""span"":" @@ -1426,6 +1548,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""RecordTypeDefinition""" @@ -1449,6 +1572,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":" @@ -1462,6 +1586,7 @@ package body Safe_Frontend.Check_Emit is & JS.Bool_Literal (Decl.Is_Public) & ",""name"":" & JS.Quote (Decl.Name) + & Generic_Formals_Field (Decl.Generic_Formals) & ",""discriminant_part"":" & Discriminant_Part_Node (Decl) & ",""type_definition"":{""node_type"":""SignedIntegerTypeDefinition"",""low_bound"":" @@ -2037,6 +2162,10 @@ package body Safe_Frontend.Check_Emit is return "{""node_type"":""FunctionSpecification"",""name"":" & JS.Quote (Spec.Name) + & ",""generic_formals"":" + & (if Spec.Generic_Formals.Is_Empty + then "null" + else Generic_Formals_Node (Spec.Generic_Formals)) & ",""receiver"":" & (if Spec.Has_Receiver then Parameter_Spec_Node (Spec.Receiver) @@ -2054,6 +2183,10 @@ package body Safe_Frontend.Check_Emit is return "{""node_type"":""ProcedureSpecification"",""name"":" & JS.Quote (Spec.Name) + & ",""generic_formals"":" + & (if Spec.Generic_Formals.Is_Empty + then "null" + else Generic_Formals_Node (Spec.Generic_Formals)) & ",""receiver"":" & (if Spec.Has_Receiver then Parameter_Spec_Node (Spec.Receiver) @@ -2263,6 +2396,9 @@ package body Safe_Frontend.Check_Emit is Kind => Item.Subp_Data.Spec.Kind, Is_Synthetic => False, Is_Interface_Template => False, + Is_Generic_Template => False, + Force_Body_Emission => False, + Generic_Formals => <>, Params => <>, Has_Return_Type => False, Return_Type => <>, @@ -2410,7 +2546,10 @@ package body Safe_Frontend.Check_Emit is begin if not Resolved.Subprograms.Is_Empty then for Subp of Resolved.Subprograms loop - if not Subp.Is_Interface_Template and then not Subp.Is_Synthetic then + if not Subp.Is_Interface_Template + and then not Subp.Is_Generic_Template + and then not Subp.Is_Synthetic + then Items.Append ("{""name"":" & JS.Quote (Subp.Name) @@ -2690,6 +2829,25 @@ package body Safe_Frontend.Check_Emit is Items : String_Vectors.Vector; Subprogram_Index : Natural := 0; Params : String_Vectors.Vector; + Source_Path : constant String := FT.To_String (Parsed.Path); + Source_Content : constant String := + (if Source_Path'Length = 0 + then "" + else FT.To_String (FS.Load (Source_Path).Content)); + function Generic_Formal_Json + (Formal : CM.Generic_Formal) return String is + begin + return + "{""name"":" + & JS.Quote (Formal.Name) + & ",""has_constraint"":" + & JS.Bool_Literal (Formal.Has_Constraint) + & ",""constraint_name"":" + & (if Formal.Has_Constraint + then JS.Quote (Formal.Constraint_Name) + else "null") + & "}"; + end Generic_Formal_Json; begin for Item of Parsed.Items loop if Item.Kind = CM.Item_Subprogram then @@ -2705,22 +2863,35 @@ package body Safe_Frontend.Check_Emit is for Param of Subp.Params loop Params.Append (Param_Json (Param)); end loop; - Items.Append - ("{""name"":" - & JS.Quote (Subp.Name) - & ",""kind"":" - & JS.Quote (Subp.Kind) - & ",""signature"":" - & JS.Quote (Signature_For (Subp)) - & ",""params"":" - & Json_List (Params) - & ",""has_return_type"":" - & JS.Bool_Literal (Subp.Has_Return_Type) - & ",""return_type"":" - & (if Subp.Has_Return_Type then Type_Json (Subp.Return_Type) else "null") - & ",""span"":" - & JS.Span_Object (Subp.Span) - & "}"); + declare + Fields : String_Vectors.Vector; + begin + Fields.Append ("""name"":" & JS.Quote (Subp.Name)); + Fields.Append ("""kind"":" & JS.Quote (Subp.Kind)); + Fields.Append ("""signature"":" & JS.Quote (Signature_For (Subp))); + Fields.Append ("""params"":" & Json_List (Params)); + Fields.Append ("""has_return_type"":" & JS.Bool_Literal (Subp.Has_Return_Type)); + Fields.Append + ("""return_type"":" + & (if Subp.Has_Return_Type then Type_Json (Subp.Return_Type) else "null")); + if Subp.Is_Generic_Template then + declare + Formals : String_Vectors.Vector; + Source : constant String := + Source_Slice (Source_Content, Item.Subp_Data.Span); + begin + if not Item.Subp_Data.Spec.Generic_Formals.Is_Empty then + for Formal of Item.Subp_Data.Spec.Generic_Formals loop + Formals.Append (Generic_Formal_Json (Formal)); + end loop; + end if; + Fields.Append ("""generic_formals"":" & Json_List (Formals)); + Fields.Append ("""template_source"":" & JS.Quote (Source)); + end; + end if; + Fields.Append ("""span"":" & JS.Span_Object (Subp.Span)); + Items.Append ("{" & Join_Object_Fields (Fields) & "}"); + end; end; end if; end if; @@ -2885,6 +3056,21 @@ package body Safe_Frontend.Check_Emit is Fields : String_Vectors.Vector; begin declare + function Generic_Formal_Json + (Formal : GM.Generic_Formal_Descriptor) return String is + begin + return + "{""name"":" + & JS.Quote (Formal.Name) + & ",""has_constraint"":" + & JS.Bool_Literal (Formal.Has_Constraint) + & ",""constraint_name"":" + & (if Formal.Has_Constraint + then JS.Quote (Formal.Constraint_Name) + else "null") + & "}"; + end Generic_Formal_Json; + function Signature_Param_Json (Param : GM.Signature_Param) return String is begin @@ -3025,6 +3211,29 @@ package body Safe_Frontend.Check_Emit is Items.Append ("""interface_members"":" & Json_List (Members)); end; end if; + if not Info.Generic_Formals.Is_Empty then + declare + Formals : String_Vectors.Vector; + begin + for Formal of Info.Generic_Formals loop + Formals.Append (Generic_Formal_Json (Formal)); + end loop; + Items.Append ("""generic_formals"":" & Json_List (Formals)); + end; + end if; + if Info.Has_Generic_Origin then + Items.Append ("""generic_origin"":" & JS.Quote (Info.Generic_Origin)); + end if; + if not Info.Generic_Actual_Types.Is_Empty then + declare + Actuals : String_Vectors.Vector; + begin + for Item of Info.Generic_Actual_Types loop + Actuals.Append (JS.Quote (Item)); + end loop; + Items.Append ("""generic_actual_types"":" & Json_List (Actuals)); + end; + end if; if Info.Has_Target then Items.Append ("""target"":" & JS.Quote (Info.Target)); end if; @@ -3228,7 +3437,7 @@ package body Safe_Frontend.Check_Emit is begin return "{" - & """format"":""typed-v5""," + & """format"":""typed-v6""," & """target_bits"":" & Positive'Image (Resolved.Target_Bits) & "," & """unit_kind"":" & JS.Quote ((if Parsed.Kind = CM.Unit_Entry then "entry" else "package")) @@ -3267,7 +3476,7 @@ package body Safe_Frontend.Check_Emit is begin return "{" - & """format"":""safei-v4""," + & """format"":""safei-v5""," & """target_bits"":" & Positive'Image (Resolved.Target_Bits) & "," & """unit_kind"":" & JS.Quote ((if Parsed.Kind = CM.Unit_Entry then "entry" else "package")) diff --git a/compiler_impl/src/safe_frontend-check_lower.adb b/compiler_impl/src/safe_frontend-check_lower.adb index c11d209..580b45a 100644 --- a/compiler_impl/src/safe_frontend-check_lower.adb +++ b/compiler_impl/src/safe_frontend-check_lower.adb @@ -3086,7 +3086,9 @@ package body Safe_Frontend.Check_Lower is end if; for Subprogram of Unit.Subprograms loop - if not Subprogram.Is_Interface_Template then + if not Subprogram.Is_Interface_Template + and then not Subprogram.Is_Generic_Template + then Result.Graphs.Append (Lower_Subprogram (Subprogram, diff --git a/compiler_impl/src/safe_frontend-check_model.ads b/compiler_impl/src/safe_frontend-check_model.ads index 1d68c8d..5503883 100644 --- a/compiler_impl/src/safe_frontend-check_model.ads +++ b/compiler_impl/src/safe_frontend-check_model.ads @@ -13,6 +13,10 @@ package Safe_Frontend.Check_Model is type Type_Spec; type Type_Spec_Access is access all Type_Spec; + package Type_Spec_Access_Vectors is new Ada.Containers.Indefinite_Vectors + (Index_Type => Positive, + Element_Type => Type_Spec_Access); + type Expr_Kind is (Expr_Unknown, Expr_Int, @@ -80,14 +84,22 @@ package Safe_Frontend.Check_Model is Args : Expr_Access_Vectors.Vector; Fields : Aggregate_Field_Vectors.Vector; Elements : Expr_Access_Vectors.Vector; + Generic_Args : Type_Spec_Access_Vectors.Vector; Subtype_Spec : Type_Spec_Access := null; Has_Call_Span : Boolean := False; Call_Span : FT.Source_Span := FT.Null_Span; end record; - package Type_Spec_Access_Vectors is new Ada.Containers.Indefinite_Vectors + type Generic_Formal is record + Name : FT.UString := FT.To_UString (""); + Has_Constraint : Boolean := False; + Constraint_Name : FT.UString := FT.To_UString (""); + Span : FT.Source_Span := FT.Null_Span; + end record; + + package Generic_Formal_Vectors is new Ada.Containers.Indefinite_Vectors (Index_Type => Positive, - Element_Type => Type_Spec_Access); + Element_Type => Generic_Formal); type Type_Spec_Kind is (Type_Spec_Unknown, @@ -126,6 +138,7 @@ package Safe_Frontend.Check_Model is Key_Type : Type_Spec_Access := null; Value_Type : Type_Spec_Access := null; Tuple_Elements : Type_Spec_Access_Vectors.Vector; + Generic_Args : Type_Spec_Access_Vectors.Vector; Has_Range_Constraint : Boolean := False; Range_Low : Expr_Access := null; Range_High : Expr_Access := null; @@ -156,6 +169,7 @@ package Safe_Frontend.Check_Model is type Subprogram_Spec is record Kind : FT.UString := FT.To_UString (""); Name : FT.UString := FT.To_UString (""); + Generic_Formals : Generic_Formal_Vectors.Vector; Has_Receiver : Boolean := False; Receiver : Parameter_Spec; Params : Parameter_Vectors.Vector; @@ -265,6 +279,7 @@ package Safe_Frontend.Check_Model is type Type_Decl is record Is_Public : Boolean := False; Name : FT.UString := FT.To_UString (""); + Generic_Formals : Generic_Formal_Vectors.Vector; Kind : Type_Decl_Kind := Type_Decl_Unknown; Span : FT.Source_Span := FT.Null_Span; Digits_Expr : Expr_Access := null; @@ -553,6 +568,9 @@ package Safe_Frontend.Check_Model is Kind : FT.UString := FT.To_UString (""); Is_Synthetic : Boolean := False; Is_Interface_Template : Boolean := False; + Is_Generic_Template : Boolean := False; + Force_Body_Emission : Boolean := False; + Generic_Formals : Generic_Formal_Vectors.Vector; Params : Symbol_Vectors.Vector; Has_Return_Type : Boolean := False; Return_Type : GM.Type_Descriptor; diff --git a/compiler_impl/src/safe_frontend-check_parse.adb b/compiler_impl/src/safe_frontend-check_parse.adb index 880fd33..344d9d1 100644 --- a/compiler_impl/src/safe_frontend-check_parse.adb +++ b/compiler_impl/src/safe_frontend-check_parse.adb @@ -628,13 +628,23 @@ package body Safe_Frontend.Check_Parse is function Parse_Type_Spec_Internal (State : in out Parser_State; - Allow_Access_Def : Boolean) return CM.Type_Spec; + Allow_Access_Def : Boolean; + Allow_Constraints : Boolean := True) return CM.Type_Spec; function Parse_Subprogram_Spec (State : in out Parser_State) return CM.Subprogram_Spec; + function Parse_Generic_Formals + (State : in out Parser_State) return CM.Generic_Formal_Vectors.Vector; + + function Parse_Generic_Args + (State : in out Parser_State; + Allow_Access_Def : Boolean := False; + Allow_Constraints : Boolean := True) return CM.Type_Spec_Access_Vectors.Vector; + function Parse_Growable_Array_Type_Spec - (State : in out Parser_State) return CM.Type_Spec + (State : in out Parser_State; + Allow_Constraints : Boolean := True) return CM.Type_Spec is Start : constant FL.Token := Expect (State, "array"); Result : CM.Type_Spec; @@ -643,13 +653,17 @@ package body Safe_Frontend.Check_Parse is Result.Kind := CM.Type_Spec_Growable_Array; Result.Element_Type := new CM.Type_Spec' - (Parse_Type_Spec_Internal (State, Allow_Access_Def => True)); + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => True, + Allow_Constraints => Allow_Constraints)); Result.Span := CM.Join (Start.Span, Result.Element_Type.Span); return Result; end Parse_Growable_Array_Type_Spec; function Parse_List_Type_Spec - (State : in out Parser_State) return CM.Type_Spec + (State : in out Parser_State; + Allow_Constraints : Boolean := True) return CM.Type_Spec is Start : constant FL.Token := Expect (State, "list"); Result : CM.Type_Spec; @@ -658,13 +672,17 @@ package body Safe_Frontend.Check_Parse is Result.Kind := CM.Type_Spec_List; Result.Element_Type := new CM.Type_Spec' - (Parse_Type_Spec_Internal (State, Allow_Access_Def => True)); + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => True, + Allow_Constraints => Allow_Constraints)); Result.Span := CM.Join (Start.Span, Result.Element_Type.Span); return Result; end Parse_List_Type_Spec; function Parse_Map_Type_Spec - (State : in out Parser_State) return CM.Type_Spec + (State : in out Parser_State; + Allow_Constraints : Boolean := True) return CM.Type_Spec is Start : constant FL.Token := Expect (State, "map"); Result : CM.Type_Spec; @@ -677,11 +695,17 @@ package body Safe_Frontend.Check_Parse is Result.Kind := CM.Type_Spec_Map; Result.Key_Type := new CM.Type_Spec' - (Parse_Type_Spec_Internal (State, Allow_Access_Def => True)); + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => True, + Allow_Constraints => Allow_Constraints)); Require (State, ","); Result.Value_Type := new CM.Type_Spec' - (Parse_Type_Spec_Internal (State, Allow_Access_Def => True)); + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => True, + Allow_Constraints => Allow_Constraints)); Ender := Expect (State, ")"); Result.Span := CM.Join (Start.Span, Ender.Span); return Result; @@ -724,7 +748,18 @@ package body Safe_Frontend.Check_Parse is begin case Spec.Kind is when CM.Type_Spec_Name | CM.Type_Spec_Subtype_Indication | CM.Type_Spec_Binary => - return Spec.Name; + Result := Spec.Name; + if not Spec.Generic_Args.Is_Empty then + for Item of Spec.Generic_Args loop + Result := + Result + & FT.To_UString ("_") + & FT.To_UString + (Sanitize_Type_Name_Component + (FT.To_String (Type_Spec_Internal_Name (Item.all)))); + end loop; + end if; + return Result; when CM.Type_Spec_List | CM.Type_Spec_Growable_Array => if Spec.Element_Type = null then return FT.To_UString ("__growable_array_value"); @@ -772,9 +807,119 @@ package body Safe_Frontend.Check_Parse is end case; end Type_Spec_Internal_Name; + function Parse_Generic_Formals + (State : in out Parser_State) return CM.Generic_Formal_Vectors.Vector + is + Result : CM.Generic_Formal_Vectors.Vector; + Item : CM.Generic_Formal; + begin + Require (State, "of"); + if Match (State, "(") then + loop + declare + Name : constant FL.Token := Expect_Identifier (State); + begin + Item := (others => <>); + Item.Name := Name.Lexeme; + Item.Span := Name.Span; + Result.Append (Item); + end; + exit when not Match (State, ","); + end loop; + Require (State, ")"); + else + declare + Name : constant FL.Token := Expect_Identifier (State); + begin + Item.Name := Name.Lexeme; + Item.Span := Name.Span; + Result.Append (Item); + end; + end if; + + if Match (State, "with") then + loop + declare + Constraint_Name : constant FL.Token := Expect_Identifier (State); + Matched : Boolean := False; + begin + Require (State, ":"); + declare + Interface_Name : constant CM.Expr_Access := Parse_Package_Name (State); + begin + for Index in Result.First_Index .. Result.Last_Index loop + declare + Formal : CM.Generic_Formal := Result (Index); + begin + if FT.Lowercase (FT.To_String (Formal.Name)) = + FT.Lowercase (FT.To_String (Constraint_Name.Lexeme)) + then + if Formal.Has_Constraint then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Constraint_Name.Span, + Message => "duplicate generic constraint for `" & FT.To_String (Formal.Name) & "`")); + end if; + Formal.Has_Constraint := True; + Formal.Constraint_Name := FT.To_UString (Name_To_String (Interface_Name)); + Formal.Span := CM.Join (Constraint_Name.Span, Interface_Name.Span); + Result.Replace_Element (Index, Formal); + Matched := True; + exit; + end if; + end; + end loop; + end; + if not Matched then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Constraint_Name.Span, + Message => "unknown generic formal `" & FT.To_String (Constraint_Name.Lexeme) & "` in constraint map")); + end if; + end; + exit when not Match (State, ","); + end loop; + end if; + + return Result; + end Parse_Generic_Formals; + + function Parse_Generic_Args + (State : in out Parser_State; + Allow_Access_Def : Boolean := False; + Allow_Constraints : Boolean := True) return CM.Type_Spec_Access_Vectors.Vector + is + Result : CM.Type_Spec_Access_Vectors.Vector; + begin + Require (State, "of"); + if Match (State, "(") then + loop + Result.Append + (new CM.Type_Spec' + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => Allow_Access_Def, + Allow_Constraints => Allow_Constraints))); + exit when not Match (State, ","); + end loop; + Require (State, ")"); + else + Result.Append + (new CM.Type_Spec' + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => Allow_Access_Def, + Allow_Constraints => Allow_Constraints))); + end if; + return Result; + end Parse_Generic_Args; + function Parse_Optional_Type_Spec (State : in out Parser_State; - Allow_Access_Def : Boolean) return CM.Type_Spec + Allow_Access_Def : Boolean; + Allow_Constraints : Boolean := True) return CM.Type_Spec is Start : constant FL.Token := Expect (State, "optional"); Result : CM.Type_Spec; @@ -782,7 +927,10 @@ package body Safe_Frontend.Check_Parse is Result.Kind := CM.Type_Spec_Optional; Result.Element_Type := new CM.Type_Spec' - (Parse_Type_Spec_Internal (State, Allow_Access_Def => Allow_Access_Def)); + (Parse_Type_Spec_Internal + (State, + Allow_Access_Def => Allow_Access_Def, + Allow_Constraints => Allow_Constraints)); Result.Name := Type_Spec_Internal_Name (Result); Result.Span := CM.Join (Start.Span, Result.Element_Type.Span); return Result; @@ -790,11 +938,13 @@ package body Safe_Frontend.Check_Parse is function Parse_Object_Type_Core (State : in out Parser_State; - Allow_Access_Def : Boolean := False) return CM.Type_Spec; + Allow_Access_Def : Boolean := False; + Allow_Constraints : Boolean := True) return CM.Type_Spec; function Parse_Tuple_Type_Spec (State : in out Parser_State; - Allow_Access_Def : Boolean) return CM.Type_Spec + Allow_Access_Def : Boolean; + Allow_Constraints : Boolean := True) return CM.Type_Spec is Start : constant FL.Token := Expect (State, "("); Result : CM.Type_Spec; @@ -804,7 +954,10 @@ package body Safe_Frontend.Check_Parse is loop declare Element : constant CM.Type_Spec := - Parse_Type_Spec_Internal (State, Allow_Access_Def); + Parse_Type_Spec_Internal + (State, + Allow_Access_Def => Allow_Access_Def, + Allow_Constraints => Allow_Constraints); begin Result.Tuple_Elements.Append (new CM.Type_Spec'(Element)); end; @@ -873,7 +1026,8 @@ package body Safe_Frontend.Check_Parse is function Parse_Named_Type_Spec (State : in out Parser_State; - Kind : CM.Type_Spec_Kind) return CM.Type_Spec + Kind : CM.Type_Spec_Kind; + Allow_Constraints : Boolean := True) return CM.Type_Spec is Name_Expr : constant CM.Expr_Access := Parse_Package_Name (State); Result : CM.Type_Spec; @@ -882,7 +1036,15 @@ package body Safe_Frontend.Check_Parse is Result.Kind := Kind; Result.Name := FT.To_UString (Name_To_String (Name_Expr)); - if FT.To_String (Current (State).Lexeme) = "(" then + if Current_Lower (State) = "of" then + Result.Generic_Args := + Parse_Generic_Args + (State, + Allow_Access_Def => Kind /= CM.Type_Spec_Subtype_Indication, + Allow_Constraints => Allow_Constraints); + end if; + + if Allow_Constraints and then FT.To_String (Current (State).Lexeme) = "(" then declare Start_Paren : constant FL.Token := Expect (State, "("); Assoc : CM.Constraint_Association; @@ -949,7 +1111,8 @@ package body Safe_Frontend.Check_Parse is function Parse_Object_Type_Core (State : in out Parser_State; - Allow_Access_Def : Boolean := False) return CM.Type_Spec + Allow_Access_Def : Boolean := False; + Allow_Constraints : Boolean := True) return CM.Type_Spec is begin if Current_Lower (State) = "aliased" then @@ -963,26 +1126,46 @@ package body Safe_Frontend.Check_Parse is elsif Current_Lower (State) = "binary" then return Parse_Binary_Type_Spec (State); elsif Current_Lower (State) = "optional" then - return Parse_Optional_Type_Spec (State, Allow_Access_Def); + return + Parse_Optional_Type_Spec + (State, + Allow_Access_Def, + Allow_Constraints => Allow_Constraints); elsif Current_Lower (State) = "list" then - return Parse_List_Type_Spec (State); + return Parse_List_Type_Spec (State, Allow_Constraints => Allow_Constraints); elsif Current_Lower (State) = "map" then - return Parse_Map_Type_Spec (State); + return Parse_Map_Type_Spec (State, Allow_Constraints => Allow_Constraints); elsif Current_Lower (State) = "array" and then FT.To_String (Next (State).Lexeme) /= "(" then - return Parse_Growable_Array_Type_Spec (State); + return + Parse_Growable_Array_Type_Spec + (State, + Allow_Constraints => Allow_Constraints); elsif FT.To_String (Current (State).Lexeme) = "(" then - return Parse_Tuple_Type_Spec (State, Allow_Access_Def); + return + Parse_Tuple_Type_Spec + (State, + Allow_Access_Def, + Allow_Constraints => Allow_Constraints); end if; - return Parse_Named_Type_Spec (State, CM.Type_Spec_Name); + return + Parse_Named_Type_Spec + (State, + CM.Type_Spec_Name, + Allow_Constraints => Allow_Constraints); end Parse_Object_Type_Core; function Parse_Type_Spec_Internal (State : in out Parser_State; - Allow_Access_Def : Boolean) return CM.Type_Spec is + Allow_Access_Def : Boolean; + Allow_Constraints : Boolean := True) return CM.Type_Spec is begin - return Parse_Object_Type_Core (State, Allow_Access_Def); + return + Parse_Object_Type_Core + (State, + Allow_Access_Def, + Allow_Constraints => Allow_Constraints); end Parse_Type_Spec_Internal; function Parse_Object_Type @@ -1348,6 +1531,10 @@ package body Safe_Frontend.Check_Parse is Item.Is_Public := Is_Public; Item.Name := Name.Lexeme; + if Current_Lower (State) = "of" then + Item.Generic_Formals := Parse_Generic_Formals (State); + end if; + if Current (State).Lexeme = FT.To_UString ("(") then Item.Discriminants := Parse_Discriminant_Spec_List (State); Item.Has_Discriminant := not Item.Discriminants.Is_Empty; @@ -1587,6 +1774,10 @@ package body Safe_Frontend.Check_Parse is Name := Expect_Identifier (State); Result.Name := Name.Lexeme; + if Current_Lower (State) = "of" then + Result.Generic_Formals := Parse_Generic_Formals (State); + end if; + if Match (State, "(") then loop Result.Params.Append (Parse_Parameter (State)); @@ -3160,6 +3351,19 @@ package body Safe_Frontend.Check_Parse is Span => Current (State).Span, Message => "expected field selector after `.`")); end if; + elsif Current_Lower (State) = "of" then + if not Result.Generic_Args.Is_Empty then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Current (State).Span, + Message => "duplicate generic argument list")); + end if; + Result.Generic_Args := + Parse_Generic_Args + (State, + Allow_Access_Def => False, + Allow_Constraints => False); elsif FT.To_String (Current (State).Lexeme) = "(" then Open_Tok := Expect (State, "("); Next_Result := New_Expr; diff --git a/compiler_impl/src/safe_frontend-check_resolve.adb b/compiler_impl/src/safe_frontend-check_resolve.adb index 57e1634..c9035d9 100644 --- a/compiler_impl/src/safe_frontend-check_resolve.adb +++ b/compiler_impl/src/safe_frontend-check_resolve.adb @@ -1,13 +1,21 @@ +with Ada.Characters.Latin_1; with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Containers.Indefinite_Vectors; with Ada.Strings.Fixed; with Ada.Strings.Hash; with System; with Safe_Frontend.Builtin_Types; +with Safe_Frontend.Check_Parse; +with Safe_Frontend.Diagnostics; with Safe_Frontend.Interfaces; +with Safe_Frontend.Lexer; with Safe_Frontend.Mir_Model; +with Safe_Frontend.Source; package body Safe_Frontend.Check_Resolve is package BT renames Safe_Frontend.Builtin_Types; + package CP renames Safe_Frontend.Check_Parse; + package FD renames Safe_Frontend.Diagnostics; + package FL renames Safe_Frontend.Lexer; package GM renames Safe_Frontend.Mir_Model; package SI renames Safe_Frontend.Interfaces; @@ -30,6 +38,7 @@ package body Safe_Frontend.Check_Resolve is type Function_Info is record Name : FT.UString := FT.To_UString (""); Kind : FT.UString := FT.To_UString (""); + Generic_Formals : CM.Generic_Formal_Vectors.Vector; Params : CM.Symbol_Vectors.Vector; Has_Return_Type : Boolean := False; Return_Type : GM.Type_Descriptor; @@ -42,12 +51,37 @@ package body Safe_Frontend.Check_Resolve is Info : Function_Info; end record; + type Generic_Type_Template_Info is record + Has_Decl : Boolean := False; + Decl : CM.Type_Decl; + Info : GM.Type_Descriptor; + end record; + + type Generic_Function_Template_Info is record + Decl : CM.Subprogram_Body; + Info : Function_Info; + Origin_Package : FT.UString := FT.To_UString (""); + Actual_Type_Names : FT.UString_Vectors.Vector; + end record; + package Interface_Template_Maps is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, Element_Type => Interface_Template_Info, Hash => Ada.Strings.Hash, Equivalent_Keys => "="); + package Generic_Type_Template_Maps is new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => Generic_Type_Template_Info, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "="); + + package Generic_Function_Template_Maps is new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => Generic_Function_Template_Info, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "="); + package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, Element_Type => String, @@ -139,7 +173,17 @@ package body Safe_Frontend.Check_Resolve is Current_Pending_Interface_Specializations : Interface_Template_Maps.Map; Current_Interface_Specialization_Order : String_Vectors.Vector; Current_Interface_Specialization_By_Key : String_Maps.Map; + Current_Generic_Type_Templates : Generic_Type_Template_Maps.Map; + Current_Generic_Type_Instantiation_Order : String_Vectors.Vector; + Current_Generic_Type_Instantiation_By_Key : String_Maps.Map; + Current_Generic_Type_Instantiations : Type_Maps.Map; + Current_Generic_Type_Instantiation_Stack : String_Vectors.Vector; + Current_Generic_Function_Templates : Generic_Function_Template_Maps.Map; + Current_Pending_Generic_Specializations : Generic_Function_Template_Maps.Map; + Current_Generic_Specialization_Order : String_Vectors.Vector; + Current_Generic_Specialization_By_Key : String_Maps.Map; Current_Synthetic_Functions : Function_Maps.Map; + Current_Generic_Function_Env : Function_Maps.Map; function UString_Value (Value : FT.UString) return String is begin @@ -160,6 +204,7 @@ package body Safe_Frontend.Check_Resolve is return Type_Env.Contains (Canonical_Name (Name)) or else Synthetic_Helper_Types.Contains (Canonical_Name (Name)) or else Synthetic_Optional_Types.Contains (Canonical_Name (Name)) + or else Current_Generic_Type_Instantiations.Contains (Canonical_Name (Name)) or else (Name'Length >= Bounded_String_Prefix'Length and then @@ -598,6 +643,10 @@ package body Safe_Frontend.Check_Resolve is (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return Boolean; + function Is_Generic_Formal_Type + (Info : GM.Type_Descriptor; + Type_Env : Type_Maps.Map) return Boolean; + function Optional_Payload_Type (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return GM.Type_Descriptor; @@ -659,6 +708,81 @@ package body Safe_Frontend.Check_Resolve is Const_Env : Static_Value_Maps.Map; Path : String) return Function_Info; + function Generic_Formal_Type + (Formal : CM.Generic_Formal) return GM.Type_Descriptor; + + function Generic_Formal_Descriptor + (Formal : CM.Generic_Formal) return GM.Generic_Formal_Descriptor; + + procedure Add_Generic_Formals_To_Env + (Type_Env : in out Type_Maps.Map; + Formals : CM.Generic_Formal_Vectors.Vector); + + function Is_Generic_Actual_Type_Allowed + (Info : GM.Type_Descriptor; + Type_Env : Type_Maps.Map) return Boolean; + + procedure Validate_Generic_Actuals + (Formals : CM.Generic_Formal_Vectors.Vector; + Actual_Types : FT.UString_Vectors.Vector; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map; + Path : String; + Span : FT.Source_Span); + + function Generic_Template_Key + (Name : String; + Actual_Types : FT.UString_Vectors.Vector) return String; + + function Generic_Specialization_Name + (Prefix : String; + Name : String; + Actual_Types : FT.UString_Vectors.Vector) return String; + + function Method_Target_Tail_Name (Name : String) return String; + + function Type_Satisfies_Interface + (Concrete_Type : GM.Type_Descriptor; + Interface_Type : GM.Type_Descriptor; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map) return Boolean; + + function Substitute_Generic_Type_Info + (Template : GM.Type_Descriptor; + Formals : GM.Generic_Formal_Descriptor_Vectors.Vector; + Actual_Types : FT.UString_Vectors.Vector) return GM.Type_Descriptor; + + function Parse_Imported_Generic_Subprogram + (Package_Name : String; + Qualified_Name : String; + Template_Source : String) return CM.Subprogram_Body; + + procedure Add_Imported_Package_Local_Aliases + (Package_Name : String; + Imported_Types : GM.Type_Descriptor_Vectors.Vector; + Imported_Subprograms : GM.External_Vectors.Vector; + Imported_Objects : Type_Maps.Map; + Imported_Static : Static_Value_Maps.Map; + Visible_Types : in out Type_Maps.Map; + Visible_Functions : in out Function_Maps.Map; + Visible_Objects : in out Type_Maps.Map; + Visible_Static : in out Static_Value_Maps.Map); + + function Instantiate_Generic_Type + (Template_Name : String; + Spec : CM.Type_Spec; + Type_Env : Type_Maps.Map; + Const_Env : Static_Value_Maps.Map; + Path : String) return GM.Type_Descriptor; + + function Specialize_Generic_Call + (Expr : CM.Expr_Access; + Var_Types : Type_Maps.Map; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map; + Const_Env : Static_Value_Maps.Map; + Path : String) return CM.Expr_Access; + function Specialize_Interface_Call (Expr : CM.Expr_Access; Var_Types : Type_Maps.Map; @@ -1092,6 +1216,14 @@ package body Safe_Frontend.Check_Resolve is return FT.Lowercase (UString_Value (Base_Type (Info, Type_Env).Kind)) = "interface"; end Is_Interface_Type; + function Is_Generic_Formal_Type + (Info : GM.Type_Descriptor; + Type_Env : Type_Maps.Map) return Boolean + is + begin + return FT.Lowercase (UString_Value (Base_Type (Info, Type_Env).Kind)) = "generic_formal"; + end Is_Generic_Formal_Type; + function Optional_Payload_Type (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return GM.Type_Descriptor @@ -1129,6 +1261,9 @@ package body Safe_Frontend.Check_Resolve is Base : constant GM.Type_Descriptor := Base_Type (Info, Type_Env); Kind : constant String := FT.Lowercase (UString_Value (Base.Kind)); begin + if Kind = "generic_formal" then + return True; + end if; if Kind in "access" | "incomplete" | "null" then return False; end if; @@ -1227,7 +1362,7 @@ package body Safe_Frontend.Check_Resolve is Type_Env, Path, Source_Expr.Elements (Index).Span); - end loop; + end loop; end if; end; elsif FT.Lowercase (UString_Value (Base_Target.Kind)) = "record" @@ -1450,6 +1585,9 @@ package body Safe_Frontend.Check_Resolve is (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return Boolean is begin + if Is_Generic_Formal_Type (Info, Type_Env) then + return True; + end if; return Is_Discrete_Case_Type (Info, Type_Env) or else Is_String_Type (Info, Type_Env); end Is_Map_Key_Type_Allowed; @@ -1676,6 +1814,8 @@ package body Safe_Frontend.Check_Resolve is begin if Kind = "incomplete" then return False; + elsif Kind = "generic_formal" then + return True; elsif Kind = "interface" then return False; elsif Info_Kind = "subtype" and then not Info.Discriminant_Constraints.Is_Empty then @@ -1828,28 +1968,56 @@ package body Safe_Frontend.Check_Resolve is Package_Name : String) return GM.Type_Descriptor is Result : GM.Type_Descriptor := Info; + function Is_Local_Generic_Formal_Name (Name : String) return Boolean is + begin + if not Result.Generic_Formals.Is_Empty then + for Formal of Result.Generic_Formals loop + if UString_Value (Formal.Name) = Name then + return True; + end if; + end loop; + end if; + return False; + end Is_Local_Generic_Formal_Name; + + function Qualify_Type_Name_Unless_Formal (Name : String) return String is + begin + if Is_Local_Generic_Formal_Name (Name) then + return Name; + end if; + return Qualify_Name (Package_Name, Name); + end Qualify_Type_Name_Unless_Formal; begin Result.Name := FT.To_UString (Qualify_Name (Package_Name, UString_Value (Info.Name))); if Result.Has_Base then - Result.Base := FT.To_UString (Qualify_Name (Package_Name, UString_Value (Result.Base))); + Result.Base := + FT.To_UString + (Qualify_Type_Name_Unless_Formal (UString_Value (Result.Base))); end if; if Result.Has_Component_Type then Result.Component_Type := - FT.To_UString (Qualify_Name (Package_Name, UString_Value (Result.Component_Type))); + FT.To_UString + (Qualify_Type_Name_Unless_Formal + (UString_Value (Result.Component_Type))); end if; if Result.Has_Target then - Result.Target := FT.To_UString (Qualify_Name (Package_Name, UString_Value (Result.Target))); + Result.Target := + FT.To_UString + (Qualify_Type_Name_Unless_Formal (UString_Value (Result.Target))); end if; if Result.Has_Discriminant then Result.Discriminant_Type := - FT.To_UString (Qualify_Name (Package_Name, UString_Value (Result.Discriminant_Type))); + FT.To_UString + (Qualify_Type_Name_Unless_Formal + (UString_Value (Result.Discriminant_Type))); end if; if not Result.Index_Types.Is_Empty then for Index in Result.Index_Types.First_Index .. Result.Index_Types.Last_Index loop Result.Index_Types.Replace_Element (Index, FT.To_UString - (Qualify_Name (Package_Name, UString_Value (Result.Index_Types (Index))))); + (Qualify_Type_Name_Unless_Formal + (UString_Value (Result.Index_Types (Index))))); end loop; end if; if not Result.Fields.Is_Empty then @@ -1858,7 +2026,9 @@ package body Safe_Frontend.Check_Resolve is Item : GM.Type_Field := Result.Fields (Index); begin Item.Type_Name := - FT.To_UString (Qualify_Name (Package_Name, UString_Value (Item.Type_Name))); + FT.To_UString + (Qualify_Type_Name_Unless_Formal + (UString_Value (Item.Type_Name))); Result.Fields.Replace_Element (Index, Item); end; end loop; @@ -1869,7 +2039,9 @@ package body Safe_Frontend.Check_Resolve is Item : GM.Variant_Field := Result.Variant_Fields (Index); begin Item.Type_Name := - FT.To_UString (Qualify_Name (Package_Name, UString_Value (Item.Type_Name))); + FT.To_UString + (Qualify_Type_Name_Unless_Formal + (UString_Value (Item.Type_Name))); Result.Variant_Fields.Replace_Element (Index, Item); end; end loop; @@ -1886,7 +2058,8 @@ package body Safe_Frontend.Check_Resolve is begin Param.Type_Name := FT.To_UString - (Qualify_Name (Package_Name, UString_Value (Param.Type_Name))); + (Qualify_Type_Name_Unless_Formal + (UString_Value (Param.Type_Name))); Member.Params.Replace_Element (Param_Index, Param); end; end loop; @@ -1894,12 +2067,32 @@ package body Safe_Frontend.Check_Resolve is if Member.Has_Return_Type then Member.Return_Type := FT.To_UString - (Qualify_Name (Package_Name, UString_Value (Member.Return_Type))); + (Qualify_Type_Name_Unless_Formal + (UString_Value (Member.Return_Type))); end if; Result.Interface_Members.Replace_Element (Member_Index, Member); end; end loop; end if; + if Result.Has_Generic_Origin then + Result.Generic_Origin := + FT.To_UString + (Qualify_Name (Package_Name, UString_Value (Result.Generic_Origin))); + end if; + if not Result.Generic_Actual_Types.Is_Empty then + for Index in Result.Generic_Actual_Types.First_Index .. Result.Generic_Actual_Types.Last_Index loop + if not Is_Local_Generic_Formal_Name + (UString_Value (Result.Generic_Actual_Types (Index))) + then + Result.Generic_Actual_Types.Replace_Element + (Index, + FT.To_UString + (Qualify_Name + (Package_Name, + UString_Value (Result.Generic_Actual_Types (Index))))); + end if; + end loop; + end if; return Result; end Qualify_Type_Info; @@ -1917,142 +2110,547 @@ package body Safe_Frontend.Check_Resolve is return Result; end Qualify_Static_Value; - function Classify_Access_Role - (Anonymous : Boolean; - Is_Constant : Boolean; - Is_All : Boolean) return String is + function Generic_Formal_Type + (Formal : CM.Generic_Formal) return GM.Type_Descriptor + is + Result : GM.Type_Descriptor; begin - if Anonymous and then Is_Constant then - return "Observe"; - elsif Anonymous then - return "Borrow"; - elsif Is_All then - return "GeneralAccess"; - elsif Is_Constant then - return "NamedConstant"; + Result.Name := Formal.Name; + Result.Kind := FT.To_UString ("generic_formal"); + if Formal.Has_Constraint then + Result.Has_Base := True; + Result.Base := Formal.Constraint_Name; end if; - return "Owner"; - end Classify_Access_Role; + return Result; + end Generic_Formal_Type; - function Expr_Text (Expr : CM.Expr_Access) return String; + function Generic_Formal_Descriptor + (Formal : CM.Generic_Formal) return GM.Generic_Formal_Descriptor + is + Result : GM.Generic_Formal_Descriptor; + begin + Result.Name := Formal.Name; + Result.Has_Constraint := Formal.Has_Constraint; + Result.Constraint_Name := Formal.Constraint_Name; + return Result; + end Generic_Formal_Descriptor; - function Expr_Text (Expr : CM.Expr_Access) return String is + procedure Add_Generic_Formals_To_Env + (Type_Env : in out Type_Maps.Map; + Formals : CM.Generic_Formal_Vectors.Vector) is begin - if Expr = null then - return ""; + if not Formals.Is_Empty then + for Formal of Formals loop + Put_Type (Type_Env, UString_Value (Formal.Name), Generic_Formal_Type (Formal)); + end loop; end if; + end Add_Generic_Formals_To_Env; - case Expr.Kind is - when CM.Expr_Int | CM.Expr_Real | CM.Expr_String => - if UString_Value (Expr.Text)'Length > 0 then - return UString_Value (Expr.Text); - end if; - when CM.Expr_Bool => - return (if Expr.Bool_Value then "true" else "false"); - when CM.Expr_Enum_Literal => - return UString_Value (Expr.Name); - when CM.Expr_Ident => - return UString_Value (Expr.Name); - when CM.Expr_Select => - return Expr_Text (Expr.Prefix) & "." & UString_Value (Expr.Selector); - when CM.Expr_Try => - return "try " & Expr_Text (Expr.Inner); - when CM.Expr_Unary => - return UString_Value (Expr.Operator) & Expr_Text (Expr.Inner); - when CM.Expr_Binary => - return Expr_Text (Expr.Left) & " " & UString_Value (Expr.Operator) & " " & Expr_Text (Expr.Right); - when others => - null; - end case; - - return CM.Flatten_Name (Expr); - end Expr_Text; + function Is_Generic_Actual_Type_Allowed + (Info : GM.Type_Descriptor; + Type_Env : Type_Maps.Map) return Boolean + is + Base : constant GM.Type_Descriptor := Base_Type (Info, Type_Env); + Kind : constant String := FT.Lowercase (UString_Value (Base.Kind)); + begin + return Kind /= "interface" + and then Kind /= "access" + and then Kind /= "incomplete" + and then Kind /= "generic_formal" + and then not Contains_Channel_Reference_Subcomponent (Base, Type_Env); + end Is_Generic_Actual_Type_Allowed; - function Flatten_Name (Expr : CM.Expr_Access) return String is + procedure Validate_Generic_Actuals + (Formals : CM.Generic_Formal_Vectors.Vector; + Actual_Types : FT.UString_Vectors.Vector; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map; + Path : String; + Span : FT.Source_Span) is begin - if Expr = null then - return ""; - elsif Expr.Kind = CM.Expr_Enum_Literal then - return UString_Value (Expr.Name); - elsif Expr.Kind = CM.Expr_Ident then - return UString_Value (Expr.Name); - elsif Expr.Kind = CM.Expr_Select then - return Flatten_Name (Expr.Prefix) & "." & UString_Value (Expr.Selector); + if Natural (Formals.Length) /= Natural (Actual_Types.Length) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Span, + Message => + "generic actual count does not match the declaration")); end if; - return ""; - end Flatten_Name; - function Root_Name (Expr : CM.Expr_Access) return String is - begin - if Expr = null then - return ""; - elsif Expr.Kind = CM.Expr_Ident then - return UString_Value (Expr.Name); - elsif Expr.Kind = CM.Expr_Select then - return Root_Name (Expr.Prefix); - elsif Expr.Kind = CM.Expr_Resolved_Index then - return Root_Name (Expr.Prefix); - elsif Expr.Kind = CM.Expr_Conversion then - return Root_Name (Expr.Inner); + if not Formals.Is_Empty then + for Index in Formals.First_Index .. Formals.Last_Index loop + declare + Formal : constant CM.Generic_Formal := Formals (Index); + Actual : constant GM.Type_Descriptor := + Resolve_Type (UString_Value (Actual_Types (Index)), Type_Env, Path, Span); + begin + if not Is_Generic_Actual_Type_Allowed (Actual, Type_Env) then + Raise_Diag + (CM.Unsupported_Source_Construct + (Path => Path, + Span => Span, + Message => + "generic actual types are limited to the admitted concrete value-type subset in PR11.11c")); + elsif Formal.Has_Constraint then + declare + Constraint_Type : constant GM.Type_Descriptor := + Resolve_Type (UString_Value (Formal.Constraint_Name), Type_Env, Path, Span); + begin + if not Is_Interface_Type (Constraint_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Span, + Message => + "generic constraint `" & UString_Value (Formal.Constraint_Name) + & "` must name an interface")); + elsif not Type_Satisfies_Interface (Actual, Constraint_Type, Functions, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Span, + Message => + "type `" & UString_Value (Base_Type (Actual, Type_Env).Name) + & "` does not satisfy interface `" + & UString_Value (Base_Type (Constraint_Type, Type_Env).Name) + & "`")); + end if; + end; + end if; + end; + end loop; end if; - return ""; - end Root_Name; + end Validate_Generic_Actuals; - function Exact_Length_Fact_Name (Expr : CM.Expr_Access) return String is + function Generic_Template_Key + (Name : String; + Actual_Types : FT.UString_Vectors.Vector) return String + is + Result : FT.UString := FT.To_UString (Canonical_Name (Name)); begin - if Expr = null then - return ""; - elsif Expr.Kind in CM.Expr_Ident | CM.Expr_Select then - return Flatten_Name (Expr); - elsif Expr.Kind in CM.Expr_Annotated | CM.Expr_Conversion then - return Exact_Length_Fact_Name (Expr.Inner); + if not Actual_Types.Is_Empty then + for Item of Actual_Types loop + Result := Result & FT.To_UString ("|") & FT.To_UString (Canonical_Name (UString_Value (Item))); + end loop; end if; - return ""; - end Exact_Length_Fact_Name; + return UString_Value (Result); + end Generic_Template_Key; - procedure Remove_Exact_Length_Fact - (Facts : in out Exact_Length_Maps.Map; - Name : String) is - Key : constant String := Canonical_Name (Name); - begin - if Key /= "" and then Facts.Contains (Key) then - Facts.Delete (Key); + function Generic_Specialization_Name + (Prefix : String; + Name : String; + Actual_Types : FT.UString_Vectors.Vector) return String + is + Result : FT.UString := + FT.To_UString + (Prefix & Sanitize_Type_Name_Component (Method_Target_Tail_Name (Name))); + begin + if not Actual_Types.Is_Empty then + for Item of Actual_Types loop + Result := + Result + & FT.To_UString ("_") + & FT.To_UString (Sanitize_Type_Name_Component (UString_Value (Item))); + end loop; end if; - end Remove_Exact_Length_Fact; + return UString_Value (Result); + end Generic_Specialization_Name; - function Try_Direct_Growable_Length_Guard - (Condition : CM.Expr_Access; - Var_Types : Type_Maps.Map; - Functions : Function_Maps.Map; - Type_Env : Type_Maps.Map; - Guard_Name : out FT.UString; - Length : out Natural) return Boolean + function Substitute_Generic_Type_Info + (Template : GM.Type_Descriptor; + Formals : GM.Generic_Formal_Descriptor_Vectors.Vector; + Actual_Types : FT.UString_Vectors.Vector) return GM.Type_Descriptor is - function Try_Length_Expr - (Expr : CM.Expr_Access; - Name : out FT.UString) return Boolean - is - Prefix_Type : GM.Type_Descriptor; - begin - Name := FT.To_UString (""); - if Expr = null - or else Expr.Kind /= CM.Expr_Select - or else UString_Value (Expr.Selector) /= "length" - then - return False; - end if; + Result : GM.Type_Descriptor := Template; - Name := FT.To_UString (Exact_Length_Fact_Name (Expr.Prefix)); - if UString_Value (Name) = "" then - return False; + function Replace_Name (Name : FT.UString) return FT.UString is + begin + if not Formals.Is_Empty then + for Index in Formals.First_Index .. Formals.Last_Index loop + if Canonical_Name (UString_Value (Name)) + = Canonical_Name (UString_Value (Formals (Index).Name)) + then + return Actual_Types (Index); + end if; + end loop; end if; + return Name; + end Replace_Name; + begin + if Result.Has_Base then + Result.Base := Replace_Name (Result.Base); + end if; + if Result.Has_Target then + Result.Target := Replace_Name (Result.Target); + end if; + if Result.Has_Component_Type then + Result.Component_Type := Replace_Name (Result.Component_Type); + end if; + if Result.Has_Discriminant then + Result.Discriminant_Type := Replace_Name (Result.Discriminant_Type); + end if; - Prefix_Type := Base_Type (Expr_Type (Expr.Prefix, Var_Types, Functions, Type_Env), Type_Env); - return FT.Lowercase (UString_Value (Prefix_Type.Kind)) = "array" - and then Prefix_Type.Growable; - end Try_Length_Expr; + if not Result.Index_Types.Is_Empty then + for Index in Result.Index_Types.First_Index .. Result.Index_Types.Last_Index loop + Result.Index_Types.Replace_Element + (Index, + Replace_Name (Result.Index_Types (Index))); + end loop; + end if; - function Try_Length_Literal + if not Result.Fields.Is_Empty then + for Index in Result.Fields.First_Index .. Result.Fields.Last_Index loop + declare + Field : GM.Type_Field := Result.Fields (Index); + begin + Field.Type_Name := Replace_Name (Field.Type_Name); + Result.Fields.Replace_Element (Index, Field); + end; + end loop; + end if; + + if not Result.Interface_Members.Is_Empty then + for Member_Index in Result.Interface_Members.First_Index .. Result.Interface_Members.Last_Index loop + declare + Member : GM.Interface_Member := Result.Interface_Members (Member_Index); + begin + if not Member.Params.Is_Empty then + for Param_Index in Member.Params.First_Index .. Member.Params.Last_Index loop + declare + Param : GM.Signature_Param := Member.Params (Param_Index); + begin + Param.Type_Name := Replace_Name (Param.Type_Name); + Member.Params.Replace_Element (Param_Index, Param); + end; + end loop; + end if; + if Member.Has_Return_Type then + Member.Return_Type := Replace_Name (Member.Return_Type); + end if; + Result.Interface_Members.Replace_Element (Member_Index, Member); + end; + end loop; + end if; + + if not Result.Discriminants.Is_Empty then + for Index in Result.Discriminants.First_Index .. Result.Discriminants.Last_Index loop + declare + Disc : GM.Discriminant_Descriptor := Result.Discriminants (Index); + begin + Disc.Type_Name := Replace_Name (Disc.Type_Name); + Result.Discriminants.Replace_Element (Index, Disc); + end; + end loop; + end if; + + if not Result.Variant_Fields.Is_Empty then + for Index in Result.Variant_Fields.First_Index .. Result.Variant_Fields.Last_Index loop + declare + Field : GM.Variant_Field := Result.Variant_Fields (Index); + begin + Field.Type_Name := Replace_Name (Field.Type_Name); + Result.Variant_Fields.Replace_Element (Index, Field); + end; + end loop; + end if; + + if not Result.Tuple_Element_Types.Is_Empty then + for Index in Result.Tuple_Element_Types.First_Index .. Result.Tuple_Element_Types.Last_Index loop + Result.Tuple_Element_Types.Replace_Element + (Index, + Replace_Name (Result.Tuple_Element_Types (Index))); + end loop; + end if; + + Result.Generic_Formals.Clear; + return Result; + end Substitute_Generic_Type_Info; + + function Parse_Imported_Generic_Subprogram + (Package_Name : String; + Qualified_Name : String; + Template_Source : String) return CM.Subprogram_Body + is + Input : constant Safe_Frontend.Source.Source_File := + (Path => FT.To_UString (""), + Content => + FT.To_UString + ("package safeimport" & Ada.Characters.Latin_1.LF + & " " & Template_Source)); + Diagnostics : FD.Diagnostic_Vectors.Vector; + Tokens : constant FL.Token_Vectors.Vector := FL.Lex (Input, Diagnostics); + Parsed : constant CM.Parse_Result := CP.Parse (Input, Tokens); + begin + if FD.Has_Errors (Diagnostics) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => "", + Span => FT.Null_Span, + Message => + "failed to import generic template from `" & Package_Name + & "`: " & FT.To_String (Diagnostics (Diagnostics.First_Index).Message))); + elsif not Parsed.Success then + Raise_Diag + (CM.Source_Frontend_Error + (Path => "", + Span => Parsed.Diagnostic.Span, + Message => + "failed to import generic template from `" & Package_Name + & "`: " & FT.To_String (Parsed.Diagnostic.Message))); + elsif Natural (Parsed.Unit.Items.Length) /= 1 + or else Parsed.Unit.Items (Parsed.Unit.Items.First_Index).Kind /= CM.Item_Subprogram + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => "", + Span => FT.Null_Span, + Message => + "generic template import from `" & Package_Name + & "` did not contain exactly one subprogram body")); + end if; + + return Parsed.Unit.Items (Parsed.Unit.Items.First_Index).Subp_Data; + end Parse_Imported_Generic_Subprogram; + + procedure Add_Imported_Package_Local_Aliases + (Package_Name : String; + Imported_Types : GM.Type_Descriptor_Vectors.Vector; + Imported_Subprograms : GM.External_Vectors.Vector; + Imported_Objects : Type_Maps.Map; + Imported_Static : Static_Value_Maps.Map; + Visible_Types : in out Type_Maps.Map; + Visible_Functions : in out Function_Maps.Map; + Visible_Objects : in out Type_Maps.Map; + Visible_Static : in out Static_Value_Maps.Map) + is + function From_Package (Name : String) return Boolean is + begin + return Name'Length > Package_Name'Length + and then Name (Name'First .. Name'First + Package_Name'Length - 1) = Package_Name + and then Name (Name'First + Package_Name'Length) = '.'; + end From_Package; + begin + if Package_Name'Length = 0 then + return; + end if; + + if not Imported_Types.Is_Empty then + for Item of Imported_Types loop + declare + Qualified_Name : constant String := UString_Value (Item.Name); + Short_Name : constant String := Method_Target_Tail_Name (Qualified_Name); + begin + if From_Package (Qualified_Name) + and then Short_Name /= Qualified_Name + and then not Has_Type (Visible_Types, Short_Name) + then + Put_Type (Visible_Types, Short_Name, Item); + end if; + end; + end loop; + end if; + + if not Imported_Subprograms.Is_Empty then + for Item of Imported_Subprograms loop + declare + Qualified_Name : constant String := UString_Value (Item.Name); + Short_Name : constant String := Method_Target_Tail_Name (Qualified_Name); + Info : Function_Info; + begin + if From_Package (Qualified_Name) + and then Short_Name /= Qualified_Name + and then not Has_Function (Visible_Functions, Short_Name) + then + Info.Name := FT.To_UString (Short_Name); + Info.Kind := Item.Kind; + Info.Span := Item.Span; + Info.Has_Return_Type := Item.Has_Return_Type; + Info.Return_Is_Access_Def := Item.Return_Is_Access_Def; + if Item.Has_Return_Type then + Info.Return_Type := Item.Return_Type; + end if; + if not Item.Params.Is_Empty then + for Param of Item.Params loop + declare + Symbol : CM.Symbol; + begin + Symbol.Name := Param.Name; + Symbol.Kind := Param.Kind; + Symbol.Mode := Param.Mode; + Symbol.Type_Info := Param.Type_Info; + Symbol.Span := Param.Span; + Info.Params.Append (Symbol); + end; + end loop; + end if; + Put_Function (Visible_Functions, Short_Name, Info); + end if; + end; + end loop; + end if; + + for Cursor in Imported_Objects.Iterate loop + declare + Qualified_Name : constant String := Type_Maps.Key (Cursor); + Short_Name : constant String := Method_Target_Tail_Name (Qualified_Name); + begin + if From_Package (Qualified_Name) + and then Short_Name /= Qualified_Name + and then not Has_Type (Visible_Objects, Short_Name) + then + Put_Type + (Visible_Objects, + Short_Name, + Type_Maps.Element (Cursor)); + if Imported_Static.Contains (Qualified_Name) + and then not Visible_Static.Contains (Short_Name) + then + Put_Static_Value + (Visible_Static, + Short_Name, + Imported_Static.Element (Qualified_Name)); + end if; + end if; + end; + end loop; + end Add_Imported_Package_Local_Aliases; + + function Classify_Access_Role + (Anonymous : Boolean; + Is_Constant : Boolean; + Is_All : Boolean) return String is + begin + if Anonymous and then Is_Constant then + return "Observe"; + elsif Anonymous then + return "Borrow"; + elsif Is_All then + return "GeneralAccess"; + elsif Is_Constant then + return "NamedConstant"; + end if; + return "Owner"; + end Classify_Access_Role; + + function Expr_Text (Expr : CM.Expr_Access) return String; + + function Expr_Text (Expr : CM.Expr_Access) return String is + begin + if Expr = null then + return ""; + end if; + + case Expr.Kind is + when CM.Expr_Int | CM.Expr_Real | CM.Expr_String => + if UString_Value (Expr.Text)'Length > 0 then + return UString_Value (Expr.Text); + end if; + when CM.Expr_Bool => + return (if Expr.Bool_Value then "true" else "false"); + when CM.Expr_Enum_Literal => + return UString_Value (Expr.Name); + when CM.Expr_Ident => + return UString_Value (Expr.Name); + when CM.Expr_Select => + return Expr_Text (Expr.Prefix) & "." & UString_Value (Expr.Selector); + when CM.Expr_Try => + return "try " & Expr_Text (Expr.Inner); + when CM.Expr_Unary => + return UString_Value (Expr.Operator) & Expr_Text (Expr.Inner); + when CM.Expr_Binary => + return Expr_Text (Expr.Left) & " " & UString_Value (Expr.Operator) & " " & Expr_Text (Expr.Right); + when others => + null; + end case; + + return CM.Flatten_Name (Expr); + end Expr_Text; + + function Flatten_Name (Expr : CM.Expr_Access) return String is + begin + if Expr = null then + return ""; + elsif Expr.Kind = CM.Expr_Enum_Literal then + return UString_Value (Expr.Name); + elsif Expr.Kind = CM.Expr_Ident then + return UString_Value (Expr.Name); + elsif Expr.Kind = CM.Expr_Select then + return Flatten_Name (Expr.Prefix) & "." & UString_Value (Expr.Selector); + end if; + return ""; + end Flatten_Name; + + function Root_Name (Expr : CM.Expr_Access) return String is + begin + if Expr = null then + return ""; + elsif Expr.Kind = CM.Expr_Ident then + return UString_Value (Expr.Name); + elsif Expr.Kind = CM.Expr_Select then + return Root_Name (Expr.Prefix); + elsif Expr.Kind = CM.Expr_Resolved_Index then + return Root_Name (Expr.Prefix); + elsif Expr.Kind = CM.Expr_Conversion then + return Root_Name (Expr.Inner); + end if; + return ""; + end Root_Name; + + function Exact_Length_Fact_Name (Expr : CM.Expr_Access) return String is + begin + if Expr = null then + return ""; + elsif Expr.Kind in CM.Expr_Ident | CM.Expr_Select then + return Flatten_Name (Expr); + elsif Expr.Kind in CM.Expr_Annotated | CM.Expr_Conversion then + return Exact_Length_Fact_Name (Expr.Inner); + end if; + return ""; + end Exact_Length_Fact_Name; + + procedure Remove_Exact_Length_Fact + (Facts : in out Exact_Length_Maps.Map; + Name : String) is + Key : constant String := Canonical_Name (Name); + begin + if Key /= "" and then Facts.Contains (Key) then + Facts.Delete (Key); + end if; + end Remove_Exact_Length_Fact; + + function Try_Direct_Growable_Length_Guard + (Condition : CM.Expr_Access; + Var_Types : Type_Maps.Map; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map; + Guard_Name : out FT.UString; + Length : out Natural) return Boolean + is + function Try_Length_Expr + (Expr : CM.Expr_Access; + Name : out FT.UString) return Boolean + is + Prefix_Type : GM.Type_Descriptor; + begin + Name := FT.To_UString (""); + if Expr = null + or else Expr.Kind /= CM.Expr_Select + or else UString_Value (Expr.Selector) /= "length" + then + return False; + end if; + + Name := FT.To_UString (Exact_Length_Fact_Name (Expr.Prefix)); + if UString_Value (Name) = "" then + return False; + end if; + + Prefix_Type := Base_Type (Expr_Type (Expr.Prefix, Var_Types, Functions, Type_Env), Type_Env); + return FT.Lowercase (UString_Value (Prefix_Type.Kind)) = "array" + and then Prefix_Type.Growable; + end Try_Length_Expr; + + function Try_Length_Literal (Expr : CM.Expr_Access; Value : out Natural) return Boolean is @@ -2269,6 +2867,8 @@ package body Safe_Frontend.Check_Resolve is return Get_Type (Synthetic_Helper_Types, Name); elsif Has_Type (Synthetic_Optional_Types, Name) then return Get_Type (Synthetic_Optional_Types, Name); + elsif Has_Type (Current_Generic_Type_Instantiations, Name) then + return Get_Type (Current_Generic_Type_Instantiations, Name); elsif Name'Length >= Bounded_String_Prefix'Length and then Name (Name'First .. Name'First + Bounded_String_Prefix'Length - 1) = Bounded_String_Prefix @@ -2431,6 +3031,36 @@ package body Safe_Frontend.Check_Resolve is begin case Spec.Kind is when CM.Type_Spec_Name | CM.Type_Spec_Subtype_Indication => + if not Spec.Generic_Args.Is_Empty then + if Current_Generic_Type_Templates.Contains + (Canonical_Name (UString_Value (Spec.Name))) + then + return + Instantiate_Generic_Type + (UString_Value (Spec.Name), + Spec, + Type_Env, + Const_Env, + Path); + end if; + + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Spec.Span, + Message => "explicit generic type arguments require a generic type declaration")); + elsif Current_Generic_Type_Templates.Contains + (Canonical_Name (UString_Value (Spec.Name))) + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Spec.Span, + Message => + "generic type `" & UString_Value (Spec.Name) + & "` requires explicit type arguments in PR11.11c")); + end if; + if Spec.Has_Range_Constraint then Base := Resolve_Type (UString_Value (Spec.Name), Type_Env, Path, Spec.Span); if Is_Enum_Type (Base, Type_Env) then @@ -3570,12 +4200,6 @@ package body Safe_Frontend.Check_Resolve is Functions : Function_Maps.Map; Type_Env : Type_Maps.Map) return Boolean; - function Type_Satisfies_Interface - (Concrete_Type : GM.Type_Descriptor; - Interface_Type : GM.Type_Descriptor; - Functions : Function_Maps.Map; - Type_Env : Type_Maps.Map) return Boolean; - function Interface_Member_Compatible_With_Function (Member : GM.Interface_Member; Concrete_Type : GM.Type_Descriptor; @@ -4180,6 +4804,33 @@ package body Safe_Frontend.Check_Resolve is end; end loop; + for Cursor in Current_Generic_Function_Templates.Iterate loop + declare + Candidate_Name : constant String := + Generic_Function_Template_Maps.Key (Cursor); + Template : constant Generic_Function_Template_Info := + Generic_Function_Template_Maps.Element (Cursor); + begin + if (Candidate_Name = Method_Name + or else Method_Target_Tail_Name (Candidate_Name) = Method_Name) + and then Function_Method_Call_Compatible + (Template.Info, + Receiver_Arg, + Expr.Args, + Var_Types, + Functions, + Type_Env, + Const_Env) + then + Match_Count := Match_Count + 1; + Append_Unique_String (Match_Names, Candidate_Name); + if UString_Value (Selected_Name)'Length = 0 then + Selected_Name := FT.To_UString (Candidate_Name); + end if; + end if; + end; + end loop; + if Builtin_Visible and then Builtin_Method_Call_Compatible (Method_Name, @@ -4214,6 +4865,7 @@ package body Safe_Frontend.Check_Resolve is Result := new CM.Expr_Node'(Expr.all); Result.Kind := CM.Expr_Call; Result.Callee := Name_Expr_From_String (UString_Value (Selected_Name), Expr.Callee.Span); + Result.Callee.Generic_Args := Expr.Callee.Generic_Args; Result.Args.Clear; Result.Args.Append (Receiver_Arg); for Arg of Expr.Args loop @@ -4227,7 +4879,8 @@ package body Safe_Frontend.Check_Resolve is Var_Types : Type_Maps.Map; Functions : Function_Maps.Map; Type_Env : Type_Maps.Map; - Const_Env : Static_Value_Maps.Map) return CM.Expr_Access + Const_Env : Static_Value_Maps.Map; + Path : String := "") return CM.Expr_Access is begin if Expr = null or else Expr.Kind /= CM.Expr_Apply then @@ -4241,7 +4894,25 @@ package body Safe_Frontend.Check_Resolve is begin if Expr.Callee /= null and then Expr.Callee.Kind = CM.Expr_Ident then Callee_Name := Expr.Callee.Name; - if Has_Type (Var_Types, UString_Value (Callee_Name)) + if not Expr.Callee.Generic_Args.Is_Empty + and then Current_Generic_Function_Templates.Contains + (Canonical_Name (UString_Value (Callee_Name))) + then + Result.Kind := CM.Expr_Call; + Result.Callee := Expr.Callee; + Result.Args := Expr.Args; + elsif Expr.Callee.Generic_Args.Is_Empty + and then Current_Generic_Function_Templates.Contains + (Canonical_Name (UString_Value (Callee_Name))) + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Expr.Callee.Span, + Message => + "generic function `" & UString_Value (Callee_Name) + & "` requires explicit type arguments in PR11.11c")); + elsif Has_Type (Var_Types, UString_Value (Callee_Name)) and then (UString_Value (Get_Type (Var_Types, UString_Value (Callee_Name)).Kind) = "array" @@ -4285,12 +4956,30 @@ package body Safe_Frontend.Check_Resolve is else if Expr.Callee /= null and then Expr.Callee.Kind = CM.Expr_Select - and then Has_Function (Functions, Flatten_Name (Expr.Callee)) + and then + ((not Expr.Callee.Generic_Args.Is_Empty + and then Current_Generic_Function_Templates.Contains + (Canonical_Name (Flatten_Name (Expr.Callee)))) + or else Has_Function (Functions, Flatten_Name (Expr.Callee))) then Result.Kind := CM.Expr_Call; Result.Callee := Expr.Callee; Result.Args := Expr.Args; else + if Expr.Callee /= null + and then Expr.Callee.Kind = CM.Expr_Select + and then Expr.Callee.Generic_Args.Is_Empty + and then Current_Generic_Function_Templates.Contains + (Canonical_Name (Flatten_Name (Expr.Callee))) + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Expr.Callee.Span, + Message => + "generic function `" & Flatten_Name (Expr.Callee) + & "` requires explicit type arguments in PR11.11c")); + end if; declare Rewritten : constant CM.Expr_Access := Rewrite_Method_Apply (Expr, Var_Types, Functions, Type_Env, Const_Env); @@ -4353,7 +5042,8 @@ package body Safe_Frontend.Check_Resolve is Var_Types : Type_Maps.Map; Functions : Function_Maps.Map; Type_Env : Type_Maps.Map; - Const_Env : Static_Value_Maps.Map) return CM.Expr_Access + Const_Env : Static_Value_Maps.Map; + Path : String := "") return CM.Expr_Access is Result : CM.Expr_Access; Field : CM.Aggregate_Field; @@ -4372,37 +5062,37 @@ package body Safe_Frontend.Check_Resolve is when CM.Expr_Apply => declare Resolved : constant CM.Expr_Access := - Resolve_Apply (Expr, Var_Types, Functions, Type_Env, Const_Env); + Resolve_Apply (Expr, Var_Types, Functions, Type_Env, Const_Env, Path); begin if Resolved.Kind = CM.Expr_Resolved_Index then Result := new CM.Expr_Node'(Resolved.all); Result.Prefix := - Normalize_Expr (Resolved.Prefix, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Resolved.Prefix, Var_Types, Functions, Type_Env, Const_Env, Path); Result.Args.Clear; for Item of Resolved.Args loop Result.Args.Append - (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env)); + (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env, Path)); end loop; elsif Resolved.Kind = CM.Expr_Call then Result := new CM.Expr_Node'(Resolved.all); Result.Callee := - Normalize_Expr (Resolved.Callee, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Resolved.Callee, Var_Types, Functions, Type_Env, Const_Env, Path); Result.Args.Clear; for Item of Resolved.Args loop Result.Args.Append - (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env)); + (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env, Path)); end loop; if Is_Pop_Last_Builtin_Call (Result, Var_Types, Functions, Type_Env) then if Natural (Result.Args.Length) /= 1 then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => (if Result.Has_Call_Span then Result.Call_Span else Result.Span), Message => "`pop_last(items)` expects exactly one argument")); elsif not Is_Assignable_Target (Result.Args (Result.Args.First_Index)) then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => Result.Args (Result.Args.First_Index).Span, Message => "`pop_last` first argument must be a writable list name")); else @@ -4418,7 +5108,7 @@ package body Safe_Frontend.Check_Resolve is if not Is_Growable_Array_Type (List_Type, Type_Env) then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => Result.Args (Result.Args.First_Index).Span, Message => "`pop_last` expects a `mut list of T` first argument")); end if; @@ -4426,7 +5116,7 @@ package body Safe_Frontend.Check_Resolve is if not Is_Container_Element_Type_Allowed (Element_Type, Type_Env) then Raise_Diag (CM.Unsupported_Source_Construct - (Path => "", + (Path => Path, Span => Result.Args (Result.Args.First_Index).Span, Message => "`list of T` is limited to the admitted value-type subset in PR11.10b")); @@ -4450,7 +5140,7 @@ package body Safe_Frontend.Check_Resolve is if Natural (Result.Args.Length) /= 2 then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => (if Result.Has_Call_Span then Result.Call_Span else Result.Span), Message => "`" & Builtin_Name & "(m, key)` expects exactly two arguments")); end if; @@ -4470,26 +5160,26 @@ package body Safe_Frontend.Check_Resolve is then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => Map_Expr.Span, Message => "`remove` first argument must be a writable map name")); elsif not Try_Map_Key_Value_Types (Map_Type, Type_Env, Key_Type, Value_Type) then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => Map_Expr.Span, Message => "`" & Builtin_Name & "` expects a `map of (K, V)` first argument")); elsif not Is_Map_Key_Type_Allowed (Key_Type, Type_Env) then Raise_Diag (CM.Unsupported_Source_Construct - (Path => "", + (Path => Path, Span => Map_Expr.Span, Message => "`map of (K, V)` keys are limited to the admitted discrete/string subset in PR11.10c")); elsif not Is_Container_Element_Type_Allowed (Value_Type, Type_Env) then Raise_Diag (CM.Unsupported_Source_Construct - (Path => "", + (Path => Path, Span => Map_Expr.Span, Message => "`map of (K, V)` values are limited to the admitted value-type subset in PR11.10c")); @@ -4501,8 +5191,8 @@ package body Safe_Frontend.Check_Resolve is Var_Types, Functions, Type_Env, - ""); - Reject_Uncontextualized_None (Key_Expr, ""); + Path); + Reject_Uncontextualized_None (Key_Expr, Path); if not Compatible_Source_Expr_To_Target_Type (Key_Expr, Expr_Type (Key_Expr, Var_Types, Functions, Type_Env), @@ -4515,7 +5205,7 @@ package body Safe_Frontend.Check_Resolve is then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => Key_Expr.Span, Message => "`" & Builtin_Name & "` key type does not match the map key type")); end if; @@ -4529,6 +5219,14 @@ package body Safe_Frontend.Check_Resolve is end; end; end if; + Result := + Specialize_Generic_Call + (Result, + Var_Types, + Functions, + Type_Env, + Const_Env, + Path); Result := Specialize_Interface_Call (Result, @@ -4536,36 +5234,36 @@ package body Safe_Frontend.Check_Resolve is Functions, Type_Env, Const_Env, - ""); + Path); else Result := new CM.Expr_Node'(Resolved.all); Result.Inner := - Normalize_Expr (Resolved.Inner, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Resolved.Inner, Var_Types, Functions, Type_Env, Const_Env, Path); end if; end; when CM.Expr_Select => Result := new CM.Expr_Node'(Expr.all); - Result.Prefix := Normalize_Expr (Expr.Prefix, Var_Types, Functions, Type_Env, Const_Env); + Result.Prefix := Normalize_Expr (Expr.Prefix, Var_Types, Functions, Type_Env, Const_Env, Path); when CM.Expr_Binary => Result := new CM.Expr_Node'(Expr.all); - Result.Left := Normalize_Expr (Expr.Left, Var_Types, Functions, Type_Env, Const_Env); - Result.Right := Normalize_Expr (Expr.Right, Var_Types, Functions, Type_Env, Const_Env); + Result.Left := Normalize_Expr (Expr.Left, Var_Types, Functions, Type_Env, Const_Env, Path); + Result.Right := Normalize_Expr (Expr.Right, Var_Types, Functions, Type_Env, Const_Env, Path); when CM.Expr_Unary => Result := new CM.Expr_Node'(Expr.all); - Result.Inner := Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env); + Result.Inner := Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env, Path); when CM.Expr_Allocator => Result := new CM.Expr_Node'(Expr.all); if Expr.Value /= null and then Expr.Value.Kind = CM.Expr_Annotated then Result.Value := new CM.Expr_Node'(Expr.Value.all); Result.Value.Inner := - Normalize_Expr (Expr.Value.Inner, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Expr.Value.Inner, Var_Types, Functions, Type_Env, Const_Env, Path); end if; when CM.Expr_Aggregate => Result := new CM.Expr_Node'(Expr.all); Result.Fields.Clear; for Item of Expr.Fields loop Field := Item; - Field.Expr := Normalize_Expr (Item.Expr, Var_Types, Functions, Type_Env, Const_Env); + Field.Expr := Normalize_Expr (Item.Expr, Var_Types, Functions, Type_Env, Const_Env, Path); Result.Fields.Append (Field); end loop; when CM.Expr_Array_Literal => @@ -4573,19 +5271,19 @@ package body Safe_Frontend.Check_Resolve is Result.Elements.Clear; for Item of Expr.Elements loop Result.Elements.Append - (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env)); + (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env, Path)); end loop; when CM.Expr_Tuple => Result := new CM.Expr_Node'(Expr.all); Result.Elements.Clear; for Item of Expr.Elements loop Result.Elements.Append - (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env)); + (Normalize_Expr (Item, Var_Types, Functions, Type_Env, Const_Env, Path)); end loop; when CM.Expr_Annotated => declare Inner_Result : constant CM.Expr_Access := - Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env, Path); Target_Type : constant GM.Type_Descriptor := Resolve_Target_Type (Expr.Target, Type_Env); begin @@ -4593,7 +5291,7 @@ package body Safe_Frontend.Check_Resolve is if not Is_Optional_Type (Target_Type, Type_Env) then Raise_Diag (CM.Source_Frontend_Error - (Path => "", + (Path => Path, Span => Expr.Span, Message => "`none` type ascription requires an `optional T` target")); end if; @@ -4606,7 +5304,7 @@ package body Safe_Frontend.Check_Resolve is when CM.Expr_Some => declare Inner_Result : constant CM.Expr_Access := - Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env, Path); Payload_Type : constant GM.Type_Descriptor := Expr_Type (Inner_Result, Var_Types, Functions, Type_Env); Optional_Type : GM.Type_Descriptor; @@ -4614,7 +5312,7 @@ package body Safe_Frontend.Check_Resolve is if not Is_Optional_Element_Type_Allowed (Payload_Type, Type_Env) then Raise_Diag (CM.Unsupported_Source_Construct - (Path => "", + (Path => Path, Span => Expr.Span, Message => "`optional T` is limited to the admitted value-type subset in PR11.10a")); @@ -4626,7 +5324,7 @@ package body Safe_Frontend.Check_Resolve is Result := new CM.Expr_Node'(Expr.all); when CM.Expr_Try => Result := new CM.Expr_Node'(Expr.all); - Result.Inner := Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env); + Result.Inner := Normalize_Expr (Expr.Inner, Var_Types, Functions, Type_Env, Const_Env, Path); when others => Result := new CM.Expr_Node'(Expr.all); end case; @@ -5190,7 +5888,7 @@ package body Safe_Frontend.Check_Resolve is Allow_Try : Boolean := False) return CM.Expr_Access is Result : constant CM.Expr_Access := - Normalize_Expr (Expr, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Expr, Var_Types, Functions, Type_Env, Const_Env, Path); begin Validate_Pr112_Expr_Boundaries (Result, Var_Types, Functions, Type_Env, Path); Validate_Print_Call_Context (Result, Var_Types, Functions, Type_Env, Path); @@ -5976,7 +6674,7 @@ package body Safe_Frontend.Check_Resolve is Allow_Try : Boolean := False) return CM.Expr_Access is Result : constant CM.Expr_Access := - Normalize_Expr (Expr, Var_Types, Functions, Type_Env, Const_Env); + Normalize_Expr (Expr, Var_Types, Functions, Type_Env, Const_Env, Path); begin Validate_Pr112_Expr_Boundaries (Result, Var_Types, Functions, Type_Env, Path); Validate_Print_Call_Context @@ -6062,16 +6760,6 @@ package body Safe_Frontend.Check_Resolve is Contracts.Append (FT.To_UString (Name)); end Append_Task_Channel_Contract; - function Contains_Label_Like_Syntax (Name : String) return Boolean is - begin - for Ch of Name loop - if Ch = '.' or else Ch = '(' then - return True; - end if; - end loop; - return False; - end Contains_Label_Like_Syntax; - function Looks_Like_Unsupported_Statement_Label (Decl : CM.Object_Decl; Var_Types : Type_Maps.Map; @@ -6089,8 +6777,7 @@ package body Safe_Frontend.Check_Resolve is return Has_Type (Var_Types, Type_Name) - or else Has_Function (Functions, Type_Name) - or else Contains_Label_Like_Syntax (Type_Name); + or else Has_Function (Functions, Type_Name); end Looks_Like_Unsupported_Statement_Label; function Normalize_Object_Decl @@ -6521,6 +7208,119 @@ package body Safe_Frontend.Check_Resolve is return Result; end Specialize_Interface_Call; + function Specialize_Generic_Call + (Expr : CM.Expr_Access; + Var_Types : Type_Maps.Map; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map; + Const_Env : Static_Value_Maps.Map; + Path : String) return CM.Expr_Access + is + Callee_Name : constant String := + (if Expr = null or else Expr.Callee = null then "" else Flatten_Name (Expr.Callee)); + Generic_Args : constant CM.Type_Spec_Access_Vectors.Vector := + (if Expr = null or else Expr.Callee = null + then CM.Type_Spec_Access_Vectors.Empty_Vector + else Expr.Callee.Generic_Args); + Template : Generic_Function_Template_Info; + Actual_Type_Names : FT.UString_Vectors.Vector; + Key : FT.UString := FT.To_UString (""); + Specialized_Name : FT.UString := FT.To_UString (""); + Clone : CM.Subprogram_Body; + Clone_Info : Function_Info; + Local_Type_Env : Type_Maps.Map := Type_Env; + Result : CM.Expr_Access := Expr; + begin + if Callee_Name = "" + or else Generic_Args.Is_Empty + or else not Current_Generic_Function_Templates.Contains (Canonical_Name (Callee_Name)) + then + return Expr; + end if; + + Template := Current_Generic_Function_Templates.Element (Canonical_Name (Callee_Name)); + for Arg of Generic_Args loop + Actual_Type_Names.Append + (Resolve_Type_Spec (Arg.all, Type_Env, Const_Env, Path).Name); + end loop; + + Validate_Generic_Actuals + (Template.Decl.Spec.Generic_Formals, + Actual_Type_Names, + Functions, + Type_Env, + Path, + (if Expr.Has_Call_Span then Expr.Call_Span else Expr.Span)); + + if Natural (Expr.Args.Length) /= Natural (Template.Info.Params.Length) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => (if Expr.Has_Call_Span then Expr.Call_Span else Expr.Span), + Message => + "call to `" & Callee_Name & "` expects " + & Ada.Strings.Fixed.Trim + (Natural'Image (Natural (Template.Info.Params.Length)), + Ada.Strings.Both) + & " arguments")); + end if; + + Key := FT.To_UString (Generic_Template_Key (Callee_Name, Actual_Type_Names)); + if Current_Generic_Specialization_By_Key.Contains (UString_Value (Key)) then + Specialized_Name := + FT.To_UString + (Current_Generic_Specialization_By_Key.Element (UString_Value (Key))); + else + Clone := Template.Decl; + Clone.Spec.Generic_Formals.Clear; + Specialized_Name := + FT.To_UString + (Generic_Specialization_Name + ("Safe_Generic_", + Callee_Name, + Actual_Type_Names)); + Clone.Spec.Name := Specialized_Name; + Clone.Is_Public := False; + + if not Template.Decl.Spec.Generic_Formals.Is_Empty then + for Index in Template.Decl.Spec.Generic_Formals.First_Index .. Template.Decl.Spec.Generic_Formals.Last_Index loop + Put_Type + (Local_Type_Env, + UString_Value (Template.Decl.Spec.Generic_Formals (Index).Name), + Resolve_Type + (UString_Value (Actual_Type_Names (Index)), + Type_Env, + Path, + Expr.Span)); + end loop; + end if; + + Clone_Info := Register_Function (Clone, Local_Type_Env, Const_Env, Path); + Put_Function + (Current_Synthetic_Functions, + UString_Value (Specialized_Name), + Clone_Info); + Current_Generic_Specialization_By_Key.Include + (UString_Value (Key), + UString_Value (Specialized_Name)); + Current_Pending_Generic_Specializations.Include + (Canonical_Name (UString_Value (Specialized_Name)), + (Decl => Clone, + Info => Clone_Info, + Origin_Package => Template.Origin_Package, + Actual_Type_Names => Actual_Type_Names)); + Append_Unique_String + (Current_Generic_Specialization_Order, + UString_Value (Specialized_Name)); + end if; + + Result := new CM.Expr_Node'(Expr.all); + Result.Callee := + Name_Expr_From_String (UString_Value (Specialized_Name), Expr.Callee.Span); + Result.Callee.Generic_Args.Clear; + return Result; + end Specialize_Generic_Call; + procedure Append_Statements (Target : in out CM.Statement_Access_Vectors.Vector; Items : CM.Statement_Access_Vectors.Vector) is @@ -10707,6 +11507,146 @@ package body Safe_Frontend.Check_Resolve is return Result; end Resolve_Type_Declaration; + function Instantiate_Generic_Type + (Template_Name : String; + Spec : CM.Type_Spec; + Type_Env : Type_Maps.Map; + Const_Env : Static_Value_Maps.Map; + Path : String) return GM.Type_Descriptor + is + Template_Key : constant String := Canonical_Name (Template_Name); + Template : Generic_Type_Template_Info; + Actual_Type_Names : FT.UString_Vectors.Vector; + Template_Formals : CM.Generic_Formal_Vectors.Vector; + Instantiation_Key : FT.UString := FT.To_UString (""); + Concrete_Name : FT.UString := FT.To_UString (""); + Clone : CM.Type_Decl; + Local_Type_Env : Type_Maps.Map := Type_Env; + Result : GM.Type_Descriptor; + begin + if not Current_Generic_Type_Templates.Contains (Template_Key) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Spec.Span, + Message => "unknown generic type `" & Template_Name & "`")); + end if; + + Template := Current_Generic_Type_Templates.Element (Template_Key); + + if Template.Has_Decl then + Template_Formals := Template.Decl.Generic_Formals; + elsif not Template.Info.Generic_Formals.Is_Empty then + for Formal of Template.Info.Generic_Formals loop + Template_Formals.Append + ((Name => Formal.Name, + Has_Constraint => Formal.Has_Constraint, + Constraint_Name => Formal.Constraint_Name, + Span => FT.Null_Span)); + end loop; + end if; + + if not Spec.Generic_Args.Is_Empty then + for Arg of Spec.Generic_Args loop + Actual_Type_Names.Append + (Resolve_Type_Spec (Arg.all, Type_Env, Const_Env, Path).Name); + end loop; + end if; + + Validate_Generic_Actuals + (Template_Formals, + Actual_Type_Names, + Current_Generic_Function_Env, + Type_Env, + Path, + Spec.Span); + + Instantiation_Key := FT.To_UString (Generic_Template_Key (Template_Name, Actual_Type_Names)); + if Current_Generic_Type_Instantiation_By_Key.Contains (UString_Value (Instantiation_Key)) then + Concrete_Name := + FT.To_UString + (Current_Generic_Type_Instantiation_By_Key.Element + (UString_Value (Instantiation_Key))); + return Get_Type + (Current_Generic_Type_Instantiations, + UString_Value (Concrete_Name)); + end if; + + for Item of Current_Generic_Type_Instantiation_Stack loop + if Item = UString_Value (Instantiation_Key) then + Raise_Diag + (CM.Unsupported_Source_Construct + (Path => Path, + Span => Spec.Span, + Message => + "self-referential generic type instantiation is outside PR11.11c")); + end if; + end loop; + + Concrete_Name := + FT.To_UString + (Generic_Specialization_Name ("__generic_", Template_Name, Actual_Type_Names)); + if Template.Has_Decl then + Clone := Template.Decl; + Clone.Generic_Formals.Clear; + Clone.Name := Concrete_Name; + + if not Template.Decl.Generic_Formals.Is_Empty then + for Index in Template.Decl.Generic_Formals.First_Index .. Template.Decl.Generic_Formals.Last_Index loop + Put_Type + (Local_Type_Env, + UString_Value (Template.Decl.Generic_Formals (Index).Name), + Resolve_Type + (UString_Value (Actual_Type_Names (Index)), + Type_Env, + Path, + Spec.Span)); + end loop; + end if; + + Current_Generic_Type_Instantiation_Stack.Append (UString_Value (Instantiation_Key)); + Result := + Resolve_Type_Declaration + (Clone, + Local_Type_Env, + Const_Env, + Path); + Current_Generic_Type_Instantiation_Stack.Delete_Last; + else + Result := + Substitute_Generic_Type_Info + (Template.Info, + Template.Info.Generic_Formals, + Actual_Type_Names); + end if; + + Result.Name := Concrete_Name; + Result.Has_Generic_Origin := True; + Result.Generic_Origin := FT.To_UString (Template_Name); + Result.Generic_Actual_Types := Actual_Type_Names; + + Put_Type + (Current_Generic_Type_Instantiations, + UString_Value (Concrete_Name), + Result); + Current_Generic_Type_Instantiation_By_Key.Include + (UString_Value (Instantiation_Key), UString_Value (Concrete_Name)); + Append_Unique_String + (Current_Generic_Type_Instantiation_Order, + UString_Value (Concrete_Name)); + return Result; + exception + when others => + if not Current_Generic_Type_Instantiation_Stack.Is_Empty + and then Current_Generic_Type_Instantiation_Stack + (Current_Generic_Type_Instantiation_Stack.Last_Index) + = UString_Value (Instantiation_Key) + then + Current_Generic_Type_Instantiation_Stack.Delete_Last; + end if; + raise; + end Instantiate_Generic_Type; + function Register_Function (Decl : CM.Subprogram_Body; Type_Env : Type_Maps.Map; @@ -10718,6 +11658,7 @@ package body Safe_Frontend.Check_Resolve is begin Result.Name := Decl.Spec.Name; Result.Kind := Decl.Spec.Kind; + Result.Generic_Formals := Decl.Spec.Generic_Formals; Result.Span := Decl.Span; Result.Return_Is_Access_Def := Decl.Spec.Return_Is_Access_Def; if Decl.Spec.Has_Receiver then @@ -10798,10 +11739,30 @@ package body Safe_Frontend.Check_Resolve is begin if not Info.Params.Is_Empty then for Param of Info.Params loop - if UString_Value (Param.Name) = Name - and then Is_Interface_Type (Param.Type_Info, Type_Env) - then - return Base_Type (Param.Type_Info, Type_Env); + if UString_Value (Param.Name) = Name then + if Is_Interface_Type (Param.Type_Info, Type_Env) then + return Base_Type (Param.Type_Info, Type_Env); + elsif Is_Generic_Formal_Type (Param.Type_Info, Type_Env) then + declare + Generic_Info : constant GM.Type_Descriptor := + Base_Type (Param.Type_Info, Type_Env); + begin + if Generic_Info.Has_Base then + declare + Constraint_Info : constant GM.Type_Descriptor := + Resolve_Type + (UString_Value (Generic_Info.Base), + Type_Env, + Path, + Decl.Span); + begin + if Is_Interface_Type (Constraint_Info, Type_Env) then + return Base_Type (Constraint_Info, Type_Env); + end if; + end; + end if; + end; + end if; end if; end loop; end if; @@ -11547,7 +12508,15 @@ package body Safe_Frontend.Check_Resolve is Info : constant GM.Type_Descriptor := Qualify_Type_Info (Type_Item, Package_Name); begin - Put_Type (Type_Env, UString_Value (Info.Name), Info); + if Info.Generic_Formals.Is_Empty then + Put_Type (Type_Env, UString_Value (Info.Name), Info); + else + Current_Generic_Type_Templates.Include + (Canonical_Name (UString_Value (Info.Name)), + (Has_Decl => False, + Decl => (others => <>), + Info => Info)); + end if; Result.Imported_Types.Append (Info); end; end loop; @@ -11557,7 +12526,15 @@ package body Safe_Frontend.Check_Resolve is Info : constant GM.Type_Descriptor := Qualify_Type_Info (Type_Item, Package_Name); begin - Put_Type (Type_Env, UString_Value (Info.Name), Info); + if Info.Generic_Formals.Is_Empty then + Put_Type (Type_Env, UString_Value (Info.Name), Info); + else + Current_Generic_Type_Templates.Include + (Canonical_Name (UString_Value (Info.Name)), + (Has_Decl => False, + Decl => (others => <>), + Info => Info)); + end if; Result.Imported_Types.Append (Info); end; end loop; @@ -11632,12 +12609,44 @@ package body Safe_Frontend.Check_Resolve is External.Has_Return_Type := Subp_Item.Has_Return_Type; External.Return_Is_Access_Def := Subp_Item.Return_Is_Access_Def; External.Span := Subp_Item.Span; + External.Generic_Formals := Subp_Item.Generic_Formals; + External.Has_Template_Source := Subp_Item.Has_Template_Source; + External.Template_Source := Subp_Item.Template_Source; if Subp_Item.Has_Return_Type then External.Return_Type := Qualify_Type_Info (Subp_Item.Return_Type, Package_Name); end if; External.Effect_Summary := Subp_Item.Effect_Summary; External.Channel_Summary := Subp_Item.Channel_Summary; - Put_Function (Functions, UString_Value (Info.Name), Info); + if Subp_Item.Generic_Formals.Is_Empty then + Put_Function (Functions, UString_Value (Info.Name), Info); + Put_Function (Current_Generic_Function_Env, UString_Value (Info.Name), Info); + else + declare + Template_Decl : CM.Subprogram_Body; + begin + if not Subp_Item.Has_Template_Source then + Raise_Diag + (CM.Source_Frontend_Error + (Path => UString_Value (Unit.Path), + Span => Imported_Interface_Span (Package_Name), + Message => + "imported generic subprogram `" + & UString_Value (Info.Name) + & "` is missing template source in safei-v5")); + end if; + Template_Decl := + Parse_Imported_Generic_Subprogram + (Package_Name, + UString_Value (Info.Name), + UString_Value (Subp_Item.Template_Source)); + Current_Generic_Function_Templates.Include + (Canonical_Name (UString_Value (Info.Name)), + (Decl => Template_Decl, + Info => Info, + Origin_Package => FT.To_UString (Package_Name), + Actual_Type_Names => <>)); + end; + end if; Result.Imported_Subprograms.Append (External); end; end loop; @@ -11676,7 +12685,17 @@ package body Safe_Frontend.Check_Resolve is Current_Pending_Interface_Specializations.Clear; Current_Interface_Specialization_Order.Clear; Current_Interface_Specialization_By_Key.Clear; + Current_Generic_Type_Templates.Clear; + Current_Generic_Type_Instantiation_Order.Clear; + Current_Generic_Type_Instantiation_By_Key.Clear; + Current_Generic_Type_Instantiations.Clear; + Current_Generic_Type_Instantiation_Stack.Clear; + Current_Generic_Function_Templates.Clear; + Current_Pending_Generic_Specializations.Clear; + Current_Generic_Specialization_Order.Clear; + Current_Generic_Specialization_By_Key.Clear; Current_Synthetic_Functions.Clear; + Current_Generic_Function_Env.Clear; Synthetic_Helper_Types.Clear; Synthetic_Helper_Order.Clear; Synthetic_Optional_Types.Clear; @@ -11684,6 +12703,7 @@ package body Safe_Frontend.Check_Resolve is Add_Builtins (Type_Env); Result.Target_Bits := Normalized_Target_Bits; Add_Builtin_Functions (Functions); + Add_Builtin_Functions (Current_Generic_Function_Env); Result.Path := Unit.Path; Result.Kind := Unit.Kind; Result.Package_Name := Unit.Package_Name; @@ -11719,13 +12739,15 @@ package body Safe_Frontend.Check_Resolve is for Item of Unit.Items loop if Item.Kind = CM.Item_Type_Decl then - declare - Placeholder : GM.Type_Descriptor; - begin - Placeholder.Name := Item.Type_Data.Name; - Placeholder.Kind := FT.To_UString ("incomplete"); - Put_Type (Type_Env, UString_Value (Placeholder.Name), Placeholder); - end; + if Item.Type_Data.Generic_Formals.Is_Empty then + declare + Placeholder : GM.Type_Descriptor; + begin + Placeholder.Name := Item.Type_Data.Name; + Placeholder.Kind := FT.To_UString ("incomplete"); + Put_Type (Type_Env, UString_Value (Placeholder.Name), Placeholder); + end; + end if; end if; end loop; @@ -11762,6 +12784,43 @@ package body Safe_Frontend.Check_Resolve is (Canonical_Name (UString_Value (Item.Type_Data.Name))) then null; + elsif not Item.Type_Data.Generic_Formals.Is_Empty then + declare + Template_Type_Env : Type_Maps.Map := Type_Env; + Info : GM.Type_Descriptor; + begin + if Item.Type_Data.Kind /= CM.Type_Decl_Record then + Raise_Diag + (CM.Unsupported_Source_Construct + (Path => UString_Value (Unit.Path), + Span => Item.Type_Data.Span, + Message => + "PR11.11c generic types are currently limited to record and discriminated-record declarations")); + end if; + Add_Generic_Formals_To_Env + (Template_Type_Env, + Item.Type_Data.Generic_Formals); + Info := + Resolve_Type_Declaration + (Item.Type_Data, + Template_Type_Env, + Const_Env, + UString_Value (Unit.Path), + Family_By_Name, + Families); + if not Item.Type_Data.Generic_Formals.Is_Empty then + for Formal of Item.Type_Data.Generic_Formals loop + Info.Generic_Formals.Append + (Generic_Formal_Descriptor (Formal)); + end loop; + end if; + Current_Generic_Type_Templates.Include + (Canonical_Name (UString_Value (Item.Type_Data.Name)), + (Has_Decl => True, + Decl => Item.Type_Data, + Info => Info)); + Result.Types.Append (Info); + end; else declare Name : constant String := UString_Value (Item.Type_Data.Name); @@ -11973,38 +13032,67 @@ package body Safe_Frontend.Check_Resolve is Task_Priorities.Append (Priority_Info); end; when CM.Item_Subprogram => - declare - Info : constant Function_Info := - Register_Function - (Item.Subp_Data, - Type_Env, - Const_Env, - UString_Value (Unit.Path)); - begin - if Has_Interface_Params (Info, Type_Env) then - if Item.Subp_Data.Is_Public then - Raise_Diag - (CM.Source_Frontend_Error - (Path => UString_Value (Unit.Path), - Span => Item.Subp_Data.Span, - Message => - "PR11.11b does not yet admit public subprogram bodies with interface-typed parameters")); - end if; + if not Item.Subp_Data.Spec.Generic_Formals.Is_Empty then + declare + Template_Type_Env : Type_Maps.Map := Type_Env; + Info : Function_Info; + begin + Add_Generic_Formals_To_Env + (Template_Type_Env, + Item.Subp_Data.Spec.Generic_Formals); + Info := + Register_Function + (Item.Subp_Data, + Template_Type_Env, + Const_Env, + UString_Value (Unit.Path)); Validate_Interface_Method_Syntax (Item.Subp_Data, Info, - Type_Env, + Template_Type_Env, UString_Value (Unit.Path)); - Current_Interface_Templates.Include - (Canonical_Name (UString_Value (Info.Name)), - (Decl => Item.Subp_Data, Info => Info)); - end if; - Reject_Package_Level_Enum_Collision - (UString_Value (Item.Subp_Data.Spec.Name), - Item.Subp_Data.Span, - UString_Value (Unit.Path)); - Put_Function (Functions, UString_Value (Info.Name), Info); - end; + Current_Generic_Function_Templates.Include + (Canonical_Name (UString_Value (Item.Subp_Data.Spec.Name)), + (Decl => Item.Subp_Data, + Info => Info, + Origin_Package => FT.To_UString (""), + Actual_Type_Names => <>)); + end; + else + declare + Info : constant Function_Info := + Register_Function + (Item.Subp_Data, + Type_Env, + Const_Env, + UString_Value (Unit.Path)); + begin + if Has_Interface_Params (Info, Type_Env) then + if Item.Subp_Data.Is_Public then + Raise_Diag + (CM.Source_Frontend_Error + (Path => UString_Value (Unit.Path), + Span => Item.Subp_Data.Span, + Message => + "PR11.11b does not yet admit public subprogram bodies with interface-typed parameters")); + end if; + Validate_Interface_Method_Syntax + (Item.Subp_Data, + Info, + Type_Env, + UString_Value (Unit.Path)); + Current_Interface_Templates.Include + (Canonical_Name (UString_Value (Info.Name)), + (Decl => Item.Subp_Data, Info => Info)); + end if; + Reject_Package_Level_Enum_Collision + (UString_Value (Item.Subp_Data.Spec.Name), + Item.Subp_Data.Span, + UString_Value (Unit.Path)); + Put_Function (Functions, UString_Value (Info.Name), Info); + Put_Function (Current_Generic_Function_Env, UString_Value (Info.Name), Info); + end; + end if; when others => null; end case; @@ -12044,6 +13132,34 @@ package body Safe_Frontend.Check_Resolve is for Item of Unit.Items loop if Item.Kind = CM.Item_Subprogram then + if not Item.Subp_Data.Spec.Generic_Formals.Is_Empty then + declare + Template_Type_Env : Type_Maps.Map := Type_Env; + Info : Function_Info; + Subprogram : CM.Resolved_Subprogram; + begin + Add_Generic_Formals_To_Env + (Template_Type_Env, + Item.Subp_Data.Spec.Generic_Formals); + Info := + Register_Function + (Item.Subp_Data, + Template_Type_Env, + Const_Env, + UString_Value (Unit.Path)); + Subprogram.Name := Info.Name; + Subprogram.Kind := Info.Kind; + Subprogram.Is_Generic_Template := True; + Subprogram.Params := Info.Params; + Subprogram.Has_Return_Type := Info.Has_Return_Type; + Subprogram.Return_Type := Info.Return_Type; + Subprogram.Return_Is_Access_Def := Info.Return_Is_Access_Def; + Subprogram.Span := Info.Span; + Subprogram.Generic_Formals := Item.Subp_Data.Spec.Generic_Formals; + Result.Subprograms.Append (Subprogram); + end; + goto Continue_Outer_Second_Pass_Item; + end if; declare Info : constant Function_Info := Get_Function (Functions, UString_Value (Item.Subp_Data.Spec.Name)); @@ -12301,6 +13417,7 @@ package body Safe_Frontend.Check_Resolve is Result.Tasks.Append (Task_Item); end; end if; + <> end loop; if not Current_Interface_Specialization_Order.Is_Empty then @@ -12316,124 +13433,284 @@ package body Safe_Frontend.Check_Resolve is Specialized_Name : constant String := Current_Interface_Specialization_Order (Specialization_Index); begin - declare - Template : constant Interface_Template_Info := - Current_Pending_Interface_Specializations.Element - (Canonical_Name (Specialized_Name)); - Info : constant Function_Info := Template.Info; - Subprogram : CM.Resolved_Subprogram; - Visible : Type_Maps.Map := Package_Vars; - Visible_Constants : Type_Maps.Map; - Visible_Static_Constants : Static_Value_Maps.Map := Const_Env; - Local_Decl : CM.Resolved_Object_Decl; - begin - Subprogram.Name := Info.Name; - Subprogram.Kind := Info.Kind; - Subprogram.Is_Synthetic := True; - Subprogram.Params := Info.Params; - Subprogram.Has_Return_Type := Info.Has_Return_Type; - Subprogram.Return_Type := Info.Return_Type; - Subprogram.Return_Is_Access_Def := Info.Return_Is_Access_Def; - Subprogram.Span := Info.Span; + declare + Template : constant Interface_Template_Info := + Current_Pending_Interface_Specializations.Element + (Canonical_Name (Specialized_Name)); + Info : constant Function_Info := Template.Info; + Subprogram : CM.Resolved_Subprogram; + Visible : Type_Maps.Map := Package_Vars; + Visible_Constants : Type_Maps.Map; + Visible_Static_Constants : Static_Value_Maps.Map := Const_Env; + Local_Decl : CM.Resolved_Object_Decl; + begin + Subprogram.Name := Info.Name; + Subprogram.Kind := Info.Kind; + Subprogram.Is_Synthetic := True; + Subprogram.Params := Info.Params; + Subprogram.Has_Return_Type := Info.Has_Return_Type; + Subprogram.Return_Type := Info.Return_Type; + Subprogram.Return_Is_Access_Def := Info.Return_Is_Access_Def; + Subprogram.Span := Info.Span; + + for Object_Decl of Result.Objects loop + if Object_Decl.Is_Constant then + for Name of Object_Decl.Names loop + Put_Type + (Visible_Constants, + UString_Value (Name), + Object_Decl.Type_Info); + end loop; + end if; + end loop; - for Object_Decl of Result.Objects loop - if Object_Decl.Is_Constant then - for Name of Object_Decl.Names loop + for Param of Info.Params loop + Put_Type (Visible, UString_Value (Param.Name), Param.Type_Info); + Remove_Type (Visible_Constants, UString_Value (Param.Name)); + Remove_Static_Value (Visible_Static_Constants, UString_Value (Param.Name)); + end loop; + + for Decl of Template.Decl.Declarations loop + declare + Normalized : constant CM.Object_Decl := + Normalize_Object_Decl + (Decl, + Visible, + Functions, + Type_Env, + Visible_Static_Constants, + Exact_Length_Maps.Empty_Map, + UString_Value (Unit.Path)); + begin + Local_Decl := (others => <>); + Local_Decl.Names := Normalized.Names; + Local_Decl.Type_Info := Normalized.Type_Info; + Local_Decl.Is_Constant := Normalized.Is_Constant; + Local_Decl.Has_Initializer := Normalized.Has_Initializer; + Local_Decl.Has_Implicit_Default_Init := Normalized.Has_Implicit_Default_Init; + Local_Decl.Span := Normalized.Span; + Local_Decl.Initializer := Normalized.Initializer; + if Local_Decl.Is_Constant + and then Local_Decl.Has_Initializer + and then Try_Static_Value + (Local_Decl.Initializer, + Visible_Static_Constants, + Local_Decl.Static_Info) + then + null; + end if; + end; + Subprogram.Declarations.Append (Local_Decl); + for Name of Decl.Names loop + Put_Type (Visible, UString_Value (Name), Local_Decl.Type_Info); + Update_Constant_Visibility + (Visible_Constants, + UString_Value (Name), + Local_Decl.Type_Info, + Local_Decl.Is_Constant); + Update_Static_Constant_Visibility + (Visible_Static_Constants, + UString_Value (Name), + Local_Decl.Initializer, + Local_Decl.Is_Constant, + Visible_Static_Constants); + end loop; + end loop; + + declare + Previous_Select_Context : constant Boolean := + Current_Select_In_Subprogram_Body; + begin + Current_Select_In_Subprogram_Body := True; + Subprogram.Statements := + Normalize_Statement_List + (Template.Decl.Statements, + Visible, + Functions, + Type_Env, + Channel_Env, + Imported_Objects, + Visible_Constants, + Visible_Static_Constants, + Exact_Length_Maps.Empty_Map, + UString_Value (Unit.Path), + Has_Enclosing_Return => Info.Has_Return_Type, + Enclosing_Return_Type => Info.Return_Type); + Current_Select_In_Subprogram_Body := Previous_Select_Context; + exception + when others => + Current_Select_In_Subprogram_Body := Previous_Select_Context; + raise; + end; + + Result.Subprograms.Append (Subprogram); + end; + Specialization_Index := Specialization_Index + 1; + end; + end loop; + end; + end if; + + if not Current_Generic_Specialization_Order.Is_Empty then + declare + Specialization_Index : Positive := + Current_Generic_Specialization_Order.First_Index; + begin + while Specialization_Index in + Current_Generic_Specialization_Order.First_Index + .. Current_Generic_Specialization_Order.Last_Index + loop + declare + Specialized_Name : constant String := + Current_Generic_Specialization_Order (Specialization_Index); + Template : constant Generic_Function_Template_Info := + Current_Pending_Generic_Specializations.Element + (Canonical_Name (Specialized_Name)); + Info : constant Function_Info := Template.Info; + Subprogram : CM.Resolved_Subprogram; + Visible : Type_Maps.Map := Package_Vars; + Local_Functions : Function_Maps.Map := Functions; + Visible_Constants : Type_Maps.Map; + Visible_Static_Constants : Static_Value_Maps.Map := Const_Env; + Local_Type_Env : Type_Maps.Map := Type_Env; + Local_Imported_Objects : Type_Maps.Map := Imported_Objects; + Local_Decl : CM.Resolved_Object_Decl; + begin + if not Info.Generic_Formals.Is_Empty then + for Index in Info.Generic_Formals.First_Index .. Info.Generic_Formals.Last_Index loop Put_Type - (Visible_Constants, - UString_Value (Name), - Object_Decl.Type_Info); + (Local_Type_Env, + UString_Value (Info.Generic_Formals (Index).Name), + Resolve_Type + (UString_Value (Template.Actual_Type_Names (Index)), + Type_Env, + UString_Value (Unit.Path), + Template.Decl.Spec.Span)); end loop; end if; - end loop; - for Param of Info.Params loop - Put_Type (Visible, UString_Value (Param.Name), Param.Type_Info); - Remove_Type (Visible_Constants, UString_Value (Param.Name)); - Remove_Static_Value (Visible_Static_Constants, UString_Value (Param.Name)); - end loop; + Add_Imported_Package_Local_Aliases + (UString_Value (Template.Origin_Package), + Result.Imported_Types, + Result.Imported_Subprograms, + Imported_Objects, + Const_Env, + Local_Type_Env, + Local_Functions, + Local_Imported_Objects, + Visible_Static_Constants); + + Subprogram.Name := Info.Name; + Subprogram.Kind := Info.Kind; + Subprogram.Is_Synthetic := True; + Subprogram.Force_Body_Emission := True; + Subprogram.Params := Info.Params; + Subprogram.Has_Return_Type := Info.Has_Return_Type; + Subprogram.Return_Type := Info.Return_Type; + Subprogram.Return_Is_Access_Def := Info.Return_Is_Access_Def; + Subprogram.Span := Info.Span; + + for Object_Decl of Result.Objects loop + if Object_Decl.Is_Constant then + for Name of Object_Decl.Names loop + Put_Type + (Visible_Constants, + UString_Value (Name), + Object_Decl.Type_Info); + end loop; + end if; + end loop; + + for Param of Info.Params loop + Put_Type (Visible, UString_Value (Param.Name), Param.Type_Info); + Remove_Type (Visible_Constants, UString_Value (Param.Name)); + Remove_Static_Value (Visible_Static_Constants, UString_Value (Param.Name)); + end loop; + + for Decl of Template.Decl.Declarations loop + declare + Normalized : constant CM.Object_Decl := + Normalize_Object_Decl + (Decl, + Visible, + Local_Functions, + Local_Type_Env, + Visible_Static_Constants, + Exact_Length_Maps.Empty_Map, + UString_Value (Unit.Path)); + begin + Local_Decl := (others => <>); + Local_Decl.Names := Normalized.Names; + Local_Decl.Type_Info := Normalized.Type_Info; + Local_Decl.Is_Constant := Normalized.Is_Constant; + Local_Decl.Has_Initializer := Normalized.Has_Initializer; + Local_Decl.Has_Implicit_Default_Init := Normalized.Has_Implicit_Default_Init; + Local_Decl.Span := Normalized.Span; + Local_Decl.Initializer := Normalized.Initializer; + if Local_Decl.Is_Constant + and then Local_Decl.Has_Initializer + and then Try_Static_Value + (Local_Decl.Initializer, + Visible_Static_Constants, + Local_Decl.Static_Info) + then + null; + end if; + end; + Subprogram.Declarations.Append (Local_Decl); + for Name of Decl.Names loop + Put_Type (Visible, UString_Value (Name), Local_Decl.Type_Info); + Update_Constant_Visibility + (Visible_Constants, + UString_Value (Name), + Local_Decl.Type_Info, + Local_Decl.Is_Constant); + Update_Static_Constant_Visibility + (Visible_Static_Constants, + UString_Value (Name), + Local_Decl.Initializer, + Local_Decl.Is_Constant, + Visible_Static_Constants); + end loop; + end loop; - for Decl of Template.Decl.Declarations loop declare - Normalized : constant CM.Object_Decl := - Normalize_Object_Decl - (Decl, + Previous_Select_Context : constant Boolean := + Current_Select_In_Subprogram_Body; + begin + Current_Select_In_Subprogram_Body := True; + Subprogram.Statements := + Normalize_Statement_List + (Template.Decl.Statements, Visible, - Functions, - Type_Env, + Local_Functions, + Local_Type_Env, + Channel_Env, + Local_Imported_Objects, + Visible_Constants, Visible_Static_Constants, Exact_Length_Maps.Empty_Map, - UString_Value (Unit.Path)); - begin - Local_Decl := (others => <>); - Local_Decl.Names := Normalized.Names; - Local_Decl.Type_Info := Normalized.Type_Info; - Local_Decl.Is_Constant := Normalized.Is_Constant; - Local_Decl.Has_Initializer := Normalized.Has_Initializer; - Local_Decl.Has_Implicit_Default_Init := Normalized.Has_Implicit_Default_Init; - Local_Decl.Span := Normalized.Span; - Local_Decl.Initializer := Normalized.Initializer; - if Local_Decl.Is_Constant - and then Local_Decl.Has_Initializer - and then Try_Static_Value - (Local_Decl.Initializer, - Visible_Static_Constants, - Local_Decl.Static_Info) - then - null; - end if; - end; - Subprogram.Declarations.Append (Local_Decl); - for Name of Decl.Names loop - Put_Type (Visible, UString_Value (Name), Local_Decl.Type_Info); - Update_Constant_Visibility - (Visible_Constants, - UString_Value (Name), - Local_Decl.Type_Info, - Local_Decl.Is_Constant); - Update_Static_Constant_Visibility - (Visible_Static_Constants, - UString_Value (Name), - Local_Decl.Initializer, - Local_Decl.Is_Constant, - Visible_Static_Constants); - end loop; - end loop; - - declare - Previous_Select_Context : constant Boolean := - Current_Select_In_Subprogram_Body; - begin - Current_Select_In_Subprogram_Body := True; - Subprogram.Statements := - Normalize_Statement_List - (Template.Decl.Statements, - Visible, - Functions, - Type_Env, - Channel_Env, - Imported_Objects, - Visible_Constants, - Visible_Static_Constants, - Exact_Length_Maps.Empty_Map, - UString_Value (Unit.Path), - Has_Enclosing_Return => Info.Has_Return_Type, - Enclosing_Return_Type => Info.Return_Type); - Current_Select_In_Subprogram_Body := Previous_Select_Context; - exception - when others => + UString_Value (Unit.Path), + Has_Enclosing_Return => Info.Has_Return_Type, + Enclosing_Return_Type => Info.Return_Type); Current_Select_In_Subprogram_Body := Previous_Select_Context; - raise; - end; + exception + when others => + Current_Select_In_Subprogram_Body := Previous_Select_Context; + raise; + end; - Result.Subprograms.Append (Subprogram); - end; + Result.Subprograms.Append (Subprogram); Specialization_Index := Specialization_Index + 1; end; end loop; end; end if; + for Concrete_Name of Current_Generic_Type_Instantiation_Order loop + Result.Types.Append (Get_Type (Current_Generic_Type_Instantiations, Concrete_Name)); + end loop; + for Hidden_Target of Pending_Hidden_Targets loop Result.Types.Append (Get_Type (Type_Env, Hidden_Target)); end loop; diff --git a/compiler_impl/src/safe_frontend-interfaces.adb b/compiler_impl/src/safe_frontend-interfaces.adb index 8f65fae..aa8b170 100644 --- a/compiler_impl/src/safe_frontend-interfaces.adb +++ b/compiler_impl/src/safe_frontend-interfaces.adb @@ -485,6 +485,57 @@ package body Safe_Frontend.Interfaces is end loop; end; + declare + Formals : constant JSON_Array := Json_Array_Or_Empty (Value, "generic_formals"); + begin + for Index in 1 .. Length (Formals) loop + declare + Item : constant JSON_Value := Get (Formals, Index); + Formal : GM.Generic_Formal_Descriptor; + begin + if Item.Kind = JSON_Object_Type then + if Has_Field (Item, "name") + and then Get (Item, "name").Kind = JSON_String_Type + then + Formal.Name := FT.To_UString (Get (Item, "name")); + end if; + if Has_Field (Item, "has_constraint") + and then Get (Item, "has_constraint").Kind = JSON_Boolean_Type + then + Formal.Has_Constraint := Get (Get (Item, "has_constraint")); + end if; + if Has_Field (Item, "constraint_name") + and then Get (Item, "constraint_name").Kind = JSON_String_Type + then + Formal.Constraint_Name := FT.To_UString (Get (Item, "constraint_name")); + end if; + Result.Generic_Formals.Append (Formal); + end if; + end; + end loop; + end; + + if Has_Field (Value, "generic_origin") + and then Get (Value, "generic_origin").Kind = JSON_String_Type + then + Result.Has_Generic_Origin := True; + Result.Generic_Origin := FT.To_UString (Get (Value, "generic_origin")); + end if; + + declare + Actuals : constant JSON_Array := Json_Array_Or_Empty (Value, "generic_actual_types"); + begin + for Index in 1 .. Length (Actuals) loop + declare + Item : constant JSON_Value := Get (Actuals, Index); + begin + if Item.Kind = JSON_String_Type then + Result.Generic_Actual_Types.Append (FT.To_UString (Get (Item))); + end if; + end; + end loop; + end; + declare Variants : constant JSON_Array := Json_Array_Or_Empty (Value, "variant_fields"); begin @@ -929,19 +980,20 @@ package body Safe_Frontend.Interfaces is and then Format /= "safei-v2" and then Format /= "safei-v3" and then Format /= "safei-v4" + and then Format /= "safei-v5" then - raise Constraint_Error with File_Path & ": format must be safei-v1, safei-v2, safei-v3, or safei-v4"; + raise Constraint_Error with File_Path & ": format must be safei-v1, safei-v2, safei-v3, safei-v4, or safei-v5"; end if; - Is_Safei_V2 := Format in "safei-v2" | "safei-v3" | "safei-v4"; - Is_Safei_V3 := Format in "safei-v3" | "safei-v4"; + Is_Safei_V2 := Format in "safei-v2" | "safei-v3" | "safei-v4" | "safei-v5"; + Is_Safei_V3 := Format in "safei-v3" | "safei-v4" | "safei-v5"; end; if Is_Safei_V2 and then not Has_Field (Root, "unit_kind") then - raise Constraint_Error with File_Path & ": unit_kind is required for safei-v2/safei-v3/safei-v4"; + raise Constraint_Error with File_Path & ": unit_kind is required for safei-v2/safei-v3/safei-v4/safei-v5"; end if; if Is_Safei_V3 then if not Has_Field (Root, "target_bits") then - raise Constraint_Error with File_Path & ": target_bits is required for safei-v3/safei-v4"; + raise Constraint_Error with File_Path & ": target_bits is required for safei-v3/safei-v4/safei-v5"; elsif Get (Root, "target_bits").Kind /= JSON_Int_Type then raise Constraint_Error with File_Path & ": target_bits must be 32 or 64"; else @@ -1151,6 +1203,43 @@ package body Safe_Frontend.Interfaces is Subp.Params.Append (Symbol); end; end loop; + declare + Formals : constant JSON_Array := Json_Array_Or_Empty (Item, "generic_formals"); + begin + for Formal_Index in 1 .. Length (Formals) loop + declare + Formal_Item : constant JSON_Value := Get (Formals, Formal_Index); + Formal : GM.Generic_Formal_Descriptor; + begin + if Formal_Item.Kind = JSON_Object_Type then + if Has_Field (Formal_Item, "name") + and then Get (Formal_Item, "name").Kind = JSON_String_Type + then + Formal.Name := FT.To_UString (Get (Formal_Item, "name")); + end if; + if Has_Field (Formal_Item, "has_constraint") + and then Get (Formal_Item, "has_constraint").Kind = JSON_Boolean_Type + then + Formal.Has_Constraint := Get (Get (Formal_Item, "has_constraint")); + end if; + if Has_Field (Formal_Item, "constraint_name") + and then Get (Formal_Item, "constraint_name").Kind = JSON_String_Type + then + Formal.Constraint_Name := FT.To_UString (Get (Formal_Item, "constraint_name")); + end if; + Subp.Generic_Formals.Append (Formal); + end if; + end; + end loop; + end; + if Has_Field (Item, "template_source") then + if Get (Item, "template_source").Kind /= JSON_String_Type then + raise Constraint_Error with + File_Path & ": subprograms[].template_source must be a string"; + end if; + Subp.Has_Template_Source := True; + Subp.Template_Source := FT.To_UString (Get (Item, "template_source")); + end if; if not Effects.Is_Empty then for Summary of Effects loop if FT.To_String (Summary.Name) diff --git a/compiler_impl/src/safe_frontend-interfaces.ads b/compiler_impl/src/safe_frontend-interfaces.ads index 1dfd768..e8a432c 100644 --- a/compiler_impl/src/safe_frontend-interfaces.ads +++ b/compiler_impl/src/safe_frontend-interfaces.ads @@ -28,6 +28,9 @@ package Safe_Frontend.Interfaces is Has_Return_Type : Boolean := False; Return_Type : GM.Type_Descriptor; Return_Is_Access_Def : Boolean := False; + Generic_Formals : GM.Generic_Formal_Descriptor_Vectors.Vector; + Has_Template_Source : Boolean := False; + Template_Source : FT.UString := FT.To_UString (""); Span : FT.Source_Span := FT.Null_Span; Effect_Summary : GM.External_Effect_Summary; Channel_Summary : GM.External_Channel_Summary; diff --git a/compiler_impl/src/safe_frontend-mir_model.ads b/compiler_impl/src/safe_frontend-mir_model.ads index ce719a7..046601f 100644 --- a/compiler_impl/src/safe_frontend-mir_model.ads +++ b/compiler_impl/src/safe_frontend-mir_model.ads @@ -111,6 +111,16 @@ package Safe_Frontend.Mir_Model is (Index_Type => Positive, Element_Type => Interface_Member); + type Generic_Formal_Descriptor is record + Name : FT.UString := FT.To_UString (""); + Has_Constraint : Boolean := False; + Constraint_Name : FT.UString := FT.To_UString (""); + end record; + + package Generic_Formal_Descriptor_Vectors is new Ada.Containers.Indefinite_Vectors + (Index_Type => Positive, + Element_Type => Generic_Formal_Descriptor); + type Scalar_Value_Kind is (Scalar_Value_None, Scalar_Value_Integer, @@ -178,6 +188,10 @@ package Safe_Frontend.Mir_Model is Length_Bound : Natural := 0; Fields : Type_Field_Vectors.Vector; Interface_Members : Interface_Member_Vectors.Vector; + Generic_Formals : Generic_Formal_Descriptor_Vectors.Vector; + Has_Generic_Origin : Boolean := False; + Generic_Origin : FT.UString := FT.To_UString (""); + Generic_Actual_Types : FT.UString_Vectors.Vector; Has_Target : Boolean := False; Target : FT.UString := FT.To_UString (""); Has_Base : Boolean := False; @@ -388,6 +402,9 @@ package Safe_Frontend.Mir_Model is Has_Return_Type : Boolean := False; Return_Type : Type_Descriptor; Return_Is_Access_Def : Boolean := False; + Generic_Formals : Generic_Formal_Descriptor_Vectors.Vector; + Has_Template_Source : Boolean := False; + Template_Source : FT.UString := FT.To_UString (""); Span : FT.Source_Span := FT.Null_Span; Effect_Summary : External_Effect_Summary; Channel_Summary : External_Channel_Summary; diff --git a/docs/PR11.x-series-proposed.md b/docs/PR11.x-series-proposed.md index 4c3681d..36fc796 100644 --- a/docs/PR11.x-series-proposed.md +++ b/docs/PR11.x-series-proposed.md @@ -2118,8 +2118,16 @@ compile time — no dynamic dispatch, no runtime type checks, no vtables. #### User-defined generics -- The programmer can define parameterized types and parameterized functions - with value-type element constraints and optional interface constraints. +- Safe-native declarations use `of ...` syntax rather than Ada `generic` + units: + - `type pair of (l, r) is record ...` + - `function identity of t (value : t) returns t` + - `function max of t with t: orderable (a : t; b : t) returns t` +- Use sites spell explicit type arguments: + - `identity of integer (value)` + - `pair of (integer, string)` +- Public generic declarations cross package boundaries and may be + instantiated in importing units. - The compiler instantiates user-defined generics monomorphically at each use site — generic instantiation produces monomorphic Ada code at emit time rather than requiring Ada-side generic machinery. @@ -2147,7 +2155,9 @@ compile time — no dynamic dispatch, no runtime type checks, no vtables. compile time and monomorphized. The proof surface is identical to non-generic code. - Generics: each instantiation is proved independently as concrete - monomorphic Ada. No generic-level proof obligations. + monomorphic Ada. No generic-level proof obligations. Public contracts bump + to `typed-v6` / `safei-v5`, while `mir-v4` remains unchanged because all + specializations lower away before MIR. ### Rationale @@ -2326,6 +2336,523 @@ shared containers (e.g., `shared cache : map of (string, integer)`). --- +# PR12: Tooling and Developer Ergonomics + +The PR11 series delivers a language that is safe by construction. The PR12 +series makes it usable day-to-day by replacing prototype tooling with +production-grade infrastructure. + +Without this series, Safe is a language with strong guarantees that nobody +can comfortably use — the CLI is a Python wrapper, there is no formatter, +no real LSP, no workspace mode, and no package management. PR12 closes +that gap before the claims-hardening work begins. + +## Dependency Chain + +- PR12.1 follows PR11.12 (compiled native `safe` CLI binary). +- PR12.2 follows PR12.1 (single-archive distribution). +- PR12.3 follows PR12.2 (`safe fmt` — code formatter). +- PR12.4 follows PR12.3 (full LSP server). +- PR12.5 follows PR12.4 (workspace mode — multi-package project discovery). +- PR12.5a follows PR12.5 (complete VS Code extension). +- PR12.6 follows PR12.5a (package management and dependency resolution). +- v1.0 tag follows PR12.6. + +--- + +## PR12.1: Compiled Native `safe` CLI + +Replace the Python prototype CLI (`scripts/safe_cli.py`) with a compiled +native binary. + +### Scope + +- Rewrite the `safe` CLI in Ada (or eventually in Safe itself) as a + native binary that ships without a Python runtime dependency. +- All existing commands (`build`, `run`, `prove`, `deploy`) must work + identically. +- The incremental build cache (`.safe-build/`) and proof cache must + transfer from the Python implementation to the native one. +- Performance target: `safe build` on a no-change 20-file project + completes in under 1 second (vs. current Python startup overhead). + +### Why first + +Every subsequent tooling milestone builds on the CLI. A native binary +eliminates the Python runtime dependency, reduces startup latency, and +makes the distribution self-contained. + +### Dependency + +Follows PR11.12. + +--- + +## PR12.2: Single-Archive Distribution + +Ship Safe as one downloadable archive containing everything needed to +write, build, prove, and run Safe programs. + +### Scope + +- One archive per supported platform (Linux x86-64, Linux ARM64). +- Contents: `safe` CLI binary, `safec` compiler binary, GNAT, gprbuild, + GNATprove, SMT solvers (Z3, CVC5, Alt-Ergo), shared stdlib, proved + standard library. +- No Python in the distribution. No Alire in the distribution. +- Install is: extract the archive, add the `bin/` directory to `PATH`. +- `safe build` and `safe prove` work immediately after extraction with + no additional setup. + +### Why second + +The native CLI must exist before it can be packaged. The distribution +model determines how all subsequent tooling (formatter, LSP, package +manager) is delivered. + +### Dependency + +Follows PR12.1. + +--- + +## PR12.3: `safe fmt` — Code Formatter + +Add a deterministic code formatter that enforces Safe's style conventions. + +### Scope + +- `safe fmt ` reformats a Safe source file in place. +- `safe fmt --check ` exits nonzero if the file is not + already formatted (for CI gating). +- Formatting rules: consistent indentation, normalized whitespace, + canonical keyword casing (already lowercase-only), aligned record + fields, and consistent spacing around operators. +- The formatter must be idempotent: formatting an already-formatted + file produces identical output. +- The formatter is a standalone tool, not integrated into `safe build`. + +### Why third + +Formatter support is a prerequisite for a healthy contributor ecosystem +and for AI agents that generate Safe code — formatted output is more +reviewable. + +### Dependency + +Follows PR12.2 (ships in the distribution archive). + +--- + +## PR12.4: Full LSP Server + +Replace the current diagnostics-only LSP shim with a full Language +Server Protocol implementation. + +### Scope + +- Go-to-definition for functions, types, variables, and imported names. +- Hover for type information and documentation. +- Completion for visible names, record fields, methods, and builtins. +- Diagnostics on save (already exists in the current shim). +- Find all references. +- Rename symbol (local scope). +- The LSP server ships as a native binary in the distribution archive. +- Supported editors: VS Code (primary), any LSP-compatible editor. + +### Why fourth + +A real LSP server is what turns Safe from "a compiler you invoke from +the terminal" into "a language you write in an IDE." This is the single +biggest developer-experience improvement after the distribution. + +### Dependency + +Follows PR12.3 (ships in the distribution archive alongside the +formatter). + +--- + +## PR12.5: Workspace Mode + +Add multi-package project discovery so `safe build` can operate on a +project root directory rather than requiring a specific source file. + +### Scope + +- `safe build` with no arguments discovers all `.safe` files in the + current directory tree, resolves their dependency graph, and builds + them in topological order. +- A `safe.project` or equivalent manifest file defines project-level + settings: name, version, source roots, dependencies, build options. +- The incremental cache operates per-project rather than per-directory. +- `safe prove` with no arguments proves all admitted fixtures in the + project. +- `safe run` with no arguments runs the project's entry point if one + is defined. + +### Why fifth + +Workspace mode is the prerequisite for real multi-package projects and +for the package manager. Without it, every build requires naming a +specific root file. + +### Dependency + +Follows PR12.4. + +--- + +## PR12.5a: Complete VS Code Extension + +Ship a production-quality VS Code extension that surfaces the full Safe +toolchain through the editor. + +### Scope + +- **LSP client wiring:** connect to the PR12.4 LSP server for + diagnostics, go-to-definition, hover, completion, find references, + and rename. +- **Syntax highlighting:** complete TextMate grammar covering all + shipped Safe syntax including `optional`, `list of`, `map of`, + `some`/`none`, `try`/`match`, `fair select`, interfaces, generics, + `shared`, method syntax, and receiver declarations. +- **Snippets:** common patterns (function, record, enum, task, channel, + select, match, for-of, interface, generic type/function). +- **Problem matchers:** parse `safec` and `safe build` / `safe prove` + output so errors appear in the Problems panel with correct source + locations. +- **Build tasks:** `safe build`, `safe run`, `safe prove`, `safe fmt` + as VS Code tasks with keyboard shortcuts. +- **Debug launch:** launch configuration for `safe run` output binaries + via GDB/LLDB. +- **Extension marketplace:** publish to the VS Code marketplace (or + Open VSX) so installation is one click. +- The extension ships the LSP server binary or discovers it from the + distribution's `PATH`. + +### Why here + +The LSP server (PR12.4) is the backend; the VS Code extension is the +frontend that makes it usable. Without the extension, developers must +configure the LSP client manually. With it, Safe works out of the box +in the most popular editor. + +### Dependency + +Follows PR12.5 (workspace mode), because the extension's project +discovery and multi-file support should reflect workspace mode +semantics. + +--- + +## PR12.6: Package Management and Dependency Resolution + +Add a package manager so Safe projects can declare and resolve external +dependencies. + +### Scope + +- `safe.project` gains a `dependencies` section listing required + packages and version constraints. +- `safe get` fetches dependencies from a registry or source repository. +- `safe build` automatically resolves and builds dependencies before + the root project. +- Dependency resolution is deterministic and reproducible (lockfile). +- The package registry may be a simple git-based or filesystem-based + registry for v1.0; a full hosted registry is post-v1.0 work. +- Dependencies must be Safe packages. Wrapping Ada or C libraries is + out of scope for v1.0. + +### Why last in PR12 + +Package management depends on workspace mode, which depends on the +distribution, which depends on the native CLI. Each layer builds on the +previous one. + +### Dependency + +Follows PR12.5. + +--- + +## v1.0 Tag + +After PR12.6, the Safe toolchain is: + +- A compiled native CLI with build, run, prove, deploy, and fmt commands +- A single-archive distribution with no external dependencies +- A full LSP server for IDE integration +- A complete VS Code extension with syntax highlighting, snippets, problem + matchers, build tasks, debug launch, and one-click marketplace install +- Workspace mode with multi-package project support +- A package manager with deterministic dependency resolution +- A language that is safe by construction for memory, concurrency, and + absence of runtime errors +- 180+ proved emitted fixtures, 14 companion templates, embedded + evidence lane + +This is the v1.0 baseline. The claims-hardening series (PR13) follows. + +--- + +# PR13: Claims Hardening Series + +The PR11 series delivers a language that is safe by construction for the +categories it covers: memory safety, concurrency safety, and absence of +runtime errors. The PR13 series closes the gaps — the properties that Safe +does not yet prove but could, using the existing architecture. + +PR13 milestones are ordered by addressability: the easiest wins first, +the hardest deferred to later in the series. + +## Dependency Chain + +- PR13.1 follows v1.0 / PR12.6 (receive-dependency deadlock analysis). +- PR13.2 follows PR13.1 (non-task termination checking). +- PR13.3 follows PR13.2 (stack depth bounding). +- PR13.4 follows PR13.3 (channel capacity exhaustion analysis). +- PR13.5 follows PR13.4 (optional Gold-level functional correctness surface). +- PR13.6 follows PR13.5 (numeric precision: fixed-point and float hardening). +- PR13.7 follows PR13.6 (timing and scheduling evidence expansion). +- PR13.8 follows PR13.7 (information flow analysis). + +--- + +## PR13.1: Receive-Dependency Deadlock Analysis + +Add a static receive-dependency graph analysis to the frontend that rejects +programs with circular blocking dependencies among receive-side operations. + +### Scope + +- Build a task-channel dependency graph from the resolved unit where edges + represent blocking operations (`receive` and `select` channel arms). +- Reject programs where the graph contains a cycle of blocking receive + dependencies. Two tasks each waiting to receive from a channel the other + produces into — with no data flowing — is the target pattern. +- This is a frontend legality rule: it narrows the accepted program space, + not a proof obligation. The soundness argument is graph-theoretic + (acyclicity), not SMT-based. +- Cross-package analysis uses conservative channel-access summaries from + imported `.safei` contracts. + +### What this eliminates + +After PR11.9d (nonblocking send) and PR12.1, the combined deadlock story +becomes: "send never blocks (by language rule), and receive-only circular +dependencies are rejected at compile time (by static analysis). Deadlock +freedom holds for all acyclic receive-dependency topologies." + +### Dependency + +Follows v1.0 (PR12.6). + +--- + +## PR13.2: Non-Task Termination Checking + +Prove that ordinary (non-task) functions terminate. Task bodies are +intentionally non-terminating (`loop` forever) and are excluded. + +### Scope + +- Reject or warn on non-task functions that contain unbounded loops + without a provable termination argument. +- Safe already lowers most self-recursive patterns to structural loops + (PR11.8f.1). Verify that no admitted non-task function body can diverge. +- Bounded loops (`for i of items`, `while` with a decreasing variant) + are already provable. The gap is `while` loops with no obvious bound + and any remaining recursive call patterns not caught by structural + lowering. +- This is a frontend/MIR analysis pass, not an SMT proof obligation. + +### What this eliminates + +"Every non-task function in a Safe program that the compiler accepts is +guaranteed to terminate." + +### Dependency + +Follows PR13.1. + +--- + +## PR13.3: Stack Depth Bounding + +Prove that the runtime stack usage of every task and every non-task call +chain is statically bounded. + +### Scope + +- Compute worst-case stack depth from the static call graph with known + frame sizes for each function. +- Safe's non-recursive admitted surface (after PR11.8f.1 structural + lowering and PR12.2 termination checking) means the call graph is + acyclic for non-task code. Stack depth is the sum of frame sizes along + the longest call chain. +- For tasks, stack depth is the longest call chain reachable from the + task body. +- Report the computed stack depth per task and per entry point. Optionally + reject programs that exceed a configurable stack budget. +- This may use GNATstack or a custom analysis pass over the emitted Ada. + +### What this eliminates + +"Stack overflow cannot occur in a Safe program that the compiler accepts, +given the reported stack budget." + +### Dependency + +Follows PR13.2 (termination checking ensures the call graph is acyclic +for non-task code). + +--- + +## PR13.4: Channel Capacity Exhaustion Analysis + +Analyze whether channel capacity exhaustion is handled on all execution +paths. + +### Scope + +- For every `send ch, value, ok` call site, verify that the `not ok` + path is handled — either by retrying, propagating an error, or taking + an explicit recovery action. +- "Handled" means the `ok` variable is checked before the next observable + operation on the same execution path. Unchecked send-failure results + are rejected or warned. +- This is a flow-analysis extension in the MIR analyzer, not an SMT proof. +- It does not prove that channels never fill — that would require + capacity/rate analysis. It proves that the programmer handles the case + where they do fill. + +### What this eliminates + +"Every channel send in a Safe program either succeeds or the failure is +explicitly handled by the programmer." + +### Dependency + +Follows PR13.3. + +--- + +## PR13.5: Optional Gold-Level Functional Correctness Surface + +Add an optional annotation surface for functional correctness +specifications, so programmers who want to prove "the program computes the +right answer" can do so without leaving Safe. + +### Scope + +- Add optional `ensures` clauses on function return types: + `function add (a : integer; b : integer) returns integer ensures result == a + b` +- Add optional `requires` clauses on function parameters: + `function divide (a : integer; b : integer (1 to 100)) returns integer requires b > 0` +- These are **optional** — Safe programs compile and prove safe without + them. They add Gold-level correctness proofs for functions that carry + them. +- The emitter lowers `ensures` to Ada postconditions and `requires` to + Ada preconditions. GNATprove proves them the same way it proves any + SPARK contract. +- This changes Safe's identity from "zero-annotation safety" to + "zero-annotation safety with optional correctness annotations." The + safety guarantee remains annotation-free; the correctness guarantee + is opt-in. + +### What this enables + +Programmers and AI agents can state what a function should compute, and +the compiler proves it. This is the path to a standard library proved at +Gold level. + +### Dependency + +Follows PR13.4. + +--- + +## PR13.6: Numeric Precision Hardening + +Close the floating-point and fixed-point gaps. + +### Scope + +- **Fixed-point support (PS-002):** add fixed-point types to the admitted + surface with Rule 5 coverage for non-trapping arithmetic. +- **Floating-point semantic policy (PS-026):** define and enforce a + precision model beyond "inheriting Ada's defaults." Specify rounding + mode, NaN/infinity handling, and cross-platform reproducibility. +- Both require emitter and proof-surface changes to generate the + appropriate Ada types and GNATprove contracts. + +### What this eliminates + +"Numeric arithmetic in Safe programs is fully specified and proved for +integer, fixed-point, and floating-point types." + +### Dependency + +Follows PR13.5. + +--- + +## PR13.7: Timing and Scheduling Evidence Expansion + +Extend the runtime evidence base beyond the admitted STM32F4/Jorvik +subset. + +### Scope + +- Add additional Renode evidence lanes for other ARM targets (e.g., + Cortex-M7, Cortex-A53). +- Integrate WCET analysis tooling (aiT, Rapita, or equivalent) so + worst-case execution time is reported per function and per task. +- Integrate Rate Monotonic Analysis so schedulability is verified for + the admitted task set under the Jorvik priority model. +- This is evidence-expansion work, not language-feature work. The + language surface does not change. + +### What this eliminates + +"The admitted concurrency surface is backed by timing and scheduling +evidence beyond a single target, with worst-case execution time and +schedulability analysis for the task set." + +### Dependency + +Follows PR13.6. + +--- + +## PR13.8: Information Flow Analysis + +Track which data flows to which output and reject programs that violate +a declared information-flow policy. + +### Scope + +- Add optional `classification` annotations on types or bindings: + `secret : classified integer = 42` +- Add flow rules: classified data cannot flow to unclassified outputs + (print, channels to unclassified tasks, public function returns). +- The analysis is a frontend/MIR flow pass, not an SMT obligation. +- This is the most speculative item in the PR12 series. It may be + descoped or redesigned based on real usage feedback. + +### What this eliminates + +"Safe programs that use classification annotations are guaranteed to +not leak classified data to unclassified outputs." + +### Dependency + +Follows PR13.7. This is the last item in the PR12 series and the most +likely to be descoped or deferred to a post-PR12 series. + +--- + ## Proposal Incubation and Branch Strategy The numbered PR11.x milestones should be admission milestones, not dumping diff --git a/docs/artifact_contract.md b/docs/artifact_contract.md index 76317ed..1f65970 100644 --- a/docs/artifact_contract.md +++ b/docs/artifact_contract.md @@ -7,9 +7,9 @@ compiler outputs. Frozen machine-facing artifacts: -- `typed.json` with `format: "typed-v5"` +- `typed.json` with `format: "typed-v6"` - `mir.json` with `format: "mir-v4"` -- `safei.json` with `format: "safei-v4"` +- `safei.json` with `format: "safei-v5"` - `diagnostics-v0` remains the current stable diagnostics shape Not part of the frozen machine-interface contract: @@ -20,7 +20,7 @@ Not part of the frozen machine-interface contract: ## Required Top-Level Fields -`typed-v5`, `mir-v4`, and `safei-v4` must all carry: +`typed-v6`, `mir-v4`, and `safei-v5` must all carry: - `format` - `target_bits` @@ -30,9 +30,19 @@ Not part of the frozen machine-interface contract: The contract validator requires the same `target_bits` value across the typed, MIR, and interface payloads from one emit run. -`typed-v5` and `safei-v4` may additionally carry `interface_members` on public -type descriptors for Safe structural interface declarations. This is part of -the frozen contract surface from `PR11.11b` onward. +`typed-v6` and `safei-v5` may additionally carry `interface_members` on public +type descriptors for Safe structural interface declarations. + +From `PR11.11c` onward, `typed-v6` type descriptors may also carry: + +- `generic_formals` +- `generic_origin` +- `generic_actual_types` + +`safei-v5` public generic subprograms may also carry: + +- `generic_formals` +- `template_source` ## CLI Surface diff --git a/docs/tutorial.md b/docs/tutorial.md index 4fdfcf5..84aa353 100644 --- a/docs/tutorial.md +++ b/docs/tutorial.md @@ -404,6 +404,33 @@ function render (item : printable) returns string In this first interface slice, interface types are admitted only in parameter positions, and public interface-constrained subprogram bodies remain deferred. +`PR11.11c` then adds Safe-native user-defined generics. They are explicit and +monomorphic: you spell the type arguments, and the compiler specializes each +use site to ordinary concrete code before MIR. + +```safe +type pair of (l, r) is record + left : l; + right : r; + +function identity of t (value : t) returns t + return value; + +function total returns integer + values : list of integer = [1, 2, 3]; + copied : list of integer = identity of list of integer (values); + + return copied.length; +``` + +The current generic surface is intentionally narrow: + +- declarations are package-level generic types and functions only, +- function calls require explicit type arguments, +- interface constraints use named clauses such as `with T: printable`, +- generic actuals must still be ordinary admitted value types, +- Ada-style `generic ... package` syntax remains outside Safe source. + ## 6. "Silver By Construction": D27 In One Page Safe's Silver level is built around a simple premise: @@ -570,9 +597,9 @@ Why this is attractive in a SPARK/Safe world: - The discriminant makes it illegal to access `.value` when `ok == false` (a property SPARK can prove). - It nudges you toward exhaustive handling and away from "ignore the error and keep going" bugs. -Tradeoff: without generics, you will likely define many small `result_*` -types, one per value/error pairing, until the language or standard library -provides a better abstraction. +Tradeoff: even with Safe-native generics, you will still often define small +`result_*` types until the language or standard library ships a standard +`result (T, E)` abstraction. Also note: Safe draws a sharp line between recoverable and non-recoverable failures. At least today, a failed `pragma Assert` or an allocation failure is defined to abort the program via a runtime abort handler, not to be handled in-user-code like an exception. @@ -586,7 +613,7 @@ Also note: Safe draws a sharp line between recoverable and non-recoverable failu imported roots only when their sibling dependency sources are present. `safe deploy` remains narrower and still rejects roots with leading `with` clauses. -- No generics, no tagged types, no overloading: abstraction techniques are intentionally limited. +- No tagged types or overloading, and generic calls still require explicit type arguments. - The "Silver by construction" story means you will spend effort on numeric subtype design. - Some Ada habits are invalid in Safe (`'` attributes and qualified expressions, exceptions). - Tooling is incomplete today: the repo has a working compiler frontend and diff --git a/scripts/_lib/proof_inventory.py b/scripts/_lib/proof_inventory.py index 0811019..36f5d04 100644 --- a/scripts/_lib/proof_inventory.py +++ b/scripts/_lib/proof_inventory.py @@ -219,6 +219,15 @@ class EmittedProofExclusion: ] +PR11_11C_CHECKPOINT_FIXTURES = [ + "tests/positive/pr1111c_generic_basics.safe", + "tests/positive/pr1111c_generic_constraint.safe", + "tests/build/pr1111c_generic_build.safe", + "tests/build/pr1111c_provider_build.safe", + "tests/build/pr1111c_imported_build.safe", +] + + PR11_8I1_CHECKPOINT_FIXTURES = [ "tests/positive/pr115_case_terminator.safe", "tests/positive/pr115_var_basic.safe", @@ -289,6 +298,7 @@ class EmittedProofExclusion: + PR11_10C_CHECKPOINT_FIXTURES + PR11_11A_CHECKPOINT_FIXTURES + PR11_11B_CHECKPOINT_FIXTURES + + PR11_11C_CHECKPOINT_FIXTURES + EMITTED_PROOF_REGRESSION_FIXTURES ) diff --git a/scripts/run_proofs.py b/scripts/run_proofs.py index 5ebde8b..4cff119 100644 --- a/scripts/run_proofs.py +++ b/scripts/run_proofs.py @@ -34,6 +34,7 @@ PR11_10D_CHECKPOINT_FIXTURES, PR11_11A_CHECKPOINT_FIXTURES, PR11_11B_CHECKPOINT_FIXTURES, + PR11_11C_CHECKPOINT_FIXTURES, PROOF_COVERAGE_ROOTS, iter_proof_coverage_paths, ) @@ -86,6 +87,7 @@ def validate_manifests() -> None: validate_manifest("PR11.10d checkpoint manifest", PR11_10D_CHECKPOINT_FIXTURES) validate_manifest("PR11.11a checkpoint manifest", PR11_11A_CHECKPOINT_FIXTURES) validate_manifest("PR11.11b checkpoint manifest", PR11_11B_CHECKPOINT_FIXTURES) + validate_manifest("PR11.11c checkpoint manifest", PR11_11C_CHECKPOINT_FIXTURES) validate_manifest("emitted proof regression manifest", EMITTED_PROOF_REGRESSION_FIXTURES) validate_manifest("emitted proof manifest", EMITTED_PROOF_FIXTURES) validate_manifest( @@ -231,6 +233,8 @@ def main() -> int: checkpoint_11a_failures: list[tuple[str, str]] = [] checkpoint_11b_passed = 0 checkpoint_11b_failures: list[tuple[str, str]] = [] + checkpoint_11c_passed = 0 + checkpoint_11c_failures: list[tuple[str, str]] = [] regression_passed = 0 regression_failures: list[tuple[str, str]] = [] @@ -319,6 +323,11 @@ def main() -> int: temp_root=temp_root, toolchain=toolchain, ) + checkpoint_11c_passed, checkpoint_11c_failures = run_fixture_group( + fixtures=PR11_11C_CHECKPOINT_FIXTURES, + temp_root=temp_root, + toolchain=toolchain, + ) regression_passed, regression_failures = run_fixture_group( fixtures=EMITTED_PROOF_REGRESSION_FIXTURES, temp_root=temp_root, @@ -348,6 +357,7 @@ def main() -> int: + checkpoint_10c_passed + checkpoint_11a_passed + checkpoint_11b_passed + + checkpoint_11c_passed + regression_passed ) total_failures = ( @@ -366,6 +376,7 @@ def main() -> int: + checkpoint_10c_failures + checkpoint_11a_failures + checkpoint_11b_failures + + checkpoint_11c_failures + regression_failures ) @@ -465,6 +476,12 @@ def main() -> int: title="PR11.11b checkpoint", trailing_blank_line=True, ) + print_summary( + passed=checkpoint_11c_passed, + failures=checkpoint_11c_failures, + title="PR11.11c checkpoint", + trailing_blank_line=True, + ) print_summary( passed=regression_passed, failures=regression_failures, diff --git a/scripts/run_tests.py b/scripts/run_tests.py index c4d22d4..11ad8a4 100644 --- a/scripts/run_tests.py +++ b/scripts/run_tests.py @@ -37,6 +37,7 @@ VALIDATE_AST_OUTPUT = REPO_ROOT / "scripts" / "validate_ast_output.py" VSCODE_README = REPO_ROOT / "editors" / "vscode" / "README.md" VSCODE_PACKAGE_JSON = REPO_ROOT / "editors" / "vscode" / "package.json" +LOCAL_WITH_RE = re.compile(r"^\s*with\s+([a-z][a-z0-9_]*(?:\.[a-z][a-z0-9_]*)*)\s*;\s*$") EMITTED_GNATPROVE_WARNING_RE = re.compile( r"pragma\s+Warnings\s*\(\s*GNATprove\b.*?\);", @@ -228,6 +229,18 @@ REPO_ROOT / "tests" / "interfaces" / "client_printable.safe", 0, ), + ( + "imported-generic", + REPO_ROOT / "tests" / "interfaces" / "provider_generic.safe", + REPO_ROOT / "tests" / "interfaces" / "client_generic.safe", + 0, + ), + ( + "imported-generic-constraint", + REPO_ROOT / "tests" / "interfaces" / "provider_printable.safe", + REPO_ROOT / "tests" / "interfaces" / "client_generic_constraint.safe", + 0, + ), ] INTERFACE_REJECT_CASES = [ @@ -249,6 +262,12 @@ REPO_ROOT / "tests" / "interfaces" / "client_printable_ambiguous.safe", "does not satisfy interface", ), + ( + "imported-generic-missing-type-args", + REPO_ROOT / "tests" / "interfaces" / "provider_generic.safe", + REPO_ROOT / "tests" / "interfaces" / "client_generic_missing_args.safe", + "requires explicit type arguments in PR11.11c", + ), ] CHECK_SUCCESS_CASES = [ @@ -294,6 +313,7 @@ REPO_ROOT / "tests" / "positive" / "pr1110c_map_basics.safe", REPO_ROOT / "tests" / "positive" / "pr1111a_method_syntax.safe", REPO_ROOT / "tests" / "positive" / "pr1111b_interface_local.safe", + REPO_ROOT / "tests" / "positive" / "pr1111c_generic_basics.safe", ] DIAGNOSTIC_GOLDEN_CASES = [ @@ -541,6 +561,16 @@ "1\n20\n", False, ), + ( + REPO_ROOT / "tests" / "build" / "pr1111c_generic_build.safe", + "3\n9\n", + False, + ), + ( + REPO_ROOT / "tests" / "build" / "pr1111c_imported_build.safe", + "1\n", + False, + ), ( REPO_ROOT / "tests" / "build" / "pr118d_tuple_string_build.safe", "ok\n", @@ -834,6 +864,7 @@ REPO_ROOT / "tests" / "interfaces" / "provider_mutual_family.safe", REPO_ROOT / "tests" / "interfaces" / "provider_enum.safe", REPO_ROOT / "tests" / "interfaces" / "provider_printable.safe", + REPO_ROOT / "tests" / "interfaces" / "provider_generic.safe", REPO_ROOT / "tests" / "interfaces" / "pr118k_try_while_contract.safe", REPO_ROOT / "tests" / "interfaces" / "provider_list.safe", ] @@ -844,6 +875,11 @@ REPO_ROOT / "tests" / "interfaces" / "provider_binary.safe", "subprograms[0].return_is_access_def must be a boolean", ), + ( + "safei-template-source-key-on-non-generic", + REPO_ROOT / "tests" / "interfaces" / "provider_binary.safe", + "subprograms[0].template_source is only valid for generic subprograms", + ), ] EMITTED_PRAGMA_ALLOWLIST = { @@ -2302,7 +2338,12 @@ def run_output_contract_reject_case( subprograms = payload.get("subprograms") if not isinstance(subprograms, list) or not subprograms: return False, "emitted safei has no subprograms to mutate" - subprograms[0]["return_is_access_def"] = "bad" + if label == "safei-bad-return-flag": + subprograms[0]["return_is_access_def"] = "bad" + elif label == "safei-template-source-key-on-non-generic": + subprograms[0]["template_source"] = None + else: + return False, f"unknown output contract reject case {label}" safei_path.write_text(json.dumps(payload, indent=2) + "\n", encoding="utf-8") validate = run_command( @@ -2361,6 +2402,31 @@ def emit_case_ada_text( source: Path, temp_root: Path, ) -> tuple[Path, str]: + def local_dependency_sources(root: Path) -> list[Path]: + found: list[Path] = [] + seen: set[Path] = set() + pending = [root] + + while pending: + current = pending.pop() + try: + text = current.read_text(encoding="utf-8") + except OSError: + continue + + for line in text.splitlines(): + match = LOCAL_WITH_RE.match(line) + if match is None: + continue + candidate = current.parent / f"{match.group(1).split('.')[-1]}.safe" + if candidate == root or not candidate.exists() or candidate in seen: + continue + seen.add(candidate) + found.append(candidate) + pending.append(candidate) + + return found + case_root = temp_root / f"{source.stem}-{label}" out_dir = case_root / "out" iface_dir = case_root / "iface" @@ -2369,20 +2435,43 @@ def emit_case_ada_text( iface_dir.mkdir(parents=True, exist_ok=True) ada_dir.mkdir(parents=True, exist_ok=True) - emit = run_command( - [ - str(safec), - "emit", - repo_rel(source), - "--out-dir", - str(out_dir), - "--interface-dir", - str(iface_dir), - "--ada-out-dir", - str(ada_dir), - ], - cwd=REPO_ROOT, - ) + dependencies = local_dependency_sources(source) + for dependency in dependencies: + dep_emit = run_command( + [ + str(safec), + "emit", + repo_rel(dependency), + "--out-dir", + str(out_dir), + "--interface-dir", + str(iface_dir), + "--interface-search-dir", + str(iface_dir), + ], + cwd=REPO_ROOT, + ) + if dep_emit.returncode != 0: + raise RuntimeError( + f"dependency emit failed for {repo_rel(dependency)}: " + f"{first_message(dep_emit)}" + ) + + emit_args = [ + str(safec), + "emit", + repo_rel(source), + "--out-dir", + str(out_dir), + "--interface-dir", + str(iface_dir), + "--ada-out-dir", + str(ada_dir), + ] + if dependencies: + emit_args.extend(["--interface-search-dir", str(iface_dir)]) + + emit = run_command(emit_args, cwd=REPO_ROOT) if emit.returncode != 0: raise RuntimeError(f"emit failed: {first_message(emit)}") diff --git a/scripts/validate_output_contracts.py b/scripts/validate_output_contracts.py index 089cf7e..64fd731 100644 --- a/scripts/validate_output_contracts.py +++ b/scripts/validate_output_contracts.py @@ -49,6 +49,23 @@ def require_positive_int(value: Any, path: str) -> int: return value +def validate_generic_formal_list(items: Any, path: str) -> list[dict[str, Any]]: + result: list[dict[str, Any]] = [] + for index, item in enumerate(require_list(items, path)): + entry = require_mapping(item, f"{path}[{index}]") + require_string(entry.get("name"), f"{path}[{index}].name") + has_constraint = require_boolean( + entry.get("has_constraint"), + f"{path}[{index}].has_constraint", + ) + if has_constraint: + require_string(entry.get("constraint_name"), f"{path}[{index}].constraint_name") + elif entry.get("constraint_name") is not None: + fail(f"{path}[{index}].constraint_name must be null when has_constraint is false") + result.append(entry) + return result + + def validate_type_descriptor(value: Any, path: str) -> dict[str, Any]: descriptor = require_mapping(value, path) require_string(descriptor.get("name"), f"{path}.name") @@ -100,6 +117,12 @@ def validate_type_descriptor(value: Any, path: str) -> dict[str, Any]: member.get("return_is_access_def"), f"{path}.interface_members[{index}].return_is_access_def", ) + if "generic_formals" in descriptor: + validate_generic_formal_list(descriptor.get("generic_formals"), f"{path}.generic_formals") + if "generic_origin" in descriptor: + require_string(descriptor.get("generic_origin"), f"{path}.generic_origin") + if "generic_actual_types" in descriptor: + validate_string_list(descriptor.get("generic_actual_types"), f"{path}.generic_actual_types") return descriptor @@ -409,8 +432,8 @@ def require_target_bits(value: Any, path: str) -> int: def validate_typed_payload(payload: Any, *, path: str, ast_payload: dict[str, Any]) -> dict[str, Any]: typed = require_mapping(payload, path) - if typed.get("format") != "typed-v5": - fail(f"{path}.format must be typed-v5") + if typed.get("format") != "typed-v6": + fail(f"{path}.format must be typed-v6") for field in ( "target_bits", "unit_kind", @@ -546,6 +569,11 @@ def validate_safei_subprograms(items: Any, path: str) -> list[dict[str, Any]]: fail(f"{path}[{index}].return_type must be null when has_return_type is false") if "return_is_access_def" in entry: require_boolean(entry.get("return_is_access_def"), f"{path}[{index}].return_is_access_def") + if "generic_formals" in entry: + validate_generic_formal_list(entry.get("generic_formals"), f"{path}[{index}].generic_formals") + require_string(entry.get("template_source"), f"{path}[{index}].template_source") + elif "template_source" in entry: + fail(f"{path}[{index}].template_source is only valid for generic subprograms") validate_span(entry.get("span"), f"{path}[{index}].span") result.append(entry) return result @@ -593,8 +621,8 @@ def validate_safei_channel_access_summaries(items: Any, path: str) -> list[dict[ def validate_safei_payload(payload: Any, *, path: str) -> dict[str, Any]: safei = require_mapping(payload, path) - if safei.get("format") != "safei-v4": - fail(f"{path}.format must be safei-v4") + if safei.get("format") != "safei-v5": + fail(f"{path}.format must be safei-v5") for field in ( "target_bits", "unit_kind", diff --git a/spec/02-restrictions.md b/spec/02-restrictions.md index 1565bd5..ea5e5ef 100644 --- a/spec/02-restrictions.md +++ b/spec/02-restrictions.md @@ -204,7 +204,7 @@ This section enumerates every feature of ISO/IEC 8652:2023 (Ada 2022) that Safe #### 8.5 Renaming Declarations -53. **Renaming declarations (§8.5).** Retained: object renaming (§8.5.1), package renaming (§8.5.3), subprogram renaming (§8.5.4). Exception renaming (§8.5.2) is excluded (exceptions are excluded). Generic renaming (§8.5.5) is excluded (generics are excluded). +53. **Renaming declarations (§8.5).** Retained: object renaming (§8.5.1), package renaming (§8.5.3), subprogram renaming (§8.5.4). Exception renaming (§8.5.2) is excluded (exceptions are excluded). Ada generic renaming (§8.5.5) is excluded; Safe-native generics do not introduce a separate renaming form. #### 8.6 Overload Resolution @@ -246,7 +246,7 @@ This section enumerates every feature of ISO/IEC 8652:2023 (Ada 2022) that Safe ### 2.1.11 Section 12 — Generic Units (8652:2023 §12) -69. **Generics (§12.1–§12.8).** Section 12 of 8652:2023 is excluded in its entirety. A conforming implementation shall reject any generic declaration, generic body, or generic instantiation. Rationale: generics require instantiation, which adds significant compiler complexity (D16). +69. **Ada generic units (§12.1–§12.8).** Section 12 of 8652:2023 is excluded in its entirety. A conforming implementation shall reject any Ada generic declaration, generic body, or Ada generic instantiation. Safe instead admits its own native generic type and function surface (`type name of ...`, `function name of ...`) with frontend monomorphization; that Safe-native surface is specified elsewhere in this document set and is not an adoption of Ada §12. ### 2.1.12 Section 13 — Representation Issues (8652:2023 §13) @@ -298,11 +298,11 @@ This section enumerates every feature of ISO/IEC 8652:2023 (Ada 2022) that Safe #### Annex F — Information Systems -88. **Information systems (Annex F).** Excluded in its entirety. Rationale: requires generics (decimal types operations use generic packages). +88. **Information systems (Annex F).** Excluded in its entirety. Rationale: requires Ada generic decimal libraries and related Annex F runtime surface beyond the admitted Safe-native generic feature set. #### Annex G — Numerics -89. **Numerics (Annex G).** The core numerics model from §3.5 is retained. Annex G extensions (complex types G.1, generic elementary functions G.2) are excluded (require generics). +89. **Numerics (Annex G).** The core numerics model from §3.5 is retained. Annex G extensions (complex types G.1, generic elementary functions G.2) are excluded; they require broader numeric libraries and Ada generic packages beyond the admitted Safe-native generic feature set. #### Annex H — High Integrity Systems @@ -1180,7 +1180,7 @@ A conforming implementation shall accept all three forms. All other domain-level failures — including but not limited to invalid input, missing data, communication timeouts, and format errors — should use the discriminated result convention. -151. **Future evolution: parametric result type.** The current convention requires each API to define its own result type, because generics are excluded (paragraph 69). A future version of Safe may introduce a built-in parametric type constructor (e.g., `Result[T, E]`) and an error-propagation operator to reduce boilerplate. Such features would be additive — programs written using the per-type discriminated result convention defined in this section would remain conforming. +151. **Future evolution: parametric result type.** The current convention still commonly uses per-API result records even after Safe-native generics, because a standard `result (T, E)` abstraction and error-propagation surface are not yet shipped. A future version of Safe may introduce a built-in parametric type constructor (e.g., `Result[T, E]`) and an error-propagation operator to reduce boilerplate. Such features would be additive — programs written using the per-type discriminated result convention defined in this section would remain conforming. 151a. **Future evolution: task-level fault containment.** Safe's ownership model guarantees that a task's mutable state is unreachable from other tasks (Section 4, §4.2). This isolation property means that a fatal failure in one task cannot corrupt another task's state. A future version of Safe may exploit this property to contain certain fatal failures to the failing task rather than aborting the entire program. The following subsections sketch the design constraints such a feature would need to satisfy. diff --git a/spec/08-syntax-summary.md b/spec/08-syntax-summary.md index c0432e6..33acbea 100644 --- a/spec/08-syntax-summary.md +++ b/spec/08-syntax-summary.md @@ -117,9 +117,11 @@ basic_declaration ::= ``` type_declaration ::= - [ 'public' ] 'type' defining_identifier [ known_discriminant_part ] + [ 'public' ] 'type' defining_identifier + [ generic_formal_part ] [ known_discriminant_part ] 'is' type_definition ';' - | [ 'public' ] 'type' defining_identifier 'is' 'interface' + | [ 'public' ] 'type' defining_identifier [ generic_formal_part ] + 'is' 'interface' indented_interface_member_list incomplete_type_declaration ::= @@ -285,6 +287,20 @@ indented_interface_member_list ::= interface_member_specification ::= function_specification ';' + +generic_formal_part ::= + 'of' generic_formal_list [ generic_constraint_part ] + +generic_formal_list ::= + defining_identifier + | '(' defining_identifier { ',' defining_identifier } ')' + +generic_constraint_part ::= + 'with' generic_constraint_association + { ',' generic_constraint_association } + +generic_constraint_association ::= + defining_identifier ':' subtype_mark ``` ## 8.5 Subtype Indications @@ -370,7 +386,7 @@ name ::= | function_call direct_name ::= - identifier + identifier [ generic_actual_part ] indexed_component ::= name '(' expression { ',' expression } ')' @@ -379,11 +395,29 @@ slice ::= name '(' discrete_range ')' selected_component ::= - name '.' selector_name + name '.' selector_name [ generic_actual_part ] selector_name ::= identifier +generic_actual_part ::= + 'of' generic_actual_list + +generic_actual_list ::= + generic_actual_type + | '(' generic_actual_type { ',' generic_actual_type } ')' + +generic_actual_type ::= + subtype_mark + | binary_type_definition + | list_type_spec + | map_type_spec + | optional_type_spec + | growable_array_type_spec + +Generic actuals in PR11.11c use these explicit type constructors at +name/call sites, but do not admit trailing subtype constraints there. + type_conversion ::= type_target '(' expression ')' @@ -704,6 +738,7 @@ subprogram_specification ::= function_specification ::= 'function' [ receiver_parameter_clause ] defining_identifier + [ generic_formal_part ] [ formal_part ] [ 'returns' subtype_indication ] receiver_parameter_clause ::= @@ -747,6 +782,20 @@ strict subset: - public interface-constrained subprogram bodies remain deferred to a later milestone. +For the post-PR11.11c surface, Safe-native generics are also admitted with a +strict subset: + +- generic declarations use Safe-native `of ...` syntax rather than Ada + `generic` units, +- generic type declarations are package-level record or discriminated-record + declarations only in this milestone, +- generic function calls require explicit type arguments, such as + `identity of integer (value)`, +- multi-parameter and constrained forms use a trailing named constraint map, + such as `function max of T with T: orderable ...`, +- public generic declarations may cross package boundaries, but all + concrete specializations lower away before MIR and emitted Ada. + default_expression ::= expression ``` diff --git a/tests/build/pr1111c_generic_build.safe b/tests/build/pr1111c_generic_build.safe new file mode 100644 index 0000000..87ae77e --- /dev/null +++ b/tests/build/pr1111c_generic_build.safe @@ -0,0 +1,26 @@ +package pr1111c_generic_build + + type pair of (l, r) is record + left : l; + right : r; + + function identity of t (value : t) returns t + return value; + + function main returns integer + values : list of integer = [4, 5, 6]; + copied : list of integer = identity of list of integer (values); + maybe : optional integer = some (9); + copied_maybe : optional integer = identity of optional integer (maybe); + totals : pair of (integer, integer) = (left = copied.length, right = 0); + + if copied_maybe.present + totals.right = copied_maybe.value; + else + totals.right = 0; + + print (totals.left); + return totals.right; + + print (main); + diff --git a/tests/build/pr1111c_imported_build.safe b/tests/build/pr1111c_imported_build.safe new file mode 100644 index 0000000..1faff78 --- /dev/null +++ b/tests/build/pr1111c_imported_build.safe @@ -0,0 +1,15 @@ +with pr1111c_provider_build; + +package pr1111c_imported_build + + function total returns integer + values : list of integer = [1, 2, 3]; + copied : list of integer = pr1111c_provider_build.identity of list of integer (values); + item : pr1111c_provider_build.pair of (integer, string) = (left = copied.length, right = "ok"); + + if item.left == 3 and then item.right == "ok" + return 1; + else + return 0; + + print (total); diff --git a/tests/build/pr1111c_provider_build.safe b/tests/build/pr1111c_provider_build.safe new file mode 100644 index 0000000..f1d8313 --- /dev/null +++ b/tests/build/pr1111c_provider_build.safe @@ -0,0 +1,9 @@ +package pr1111c_provider_build + + public type pair of (l, r) is record + left : l; + right : r; + + public function identity of t (value : t) returns t + return value; + diff --git a/tests/interfaces/client_generic.safe b/tests/interfaces/client_generic.safe new file mode 100644 index 0000000..ef3ebba --- /dev/null +++ b/tests/interfaces/client_generic.safe @@ -0,0 +1,13 @@ +with provider_generic; + +package client_generic + + function total returns integer + values : list of integer = [1, 2]; + copied : list of integer = provider_generic.identity of list of integer (values); + item : provider_generic.pair of (integer, string) = (left = copied.length, right = "ok"); + + if item.left == 2 and then item.right == "ok" + return 1; + else + return 0; diff --git a/tests/interfaces/client_generic_constraint.safe b/tests/interfaces/client_generic_constraint.safe new file mode 100644 index 0000000..7ab4bbe --- /dev/null +++ b/tests/interfaces/client_generic_constraint.safe @@ -0,0 +1,12 @@ +with provider_printable; + +package client_generic_constraint + + function render of t with t: provider_printable.printable (item : t) returns string + return item.label(); + + function total returns integer + item : provider_printable.widget = (text = "Bob"); + text : string = render of provider_printable.widget (item); + + return text.length; diff --git a/tests/interfaces/client_generic_missing_args.safe b/tests/interfaces/client_generic_missing_args.safe new file mode 100644 index 0000000..2e2740a --- /dev/null +++ b/tests/interfaces/client_generic_missing_args.safe @@ -0,0 +1,9 @@ +with provider_generic; + +package client_generic_missing_args + + function total returns integer + values : list of integer = [1, 2]; + + return provider_generic.identity (values).length; + diff --git a/tests/interfaces/provider_generic.safe b/tests/interfaces/provider_generic.safe new file mode 100644 index 0000000..e39ece1 --- /dev/null +++ b/tests/interfaces/provider_generic.safe @@ -0,0 +1,9 @@ +package provider_generic + + public type pair of (l, r) is record + left : l; + right : r; + + public function identity of t (value : t) returns t + return value; + diff --git a/tests/negative/neg_pr1111c_ada_generic_keyword.safe b/tests/negative/neg_pr1111c_ada_generic_keyword.safe new file mode 100644 index 0000000..7229c9d --- /dev/null +++ b/tests/negative/neg_pr1111c_ada_generic_keyword.safe @@ -0,0 +1,7 @@ +package neg_pr1111c_ada_generic_keyword + + generic + type t is private; + + function identity (value : t) returns t; + diff --git a/tests/negative/neg_pr1111c_free_call_constraint.safe b/tests/negative/neg_pr1111c_free_call_constraint.safe new file mode 100644 index 0000000..417ec37 --- /dev/null +++ b/tests/negative/neg_pr1111c_free_call_constraint.safe @@ -0,0 +1,14 @@ +package neg_pr1111c_free_call_constraint + + type printable is interface + function (self : printable) label returns string; + + type widget is record + text : string; + + function (self : widget) label returns string + return self.text; + + function render of t with t: printable (item : t) returns string + return label (item); + diff --git a/tests/negative/neg_pr1111c_interface_actual.safe b/tests/negative/neg_pr1111c_interface_actual.safe new file mode 100644 index 0000000..7d1770f --- /dev/null +++ b/tests/negative/neg_pr1111c_interface_actual.safe @@ -0,0 +1,16 @@ +package neg_pr1111c_interface_actual + + type printable is interface + function (self : printable) label returns string; + + type holder of t is record + value : t; + + function total returns integer + var item : holder of printable; + + if item.value.present + return 1; + else + return 0; + diff --git a/tests/negative/neg_pr1111c_missing_member.safe b/tests/negative/neg_pr1111c_missing_member.safe new file mode 100644 index 0000000..fd823ce --- /dev/null +++ b/tests/negative/neg_pr1111c_missing_member.safe @@ -0,0 +1,19 @@ +package neg_pr1111c_missing_member + + type printable is interface + function (self : printable) label returns string; + + type widget is record + value : integer; + + function render of t with t: printable (item : t) returns string + return item.label(); + + function total returns integer + item : widget = (value = 1); + + if render of widget (item) == "ok" + return 1; + else + return 0; + diff --git a/tests/negative/neg_pr1111c_missing_type_args.safe b/tests/negative/neg_pr1111c_missing_type_args.safe new file mode 100644 index 0000000..07f8cac --- /dev/null +++ b/tests/negative/neg_pr1111c_missing_type_args.safe @@ -0,0 +1,8 @@ +package neg_pr1111c_missing_type_args + + function identity of t (value : t) returns t + return value; + + function total returns integer + return identity (1); + diff --git a/tests/negative/neg_pr1111c_reference_actual.safe b/tests/negative/neg_pr1111c_reference_actual.safe new file mode 100644 index 0000000..3069272 --- /dev/null +++ b/tests/negative/neg_pr1111c_reference_actual.safe @@ -0,0 +1,14 @@ +package neg_pr1111c_reference_actual + + type node is record + next : node; + + type wrapper is record + item : node; + + type box of t is record + value : t; + + function total returns integer + var item : box of wrapper; + return 0; diff --git a/tests/negative/neg_pr1111c_unsupported_generic_type.safe b/tests/negative/neg_pr1111c_unsupported_generic_type.safe new file mode 100644 index 0000000..5ce8f0c --- /dev/null +++ b/tests/negative/neg_pr1111c_unsupported_generic_type.safe @@ -0,0 +1,4 @@ +package neg_pr1111c_unsupported_generic_type + + type box of t is integer; + diff --git a/tests/positive/pr1111c_generic_basics.safe b/tests/positive/pr1111c_generic_basics.safe new file mode 100644 index 0000000..6ab1bf8 --- /dev/null +++ b/tests/positive/pr1111c_generic_basics.safe @@ -0,0 +1,28 @@ +package pr1111c_generic_basics + + subtype small_value is integer (0 to 100); + + type pair of (l, r) is record + left : l; + right : r; + + function identity of t (value : t) returns t + return value; + + function sum_pair (item : pair of (small_value, small_value)) returns integer + return item.left + item.right; + + function total returns integer + values : list of integer = [1, 2, 3]; + maybe : optional integer = some (4); + copied_values : list of integer = identity of list of integer (values); + copied_maybe : optional integer = identity of optional integer (maybe); + ints : pair of (small_value, small_value) = (left = 10, right = 20); + + if copied_values.length == 3 and then copied_maybe.present + if copied_maybe.value == 4 and then sum_pair (ints) == 30 + return 1; + else + return 0; + else + return 0; diff --git a/tests/positive/pr1111c_generic_constraint.safe b/tests/positive/pr1111c_generic_constraint.safe new file mode 100644 index 0000000..0b1bd2d --- /dev/null +++ b/tests/positive/pr1111c_generic_constraint.safe @@ -0,0 +1,23 @@ +package pr1111c_generic_constraint + + type orderable is interface + function (self : orderable) rank returns integer; + + type score is record + value : integer; + + function (self : score) rank returns integer + return self.value; + + function best_rank of t with t: orderable (left : t; right : t) returns integer + if left.rank() >= right.rank() + return left.rank(); + else + return right.rank(); + + function total returns integer + low : score = (value = 3); + high : score = (value = 7); + + return best_rank of score (low, high); +