diff --git a/compiler/ast_schema.json b/compiler/ast_schema.json index d112a43..b9c755d 100644 --- a/compiler/ast_schema.json +++ b/compiler/ast_schema.json @@ -307,6 +307,15 @@ { "name": "span", "type": "Span", "optional": false } ] }, + { + "node_type": "InterfaceTypeDefinition", + "production": "interface_type_definition", + "source_section": "8.4", + "fields": [ + { "name": "members", "type": "List", "optional": false }, + { "name": "span", "type": "Span", "optional": false } + ] + }, { "node_type": "IndexSubtypeDefinition", "production": "index_subtype_definition", diff --git a/compiler_impl/README.md b/compiler_impl/README.md index 4bdb54e..784e4b3 100644 --- a/compiler_impl/README.md +++ b/compiler_impl/README.md @@ -105,11 +105,11 @@ contract is documented in [`../docs/artifact_contract.md`](../docs/artifact_cont - `.ast.json` The parser AST, shaped to [`../compiler/ast_schema.json`](../compiler/ast_schema.json). - `.typed.json` - The typed frontend snapshot (`typed-v4`). + The typed frontend snapshot (`typed-v5`). - `.mir.json` The lowered MIR document (`mir-v4`). - `.safei.json` - The dependency interface contract (`safei-v3`). + The dependency interface contract (`safei-v4`). When `--ada-out-dir ` is provided, `safec emit` also writes emitted Ada/SPARK artifacts: @@ -191,7 +191,7 @@ run the unit. - Python remains repo glue and orchestration only. The compiler itself is the Ada-native `safec` binary. -- Cross-unit resolution uses emitted `safei-v3` interfaces plus +- Cross-unit resolution uses emitted `safei-v4` interfaces plus `--interface-search-dir`. - [`../docs/emitted_output_verification_matrix.md`](../docs/emitted_output_verification_matrix.md) is the current statement of what is compile-only versus `flow` / `prove` diff --git a/compiler_impl/src/safe_frontend-ada_emit.adb b/compiler_impl/src/safe_frontend-ada_emit.adb index c3cde97..f16255f 100644 --- a/compiler_impl/src/safe_frontend-ada_emit.adb +++ b/compiler_impl/src/safe_frontend-ada_emit.adb @@ -18668,15 +18668,17 @@ package body Safe_Frontend.Ada_Emit is end if; for Subprogram of Unit.Subprograms loop - declare - Name_Text : constant String := FT.To_String (Subprogram.Name); - begin - if Name_Text'Length > 0 - and then Expr_Uses_Name (Decl.Initializer, Name_Text) - then - return True; - end if; - end; + if not Subprogram.Is_Interface_Template then + declare + Name_Text : constant String := FT.To_String (Subprogram.Name); + begin + if Name_Text'Length > 0 + and then Expr_Uses_Name (Decl.Initializer, Name_Text) + then + return True; + end if; + end; + end if; end loop; return False; @@ -19051,9 +19053,11 @@ package body Safe_Frontend.Ada_Emit is end if; for Type_Item of Unit.Types loop - 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); + if 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); + end if; end if; end loop; @@ -19139,25 +19143,27 @@ package body Safe_Frontend.Ada_Emit is if not Unit.Subprograms.Is_Empty then for Subprogram of Unit.Subprograms loop - declare - Expression_Image : constant String := - 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); - end; + if not Subprogram.Is_Interface_Template then + declare + Expression_Image : constant String := + 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); + end; + end if; end loop; Append_Line (Spec_Inner); end if; @@ -19244,8 +19250,10 @@ package body Safe_Frontend.Ada_Emit is Append_Line (Body_Inner); for Type_Item of Unit.Types loop - Render_Growable_Array_Helper_Body - (Body_Inner, Unit, Document, Type_Item, State); + if FT.To_String (Type_Item.Kind) /= "interface" then + Render_Growable_Array_Helper_Body + (Body_Inner, Unit, Document, Type_Item, State); + end if; end loop; for Type_Item of Synthetic_Types loop @@ -19291,7 +19299,9 @@ package body Safe_Frontend.Ada_Emit is end loop; for Subprogram of Unit.Subprograms loop - if Render_Expression_Function_Image (Unit, Document, Subprogram, State)'Length = 0 then + if not Subprogram.Is_Interface_Template + and then Render_Expression_Function_Image (Unit, Document, Subprogram, State)'Length = 0 + then Render_Subprogram_Body (Body_Inner, Unit, Document, Subprogram, State); end if; end loop; diff --git a/compiler_impl/src/safe_frontend-check_emit.adb b/compiler_impl/src/safe_frontend-check_emit.adb index 16700fd..885dd48 100644 --- a/compiler_impl/src/safe_frontend-check_emit.adb +++ b/compiler_impl/src/safe_frontend-check_emit.adb @@ -52,6 +52,13 @@ package body Safe_Frontend.Check_Emit is function Shift_Expression_Node (Expr : CM.Expr_Access) return String; function Type_Json (Info : GM.Type_Descriptor) return String; + function Parameter_Spec_Node + (Param : CM.Parameter_Spec) return String; + function Formal_Part_Node + (Params : CM.Parameter_Vectors.Vector; + Span : FT.Source_Span) return String; + function Subprogram_Spec_Node + (Spec : CM.Subprogram_Spec) return String; function Operator_String (Value : FT.UString) return String is begin @@ -1388,6 +1395,28 @@ package body Safe_Frontend.Check_Emit is & "},""span"":" & JS.Span_Object (Decl.Span) & "}"; + when CM.Type_Decl_Interface => + declare + Members : String_Vectors.Vector; + begin + if not Decl.Interface_Members.Is_Empty then + for Member of Decl.Interface_Members loop + Members.Append (Subprogram_Spec_Node (Member)); + end loop; + end if; + return + "{""node_type"":""TypeDeclaration"",""is_public"":" + & JS.Bool_Literal (Decl.Is_Public) + & ",""name"":" + & JS.Quote (Decl.Name) + & ",""discriminant_part"":null,""type_definition"":{""node_type"":""InterfaceTypeDefinition"",""members"":" + & Json_List (Members) + & ",""span"":" + & JS.Span_Object (Decl.Span) + & "},""span"":" + & JS.Span_Object (Decl.Span) + & "}"; + end; when CM.Type_Decl_Record => declare Component_List : constant String := Component_List_Node (Decl); @@ -2001,6 +2030,42 @@ package body Safe_Frontend.Check_Emit is & "}"; end Formal_Part_Node; + function Subprogram_Spec_Node + (Spec : CM.Subprogram_Spec) return String is + begin + if Spec.Has_Return_Type then + return + "{""node_type"":""FunctionSpecification"",""name"":" + & JS.Quote (Spec.Name) + & ",""receiver"":" + & (if Spec.Has_Receiver + then Parameter_Spec_Node (Spec.Receiver) + else "null") + & ",""formal_part"":" + & (if Spec.Params.Is_Empty then "null" + else Formal_Part_Node (Spec.Params, Spec.Span)) + & ",""return_type"":" + & Object_Type_Node (Spec.Return_Type) + & ",""span"":" + & JS.Span_Object (Spec.Span) + & "}"; + end if; + + return + "{""node_type"":""ProcedureSpecification"",""name"":" + & JS.Quote (Spec.Name) + & ",""receiver"":" + & (if Spec.Has_Receiver + then Parameter_Spec_Node (Spec.Receiver) + else "null") + & ",""formal_part"":" + & (if Spec.Params.Is_Empty then "null" + else Formal_Part_Node (Spec.Params, Spec.Span)) + & ",""span"":" + & JS.Span_Object (Spec.Span) + & "}"; + end Subprogram_Spec_Node; + function Signature_For (Subprogram : CM.Resolved_Subprogram) return String is Result : US.Unbounded_String := US.Null_Unbounded_String; begin @@ -2060,20 +2125,9 @@ package body Safe_Frontend.Check_Emit is return "{""node_type"":""SubprogramBody"",""is_public"":" & JS.Bool_Literal (Parsed.Is_Public) - & ",""spec"":{""node_type"":""FunctionSpecification"",""name"":" - & JS.Quote (Parsed.Spec.Name) - & ",""receiver"":" - & (if Parsed.Spec.Has_Receiver - then Parameter_Spec_Node (Parsed.Spec.Receiver) - else "null") - & ",""formal_part"":" - & (if Parsed.Spec.Params.Is_Empty then "null" - else Formal_Part_Node (Parsed.Spec.Params, Parsed.Spec.Span)) - & ",""return_type"":" - & Object_Type_Node (Parsed.Spec.Return_Type) - & ",""span"":" - & JS.Span_Object (Parsed.Spec.Span) - & "},""declarative_part"":" + & ",""spec"":" + & Subprogram_Spec_Node (Parsed.Spec) + & ",""declarative_part"":" & Json_List (Decls) & ",""body"":" & Sequence_Node (Parsed.Statements, Resolved.Statements, Parsed.Span) @@ -2087,18 +2141,9 @@ package body Safe_Frontend.Check_Emit is return "{""node_type"":""SubprogramBody"",""is_public"":" & JS.Bool_Literal (Parsed.Is_Public) - & ",""spec"":{""node_type"":""ProcedureSpecification"",""name"":" - & JS.Quote (Parsed.Spec.Name) - & ",""receiver"":" - & (if Parsed.Spec.Has_Receiver - then Parameter_Spec_Node (Parsed.Spec.Receiver) - else "null") - & ",""formal_part"":" - & (if Parsed.Spec.Params.Is_Empty then "null" - else Formal_Part_Node (Parsed.Spec.Params, Parsed.Spec.Span)) - & ",""span"":" - & JS.Span_Object (Parsed.Spec.Span) - & "},""declarative_part"":" + & ",""spec"":" + & Subprogram_Spec_Node (Parsed.Spec) + & ",""declarative_part"":" & Json_List (Decls) & ",""body"":" & Sequence_Node (Parsed.Statements, Resolved.Statements, Parsed.Span) @@ -2216,6 +2261,8 @@ package body Safe_Frontend.Check_Emit is (Item.Subp_Data, (Name => Item.Subp_Data.Spec.Name, Kind => Item.Subp_Data.Spec.Kind, + Is_Synthetic => False, + Is_Interface_Template => False, Params => <>, Has_Return_Type => False, Return_Type => <>, @@ -2363,16 +2410,18 @@ package body Safe_Frontend.Check_Emit is begin if not Resolved.Subprograms.Is_Empty then for Subp of Resolved.Subprograms loop - Items.Append - ("{""name"":" - & JS.Quote (Subp.Name) - & ",""kind"":" - & JS.Quote (Subp.Kind) - & ",""signature"":" - & JS.Quote (Signature_For (Subp)) - & ",""span"":" - & JS.Span_Object (Subp.Span) - & "}"); + if not Subp.Is_Interface_Template and then not Subp.Is_Synthetic then + Items.Append + ("{""name"":" + & JS.Quote (Subp.Name) + & ",""kind"":" + & JS.Quote (Subp.Kind) + & ",""signature"":" + & JS.Quote (Signature_For (Subp)) + & ",""span"":" + & JS.Span_Object (Subp.Span) + & "}"); + end if; end loop; end if; if not Resolved.Tasks.Is_Empty then @@ -2836,6 +2885,43 @@ package body Safe_Frontend.Check_Emit is Fields : String_Vectors.Vector; begin declare + function Signature_Param_Json + (Param : GM.Signature_Param) return String is + begin + return + "{""name"":" + & JS.Quote (Param.Name) + & ",""mode"":" + & JS.Quote (Param.Mode) + & ",""type_name"":" + & JS.Quote (Param.Type_Name) + & "}"; + end Signature_Param_Json; + + function Interface_Member_Json + (Member : GM.Interface_Member) return String + is + Params : String_Vectors.Vector; + begin + if not Member.Params.Is_Empty then + for Param of Member.Params loop + Params.Append (Signature_Param_Json (Param)); + end loop; + end if; + return + "{""name"":" + & JS.Quote (Member.Name) + & ",""params"":" + & Json_List (Params) + & ",""has_return_type"":" + & JS.Bool_Literal (Member.Has_Return_Type) + & ",""return_type"":" + & (if Member.Has_Return_Type then JS.Quote (Member.Return_Type) else "null") + & ",""return_is_access_def"":" + & JS.Bool_Literal (Member.Return_Is_Access_Def) + & "}"; + end Interface_Member_Json; + function Public_Type_Kind (Value : GM.Type_Descriptor) return String is begin if FT.To_String (Value.Kind) = "access" then @@ -2929,6 +3015,16 @@ package body Safe_Frontend.Check_Emit is end loop; Items.Append ("""fields"":{" & Join_Object_Fields (Fields) & "}"); end if; + if not Info.Interface_Members.Is_Empty then + declare + Members : String_Vectors.Vector; + begin + for Member of Info.Interface_Members loop + Members.Append (Interface_Member_Json (Member)); + end loop; + Items.Append ("""interface_members"":" & Json_List (Members)); + end; + end if; if Info.Has_Target then Items.Append ("""target"":" & JS.Quote (Info.Target)); end if; @@ -3132,7 +3228,7 @@ package body Safe_Frontend.Check_Emit is begin return "{" - & """format"":""typed-v4""," + & """format"":""typed-v5""," & """target_bits"":" & Positive'Image (Resolved.Target_Bits) & "," & """unit_kind"":" & JS.Quote ((if Parsed.Kind = CM.Unit_Entry then "entry" else "package")) @@ -3171,7 +3267,7 @@ package body Safe_Frontend.Check_Emit is begin return "{" - & """format"":""safei-v3""," + & """format"":""safei-v4""," & """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 ef7ecef..c11d209 100644 --- a/compiler_impl/src/safe_frontend-check_lower.adb +++ b/compiler_impl/src/safe_frontend-check_lower.adb @@ -3086,12 +3086,14 @@ package body Safe_Frontend.Check_Lower is end if; for Subprogram of Unit.Subprograms loop - Result.Graphs.Append - (Lower_Subprogram - (Subprogram, - Unit.Subprograms, - Type_Env, - Unit.Objects)); + if not Subprogram.Is_Interface_Template then + Result.Graphs.Append + (Lower_Subprogram + (Subprogram, + Unit.Subprograms, + Type_Env, + Unit.Objects)); + end if; end loop; for Task_Item of Unit.Tasks loop diff --git a/compiler_impl/src/safe_frontend-check_model.ads b/compiler_impl/src/safe_frontend-check_model.ads index 479691d..1d68c8d 100644 --- a/compiler_impl/src/safe_frontend-check_model.ads +++ b/compiler_impl/src/safe_frontend-check_model.ads @@ -153,6 +153,22 @@ package Safe_Frontend.Check_Model is (Index_Type => Positive, Element_Type => Parameter_Spec); + type Subprogram_Spec is record + Kind : FT.UString := FT.To_UString (""); + Name : FT.UString := FT.To_UString (""); + Has_Receiver : Boolean := False; + Receiver : Parameter_Spec; + Params : Parameter_Vectors.Vector; + Has_Return_Type : Boolean := False; + Return_Type : Type_Spec; + Return_Is_Access_Def : Boolean := False; + Span : FT.Source_Span := FT.Null_Span; + end record; + + package Subprogram_Spec_Vectors is new Ada.Containers.Indefinite_Vectors + (Index_Type => Positive, + Element_Type => Subprogram_Spec); + type Static_Value_Kind is (Static_Value_None, Static_Value_Integer, @@ -235,6 +251,7 @@ package Safe_Frontend.Check_Model is type Type_Decl_Kind is (Type_Decl_Unknown, Type_Decl_Incomplete, + Type_Decl_Interface, Type_Decl_Integer, Type_Decl_Binary, Type_Decl_Float, @@ -258,6 +275,7 @@ package Safe_Frontend.Check_Model is Indexes : Array_Index_Vectors.Vector; Component_Type : Type_Spec; Components : Component_Decl_Vectors.Vector; + Interface_Members : Subprogram_Spec_Vectors.Vector; Has_Discriminant : Boolean := False; Discriminant : Discriminant_Spec; Discriminants : Discriminant_Spec_Vectors.Vector; @@ -413,18 +431,6 @@ package Safe_Frontend.Check_Model is Is_Synthetic : Boolean := False; end record; - type Subprogram_Spec is record - Kind : FT.UString := FT.To_UString (""); - Name : FT.UString := FT.To_UString (""); - Has_Receiver : Boolean := False; - Receiver : Parameter_Spec; - Params : Parameter_Vectors.Vector; - Has_Return_Type : Boolean := False; - Return_Type : Type_Spec; - Return_Is_Access_Def : Boolean := False; - Span : FT.Source_Span := FT.Null_Span; - end record; - type Subprogram_Body is record Is_Public : Boolean := False; Spec : Subprogram_Spec; @@ -545,6 +551,8 @@ package Safe_Frontend.Check_Model is type Resolved_Subprogram is record Name : FT.UString := FT.To_UString (""); Kind : FT.UString := FT.To_UString (""); + Is_Synthetic : Boolean := False; + Is_Interface_Template : Boolean := False; 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 fd9af87..880fd33 100644 --- a/compiler_impl/src/safe_frontend-check_parse.adb +++ b/compiler_impl/src/safe_frontend-check_parse.adb @@ -630,6 +630,9 @@ package body Safe_Frontend.Check_Parse is (State : in out Parser_State; Allow_Access_Def : Boolean) return CM.Type_Spec; + function Parse_Subprogram_Spec + (State : in out Parser_State) return CM.Subprogram_Spec; + function Parse_Growable_Array_Type_Spec (State : in out Parser_State) return CM.Type_Spec is @@ -1402,6 +1405,64 @@ package body Safe_Frontend.Check_Parse is Item.Is_Public := Is_Public; Item.Name := Name.Lexeme; Item.Has_Discriminant := False; + elsif Current_Lower (State) = "interface" then + declare + Last_Span : FT.Source_Span := Current (State).Span; + begin + if Item.Has_Discriminant then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Item.Discriminant.Span, + Message => "interfaces do not support discriminants")); + end if; + Advance (State); + Item.Kind := CM.Type_Decl_Interface; + Require_Indent + (State, + "interface members must be indented under `type ... is interface`"); + while Current (State).Kind not in FL.Dedent | FL.End_Of_File loop + declare + Member : constant CM.Subprogram_Spec := Parse_Subprogram_Spec (State); + begin + if not Member.Has_Receiver then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Member.Span, + Message => "interface members require a receiver parameter")); + elsif Member.Receiver.Param_Type.Kind not in + CM.Type_Spec_Name | CM.Type_Spec_Subtype_Indication + or else FT.Lowercase (FT.To_String (Member.Receiver.Param_Type.Name)) /= + FT.Lowercase (FT.To_String (Item.Name)) + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Member.Receiver.Span, + Message => "interface member receiver type must be the enclosing interface")); + end if; + for Existing of Item.Interface_Members loop + if FT.Lowercase (FT.To_String (Existing.Name)) = + FT.Lowercase (FT.To_String (Member.Name)) + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path_String (State), + Span => Member.Span, + Message => "duplicate interface member `" & FT.To_String (Member.Name) & "`")); + end if; + end loop; + Require (State, ";"); + Item.Interface_Members.Append (Member); + Last_Span := Member.Span; + end; + end loop; + Require_Dedent + (State, + "interface members must dedent back to the enclosing declaration level"); + Item.Span := CM.Join (Start.Span, Last_Span); + end; elsif Current_Lower (State) = "record" then Advance (State); declare diff --git a/compiler_impl/src/safe_frontend-check_resolve.adb b/compiler_impl/src/safe_frontend-check_resolve.adb index b28100f..57e1634 100644 --- a/compiler_impl/src/safe_frontend-check_resolve.adb +++ b/compiler_impl/src/safe_frontend-check_resolve.adb @@ -13,6 +13,7 @@ package body Safe_Frontend.Check_Resolve is use type CM.Expr_Access; use type CM.Expr_Kind; + use type CM.Statement_Access; use type CM.Discrete_Range_Kind; use type CM.Package_Item_Kind; use type CM.Select_Arm_Kind; @@ -36,6 +37,23 @@ package body Safe_Frontend.Check_Resolve is Span : FT.Source_Span := FT.Null_Span; end record; + type Interface_Template_Info is record + Decl : CM.Subprogram_Body; + Info : Function_Info; + 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 String_Maps is new Ada.Containers.Indefinite_Hashed_Maps + (Key_Type => String, + Element_Type => String, + Hash => Ada.Strings.Hash, + Equivalent_Keys => "="); + function Equal_Static_Value (Left, Right : CM.Static_Value) return Boolean is begin @@ -117,6 +135,11 @@ package body Safe_Frontend.Check_Resolve is Synthetic_Helper_Order : String_Vectors.Vector; Synthetic_Optional_Types : Type_Maps.Map; Synthetic_Optional_Order : String_Vectors.Vector; + Current_Interface_Templates : Interface_Template_Maps.Map; + Current_Pending_Interface_Specializations : Interface_Template_Maps.Map; + Current_Interface_Specialization_Order : String_Vectors.Vector; + Current_Interface_Specialization_By_Key : String_Maps.Map; + Current_Synthetic_Functions : Function_Maps.Map; function UString_Value (Value : FT.UString) return String is begin @@ -204,6 +227,8 @@ package body Safe_Frontend.Check_Resolve is case Kind is when CM.Type_Decl_Record => return "record"; + when CM.Type_Decl_Interface => + return "interface"; when CM.Type_Decl_Growable_Array => return "growable array"; when CM.Type_Decl_Constrained_Array | CM.Type_Decl_Unconstrained_Array => @@ -329,14 +354,18 @@ package body Safe_Frontend.Check_Resolve is (Map : Function_Maps.Map; Name : String) return Boolean is begin - return Map.Contains (Canonical_Name (Name)); + return Map.Contains (Canonical_Name (Name)) + or else Current_Synthetic_Functions.Contains (Canonical_Name (Name)); end Has_Function; function Get_Function (Map : Function_Maps.Map; Name : String) return Function_Info is begin - return Map.Element (Canonical_Name (Name)); + if Map.Contains (Canonical_Name (Name)) then + return Map.Element (Canonical_Name (Name)); + end if; + return Current_Synthetic_Functions.Element (Canonical_Name (Name)); end Get_Function; procedure Put_Static_Value @@ -565,6 +594,10 @@ package body Safe_Frontend.Check_Resolve is (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return Boolean; + function Is_Interface_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; @@ -620,6 +653,30 @@ package body Safe_Frontend.Check_Resolve is (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return Boolean; + function Register_Function + (Decl : CM.Subprogram_Body; + Type_Env : Type_Maps.Map; + Const_Env : Static_Value_Maps.Map; + Path : String) return Function_Info; + + function Specialize_Interface_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 Interface_Has_Member + (Info : GM.Type_Descriptor; + Member_Name : String) return Boolean; + + procedure Validate_Interface_Method_Syntax + (Decl : CM.Subprogram_Body; + Info : Function_Info; + Type_Env : Type_Maps.Map; + Path : String); + function Bool_Expr (Value : Boolean; Span : FT.Source_Span) return CM.Expr_Access; @@ -1027,6 +1084,14 @@ package body Safe_Frontend.Check_Resolve is and then Name (Name'First .. Name'First + 10) = "__optional_"; end Is_Optional_Type; + function Is_Interface_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)) = "interface"; + end Is_Interface_Type; + function Optional_Payload_Type (Info : GM.Type_Descriptor; Type_Env : Type_Maps.Map) return GM.Type_Descriptor @@ -1611,6 +1676,8 @@ package body Safe_Frontend.Check_Resolve is begin if Kind = "incomplete" then return False; + elsif Kind = "interface" then + return False; elsif Info_Kind = "subtype" and then not Info.Discriminant_Constraints.Is_Empty then return True; elsif Kind = "array" then @@ -1807,6 +1874,32 @@ package body Safe_Frontend.Check_Resolve is 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 := + FT.To_UString + (Qualify_Name (Package_Name, UString_Value (Param.Type_Name))); + Member.Params.Replace_Element (Param_Index, Param); + end; + end loop; + end if; + if Member.Has_Return_Type then + Member.Return_Type := + FT.To_UString + (Qualify_Name (Package_Name, UString_Value (Member.Return_Type))); + end if; + Result.Interface_Members.Replace_Element (Member_Index, Member); + end; + end loop; + end if; return Result; end Qualify_Type_Info; @@ -3434,6 +3527,302 @@ package body Safe_Frontend.Check_Resolve is return Name (Last_Dot + 1 .. Name'Last); end Method_Target_Tail_Name; + function Has_Synthetic_Tail_Compatibility + (Source : GM.Type_Descriptor; + Target : GM.Type_Descriptor; + Type_Env : Type_Maps.Map) return Boolean + is + Source_Base : constant GM.Type_Descriptor := Base_Type (Source, Type_Env); + Target_Base : constant GM.Type_Descriptor := Base_Type (Target, Type_Env); + Source_Tail : constant String := + Method_Target_Tail_Name (UString_Value (Source_Base.Name)); + Target_Tail : constant String := + Method_Target_Tail_Name (UString_Value (Target_Base.Name)); + begin + return Source_Tail'Length > 1 + and then Target_Tail'Length > 1 + and then Source_Tail (Source_Tail'First .. Source_Tail'First + 1) = "__" + and then Target_Tail (Target_Tail'First .. Target_Tail'First + 1) = "__" + and then FT.Lowercase (UString_Value (Source_Base.Kind)) = + FT.Lowercase (UString_Value (Target_Base.Kind)) + and then Source_Tail = Target_Tail; + end Has_Synthetic_Tail_Compatibility; + + function Method_Source_To_Target_Compatible + (Source : GM.Type_Descriptor; + Target : GM.Type_Descriptor; + Type_Env : Type_Maps.Map) return Boolean is + begin + return Compatible_Source_To_Target_Type (Source, Target, Type_Env) + or else Has_Synthetic_Tail_Compatibility (Source, Target, Type_Env); + end Method_Source_To_Target_Compatible; + + function Interface_Member_Compatible_With_Function + (Member : GM.Interface_Member; + Concrete_Type : GM.Type_Descriptor; + Info : Function_Info; + Type_Env : Type_Maps.Map) return Boolean; + + function Builtin_Method_Satisfies_Interface_Member + (Name : String; + Concrete_Type : GM.Type_Descriptor; + Member : GM.Interface_Member; + 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; + Info : Function_Info; + Type_Env : Type_Maps.Map) return Boolean + is + begin + if Natural (Member.Params.Length) /= Natural (Info.Params.Length) + or else Member.Params.Is_Empty + then + return False; + end if; + + declare + Receiver_Param : constant GM.Signature_Param := Member.Params (Member.Params.First_Index); + Target_Param : constant CM.Symbol := Info.Params (Info.Params.First_Index); + begin + if UString_Value (Receiver_Param.Mode) /= UString_Value (Target_Param.Mode) then + return False; + elsif not Method_Source_To_Target_Compatible + (Concrete_Type, + Target_Param.Type_Info, + Type_Env) + then + return False; + end if; + end; + + if Natural (Member.Params.Length) > 1 then + for Offset in 1 .. Natural (Member.Params.Length) - 1 loop + declare + Member_Param : constant GM.Signature_Param := + Member.Params (Member.Params.First_Index + Offset); + Target_Param : constant CM.Symbol := + Info.Params (Info.Params.First_Index + Offset); + Member_Type : constant GM.Type_Descriptor := + Resolve_Type + (UString_Value (Member_Param.Type_Name), + Type_Env, + "", + FT.Null_Span); + begin + if UString_Value (Member_Param.Mode) /= UString_Value (Target_Param.Mode) + or else not Method_Source_To_Target_Compatible + (Member_Type, + Target_Param.Type_Info, + Type_Env) + then + return False; + end if; + end; + end loop; + end if; + + if Member.Has_Return_Type /= Info.Has_Return_Type then + return False; + elsif Member.Has_Return_Type then + declare + Member_Return : constant GM.Type_Descriptor := + Resolve_Type + (UString_Value (Member.Return_Type), + Type_Env, + "", + FT.Null_Span); + begin + return Method_Source_To_Target_Compatible + (Info.Return_Type, + Member_Return, + Type_Env); + end; + end if; + + return True; + end Interface_Member_Compatible_With_Function; + + function Builtin_Method_Satisfies_Interface_Member + (Name : String; + Concrete_Type : GM.Type_Descriptor; + Member : GM.Interface_Member; + Functions : Function_Maps.Map; + Type_Env : Type_Maps.Map) return Boolean + is + Element_Type : GM.Type_Descriptor; + Key_Type : GM.Type_Descriptor; + Value_Type : GM.Type_Descriptor; + begin + if Has_Function (Functions, Name) or else Has_Type (Type_Env, Name) then + return False; + end if; + + if Name = "append" then + if Natural (Member.Params.Length) /= 2 + or else Member.Has_Return_Type + or else UString_Value (Member.Params (Member.Params.First_Index).Mode) /= "mut" + or else not Is_Growable_Array_Type (Concrete_Type, Type_Env) + then + return False; + end if; + Element_Type := Growable_Array_Element_Type (Concrete_Type, Type_Env); + return Method_Source_To_Target_Compatible + (Resolve_Type + (UString_Value (Member.Params (Member.Params.First_Index + 1).Type_Name), + Type_Env, + "", + FT.Null_Span), + Element_Type, + Type_Env); + elsif Name = "pop_last" then + if Natural (Member.Params.Length) /= 1 + or else UString_Value (Member.Params (Member.Params.First_Index).Mode) /= "mut" + or else not Is_Growable_Array_Type (Concrete_Type, Type_Env) + or else not Member.Has_Return_Type + then + return False; + end if; + Element_Type := Growable_Array_Element_Type (Concrete_Type, Type_Env); + return Method_Source_To_Target_Compatible + (Make_Optional_Type (Element_Type, Type_Env), + Resolve_Type (UString_Value (Member.Return_Type), Type_Env, "", FT.Null_Span), + Type_Env); + elsif Name in "contains" | "get" | "remove" | "set" then + if not Try_Map_Key_Value_Types (Concrete_Type, Type_Env, Key_Type, Value_Type) then + return False; + end if; + end if; + + if Name = "contains" then + return Natural (Member.Params.Length) = 2 + and then Member.Has_Return_Type + and then Method_Source_To_Target_Compatible + (Resolve_Type + (UString_Value (Member.Params (Member.Params.First_Index + 1).Type_Name), + Type_Env, + "", + FT.Null_Span), + Key_Type, + Type_Env) + and then Method_Source_To_Target_Compatible + (BT.Boolean_Type, + Resolve_Type (UString_Value (Member.Return_Type), Type_Env, "", FT.Null_Span), + Type_Env); + elsif Name = "get" then + return Natural (Member.Params.Length) = 2 + and then Member.Has_Return_Type + and then Method_Source_To_Target_Compatible + (Resolve_Type + (UString_Value (Member.Params (Member.Params.First_Index + 1).Type_Name), + Type_Env, + "", + FT.Null_Span), + Key_Type, + Type_Env) + and then Method_Source_To_Target_Compatible + (Make_Optional_Type (Value_Type, Type_Env), + Resolve_Type (UString_Value (Member.Return_Type), Type_Env, "", FT.Null_Span), + Type_Env); + elsif Name = "remove" then + return Natural (Member.Params.Length) = 2 + and then UString_Value (Member.Params (Member.Params.First_Index).Mode) = "mut" + and then Member.Has_Return_Type + and then Method_Source_To_Target_Compatible + (Resolve_Type + (UString_Value (Member.Params (Member.Params.First_Index + 1).Type_Name), + Type_Env, + "", + FT.Null_Span), + Key_Type, + Type_Env) + and then Method_Source_To_Target_Compatible + (Make_Optional_Type (Value_Type, Type_Env), + Resolve_Type (UString_Value (Member.Return_Type), Type_Env, "", FT.Null_Span), + Type_Env); + elsif Name = "set" then + return Natural (Member.Params.Length) = 3 + and then UString_Value (Member.Params (Member.Params.First_Index).Mode) = "mut" + and then not Member.Has_Return_Type + and then Method_Source_To_Target_Compatible + (Resolve_Type + (UString_Value (Member.Params (Member.Params.First_Index + 1).Type_Name), + Type_Env, + "", + FT.Null_Span), + Key_Type, + Type_Env) + and then Method_Source_To_Target_Compatible + (Resolve_Type + (UString_Value (Member.Params (Member.Params.First_Index + 2).Type_Name), + Type_Env, + "", + FT.Null_Span), + Value_Type, + Type_Env); + end if; + + return False; + end Builtin_Method_Satisfies_Interface_Member; + + 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 + is + Interface_Info : constant GM.Type_Descriptor := Base_Type (Interface_Type, Type_Env); + Match_Count : Natural; + begin + if not Is_Interface_Type (Interface_Info, Type_Env) then + return False; + end if; + + for Member of Interface_Info.Interface_Members loop + Match_Count := 0; + for Cursor in Functions.Iterate loop + declare + Candidate_Name : constant String := Function_Maps.Key (Cursor); + Tail_Name : constant String := Method_Target_Tail_Name (Candidate_Name); + begin + if Tail_Name = UString_Value (Member.Name) + and then Interface_Member_Compatible_With_Function + (Member, + Concrete_Type, + Function_Maps.Element (Cursor), + Type_Env) + then + Match_Count := Match_Count + 1; + end if; + end; + end loop; + + if Builtin_Method_Satisfies_Interface_Member + (UString_Value (Member.Name), + Concrete_Type, + Member, + Functions, + Type_Env) + then + Match_Count := Match_Count + 1; + end if; + + if Match_Count /= 1 then + return False; + end if; + end loop; + + return True; + end Type_Satisfies_Interface; + function Name_Expr_From_String (Name : String; Span : FT.Source_Span) return CM.Expr_Access @@ -3499,25 +3888,6 @@ package body Safe_Frontend.Check_Resolve is is Receiver_Type : constant GM.Type_Descriptor := Expr_Type (Receiver_Arg, Var_Types, Functions, Type_Env); - function Has_Synthetic_Tail_Compatibility - (Source : GM.Type_Descriptor; - Target : GM.Type_Descriptor) return Boolean - is - Source_Base : constant GM.Type_Descriptor := Base_Type (Source, Type_Env); - Target_Base : constant GM.Type_Descriptor := Base_Type (Target, Type_Env); - Source_Tail : constant String := - Method_Target_Tail_Name (UString_Value (Source_Base.Name)); - Target_Tail : constant String := - Method_Target_Tail_Name (UString_Value (Target_Base.Name)); - begin - return Source_Tail'Length > 1 - and then Target_Tail'Length > 1 - and then Source_Tail (Source_Tail'First .. Source_Tail'First + 1) = "__" - and then Target_Tail (Target_Tail'First .. Target_Tail'First + 1) = "__" - and then FT.Lowercase (UString_Value (Source_Base.Kind)) = - FT.Lowercase (UString_Value (Target_Base.Kind)) - and then Source_Tail = Target_Tail; - end Has_Synthetic_Tail_Compatibility; begin if Natural (Info.Params.Length) /= Natural (Extra_Args.Length) + 1 then return False; @@ -3529,7 +3899,16 @@ package body Safe_Frontend.Check_Resolve is return False; end if; - if not Compatible_Source_Expr_To_Target_Type + if Is_Interface_Type (Info.Params (Info.Params.First_Index).Type_Info, Type_Env) then + if not Type_Satisfies_Interface + (Receiver_Type, + Info.Params (Info.Params.First_Index).Type_Info, + Functions, + Type_Env) + then + return False; + end if; + elsif not Compatible_Source_Expr_To_Target_Type (Receiver_Arg, Receiver_Type, Info.Params (Info.Params.First_Index).Type_Info, @@ -3538,9 +3917,10 @@ package body Safe_Frontend.Check_Resolve is Type_Env, Const_Env, Exact_Length_Maps.Empty_Map) - and then not Has_Synthetic_Tail_Compatibility + and then not Method_Source_To_Target_Compatible (Receiver_Type, - Info.Params (Info.Params.First_Index).Type_Info) + Info.Params (Info.Params.First_Index).Type_Info, + Type_Env) then return False; end if; @@ -3566,7 +3946,16 @@ package body Safe_Frontend.Check_Resolve is Functions, Type_Env, ""); - if not Compatible_Source_Expr_To_Target_Type + if Is_Interface_Type (Param.Type_Info, Type_Env) then + if not Type_Satisfies_Interface + (Expr_Type (Arg, Var_Types, Functions, Type_Env), + Param.Type_Info, + Functions, + Type_Env) + then + return False; + end if; + elsif not Compatible_Source_Expr_To_Target_Type (Arg, Expr_Type (Arg, Var_Types, Functions, Type_Env), Param.Type_Info, @@ -3575,9 +3964,10 @@ package body Safe_Frontend.Check_Resolve is Type_Env, Const_Env, Exact_Length_Maps.Empty_Map) - and then not Has_Synthetic_Tail_Compatibility + and then not Method_Source_To_Target_Compatible (Expr_Type (Arg, Var_Types, Functions, Type_Env), - Param.Type_Info) + Param.Type_Info, + Type_Env) then return False; end if; @@ -4139,6 +4529,14 @@ package body Safe_Frontend.Check_Resolve is end; end; end if; + Result := + Specialize_Interface_Call + (Result, + Var_Types, + Functions, + Type_Env, + Const_Env, + ""); else Result := new CM.Expr_Node'(Resolved.all); Result.Inner := @@ -5467,7 +5865,9 @@ package body Safe_Frontend.Check_Resolve is (Decl : CM.Object_Decl; Type_Env : Type_Maps.Map; Const_Env : Static_Value_Maps.Map; - Path : String) return GM.Type_Descriptor is + Path : String) return GM.Type_Descriptor + is + Result : GM.Type_Descriptor; begin if Decl.Is_Constant and then not Decl.Has_Initializer then Raise_Diag @@ -5479,9 +5879,18 @@ package body Safe_Frontend.Check_Resolve is if Decl.Decl_Type.Kind = CM.Type_Spec_Unknown and then UString_Value (Decl.Type_Info.Name)'Length > 0 then - return Decl.Type_Info; + Result := Decl.Type_Info; + else + Result := Resolve_Type_Spec (Decl.Decl_Type, Type_Env, Const_Env, Path); + end if; + if Is_Interface_Type (Result, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Decl.Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); end if; - return Resolve_Type_Spec (Decl.Decl_Type, Type_Env, Const_Env, Path); + return Result; end Resolve_Decl_Type; function Normalize_Procedure_Call @@ -5947,6 +6356,171 @@ package body Safe_Frontend.Check_Resolve is return Prefix & "_" & Ada.Strings.Fixed.Trim (Natural'Image (Synthetic_Name_Counter), Ada.Strings.Both); end Next_Synthetic_Name; + function Named_Type_Spec + (Info : GM.Type_Descriptor; + Span : FT.Source_Span) return CM.Type_Spec + is + Result : CM.Type_Spec; + begin + Result.Kind := CM.Type_Spec_Name; + Result.Name := Info.Name; + Result.Span := Span; + return Result; + end Named_Type_Spec; + + function Has_Interface_Params + (Info : Function_Info; + Type_Env : Type_Maps.Map) return Boolean is + begin + for Param of Info.Params loop + if Is_Interface_Type (Param.Type_Info, Type_Env) then + return True; + end if; + end loop; + return False; + end Has_Interface_Params; + + function Specialize_Interface_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)); + Template : Interface_Template_Info; + Clone : CM.Subprogram_Body; + Result : CM.Expr_Access := Expr; + Key : FT.UString := FT.To_UString (Canonical_Name (Callee_Name)); + Arg_Index : Positive := 1; + Specialized_Name : FT.UString := FT.To_UString (""); + Clone_Info : Function_Info; + Replacement : GM.Type_Descriptor; + Arg : CM.Expr_Access; + Arg_Type : GM.Type_Descriptor; + begin + if Callee_Name = "" + or else not Current_Interface_Templates.Contains (Canonical_Name (Callee_Name)) + then + return Expr; + end if; + + Template := Current_Interface_Templates.Element (Canonical_Name (Callee_Name)); + 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; + + Clone := Template.Decl; + + if Clone.Spec.Has_Receiver then + Arg := Expr.Args (Arg_Index); + Replacement := + Resolve_Type_Spec (Clone.Spec.Receiver.Param_Type, Type_Env, Const_Env, Path); + if Is_Interface_Type (Replacement, Type_Env) then + Arg_Type := Expr_Type (Arg, Var_Types, Functions, Type_Env); + if Is_Interface_Type (Arg_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Arg.Span, + Message => "interface-constrained calls require concrete receiver types")); + elsif not Type_Satisfies_Interface (Arg_Type, Replacement, Functions, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Arg.Span, + Message => + "receiver type `" & UString_Value (Base_Type (Arg_Type, Type_Env).Name) + & "` does not satisfy interface `" + & UString_Value (Base_Type (Replacement, Type_Env).Name) & "`")); + end if; + Clone.Spec.Receiver.Param_Type := Named_Type_Spec (Arg_Type, Clone.Spec.Receiver.Param_Type.Span); + Key := Key & FT.To_UString ("|") & Arg_Type.Name; + end if; + Arg_Index := Arg_Index + 1; + end if; + + if not Clone.Spec.Params.Is_Empty then + for Index in Clone.Spec.Params.First_Index .. Clone.Spec.Params.Last_Index loop + declare + Param_Group : CM.Parameter_Spec := Clone.Spec.Params (Index); + Param_Type : constant GM.Type_Descriptor := + Resolve_Type_Spec (Param_Group.Param_Type, Type_Env, Const_Env, Path); + begin + if Is_Interface_Type (Param_Type, Type_Env) then + if Natural (Param_Group.Names.Length) /= 1 then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Param_Group.Span, + Message => "interface-typed parameters must declare exactly one name in PR11.11b")); + end if; + Arg := Expr.Args (Arg_Index); + Arg_Type := Expr_Type (Arg, Var_Types, Functions, Type_Env); + if Is_Interface_Type (Arg_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Arg.Span, + Message => "interface-constrained calls require concrete argument types")); + elsif not Type_Satisfies_Interface (Arg_Type, Param_Type, Functions, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Arg.Span, + Message => + "argument type `" & UString_Value (Base_Type (Arg_Type, Type_Env).Name) + & "` does not satisfy interface `" + & UString_Value (Base_Type (Param_Type, Type_Env).Name) & "`")); + end if; + Param_Group.Param_Type := Named_Type_Spec (Arg_Type, Param_Group.Param_Type.Span); + Clone.Spec.Params.Replace_Element (Index, Param_Group); + Key := Key & FT.To_UString ("|") & Arg_Type.Name; + end if; + Arg_Index := Arg_Index + Natural (Param_Group.Names.Length); + end; + end loop; + end if; + + if Current_Interface_Specialization_By_Key.Contains (UString_Value (Key)) then + Specialized_Name := + FT.To_UString + (Current_Interface_Specialization_By_Key.Element (UString_Value (Key))); + else + Specialized_Name := + FT.To_UString + (Next_Synthetic_Name + ("Safe_Interface_" & Sanitize_Type_Name_Component (Method_Target_Tail_Name (Callee_Name)))); + Clone.Spec.Name := Specialized_Name; + Clone.Is_Public := False; + Clone_Info := + Register_Function (Clone, Type_Env, Const_Env, Path); + Put_Function (Current_Synthetic_Functions, UString_Value (Specialized_Name), Clone_Info); + Current_Interface_Specialization_By_Key.Include + (UString_Value (Key), UString_Value (Specialized_Name)); + Current_Pending_Interface_Specializations.Include + (Canonical_Name (UString_Value (Specialized_Name)), + (Decl => Clone, Info => Clone_Info)); + Append_Unique_String + (Current_Interface_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); + return Result; + end Specialize_Interface_Call; + procedure Append_Statements (Target : in out CM.Statement_Access_Vectors.Vector; Items : CM.Statement_Access_Vectors.Vector) is @@ -9614,6 +10188,70 @@ package body Safe_Frontend.Check_Resolve is case Decl.Kind is when CM.Type_Decl_Incomplete => Result.Kind := FT.To_UString ("incomplete"); + when CM.Type_Decl_Interface => + Result.Kind := FT.To_UString ("interface"); + for Member of Decl.Interface_Members loop + declare + Member_Info : GM.Interface_Member; + Param_Info : GM.Signature_Param; + begin + if not Member.Has_Receiver then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Member.Span, + Message => "interface members require a receiver parameter")); + end if; + + Member_Info.Name := Member.Name; + Param_Info.Name := Member.Receiver.Names (Member.Receiver.Names.First_Index); + Param_Info.Mode := Member.Receiver.Mode; + Param_Info.Type_Name := Decl.Name; + Member_Info.Params.Append (Param_Info); + + for Param of Member.Params loop + declare + Param_Type : constant GM.Type_Descriptor := + Resolve_Type_Spec (Param.Param_Type, Type_Env, Const_Env, Path); + begin + if Is_Interface_Type (Param_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Param.Span, + Message => "interface member parameters must use concrete non-interface types")); + end if; + for Param_Name of Param.Names loop + Param_Info := (others => <>); + Param_Info.Name := Param_Name; + Param_Info.Mode := Param.Mode; + Param_Info.Type_Name := Param_Type.Name; + Member_Info.Params.Append (Param_Info); + end loop; + end; + end loop; + + if Member.Has_Return_Type then + declare + Return_Type : constant GM.Type_Descriptor := + Resolve_Type_Spec (Member.Return_Type, Type_Env, Const_Env, Path); + begin + if Is_Interface_Type (Return_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Member.Return_Type.Span, + Message => "interface member returns must use concrete non-interface types")); + end if; + Member_Info.Has_Return_Type := True; + Member_Info.Return_Type := Return_Type.Name; + Member_Info.Return_Is_Access_Def := Member.Return_Is_Access_Def; + end; + end if; + + Result.Interface_Members.Append (Member_Info); + end; + end loop; when CM.Type_Decl_Integer => Result.Kind := FT.To_UString ("subtype"); Result.Has_Base := True; @@ -9757,6 +10395,13 @@ package body Safe_Frontend.Check_Resolve is Component_Type : constant GM.Type_Descriptor := Resolve_Type_Spec (Decl.Component_Type, Type_Env, Const_Env, Path); begin + if Is_Interface_Type (Component_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Decl.Component_Type.Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); + end if; Result.Component_Type := Component_Type.Name; end; Result.Unconstrained := Decl.Kind = CM.Type_Decl_Unconstrained_Array; @@ -9765,6 +10410,13 @@ package body Safe_Frontend.Check_Resolve is Component : constant GM.Type_Descriptor := Resolve_Type_Spec (Decl.Component_Type, Type_Env, Const_Env, Path); begin + if Is_Interface_Type (Component, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Decl.Component_Type.Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); + end if; if FT.Lowercase (UString_Value (Component.Kind)) = "incomplete" and then FT.Lowercase (UString_Value (Component.Name)) = FT.Lowercase (UString_Value (Decl.Name)) @@ -9799,6 +10451,13 @@ package body Safe_Frontend.Check_Resolve is Base_Field : constant GM.Type_Descriptor := Base_Type (Field_Type, Type_Env); Adjusted : GM.Type_Descriptor := Field_Type; begin + if Is_Interface_Type (Field_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); + end if; if FT.Lowercase (UString_Value (Base_Field.Kind)) = "incomplete" then if In_Same_Admitted_Record_Family (Self_Name, @@ -10014,10 +10673,21 @@ package body Safe_Frontend.Check_Resolve is end if; end; when CM.Type_Decl_Access => - Result.Kind := FT.To_UString ("access"); - Result.Has_Target := True; - Result.Target := - Resolve_Type (Flatten_Name (Decl.Access_Type.Target_Name), Type_Env, Path, Decl.Span).Name; + declare + Target_Info : constant GM.Type_Descriptor := + Resolve_Type (Flatten_Name (Decl.Access_Type.Target_Name), Type_Env, Path, Decl.Span); + begin + if Is_Interface_Type (Target_Info, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Decl.Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); + end if; + Result.Kind := FT.To_UString ("access"); + Result.Has_Target := True; + Result.Target := Target_Info.Name; + end; Result.Not_Null := Decl.Access_Type.Not_Null; Result.Anonymous := False; Result.Is_All := Decl.Access_Type.Is_All; @@ -10057,10 +10727,10 @@ package body Safe_Frontend.Check_Resolve is begin Symbol.Name := Decl.Spec.Receiver.Names (Decl.Spec.Receiver.Names.First_Index); Symbol.Kind := FT.To_UString ("param"); - Symbol.Mode := Decl.Spec.Receiver.Mode; - Symbol.Span := Decl.Spec.Receiver.Span; - Symbol.Type_Info := Param_Type; - Result.Params.Append (Symbol); + Symbol.Mode := Decl.Spec.Receiver.Mode; + Symbol.Span := Decl.Spec.Receiver.Span; + Symbol.Type_Info := Param_Type; + Result.Params.Append (Symbol); end; end if; for Param of Decl.Spec.Params loop @@ -10068,6 +10738,15 @@ package body Safe_Frontend.Check_Resolve is Param_Type : constant GM.Type_Descriptor := Resolve_Type_Spec (Param.Param_Type, Type_Env, Const_Env, Path); begin + if Is_Interface_Type (Param_Type, Type_Env) + and then Natural (Param.Names.Length) /= 1 + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Param.Span, + Message => "interface-typed parameters must declare exactly one name in PR11.11b")); + end if; for Name of Param.Names loop Symbol.Name := Name; Symbol.Kind := FT.To_UString ("param"); @@ -10082,10 +10761,239 @@ package body Safe_Frontend.Check_Resolve is Result.Has_Return_Type := True; Result.Return_Type := Resolve_Type_Spec (Decl.Spec.Return_Type, Type_Env, Const_Env, Path); + if Is_Interface_Type (Result.Return_Type, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Decl.Spec.Return_Type.Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); + end if; end if; return Result; end Register_Function; + function Interface_Has_Member + (Info : GM.Type_Descriptor; + Member_Name : String) return Boolean + is + Canonical_Member : constant String := Canonical_Name (Member_Name); + begin + if not Info.Interface_Members.Is_Empty then + for Member of Info.Interface_Members loop + if Canonical_Name (UString_Value (Member.Name)) = Canonical_Member then + return True; + end if; + end loop; + end if; + return False; + end Interface_Has_Member; + + procedure Validate_Interface_Method_Syntax + (Decl : CM.Subprogram_Body; + Info : Function_Info; + Type_Env : Type_Maps.Map; + Path : String) + is + function Param_Interface_Type (Name : String) return GM.Type_Descriptor 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); + end if; + end loop; + end if; + return (others => <>); + end Param_Interface_Type; + + procedure Validate_Expr (Expr : CM.Expr_Access); + + procedure Validate_Statement_List + (Statements : CM.Statement_Access_Vectors.Vector); + + procedure Validate_Expr (Expr : CM.Expr_Access) is + function Is_Interface_Method_Syntax return Boolean is + begin + if Expr = null + or else Expr.Callee = null + or else Expr.Callee.Kind /= CM.Expr_Select + or else Expr.Callee.Prefix = null + or else Expr.Callee.Prefix.Kind /= CM.Expr_Ident + then + return False; + end if; + + declare + Prefix_Interface_Info : constant GM.Type_Descriptor := + Param_Interface_Type + (UString_Value (Expr.Callee.Prefix.Name)); + begin + return + UString_Value (Prefix_Interface_Info.Name)'Length > 0 + and then Interface_Has_Member + (Prefix_Interface_Info, + FT.Lowercase (UString_Value (Expr.Callee.Selector))); + end; + end Is_Interface_Method_Syntax; + begin + if Expr = null then + return; + end if; + + case Expr.Kind is + when CM.Expr_Apply | CM.Expr_Call => + if Expr.Callee /= null and then not Expr.Args.Is_Empty then + declare + Callee_Name : constant String := + Method_Target_Tail_Name (Flatten_Name (Expr.Callee)); + First_Arg : constant CM.Expr_Access := Expr.Args (Expr.Args.First_Index); + begin + if not Is_Interface_Method_Syntax + and then First_Arg /= null + and then First_Arg.Kind = CM.Expr_Ident + then + declare + Interface_Info : constant GM.Type_Descriptor := + Param_Interface_Type (UString_Value (First_Arg.Name)); + begin + if UString_Value (Interface_Info.Name)'Length > 0 + and then Interface_Has_Member (Interface_Info, Callee_Name) + then + Raise_Diag + (CM.Source_Frontend_Error + (Path => Path, + Span => Expr.Span, + Message => + "interface member calls on interface-typed parameters must use method syntax in PR11.11b")); + end if; + end; + end if; + end; + end if; + + Validate_Expr (Expr.Callee); + if not Expr.Args.Is_Empty then + for Arg of Expr.Args loop + Validate_Expr (Arg); + end loop; + end if; + when CM.Expr_Select => + Validate_Expr (Expr.Prefix); + when CM.Expr_Binary => + Validate_Expr (Expr.Left); + Validate_Expr (Expr.Right); + when CM.Expr_Unary | CM.Expr_Annotated => + Validate_Expr (Expr.Inner); + when CM.Expr_Conversion => + Validate_Expr (Expr.Inner); + when CM.Expr_Allocator => + Validate_Expr (Expr.Value); + when CM.Expr_Aggregate => + if not Expr.Fields.Is_Empty then + for Field of Expr.Fields loop + Validate_Expr (Field.Expr); + end loop; + end if; + when CM.Expr_Array_Literal | CM.Expr_Tuple => + if not Expr.Elements.Is_Empty then + for Item of Expr.Elements loop + Validate_Expr (Item); + end loop; + end if; + when CM.Expr_Resolved_Index => + Validate_Expr (Expr.Prefix); + if not Expr.Args.Is_Empty then + for Arg of Expr.Args loop + Validate_Expr (Arg); + end loop; + end if; + when others => + null; + end case; + end Validate_Expr; + + procedure Validate_Statement_List + (Statements : CM.Statement_Access_Vectors.Vector) + is + begin + if Statements.Is_Empty then + return; + end if; + + for Stmt of Statements loop + if Stmt = null then + null; + else + case Stmt.Kind is + when CM.Stmt_Assign => + Validate_Expr (Stmt.Target); + Validate_Expr (Stmt.Value); + when CM.Stmt_Call => + Validate_Expr (Stmt.Call); + when CM.Stmt_Return | CM.Stmt_Delay => + Validate_Expr (Stmt.Value); + when CM.Stmt_Object_Decl => + Validate_Expr (Stmt.Decl.Initializer); + when CM.Stmt_Destructure_Decl => + Validate_Expr (Stmt.Decl.Initializer); + when CM.Stmt_Receive | CM.Stmt_Try_Receive => + Validate_Expr (Stmt.Channel_Name); + Validate_Expr (Stmt.Target); + when CM.Stmt_Send | CM.Stmt_Try_Send => + Validate_Expr (Stmt.Channel_Name); + Validate_Expr (Stmt.Value); + Validate_Expr (Stmt.Success_Var); + when CM.Stmt_If => + Validate_Expr (Stmt.Condition); + Validate_Statement_List (Stmt.Then_Stmts); + for Part of Stmt.Elsifs loop + Validate_Expr (Part.Condition); + Validate_Statement_List (Part.Statements); + end loop; + if Stmt.Has_Else then + Validate_Statement_List (Stmt.Else_Stmts); + end if; + when CM.Stmt_Case => + Validate_Expr (Stmt.Case_Expr); + for Arm of Stmt.Case_Arms loop + Validate_Expr (Arm.Choice); + Validate_Statement_List (Arm.Statements); + end loop; + when CM.Stmt_While => + Validate_Expr (Stmt.Condition); + Validate_Statement_List (Stmt.Body_Stmts); + when CM.Stmt_For | CM.Stmt_Loop => + Validate_Statement_List (Stmt.Body_Stmts); + when CM.Stmt_Select => + for Arm of Stmt.Arms loop + case Arm.Kind is + when CM.Select_Arm_Channel => + Validate_Expr (Arm.Channel_Data.Channel_Name); + Validate_Statement_List (Arm.Channel_Data.Statements); + when CM.Select_Arm_Delay => + Validate_Expr (Arm.Delay_Data.Duration_Expr); + Validate_Statement_List (Arm.Delay_Data.Statements); + when others => + null; + end case; + end loop; + when CM.Stmt_Match => + Validate_Expr (Stmt.Match_Expr); + for Arm of Stmt.Match_Arms loop + Validate_Statement_List (Arm.Statements); + end loop; + when others => + null; + end case; + end if; + end loop; + end Validate_Statement_List; + begin + Validate_Statement_List (Decl.Statements); + end Validate_Interface_Method_Syntax; + function Resolve_Channel_Declaration (Decl : CM.Channel_Decl; Type_Env : Type_Maps.Map; @@ -10764,6 +11672,11 @@ package body Safe_Frontend.Check_Resolve is Current_Target_Bits := Normalized_Target_Bits; Current_Public_Channel_Names.Clear; Current_Select_In_Subprogram_Body := False; + Current_Interface_Templates.Clear; + Current_Pending_Interface_Specializations.Clear; + Current_Interface_Specialization_Order.Clear; + Current_Interface_Specialization_By_Key.Clear; + Current_Synthetic_Functions.Clear; Synthetic_Helper_Types.Clear; Synthetic_Helper_Order.Clear; Synthetic_Optional_Types.Clear; @@ -10902,6 +11815,13 @@ package body Safe_Frontend.Check_Resolve is UString_Value (Unit.Path)); Info : GM.Type_Descriptor; begin + if Is_Interface_Type (Base, Type_Env) then + Raise_Diag + (CM.Source_Frontend_Error + (Path => UString_Value (Unit.Path), + Span => Item.Sub_Data.Span, + Message => "interface types are only admitted in parameter positions in PR11.11b")); + end if; Reject_Package_Level_Enum_Collision (UString_Value (Item.Sub_Data.Name), Item.Sub_Data.Span, @@ -11061,6 +11981,24 @@ package body Safe_Frontend.Check_Resolve is 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, @@ -11123,6 +12061,12 @@ package body Safe_Frontend.Check_Resolve is Subprogram.Return_Is_Access_Def := Info.Return_Is_Access_Def; Subprogram.Span := Info.Span; + if Has_Interface_Params (Info, Type_Env) then + Subprogram.Is_Interface_Template := True; + Result.Subprograms.Append (Subprogram); + goto Continue_Second_Pass_Item; + end if; + for Object_Decl of Result.Objects loop if Object_Decl.Is_Constant then for Name of Object_Decl.Names loop @@ -11214,6 +12158,7 @@ package body Safe_Frontend.Check_Resolve is end; Result.Subprograms.Append (Subprogram); + <> end; elsif Item.Kind = CM.Item_Task then declare @@ -11358,6 +12303,137 @@ package body Safe_Frontend.Check_Resolve is end if; end loop; + if not Current_Interface_Specialization_Order.Is_Empty then + declare + Specialization_Index : Positive := + Current_Interface_Specialization_Order.First_Index; + begin + while Specialization_Index in + Current_Interface_Specialization_Order.First_Index + .. Current_Interface_Specialization_Order.Last_Index + loop + declare + 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; + + 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, + 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; + 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 4b2ae89..8f65fae 100644 --- a/compiler_impl/src/safe_frontend-interfaces.adb +++ b/compiler_impl/src/safe_frontend-interfaces.adb @@ -418,6 +418,73 @@ package body Safe_Frontend.Interfaces is Map_JSON_Object (Get (Value, "fields"), Append_Field'Access); end if; + declare + Members : constant JSON_Array := Json_Array_Or_Empty (Value, "interface_members"); + begin + for Index in 1 .. Length (Members) loop + declare + Item : constant JSON_Value := Get (Members, Index); + Member : GM.Interface_Member; + begin + if Item.Kind = JSON_Object_Type then + if Has_Field (Item, "name") + and then Get (Item, "name").Kind = JSON_String_Type + then + Member.Name := FT.To_UString (Get (Item, "name")); + end if; + + declare + Params : constant JSON_Array := Json_Array_Or_Empty (Item, "params"); + begin + for Param_Index in 1 .. Length (Params) loop + declare + Param_Item : constant JSON_Value := Get (Params, Param_Index); + Param : GM.Signature_Param; + begin + if Param_Item.Kind = JSON_Object_Type then + if Has_Field (Param_Item, "name") + and then Get (Param_Item, "name").Kind = JSON_String_Type + then + Param.Name := FT.To_UString (Get (Param_Item, "name")); + end if; + if Has_Field (Param_Item, "mode") + and then Get (Param_Item, "mode").Kind = JSON_String_Type + then + Param.Mode := FT.To_UString (Get (Param_Item, "mode")); + end if; + if Has_Field (Param_Item, "type_name") + and then Get (Param_Item, "type_name").Kind = JSON_String_Type + then + Param.Type_Name := FT.To_UString (Get (Param_Item, "type_name")); + end if; + Member.Params.Append (Param); + end if; + end; + end loop; + end; + + if Has_Field (Item, "has_return_type") + and then Get (Item, "has_return_type").Kind = JSON_Boolean_Type + then + Member.Has_Return_Type := Get (Get (Item, "has_return_type")); + end if; + if Has_Field (Item, "return_type") + and then Get (Item, "return_type").Kind = JSON_String_Type + then + Member.Return_Type := FT.To_UString (Get (Item, "return_type")); + end if; + if Has_Field (Item, "return_is_access_def") + and then Get (Item, "return_is_access_def").Kind = JSON_Boolean_Type + then + Member.Return_Is_Access_Def := Get (Get (Item, "return_is_access_def")); + end if; + + Result.Interface_Members.Append (Member); + end if; + end; + end loop; + end; + declare Variants : constant JSON_Array := Json_Array_Or_Empty (Value, "variant_fields"); begin @@ -858,19 +925,23 @@ package body Safe_Frontend.Interfaces is declare Format : constant String := Require_String (Root, "format", File_Path); begin - if Format /= "safei-v1" and then Format /= "safei-v2" and then Format /= "safei-v3" then - raise Constraint_Error with File_Path & ": format must be safei-v1, safei-v2, or safei-v3"; + if Format /= "safei-v1" + and then Format /= "safei-v2" + and then Format /= "safei-v3" + and then Format /= "safei-v4" + then + raise Constraint_Error with File_Path & ": format must be safei-v1, safei-v2, safei-v3, or safei-v4"; end if; - Is_Safei_V2 := Format in "safei-v2" | "safei-v3"; - Is_Safei_V3 := Format = "safei-v3"; + Is_Safei_V2 := Format in "safei-v2" | "safei-v3" | "safei-v4"; + Is_Safei_V3 := Format in "safei-v3" | "safei-v4"; 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"; + raise Constraint_Error with File_Path & ": unit_kind is required for safei-v2/safei-v3/safei-v4"; 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"; + raise Constraint_Error with File_Path & ": target_bits is required for safei-v3/safei-v4"; elsif Get (Root, "target_bits").Kind /= JSON_Int_Type then raise Constraint_Error with File_Path & ": target_bits must be 32 or 64"; else diff --git a/compiler_impl/src/safe_frontend-mir_model.ads b/compiler_impl/src/safe_frontend-mir_model.ads index 1d51c41..ce719a7 100644 --- a/compiler_impl/src/safe_frontend-mir_model.ads +++ b/compiler_impl/src/safe_frontend-mir_model.ads @@ -89,6 +89,28 @@ package Safe_Frontend.Mir_Model is (Index_Type => Positive, Element_Type => Type_Field); + type Signature_Param is record + Name : FT.UString := FT.To_UString (""); + Mode : FT.UString := FT.To_UString (""); + Type_Name : FT.UString := FT.To_UString (""); + end record; + + package Signature_Param_Vectors is new Ada.Containers.Indefinite_Vectors + (Index_Type => Positive, + Element_Type => Signature_Param); + + type Interface_Member is record + Name : FT.UString := FT.To_UString (""); + Params : Signature_Param_Vectors.Vector; + Has_Return_Type : Boolean := False; + Return_Type : FT.UString := FT.To_UString (""); + Return_Is_Access_Def : Boolean := False; + end record; + + package Interface_Member_Vectors is new Ada.Containers.Indefinite_Vectors + (Index_Type => Positive, + Element_Type => Interface_Member); + type Scalar_Value_Kind is (Scalar_Value_None, Scalar_Value_Integer, @@ -155,6 +177,7 @@ package Safe_Frontend.Mir_Model is Has_Length_Bound : Boolean := False; Length_Bound : Natural := 0; Fields : Type_Field_Vectors.Vector; + Interface_Members : Interface_Member_Vectors.Vector; Has_Target : Boolean := False; Target : FT.UString := FT.To_UString (""); Has_Base : Boolean := False; diff --git a/docs/PR11.x-series-proposed.md b/docs/PR11.x-series-proposed.md index d6ff631..4c3681d 100644 --- a/docs/PR11.x-series-proposed.md +++ b/docs/PR11.x-series-proposed.md @@ -2206,22 +2206,30 @@ Follows PR11.10d. ## PR11.11b: Structural Interfaces -Add Go-style named operation contracts. A type satisfies an interface if -it has matching functions — structural typing, not explicit `implements`. +Add Go-style named operation contracts as a compile-time-only structural +constraint surface. A type satisfies an interface if it has matching functions +or methods; there is no explicit `implements`. ### Scope -- An interface is a named set of function/method signatures. -- The compiler checks interface satisfaction at the use site (function - parameter, generic constraint) and monomorphizes. -- No vtable, no dynamic dispatch, no runtime type check. -- Interfaces are value-typed constraints, not reference-typed base - classes. No inheritance, no subclassing. +- Interface syntax is `type name is interface` with an indented suite of + signature-only members. +- Every member must use receiver syntax, and the receiver type must be the + enclosing interface name. +- Interface types are admitted only in parameter positions in `PR11.11b`. +- Same-unit/private interface-constrained subprogram bodies are specialized to + ordinary concrete functions before MIR. +- Public interface declarations cross package boundaries now, and imported + public concrete functions participate in structural satisfaction. +- Public interface-constrained subprogram bodies remain deferred to + `PR11.11c`; `PR11.11b` rejects them with a subset diagnostic. +- No vtable, no dynamic dispatch, no runtime type check, no inheritance. ### Proof impact -Zero runtime impact. Satisfaction is checked at compile time and -monomorphized. The proof surface is identical to non-generic code. +Zero runtime impact. Satisfaction is checked at compile time and local/private +interface-constrained bodies are monomorphized before MIR, so the proof +surface remains ordinary concrete code. ### Dependency diff --git a/docs/artifact_contract.md b/docs/artifact_contract.md index 6b35e6a..76317ed 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-v4"` +- `typed.json` with `format: "typed-v5"` - `mir.json` with `format: "mir-v4"` -- `safei.json` with `format: "safei-v3"` +- `safei.json` with `format: "safei-v4"` - `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-v4`, `mir-v4`, and `safei-v3` must all carry: +`typed-v5`, `mir-v4`, and `safei-v4` must all carry: - `format` - `target_bits` @@ -30,6 +30,10 @@ 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. + ## CLI Surface The compiler accepts `--target-bits 32|64` on: diff --git a/docs/tutorial.md b/docs/tutorial.md index 6fd9882..4fdfcf5 100644 --- a/docs/tutorial.md +++ b/docs/tutorial.md @@ -384,6 +384,26 @@ so `value.unwrap_or_zero()`, `items.append(3)`, `items.pop_last()`, `m.contains(key)`, `m.get(key)`, `m.set(key, value)`, and `m.remove(key)` all lower to the existing ordinary-call forms. +`PR11.11b` then adds structural interfaces as compile-time operation +contracts. They are not runtime base classes and do not add dynamic dispatch: + +```safe +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 (item : printable) returns string + return item.label(); +``` + +In this first interface slice, interface types are admitted only in parameter +positions, and public interface-constrained subprogram bodies remain deferred. + ## 6. "Silver By Construction": D27 In One Page Safe's Silver level is built around a simple premise: diff --git a/scripts/_lib/proof_inventory.py b/scripts/_lib/proof_inventory.py index d328466..0811019 100644 --- a/scripts/_lib/proof_inventory.py +++ b/scripts/_lib/proof_inventory.py @@ -213,6 +213,12 @@ class EmittedProofExclusion: ] +PR11_11B_CHECKPOINT_FIXTURES = [ + "tests/positive/pr1111b_interface_local.safe", + "tests/build/pr1111b_interface_builtin_build.safe", +] + + PR11_8I1_CHECKPOINT_FIXTURES = [ "tests/positive/pr115_case_terminator.safe", "tests/positive/pr115_var_basic.safe", @@ -282,6 +288,7 @@ class EmittedProofExclusion: + PR11_10B_CHECKPOINT_FIXTURES + PR11_10C_CHECKPOINT_FIXTURES + PR11_11A_CHECKPOINT_FIXTURES + + PR11_11B_CHECKPOINT_FIXTURES + EMITTED_PROOF_REGRESSION_FIXTURES ) diff --git a/scripts/run_proofs.py b/scripts/run_proofs.py index cd64093..5ebde8b 100644 --- a/scripts/run_proofs.py +++ b/scripts/run_proofs.py @@ -33,6 +33,7 @@ PR11_10C_CHECKPOINT_FIXTURES, PR11_10D_CHECKPOINT_FIXTURES, PR11_11A_CHECKPOINT_FIXTURES, + PR11_11B_CHECKPOINT_FIXTURES, PROOF_COVERAGE_ROOTS, iter_proof_coverage_paths, ) @@ -84,6 +85,7 @@ def validate_manifests() -> None: validate_manifest("PR11.10c checkpoint manifest", PR11_10C_CHECKPOINT_FIXTURES) 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("emitted proof regression manifest", EMITTED_PROOF_REGRESSION_FIXTURES) validate_manifest("emitted proof manifest", EMITTED_PROOF_FIXTURES) validate_manifest( @@ -227,6 +229,8 @@ def main() -> int: checkpoint_10d_failures: list[tuple[str, str]] = [] checkpoint_11a_passed = 0 checkpoint_11a_failures: list[tuple[str, str]] = [] + checkpoint_11b_passed = 0 + checkpoint_11b_failures: list[tuple[str, str]] = [] regression_passed = 0 regression_failures: list[tuple[str, str]] = [] @@ -310,6 +314,11 @@ def main() -> int: temp_root=temp_root, toolchain=toolchain, ) + checkpoint_11b_passed, checkpoint_11b_failures = run_fixture_group( + fixtures=PR11_11B_CHECKPOINT_FIXTURES, + temp_root=temp_root, + toolchain=toolchain, + ) regression_passed, regression_failures = run_fixture_group( fixtures=EMITTED_PROOF_REGRESSION_FIXTURES, temp_root=temp_root, @@ -338,6 +347,7 @@ def main() -> int: + checkpoint_10b_passed + checkpoint_10c_passed + checkpoint_11a_passed + + checkpoint_11b_passed + regression_passed ) total_failures = ( @@ -355,6 +365,7 @@ def main() -> int: + checkpoint_10b_failures + checkpoint_10c_failures + checkpoint_11a_failures + + checkpoint_11b_failures + regression_failures ) @@ -448,6 +459,12 @@ def main() -> int: title="PR11.11a checkpoint", trailing_blank_line=True, ) + print_summary( + passed=checkpoint_11b_passed, + failures=checkpoint_11b_failures, + title="PR11.11b 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 7f36577..c4d22d4 100644 --- a/scripts/run_tests.py +++ b/scripts/run_tests.py @@ -222,6 +222,12 @@ REPO_ROOT / "tests" / "interfaces" / "client_imported_method_observe.safe", 0, ), + ( + "imported-interface", + REPO_ROOT / "tests" / "interfaces" / "provider_printable.safe", + REPO_ROOT / "tests" / "interfaces" / "client_printable.safe", + 0, + ), ] INTERFACE_REJECT_CASES = [ @@ -237,6 +243,12 @@ REPO_ROOT / "tests" / "interfaces" / "client_optional_method_ambiguous.safe", "ambiguous method call `unwrap_or_zero`", ), + ( + "ambiguous-interface-satisfaction", + REPO_ROOT / "tests" / "interfaces" / "provider_printable.safe", + REPO_ROOT / "tests" / "interfaces" / "client_printable_ambiguous.safe", + "does not satisfy interface", + ), ] CHECK_SUCCESS_CASES = [ @@ -281,6 +293,7 @@ REPO_ROOT / "tests" / "positive" / "pr1110b_list_basics.safe", REPO_ROOT / "tests" / "positive" / "pr1110c_map_basics.safe", REPO_ROOT / "tests" / "positive" / "pr1111a_method_syntax.safe", + REPO_ROOT / "tests" / "positive" / "pr1111b_interface_local.safe", ] DIAGNOSTIC_GOLDEN_CASES = [ @@ -523,6 +536,11 @@ "30\n15\n20\n2\n1\n", False, ), + ( + REPO_ROOT / "tests" / "build" / "pr1111b_interface_builtin_build.safe", + "1\n20\n", + False, + ), ( REPO_ROOT / "tests" / "build" / "pr118d_tuple_string_build.safe", "ok\n", @@ -815,6 +833,7 @@ REPO_ROOT / "tests" / "build" / "pr118d_for_of_growable_build.safe", 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" / "pr118k_try_while_contract.safe", REPO_ROOT / "tests" / "interfaces" / "provider_list.safe", ] diff --git a/scripts/validate_ast_output.py b/scripts/validate_ast_output.py index 5587f3f..9ee1d17 100644 --- a/scripts/validate_ast_output.py +++ b/scripts/validate_ast_output.py @@ -49,6 +49,7 @@ "FloatingPointDefinition", "UnconstrainedArrayDefinition", "ConstrainedArrayDefinition", + "InterfaceTypeDefinition", "RecordTypeDefinition", }, "Name": { diff --git a/scripts/validate_output_contracts.py b/scripts/validate_output_contracts.py index e43efee..089cf7e 100644 --- a/scripts/validate_output_contracts.py +++ b/scripts/validate_output_contracts.py @@ -59,6 +59,47 @@ def validate_type_descriptor(value: Any, path: str) -> dict[str, Any]: fail(f"{path}.bit_width must be one of 8, 16, 32, 64") if kind == "binary" and "bit_width" not in descriptor: fail(f"{path}.bit_width is required for binary types") + if "interface_members" in descriptor: + members = require_list(descriptor.get("interface_members"), f"{path}.interface_members") + for index, item in enumerate(members): + member = require_mapping(item, f"{path}.interface_members[{index}]") + require_string(member.get("name"), f"{path}.interface_members[{index}].name") + params = require_list(member.get("params"), f"{path}.interface_members[{index}].params") + for param_index, param_item in enumerate(params): + param = require_mapping( + param_item, + f"{path}.interface_members[{index}].params[{param_index}]", + ) + require_string( + param.get("name"), + f"{path}.interface_members[{index}].params[{param_index}].name", + ) + require_string( + param.get("mode"), + f"{path}.interface_members[{index}].params[{param_index}].mode", + ) + require_string( + param.get("type_name"), + f"{path}.interface_members[{index}].params[{param_index}].type_name", + ) + has_return_type = require_boolean( + member.get("has_return_type"), + f"{path}.interface_members[{index}].has_return_type", + ) + if has_return_type: + require_string( + member.get("return_type"), + f"{path}.interface_members[{index}].return_type", + ) + elif member.get("return_type") is not None: + fail( + f"{path}.interface_members[{index}].return_type must be null when " + "has_return_type is false" + ) + require_boolean( + member.get("return_is_access_def"), + f"{path}.interface_members[{index}].return_is_access_def", + ) return descriptor @@ -368,8 +409,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-v4": - fail(f"{path}.format must be typed-v4") + if typed.get("format") != "typed-v5": + fail(f"{path}.format must be typed-v5") for field in ( "target_bits", "unit_kind", @@ -552,8 +593,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-v3": - fail(f"{path}.format must be safei-v3") + if safei.get("format") != "safei-v4": + fail(f"{path}.format must be safei-v4") for field in ( "target_bits", "unit_kind", diff --git a/spec/02-restrictions.md b/spec/02-restrictions.md index 1ee58a4..1565bd5 100644 --- a/spec/02-restrictions.md +++ b/spec/02-restrictions.md @@ -32,7 +32,7 @@ This section enumerates every feature of ISO/IEC 8652:2023 (Ada 2022) that Safe #### 3.9 Tagged Types and Type Extensions -7. **Tagged types (§3.9).** Tagged type declarations, type extensions (§3.9.1), dispatching operations (§3.9.2), abstract types and subprograms (§3.9.3), and interface types (§3.9.4) are excluded. A conforming implementation shall reject any `tagged` type declaration, type extension declaration, `abstract` type or subprogram declaration, or interface type declaration. +7. **Tagged types (§3.9).** Tagged type declarations, type extensions (§3.9.1), dispatching operations (§3.9.2), abstract types and subprograms (§3.9.3), and Ada interface types (§3.9.4) are excluded. A conforming implementation shall reject any `tagged` type declaration, type extension declaration, `abstract` type or subprogram declaration, or Ada interface type declaration. Safe structural interfaces introduced in PR11.11b are a distinct Safe-only construct; they are compile-time operation contracts, not Ada tagged/interface types. 8. **Related exclusions:** Extension aggregates (§4.3.2), class-wide types, class-wide operations, and all constructs requiring tagged types are excluded as a consequence. diff --git a/spec/08-syntax-summary.md b/spec/08-syntax-summary.md index 3b27aae..c0432e6 100644 --- a/spec/08-syntax-summary.md +++ b/spec/08-syntax-summary.md @@ -119,6 +119,8 @@ basic_declaration ::= type_declaration ::= [ 'public' ] 'type' defining_identifier [ known_discriminant_part ] 'is' type_definition ';' + | [ 'public' ] 'type' defining_identifier 'is' 'interface' + indented_interface_member_list incomplete_type_declaration ::= [ 'public' ] 'type' defining_identifier ';' @@ -275,6 +277,14 @@ discrete_choice ::= derived_type_definition ::= [ 'limited' ] 'new' subtype_indication + +indented_interface_member_list ::= + INDENT + interface_member_specification { interface_member_specification } + DEDENT + +interface_member_specification ::= + function_specification ';' ``` ## 8.5 Subtype Indications @@ -725,6 +735,18 @@ function model: - Bare selectors such as `.length`, `.present`, `.value`, and ordinary field access keep their existing meaning unless immediately followed by `(...)`. +For the post-PR11.11b surface, structural interfaces are also admitted with a +strict subset: + +- interface declarations are `type name is interface` plus an indented suite + of signature-only members, +- every interface member must use receiver syntax and the receiver type must be + the enclosing interface name, +- interface types are admitted only in subprogram parameter positions in this + milestone, +- public interface-constrained subprogram bodies remain deferred to a later + milestone. + default_expression ::= expression ``` diff --git a/tests/build/pr1111b_interface_builtin_build.safe b/tests/build/pr1111b_interface_builtin_build.safe new file mode 100644 index 0000000..7c773d3 --- /dev/null +++ b/tests/build/pr1111b_interface_builtin_build.safe @@ -0,0 +1,23 @@ +package pr1111b_interface_builtin_build + + type appendable is interface + function (self : mut appendable) append (value : integer); + + function extend_twice (values : mut appendable) + values.append (10); + values.append (20); + + function popped_value returns integer + var numbers : list of integer; + var last_value : optional integer; + + extend_twice (numbers); + last_value = numbers.pop_last(); + + print (numbers.length); + if last_value.present + return last_value.value; + else + return 0; + + print (popped_value); diff --git a/tests/interfaces/client_printable.safe b/tests/interfaces/client_printable.safe new file mode 100644 index 0000000..5e517f3 --- /dev/null +++ b/tests/interfaces/client_printable.safe @@ -0,0 +1,14 @@ +with provider_printable; + +package client_printable + + function render (item : provider_printable.printable) returns string + return item.label(); + + function total returns integer + item : provider_printable.widget = (text = "Bob"); + + if render (item) == "Bob" + return 1; + else + return 0; diff --git a/tests/interfaces/client_printable_ambiguous.safe b/tests/interfaces/client_printable_ambiguous.safe new file mode 100644 index 0000000..5086036 --- /dev/null +++ b/tests/interfaces/client_printable_ambiguous.safe @@ -0,0 +1,14 @@ +with provider_printable; + +package client_printable_ambiguous + + function (self : provider_printable.widget) label returns string + return self.text; + + function render (item : provider_printable.printable) returns string + return item.label(); + + function total returns integer + item : provider_printable.widget = (text = "Bob"); + + return render (item).length; diff --git a/tests/interfaces/provider_printable.safe b/tests/interfaces/provider_printable.safe new file mode 100644 index 0000000..594184e --- /dev/null +++ b/tests/interfaces/provider_printable.safe @@ -0,0 +1,10 @@ +package provider_printable + + public type printable is interface + function (self : printable) label returns string; + + public type widget is record + text : string; + + public function (self : widget) label returns string + return self.text; diff --git a/tests/negative/neg_pr1111b_interface_free_call.safe b/tests/negative/neg_pr1111b_interface_free_call.safe new file mode 100644 index 0000000..b1cf893 --- /dev/null +++ b/tests/negative/neg_pr1111b_interface_free_call.safe @@ -0,0 +1,13 @@ +package neg_pr1111b_interface_free_call + + 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 (item : printable) returns string + return label (item); diff --git a/tests/negative/neg_pr1111b_interface_member_no_receiver.safe b/tests/negative/neg_pr1111b_interface_member_no_receiver.safe new file mode 100644 index 0000000..acf3870 --- /dev/null +++ b/tests/negative/neg_pr1111b_interface_member_no_receiver.safe @@ -0,0 +1,4 @@ +package neg_pr1111b_interface_member_no_receiver + + type printable is interface + function label returns string; diff --git a/tests/negative/neg_pr1111b_interface_object.safe b/tests/negative/neg_pr1111b_interface_object.safe new file mode 100644 index 0000000..91679e6 --- /dev/null +++ b/tests/negative/neg_pr1111b_interface_object.safe @@ -0,0 +1,6 @@ +package neg_pr1111b_interface_object + + type printable is interface + function (self : printable) label returns string; + + item : printable; diff --git a/tests/negative/neg_pr1111b_interface_qualified_free_call.safe b/tests/negative/neg_pr1111b_interface_qualified_free_call.safe new file mode 100644 index 0000000..cd24ee3 --- /dev/null +++ b/tests/negative/neg_pr1111b_interface_qualified_free_call.safe @@ -0,0 +1,13 @@ +package neg_pr1111b_interface_qualified_free_call + + 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 (item : printable) returns string + return neg_pr1111b_interface_qualified_free_call.label (item); diff --git a/tests/negative/neg_pr1111b_interface_return.safe b/tests/negative/neg_pr1111b_interface_return.safe new file mode 100644 index 0000000..63a5e06 --- /dev/null +++ b/tests/negative/neg_pr1111b_interface_return.safe @@ -0,0 +1,7 @@ +package neg_pr1111b_interface_return + + type printable is interface + function (self : printable) label returns string; + + function make returns printable + return 0; diff --git a/tests/negative/neg_pr1111b_missing_member.safe b/tests/negative/neg_pr1111b_missing_member.safe new file mode 100644 index 0000000..3408c11 --- /dev/null +++ b/tests/negative/neg_pr1111b_missing_member.safe @@ -0,0 +1,15 @@ +package neg_pr1111b_missing_member + + type printable is interface + function (self : printable) label returns string; + + type widget is record + value : integer; + + function render (item : printable) returns string + return item.label(); + + function total returns integer + item : widget = (value = 1); + + return render (item).length; diff --git a/tests/negative/neg_pr1111b_public_interface_body.safe b/tests/negative/neg_pr1111b_public_interface_body.safe new file mode 100644 index 0000000..1b5dcc7 --- /dev/null +++ b/tests/negative/neg_pr1111b_public_interface_body.safe @@ -0,0 +1,7 @@ +package neg_pr1111b_public_interface_body + + public type printable is interface + function (self : printable) label returns string; + + public function render (item : printable) returns string + return item.label(); diff --git a/tests/positive/pr1111b_interface_local.safe b/tests/positive/pr1111b_interface_local.safe new file mode 100644 index 0000000..c220329 --- /dev/null +++ b/tests/positive/pr1111b_interface_local.safe @@ -0,0 +1,21 @@ +package pr1111b_interface_local + + 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 (item : printable) returns string + return item.label(); + + function total returns integer + item : widget = (text = "Ada"); + + if render (item) == "Ada" + return 1; + else + return 0;