+ -----------------
+ -- Write_Itype --
+ -----------------
+
+ procedure Write_Itype (Typ : Entity_Id) is
+
+ procedure Write_Header (T : Boolean := True);
+ -- Write type if T is True, subtype if T is false
+
+ ------------------
+ -- Write_Header --
+ ------------------
+
+ procedure Write_Header (T : Boolean := True) is
+ begin
+ if T then
+ Write_Str ("[type ");
+ else
+ Write_Str ("[subtype ");
+ end if;
+
+ Write_Name_With_Col_Check (Chars (Typ));
+ Write_Str (" is ");
+ end Write_Header;
+
+ -- Start of processing for Write_Itype
+
+ begin
+ if Nkind (Typ) in N_Entity
+ and then Is_Itype (Typ)
+ and then not Itype_Printed (Typ)
+ then
+ -- Itype to be printed
+
+ declare
+ B : constant Node_Id := Etype (Typ);
+ X : Node_Id;
+ P : constant Node_Id := Parent (Typ);
+
+ S : constant Saved_Output_Buffer := Save_Output_Buffer;
+ -- Save current output buffer
+
+ Old_Sloc : Source_Ptr;
+ -- Save sloc of related node, so it is not modified when
+ -- printing with -gnatD.
+
+ begin
+ -- Write indentation at start of line
+
+ for J in 1 .. Indent loop
+ Write_Char (' ');
+ end loop;
+
+ -- If we have a constructed declaration, print it
+
+ if Present (P) and then Nkind (P) in N_Declaration then
+
+ -- We must set Itype_Printed true before the recursive call to
+ -- print the node, otherwise we get an infinite recursion!
+
+ Set_Itype_Printed (Typ, True);
+
+ -- Write the declaration enclosed in [], avoiding new line
+ -- at start of declaration, and semicolon at end.
+
+ -- Note: The itype may be imported from another unit, in which
+ -- case we do not want to modify the Sloc of the declaration.
+ -- Otherwise the itype may appear to be in the current unit,
+ -- and the back-end will reject a reference out of scope.
+
+ Write_Char ('[');
+ Indent_Annull_Flag := True;
+ Old_Sloc := Sloc (P);
+ Sprint_Node (P);
+ Set_Sloc (P, Old_Sloc);
+ Write_Erase_Char (';');
+
+ -- If no constructed declaration, then we have to concoct the
+ -- source corresponding to the type entity that we have at hand.
+
+ else
+ case Ekind (Typ) is
+
+ -- Access types and subtypes
+
+ when Access_Kind =>
+ Write_Header (Ekind (Typ) = E_Access_Type);
+ Write_Str ("access ");
+
+ if Is_Access_Constant (Typ) then
+ Write_Str ("constant ");
+ elsif Can_Never_Be_Null (Typ) then
+ Write_Str ("not null ");
+ end if;
+
+ Write_Id (Directly_Designated_Type (Typ));
+
+ -- Array types and string types
+
+ when E_Array_Type | E_String_Type =>
+ Write_Header;
+ Write_Str ("array (");
+
+ X := First_Index (Typ);
+ loop
+ Sprint_Node (X);
+
+ if not Is_Constrained (Typ) then
+ Write_Str (" range <>");
+ end if;
+
+ Next_Index (X);
+ exit when No (X);
+ Write_Str (", ");
+ end loop;
+
+ Write_Str (") of ");
+ Sprint_Node (Component_Type (Typ));
+
+ -- Array subtypes and string subtypes
+
+ when E_Array_Subtype | E_String_Subtype =>
+ Write_Header (False);
+ Write_Id (Etype (Typ));
+ Write_Str (" (");
+
+ X := First_Index (Typ);
+ loop
+ Sprint_Node (X);
+ Next_Index (X);
+ exit when No (X);
+ Write_Str (", ");
+ end loop;
+
+ Write_Char (')');
+
+ -- Signed integer types, and modular integer subtypes
+
+ when E_Signed_Integer_Type |
+ E_Signed_Integer_Subtype |
+ E_Modular_Integer_Subtype =>
+
+ Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
+
+ if Ekind (Typ) = E_Signed_Integer_Type then
+ Write_Str ("new ");
+ end if;
+
+ Write_Id (B);
+
+ -- Print bounds if different from base type
+
+ declare
+ L : constant Node_Id := Type_Low_Bound (Typ);
+ H : constant Node_Id := Type_High_Bound (Typ);
+ LE : Node_Id;
+ HE : Node_Id;
+
+ begin
+ -- B can either be a scalar type, in which case the
+ -- declaration of Typ may constrain it with different
+ -- bounds, or a private type, in which case we know
+ -- that the declaration of Typ cannot have a scalar
+ -- constraint.
+
+ if Is_Scalar_Type (B) then
+ LE := Type_Low_Bound (B);
+ HE := Type_High_Bound (B);
+ else
+ LE := Empty;
+ HE := Empty;
+ end if;
+
+ if No (LE)
+ or else (True
+ and then Nkind (L) = N_Integer_Literal
+ and then Nkind (H) = N_Integer_Literal
+ and then Nkind (LE) = N_Integer_Literal
+ and then Nkind (HE) = N_Integer_Literal
+ and then UI_Eq (Intval (L), Intval (LE))
+ and then UI_Eq (Intval (H), Intval (HE)))
+ then
+ null;
+
+ else
+ Write_Str (" range ");
+ Sprint_Node (Type_Low_Bound (Typ));
+ Write_Str (" .. ");
+ Sprint_Node (Type_High_Bound (Typ));
+ end if;
+ end;
+
+ -- Modular integer types
+
+ when E_Modular_Integer_Type =>
+ Write_Header;
+ Write_Str (" mod ");
+ Write_Uint_With_Col_Check (Modulus (Typ), Auto);
+
+ -- Floating point types and subtypes
+
+ when E_Floating_Point_Type |
+ E_Floating_Point_Subtype =>
+
+ Write_Header (Ekind (Typ) = E_Floating_Point_Type);
+
+ if Ekind (Typ) = E_Floating_Point_Type then
+ Write_Str ("new ");
+ end if;
+
+ Write_Id (Etype (Typ));
+
+ if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then
+ Write_Str (" digits ");
+ Write_Uint_With_Col_Check
+ (Digits_Value (Typ), Decimal);
+ end if;
+
+ -- Print bounds if not different from base type
+
+ declare
+ L : constant Node_Id := Type_Low_Bound (Typ);
+ H : constant Node_Id := Type_High_Bound (Typ);
+ LE : constant Node_Id := Type_Low_Bound (B);
+ HE : constant Node_Id := Type_High_Bound (B);
+
+ begin
+ if Nkind (L) = N_Real_Literal
+ and then Nkind (H) = N_Real_Literal
+ and then Nkind (LE) = N_Real_Literal
+ and then Nkind (HE) = N_Real_Literal
+ and then UR_Eq (Realval (L), Realval (LE))
+ and then UR_Eq (Realval (H), Realval (HE))
+ then
+ null;
+
+ else
+ Write_Str (" range ");
+ Sprint_Node (Type_Low_Bound (Typ));
+ Write_Str (" .. ");
+ Sprint_Node (Type_High_Bound (Typ));
+ end if;
+ end;
+
+ -- Record subtypes
+
+ when E_Record_Subtype =>
+ Write_Header (False);
+ Write_Str ("record");
+ Indent_Begin;
+
+ declare
+ C : Entity_Id;
+ begin
+ C := First_Entity (Typ);
+ while Present (C) loop
+ Write_Indent;
+ Write_Id (C);
+ Write_Str (" : ");
+ Write_Id (Etype (C));
+ Next_Entity (C);
+ end loop;
+ end;
+
+ Indent_End;
+ Write_Indent_Str (" end record");
+
+ -- Class-Wide types
+
+ when E_Class_Wide_Type |
+ E_Class_Wide_Subtype =>
+ Write_Header;
+ Write_Name_With_Col_Check (Chars (Etype (Typ)));
+ Write_Str ("'Class");
+
+ -- Subprogram types
+
+ when E_Subprogram_Type =>
+ Write_Header;
+
+ if Etype (Typ) = Standard_Void_Type then
+ Write_Str ("procedure");
+ else
+ Write_Str ("function");
+ end if;
+
+ if Present (First_Entity (Typ)) then
+ Write_Str (" (");
+
+ declare
+ Param : Entity_Id;
+
+ begin
+ Param := First_Entity (Typ);
+ loop
+ Write_Id (Param);
+ Write_Str (" : ");
+
+ if Ekind (Param) = E_In_Out_Parameter then
+ Write_Str ("in out ");
+ elsif Ekind (Param) = E_Out_Parameter then
+ Write_Str ("out ");
+ end if;
+
+ Write_Id (Etype (Param));
+ Next_Entity (Param);
+ exit when No (Param);
+ Write_Str (", ");
+ end loop;
+
+ Write_Char (')');
+ end;
+ end if;
+
+ if Etype (Typ) /= Standard_Void_Type then
+ Write_Str (" return ");
+ Write_Id (Etype (Typ));
+ end if;
+
+ when E_String_Literal_Subtype =>
+ declare
+ LB : constant Uint :=
+ Intval (String_Literal_Low_Bound (Typ));
+ Len : constant Uint :=
+ String_Literal_Length (Typ);
+ begin
+ Write_Str ("String (");
+ Write_Int (UI_To_Int (LB));
+ Write_Str (" .. ");
+ Write_Int (UI_To_Int (LB + Len) - 1);
+ Write_Str (");");
+ end;
+
+ -- For all other Itypes, print ??? (fill in later)
+
+ when others =>
+ Write_Header (True);
+ Write_Str ("???");
+
+ end case;
+ end if;
+
+ -- Add terminating bracket and restore output buffer
+
+ Write_Char (']');
+ Write_Eol;
+ Restore_Output_Buffer (S);
+ end;
+
+ Set_Itype_Printed (Typ);
+ end if;
+ end Write_Itype;
+