+2004-06-11 Vincent Celier <celier@gnat.com>
+
+ * mlib-tgt-vms-alpha.adb (Build_Dynamic_Library): Issue switch -R to
+ gnatsym, when symbol policy is Restricted.
+
+ * mlib-tgt-vms-ia64.adb (Build_Dynamic_Library): Issue switch -R to
+ gnatsym, when symbol policy is Restricted.
+
+ * symbols-vms-alpha.adb (Initialize): When symbol policy is Restricted,
+ read the symbol file.
+ (Finalize): Fail in symbol policy Restricted if a symbol in the original
+ symbol file is not in the object files. Do not create a new symbol file
+ when symbol policy is Restricted.
+
+ * gnatbind.adb (Gnatbind): Initialize Snames, because Snames is used
+ in Scng.
+
+ * gnatsym.adb (Parse_Vmd_Line): Process new switch -R for symbol policy
+ Restricted.
+ (Usage): Line for new switch -R
+
+ * make.adb (Initialize): When the platform is not VMS, add the
+ directory where gnatmake is invoked in the front of the path, if
+ gnatmake is invoked with directory information. Change the Scan_Args
+ while loop to a for loop.
+ (Recursive_Compute_Depth): Remove parameter Visited. Improve efficiency:
+ if Depth is equal or greater than the proposed depth, there is nothing
+ to do.
+ (Initialize): Call Recursive_Compute_Depth with initial Depth equal to 1
+ instead of 0.
+
+ * prj.ads: Add new symbol policy Restricted.
+
+ * prj-dect.adb (Parse_Case_Construction): Call End_Case_Construction
+ with the new parameters Check_All_Labels and Case_Location.
+
+ * prj-nmsc.adb (Ada_Check): Process new symbol policy Restricted
+ (Library_Symbol_File needs to be defined).
+
+ * prj-strt.adb (End_Case_Construction): New parameters Check_All_Labels
+ and Case_Location If Check_All_Labels is True, check that all values of
+ the string type are used, and output warning(s) if they are not.
+
+ * prj-strt.ads (End_Case_Construction): New parameters Check_All_Labels
+ and Case_Location.
+
+ * gnat_ugn.texi: Reorder subclauses in menus "Switches for gcc"
+
+ * gnat_ugn.texi: Update documentation about the library directory in
+ Library Projects.
+
+ * makegpr.adb (Display_Command): In verbose mode, also display the
+ value of the CPATH env var, when the compiler is gcc.
+ (Initialize): Change the Scan_Args while loop to a for loop
+ (Compile_Individual_Sources): Change directory to object directory
+ before compilations.
+
+ * symbols.ads: New symbol policy Restricted.
+
+2004-06-11 Olivier Hainque <hainque@act-europe.fr>
+
+ * a-except.adb (Raise_After_Setup family): Remove. The responsibility
+ is now taken care of internally in the Exception_Propagation package
+ and does not require clients assistance any more.
+
+ * a-exexpr.adb (Is_Setup_And_Not_Propagated,
+ Set_Setup_And_Not_Propagated, and Clear_Setup_And_Not_Propagated): New
+ functions. Helpers to maintain a predicate required in the handling of
+ occurrence transfer between tasks.
+ This is now handled internally and does not require clients assistance
+ for the setup/propagate separation anymore.
+ (Setup_Exception, Propagate_Exception): Simplify the Private_Data
+ allocation strategy, handle the Setup_And_Not_Propagated predicate and
+ document.
+
+ * s-taenca.adb (Check_Exception): Use raise_with_msg instead of
+ raise_after_setup, now that everything is handled internally within the
+ setup/propagation engine.
+
+2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
+
+ * exp_ch6.adb (Expand_Inlined_Call): Add function Formal_Is_Used_Once.
+ Add additional conditions for the case of an actual being a simple
+ name or literal. Improve inlining by preventing the generation
+ of temporaries with a short lifetime (one use).
+
+2004-06-11 Hristian Kirtchev <kirtchev@gnat.com>
+
+ PR ada/15587
+
+ * einfo.ads: Minor comment updates for Has_Completion and
+ E_Constant list of flags.
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Full constant declarations
+ and constant redeclarations now set the Has_Completion flag of their
+ defining identifiers.
+
+ * sem_ch7.adb (Analyze_Package_Spec): Add procedure
+ Inspect_Deferred_Constant_Completion.
+ Used to detect private deferred constants that have not been completed
+ either by a constant redeclaration or pragma Import. Emits error message
+ "constant declaration requires initialization expression".
+
+ * sem_prag.adb (Process_Import_Or_Interface): An Import pragma now
+ completes a deferred constant.
+
+2004-06-11 Geert Bosch <bosch@gnat.com>
+
+ * eval_fat.adb (Decompose_Int): Fix rounding of negative numbers.
+
+ * s-fatgen.adb (Gradual_Scaling): Correct off-by-one error in
+ calculating exponent for scaling denormal numbers.
+ (Leading_Part): Properly raise Constraint_Error for zero or negative
+ Adjustment.
+ (Remainder): Properly raise Constraint_Error for zero divisor.
+
+2004-06-11 Thomas Quinot <quinot@act-europe.fr>
+
+ * sem_util.adb: Minor reformatting.
+
+ * exp_ch2.adb (Expand_Entry_Parameter): Generate an explicit
+ dereference when accessing the entry parameter record.
+ (Check_Array_Type): Always check for possible implicit dereference.
+ (maybe_implicit_dereference): Rename to check_no_implicit_derefence.
+ Abort if a pointer is still present (denoting that an implicit
+ dereference was left in the tree by the front-end).
+
+ * sem_attr.adb (Expand_Entry_Parameter): Generate an explicit
+ dereference when accessing the entry parameter record.
+ (Check_Array_Type): Always check for possible implicit dereference.
+ (maybe_implicit_dereference): Rename to check_no_implicit_derefence.
+ Abort if a pointer is still present (denoting that an implicit
+ dereference was left in the tree by the front-end).
+
+2004-06-11 Emmanuel Briot <briot@act-europe.fr>
+
+ * g-debpoo.adb (Deallocate, Dereference): Add prefix "error:" to error
+ message, like the compiler itself does. Easier to parse the output.
+
+ * g-debpoo.ads: (Allocate, Deallocate, Dereference): Add comments.
+
+ * gnat_ugn.texi (gnatxref, gnatfind): Clarify that source names should
+ be base names, and not includes directories.
+
+2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
+
+ * Makefile.generic ($(EXEC)): Depend on $(OBJECTS), not $(OBJ_FILES),
+ so that dependencies are properly taken into account by make.
+
+2004-06-11 Arnaud Charlet <charlet@act-europe.fr>
+
+ PR ada/15622
+ * s-unstyp.ads, s-maccod.ads, sem_ch8.adb, s-auxdec.ads,
+ exp_intr.adb, s-auxdec-vms_64.ads: Fix typo: instrinsic -> intrinsic
+
+2004-06-11 Jerome Guitton <guitton@act-europe.fr>
+
+ * Makefile.in (install-gnatlib): install target-specific run-time files.
+
+ * Make-lang.in: Remove obsolete targets.
+
+2004-06-11 Ed Schonberg <schonberg@gnat.com>
+
+ * par-ch12.adb (P_Generic): Add scope before analyzing subprogram
+ specification, to catch misuses of program unit names.
+
+ * sem_res.adb (Resolve_Type_Conversion): Do not emit warnings on
+ superfluous conversions in an instance.
+
+2004-06-11 Ed Schonberg <schonberg@gnat.com>
+
+ PR ada/15403
+
+ * sem_ch12.adb (Save_References): If operator node has been folded to
+ enumeration literal, associated_node must be discarded.
+
+2004-06-11 Jose Ruiz <ruiz@act-europe.fr>
+
+ * s-stchop-vxworks.adb: Add required pragma Convention to
+ Task_Descriptor because it is updated by a C function.
+
2004-06-08 Arnaud Charlet <charlet@act-europe.fr>
PR ada/15568
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) \
$(LIBS) $(SYSLIBS)
-install-rts-zfp: force
- $(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=zfp
-
-install-rts-ravenscar: force
- $(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=ravenscar
-
# use cross-gcc
gnat-cross: force
make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \
else
link: $(EXEC_DIR)/$(EXEC) archive-objects
-$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
+$(EXEC_DIR)/$(EXEC): $(OBJECTS)
@$(display) $(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
@$(LINKER) -o $(EXEC_DIR)/$(EXEC) $(OBJ_DIR)/$(MAIN_OBJECT) $(LDFLAGS) $(FLDFLAGS)
endif
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
$(RANLIB) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \
done
+ -$(foreach file, $(EXTRA_ADALIB_FILES), \
+ $(INSTALL_DATA_DATE) rts/$(file) $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
+ ) true
# Install the shared libraries, if any, using $(INSTALL) instead
# of $(INSTALL_DATA). The latter may force a mode inappropriate
# for shared libraries on some targets, e.g. on HP-UX where the x
-- exception occurrence referenced by the Current_Excep in the TSD.
-- Abort is deferred before the raise call.
- procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean);
- pragma No_Return (Raise_With_Msg);
- -- Similar to above, with an extra parameter to indicate wether
- -- Setup_Exception has been called already.
-
- procedure Raise_After_Setup (E : Exception_Id);
- pragma No_Return (Raise_After_Setup);
- pragma Export (C, Raise_After_Setup, "__gnat_raise_after_setup");
- -- Wrapper to Raise_With_Msg and Setup set to True.
- --
- -- This is called by System.Tasking.Entry_Calls.Check_Exception when an
- -- exception has occured during an entry call. The exception to propagate
- -- has been setup and initialized via Transfer_Occurrence in this case.
-
procedure Raise_With_Location_And_Msg
(E : Exception_Id;
F : Big_String_Ptr;
-- Raise_With_Msg --
--------------------
- procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean) is
+ procedure Raise_With_Msg (E : Exception_Id) is
Excep : constant EOA := Get_Current_Excep.all;
begin
- if not Setup then
- Exception_Propagation.Setup_Exception (Excep, Excep);
- end if;
+ Exception_Propagation.Setup_Exception (Excep, Excep);
Excep.Exception_Raised := False;
Excep.Id := E;
Raise_Current_Excep (E);
end Raise_With_Msg;
- procedure Raise_With_Msg (E : Exception_Id) is
- begin
- Raise_With_Msg (E, Setup => False);
- end Raise_With_Msg;
-
- -----------------------
- -- Raise_After_Setup --
- -----------------------
-
- procedure Raise_After_Setup (E : Exception_Id) is
- begin
- Raise_With_Msg (E, Setup => True);
- end Raise_After_Setup;
-
--------------------------------------
-- Calls to Run-Time Check Routines --
--------------------------------------
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
+with System.Storage_Elements; use System.Storage_Elements;
+
pragma Warnings (Off);
-- Since several constructs give warnings in 3.14a1, including unreferenced
-- variables and pragma Unreferenced itself.
procedure Free is new Unchecked_Deallocation
(Exception_Occurrence, EOA);
- function Remove
- (Top : EOA;
- Excep : GNAT_GCC_Exception_Access) return Boolean;
- -- Remove Excep from the stack starting at Top.
- -- Return True if Excep was found and removed, false otherwise.
-
- -- Hooks called when entering/leaving an exception handler for a given
- -- occurrence, aimed at handling the stack of active occurrences. The
- -- calls are generated by gigi in tree_transform/N_Exception_Handler.
-
- procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
- pragma Export (C, Begin_Handler, "__gnat_begin_handler");
-
- procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
- pragma Export (C, End_Handler, "__gnat_end_handler");
-
function CleanupUnwind_Handler
(UW_Version : Integer;
UW_Phases : Unwind_Action;
UW_Argument : System.Address);
pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
+ --------------------------------------------
+ -- Occurrence stack management facilities --
+ --------------------------------------------
+
+ function Remove
+ (Top : EOA;
+ Excep : GNAT_GCC_Exception_Access) return Boolean;
+ -- Remove Excep from the stack starting at Top.
+ -- Return True if Excep was found and removed, false otherwise.
+
+ -- Hooks called when entering/leaving an exception handler for a given
+ -- occurrence, aimed at handling the stack of active occurrences. The
+ -- calls are generated by gigi in tree_transform/N_Exception_Handler.
+
+ procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
+ pragma Export (C, Begin_Handler, "__gnat_begin_handler");
+
+ procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
+ pragma Export (C, End_Handler, "__gnat_end_handler");
+
+ -- To handle the case of a task "transferring" an exception occurrence to
+ -- another task, for instance via Exceptional_Complete_Rendezvous, we need
+ -- to be able to identify occurrences which have been Setup and not yet
+ -- Propagated. We hijack one of the common header fields for that purpose,
+ -- setting it to a special key value during the setup process, clearing it
+ -- at the very beginning of the propagation phase, and expecting it never
+ -- to be reset to the special value later on.
+
+ Setup_Key : constant := 16#DEAD_BEEF#;
+
+ function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;
+
+ procedure Set_Setup_And_Not_Propagated (E : EOA);
+ procedure Clear_Setup_And_Not_Propagated (E : EOA);
+
------------------------------------------------------------
-- Accessors to basic components of a GNAT exception data --
------------------------------------------------------------
return URC_NO_REASON;
end CleanupUnwind_Handler;
+ ---------------------------------
+ -- Is_Setup_And_Not_Propagated --
+ ---------------------------------
+
+ function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
+ GCC_E : GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (E.Private_Data);
+ begin
+ return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
+ end Is_Setup_And_Not_Propagated;
+
+ ------------------------------------
+ -- Clear_Setup_And_Not_Propagated --
+ ------------------------------------
+
+ procedure Clear_Setup_And_Not_Propagated (E : EOA) is
+ GCC_E : GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (E.Private_Data);
+ begin
+ pragma Assert (GCC_E /= null);
+ GCC_E.Header.Private1 := 0;
+ end Clear_Setup_And_Not_Propagated;
+
+ ----------------------------------
+ -- Set_Setup_And_Not_Propagated --
+ ----------------------------------
+
+ procedure Set_Setup_And_Not_Propagated (E : EOA) is
+ GCC_E : GNAT_GCC_Exception_Access :=
+ To_GNAT_GCC_Exception (E.Private_Data);
+ begin
+ pragma Assert (GCC_E /= null);
+ GCC_E.Header.Private1 := Setup_Key;
+ end Set_Setup_And_Not_Propagated;
+
---------------------
-- Setup_Exception --
---------------------
- -- Push the current exception occurrence on the stack before overriding it.
+ -- In this implementation of the exception propagation scheme, this
+ -- subprogram should be understood as: Setup the exception occurrence
+ -- stack headed at Current for a forthcoming raise of Excep.
procedure Setup_Exception
(Excep : EOA;
Next : EOA;
GCC_Exception : GNAT_GCC_Exception_Access;
- -- Note that we make no use of the Reraised indication at this point.
-
- -- The information is still passed around just in case of future needs,
- -- since we've already switched between using/not-using it a number of
- -- times.
-
begin
- -- If the current exception is not live, the stack is empty and there
- -- is nothing to do. Note that the stack always appears empty for
- -- mechanisms that do not require one. For the mechanism we implement
- -- in this unit, the initial Private_Data allocation for an occurrence
- -- is issued by Propagate_Exception.
- if Top.Private_Data = System.Null_Address then
+ -- The exception Excep is soon to be propagated, and the storage used
+ -- for that will be the occurrence statically allocated for the current
+ -- thread. This storage might currently be used for a still active
+ -- occurrence, so we need to push it on the thread's occurrence stack
+ -- (headed at that static occurrence) before it gets clobbered.
+
+ -- What we do here is to trigger this push when need be, and allocate a
+ -- Private_Data block for the forthcoming Propagation.
+
+ -- Some tasking rendez-vous attempts lead to an occurrence transfer
+ -- from the server to the client (see Exceptional_Complete_Rendezvous).
+ -- In those cases Setup is called twice for the very same occurrence
+ -- before it gets propagated: once from the server, because this is
+ -- where the occurrence contents is elaborated and known, and then
+ -- once from the client when it detects the case and actually raises
+ -- the exception in its own context.
+
+ -- The Is_Setup_And_Not_Propagated predicate tells us when we are in
+ -- the second call to Setup for a Transferred occurrence, and there is
+ -- nothing to be done here in this situation. This predicate cannot be
+ -- True if we are dealing with a Reraise, and we may even be called
+ -- with a raw uninitialized Excep occurrence in this case so we should
+ -- not check anyway. Observe the front-end expansion for a "raise;" to
+ -- see that happening. We get a local occurrence and a direct call to
+ -- Save_Occurrence without the intermediate init-proc call.
+
+ if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
return;
end if;
- -- Shift the contents of the Top of the stack in a freshly allocated
- -- entry, which leaves the room in the fixed Top entry available for the
- -- occurrence about to be propagated.
+ -- Allocate what will be the Private_Data block for the exception
+ -- to be propagated.
- Next := new Exception_Occurrence;
- Save_Occurrence_And_Private (Next.all, Top.all);
+ GCC_Exception := new GNAT_GCC_Exception;
- -- Allocate Private_Data for the occurrence about to be propagated
- -- and link everything together.
+ -- If the Top of the occurrence stack is not currently used for an
+ -- active exception (the stack is empty) we just need to setup the
+ -- Private_Data pointer.
- GCC_Exception := new GNAT_GCC_Exception;
- GCC_Exception.Next_Exception := Next;
+ -- Otherwise, we also need to shift the contents of the Top of the
+ -- stack in a freshly allocated entry and link everything together.
+
+ if Top.Private_Data /= System.Null_Address then
+ Next := new Exception_Occurrence;
+ Save_Occurrence_And_Private (Next.all, Top.all);
+
+ GCC_Exception.Next_Exception := Next;
+ Top.Private_Data := GCC_Exception.all'Address;
+ end if;
Top.Private_Data := GCC_Exception.all'Address;
+ Set_Setup_And_Not_Propagated (Top);
+
end Setup_Exception;
-------------------
GCC_Exception : GNAT_GCC_Exception_Access;
begin
- if Excep.Private_Data = System.Null_Address then
- GCC_Exception := new GNAT_GCC_Exception;
- Excep.Private_Data := GCC_Exception.all'Address;
- else
- GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
- end if;
+ pragma Assert (Excep.Private_Data /= System.Null_Address);
- -- Fill in the useful flags for the personality routine called for each
+ -- Retrieve the Private_Data for this occurrence and set the useful
+ -- flags for the personality routine, which will be called for each
-- frame via Unwind_RaiseException below.
+ GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
+
+ Clear_Setup_And_Not_Propagated (Excep);
+
GCC_Exception.Id := Excep.Id;
GCC_Exception.N_Cleanups_To_Trigger := 0;
-- Has_Completion (Flag26)
-- Present in all entities that require a completion (functions,
-- procedures, private types, limited private types, incomplete types,
--- and packages that require a body). Set if the completion has been
--- encountered and analyzed.
+-- constants and packages that require a body). The flag is set if the
+-- completion has been encountered and analyzed.
-- Has_Completion_In_Body (Flag71)
-- Present in "Taft amendment types" that is to say incomplete types
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
+ -- Has_Completion (Flag26) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
Calculate_Fraction_And_Exponent : begin
Uintp_Mark := Mark;
- -- Put back sign before applying the rounding.
-
- if UR_Is_Negative (X) then
- Fraction := -Fraction;
- end if;
-
-- Determine correct rounding based on the remainder
- -- which is in N and the divisor D.
+ -- which is in N and the divisor D. The rounding is
+ -- performed on the absolute value of X, so Ceiling
+ -- and Floor need to check for the sign of X explicitly.
case Mode is
when Round_Even =>
end if;
when Ceiling =>
- if N > Uint_0 then
+ if N > Uint_0 and then not UR_Is_Negative (X) then
Fraction := Fraction + 1;
end if;
- when Floor => null;
+ when Floor =>
+ if N > Uint_0 and then UR_Is_Negative (X) then
+ Fraction := Fraction + 1;
+ end if;
end case;
-- The result must be normalized to [1.0/Radix, 1.0),
Exponent := Exponent + 1;
end if;
+ -- Put back sign after applying the rounding.
+
+ if UR_Is_Negative (X) then
+ Fraction := -Fraction;
+ end if;
+
Release_And_Save (Uintp_Mark, Fraction, Exponent);
end Calculate_Fraction_And_Exponent;
end Decompose_Int;
P_Comp_Ref :=
Make_Selected_Component (Loc,
Prefix =>
- Unchecked_Convert_To (Parm_Type,
- New_Reference_To (Addr_Ent, Loc)),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Parm_Type,
+ New_Reference_To (Addr_Ent, Loc))),
Selector_Name =>
New_Reference_To (Entry_Component (Ent_Formal), Loc));
-- If procedure body has no local variables, inline body without
-- creating block, otherwise rewrite call with block.
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
+ -- Determine whether a formal parameter is used only once in Orig_Bod
+
---------------------
-- Make_Exit_Label --
---------------------
end if;
end Rewrite_Procedure_Call;
+ -------------------------
+ -- Formal_Is_Used_Once --
+ ------------------------
+
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
+ Use_Counter : Int := 0;
+
+ function Count_Uses (N : Node_Id) return Traverse_Result;
+ -- Traverse the tree and count the uses of the formal parameter.
+ -- In this case, for optimization purposes, we do not need to
+ -- continue the traversal once more than one use is encountered.
+
+ function Count_Uses (N : Node_Id) return Traverse_Result is
+ begin
+
+ -- The original node is an identifier
+
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+
+ -- The original node's entity points to the one in the
+ -- copied body.
+
+ and then Nkind (Entity (N)) = N_Identifier
+ and then Present (Entity (Entity (N)))
+
+ -- The entity of the copied node is the formal parameter
+
+ and then Entity (Entity (N)) = Formal
+ then
+ Use_Counter := Use_Counter + 1;
+
+ if Use_Counter > 1 then
+
+ -- Denote more than one use and abandon the traversal
+
+ Use_Counter := 2;
+ return Abandon;
+
+ end if;
+ end if;
+
+ return OK;
+ end Count_Uses;
+
+ procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
+
+ -- Start of processing for Formal_Is_Used_Once
+
+ begin
+
+ Count_Formal_Uses (Orig_Bod);
+ return Use_Counter = 1;
+
+ end Formal_Is_Used_Once;
+
-- Start of processing for Expand_Inlined_Call
begin
(not Is_Scalar_Type (Etype (A))
or else Ekind (Entity (A)) = E_Enumeration_Literal))
+ -- When the actual is an identifier and the corresponding formal
+ -- is used only once in the original body, the formal can be
+ -- substituted directly with the actual parameter.
+
+ or else (Nkind (A) = N_Identifier
+ and then Formal_Is_Used_Once (F))
+
or else Nkind (A) = N_Real_Literal
or else Nkind (A) = N_Integer_Literal
or else Nkind (A) = N_Character_Literal
procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
-- Expand an intrinsic shift operation, N and E are from the call to
- -- Expand_Instrinsic_Call (call node and subprogram spec entity) and
+ -- Expand_Intrinsic_Call (call node and subprogram spec entity) and
-- K is the kind for the shift node
procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
if Pool.Raise_Exceptions then
raise Freeing_Not_Allocated_Storage;
else
- Put ("Freeing not allocated storage, at ");
+ Put ("error: Freeing not allocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
if Pool.Raise_Exceptions then
raise Freeing_Deallocated_Storage;
else
- Put ("Freeing already deallocated storage, at ");
+ Put ("error: Freeing already deallocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
if Pool.Raise_Exceptions then
raise Accessing_Not_Allocated_Storage;
else
- Put ("Accessing not allocated storage, at ");
+ Put ("error: Accessing not allocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
Code_Address_For_Dereference_End);
if Pool.Raise_Exceptions then
raise Accessing_Deallocated_Storage;
else
- Put ("Accessing deallocated storage, at ");
+ Put ("error: Accessing deallocated storage, at ");
Put_Line
(Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
-- --
-- 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- --
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
+ -- Allocate a new chunk of memory, and set it up so that the debug pool
+ -- can check accesses to its data, and report incorrect access later on.
+ -- The parameters have the same semantics as defined in the ARM95.
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
+ -- Mark a block of memory as invalid. It might not be physically removed
+ -- immediately, depending on the setup of the debug pool, so that checks
+ -- are still possible.
+ -- The parameters have the same semantics as defined in the ARM95.
function Storage_Size (Pool : Debug_Pool) return SSC;
+ -- Return the maximal size of data that can be allocated through Pool.
+ -- Since Pool uses the malloc() system call, all the memory is accessible
+ -- through the pool
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : System.Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
+ -- Check whether a derefence statement is valid, ie whether the pointer
+ -- was allocated through Pool. As documented above, errors will be
+ -- reported either by a special error message or an exception, depending
+ -- on the setup of the storage pool.
+ -- The parameters have the same semantics as defined in the ARM95.
type Byte_Count is mod System.Max_Binary_Modulus;
-- Type used for maintaining byte counts, needs to be large enough
* Output and Error Message Control::
* Warning Message Control::
* Debugging and Assertion Control::
-* Run-Time Checks::
-* Stack Overflow Checking::
* Validity Checking::
* Style Checking::
+* Run-Time Checks::
+* Stack Overflow Checking::
* Using gcc for Syntax Checking::
* Using gcc for Semantic Checking::
* Compiling Ada 83 Programs::
* Output and Error Message Control::
* Warning Message Control::
* Debugging and Assertion Control::
-* Run-Time Checks::
-* Stack Overflow Checking::
* Validity Checking::
* Style Checking::
+* Run-Time Checks::
+* Stack Overflow Checking::
* Using gcc for Syntax Checking::
* Using gcc for Semantic Checking::
* Compiling Ada 83 Programs::
(absolute or relative) of the directory where the library will reside.
It must designate an existing directory, and this directory must be
different from the project's object directory. It also needs to be writable.
+The directory should only be used for one library; the reason is that all
+files contained in this directory may be deleted by the Project Manager.
If both @code{Library_Name} and @code{Library_Dir} are specified and
are legal, then the project file defines a library project. The optional
directory whose name starts with @file{source} and whose extension is
@file{adb}.
+You shouldn't specify any directory name, just base names. @command{gnatxref}
+and @command{gnatfind} will be able to locate these files by themselves using
+the source path. If you specify directories, no result is produced.
+
@end table
@noindent
with Osint.B; use Osint.B;
with Output; use Output;
with Rident; use Rident;
+with Snames;
with Switch; use Switch;
with Switch.B; use Switch.B;
with Targparm; use Targparm;
Csets.Initialize;
Namet.Initialize;
+ Snames.Initialize;
-- Acquire target parameters
procedure Parse_Cmd_Line is
begin
loop
- case GNAT.Command_Line.Getopt ("c C q r: s: v V:") is
+ case GNAT.Command_Line.Getopt ("c C q r: R s: v V:") is
when ASCII.NUL =>
exit;
Reference_Symbol_File_Name :=
new String'(GNAT.Command_Line.Parameter);
+ when 'R' =>
+ Symbol_Policy := Restricted;
+
when 's' =>
Symbol_File_Name := new String'(GNAT.Command_Line.Parameter);
begin
Write_Line ("gnatsym [options] object_file {object_file}");
Write_Eol;
- Write_Line (" -c Compliant policy");
- Write_Line (" -C Controlled policy");
+ Write_Line (" -c Compliant symbol policy");
+ Write_Line (" -C Controlled symbol policy");
Write_Line (" -q Quiet mode");
Write_Line (" -r<ref> Reference symbol file name");
+ Write_Line (" -R Restricted symbol policy");
Write_Line (" -s<sym> Symbol file name");
Write_Line (" -v Verbose mode");
Write_Line (" -V<ver> Version");
procedure Debug_Msg (S : String; N : Name_Id);
-- If Debug.Debug_Flag_W is set outputs string S followed by name N.
- type Project_Array is array (Positive range <>) of Project_Id;
- No_Projects : constant Project_Array := (1 .. 0 => No_Project);
-
procedure Recursive_Compute_Depth
(Project : Project_Id;
- Visited : Project_Array;
Depth : Natural);
-- Compute depth of Project and of the projects it depends on
----------------
procedure Initialize is
- Next_Arg : Positive;
-
begin
-- Override default initialization of Check_Object_Consistency
-- since this is normally False for GNATBIND, but is True for
Mains.Delete;
- Next_Arg := 1;
- Scan_Args : while Next_Arg <= Argument_Count loop
+ -- Add the directory where gnatmake is invoked in the front of the
+ -- path, if gnatmake is invoked with directory information.
+ -- Only do this if the platform is not VMS, where the notion of path
+ -- does not really exist.
+
+ if not OpenVMS then
+ declare
+ Command : constant String := Command_Name;
+ begin
+ for Index in reverse Command'Range loop
+ if Command (Index) = Directory_Separator then
+ declare
+ Absolute_Dir : constant String :=
+ Normalize_Pathname (Command (Command'First .. Index));
+ PATH : constant String :=
+ Absolute_Dir & Path_Separator & Getenv ("PATH").all;
+
+ begin
+ Setenv ("PATH", PATH);
+ end;
+
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Scan the switches and arguments
+
+ Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
- Next_Arg := Next_Arg + 1;
end loop Scan_Args;
if Usage_Requested then
-- Compute depth of each project
+ for Proj in 1 .. Projects.Last loop
+ Projects.Table (Proj).Seen := False;
+ Projects.Table (Proj).Depth := 0;
+ end loop;
+
Recursive_Compute_Depth
- (Main_Project, Visited => No_Projects, Depth => 0);
+ (Main_Project, Depth => 1);
else
procedure Recursive_Compute_Depth
(Project : Project_Id;
- Visited : Project_Array;
Depth : Natural)
is
List : Project_List;
Proj : Project_Id;
- OK : Boolean;
- New_Visited : constant Project_Array := Visited & Project;
begin
- -- Nothing to do if there is no project
+ -- Nothing to do if there is no project or if the project has already
+ -- been seen or if the depth is large enough.
- if Project = No_Project then
+ if Project = No_Project
+ or else Projects.Table (Project).Seen
+ or else Projects.Table (Project).Depth >= Depth
+ then
return;
end if;
- -- If current depth of project is lower than Depth, adjust it
+ Projects.Table (Project).Depth := Depth;
- if Projects.Table (Project).Depth < Depth then
- Projects.Table (Project).Depth := Depth;
- end if;
+ -- Mark the project as Seen to avoid endless loop caused by limited
+ -- withs.
+
+ Projects.Table (Project).Seen := True;
List := Projects.Table (Project).Imported_Projects;
while List /= Empty_Project_List loop
Proj := Project_Lists.Table (List).Project;
List := Project_Lists.Table (List).Next;
-
- OK := True;
-
- -- To avoid endless loops due to cycles with limited widts,
- -- do not revisit a project that is already in the chain of imports
- -- that brought us here.
-
- for J in Visited'Range loop
- if Visited (J) = Proj then
- OK := False;
- exit;
- end if;
- end loop;
-
- if OK then
- Recursive_Compute_Depth
- (Project => Proj,
- Visited => New_Visited,
- Depth => Depth + 1);
- end if;
+ Recursive_Compute_Depth
+ (Project => Proj,
+ Depth => Depth + 1);
end loop;
-- Visit a project being extended, if any
Recursive_Compute_Depth
(Project => Projects.Table (Project).Extends,
- Visited => New_Visited,
- Depth => Depth + 1);
+ Depth => Depth + 1);
+
+ -- Reset the Seen flag, as we leave this project
+
+ Projects.Table (Project).Seen := False;
end Recursive_Compute_Depth;
-----------------------
First_Source : Other_Source_Id);
-- ??? needs comment
- procedure Display_Command (Name : String; Path : String_Access);
+ procedure Display_Command
+ (Name : String;
+ Path : String_Access;
+ CPATH : String_Access := null);
-- Display the command for a spawned process, if in Verbose_Mode or
-- not in Quiet_Output.
is
Source : Other_Source := Other_Sources.Table (Source_Id);
Success : Boolean;
+ CPATH : String_Access := null;
begin
-- If the compiler is not know yet, get its path name
Add_Search_Directories (Data, Source.Language);
+ -- Set CPATH, if compiler is GCC
+
+ if Compiler_Is_Gcc (Source.Language) then
+ CPATH := Current_Include_Paths (Source.Language);
+ end if;
+
-- And invoke the compiler
Display_Command
- (Compiler_Names (Source.Language).all,
- Compiler_Paths (Source.Language));
+ (Name => Compiler_Names (Source.Language).all,
+ Path => Compiler_Paths (Source.Language),
+ CPATH => CPATH);
Spawn
(Compiler_Paths (Source.Language).all,
Get_Imported_Directories (Main_Project, Data);
Projects.Table (Main_Project) := Data;
+ -- Compilation will occur in the object directory
+
+ Change_Dir (Get_Name_String (Data.Object_Directory));
+
if not Data.Sources_Present then
if Ada_Is_A_Language then
Mains.Reset;
-- Display_Command --
---------------------
- procedure Display_Command (Name : String; Path : String_Access) is
+ procedure Display_Command
+ (Name : String;
+ Path : String_Access;
+ CPATH : String_Access := null)
+ is
begin
-- Only display the command in Verbose Mode (-v) or when
-- not in Quiet Output (no -q).
-- In Verbose Mode output the full path of the spawned process
if Verbose_Mode then
+ if CPATH /= null then
+ Write_Str ("CPATH = ");
+ Write_Line (CPATH.all);
+ end if;
+
Write_Str (Path.all);
else
----------------
procedure Initialize is
- Next_Arg : Positive;
-
begin
-- Do some necessary package initializations
Add_Str_To_Name_Buffer ("compiler_command");
Name_Compiler_Command := Name_Find;
- Next_Arg := 1;
-
-- Get the command line arguments
- Scan_Args : while Next_Arg <= Argument_Count loop
+ Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Arg (Argument (Next_Arg));
- Next_Arg := Next_Arg + 1;
end loop Scan_Args;
-- Fail if command line ended with "-P"
when Controlled =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-C");
+
+ when Restricted =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-R");
end case;
-- Add each relevant object file
when Controlled =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-C");
+
+ when Restricted =>
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'("-R");
end case;
-- Add each relevant object file
-- --
-- B o d y --
-- --
--- 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- --
Set_Specification (Gen_Decl, P_Package (Pf_Spcn));
else
Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc);
+
Set_Specification (Gen_Decl, P_Subprogram_Specification);
+
+ if Nkind (Defining_Unit_Name (Specification (Gen_Decl)))
+ = N_Defining_Program_Unit_Name
+ and then Scope.Last > 0
+ then
+ Error_Msg_SP ("child unit allowed only at library level");
+ end if;
TF_Semicolon;
end if;
with Err_Vars; use Err_Vars;
with Namet; use Namet;
+with Opt; use Opt;
with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree;
First_Declarative_Item : Project_Node_Id := Empty_Node;
- First_Choice : Project_Node_Id := Empty_Node;
+ First_Choice : Project_Node_Id := Empty_Node;
+
+ When_Others : Boolean := False;
+ -- Set to True when there is a "when others =>" clause
begin
Case_Construction :=
Scan;
if Token = Tok_Others then
+ When_Others := True;
-- Scan past "others"
end if;
end loop When_Loop;
- End_Case_Construction;
+ End_Case_Construction
+ (Check_All_Labels => not When_Others and not Quiet_Output,
+ Case_Location => Location_Of (Case_Construction));
Expect (Tok_End, "`END CASE`");
Remove_Next_End_Node;
end;
end if;
- if not Lib_Symbol_File.Default then
+ if not Lib_Symbol_Policy.Default then
+ declare
+ Value : constant String :=
+ To_Lower
+ (Get_Name_String (Lib_Symbol_Policy.Value));
+
+ begin
+ if Value = "autonomous" or else Value = "default" then
+ Data.Symbol_Data.Symbol_Policy := Autonomous;
+
+ elsif Value = "compliant" then
+ Data.Symbol_Data.Symbol_Policy := Compliant;
+
+ elsif Value = "controlled" then
+ Data.Symbol_Data.Symbol_Policy := Controlled;
+
+ elsif Value = "restricted" then
+ Data.Symbol_Data.Symbol_Policy := Restricted;
+
+ else
+ Error_Msg
+ (Project,
+ "illegal value for Library_Symbol_Policy",
+ Lib_Symbol_Policy.Location);
+ end if;
+ end;
+ end if;
+
+ if Lib_Symbol_File.Default then
+ if Data.Symbol_Data.Symbol_Policy = Restricted then
+ Error_Msg
+ (Project,
+ "Library_Symbol_File needs to be defined when " &
+ "symbol policy is Restricted",
+ Lib_Symbol_Policy.Location);
+ end if;
+
+ else
Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
Get_Name_String (Lib_Symbol_File.Value);
end if;
end if;
- if not Lib_Symbol_Policy.Default then
- declare
- Value : constant String :=
- To_Lower
- (Get_Name_String (Lib_Symbol_Policy.Value));
-
- begin
- if Value = "autonomous" or else Value = "default" then
- Data.Symbol_Data.Symbol_Policy := Autonomous;
-
- elsif Value = "compliant" then
- Data.Symbol_Data.Symbol_Policy := Compliant;
-
- elsif Value = "controlled" then
- Data.Symbol_Data.Symbol_Policy := Controlled;
-
- else
- Error_Msg
- (Project,
- "illegal value for Library_Symbol_Policy",
- Lib_Symbol_Policy.Location);
- end if;
- end;
- end if;
-
if Lib_Ref_Symbol_File.Default then
- if Data.Symbol_Data.Symbol_Policy /= Autonomous then
+ if Data.Symbol_Data.Symbol_Policy = Compliant
+ or else Data.Symbol_Data.Symbol_Policy = Controlled
+ then
Error_Msg
(Project,
"a reference symbol file need to be defined",
-- End_Case_Construction --
---------------------------
- procedure End_Case_Construction is
+ procedure End_Case_Construction
+ (Check_All_Labels : Boolean;
+ Case_Location : Source_Ptr)
+ is
+ Non_Used : Natural := 0;
+ First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
begin
+ -- First, if Check_All_Labels is True, check if all values
+ -- of the string type have been used.
+
+ if Check_All_Labels then
+ for Choice in Choice_First .. Choices.Last loop
+ if not Choices.Table (Choice).Already_Used then
+ Non_Used := Non_Used + 1;
+
+ if Non_Used = 1 then
+ First_Non_Used := Choice;
+ end if;
+ end if;
+ end loop;
+
+ -- If only one is not used, report a single warning for this value
+ if Non_Used = 1 then
+ Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
+ Error_Msg ("?value { is not used as label", Case_Location);
+
+ -- If several are not used, report a warning for each one of them
+
+ elsif Non_Used > 1 then
+ Error_Msg
+ ("?the following values are not used as labels:",
+ Case_Location);
+
+ for Choice in First_Non_Used .. Choices.Last loop
+ if not Choices.Table (Choice).Already_Used then
+ Error_Msg_Name_1 := Choices.Table (Choice).The_String;
+ Error_Msg ("\?{", Case_Location);
+ end if;
+ end loop;
+ end if;
+ end if;
+
-- If this is the only case construction, empty the tables
if Choice_Lasts.Last = 1 then
-- into a table to be checked against the case labels of the
-- case construction.
- procedure End_Case_Construction;
+ procedure End_Case_Construction
+ (Check_All_Labels : Boolean;
+ Case_Location : Source_Ptr);
-- This procedure is called at the end of a case construction
-- to remove the case labels and to restore the previous state.
-- In particular, in the case of nested case constructions,
-- the case labels of the enclosing case construction are restored.
+ -- When When_Others is False and we are not in quiet output, a warning
+ -- is emitted for each value of the case variable string type that has
+ -- not been specified.
procedure Parse_Choice_List
(First_Choice : out Project_Node_Id);
type Lib_Kind is (Static, Dynamic, Relocatable);
- type Policy is (Autonomous, Compliant, Controlled);
- -- See explaination about this type in package Symbol
+ type Policy is (Autonomous, Compliant, Controlled, Restricted);
+ -- See explaination about this type in package Symbols
type Symbol_Record is record
Symbol_File : Name_Id := No_Name;
-- convention C so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
- -- spirit of the original (hardware instrinsic) routines.
+ -- spirit of the original (hardware intrinsic) routines.
pragma Convention (C, Clear_Interlocked);
pragma Inline_Always (Clear_Interlocked);
-- convention C so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
- -- spirit of the original (hardware instrinsic) routines.
+ -- spirit of the original (hardware intrinsic) routines.
pragma Convention (C, Clear_Interlocked);
pragma Inline_Always (Clear_Interlocked);
-- --
-- B o d y --
-- --
--- 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- --
Ex : UI := Adjustment;
begin
- if Adjustment < T'Machine_Emin then
+ if Adjustment < T'Machine_Emin - 1 then
Y := 2.0 ** T'Machine_Emin;
Y1 := Y;
Ex := Ex - T'Machine_Emin;
- while Ex <= 0 loop
+ while Ex < 0 loop
Y := T'Machine (Y / 2.0);
if Y = 0.0 then
if Radix_Digits >= T'Machine_Mantissa then
return X;
+ elsif Radix_Digits <= 0 then
+ raise Constraint_Error;
+
else
L := Exponent (X) - Radix_Digits;
Y := Truncation (Scaling (X, -L));
P_Even : Boolean;
begin
+ if Y = 0.0 then
+ raise Constraint_Error;
+ end if;
+
if X > 0.0 then
Sign_X := 1.0;
Arg := X;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- This package provides machine code support, both for instrinsic machine
+-- This package provides machine code support, both for intrinsic machine
-- operations, and also for machine code statements. See GNAT documentation
-- for full details.
Td_ErrorStatus : Interfaces.C.int; -- most recent task error status
Td_Delay : Interfaces.C.int; -- delay/timeout ticks
end record;
+ pragma Convention (C, Task_Descriptor);
-- This VxWorks procedure fills in a specified task descriptor
-- for a specified task.
use type Ada.Exceptions.Exception_Id;
procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
- pragma Import (C, Internal_Raise, "__gnat_raise_after_setup");
+ pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
E : constant Ada.Exceptions.Exception_Id :=
Entry_Call.Exception_To_Raise;
-- --
-- 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- --
-- Types used for packed array conversions
subtype Bytes_F is Packed_Bytes4 (1 .. Float'Size / 8);
- -- Type used in implementation of Is_Negative instrinsic (see Exp_Intr)
+ -- Type used in implementation of Is_Negative intrinsic (see Exp_Intr)
function Shift_Left
(Value : Short_Short_Unsigned;
-- object, and that the expression, if present, is static
-- and within the range of the dimensions of the type.
- if Is_Array_Type (P_Type) then
- Index := First_Index (P_Base_Type);
-
- else pragma Assert (Is_Access_Type (P_Type));
- Index := First_Index (Base_Type (Designated_Type (P_Type)));
- end if;
+ pragma Assert (Is_Array_Type (P_Type));
+ Index := First_Index (P_Base_Type);
if No (E1) then
-- Normal case of array type or subtype
Check_Either_E0_Or_E1;
+ Check_Dereference;
if Is_Array_Type (P_Type) then
if not Is_Constrained (P_Type)
D := Number_Dimensions (P_Type);
- elsif Is_Access_Type (P_Type)
- and then Is_Array_Type (Designated_Type (P_Type))
- then
- if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
- Error_Attr ("prefix of % attribute cannot be access type", P);
- end if;
-
- D := Number_Dimensions (Designated_Type (P_Type));
-
- -- If there is an implicit dereference, then we must freeze
- -- the designated type of the access type, since the type of
- -- the referenced array is this type (see AI95-00106).
-
- Freeze_Before (N, Designated_Type (P_Type));
-
else
if Is_Private_Type (P_Type) then
Error_Attr
("prefix for % attribute may not be private type", P);
+ elsif Is_Access_Type (P_Type)
+ and then Is_Array_Type (Designated_Type (P_Type))
+ and then Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
+ then
+ Error_Attr ("prefix of % attribute cannot be access type", P);
+
elsif Attr_Id = Attribute_First
or else
Attr_Id = Attribute_Last
Resolve (P);
if Is_Access_Type (P_Type) then
+
+ -- If there is an implicit dereference, then we must freeze
+ -- the designated type of the access type, since the type of
+ -- the referenced array is this type (see AI95-00106).
+
+ Freeze_Before (N, Designated_Type (P_Type));
+
Rewrite (P,
Make_Explicit_Dereference (Sloc (P),
Prefix => Relocate_Node (P)));
-- If the prefix is a selected component whose prefix is of an
-- access type, then introduce an explicit dereference.
+ -- ??? Could we reuse Check_Dereference here?
if Nkind (Pref) = N_Selected_Component
and then Is_Access_Type (Ptyp)
-- inlining.
Rewrite (N, New_Copy (N2));
- Set_Associated_Node (N, N2);
Set_Analyzed (N, False);
end if;
end if;
Set_Is_True_Constant (Id, True);
+ -- If we are analyzing a constant declaration, set its completion
+ -- flag after analyzing the expression.
+
+ if Constant_Present (N) then
+ Set_Has_Completion (Id);
+ end if;
+
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;
-- Child and Unit are entities of compilation units. True if Child
-- is a public child of Parent as defined in 10.1.1
+ procedure Inspect_Deferred_Constant_Completion;
+ -- Examines the deferred constants in the private part of the
+ -- package specification. Emits the error "constant declaration
+ -- requires initialization expression " if not completed by an
+ -- import pragma.
+
---------------------
-- Clear_Constants --
---------------------
end if;
end Is_Public_Child;
+ --------------------------------------------
+ -- Inspect_Deferred_Constant_Completion --
+ --------------------------------------------
+
+ procedure Inspect_Deferred_Constant_Completion is
+ Decl : Node_Id;
+ begin
+
+ Decl := First (Priv_Decls);
+ while Present (Decl) loop
+
+ -- Deferred constant signature
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Constant_Present (Decl)
+ and then No (Expression (Decl))
+
+ -- No need to check internally generated constants
+
+ and then Comes_From_Source (Decl)
+
+ -- The constant is not completed. A full object declaration
+ -- or a pragma Import complete a deferred constant.
+
+ and then not Has_Completion (Defining_Identifier (Decl))
+ then
+ Error_Msg_N
+ ("constant declaration requires initialization expression",
+ Defining_Identifier (Decl));
+
+ end if;
+
+ Decl := Next (Decl);
+ end loop;
+ end Inspect_Deferred_Constant_Completion;
+
-- Start of processing for Analyze_Package_Specification
begin
Analyze_Declarations (Priv_Decls);
+ -- Check the private declarations for incomplete deferred
+ -- constants.
+
+ Inspect_Deferred_Constant_Completion;
+
-- The first private entity is the immediate follower of the last
-- visible entity, if there was one.
Set_Alias (New_S, Old_S);
end if;
- -- Note that we do not set Is_Instrinsic_Subprogram if we have
+ -- Note that we do not set Is_Intrinsic_Subprogram if we have
-- a renaming as body, since the entity in this case is not an
-- intrinsic (it calls an intrinsic, but we have a real body
-- for this call, and it is in this body that the required
Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
+ -- pragma Import completes deferred constants
+
+ if Ekind (Def_Id) = E_Constant then
+ Set_Has_Completion (Def_Id);
+ end if;
+
-- It is not possible to import a constant of an unconstrained
-- array type (e.g. string) because there is no simple way to
-- write a meaningful subtype for it.
if Warn_On_Redundant_Constructs
and then Comes_From_Source (Orig_N)
and then Nkind (Orig_N) = N_Type_Conversion
+ and then not In_Instance
then
Orig_N := Original_Node (Expression (Orig_N));
Orig_T := Target_Type;
with Output; use Output;
with Opt; use Opt;
with Restrict; use Restrict;
-with Rtsfind; use Rtsfind;
+with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
with Sem; use Sem;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
Success := True;
- -- If policy is not autonomous, attempt to read the reference file
+ -- If policy is Compliant or Controlled, attempt to read the reference
+ -- file. If policy is Restricted, attempt to read the symbol file.
if Sym_Policy /= Autonomous then
- begin
- Open (File, In_File, Reference);
+ case Sym_Policy is
+ when Autonomous =>
+ null;
- exception
- when Ada.Text_IO.Name_Error =>
- return;
+ when Compliant | Controlled =>
+ begin
+ Open (File, In_File, Reference);
- when X : others =>
- if not Quiet then
- Put_Line ("could not open """ & Reference & """");
- Put_Line (Exception_Message (X));
- end if;
+ exception
+ when Ada.Text_IO.Name_Error =>
+ Success := False;
+ return;
- Success := False;
- return;
- end;
+ when X : others =>
+ if not Quiet then
+ Put_Line ("could not open """ & Reference & """");
+ Put_Line (Exception_Message (X));
+ end if;
+
+ Success := False;
+ return;
+ end;
+
+ when Restricted =>
+ begin
+ Open (File, In_File, Symbol_File);
+
+ exception
+ when Ada.Text_IO.Name_Error =>
+ Success := False;
+ return;
+
+ when X : others =>
+ if not Quiet then
+ Put_Line ("could not open """ & Symbol_File & """");
+ Put_Line (Exception_Message (X));
+ end if;
+
+ Success := False;
+ return;
+ end;
+ end case;
-- Read line by line
""" is no longer present in the object files");
end if;
- if Sym_Policy = Controlled then
+ if Sym_Policy = Controlled or else Sym_Policy = Restricted then
Success := False;
return;
end if;
end loop;
- -- Append additional symbols, if any, to the Original_Symbols table
+ if Sym_Policy /= Restricted then
- for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
- S_Data := Complete_Symbols.Table (Index);
+ -- Append additional symbols, if any, to the Original_Symbols
+ -- table.
- if S_Data.Present then
+ for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
+ S_Data := Complete_Symbols.Table (Index);
- if Sym_Policy = Controlled then
- Put_Line ("symbol """ & S_Data.Name.all &
- """ is not in the reference symbol file");
- Success := False;
- return;
+ if S_Data.Present then
- elsif Soft_Minor_ID then
- Minor_ID := Minor_ID + 1;
- Soft_Minor_ID := False;
+ 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;
- 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 the symbol file
+ Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
- Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
+ Put (File, Case_Sensitive);
+ Put_Line (File, "yes");
- Put (File, Case_Sensitive);
- Put_Line (File, "yes");
+ -- Put a line in the symbol file for each symbol in the symbol
+ -- table.
- -- 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);
- 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);
- if Original_Symbols.Table (Index).Kind = Data then
- Put_Line (File, Equal_Data);
+ else
+ Put_Line (File, Equal_Procedure);
+ end if;
- else
- Put_Line (File, Equal_Procedure);
+ Free (Original_Symbols.Table (Index).Name);
end if;
+ end loop;
- Free (Original_Symbols.Table (Index).Name);
- end if;
- end loop;
-
- Put (File, Case_Sensitive);
- Put_Line (File, "NO");
+ Put (File, Case_Sensitive);
+ Put_Line (File, "NO");
- -- Put the version IDs
+ -- Put the version IDs
- Put (File, Gsmatch);
- Put (File, Image (Major_ID));
- Put (File, ',');
- Put_Line (File, Image (Minor_ID));
+ Put (File, Gsmatch);
+ Put (File, Image (Major_ID));
+ Put (File, ',');
+ Put_Line (File, Image (Minor_ID));
- -- And we are done
+ -- And we are done
- Close (File);
+ Close (File);
- -- Reset both tables
+ -- Reset both tables
- Symbol_Table.Set_Last (Original_Symbols, 0);
- Symbol_Table.Set_Last (Complete_Symbols, 0);
+ Symbol_Table.Set_Last (Original_Symbols, 0);
+ Symbol_Table.Set_Last (Complete_Symbols, 0);
- -- Clear the symbol file name
+ -- Clear the symbol file name
- Free (Symbol_File_Name);
+ Free (Symbol_File_Name);
+ end if;
Success := True;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
-- all symbols are already found in the reference file or with an
-- incremented minor ID, if not.
- Controlled);
+ Controlled,
-- Fail if symbols are not the same as those in the reference file
+ Restricted);
+ -- Restrict the symbols to those in the symbol file. Fail if some
+ -- symbols in the symbol file are not exported from the object files.
+
type Symbol_Kind is (Data, Proc);
-- To distinguish between the different kinds of symbols
projects / gcc.git / commitdiff