+2012-07-09 Vincent Celier <celier@adacore.com>
+
+ * lib-writ.ads: Add documentation for the Z lines (implicitly
+ withed units) and Y lines (limited withed units).
+
+2012-07-09 Robert Dewar <dewar@adacore.com>
+
+ * lib.ads, exp_attr.adb, exp_ch9.adb, sem_dim.adb, sem_ch9.adb,
+ sem_prag.adb, sem_ch12.adb, mlib-utl.adb, freeze.adb, sem_res.adb,
+ sem_attr.adb, sem_case.adb, gnatlink.adb, exp_ch4.adb, sem_ch6.adb,
+ sem_elim.adb, s-dimmks.ads, sem_ch13.adb: Minor code clean ups.
+
+2012-07-09 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat_ugn.texi (Switches for gcc): Document -gnatn[12] only
+ lightly in the summary and more thoroughly in inlining section.
+ (Performance Considerations): Document -gnatn[12] in inlining
+ section.
+
+2012-07-09 Tristan Gingold <gingold@adacore.com>
+
+ * a-exexpr-gcc.adb (Unhandled_Except_Handler): New procedure.
+ (Unhandled_Others_Value): New const.
+ * raise-gcc.c (GNAT_UNHANDLED_OTHERS): Define.
+ (action_descriptor): Remove ttype_entry.
+ (get_action_description_for): Do not assign ttype_entry.
+ (is_handled_by): Consider GNAT_UNHANDLED_OTHERS.
+
2012-07-03 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (Call_to_gnu): Robustify test for function case
pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
-- Write Get_Current_Excep.all from GCC_Exception
+ procedure Unhandled_Except_Handler
+ (GCC_Exception : not null GCC_Exception_Access);
+ pragma No_Return (Unhandled_Except_Handler);
+ pragma Export (C, Unhandled_Except_Handler,
+ "__gnat_unhandled_except_handler");
+ -- Called for handle unhandled exceptions, ie the last chance handler
+ -- on platforms (such as SEH) that never returns after throwing an
+ -- exception. Called directly by gigi.
+
function CleanupUnwind_Handler
(UW_Version : Integer;
UW_Phases : Unwind_Action;
All_Others_Value : constant Integer := 16#7FFF#;
pragma Export (C, All_Others_Value, "__gnat_all_others_value");
+ Unhandled_Others_Value : constant Integer := 16#7FFF#;
+ pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
+ -- Special choice (emitted by gigi) to catch and notify unhandled
+ -- exceptions on targets which always handle exceptions (such as SEH).
+ -- The handler will simply call Unhandled_Except_Handler.
+
--------------------------------
-- GNAT_GCC_Exception_Cleanup --
--------------------------------
-- Terminate when the end of the stack is reached
if UW_Phases >= UA_END_OF_STACK then
- Setup_Current_Excep (UW_Exception);
- Unhandled_Exception_Terminate;
+ Unhandled_Except_Handler (UW_Exception);
end if;
-- We know there is at least one cleanup further up. Return so that it
-- We get here in case of error. The debugger has been notified before
-- the second step above.
+ Unhandled_Except_Handler (GCC_Exception);
+ end Propagate_GCC_Exception;
+
+ ------------------------------
+ -- Unhandled_Except_Handler --
+ ------------------------------
+
+ procedure Unhandled_Except_Handler
+ (GCC_Exception : not null GCC_Exception_Access)
+ is
+ begin
Setup_Current_Excep (GCC_Exception);
Unhandled_Exception_Terminate;
- end Propagate_GCC_Exception;
+ end Unhandled_Except_Handler;
-------------------------
-- Propagate_Exception --
-- Rewrite the attribute reference with the value of Uses_Lock_Free
when Attribute_Lock_Free => Lock_Free : declare
- Val : Entity_Id;
-
+ V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (Ptyp));
begin
- if Uses_Lock_Free (Ptyp) then
- Val := Standard_True;
-
- else
- Val := Standard_False;
- end if;
-
- Rewrite (N,
- New_Occurrence_Of (Val, Loc));
-
+ Rewrite (N, New_Occurrence_Of (V, Loc));
Analyze_And_Resolve (N, Standard_Boolean);
end Lock_Free;
if AV = False then
if True_Result or False_Result then
- if True_Result then
- Result := Standard_True;
- else
- Result := Standard_False;
- end if;
-
+ Result := Boolean_Literals (True_Result);
Rewrite (N,
Convert_To (Typ,
New_Occurrence_Of (Result, Sloc (N))));
-- will allocate an array to hold the string names of task entries.
if not Restricted_Profile then
- if Has_Entries (Ttyp)
- and then Entry_Names_OK
- then
- Append_To (Args, New_Reference_To (Standard_True, Loc));
- else
- Append_To (Args, New_Reference_To (Standard_False, Loc));
- end if;
+ Append_To (Args,
+ New_Reference_To
+ (Boolean_Literals (Has_Entries (Ttyp) and then Entry_Names_OK),
+ Loc));
end if;
if Restricted_Profile then
else
Id := Defining_Unit_Name (Specification (P));
+ -- Following complex conditional could use comments ???
+
if Nkind (Id) = N_Defining_Identifier
- and then (Is_Init_Proc (Id) or else
- Is_TSS (Id, TSS_Stream_Input) or else
- Is_TSS (Id, TSS_Stream_Output) or else
- Is_TSS (Id, TSS_Stream_Read) or else
- Is_TSS (Id, TSS_Stream_Write) or else
- Nkind (Original_Node (P)) =
- N_Subprogram_Renaming_Declaration or else
- Nkind (Original_Node (P)) =
- N_Expression_Function)
+ and then (Is_Init_Proc (Id)
+ or else Is_TSS (Id, TSS_Stream_Input)
+ or else Is_TSS (Id, TSS_Stream_Output)
+ or else Is_TSS (Id, TSS_Stream_Read)
+ or else Is_TSS (Id, TSS_Stream_Write)
+ or else Nkind_In (Original_Node (P),
+ N_Subprogram_Renaming_Declaration,
+ N_Expression_Function))
then
return True;
else
if not Is_Compilation_Unit (Current_Scope)
and then (Is_Record_Type (Scope (Current_Scope))
or else Nkind (Parent (Current_Scope)) =
- N_Quantified_Expression)
+ N_Quantified_Expression)
then
Pos := Pos - 1;
end if;
@cindex @option{-gnatn} (@command{gcc})
Activate inlining for subprograms for which pragma @code{Inline} is
specified. This inlining is performed by the GCC back-end. An optional
-digit sets the inlining level: 1 for moderate inlining across modules,
-which is a good compromise between compilation times and performances
-at run time, and 2 for full inlining across modules, which may bring
-about longer compilation times. If no inlining level is specified,
+digit sets the inlining level: 1 for moderate inlining across modules
+or 2 for full inlining across modules. If no inlining level is specified,
the compiler will pick it based on the optimization level.
@item -gnatN
@table @option
@c !sort!
-@item -gnatn
+@item -gnatn[12]
@cindex @option{-gnatn} (@command{gcc})
@ifclear vms
The @code{n} here is intended to suggest the first syllable of the
word ``inline''.
@end ifclear
GNAT recognizes and processes @code{Inline} pragmas. However, for the
-inlining to actually occur, optimization must be enabled. To enable
-inlining of subprograms specified by pragma @code{Inline},
+inlining to actually occur, optimization must be enabled and, in order
+to enable inlining of subprograms specified by pragma @code{Inline},
you must also specify this switch.
In the absence of this switch, GNAT does not attempt
inlining and does not need to access the bodies of
subprograms for which @code{pragma Inline} is specified if they are not
in the current unit.
+You can optionally specify the inlining level: 1 for moderate inlining across
+modules, which is a good compromise between compilation times and performances
+at run time, or 2 for full inlining across modules, which may bring about
+longer compilation times. If no inlining level is specified, the compiler will
+pick it based on the optimization level: 1 for @option{-O1}, @option{-O2} or
+@option{-Os} and 2 for @option{-O3}.
+
If you specify this switch the compiler will access these bodies,
creating an extra source dependency for the resulting object file, and
where possible, the call will be inlined.
can be used to prevent inlining of subprograms local to the unit
and called once from within it if @option{-O1} is used.
-Note regarding the use of @option{-O3}: There is no difference in inlining
-behavior between @option{-O2} and @option{-O3} for subprograms with an explicit
-pragma @code{Inline} assuming the use of @option{-gnatn}
-or @option{-gnatN} (the switches that activate inlining). If you have used
-pragma @code{Inline} in appropriate cases, then it is usually much better
-to use @option{-O2} and @option{-gnatn} and avoid the use of @option{-O3} which
-in this case only has the effect of inlining subprograms you did not
-think should be inlined. We often find that the use of @option{-O3} slows
-down code by performing excessive inlining, leading to increased instruction
-cache pressure from the increased code size. So the bottom line here is
-that you should not automatically assume that @option{-O3} is better than
-@option{-O2}, and indeed you should use @option{-O3} only if tests show that
-it actually improves performance.
+Note regarding the use of @option{-O3}: @option{-gnatn} is made up of two
+sub-switches @option{-gnatn1} and @option{-gnatn2} that can be directly
+specified in lieu of it, @option{-gnatn} being translated into one of them
+based on the optimization level. With @option{-O2} or below, @option{-gnatn}
+is equivalent to @option{-gnatn1} which activates pragma @code{Inline} with
+moderate inlining across modules. With @option{-O3}, @option{-gnatn} is
+equivalent to @option{-gnatn2} which activates pragma @code{Inline} with
+full inlining across modules. If you have used pragma @code{Inline} in appropriate cases, then it is usually much better to use @option{-O2} and @option{-gnatn} and avoid the use of @option{-O3} which has the additional
+effect of inlining subprograms you did not think should be inlined. We have
+found that the use of @option{-O3} may slow down the compilation and increase
+the code size by performing excessive inlining, leading to increased
+instruction cache pressure from the increased code size and thus minor
+performance improvements. So the bottom line here is that you should not
+automatically assume that @option{-O3} is better than @option{-O2}, and
+indeed you should use @option{-O3} only if tests show that it actually
+improves performance for your program.
@node Vectorization of loops
@subsection Vectorization of loops
procedure Write_RF (S : String) is
Success : Boolean := True;
+
begin
-- If a GNU response file is used, space and backslash need to be
-- escaped because they are interpreted as a string separator and
-- they are interpreted as string delimiters on both sides.
if Using_GNU_response_file then
- for I in S'Range loop
- if S (I) = ' ' or else S (I) = '\' then
+ for J in S'Range loop
+ if S (J) = ' ' or else S (J) = '\' then
if Write (Tname_FD, ASCII.BACK_SLASH'Address, 1) /= 1 then
Success := False;
end if;
end if;
- if Write (Tname_FD, S (I)'Address, 1) /= 1 then
+ if Write (Tname_FD, S (J)'Address, 1) /= 1 then
Success := False;
end if;
end loop;
+
else
if Write (Tname_FD, S'Address, S'Length) /= S'Length then
Success := False;
Linker_Objects.Increment_Last;
- -- Mark the positions of first and last object files in case
- -- they need to be placed with a named file on systems having
- -- linker line limitations.
+ -- Mark the positions of first and last object files in case they
+ -- need to be placed with a named file on systems having linker
+ -- line limitations.
if Objs_Begin = 0 then
Objs_Begin := Linker_Objects.Last;
and then Link_Bytes > Link_Max)
then
-- Create a temporary file containing the Ada user object files
- -- needed by the link. This list is taken from the bind file
- -- and is output one object per line for maximal compatibility with
- -- linkers supporting this option.
+ -- needed by the link. This list is taken from the bind file and is
+ -- output one object per line for maximal compatibility with linkers
+ -- supporting this option.
Create_Temp_File (Tname_FD, Tname);
Tname (Tname'First .. Tname'Last - 1));
-- The slots containing these object file names are then removed
- -- from the objects table so they do not appear in the link. They
- -- are removed by moving up the linker options and non-Ada object
- -- files appearing after the Ada object list in the table.
+ -- from the objects table so they do not appear in the link. They are
+ -- removed by moving up the linker options and non-Ada object files
+ -- appearing after the Ada object list in the table.
declare
N : Integer;
elsif Next_Line (Nfirst .. Nlast) = "-shared" then
GNAT_Shared := True;
- -- Add binder options only if not already set on the command
- -- line. This rule is a way to control the linker options order.
+ -- Add binder options only if not already set on the command line.
+ -- This rule is a way to control the linker options order.
-- The following test needs comments, why is it VMS specific.
-- The above comment looks out of date ???
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
- -- Construct a library search path for use later
- -- to locate static gnatlib libraries.
+ -- Construct a library search path for use later to locate
+ -- static gnatlib libraries.
if Libpath.Last > 1 then
Libpath.Increment_Last;
System.OS_Lib.Spawn (Linker_Path.all, Args, Success);
if Success then
+
-- Delete the temporary file used in conjunction with linking
-- if one was created. See Process_Bind_File for details.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--
-- The attributes may appear in any order, separated by spaces.
- -- ---------------------
- -- -- W Withed Units --
- -- ---------------------
+ -- -----------------------------
+ -- -- W, Y and Z Withed Units --
+ -- -----------------------------
-- Following each U line, is a series of lines of the form
-- W unit-name [source-name lib-name] [E] [EA] [ED] [AD]
- --
- -- One of these lines is present for each unit that is mentioned in an
- -- explicit with clause by the current unit. The first parameter is the
- -- unit name in internal format. The second parameter is the file name
- -- of the file that must be compiled to compile this unit. It is
+ -- or
+ -- Y unit-name [source-name lib-name] [E] [EA] [ED] [AD]
+ -- or
+ -- Z unit-name [source-name lib-name] [E] [EA] [ED] [AD]
+ --
+ -- One W line is present for each unit that is mentioned in an explicit
+ -- non-limited with clause by the current unit. One Y line is present
+ -- for each unit that is mentioned in an explicit limited with clause
+ -- by the current unit. One Z line is present for each unit that is
+ -- only implicitly withed by the current unit. The first parameter is
+ -- the unit name in internal format. The second parameter is the file
+ -- name of the file that must be compiled to compile this unit. It is
-- usually the file for the body, except for packages which have no
-- body. For units that need a body, if the source file for the body
-- cannot be found, the file name of the spec is used instead. The
-- generic unit compiled with earlier versions of GNAT which did not
-- generate object or ali files for generics.
- -- In fact W lines include implicit withs ???
-
-- -----------------------
-- -- L Linker_Options --
-- -----------------------
-- one with no code, but the ALI file has the normal form, and we need
-- this ALI file so that the binder can work out a correct order of
-- elaboration.
-
+ --
-- However, ancient versions of GNAT used to not generate code or ALI
-- files for generic units, and this would yield complex order of
-- elaboration issues. These were fixed in GNAT 3.10. The support for not
-- The linker option which specifies the response file as a string
Using_GNU_response_file : constant Boolean :=
- Object_File_Option'Length > 0
- and then Object_File_Option (Object_File_Option'Last) = '@';
+ Object_File_Option'Length > 0
+ and then
+ Object_File_Option
+ (Object_File_Option'Last) = '@';
-- Whether a GNU response file is used
Tname : String_Access;
procedure Write_RF (S : String) is
Success : Boolean := True;
+
begin
-- If a GNU response file is used, space and backslash need to be
-- escaped because they are interpreted as a string separator and
-- they are interpreted as string delimiters on both sides.
if Using_GNU_response_file then
- for I in S'Range loop
- if S (I) = ' ' or else S (I) = '\' then
+ for J in S'Range loop
+ if S (J) = ' ' or else S (J) = '\' then
if Write (Tname_FD, ASCII.BACK_SLASH'Address, 1) /= 1 then
Success := False;
end if;
end if;
- if Write (Tname_FD, S (I)'Address, 1) /= 1 then
+ if Write (Tname_FD, S (J)'Address, 1) /= 1 then
Success := False;
end if;
end loop;
+
else
if Write (Tname_FD, S'Address, S'Length) /= S'Length then
Success := False;
end if;
end Write_RF;
+ -- Start of processing for Gcc
+
begin
if Driver_Name = No_Name then
if Gcc_Exec = null then
end loop;
if Object_List_File_Supported and then Link_Bytes > Link_Max then
+
-- Create a temporary file containing the object files, one object
-- file per line for maximal compatibility with linkers supporting
-- this option.
extern const int __gnat_all_others_value;
#define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value)
+extern const int __gnat_unhandled_others_value;
+#define GNAT_UNHANDLED_OTHERS ((_Unwind_Ptr) &__gnat_unhandled_others_value)
+
/* Describe the useful region data associated with an unwind context. */
typedef struct
/* If we have a handler matching our exception, these are the filter to
trigger it and the corresponding id. */
_Unwind_Sword ttype_filter;
- _Unwind_Ptr ttype_entry;
} action_descriptor;
bool is_handled =
choice == E
+ || (choice == GNAT_OTHERS && Is_Handled_By_Others (E))
|| choice == GNAT_ALL_OTHERS
- || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
+ || choice == GNAT_UNHANDLED_OTHERS;
/* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
may have different exception data pointers that should match for the
{
action->kind = handler;
action->ttype_filter = ar_filter;
- action->ttype_entry = choice;
return;
}
}
Dimension => (Symbol => 'm',
Meter => 1,
others => 0);
+
subtype Mass is Mks_Type
with
Dimension => (Symbol => "kg",
Kilogram => 1,
others => 0);
+
subtype Time is Mks_Type
with
Dimension => (Symbol => 's',
Second => 1,
others => 0);
+
subtype Electric_Current is Mks_Type
with
Dimension => (Symbol => 'A',
Ampere => 1,
others => 0);
+
subtype Thermodynamic_Temperature is Mks_Type
with
Dimension => (Symbol => 'K',
Kelvin => 1,
others => 0);
+
subtype Amount_Of_Substance is Mks_Type
with
Dimension => (Symbol => "mol",
Mole => 1,
others => 0);
+
subtype Luminous_Intensity is Mks_Type
with
Dimension => (Symbol => "cd",
Dimension => (Symbol => "Hz",
Second => -1,
others => 0);
+
subtype Force is Mks_Type
with
Dimension => (Symbol => 'N',
Kilogram => 1,
Second => -2,
others => 0);
+
subtype Pressure is Mks_Type
with
Dimension => (Symbol => "Pa",
Kilogram => 1,
Second => -2,
others => 0);
+
subtype Energy is Mks_Type
with
Dimension => (Symbol => 'J',
Kilogram => 1,
Second => -2,
others => 0);
+
subtype Power is Mks_Type
with
Dimension => (Symbol => 'W',
Kilogram => 1,
Second => -3,
others => 0);
+
subtype Electric_Charge is Mks_Type
with
Dimension => (Symbol => 'C',
Second => 1,
Ampere => 1,
others => 0);
+
subtype Electric_Potential_Difference is Mks_Type
with
Dimension => (Symbol => 'V',
Second => -3,
Ampere => -1,
others => 0);
+
subtype Electric_Capacitance is Mks_Type
with
Dimension => (Symbol => 'F',
Second => 4,
Ampere => 2,
others => 0);
+
subtype Electric_Resistance is Mks_Type
with
Dimension => (Symbol => "Ω",
Second => -3,
Ampere => -2,
others => 0);
+
subtype Electric_Conductance is Mks_Type
with
Dimension => (Symbol => 'S',
Second => 3,
Ampere => 2,
others => 0);
+
subtype Magnetic_Flux is Mks_Type
with
Dimension => (Symbol => "Wb",
Second => -2,
Ampere => -1,
others => 0);
+
subtype Magnetic_Flux_Density is Mks_Type
with
Dimension => (Symbol => 'T',
Second => -2,
Ampere => -1,
others => 0);
+
subtype Inductance is Mks_Type
with
Dimension => (Symbol => 'H',
Second => -2,
Ampere => -2,
others => 0);
+
subtype Celsius_Temperature is Mks_Type
with
Dimension => (Symbol => "°C",
Kelvin => 1,
others => 0);
+
subtype Luminous_Flux is Mks_Type
with
Dimension => (Symbol => "lm",
Candela => 1,
others => 0);
+
subtype Illuminance is Mks_Type
with
Dimension => (Symbol => "lx",
Meter => -2,
Candela => 1,
others => 0);
+
subtype Radioactivity is Mks_Type
with
Dimension => (Symbol => "Bq",
Second => -1,
others => 0);
+
subtype Absorbed_Dose is Mks_Type
with
Dimension => (Symbol => "Gy",
Meter => 2,
Second => -2,
others => 0);
+
subtype Equivalent_Dose is Mks_Type
with
Dimension => (Symbol => "Sv",
Meter => 2,
Second => -2,
others => 0);
+
subtype Catalytic_Activity is Mks_Type
with
Dimension => (Symbol => "kat",
when Attribute_Fast_Math =>
Check_Standard_Prefix;
-
- if Opt.Fast_Math then
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
- else
- Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
- end if;
+ Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
-----------
-- First --
R := Is_Check_Suppressed (Entity (E1), C);
end if;
- if R then
- Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
- else
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
- end if;
+ Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc));
end;
end if;
-- AI05-0188 : within an instance the non-others choices do not
-- have to belong to the actual subtype.
- if Ada_Version >= Ada_2012
- and then In_Instance
- then
+ if Ada_Version >= Ada_2012 and then In_Instance then
return;
end if;
-- Do not insert non static choices in the table to be sorted
elsif not Is_Static_Expression (Lo)
- or else not Is_Static_Expression (Hi)
+ or else
+ not Is_Static_Expression (Hi)
then
Process_Non_Static_Choice (Choice);
return;
Raises_CE := True;
return;
- -- AI05-0188 : within an instance the non-others choices do not
+ -- AI05-0188 : Within an instance the non-others choices do not
-- have to belong to the actual subtype.
- elsif Ada_Version >= Ada_2012
- and then In_Instance
- then
+ elsif Ada_Version >= Ada_2012 and then In_Instance then
return;
-- Otherwise we have an OK static choice
pragma Assert (Present (Ancestor));
- -- the ancestor itself may be a previous formal that
- -- has been instantiated.
+ -- The ancestor itself may be a previous formal that has been
+ -- instantiated.
Ancestor := Get_Instance_Of (Ancestor);
Set_Is_Delayed_Aspect (Prag);
Set_Parent (Prag, ASN);
end if;
-
end Make_Pragma_From_Boolean_Aspect;
-- Start of processing for Analyze_Aspects_At_Freeze_Point
-- Look for aspect specification entries for this entity
ASN := First_Rep_Item (E);
-
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification
and then Entity (ASN) = E
A_Id := Get_Aspect_Id (Chars (Identifier (ASN)));
case A_Id is
+
-- For aspects whose expression is an optional Boolean, make
-- the corresponding pragma at the freezing point.
Aspect_Default_Component_Value =>
Analyze_Aspect_Default_Value (ASN);
- when others => null;
+ when others =>
+ null;
end case;
Ritem := Aspect_Rep_Item (ASN);
-- rewritten if the original call was in prefix notation) then error
-- has been emitted already, mark node and return.
- if Error_Posted (N)
- or else Etype (Name (N)) = Any_Type
- then
+ if Error_Posted (N) or else Etype (Name (N)) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
-- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
if Nkind (P) = N_Attribute_Reference
- and then (Attribute_Name (P) = Name_Elab_Spec
- or else Attribute_Name (P) = Name_Elab_Body
- or else Attribute_Name (P) = Name_Elab_Subp_Body)
+ and then (Attribute_Name (P) = Name_Elab_Spec or else
+ Attribute_Name (P) = Name_Elab_Body or else
+ Attribute_Name (P) = Name_Elab_Subp_Body)
then
if Present (Actuals) then
Error_Msg_N
end if;
end if;
- -- Ada 2012: mode conformance also requires that formal parameters
+ -- Ada 2012: Mode conformance also requires that formal parameters
-- be both aliased, or neither.
- if Ctype >= Mode_Conformant
- and then Ada_Version >= Ada_2012
- then
+ if Ctype >= Mode_Conformant and then Ada_Version >= Ada_2012 then
if Is_Aliased (Old_Formal) /= Is_Aliased (New_Formal) then
Conformance_Error
("\aliased parameter mismatch!", New_Formal);
begin
if Present (Ritem) then
+
-- Pragma with one argument
if Nkind (Ritem) = N_Pragma
and then Present (Pragma_Argument_Associations (Ritem))
then
return
- Is_False (Static_Boolean
- (Expression (First (Pragma_Argument_Associations (Ritem)))));
+ Is_False
+ (Static_Boolean
+ (Expression
+ (First (Pragma_Argument_Associations (Ritem)))));
-- Aspect Specification with expression present
No_Symbols : constant Symbol_Array := (others => No_String);
+ -- The following record should be documented field by field
+
type System_Type is record
Type_Decl : Node_Id;
Unit_Names : Name_Array;
Errors_Count : Nat;
-- Errors_Count is a count of errors detected by the compiler so far
-- just before the extraction of symbol, names and values in the
- -- aggregate
- -- (Step 2).
+ -- aggregate (Step 2).
--
-- At the end of the analysis, there is a check to verify that this
-- count equals to Serious_Errors_Detected i.e. no erros have been
Assoc := First (Component_Associations (Aggr));
Choice := First (Choices (Assoc));
- if No (Next (Choice))
- and then Nkind (Choice) = N_Identifier
- then
+ if No (Next (Choice)) and then Nkind (Choice) = N_Identifier then
+
-- Symbol component association is present
if Chars (Choice) = Name_Symbol then
N_String_Literal)
then
Symbol_Expr := Empty;
- Error_Msg_N ("symbol expression must be character or " &
- "string",
- Symbol_Expr);
+ Error_Msg_N
+ ("symbol expression must be character or string",
+ Symbol_Expr);
end if;
-- Special error if no Symbol choice but expression is string
-- Skip the symbol expression when present
- if Present (Symbol_Expr)
- and then Num_Choices = 0
- then
+ if Present (Symbol_Expr) and then Num_Choices = 0 then
Expr := Next (Expr);
end if;
end if;
while Present (Assoc) loop
- Expr := Expression (Assoc);
- Choice := First (Choices (Assoc));
+ Expr := Expression (Assoc);
+ Choice := First (Choices (Assoc));
while Present (Choice) loop
-- Identifier case: NAME => EXPRESSION
-- Others case: OTHERS => EXPRESSION
elsif Nkind (Choice) = N_Others_Choice then
- if Present (Next (Choice))
- or else Present (Prev (Choice))
- then
+ if Present (Next (Choice)) or else Present (Prev (Choice)) then
Error_Msg_N
("OTHERS must appear alone in a choice list", Choice);
-- Check that no errors have been detected during the analysis
if Errors_Count = Serious_Errors_Detected then
- -- useless declaration
- if Symbol = No_String
- and then not Exists (Dimensions)
- then
+ -- Check for useless declaration
+
+ if Symbol = No_String and then not Exists (Dimensions) then
Error_Msg_N ("useless dimension declaration", Aggr);
end if;
-- Named dimension aggregate
if Present (Component_Associations (Dim_Aggr)) then
+
-- Check first argument denotes the unit name
Assoc := First (Component_Associations (Dim_Aggr));
-- Expand_Put_Call_With_Symbol --
---------------------------------
- -- For procedure Put (resp. Put_Dim_Of) defined in
- -- System.Dim.Float_IO/System.Dim.Integer_IO, the default string parameter
- -- must be rewritten to include the unit symbols (resp. dimension symbols)
- -- in the output of a dimensioned object. Note that if a value is already
- -- supplied for parameter Symbol, this routine doesn't do anything.
+ -- For procedure Put (resp. Put_Dim_Of) defined in System.Dim.Float_IO
+ -- (System.Dim.Integer_IO), the default string parameter must be rewritten
+ -- to include the unit symbols (resp. dimension symbols) in the output
+ -- of a dimensioned object. Note that if a value is already supplied for
+ -- parameter Symbol, this routine doesn't do anything.
-- Case 1. Item is dimensionless
if Nkind (Actual) = N_Parameter_Association
and then Chars (Selector_Name (Actual)) = Name_Symbol
then
-
- -- return True if the actual comes from source or if the string
- -- of symbols doesn't have the default value (i.e "").
+ -- Return True if the actual comes from source or if the string
+ -- of symbols doesn't have the default value (i.e. it is "").
return Comes_From_Source (Actual)
- or else String_Length
- (Strval
- (Explicit_Actual_Parameter (Actual))) /= 0;
+ or else
+ String_Length
+ (Strval (Explicit_Actual_Parameter (Actual))) /= 0;
end if;
Next (Actual);
end loop;
- -- At this point, the call has no parameter association
- -- Look to the last actual since the symbols parameter is the last
- -- one.
+ -- At this point, the call has no parameter association. Look to the
+ -- last actual since the symbols parameter is the last one.
return Nkind (Last (Actuals)) = N_String_Literal;
end Has_Symbols;
-- Put_Dim_Of case
if Is_Put_Dim_Of then
+
-- Check that the item is not dimensionless
-- Create the new String_Literal with the new String_Id generated
-- From_Dim_To_Str_Of_Dim_Symbols --
------------------------------------
- -- Given a dimension vector and the corresponding dimension system,
- -- create a String_Id to output the dimension symbols corresponding to the
- -- dimensions Dims. If In_Error_Msg is True, there is a special handling
- -- for character asterisk * which is an insertion character in error
- -- messages.
+ -- Given a dimension vector and the corresponding dimension system, create
+ -- a String_Id to output dimension symbols corresponding to the dimensions
+ -- Dims. If In_Error_Msg is True, there is a special handling for character
+ -- asterisk * which is an insertion character in error messages.
function From_Dim_To_Str_Of_Dim_Symbols
(Dims : Dimension_Type;
First_Dim : Boolean := True;
procedure Store_String_Oexpon;
- -- Store the expon operator symbol "**" to the string. In error
- -- messages, asterisk * is a special character and must be precede by a
- -- quote ' to be placed literally into the message.
+ -- Store the expon operator symbol "**" in the string. In error
+ -- messages, asterisk * is a special character and must be quoted
+ -- to be placed literally into the message.
-------------------------
-- Store_String_Oexpon --
begin
if In_Error_Msg then
Store_String_Chars ("'*'*");
-
else
Store_String_Chars ("**");
end if;
end loop;
Store_String_Char (']');
-
return End_String;
end From_Dim_To_Str_Of_Dim_Symbols;
for Position in Dimension_Type'Range loop
Dim_Power := Dims (Position);
+
if Dim_Power /= Zero then
if First_Dim then
-- Positive dimension case
if Dim_Power.Numerator > 0 then
+
-- Integer case
if Dim_Power.Denominator = 1 then
return Null_System;
end System_Of;
+
end Sem_Dim;
function OK_Selected_Component (N : Node_Id) return Boolean;
-- Test if N is a selected component with all identifiers, or a selected
- -- component whose selector is an operator symbol. As a side effect if
- -- result is True, sets Num_Names to the number of names present
+ -- component whose selector is an operator symbol. As a side effect
+ -- if result is True, sets Num_Names to the number of names present
-- (identifiers, and operator if any).
---------------------------
Arg := Get_Pragma_Arg (Arg1);
Val := Is_True (Static_Boolean (Arg));
- -- Zero argument. In this case the expression is considered to
- -- be True.
+ -- No arguments (expression is considered to be True)
else
Val := True;
Record_Rep_Item (Ent, N);
Set_Uses_Lock_Free (Ent, Val);
- -- Anything else is incorrect
+ -- Anything else is incorrect placement
else
Pragma_Misplaced;
range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
LP_Val : LP_Range;
LP : Character;
+
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
LP_Val := Chars (Get_Pragma_Arg (Arg1));
case LP_Val is
- when Name_Ceiling_Locking => LP := 'C';
- when Name_Inheritance_Locking => LP := 'I';
- when Name_Concurrent_Readers_Locking => LP := 'R';
+ when Name_Ceiling_Locking =>
+ LP := 'C';
+ when Name_Inheritance_Locking =>
+ LP := 'I';
+ when Name_Concurrent_Readers_Locking =>
+ LP := 'R';
end case;
if Locking_Policy /= ' '
Check_Restriction (No_Relative_Delay, N);
end if;
- -- Issue an error for a call to an eliminated subprogram.
- -- The routine will not perform the check if the call appears within
- -- a default expression.
+ -- Issue an error for a call to an eliminated subprogram. This routine
+ -- will not perform the check if the call appears within a default
+ -- expression.
Check_For_Eliminated_Subprogram (Subp, Nam);
projects / gcc.git / commitdiff