+2004-05-27 Vincent Celier <celier@gnat.com>
+
+ * vms_data.ads: Add new GNAT PRETTY qualifiers /NO_BACKUP and
+ COMMENTS_LAYOUT=UNTOUCHED
+
+ * symbols-vms.adb, symbols-vms-alpha.adb: Renamed symbols-vms.adb to
+ symbols-vms-alpha.adb
+
+2004-05-27 Thomas Quinot <quinot@act-europe.fr>
+
+ * sem.ads: Clarify documentation on checks suppression.
+
+ * einfo.ads (Is_Known_Non_Null): Minor comment typo fix and rephrasing.
+
+2004-05-27 Ed Schonberg <schonberg@gnat.com>
+
+ * sem_util.adb (Is_Descendent_Of): Examine properly all ancestors in
+ the case of multiple derivations.
+ (Is_Object_Reference): For a selected component, verify that the prefix
+ is itself an object and not a value.
+
+ * sem_ch12.adb (Same_Instantiated_Constant): New name for
+ Same_Instantiated_Entity.
+ (Same_Instantiated_Variable): Subsidiary to
+ Check_Formal_Package_Instance, to recognize actuals for in-out generic
+ formals that are obtained from a previous formal package.
+ (Instantiate_Subprogram_Body): Emit proper error when
+ generating code and the proper body of a stub is missing.
+
+ * sem_ch4.adb (Remove_Address_Interpretations): If the operation still
+ has a universal interpretation, do the disambiguation here.
+
+ * exp_ch4.adb (Expand_N_Type_Conversion,
+ Expand_N_Unchecked_Type_Conversion): Special handling when target type
+ is Address, to avoid typing anomalies when Address is a visible integer
+ type.
+
+ * exp_ch6.adb (Expand_N_Subprogram_Body): Use Is_Descendent_Of_Address
+ to determine whether a subprogram should not be marked Pure, even when
+ declared in a pure package.
+
+2004-05-27 Jose Ruiz <ruiz@act-europe.fr>
+
+ * gnat_ugn.texi: Replace pragma Ravenscar by pragma Profile.
+
+ * gnat_rm.texi: Replace Max_Entry_Queue_Depth by Max_Entry_Queue_Length
+ Document No_Dynamic_Attachment, that supersedes No_Dynamic_Interrupts.
+ Update the documentation about the Ravenscar profile, following the
+ definition found in AI-249.
+
+ * sem_prag.adb: Use FIFO_Within_Priorities and Ceiling_Locking when
+ setting the Profile (Ravenscar). This must be done in addition to
+ setting the required restrictions.
+
+ * rtsfind.ads: Add the set of operations defined in package
+ Ada.Interrupts.
+
+ * exp_ch6.adb: Check whether we are violating the No_Dynamic_Attachment
+ restriction.
+
+2004-05-27 Eric Botcazou <ebotcazou@act-europe.fr>
+
+ lang-specs.h: Always require -c or -S and always redirect to /dev/null
+ if -gnatc or -gnats is passed.
+
+2004-05-27 Hristian Kirtchev <kirtchev@gnat.com>
+
+ * sem_prag.adb (Sig_Flags): A Pragma_Unchecked_Union does not count as
+ a significant reference. Warnings are now properly emitted when a
+ discriminated type is not referenced.
+
+ * lib-xref.adb (Generate_Reference): A deferred constant completion,
+ record representation clause or record type discriminant does not
+ produce a reference to its corresponding entity. Warnings are now
+ properly emitted when deferred constants and record types are not
+ referenced.
+
+2004-05-27 Geert Bosch <bosch@gnat.com>
+
+ * Makefile.in: Use long version of libm routines on ia64 gnu/linux.
+ Fixes ACATS Annex G tests.
+
+2004-05-27 Robert Dewar <dewar@gnat.com>
+
+ * rtsfind.adb (RTU_Loaded): Temporary kludge to get past bug of not
+ handling WITH
+
+2004-05-27 Arnaud Charlet <charlet@act-europe.fr>
+
+ * s-interr.adb (Server_Task): Take into account case of early return
+ from sigwait under e.g. linux.
+
+2004-05-27 Sergey Rybin <rybin@act-europe.fr>
+
+ * gnat_ugn.texi: Add description for the new gnatpp options:
+ -rnb - replace the original source without creating its backup copy
+ -c0 - do not format comments
+
2004-05-24 Geert Bosch <bosch@gnat.com>
* a-numaux-x86.adb (Reduce): Reimplement using an approximation of Pi
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-linux.ads \
+ a-numaux.ads<a-numaux-libc-x86.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-osinte.ads<s-osinte-linux.ads \
-- Present in all entities. Relevant (and can be set True) only for
-- objects of an access type. It is set if the object is currently
-- known to have a non-null value (meaning that no access checks
--- are needed). The indication can for example3 come from assignment
+-- are needed). The indication can for example come from assignment
-- of an access parameter or an allocator.
--
-- Note: this flag is set according to the sequential flow of the
-- program, watching the current value of the variable. However,
--- this processing can cases of changing the value of an aliased
+-- this processing can miss cases of changing the value of an aliased
-- or constant object, so even if this flag is set, it should not
-- be believed if the variable is aliased or volatile. It would
-- be a little neater to avoid the flag being set in the first
-- Reset overflow flag, since the range check will include
-- dealing with possible overflow, and generate the check
+ -- If Address is either source or target type, suppress
+ -- range check to avoid typing anomalies when it is a visible
+ -- integer type.
Set_Do_Overflow_Check (N, False);
- Generate_Range_Check
- (Expr, Target_Type, CE_Range_Check_Failed);
+ if not Is_Descendent_Of_Address (Etype (Expr))
+ and then not Is_Descendent_Of_Address (Target_Type)
+ then
+ Generate_Range_Check
+ (Expr, Target_Type, CE_Range_Check_Failed);
+ end if;
end if;
end;
end if;
Val <= Expr_Value (Type_High_Bound (Target_Type))
then
Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
- Analyze_And_Resolve (N, Target_Type);
+
+ -- If Address is the target type, just set the type
+ -- to avoid a spurious type error on the literal when
+ -- Address is a visible integer type.
+
+ if Is_Descendent_Of_Address (Target_Type) then
+ Set_Etype (N, Target_Type);
+ else
+ Analyze_And_Resolve (N, Target_Type);
+ end if;
+
return;
end if;
end;
Subp := Parent_Subp;
end if;
+ -- Check for violation of No_Abort_Statements
+
if Is_RTE (Subp, RE_Abort_Task) then
Check_Restriction (No_Abort_Statements, N);
+
+ -- Check for violation of No_Dynamic_Attachment
+
+ elsif RTU_Loaded (Ada_Interrupts)
+ and then (Is_RTE (Subp, RE_Is_Reserved) or else
+ Is_RTE (Subp, RE_Is_Attached) or else
+ Is_RTE (Subp, RE_Current_Handler) or else
+ Is_RTE (Subp, RE_Attach_Handler) or else
+ Is_RTE (Subp, RE_Exchange_Handler) or else
+ Is_RTE (Subp, RE_Detach_Handler) or else
+ Is_RTE (Subp, RE_Reference))
+ then
+ Check_Restriction (No_Dynamic_Attachment, N);
end if;
+ -- Deal with case where call is an explicit dereference
+
if Nkind (Name (N)) = N_Explicit_Dereference then
-- Handle case of access to protected subprogram type
begin
while Present (F) loop
- if Is_RTE (Root_Type (Etype (F)), RE_Address) then
+ if Is_Descendent_Of_Address (Etype (F)) then
Set_Is_Pure (Spec_Id, False);
if Spec_Id /= Body_Id then
* Pragma Obsolescent::
* Pragma Passive::
* Pragma Polling::
+* Pragma Profile (Ravenscar)::
* Pragma Propagate_Exceptions::
* Pragma Psect_Object::
* Pragma Pure_Function::
-* Pragma Ravenscar::
* Pragma Restricted_Run_Time::
* Pragma Restriction_Warnings::
* Pragma Source_File_Name::
* Pragma Obsolescent::
* Pragma Passive::
* Pragma Polling::
+* Pragma Profile (Ravenscar)::
* Pragma Propagate_Exceptions::
* Pragma Psect_Object::
* Pragma Pure_Function::
-* Pragma Ravenscar::
* Pragma Restricted_Run_Time::
* Pragma Restriction_Warnings::
* Pragma Source_File_Name::
Note that polling can also be enabled by use of the @code{-gnatP} switch. See
the @cite{GNAT User's Guide} for details.
+@node Pragma Profile (Ravenscar)
+@unnumberedsec Pragma Profile (Ravenscar)
+@findex Ravenscar
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Profile (Ravenscar);
+@end smallexample
+
+@noindent
+A configuration pragma that establishes the following set of configuration
+pragmas:
+
+@table @code
+@item Task_Dispatching_Policy (FIFO_Within_Priorities)
+[RM D.2.2] Tasks are dispatched following a preemptive
+priority-ordered scheduling policy.
+
+@item Locking_Policy (Ceiling_Locking)
+[RM D.3] While tasks and interrupts execute a protected action, they inherit
+the ceiling priority of the corresponding protected object.
+@c
+@c @item Detect_Blocking
+@c This pragma forces the detection of potentially blocking operations within a
+@c protected operation, and to raise Program_Error if that happens.
+@end table
+@noindent
+
+plus the following set of restrictions:
+
+@table @code
+@item Max_Entry_Queue_Length = 1
+Defines the maximum number of calls that are queued on a (protected) entry.
+Note that this restrictions is checked at run time. Violation of this
+restriction results in the raising of Program_Error exception at the point of
+the call. For the Profile (Ravenscar) the value of Max_Entry_Queue_Length is
+always 1 and hence no task can be queued on a protected entry.
+
+@item Max_Protected_Entries = 1
+[RM D.7] Specifies the maximum number of entries per protected type. The
+bounds of every entry family of a protected unit shall be static, or shall be
+defined by a discriminant of a subtype whose corresponding bound is static.
+For the Profile (Ravenscar) the value of Max_Protected_Entries is always 1.
+
+@item Max_Task_Entries = 0
+[RM D.7] Specifies the maximum number of entries
+per task. The bounds of every entry family
+of a task unit shall be static, or shall be
+defined by a discriminant of a subtype whose
+corresponding bound is static. A value of zero
+indicates that no rendezvous are possible. For
+the Profile (Ravenscar), the value of Max_Task_Entries is always
+0 (zero).
+
+@item No_Abort_Statements
+[RM D.7] There are no abort_statements, and there are
+no calls to Task_Identification.Abort_Task.
+
+@item No_Asynchronous_Control
+[RM D.7] There are no semantic dependences on the package
+Asynchronous_Task_Control.
+
+@item No_Calendar
+There are no semantic dependencies on the package Ada.Calendar.
+
+@item No_Dynamic_Attachment
+There is no call to any of the operations defined in package Ada.Interrupts
+(Is_Reserved, Is_Attached, Current_Handler, Attach_Handler, Exchange_Handler,
+Detach_Handler, and Reference).
+
+@item No_Dynamic_Priorities
+[RM D.7] There are no semantic dependencies on the package Dynamic_Priorities.
+
+@item No_Implicit_Heap_Allocations
+[RM D.7] No constructs are allowed to cause implicit heap allocation.
+
+@item No_Local_Protected_Objects
+Protected objects and access types that designate
+such objects shall be declared only at library level.
+
+@item No_Protected_Type_Allocators
+There are no allocators for protected types or
+types containing protected subcomponents.
+
+@item No_Relative_Delay
+There are no delay_relative statements.
+
+@item No_Requeue_Statements
+Requeue statements are not allowed.
+
+@item No_Select_Statements
+There are no select_statements.
+
+@item No_Task_Allocators
+[RM D.7] There are no allocators for task types
+or types containing task subcomponents.
+
+@item No_Task_Attributes_Package
+There are no semantic dependencies on the Ada.Task_Attributes package.
+
+@item No_Task_Hierarchy
+[RM D.7] All (non-environment) tasks depend
+directly on the environment task of the partition.
+
+@item No_Task_Termination
+Tasks which terminate are erroneous.
+
+@item Simple_Barriers
+Entry barrier condition expressions shall be either static
+boolean expressions or boolean objects which are declared in
+the protected type which contains the entry.
+@end table
+
+@noindent
+This set of configuration pragmas and restrictions correspond to the
+definition of the ``Ravenscar Profile'' for limited tasking, devised and
+published by the @cite{International Real-Time Ada Workshop}, 1997,
+and whose most recent description is available at
+@url{ftp://ftp.openravenscar.org/openravenscar/ravenscar00.pdf}.
+
+The original definition of the profile was revised at subsequent IRTAW
+meetings. It has been included in the ISO
+@cite{Guide for the Use of the Ada Programming Language in High
+Integrity Systems}, and has been approved by ISO/IEC/SC22/WG9 for inclusion in
+the next revision of the standard. The formal definition given by
+the Ada Rapporteur Group (ARG) can be found in two Ada Issues (AI-249 and
+AI-305) available at
+@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00249.TXT} and
+@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00305.TXT}
+respectively.
+
+The above set is a superset of the restrictions provided by pragma
+@code{Restricted_Run_Time}, it includes six additional restrictions
+(@code{Simple_Barriers}, @code{No_Select_Statements},
+@code{No_Calendar}, @code{No_Implicit_Heap_Allocations},
+@code{No_Relative_Delay} and @code{No_Task_Termination}). This means
+that pragma @code{Profile (Ravenscar)}, like the pragma
+@code{Restricted_Run_Time}, automatically causes the use of a simplified,
+more efficient version of the tasking run-time system.
+
@node Pragma Propagate_Exceptions
@unnumberedsec Pragma Propagate_Exceptions
@findex Propagate_Exceptions
disambiguate cases of overloading where some but not all functions
in a set of overloaded functions are to be designated as pure.
-@node Pragma Ravenscar
-@unnumberedsec Pragma Ravenscar
-@findex Ravenscar
-@noindent
-Syntax:
-
-@smallexample @c ada
-pragma Ravenscar;
-@end smallexample
-
-@noindent
-A configuration pragma that establishes the following set of restrictions:
-
-@table @code
-@item No_Abort_Statements
-[RM D.7] There are no abort_statements, and there are
-no calls to Task_Identification.Abort_Task.
-
-@item No_Select_Statements
-There are no select_statements.
-
-@item No_Task_Hierarchy
-[RM D.7] All (non-environment) tasks depend
-directly on the environment task of the partition.
-
-@item No_Task_Allocators
-[RM D.7] There are no allocators for task types
-or types containing task subcomponents.
-
-@item No_Dynamic_Priorities
-[RM D.7] There are no semantic dependencies on the package Dynamic_Priorities.
-
-@item No_Terminate_Alternatives
-[RM D.7] There are no selective_accepts with terminate_alternatives
-
-@item No_Dynamic_Interrupts
-There are no semantic dependencies on Ada.Interrupts.
-
-@item No_Implicit_Heap_Allocations
-[RM D.7] No constructs are allowed to cause implicit heap allocation
-
-@item No_Protected_Type_Allocators
-There are no allocators for protected types or
-types containing protected subcomponents.
-
-@item No_Local_Protected_Objects
-Protected objects and access types that designate
-such objects shall be declared only at library level.
-
-@item No_Requeue_Statements
-Requeue statements are not allowed.
-
-@item No_Calendar
-There are no semantic dependencies on the package Ada.Calendar.
-
-@item No_Relative_Delay
-There are no delay_relative_statements.
-
-@item No_Task_Attributes_Package
-There are no semantic dependencies on the Ada.Task_Attributes package.
-
-@item Simple_Barriers
-Entry barrier condition expressions shall be either static
-boolean expressions or boolean objects which are declared in
-the protected type which contains the entry.
-
-@item Max_Asynchronous_Select_Nesting = 0
-[RM D.7] Specifies the maximum dynamic nesting level of asynchronous_selects.
-A value of zero prevents the use of any asynchronous_select.
-
-@item Max_Task_Entries = 0
-[RM D.7] Specifies the maximum number of entries
-per task. The bounds of every entry family
-of a task unit shall be static, or shall be
-defined by a discriminant of a subtype whose
-corresponding bound is static. A value of zero
-indicates that no rendezvous are possible. For
-the Ravenscar pragma, the value of Max_Task_Entries is always
-0 (zero).
-
-@item Max_Protected_Entries = 1
-[RM D.7] Specifies the maximum number of entries per
-protected type. The bounds of every entry family of
-a protected unit shall be static, or shall be defined
-by a discriminant of a subtype whose corresponding
-bound is static. For the Ravenscar pragma the value of
-Max_Protected_Entries is always 1.
-
-@item Max_Select_Alternatives = 0
-[RM D.7] Specifies the maximum number of alternatives in a selective_accept.
-For the Ravenscar pragma the value is always 0.
-
-@item No_Task_Termination
-Tasks which terminate are erroneous.
-
-@item No_Entry_Queue
-No task can be queued on a protected entry. Note that this restrictions is
-checked at run time. The violation of this restriction generates a
-Program_Error exception.
-@end table
-
-@noindent
-This set of restrictions corresponds to the definition of the ``Ravenscar
-Profile'' for limited tasking, devised and published by the
-@cite{International Real-Time Ada Workshop}, 1997,
-and whose most recent description is available at
-@url{ftp://ftp.openravenscar.org/openravenscar/ravenscar00.pdf}.
-
-The above set is a superset of the restrictions provided by pragma
-@code{Restricted_Run_Time}, it includes five additional restrictions
-(@code{Simple_Barriers}, @code{No_Select_Statements},
-@code{No_Calendar},
-@code{No_Relative_Delay} and @code{No_Task_Termination}). This means
-that pragma @code{Ravenscar}, like the pragma @code{Restricted_Run_Time},
-automatically causes the use of a simplified, more efficient version
-of the tasking run-time system.
-
@node Pragma Restricted_Run_Time
@unnumberedsec Pragma Restricted_Run_Time
@findex Restricted_Run_Time
@item No_Task_Allocators
@item No_Dynamic_Priorities
@item No_Terminate_Alternatives
-@item No_Dynamic_Interrupts
+@item No_Dynamic_Attachment
@item No_Protected_Type_Allocators
@item No_Local_Protected_Objects
@item No_Requeue_Statements
@end cartouche
GNAT currently takes advantage of these restrictions by providing an optimized
run time when the Ravenscar profile and the GNAT restricted run time set
-of restrictions are specified. See pragma @code{Ravenscar} and pragma
-@code{Restricted_Run_Time} for more details.
+of restrictions are specified. See pragma @code{Profile (Ravenscar)} and
+pragma @code{Restricted_Run_Time} for more details.
@cindex Time, monotonic
@unnumberedsec D.8(47-49): Monotonic Time
references to simple boolean variables defined in the private part of the
protected type. No other form of entry barriers is permitted. This is one
of the restrictions of the Ravenscar profile for limited tasking (see also
-pragma @code{Ravenscar}).
+pragma @code{Profile (Ravenscar)}).
-@item Max_Entry_Queue_Depth => Expr
-@findex Max_Entry_Queue_Depth
+@item Max_Entry_Queue_Length => Expr
+@findex Max_Entry_Queue_Length
This restriction is a declaration that any protected entry compiled in
the scope of the restriction has at most the specified number of
tasks waiting on the entry
where the certification protocol requires the use of short-circuit
(and then, or else) forms for all composite boolean operations.
-@item No_Dynamic_Interrupts
-@findex No_Dynamic_Interrupts
-This restriction ensures at compile time that there is no attempt to
-dynamically associate interrupts. Only static association is allowed.
+@item No_Dynamic_Attachment
+@findex No_Dynamic_Attachment
+This restriction ensures that there is no call to any of the operations
+defined in package Ada.Interrupts.
@item No_Enumeration_Maps
@findex No_Enumeration_Maps
This restriction ensures at compile time no select statements of any kind
are permitted, that is the keyword @code{select} may not appear.
This is one of the restrictions of the Ravenscar
-profile for limited tasking (see also pragma @code{Ravenscar}).
+profile for limited tasking (see also pragma @code{Profile (Ravenscar)}).
@item No_Standard_Storage_Pools
@findex No_Standard_Storage_Pools
Long_Float
Normalize_Scalars
Polling
+ Profile
Propagate_Exceptions
Queuing_Policy
- Ravenscar
Restricted_Run_Time
Restrictions
Reviewable
@table @option
@cindex @option{^-c@var{n}^/COMMENTS_LAYOUT^} (@command{gnatpp})
+@item ^-c0^/COMMENTS_LAYOUT=UNTOUCHED^
+All the comments remain unchanged
+
@item ^-c1^/COMMENTS_LAYOUT=DEFAULT^
GNAT-style comment line indentation (this is the default).
@noindent
The @option{-c1} and @option{-c2} switches are incompatible.
The @option{-c3} and @option{-c4} switches are compatible with each other and
-also with @option{-c1} and @option{-c2}.
+also with @option{-c1} and @option{-c2}. The @option{-c0} switch disables all
+the other comment formatting switches.
The @option{-l1}, @option{-l2}, and @option{-l3} switches are incompatible.
@end ifclear
@cindex @option{^-rf^/OVERRIDING_REPLACE^} (@code{gnatpp})
Like @option{^-r^/REPLACE^} except that if the file with the specified name
already exists, it is overwritten.
+
+@item ^-rnb^/NO_BACKUP^
+@cindex @option{^-rnb^/NO_BACKUP^} (@code{gnatpp})
+Replace the input source file with the reformatted output without
+creating any backup copy of the input source.
@end table
@noindent
{"@ada",
"\
%{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\
- %{!gnatc*:%{!gnats*:%{!S:%{!c:\
- %eone of -c, -S, -gnatc or -gnats is required for Ada}}}}\
+ %{!S:%{!c:%e-c or -S required for Ada}}\
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
%{nostdlib*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \
%i %{S:%W{o*}%{!o*:-o %b.s}} \
- %{!S:%{gnatc*|gnats*: -o %j}} \
+ %{gnatc*|gnats*: -o %j} \
%{!gnatc*:%{!gnats*:%(invoke_as)}}", 0, 0, 0},
then
null;
+ -- Constant completion does not count as a reference
+
+ elsif Typ = 'c'
+ and then Ekind (E) = E_Constant
+ then
+ null;
+
+ -- Record representation clause does not count as a reference
+
+ elsif Nkind (N) = N_Identifier
+ and then Nkind (Parent (N)) = N_Record_Representation_Clause
+ then
+ null;
+
+ -- Discriminants do not need to produce a reference to record type
+
+ elsif Typ = 'd'
+ and then Nkind (Parent (N)) = N_Discriminant_Specification
+ then
+ null;
+
-- Any other occurrence counts as referencing the entity
else
Use_Setting : Boolean := False);
-- Load the unit whose Id is given if not already loaded. The unit is
-- loaded, analyzed, and added to the WITH list, and the entry in
- -- RT_Unit_Table is updated to reflect the load. The second parameter
- -- indicates the initial setting for the Is_Potentially_Use_Visible
+ -- RT_Unit_Table is updated to reflect the load. Use_Setting is used
+ -- to indicate the initial setting for the Is_Potentially_Use_Visible
-- flag of the entity for the loaded unit (if it is indeed loaded).
-- A value of False means nothing special need be done. A value of
-- True indicates that this flag must be set to True. It is needed
function RTU_Loaded (U : RTU_Id) return Boolean is
begin
- return Present (RT_Unit_Table (U).Entity);
+ return True and Present (RT_Unit_Table (U).Entity);
+ -- Temp kludge, return True, deals with bug of loading unit with
+ -- WITH not being registered as a proper rtsfind load ???
end RTU_Loaded;
--------------------
RE_List_Controller, -- Ada.Finalization.List_Controller
RE_Interrupt_ID, -- Ada.Interrupts
+ RE_Is_Reserved, -- Ada.Interrupts
+ RE_Is_Attached, -- Ada.Interrupts
+ RE_Current_Handler, -- Ada.Interrupts
+ RE_Attach_Handler, -- Ada.Interrupts
+ RE_Exchange_Handler, -- Ada.Interrupts
+ RE_Detach_Handler, -- Ada.Interrupts
+ RE_Reference, -- Ada.Interrupts
RE_Names, -- Ada.Interupts.Names
RE_List_Controller => Ada_Finalization_List_Controller,
RE_Interrupt_ID => Ada_Interrupts,
+ RE_Is_Reserved => Ada_Interrupts,
+ RE_Is_Attached => Ada_Interrupts,
+ RE_Current_Handler => Ada_Interrupts,
+ RE_Attach_Handler => Ada_Interrupts,
+ RE_Exchange_Handler => Ada_Interrupts,
+ RE_Detach_Handler => Ada_Interrupts,
+ RE_Reference => Ada_Interrupts,
RE_Names => Ada_Interrupts_Names,
-- Bind_Interrupt_To_Entry --
-----------------------------
- -- This procedure raises a Program_Error if it tries to
- -- bind an interrupt to which an Entry or a Procedure is
- -- already bound.
+ -- This procedure raises a Program_Error if it tries to bind an
+ -- interrupt to which an Entry or a Procedure is already bound.
procedure Bind_Interrupt_To_Entry
(T : Task_Id;
Int_Ref : System.Address)
is
Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
begin
if Is_Reserved (Interrupt) then
end if;
Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
-
end Bind_Interrupt_To_Entry;
---------------------
end if;
Interrupt_Manager.Detach_Handler (Interrupt, Static);
-
end Detach_Handler;
------------------------------
-- previous handler's binding status (ie. do not care if it is a
-- dynamic or static handler).
- -- This option is needed so that during the finalization of a PO, we
- -- can detach handlers attached through pragma Attach_Handler.
+ -- This option is needed so that during the finalization of a PO,
+ -- we can detach handlers attached through pragma Attach_Handler.
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
Interrupt_Manager.Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static);
-
end Exchange_Handler;
- ----------------
- -- Finalize --
- ----------------
+ --------------
+ -- Finalize --
+ --------------
procedure Finalize (Object : in out Static_Interrupt_Protection) is
begin
-- Has_Interrupt_Or_Attach_Handler --
-------------------------------------
- -- Need comments as to why these always return True
+ -- Need comments as to why these always return True ???
function Has_Interrupt_Or_Attach_Handler
(Object : access Dynamic_Interrupt_Protection) return Boolean
end loop;
return False;
-
end Is_Registered;
-----------------
else
IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
end if;
-
end Unbind_Handler;
--------------------------------
-- status of the current_Handler.
if not Static and then User_Handler (Interrupt).Static then
+
-- Tries to detach a static Interrupt Handler.
-- raise a program error.
if Old_Handler /= null then
Unbind_Handler (Interrupt);
end if;
-
end Unprotected_Detach_Handler;
----------------------------------
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean;
- Restoration : Boolean := False) is
+ Restoration : Boolean := False)
+ is
begin
if User_Entry (Interrupt).T /= Null_Task then
if Old_Handler = null then
Bind_Handler (Interrupt);
end if;
-
end Unprotected_Exchange_Handler;
-- Start of processing for Interrupt_Manager
-- Place Task_Id info in Server_ID array.
if Server_ID (Interrupt) = Null_Task then
+
-- When a new Server_Task is created, it should have its
-- signal mask set to the All_Tasks_Mask.
for J in Interrupt_ID'Range loop
if not Is_Reserved (J) then
if User_Entry (J).T = T then
+
-- The interrupt should no longer be ingnored if
-- it was ever ignored.
end if;
end loop;
- -- Indicate in ATCB that no Interrupt Entries are attached.
+ -- Indicate in ATCB that no Interrupt Entries are attached
T.Interrupt_Entry := False;
end Detach_Interrupt_Entries;
if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task
then
- -- This is the case where the Server_Task is waiting on
- -- "sigwait." Wake it up by sending an
- -- Abort_Task_Interrupt so that the Server_Task waits on
- -- Cond.
+ -- This is the case where the Server_Task is waiting
+ -- on "sigwait." Wake it up by sending an
+ -- Abort_Task_Interrupt so that the Server_Task
+ -- waits on Cond.
POP.Abort_Task (Server_ID (Interrupt));
then
-- No handler is attached. Unmask the Interrupt so that
-- the default action can be carried out.
+
IMOP.Thread_Unblock_Interrupt
(IMNG.Interrupt_ID (Interrupt));
-- since it was being blocked and an Interrupt Hander or
-- an Entry was there. Wake it up and let it change
-- it place of waiting according to its new state.
+
POP.Wakeup (Server_ID (Interrupt),
Interrupt_Server_Blocked_Interrupt_Sleep);
end if;
POP.Write_Lock (Self_ID);
else
- pragma Assert (Ret_Interrupt = Interrupt);
-
if Single_Lock then
POP.Lock_RTS;
end if;
POP.Write_Lock (Self_ID);
- -- Even though we have received an Interrupt the status may
- -- have changed already before we got the Self_ID lock above.
- -- Therefore we make sure a Handler or an Entry is still
- -- there and make appropriate call.
- -- If there is no calls to make we need to regenerate the
- -- Interrupt in order not to lose it.
+ if Ret_Interrupt /= Interrupt then
- if User_Handler (Interrupt).H /= null then
- Tmp_Handler := User_Handler (Interrupt).H;
+ -- On some systems (e.g. recent linux kernels), sigwait
+ -- may return unexpectedly (with errno set to EINTR).
- -- RTS calls should not be made with self being locked.
+ null;
- POP.Unlock (Self_ID);
+ else
+ -- Even though we have received an Interrupt the status may
+ -- have changed already before we got the Self_ID lock above
+ -- Therefore we make sure a Handler or an Entry is still
+ -- there and make appropriate call.
- if Single_Lock then
- POP.Unlock_RTS;
- end if;
+ -- If there is no calls to make we need to regenerate the
+ -- Interrupt in order not to lose it.
- Tmp_Handler.all;
+ if User_Handler (Interrupt).H /= null then
+ Tmp_Handler := User_Handler (Interrupt).H;
- if Single_Lock then
- POP.Lock_RTS;
- end if;
+ -- RTS calls should not be made with self being locked.
- POP.Write_Lock (Self_ID);
+ POP.Unlock (Self_ID);
- elsif User_Entry (Interrupt).T /= Null_Task then
- Tmp_ID := User_Entry (Interrupt).T;
- Tmp_Entry_Index := User_Entry (Interrupt).E;
+ if Single_Lock then
+ POP.Unlock_RTS;
+ end if;
- -- RTS calls should not be made with self being locked.
+ Tmp_Handler.all;
- if Single_Lock then
- POP.Unlock_RTS;
- end if;
+ if Single_Lock then
+ POP.Lock_RTS;
+ end if;
- POP.Unlock (Self_ID);
+ POP.Write_Lock (Self_ID);
- System.Tasking.Rendezvous.Call_Simple
- (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+ elsif User_Entry (Interrupt).T /= Null_Task then
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
- POP.Write_Lock (Self_ID);
+ -- RTS calls should not be made with self being locked.
- if Single_Lock then
- POP.Lock_RTS;
- end if;
+ if Single_Lock then
+ POP.Unlock_RTS;
+ end if;
- else
- -- This is a situation that this task wake up
- -- receiving an Interrupt and before it get the lock
- -- the Interrupt is blocked. We do not
- -- want to lose the interrupt in this case so that
- -- regenerate the Interrupt to process level;
+ POP.Unlock (Self_ID);
+
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
- IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt));
+ POP.Write_Lock (Self_ID);
+
+ if Single_Lock then
+ POP.Lock_RTS;
+ end if;
+
+ else
+ -- This is a situation that this task wakes up receiving
+ -- an Interrupt and before it gets the lock the Interrupt
+ -- is blocked. We do not want to lose the interrupt in
+ -- this case so we regenerate the Interrupt to process
+ -- level.
+
+ IMOP.Interrupt_Self_Process
+ (IMNG.Interrupt_ID (Interrupt));
+ end if;
end if;
end if;
end if;
-- Undefer abort here to allow a window for this task
-- to be aborted at the time of system shutdown.
+
end loop;
end Server_Task;
-- Elaboration code for package System.Interrupts
begin
-
-- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
- -- During the elaboration of this package body we want RTS to
- -- inherit the interrupt mask from the Environment Task.
+ -- During the elaboration of this package body we want the RTS
+ -- to inherit the interrupt mask from the Environment Task.
- -- The Environment Task should have gotten its mask from
+ -- The environment task should have gotten its mask from
-- the enclosing process during the RTS start up. (See
- -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
- -- task to the Interrupt_Manager.
+ -- processing in s-inmaop.adb). Pass the Interrupt_Mask
+ -- of the environment task to the Interrupt_Manager.
-- Note : At this point we know that all tasks (including
-- RTS internal servers) are masked for non-reserved signals
-- (see s-taprop.adb). Only the Interrupt_Manager will have
- -- masks set up differently inheriting the original Environment
- -- Task's mask.
+ -- masks set up differently inheriting the original environment
+ -- task's mask.
Interrupt_Manager.Initialize (IMOP.Environment_Mask);
end System.Interrupts;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- Handling of Check Suppression --
-----------------------------------
- -- There are two kinds of suppress checks, scope based suppress checks
- -- (from initial command line arguments, or from Suppress pragmas not
- -- including an entity name). The scope based suppress checks are recorded
+ -- There are two kinds of suppress checks: scope based suppress checks,
+ -- and entity based suppress checks.
+
+ -- Scope based suppress chems (from initial command line arguments,
+ -- or from Suppress pragmas not including an entity name) are recorded
-- in the Sem.Supress variable, and all that is necessary is to save the
-- state of this variable on scope entry, and restore it on scope exit.
- -- The other kind of suppress check is entity based suppress checks, from
- -- Suppress pragmas giving an Entity_Id. These are handled as follows. If
- -- a suppress or unsuppress pragma is encountered for a given entity, then
- -- the flag Checks_May_Be_Suppressed is set in the entity and an entry is
- -- made in either the Local_Entity_Suppress table (case of pragma that
- -- appears in other than a package spec), or in the Global_Entity_Suppress
- -- table (case of pragma that appears in a package spec, which is by the
- -- rule of RM 11.5(7) applicable throughout the life of the entity).
+ -- Entity based suppress checks, from Suppress pragmas giving an Entity_Id,
+ -- are handled as follows. If a suppress or unsuppress pragma is
+ -- encountered for a given entity, then the flag Checks_May_Be_Suppressed
+ -- is set in the entity and an entry is made in either the
+ -- Local_Entity_Suppress table (case of pragma that appears in other than
+ -- a package spec), or in the Global_Entity_Suppress table (case of pragma
+ -- that appears in a package spec, which is by the rule of RM 11.5(7)
+ -- applicable throughout the life of the entity).
-- If the Checks_May_Be_Suppressed flag is set in an entity then the
-- procedure is to search first the local and then the global suppress
-- Common error routine for mismatch between the parameters of
-- the actual instance and those of the formal package.
- function Same_Instantiated_Entity (E1, E2 : Entity_Id) return Boolean;
+ function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
-- The formal may come from a nested formal package, and the actual
-- may have been constant-folded. To determine whether the two denote
-- the same entity we may have to traverse several definitions to
-- recover the ultimate entity that they refer to.
+ function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
+ -- Similarly, if the formal comes from a nested formal package, the
+ -- actual may designate the formal through multiple renamings, which
+ -- have to be followed to determine the original variable in question.
+
--------------------
-- Check_Mismatch --
--------------------
end if;
end Check_Mismatch;
- ------------------------------
- -- Same_Instantiated_Entity --
- ------------------------------
+ --------------------------------
+ -- Same_Instantiated_Constant --
+ --------------------------------
- function Same_Instantiated_Entity (E1, E2 : Entity_Id) return Boolean is
+ function Same_Instantiated_Constant
+ (E1, E2 : Entity_Id) return Boolean
+ is
Ent : Entity_Id;
-
begin
Ent := E2;
while Present (Ent) loop
end loop;
return False;
- end Same_Instantiated_Entity;
+ end Same_Instantiated_Constant;
+
+ --------------------------------
+ -- Same_Instantiated_Variable --
+ --------------------------------
+
+ function Same_Instantiated_Variable
+ (E1, E2 : Entity_Id) return Boolean
+ is
+ function Original_Entity (E : Entity_Id) return Entity_Id;
+ -- Follow chain of renamings to the ultimate ancestor.
+
+ ---------------------
+ -- Original_Entity --
+ ---------------------
+
+ function Original_Entity (E : Entity_Id) return Entity_Id is
+ Orig : Entity_Id;
+
+ begin
+ Orig := E;
+ while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
+ and then Present (Renamed_Object (Orig))
+ and then Is_Entity_Name (Renamed_Object (Orig))
+ loop
+ Orig := Entity (Renamed_Object (Orig));
+ end loop;
+
+ return Orig;
+ end Original_Entity;
+
+ -- Start of processing for Same_Instantiated_Variable
+
+ begin
+ return Ekind (E1) = Ekind (E2)
+ and then Original_Entity (E1) = Original_Entity (E2);
+ end Same_Instantiated_Variable;
-- Start of processing for Check_Formal_Package_Instance
if Is_Entity_Name (Expr2) then
if Entity (Expr1) = Entity (Expr2) then
null;
-
- elsif
- Same_Instantiated_Entity (Entity (Expr1), Entity (Expr2))
- then
- null;
else
- Check_Mismatch (True);
+ Check_Mismatch
+ (not Same_Instantiated_Constant
+ (Entity (Expr1), Entity (Expr2)));
end if;
else
Check_Mismatch (True);
elsif Is_Entity_Name (Original_Node (Expr1))
and then Is_Entity_Name (Expr2)
and then
- Same_Instantiated_Entity
+ Same_Instantiated_Constant
(Entity (Original_Node (Expr1)), Entity (Expr2))
then
null;
Check_Mismatch (True);
end if;
- elsif Ekind (E1) = E_Variable
- or else Ekind (E1) = E_Package
- then
+ elsif Ekind (E1) = E_Variable then
+ Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
+
+ elsif Ekind (E1) = E_Package then
Check_Mismatch
(Ekind (E1) /= Ekind (E2)
or else Renamed_Object (E1) /= Renamed_Object (E2));
if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
-- Either body is not present, or context is non-expanding, as
- -- when compiling a subunit. Mark the instance as completed.
+ -- when compiling a subunit. Mark the instance as completed, and
+ -- diagnose a missing body when needed.
+
+ if Expander_Active
+ and then Operating_Mode = Generate_Code
+ then
+ Error_Msg_N
+ ("missing proper body for instantiation", Gen_Body);
+ end if;
Set_Has_Completion (Anon_Id);
return;
-- truly hidden.
type Operand_Position is (First_Op, Second_Op);
+ Univ_Type : constant Entity_Id := Universal_Interpretation (N);
procedure Remove_Address_Interpretations (Op : Operand_Position);
-- Ambiguities may arise when the operands are literal and the
Remove_Interp (I);
end if;
+ Get_Next_Interp (I, It);
+ end loop;
+
+ elsif Is_Overloaded (N)
+ and then Present (Univ_Type)
+ then
+ -- If both operands have a universal interpretation,
+ -- select the predefined operator and discard others.
+
+ Get_First_Interp (N, I, It);
+
+ while Present (It.Nam) loop
+ if Scope (It.Nam) = Standard_Standard then
+ Set_Etype (N, Univ_Type);
+ Set_Entity (N, It.Nam);
+ Set_Is_Overloaded (N, False);
+ exit;
+ end if;
+
Get_Next_Interp (I, It);
end loop;
end if;
-- argument has the right form then the Mechanism field of Ent is
-- set appropriately.
+ procedure Set_Ravenscar_Profile (N : Node_Id);
+ -- Activate the set of configuration pragmas and restrictions that
+ -- make up the Ravenscar Profile. N is the corresponding pragma
+ -- node, which is used for error messages on any constructs
+ -- that violate the profile.
+
--------------------------
-- Check_Ada_83_Warning --
--------------------------
Val : Uint;
procedure Set_Warning (R : All_Restrictions);
- -- If this is a Restriction_Warnings pragma, set warning flag,
- -- otherwise flag gets cleared.
+ -- If this is a Restriction_Warnings pragma, set warning flag
-----------------
-- Set_Warning --
procedure Set_Warning (R : All_Restrictions) is
begin
- Restriction_Warnings (R) :=
- Prag_Id = Pragma_Restriction_Warnings;
+ if Prag_Id = Pragma_Restriction_Warnings then
+ Restriction_Warnings (R) := True;
+ end if;
end Set_Warning;
-- Start of processing for Process_Restrictions_Or_Restriction_Warnings
end Set_Mechanism_Value;
+ ---------------------------
+ -- Set_Ravenscar_Profile --
+ ---------------------------
+
+ -- The tasks to be done here are
+
+ -- Set required policies
+
+ -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
+ -- pragma Locking_Policy (Ceiling_Locking)
+
+ -- Set Detect_Blocking mode ???
+
+ -- Set required restrictions (see Restrict.Set_Ravenscar for details)
+
+ procedure Set_Ravenscar_Profile (N : Node_Id) is
+ begin
+ -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
+
+ if Task_Dispatching_Policy /= ' '
+ and then Task_Dispatching_Policy /= 'F'
+ then
+ Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
+ Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
+
+ -- Set the FIFO_Within_Priorities policy, but always
+ -- preserve System_Location since we like the error
+ -- message with the run time name.
+
+ else
+ Task_Dispatching_Policy := 'F';
+
+ if Task_Dispatching_Policy_Sloc /= System_Location then
+ Task_Dispatching_Policy_Sloc := Loc;
+ end if;
+ end if;
+
+ -- pragma Locking_Policy (Ceiling_Locking)
+
+ if Locking_Policy /= ' '
+ and then Locking_Policy /= 'C'
+ then
+ Error_Msg_Sloc := Locking_Policy_Sloc;
+ Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
+
+ -- Set the Ceiling_Locking policy, but always preserve
+ -- System_Location since we like the error message with the
+ -- run time name.
+
+ else
+ Locking_Policy := 'C';
+
+ if Locking_Policy_Sloc /= System_Location then
+ Locking_Policy_Sloc := Loc;
+ end if;
+ end if;
+
+ -- ??? Detect_Blocking
+
+ -- Set the corresponding restrictions
+
+ Set_Ravenscar (N);
+ end Set_Ravenscar_Profile;
+
-- Start of processing for Analyze_Pragma
begin
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
Check_No_Identifiers;
- Set_Ravenscar (N);
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
if Chars (Argx) = Name_Ravenscar then
- Set_Ravenscar (N);
+ Set_Ravenscar_Profile (N);
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- Set_Ravenscar (N);
+ Set_Ravenscar_Profile (N);
-------------------------
-- Restricted_Run_Time --
-- Start of prorcessing for Is_Config_Static_String
begin
+
Name_Len := 0;
return Add_Config_Static_String (Arg);
end Is_Config_Static_String;
-- indicates that appearence in that parameter position is significant.
Sig_Flags : constant array (Pragma_Id) of Int :=
+
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Thread_Body => +2,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
- Pragma_Unchecked_Union => -1,
+ Pragma_Unchecked_Union => 0,
Pragma_Unimplemented_Unit => -1,
Pragma_Universal_Data => -1,
Pragma_Unreferenced => -1,
-- Done if no more derivations to check
- elsif T = T1 then
+ elsif T = T1
+ or else T = Etyp
+ then
return False;
-- Following test catches error cases resulting from prev errors
return False;
end if;
- -- Return if no further entries to check
-
- if T = Base_Type (T1) or else T = T1 then
- return False;
- end if;
+ T := Base_Type (Etyp);
end loop;
end if;
return Attribute_Name (N) = Name_Input;
when N_Selected_Component =>
- return Is_Object_Reference (Selector_Name (N));
+ return
+ Is_Object_Reference (Selector_Name (N))
+ and then Is_Object_Reference (Prefix (N));
when N_Explicit_Dereference =>
return True;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y M B O L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VMS version of this package
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Sequential_IO;
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Symbols is
+
+ Case_Sensitive : constant String := "case_sensitive=";
+ Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
+ Equal_Data : constant String := "=DATA)";
+ Equal_Procedure : constant String := "=PROCEDURE)";
+ Gsmatch : constant String := "gsmatch=equal,";
+
+ Symbol_File_Name : String_Access := null;
+ -- Name of the symbol file
+
+ Sym_Policy : Policy := Autonomous;
+ -- The symbol policy. Set by Initialize
+
+ Major_ID : Integer := 1;
+ -- The Major ID. May be modified by Initialize if Library_Version is
+ -- specified or if it is read from the reference symbol file.
+
+ Soft_Major_ID : Boolean := True;
+ -- False if library version is specified in procedure Initialize.
+ -- When True, Major_ID may be modified if found in the reference symbol
+ -- file.
+
+ Minor_ID : Natural := 0;
+ -- The Minor ID. May be modified if read from the reference symbol file
+
+ Soft_Minor_ID : Boolean := True;
+ -- False if symbol policy is Autonomous, if library version is specified
+ -- in procedure Initialize and is not the same as the major ID read from
+ -- the reference symbol file. When True, Minor_ID may be increased in
+ -- Compliant symbol policy.
+
+ subtype Byte is Character;
+ -- Object files are stream of bytes, but some of these bytes, those for
+ -- the names of the symbols, are ASCII characters.
+
+ package Byte_IO is new Ada.Sequential_IO (Byte);
+ use Byte_IO;
+
+ type Number is mod 2**16;
+ -- 16 bits unsigned number for number of characters
+
+ GSD : constant Number := 10;
+ -- Code for the Global Symbol Definition section
+
+ C_SYM : constant Number := 1;
+ -- Code for a Symbol subsection
+
+ V_DEF_Mask : constant Number := 2**1;
+ V_NORM_Mask : constant Number := 2**6;
+
+ File : Byte_IO.File_Type;
+ -- Each object file is read as a stream of bytes (characters)
+
+ B : Byte;
+
+ Number_Of_Characters : Natural := 0;
+ -- The number of characters of each section
+
+ -- The following variables are used by procedure Process when reading an
+ -- object file.
+
+ Code : Number := 0;
+ Length : Natural := 0;
+
+ Dummy : Number;
+
+ Nchars : Natural := 0;
+ Flags : Number := 0;
+
+ Symbol : String (1 .. 255);
+ LSymb : Natural;
+
+ function Equal (Left, Right : Symbol_Data) return Boolean;
+ -- Test for equality of symbols
+
+ procedure Get (N : out Number);
+ -- Read two bytes from the object file LSB first as unsigned 16 bit number
+
+ procedure Get (N : out Natural);
+ -- Read two bytes from the object file, LSByte first, as a Natural
+
+
+ function Image (N : Integer) return String;
+ -- Returns the image of N, without the initial space
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (Left, Right : Symbol_Data) return Boolean is
+ begin
+ return Left.Name /= null and then
+ Right.Name /= null and then
+ Left.Name.all = Right.Name.all and then
+ Left.Kind = Right.Kind and then
+ Left.Present = Right.Present;
+ end Equal;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get (N : out Number) is
+ C : Byte;
+ LSByte : Number;
+ begin
+ Read (File, C);
+ LSByte := Byte'Pos (C);
+ Read (File, C);
+ N := LSByte + (256 * Byte'Pos (C));
+ end Get;
+
+ procedure Get (N : out Natural) is
+ Result : Number;
+ begin
+ Get (Result);
+ N := Natural (Result);
+ end Get;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (N : Integer) return String is
+ Result : constant String := N'Img;
+ begin
+ if Result (Result'First) = ' ' then
+ return Result (Result'First + 1 .. Result'Last);
+
+ else
+ return Result;
+ end if;
+ end Image;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Symbol_File : String;
+ Reference : String;
+ Symbol_Policy : Policy;
+ Quiet : Boolean;
+ Version : String;
+ Success : out Boolean)
+ is
+ File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 1_000);
+ Last : Natural;
+
+ begin
+ -- Record the symbol file name
+
+ Symbol_File_Name := new String'(Symbol_File);
+
+ -- Record the policy
+
+ Sym_Policy := Symbol_Policy;
+
+ -- Record the version (Major ID)
+
+ if Version = "" then
+ Major_ID := 1;
+ Soft_Major_ID := True;
+
+ else
+ begin
+ Major_ID := Integer'Value (Version);
+ Soft_Major_ID := False;
+
+ if Major_ID <= 0 then
+ raise Constraint_Error;
+ end if;
+
+ exception
+ when Constraint_Error =>
+ if not Quiet then
+ Put_Line ("Version """ & Version & """ is illegal.");
+ Put_Line ("On VMS, version must be a positive number");
+ end if;
+
+ Success := False;
+ return;
+ end;
+ end if;
+
+ Minor_ID := 0;
+ Soft_Minor_ID := Sym_Policy /= Autonomous;
+
+ -- Empty the symbol tables
+
+ Symbol_Table.Set_Last (Original_Symbols, 0);
+ Symbol_Table.Set_Last (Complete_Symbols, 0);
+
+ -- Assume that everything will be fine
+
+ Success := True;
+
+ -- If policy is not autonomous, attempt to read the reference file
+
+ if Sym_Policy /= Autonomous then
+ begin
+ Open (File, In_File, Reference);
+
+ exception
+ when Ada.Text_IO.Name_Error =>
+ return;
+
+ when X : others =>
+ if not Quiet then
+ Put_Line ("could not open """ & Reference & """");
+ Put_Line (Exception_Message (X));
+ end if;
+
+ Success := False;
+ return;
+ end;
+
+ -- Read line by line
+
+ while not End_Of_File (File) loop
+ Get_Line (File, Line, Last);
+
+ -- Ignore empty lines
+
+ if Last = 0 then
+ null;
+
+ -- Ignore lines starting with "case_sensitive="
+
+ elsif Last > Case_Sensitive'Length
+ and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
+ then
+ null;
+
+ -- Line starting with "SYMBOL_VECTOR=("
+
+ elsif Last > Symbol_Vector'Length
+ and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
+ then
+
+ -- SYMBOL_VECTOR=(<symbol>=DATA)
+
+ if Last > Symbol_Vector'Length + Equal_Data'Length and then
+ Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
+ then
+ Symbol_Table.Increment_Last (Original_Symbols);
+ Original_Symbols.Table
+ (Symbol_Table.Last (Original_Symbols)) :=
+ (Name =>
+ new String'(Line (Symbol_Vector'Length + 1 ..
+ Last - Equal_Data'Length)),
+ Kind => Data,
+ Present => True);
+
+ -- SYMBOL_VECTOR=(<symbol>=PROCEDURE)
+
+ elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
+ and then
+ Line (Last - Equal_Procedure'Length + 1 .. Last) =
+ Equal_Procedure
+ then
+ Symbol_Table.Increment_Last (Original_Symbols);
+ Original_Symbols.Table
+ (Symbol_Table.Last (Original_Symbols)) :=
+ (Name =>
+ new String'(Line (Symbol_Vector'Length + 1 ..
+ Last - Equal_Procedure'Length)),
+ Kind => Proc,
+ Present => True);
+
+ -- Anything else is incorrectly formatted
+
+ else
+ if not Quiet then
+ Put_Line ("symbol file """ & Reference &
+ """ is incorrectly formatted:");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+
+ -- Lines with "gsmatch=equal,<Major_ID>,<Minor_Id>
+
+ elsif Last > Gsmatch'Length
+ and then Line (1 .. Gsmatch'Length) = Gsmatch
+ then
+ declare
+ Start : Positive := Gsmatch'Length + 1;
+ Finish : Positive := Start;
+ OK : Boolean := True;
+ ID : Integer;
+
+ begin
+ loop
+ if Line (Finish) not in '0' .. '9'
+ or else Finish >= Last - 1
+ then
+ OK := False;
+ exit;
+ end if;
+
+ exit when Line (Finish + 1) = ',';
+
+ Finish := Finish + 1;
+ end loop;
+
+ if OK then
+ ID := Integer'Value (Line (Start .. Finish));
+ OK := ID /= 0;
+
+ -- If Soft_Major_ID is True, it means that
+ -- Library_Version was not specified.
+
+ if Soft_Major_ID then
+ Major_ID := ID;
+
+ -- If the Major ID in the reference file is different
+ -- from the Library_Version, then the Minor ID will be 0
+ -- because there is no point in taking the Minor ID in
+ -- the reference file, or incrementing it. So, we set
+ -- Soft_Minor_ID to False, so that we don't modify
+ -- the Minor_ID later.
+
+ elsif Major_ID /= ID then
+ Soft_Minor_ID := False;
+ end if;
+
+ Start := Finish + 2;
+ Finish := Start;
+
+ loop
+ if Line (Finish) not in '0' .. '9' then
+ OK := False;
+ exit;
+ end if;
+
+ exit when Finish = Last;
+
+ Finish := Finish + 1;
+ end loop;
+
+ -- Only set Minor_ID if Soft_Minor_ID is True (see above)
+
+ if OK and then Soft_Minor_ID then
+ Minor_ID := Integer'Value (Line (Start .. Finish));
+ end if;
+ end if;
+
+ -- If OK is not True, that means the line is not correctly
+ -- formatted.
+
+ if not OK then
+ if not Quiet then
+ Put_Line ("symbol file """ & Reference &
+ """ is incorrectly formatted");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+ end;
+
+ -- Anything else is incorrectly formatted
+
+ else
+ if not Quiet then
+ Put_Line ("unexpected line in symbol file """ &
+ Reference & """");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+ end loop;
+
+ Close (File);
+ end if;
+ end Initialize;
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process
+ (Object_File : String;
+ Success : out Boolean)
+ is
+ begin
+ -- Open the object file with Byte_IO. Return with Success = False if
+ -- this fails.
+
+ begin
+ Open (File, In_File, Object_File);
+ exception
+ when others =>
+ Put_Line
+ ("*** Unable to open object file """ & Object_File & """");
+ Success := False;
+ return;
+ end;
+
+ -- Assume that the object file has a correct format
+
+ Success := True;
+
+ -- Get the different sections one by one from the object file
+
+ while not End_Of_File (File) loop
+
+ Get (Code);
+ Get (Number_Of_Characters);
+ Number_Of_Characters := Number_Of_Characters - 4;
+
+ -- If this is not a Global Symbol Definition section, skip to the
+ -- next section.
+
+ if Code /= GSD then
+
+ for J in 1 .. Number_Of_Characters loop
+ Read (File, B);
+ end loop;
+
+ else
+
+ -- Skip over the next 4 bytes
+
+ Get (Dummy);
+ Get (Dummy);
+ Number_Of_Characters := Number_Of_Characters - 4;
+
+ -- Get each subsection in turn
+
+ loop
+ Get (Code);
+ Get (Nchars);
+ Get (Dummy);
+ Get (Flags);
+ Number_Of_Characters := Number_Of_Characters - 8;
+ Nchars := Nchars - 8;
+
+ -- If this is a symbol and the V_DEF flag is set, get the
+ -- symbol.
+
+ if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then
+ -- First, reach the symbol length
+
+ for J in 1 .. 25 loop
+ Read (File, B);
+ Nchars := Nchars - 1;
+ Number_Of_Characters := Number_Of_Characters - 1;
+ end loop;
+
+ Length := Byte'Pos (B);
+ LSymb := 0;
+
+ -- Get the symbol characters
+
+ for J in 1 .. Nchars loop
+ Read (File, B);
+ Number_Of_Characters := Number_Of_Characters - 1;
+ if Length > 0 then
+ LSymb := LSymb + 1;
+ Symbol (LSymb) := B;
+ Length := Length - 1;
+ end if;
+ end loop;
+
+ -- Create the new Symbol
+
+ declare
+ S_Data : Symbol_Data;
+ begin
+ S_Data.Name := new String'(Symbol (1 .. LSymb));
+
+ -- The symbol kind (Data or Procedure) depends on the
+ -- V_NORM flag.
+
+ if (Flags and V_NORM_Mask) = 0 then
+ S_Data.Kind := Data;
+
+ else
+ S_Data.Kind := Proc;
+ end if;
+
+ -- Put the new symbol in the table
+
+ Symbol_Table.Increment_Last (Complete_Symbols);
+ Complete_Symbols.Table
+ (Symbol_Table.Last (Complete_Symbols)) := S_Data;
+ end;
+
+ else
+ -- As it is not a symbol subsection, skip to the next
+ -- subsection.
+
+ for J in 1 .. Nchars loop
+ Read (File, B);
+ Number_Of_Characters := Number_Of_Characters - 1;
+ end loop;
+ end if;
+
+ -- Exit the GSD section when number of characters reaches 0
+
+ exit when Number_Of_Characters = 0;
+ end loop;
+ end if;
+ end loop;
+
+ -- The object file has been processed, close it
+
+ Close (File);
+
+ exception
+ -- For any exception, output an error message, close the object file
+ -- and return with Success = False.
+
+ when X : others =>
+ Put_Line ("unexpected exception raised while processing """
+ & Object_File & """");
+ Put_Line (Exception_Information (X));
+ Close (File);
+ Success := False;
+ end Process;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize
+ (Quiet : Boolean;
+ Success : out Boolean)
+ is
+ File : Ada.Text_IO.File_Type;
+ -- The symbol file
+
+ S_Data : Symbol_Data;
+ -- A symbol
+
+ Cur : Positive := 1;
+ -- Most probable index in the Complete_Symbols of the current symbol
+ -- in Original_Symbol.
+
+ Found : Boolean;
+
+ begin
+ -- Nothing to be done if Initialize has never been called
+
+ if Symbol_File_Name = null then
+ Success := False;
+
+ else
+
+ -- First find if the symbols in the reference symbol file are also
+ -- in the object files. Note that this is not done if the policy is
+ -- Autonomous, because no reference symbol file has been read.
+
+ -- Expect the first symbol in the symbol file to also be the first
+ -- in Complete_Symbols.
+
+ Cur := 1;
+
+ for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop
+ S_Data := Original_Symbols.Table (Index_1);
+ Found := False;
+
+ First_Object_Loop :
+ for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop
+ if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
+ Cur := Index_2 + 1;
+ Complete_Symbols.Table (Index_2).Present := False;
+ Found := True;
+ exit First_Object_Loop;
+ end if;
+ end loop First_Object_Loop;
+
+ -- If the symbol could not be found between Cur and Last, try
+ -- before Cur.
+
+ if not Found then
+ Second_Object_Loop :
+ for Index_2 in 1 .. Cur - 1 loop
+ if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
+ Cur := Index_2 + 1;
+ Complete_Symbols.Table (Index_2).Present := False;
+ Found := True;
+ exit Second_Object_Loop;
+ end if;
+ end loop Second_Object_Loop;
+ end if;
+
+ -- If the symbol is not found, mark it as such in the table
+
+ if not Found then
+ if (not Quiet) or else Sym_Policy = Controlled then
+ Put_Line ("symbol """ & S_Data.Name.all &
+ """ is no longer present in the object files");
+ end if;
+
+ if Sym_Policy = Controlled then
+ Success := False;
+ return;
+
+ elsif Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+
+ Original_Symbols.Table (Index_1).Present := False;
+ Free (Original_Symbols.Table (Index_1).Name);
+
+ if Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+ end if;
+ end loop;
+
+ -- Append additional symbols, if any, to the Original_Symbols table
+
+ for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
+ S_Data := Complete_Symbols.Table (Index);
+
+ if S_Data.Present then
+
+ if Sym_Policy = Controlled then
+ Put_Line ("symbol """ & S_Data.Name.all &
+ """ is not in the reference symbol file");
+ Success := False;
+ return;
+
+ elsif Soft_Minor_ID then
+ Minor_ID := Minor_ID + 1;
+ Soft_Minor_ID := False;
+ end if;
+
+ Symbol_Table.Increment_Last (Original_Symbols);
+ Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) :=
+ S_Data;
+ Complete_Symbols.Table (Index).Present := False;
+ end if;
+ end loop;
+
+ -- Create the symbol file
+
+ Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
+
+ Put (File, Case_Sensitive);
+ Put_Line (File, "yes");
+
+ -- Put a line in the symbol file for each symbol in the symbol table
+
+ for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
+ if Original_Symbols.Table (Index).Present then
+ Put (File, Symbol_Vector);
+ Put (File, Original_Symbols.Table (Index).Name.all);
+
+ if Original_Symbols.Table (Index).Kind = Data then
+ Put_Line (File, Equal_Data);
+
+ else
+ Put_Line (File, Equal_Procedure);
+ end if;
+
+ Free (Original_Symbols.Table (Index).Name);
+ end if;
+ end loop;
+
+ Put (File, Case_Sensitive);
+ Put_Line (File, "NO");
+
+ -- Put the version IDs
+
+ Put (File, Gsmatch);
+ Put (File, Image (Major_ID));
+ Put (File, ',');
+ Put_Line (File, Image (Minor_ID));
+
+ -- And we are done
+
+ Close (File);
+
+ -- Reset both tables
+
+ Symbol_Table.Set_Last (Original_Symbols, 0);
+ Symbol_Table.Set_Last (Complete_Symbols, 0);
+
+ -- Clear the symbol file name
+
+ Free (Symbol_File_Name);
+
+ Success := True;
+ end if;
+
+ exception
+ when X : others =>
+ Put_Line ("unexpected exception raised while finalizing """
+ & Symbol_File_Name.all & """");
+ Put_Line (Exception_Information (X));
+ Success := False;
+ end Finalize;
+
+end Symbols;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y M B O L S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VMS version of this package
-
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Sequential_IO;
-with Ada.Text_IO; use Ada.Text_IO;
-
-package body Symbols is
-
- Case_Sensitive : constant String := "case_sensitive=";
- Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
- Equal_Data : constant String := "=DATA)";
- Equal_Procedure : constant String := "=PROCEDURE)";
- Gsmatch : constant String := "gsmatch=equal,";
-
- Symbol_File_Name : String_Access := null;
- -- Name of the symbol file
-
- Sym_Policy : Policy := Autonomous;
- -- The symbol policy. Set by Initialize
-
- Major_ID : Integer := 1;
- -- The Major ID. May be modified by Initialize if Library_Version is
- -- specified or if it is read from the reference symbol file.
-
- Soft_Major_ID : Boolean := True;
- -- False if library version is specified in procedure Initialize.
- -- When True, Major_ID may be modified if found in the reference symbol
- -- file.
-
- Minor_ID : Natural := 0;
- -- The Minor ID. May be modified if read from the reference symbol file
-
- Soft_Minor_ID : Boolean := True;
- -- False if symbol policy is Autonomous, if library version is specified
- -- in procedure Initialize and is not the same as the major ID read from
- -- the reference symbol file. When True, Minor_ID may be increased in
- -- Compliant symbol policy.
-
- subtype Byte is Character;
- -- Object files are stream of bytes, but some of these bytes, those for
- -- the names of the symbols, are ASCII characters.
-
- package Byte_IO is new Ada.Sequential_IO (Byte);
- use Byte_IO;
-
- type Number is mod 2**16;
- -- 16 bits unsigned number for number of characters
-
- GSD : constant Number := 10;
- -- Code for the Global Symbol Definition section
-
- C_SYM : constant Number := 1;
- -- Code for a Symbol subsection
-
- V_DEF_Mask : constant Number := 2**1;
- V_NORM_Mask : constant Number := 2**6;
-
- File : Byte_IO.File_Type;
- -- Each object file is read as a stream of bytes (characters)
-
- B : Byte;
-
- Number_Of_Characters : Natural := 0;
- -- The number of characters of each section
-
- -- The following variables are used by procedure Process when reading an
- -- object file.
-
- Code : Number := 0;
- Length : Natural := 0;
-
- Dummy : Number;
-
- Nchars : Natural := 0;
- Flags : Number := 0;
-
- Symbol : String (1 .. 255);
- LSymb : Natural;
-
- function Equal (Left, Right : Symbol_Data) return Boolean;
- -- Test for equality of symbols
-
- procedure Get (N : out Number);
- -- Read two bytes from the object file LSB first as unsigned 16 bit number
-
- procedure Get (N : out Natural);
- -- Read two bytes from the object file, LSByte first, as a Natural
-
-
- function Image (N : Integer) return String;
- -- Returns the image of N, without the initial space
-
- -----------
- -- Equal --
- -----------
-
- function Equal (Left, Right : Symbol_Data) return Boolean is
- begin
- return Left.Name /= null and then
- Right.Name /= null and then
- Left.Name.all = Right.Name.all and then
- Left.Kind = Right.Kind and then
- Left.Present = Right.Present;
- end Equal;
-
- ---------
- -- Get --
- ---------
-
- procedure Get (N : out Number) is
- C : Byte;
- LSByte : Number;
- begin
- Read (File, C);
- LSByte := Byte'Pos (C);
- Read (File, C);
- N := LSByte + (256 * Byte'Pos (C));
- end Get;
-
- procedure Get (N : out Natural) is
- Result : Number;
- begin
- Get (Result);
- N := Natural (Result);
- end Get;
-
- -----------
- -- Image --
- -----------
-
- function Image (N : Integer) return String is
- Result : constant String := N'Img;
- begin
- if Result (Result'First) = ' ' then
- return Result (Result'First + 1 .. Result'Last);
-
- else
- return Result;
- end if;
- end Image;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Symbol_File : String;
- Reference : String;
- Symbol_Policy : Policy;
- Quiet : Boolean;
- Version : String;
- Success : out Boolean)
- is
- File : Ada.Text_IO.File_Type;
- Line : String (1 .. 1_000);
- Last : Natural;
-
- begin
- -- Record the symbol file name
-
- Symbol_File_Name := new String'(Symbol_File);
-
- -- Record the policy
-
- Sym_Policy := Symbol_Policy;
-
- -- Record the version (Major ID)
-
- if Version = "" then
- Major_ID := 1;
- Soft_Major_ID := True;
-
- else
- begin
- Major_ID := Integer'Value (Version);
- Soft_Major_ID := False;
-
- if Major_ID <= 0 then
- raise Constraint_Error;
- end if;
-
- exception
- when Constraint_Error =>
- if not Quiet then
- Put_Line ("Version """ & Version & """ is illegal.");
- Put_Line ("On VMS, version must be a positive number");
- end if;
-
- Success := False;
- return;
- end;
- end if;
-
- Minor_ID := 0;
- Soft_Minor_ID := Sym_Policy /= Autonomous;
-
- -- Empty the symbol tables
-
- Symbol_Table.Set_Last (Original_Symbols, 0);
- Symbol_Table.Set_Last (Complete_Symbols, 0);
-
- -- Assume that everything will be fine
-
- Success := True;
-
- -- If policy is not autonomous, attempt to read the reference file
-
- if Sym_Policy /= Autonomous then
- begin
- Open (File, In_File, Reference);
-
- exception
- when Ada.Text_IO.Name_Error =>
- return;
-
- when X : others =>
- if not Quiet then
- Put_Line ("could not open """ & Reference & """");
- Put_Line (Exception_Message (X));
- end if;
-
- Success := False;
- return;
- end;
-
- -- Read line by line
-
- while not End_Of_File (File) loop
- Get_Line (File, Line, Last);
-
- -- Ignore empty lines
-
- if Last = 0 then
- null;
-
- -- Ignore lines starting with "case_sensitive="
-
- elsif Last > Case_Sensitive'Length
- and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
- then
- null;
-
- -- Line starting with "SYMBOL_VECTOR=("
-
- elsif Last > Symbol_Vector'Length
- and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
- then
-
- -- SYMBOL_VECTOR=(<symbol>=DATA)
-
- if Last > Symbol_Vector'Length + Equal_Data'Length and then
- Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
- then
- Symbol_Table.Increment_Last (Original_Symbols);
- Original_Symbols.Table
- (Symbol_Table.Last (Original_Symbols)) :=
- (Name =>
- new String'(Line (Symbol_Vector'Length + 1 ..
- Last - Equal_Data'Length)),
- Kind => Data,
- Present => True);
-
- -- SYMBOL_VECTOR=(<symbol>=PROCEDURE)
-
- elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
- and then
- Line (Last - Equal_Procedure'Length + 1 .. Last) =
- Equal_Procedure
- then
- Symbol_Table.Increment_Last (Original_Symbols);
- Original_Symbols.Table
- (Symbol_Table.Last (Original_Symbols)) :=
- (Name =>
- new String'(Line (Symbol_Vector'Length + 1 ..
- Last - Equal_Procedure'Length)),
- Kind => Proc,
- Present => True);
-
- -- Anything else is incorrectly formatted
-
- else
- if not Quiet then
- Put_Line ("symbol file """ & Reference &
- """ is incorrectly formatted:");
- Put_Line ("""" & Line (1 .. Last) & """");
- end if;
-
- Close (File);
- Success := False;
- return;
- end if;
-
- -- Lines with "gsmatch=equal,<Major_ID>,<Minor_Id>
-
- elsif Last > Gsmatch'Length
- and then Line (1 .. Gsmatch'Length) = Gsmatch
- then
- declare
- Start : Positive := Gsmatch'Length + 1;
- Finish : Positive := Start;
- OK : Boolean := True;
- ID : Integer;
-
- begin
- loop
- if Line (Finish) not in '0' .. '9'
- or else Finish >= Last - 1
- then
- OK := False;
- exit;
- end if;
-
- exit when Line (Finish + 1) = ',';
-
- Finish := Finish + 1;
- end loop;
-
- if OK then
- ID := Integer'Value (Line (Start .. Finish));
- OK := ID /= 0;
-
- -- If Soft_Major_ID is True, it means that
- -- Library_Version was not specified.
-
- if Soft_Major_ID then
- Major_ID := ID;
-
- -- If the Major ID in the reference file is different
- -- from the Library_Version, then the Minor ID will be 0
- -- because there is no point in taking the Minor ID in
- -- the reference file, or incrementing it. So, we set
- -- Soft_Minor_ID to False, so that we don't modify
- -- the Minor_ID later.
-
- elsif Major_ID /= ID then
- Soft_Minor_ID := False;
- end if;
-
- Start := Finish + 2;
- Finish := Start;
-
- loop
- if Line (Finish) not in '0' .. '9' then
- OK := False;
- exit;
- end if;
-
- exit when Finish = Last;
-
- Finish := Finish + 1;
- end loop;
-
- -- Only set Minor_ID if Soft_Minor_ID is True (see above)
-
- if OK and then Soft_Minor_ID then
- Minor_ID := Integer'Value (Line (Start .. Finish));
- end if;
- end if;
-
- -- If OK is not True, that means the line is not correctly
- -- formatted.
-
- if not OK then
- if not Quiet then
- Put_Line ("symbol file """ & Reference &
- """ is incorrectly formatted");
- Put_Line ("""" & Line (1 .. Last) & """");
- end if;
-
- Close (File);
- Success := False;
- return;
- end if;
- end;
-
- -- Anything else is incorrectly formatted
-
- else
- if not Quiet then
- Put_Line ("unexpected line in symbol file """ &
- Reference & """");
- Put_Line ("""" & Line (1 .. Last) & """");
- end if;
-
- Close (File);
- Success := False;
- return;
- end if;
- end loop;
-
- Close (File);
- end if;
- end Initialize;
-
- -------------
- -- Process --
- -------------
-
- procedure Process
- (Object_File : String;
- Success : out Boolean)
- is
- begin
- -- Open the object file with Byte_IO. Return with Success = False if
- -- this fails.
-
- begin
- Open (File, In_File, Object_File);
- exception
- when others =>
- Put_Line
- ("*** Unable to open object file """ & Object_File & """");
- Success := False;
- return;
- end;
-
- -- Assume that the object file has a correct format
-
- Success := True;
-
- -- Get the different sections one by one from the object file
-
- while not End_Of_File (File) loop
-
- Get (Code);
- Get (Number_Of_Characters);
- Number_Of_Characters := Number_Of_Characters - 4;
-
- -- If this is not a Global Symbol Definition section, skip to the
- -- next section.
-
- if Code /= GSD then
-
- for J in 1 .. Number_Of_Characters loop
- Read (File, B);
- end loop;
-
- else
-
- -- Skip over the next 4 bytes
-
- Get (Dummy);
- Get (Dummy);
- Number_Of_Characters := Number_Of_Characters - 4;
-
- -- Get each subsection in turn
-
- loop
- Get (Code);
- Get (Nchars);
- Get (Dummy);
- Get (Flags);
- Number_Of_Characters := Number_Of_Characters - 8;
- Nchars := Nchars - 8;
-
- -- If this is a symbol and the V_DEF flag is set, get the
- -- symbol.
-
- if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then
- -- First, reach the symbol length
-
- for J in 1 .. 25 loop
- Read (File, B);
- Nchars := Nchars - 1;
- Number_Of_Characters := Number_Of_Characters - 1;
- end loop;
-
- Length := Byte'Pos (B);
- LSymb := 0;
-
- -- Get the symbol characters
-
- for J in 1 .. Nchars loop
- Read (File, B);
- Number_Of_Characters := Number_Of_Characters - 1;
- if Length > 0 then
- LSymb := LSymb + 1;
- Symbol (LSymb) := B;
- Length := Length - 1;
- end if;
- end loop;
-
- -- Create the new Symbol
-
- declare
- S_Data : Symbol_Data;
- begin
- S_Data.Name := new String'(Symbol (1 .. LSymb));
-
- -- The symbol kind (Data or Procedure) depends on the
- -- V_NORM flag.
-
- if (Flags and V_NORM_Mask) = 0 then
- S_Data.Kind := Data;
-
- else
- S_Data.Kind := Proc;
- end if;
-
- -- Put the new symbol in the table
-
- Symbol_Table.Increment_Last (Complete_Symbols);
- Complete_Symbols.Table
- (Symbol_Table.Last (Complete_Symbols)) := S_Data;
- end;
-
- else
- -- As it is not a symbol subsection, skip to the next
- -- subsection.
-
- for J in 1 .. Nchars loop
- Read (File, B);
- Number_Of_Characters := Number_Of_Characters - 1;
- end loop;
- end if;
-
- -- Exit the GSD section when number of characters reaches 0
-
- exit when Number_Of_Characters = 0;
- end loop;
- end if;
- end loop;
-
- -- The object file has been processed, close it
-
- Close (File);
-
- exception
- -- For any exception, output an error message, close the object file
- -- and return with Success = False.
-
- when X : others =>
- Put_Line ("unexpected exception raised while processing """
- & Object_File & """");
- Put_Line (Exception_Information (X));
- Close (File);
- Success := False;
- end Process;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize
- (Quiet : Boolean;
- Success : out Boolean)
- is
- File : Ada.Text_IO.File_Type;
- -- The symbol file
-
- S_Data : Symbol_Data;
- -- A symbol
-
- Cur : Positive := 1;
- -- Most probable index in the Complete_Symbols of the current symbol
- -- in Original_Symbol.
-
- Found : Boolean;
-
- begin
- -- Nothing to be done if Initialize has never been called
-
- if Symbol_File_Name = null then
- Success := False;
-
- else
-
- -- First find if the symbols in the reference symbol file are also
- -- in the object files. Note that this is not done if the policy is
- -- Autonomous, because no reference symbol file has been read.
-
- -- Expect the first symbol in the symbol file to also be the first
- -- in Complete_Symbols.
-
- Cur := 1;
-
- for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop
- S_Data := Original_Symbols.Table (Index_1);
- Found := False;
-
- First_Object_Loop :
- for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop
- if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
- Cur := Index_2 + 1;
- Complete_Symbols.Table (Index_2).Present := False;
- Found := True;
- exit First_Object_Loop;
- end if;
- end loop First_Object_Loop;
-
- -- If the symbol could not be found between Cur and Last, try
- -- before Cur.
-
- if not Found then
- Second_Object_Loop :
- for Index_2 in 1 .. Cur - 1 loop
- if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
- Cur := Index_2 + 1;
- Complete_Symbols.Table (Index_2).Present := False;
- Found := True;
- exit Second_Object_Loop;
- end if;
- end loop Second_Object_Loop;
- end if;
-
- -- If the symbol is not found, mark it as such in the table
-
- if not Found then
- if (not Quiet) or else Sym_Policy = Controlled then
- Put_Line ("symbol """ & S_Data.Name.all &
- """ is no longer present in the object files");
- end if;
-
- if Sym_Policy = Controlled then
- Success := False;
- return;
-
- elsif Soft_Minor_ID then
- Minor_ID := Minor_ID + 1;
- Soft_Minor_ID := False;
- end if;
-
- Original_Symbols.Table (Index_1).Present := False;
- Free (Original_Symbols.Table (Index_1).Name);
-
- if Soft_Minor_ID then
- Minor_ID := Minor_ID + 1;
- Soft_Minor_ID := False;
- end if;
- end if;
- end loop;
-
- -- Append additional symbols, if any, to the Original_Symbols table
-
- for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
- S_Data := Complete_Symbols.Table (Index);
-
- if S_Data.Present then
-
- if Sym_Policy = Controlled then
- Put_Line ("symbol """ & S_Data.Name.all &
- """ is not in the reference symbol file");
- Success := False;
- return;
-
- elsif Soft_Minor_ID then
- Minor_ID := Minor_ID + 1;
- Soft_Minor_ID := False;
- end if;
-
- Symbol_Table.Increment_Last (Original_Symbols);
- Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) :=
- S_Data;
- Complete_Symbols.Table (Index).Present := False;
- end if;
- end loop;
-
- -- Create the symbol file
-
- Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
-
- Put (File, Case_Sensitive);
- Put_Line (File, "yes");
-
- -- Put a line in the symbol file for each symbol in the symbol table
-
- for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
- if Original_Symbols.Table (Index).Present then
- Put (File, Symbol_Vector);
- Put (File, Original_Symbols.Table (Index).Name.all);
-
- if Original_Symbols.Table (Index).Kind = Data then
- Put_Line (File, Equal_Data);
-
- else
- Put_Line (File, Equal_Procedure);
- end if;
-
- Free (Original_Symbols.Table (Index).Name);
- end if;
- end loop;
-
- Put (File, Case_Sensitive);
- Put_Line (File, "NO");
-
- -- Put the version IDs
-
- Put (File, Gsmatch);
- Put (File, Image (Major_ID));
- Put (File, ',');
- Put_Line (File, Image (Minor_ID));
-
- -- And we are done
-
- Close (File);
-
- -- Reset both tables
-
- Symbol_Table.Set_Last (Original_Symbols, 0);
- Symbol_Table.Set_Last (Complete_Symbols, 0);
-
- -- Clear the symbol file name
-
- Free (Symbol_File_Name);
-
- Success := True;
- end if;
-
- exception
- when X : others =>
- Put_Line ("unexpected exception raised while finalizing """
- & Symbol_File_Name.all & """");
- Put_Line (Exception_Information (X));
- Success := False;
- end Finalize;
-
-end Symbols;
-- UPPER_CASE
S_Pretty_Comments : aliased constant S := "/COMMENTS_LAYOUT=" &
+ "UNTOUCHED " &
+ "-c0 " &
"DEFAULT " &
"-c1 " &
"STANDARD_INDENT " &
"-c4";
-- /COMMENTS_LAYOUT[=layout-option, layout-option, ...]
--
- -- Set the comment layout. By default, comments use the GNAT style comment
- -- line indentation.
- -- layout-option may be one of the following:
+ -- Set the comment layout. By default, comments use the GNAT style
+ -- comment line indentation.
--
+ -- layout-option is be one of the following:
+ --
+ -- UNTOUCHED All the comments remain unchanged
-- DEFAULT (D) GNAT style comment line indentation
-- STANDARD_INDENT Standard comment line indentation
-- GNAT_BEGINNING GNAT style comment beginning
-- REFORMAT Reformat comment blocks
--
-- All combinations of layout options are allowed, except for DEFAULT
- -- and STANDARD_INDENT which are mutually exclusive.
+ -- and STANDARD_INDENT which are mutually exclusive, and also if
+ -- UNTOUCHED is specified, this must be the only option.
--
-- The difference between "GNAT style comment line indentation" and
-- "standard comment line indentation" is the following: for standard
--
-- MIXED_CASE Names are in mixed case.
+ S_Pretty_No_Backup : aliased constant S := "/NO_BACKUP " &
+ "-rnb";
+ -- /REPLACE_NO_BACKUP
+ --
+ -- Replace the argument source with the pretty-printed source without
+ -- creating any backup copy of the argument source.
+
S_Pretty_No_Labels : aliased constant S := "/NO_MISSED_LABELS " &
"-e";
-- /NO_MISSED_LABELS
"LOWER_CASE " &
"-pL " &
"UPPER_CASE " &
- -- /PRAGMA_CASING[=pragma-option]
+ "-pU";
+ -- /PRAGMA_CASING[=pragma-option]
--
-- Set the case of pragma identifiers. The default is Mixed case.
-- pragma-option may be one of the following:
-- MIXED_CASE (D)
-- LOWER_CASE
-- UPPER_CASE
- "-pU";
- S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" &
- "-P>";
+
+ S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
-- /PROJECT_FILE=filename
--
-- Specifies the main project file to be used. The project files rooted
S_Pretty_Maxind 'Access,
S_Pretty_Mess 'Access,
S_Pretty_Names 'Access,
+ S_Pretty_No_Backup 'Access,
S_Pretty_No_Labels 'Access,
S_Pretty_Notabs 'Access,
S_Pretty_Output 'Access,
projects / gcc.git / commitdiff