* 3zsoccon.ads: Fix multicast options.
* s-thread.ads: Move unchecked conversion from ATSD_Access to Address
in the spec.
2004-03-15 Robert Dewar <dewar@gnat.com>
* sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when
pragma used for a private type.
* lib-xref.adb (Generate_Reference): Do not generate warning if
reference is in a different unit from the pragma Unreferenced.
* 5vtpopde.adb: Minor reformatting
Fix casing of To_Task_ID
* sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing
flag if we have an unchecked conversion to an access type in the same
unit.
2004-03-15 Geert Bosch <bosch@gnat.com>
* a-ngcoty.adb (Modulus): In alternate formula for large real or
imaginary parts, use Double precision throughout.
* a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only
we want to be able to compile run-time with -gnata for testing, but
this may also be instantiated in user code that is compiled with -gnata.
2004-03-15 Olivier Hainque <hainque@act-europe.fr>
* s-stalib.ads (Exception_Code): New type, to represent Import/Export
codes. Having a separate type for this is useful to enforce consistency
throughout the various run-time units.
(Exception_Data): Use Exception_Code for Import_Code.
* s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of
Natural and Integer in various places.
(Register_VMS_Exception): Use Base_Code_In to compute the exception code
with the severity bits masked off.
(Register_VMS_Exception): Handle the additional exception data pointer
argument.
* raise.c (_GNAT_Exception structure): Remove the handled_by_others
component, now reflected by an exported accessor.
(is_handled_by): New routine to compute whether the propagated
occurrence matches some handler choice specification. Extracted out of
get_action_description_for, and expanded to take care of the VMS
specifities.
(get_action_description_for): Use is_handled_by instead of an explicit
complex condition to decide if the current choice at hand catches the
propagated occurrence.
* raise.h (Exception_Code): New type for C.
* rtsfind.ads (RE_Id, RE_Unit_Table): Add
System.Standard_Library.Exception_Code, to allow references from the
pragma import/export expander.
* a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For):
New accessors to allow easy access to GNAT exception data
characteristics.
(GNAT_GCC_Exception record, Propagate_Exception): Get rid of the
redundant Handled_By_Others component, helper for the personality
routine which will now be able to call the appropriate exception data
accessor instead.
* cstand.adb (Create_Standard): Adjust the type of the Import_Code
component of Standard_Exception_Type to be the closest possible to
Exception_Code in System.Standard_Library, that we cannot get at this
point. Expand a ??? comment to notify that this type node should
probably be rewritten later on.
* exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the
registration call to include a pointer to the exception object in the
arguments.
* init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In
instead of int and explicit bitmasks.
2004-03-15 Vincent Celier <celier@gnat.com>
* vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED
equivalent to /STATIC and /NOSTATIC equivalent to /SHARED.
* a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no
longer needed now that it is in the spec of
System.Tasking.Task_Attributes.
* adaint.h, adaint.c: (__gnat_create_output_file): New function
* gnatcmd.adb: Fix bug introduced in previous rev: /= instead of =
* g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function.
* make.adb (Gnatmake): Do not check the executable suffix; it is being
taken care of in Scan_Make_Arg.
(Scan_Make_Arg): Add the executable suffix only if the argument
following -o, in canonical case, does not end with the executable
suffix. When in verbose mode and executable file name does not end
with executable suffix, output the executable name, in canonical case.
* s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing
to avoid warnings when instantiating Ada.Task_Attributes.
Minor reformating.
* mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries
in the correct order.
* prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but
redirect standard output and error to a file for the invocation of the
compiler, then read the file.
* prj-nmsc.adb (Find_Sources): Use the Display_Value for each
directory, instead of the Value.
(Find_Source_Dirs): Remove useless code & comments.
2004-03-15 Ed Schonberg <schonberg@gnat.com>
* exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a
tagged type is inherited, and the parent operation is not frozen yet,
force generation of a freeze node for the inherited operation, so the
corresponding dispatch entry is properly initialized.
(Make_Predefined_Primitive_Specs): Check that return type is Boolean
when looking for user-defined equality operation.
* exp_ch4.adb (Expand_Composite_Equality): Check that return type is
boolean when locating primitive equality of tagged component.
* exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a
bit-aligned field and the right-hand side a string literal, introduce
a temporary before expanding assignment into a loop.
* exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for
priority in full, to ensure that any expanded subepxressions of it are
elaborated in the scope of the init_proc.
* exp_prag.adb (Expand_Pragma_Import): Search for initialization call
after object declaration, skipping over code that may have been
generated for validity checks.
* sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown
discriminants, ignore the known discriminants of its full view, if
any, to check legality.
* sem_ch3.adb (Complete_Private_Subtype): Do not create constrained
component if type has unknown discriminants.
(Analyze_Private_Extension_Declaration): Discriminant constraint is
null if type has unknown discriminants.
* sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference
for end label when present.
* s-fileio.adb (Open): When called with a C_Stream, use given name for
temporary file, rather than an empty string.
2004-03-15 Ed Falis <falis@gnat.com>
* s-thread.adb: Removed, no longer used.
2004-03-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (target.h): Now include.
(gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE
in new build_pointer_from_mode calls for non-fat/non-thin pointer.
(validate_size): For POINTER_TYPE, get smallest size permitted on
machine.
* fe.h: Sort Einfo decls and add Set_Mechanism.
* Makefile.in: (LIBGNAT_SRCS): Remove types.h.
(ada/decl.o): Depends on target.h.
* trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use
FUNCTION_BOUNDARY; always use TYPE_ALIGN.
2004-03-15 Thomas Quinot <quinot@act-europe.fr>
* 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID.
* exp_ch4.adb (Expand_N_Indexed_Component): Do not call
Insert_Dereference_Action when rewriting an implicit dereference into
an explicit one, this will be taken care of during expansion of the
explicit dereference.
(Expand_N_Slice): Same. Always do the rewriting, even for the case
of non-packed slices, since the dereference action generated by
expansion of the explicit dereference is needed in any case.
(Expand_N_Selected_Component): When rewriting an implicit dereference,
analyze and resolve the rewritten explicit dereference so it is seen
by the expander.
(Insert_Dereference_Action): This procedure is now called only for the
expansion of an N_Explcit_Dereference_Node. Do insert a check even for
dereferences that do not come from source (including explicit
dereferences resulting from rewriting implicit ones), but do not
recursively insert a check for the dereference nodes contained within
the check.
(Insert_Dereference_Action): Clarify and correct comment.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@79494
138bc75d-0d04-0410-961f-
82ee72b054a4
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
SO_LINGER : constant := 128; -- Defer close to flush data
SO_ERROR : constant := 4103; -- Get/clear error status
SO_BROADCAST : constant := 32; -- Can send broadcast msgs
- IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group
- IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group
- IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL
- IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback
+ IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback
end GNAT.Sockets.Constants;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- If the key value is Null, then it is a non-Ada task.
if Value /= System.Null_Address then
- return To_Task_Id (Value);
+ return To_Task_ID (Value);
else
return Register_Foreign_Thread;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2004 Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
procedure Interrupt_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
- AST_Self_ID : Task_ID := To_Task_Id (ID);
-
+ AST_Self_ID : Task_ID := To_Task_ID (ID);
begin
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
procedure Starlet_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
- AST_Self_ID : Task_ID := To_Task_Id (ID);
-
+ AST_Self_ID : Task_ID := To_Task_ID (ID);
begin
AST_Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
procedure Task_Synch is
Synch_Self_ID : constant Task_ID := Self;
+
begin
if Single_Lock then
Lock_RTS;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
function Self return Task_ID is
begin
- return To_Task_Id (ATCB_Key);
+ return To_Task_ID (ATCB_Key);
end Self;
end Specific;
+2004-03-15 Jerome Guitton <guitton@act-europe.fr>
+
+ * 3zsoccon.ads: Fix multicast options.
+
+ * s-thread.ads: Move unchecked conversion from ATSD_Access to Address
+ in the spec.
+
+2004-03-15 Robert Dewar <dewar@gnat.com>
+
+ * sem_prag.adb: Make sure No_Strict_Aliasing flag is set right when
+ pragma used for a private type.
+
+ * lib-xref.adb (Generate_Reference): Do not generate warning if
+ reference is in a different unit from the pragma Unreferenced.
+
+ * 5vtpopde.adb: Minor reformatting
+ Fix casing of To_Task_ID
+
+ * sem_ch13.adb (Validate_Unchecked_Conversion): Set No_Strict_Aliasing
+ flag if we have an unchecked conversion to an access type in the same
+ unit.
+
+2004-03-15 Geert Bosch <bosch@gnat.com>
+
+ * a-ngcoty.adb (Modulus): In alternate formula for large real or
+ imaginary parts, use Double precision throughout.
+
+ * a-tifiio.adb (Put_Scaled): Remove remaining pragma Debug. Not only
+ we want to be able to compile run-time with -gnata for testing, but
+ this may also be instantiated in user code that is compiled with -gnata.
+
+2004-03-15 Olivier Hainque <hainque@act-europe.fr>
+
+ * s-stalib.ads (Exception_Code): New type, to represent Import/Export
+ codes. Having a separate type for this is useful to enforce consistency
+ throughout the various run-time units.
+ (Exception_Data): Use Exception_Code for Import_Code.
+
+ * s-vmextra.ads, s-vmexta.adb: Use Exception_Code instead of a mix of
+ Natural and Integer in various places.
+ (Register_VMS_Exception): Use Base_Code_In to compute the exception code
+ with the severity bits masked off.
+ (Register_VMS_Exception): Handle the additional exception data pointer
+ argument.
+
+ * raise.c (_GNAT_Exception structure): Remove the handled_by_others
+ component, now reflected by an exported accessor.
+ (is_handled_by): New routine to compute whether the propagated
+ occurrence matches some handler choice specification. Extracted out of
+ get_action_description_for, and expanded to take care of the VMS
+ specifities.
+ (get_action_description_for): Use is_handled_by instead of an explicit
+ complex condition to decide if the current choice at hand catches the
+ propagated occurrence.
+
+ * raise.h (Exception_Code): New type for C.
+
+ * rtsfind.ads (RE_Id, RE_Unit_Table): Add
+ System.Standard_Library.Exception_Code, to allow references from the
+ pragma import/export expander.
+
+ * a-exexpr.adb (Is_Handled_By_Others, Language_For, Import_Code_For):
+ New accessors to allow easy access to GNAT exception data
+ characteristics.
+ (GNAT_GCC_Exception record, Propagate_Exception): Get rid of the
+ redundant Handled_By_Others component, helper for the personality
+ routine which will now be able to call the appropriate exception data
+ accessor instead.
+
+ * cstand.adb (Create_Standard): Adjust the type of the Import_Code
+ component of Standard_Exception_Type to be the closest possible to
+ Exception_Code in System.Standard_Library, that we cannot get at this
+ point. Expand a ??? comment to notify that this type node should
+ probably be rewritten later on.
+
+ * exp_prag.adb (Expand_Pragma_Import_Export_Exception): Adjust the
+ registration call to include a pointer to the exception object in the
+ arguments.
+
+ * init.c (__gnat_error_handler): Use Exception_Code and Base_Code_In
+ instead of int and explicit bitmasks.
+
+2004-03-15 Vincent Celier <celier@gnat.com>
+
+ * vms_data.ads: Add new GNAT BIND qualifier /STATIC. Makes /NOSHARED
+ equivalent to /STATIC and /NOSTATIC equivalent to /SHARED.
+
+ * a-tasatt.adb (To_Access_Code): Remove this UC instantiation, no
+ longer needed now that it is in the spec of
+ System.Tasking.Task_Attributes.
+
+ * adaint.h, adaint.c: (__gnat_create_output_file): New function
+
+ * gnatcmd.adb: Fix bug introduced in previous rev: /= instead of =
+
+ * g-os_lib.ads, g-os_lib.adb (Create_Output_Text_File): New function.
+
+ * make.adb (Gnatmake): Do not check the executable suffix; it is being
+ taken care of in Scan_Make_Arg.
+ (Scan_Make_Arg): Add the executable suffix only if the argument
+ following -o, in canonical case, does not end with the executable
+ suffix. When in verbose mode and executable file name does not end
+ with executable suffix, output the executable name, in canonical case.
+
+ * s-tataat.ads (Access_Dummy_Wrapper): Add pragma No_Strict_Aliasing
+ to avoid warnings when instantiating Ada.Task_Attributes.
+ Minor reformating.
+
+ * mlib-prj.adb (Process_Imported_Libraries): Get the imported libraries
+ in the correct order.
+
+ * prj-makr.adb (Process_Directory): No longer use GNAT.Expect, but
+ redirect standard output and error to a file for the invocation of the
+ compiler, then read the file.
+
+ * prj-nmsc.adb (Find_Sources): Use the Display_Value for each
+ directory, instead of the Value.
+ (Find_Source_Dirs): Remove useless code & comments.
+
+2004-03-15 Ed Schonberg <schonberg@gnat.com>
+
+ * exp_ch3.adb (Freeze_Record_Type): If a primitive operation of a
+ tagged type is inherited, and the parent operation is not frozen yet,
+ force generation of a freeze node for the inherited operation, so the
+ corresponding dispatch entry is properly initialized.
+ (Make_Predefined_Primitive_Specs): Check that return type is Boolean
+ when looking for user-defined equality operation.
+
+ * exp_ch4.adb (Expand_Composite_Equality): Check that return type is
+ boolean when locating primitive equality of tagged component.
+
+ * exp_ch5.adb (Expand_Assign_Array): If the left-hand side is a
+ bit-aligned field and the right-hand side a string literal, introduce
+ a temporary before expanding assignment into a loop.
+
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration): Copy expression for
+ priority in full, to ensure that any expanded subepxressions of it are
+ elaborated in the scope of the init_proc.
+
+ * exp_prag.adb (Expand_Pragma_Import): Search for initialization call
+ after object declaration, skipping over code that may have been
+ generated for validity checks.
+
+ * sem_ch12.adb (Validate_Private_Type_Instance): If type has unknown
+ discriminants, ignore the known discriminants of its full view, if
+ any, to check legality.
+
+ * sem_ch3.adb (Complete_Private_Subtype): Do not create constrained
+ component if type has unknown discriminants.
+ (Analyze_Private_Extension_Declaration): Discriminant constraint is
+ null if type has unknown discriminants.
+
+ * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Generate reference
+ for end label when present.
+
+ * s-fileio.adb (Open): When called with a C_Stream, use given name for
+ temporary file, rather than an empty string.
+
+2004-03-15 Ed Falis <falis@gnat.com>
+
+ * s-thread.adb: Removed, no longer used.
+
+2004-03-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
+
+ * decl.c (target.h): Now include.
+ (gnat_to_gnu_entity, case E_Access_Type): Use mode derived from ESIZE
+ in new build_pointer_from_mode calls for non-fat/non-thin pointer.
+ (validate_size): For POINTER_TYPE, get smallest size permitted on
+ machine.
+
+ * fe.h: Sort Einfo decls and add Set_Mechanism.
+
+ * Makefile.in: (LIBGNAT_SRCS): Remove types.h.
+ (ada/decl.o): Depends on target.h.
+
+ * trans.c (tree_transform, N_Unchecked_Type_Conversion): Do not use
+ FUNCTION_BOUNDARY; always use TYPE_ALIGN.
+
+2004-03-15 Thomas Quinot <quinot@act-europe.fr>
+
+ * 5ztpopsp.adb, 56tpopsp.adb: Fix spelling of Task_ID.
+
+ * exp_ch4.adb (Expand_N_Indexed_Component): Do not call
+ Insert_Dereference_Action when rewriting an implicit dereference into
+ an explicit one, this will be taken care of during expansion of the
+ explicit dereference.
+ (Expand_N_Slice): Same. Always do the rewriting, even for the case
+ of non-packed slices, since the dereference action generated by
+ expansion of the explicit dereference is needed in any case.
+ (Expand_N_Selected_Component): When rewriting an implicit dereference,
+ analyze and resolve the rewritten explicit dereference so it is seen
+ by the expander.
+ (Insert_Dereference_Action): This procedure is now called only for the
+ expansion of an N_Explcit_Dereference_Node. Do insert a check even for
+ dereferences that do not come from source (including explicit
+ dereferences resulting from rewriting implicit ones), but do not
+ recursively insert a check for the dereference nodes contained within
+ the check.
+ (Insert_Dereference_Action): Clarify and correct comment.
+
2004-03-08 Paolo Bonzini <bonzini@gnu.org>
PR ada/14131
ada/elists.h ada/nlists.h ada/fe.h ada/gigi.h
ada/decl.o : ada/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
- flags.h toplev.h convert.h ada/ada.h ada/types.h ada/atree.h ada/nlists.h \
- ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/snames.h ada/namet.h \
- ada/stringt.h ada/repinfo.h ada/fe.h $(ADA_TREE_H) ada/gigi.h gt-ada-decl.h
+ flags.h toplev.h convert.h target.h ada/ada.h ada/types.h ada/atree.h \
+ ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/snames.h \
+ ada/namet.h ada/stringt.h ada/repinfo.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \
+ gt-ada-decl.h
ada/misc.o : ada/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
$(RTL_H) expr.h insn-codes.h insn-flags.h insn-config.h recog.h flags.h \
# subdirectory and copied.
LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \
errno.c exit.c cal.c ctrl_c.c \
- raise.h raise.c sysdep.c types.h aux-io.c init.c \
+ raise.h raise.c sysdep.c aux-io.c init.c \
final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c \
$(EXTRA_LIBGNAT_SRCS)
-- --
-- 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- --
-- routine to determine if the context it examines contains a
-- handler for the exception beeing propagated.
- Handled_By_Others : Boolean;
- -- Is this exception handled by "when others" ? This is used by the
- -- personality routine to determine if an "others" handler in the
- -- context it examines may catch the exception beeing propagated.
-
N_Cleanups_To_Trigger : Integer;
-- Number of cleanup only frames encountered in SEARCH phase.
-- This is used to control the forced unwinding triggered when
function Remove
(Top : EOA;
- Excep : GNAT_GCC_Exception_Access)
- return Boolean;
+ 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.
UW_Eclass : Exception_Class;
UW_Exception : access GNAT_GCC_Exception;
UW_Context : System.Address;
- UW_Argument : System.Address)
- return Unwind_Reason_Code;
+ UW_Argument : System.Address) return Unwind_Reason_Code;
-- Hook called at each step of the forced unwinding we perform to
-- trigger cleanups found during the propagation of an unhandled
-- exception.
UW_Argument : System.Address);
pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
+ ------------------------------------------------------------
+ -- Accessors to basic components of a GNAT exception data --
+ ------------------------------------------------------------
+
+ -- As of today, these are only used by the C implementation of the
+ -- propagation personality routine to avoid having to rely on a C
+ -- counterpart of the whole exception_data structure, which is both
+ -- painful and error prone. These subprograms could be moved to a
+ -- more widely visible location if need be.
+
+ function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
+ pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
+
+ function Language_For (E : Exception_Data_Ptr) return Character;
+ pragma Export (C, Language_For, "__gnat_language_for");
+
+ function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
+ pragma Export (C, Import_Code_For, "__gnat_import_code_for");
+
------------
-- Remove --
------------
function Remove
(Top : EOA;
- Excep : GNAT_GCC_Exception_Access)
- return Boolean
+ Excep : GNAT_GCC_Exception_Access) return Boolean
is
Prev : GNAT_GCC_Exception_Access := null;
Iter : EOA := Top;
UW_Eclass : Exception_Class;
UW_Exception : access GNAT_GCC_Exception;
UW_Context : System.Address;
- UW_Argument : System.Address)
- return Unwind_Reason_Code
+ UW_Argument : System.Address) return Unwind_Reason_Code
is
begin
-- Terminate as soon as we know there is nothing more to run. The
-- frame via Unwind_RaiseException below.
GCC_Exception.Id := Excep.Id;
- GCC_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
GCC_Exception.N_Cleanups_To_Trigger := 0;
-- Compute the backtrace for this occurrence if the corresponding
Unhandled_Exception_Terminate;
end Propagate_Exception;
+ ---------------------
+ -- Import_Code_For --
+ ---------------------
+
+ function Import_Code_For
+ (E : SSL.Exception_Data_Ptr) return Exception_Code
+ is
+ begin
+ return E.all.Import_Code;
+ end Import_Code_For;
+
+ --------------------------
+ -- Is_Handled_By_Others --
+ --------------------------
+
+ function Is_Handled_By_Others
+ (E : SSL.Exception_Data_Ptr) return Boolean
+ is
+ begin
+ return not E.all.Not_Handled_By_Others;
+ end Is_Handled_By_Others;
+
+ ------------------
+ -- Language_For --
+ ------------------
+
+ function Language_For
+ (E : SSL.Exception_Data_Ptr) return Character
+ is
+ begin
+ return E.all.Lang;
+ end Language_For;
+
-----------
-- Notes --
-----------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 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- --
-- we can use an explicit comparison to determine whether to use
-- the scaling expression.
+ -- The scaling expression is computed in double format throughout
+ -- in order to prevent inaccuracies on machines where not all
+ -- immediate expressions are rounded, such as PowerPC.
+
if Re2 > R'Last then
raise Constraint_Error;
end if;
exception
when Constraint_Error =>
- return abs (X.Re)
- * R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2)));
+ return R (Double (abs (X.Re))
+ * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2));
end;
begin
exception
when Constraint_Error =>
- return abs (X.Im)
- * R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2)));
+ return R (Double (abs (X.Im))
+ * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2));
end;
-- Now deal with cases of underflow. If only one of the squares
else
if abs (X.Re) > abs (X.Im) then
return
- abs (X.Re)
- * R (Sqrt (Double (R (1.0) + (X.Im / X.Re) ** 2)));
+ R (Double (abs (X.Re))
+ * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2));
else
return
- abs (X.Im)
- * R (Sqrt (Double (R (1.0) + (X.Re / X.Im) ** 2)));
+ R (Double (abs (X.Im))
+ * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2));
end if;
end if;
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2003, Ada Core Technologies --
+-- Copyright (C) 1995-2004, Ada Core Technologies --
-- --
-- GNARL 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- --
(Access_Node, Access_Address);
-- To store pointer to list of indirect attributes
- function To_Access_Node is new Unchecked_Conversion
- (Access_Address, Access_Node);
- -- To fetch pointer to list of indirect attributes
-
pragma Warnings (Off);
function To_Access_Wrapper is new Unchecked_Conversion
(Access_Dummy_Wrapper, Access_Wrapper);
-- --
-- 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- --
+ Boolean'Pos (not Exact)
* (Scale - 1);
-
procedure Put_Character (C : Character);
pragma Inline (Put_Character);
-- Add C to the output string To, updating Last
E : Integer)
is
N : constant Natural := (A + Max_Digits - 1) / Max_Digits + 1;
- pragma Debug (Put_Line ("N =" & N'Img));
Q : array (1 .. N) of Int64 := (others => 0);
XX : Int64 := X;
}
int
+__gnat_create_output_file (char *path)
+{
+ int fd;
+#if defined (VMS)
+ fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM,
+ "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk",
+ "shr=del,get,put,upd");
+#else
+ fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM);
+#endif
+
+ return fd < 0 ? -1 : fd;
+}
+
+int
__gnat_open_append (char *path, int fmode)
{
int fd;
* *
* C Header File *
* *
- * 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- *
extern int __gnat_open_read (char *, int);
extern int __gnat_open_rw (char *, int);
extern int __gnat_open_create (char *, int);
+extern int __gnat_create_output_file (char *);
extern int __gnat_open_append (char *, int);
extern long __gnat_file_length (int);
extern void __gnat_tmp_name (char *);
-- Build standard exception type. Note that the type name here is
-- actually used in the generated code, so it must be set correctly
+ -- ??? Also note that the Import_Code component is now declared
+ -- as a System.Standard_Library.Exception_Code to enforce run-time
+ -- library implementation consistency. It's too early here to resort
+ -- to rtsfind to get the proper node for that type, so we use the
+ -- closest possible available type node at hand instead. We should
+ -- probably be fixing this up at some point.
+
Standard_Exception_Type := New_Standard_Entity;
Set_Ekind (Standard_Exception_Type, E_Record_Type);
Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
"Full_Name");
Make_Component (Standard_Exception_Type, Standard_A_Char,
"HTable_Ptr");
- Make_Component (Standard_Exception_Type, Standard_Integer,
+ Make_Component (Standard_Exception_Type, Standard_Unsigned,
"Import_Code");
Make_Component (Standard_Exception_Type, Standard_A_Char,
"Raise_Hook");
#include "convert.h"
#include "ggc.h"
#include "obstack.h"
+#include "target.h"
#include "ada.h"
#include "types.h"
int got_fat_p = 0;
int made_dummy = 0;
tree gnu_desig_type = 0;
+ enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
+
+ if (!targetm.valid_pointer_mode (p_mode))
+ p_mode = ptr_mode;
if (No (gnat_desig_full)
&& (Ekind (gnat_desig_type) == E_Class_Wide_Type
}
else if (gnat_desig_type == gnat_entity)
{
- gnu_type = build_pointer_type (make_node (VOID_TYPE));
+ gnu_type = build_pointer_type_for_mode (make_node (VOID_TYPE),
+ p_mode);
TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
}
else
}
}
- gnu_type = build_pointer_type (gnu_desig_type);
+ gnu_type = build_pointer_type_for_mode (gnu_desig_type, p_mode);
}
/* If we are not defining this object and we made a dummy pointer,
it means that a size of zero should be treated as an unspecified size. */
static tree
-validate_size (Uint uint_size,
- tree gnu_type,
- Entity_Id gnat_object,
- enum tree_code kind,
- int component_p,
- int zero_ok)
+validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
+ enum tree_code kind, int component_p, int zero_ok)
{
Node_Id gnat_error_node;
tree type_size
else if (TYPE_FAT_POINTER_P (gnu_type))
type_size = bitsize_int (POINTER_SIZE);
+ /* If this is an access type, the minimum size is that given by the smallest
+ integral mode that's valid for pointers. */
+ if (TREE_CODE (gnu_type) == POINTER_TYPE)
+ {
+ enum machine_mode p_mode;
+
+ for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
+ !targetm.valid_pointer_mode (p_mode);
+ p_mode = GET_MODE_WIDER_MODE (p_mode))
+ ;
+
+ type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
+ }
+
/* If the size of the object is a constant, the new size must not be
smaller. */
if (TREE_CODE (type_size) != INTEGER_CST
-- (usually the inherited primitive address is inserted in the
-- DT by Inherit_DT)
- if Is_CPP_Class (Etype (Def_Id)) then
- declare
- Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
- Subp : Entity_Id;
+ -- Similarly, if this is an inherited operation whose parent
+ -- is not frozen yet, it is not in the DT of the parent, and
+ -- we generate an explicit freeze node for the inherited
+ -- operation, so that it is properly inserted in the DT of the
+ -- current type.
- begin
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ declare
+ Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id));
+ Subp : Entity_Id;
+
+ begin
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ if Present (Alias (Subp)) then
+ if Is_CPP_Class (Etype (Def_Id)) then
+ Set_Has_Delayed_Freeze (Subp);
- if Present (Alias (Subp)) then
+ elsif Has_Delayed_Freeze (Alias (Subp))
+ and then not Is_Frozen (Alias (Subp))
+ then
+ Set_Is_Frozen (Subp, False);
Set_Has_Delayed_Freeze (Subp);
end if;
+ end if;
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
+ end;
if Underlying_Type (Etype (Def_Id)) = Def_Id then
Expand_Tagged_Root (Def_Id);
N_Subprogram_Renaming_Declaration)
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
+ and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
then
Eq_Needed := False;
-- local access type to have a usable finalization list.
procedure Insert_Dereference_Action (N : Node_Id);
- -- N is an expression whose type is an access. When the type is derived
- -- from Checked_Pool, expands a call to the primitive 'dereference'.
+ -- N is an expression whose type is an access. When the type of the
+ -- associated storage pool is derived from Checked_Pool, generate a
+ -- call to the 'Dereference' primitive operation.
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Eq_Op := Node (Prim);
exit when Chars (Eq_Op) = Name_Op_Eq
and then Etype (First_Formal (Eq_Op)) =
- Etype (Next_Formal (First_Formal (Eq_Op)));
+ Etype (Next_Formal (First_Formal (Eq_Op)))
+ and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
-- was necessary, but it cleans up the code to do it all the time.
if Is_Access_Type (T) then
-
- -- Check whether the prefix comes from a debug pool, and generate
- -- the check before rewriting.
-
- Insert_Dereference_Action (P);
-
Rewrite (P,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (P)));
if Is_Access_Type (Ptyp) then
Insert_Explicit_Dereference (P);
+ Analyze_And_Resolve (P, Designated_Type (Ptyp));
if Ekind (Etype (P)) = E_Private_Subtype
and then Is_For_Access_Subtype (Etype (P))
if Is_Access_Type (Ptp) then
- -- Check for explicit dereference required for checked pool
-
- Insert_Dereference_Action (Pfx);
-
- -- If we have an access to a packed array type, then put in an
- -- explicit dereference. We do this in case the slice must be
- -- expanded, and we want to make sure we get an access check.
-
Ptp := Designated_Type (Ptp);
- if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
- Rewrite (Pfx,
- Make_Explicit_Dereference (Sloc (N),
- Prefix => Relocate_Node (Pfx)));
+ Rewrite (Pfx,
+ Make_Explicit_Dereference (Sloc (N),
+ Prefix => Relocate_Node (Pfx)));
- Analyze_And_Resolve (Pfx, Ptp);
- end if;
+ Analyze_And_Resolve (Pfx, Ptp);
end if;
-- Range checks are potentially also needed for cases involving
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
+ Pnod : constant Node_Id := Parent (N);
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
-- Return true if type of P is derived from Checked_Pool;
-- Start of processing for Insert_Dereference_Action
begin
- if not Comes_From_Source (Parent (N)) then
+ pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
+
+ -- Do not recursively add a dereference check for the
+ -- attribute references contained within the generated check.
+
+ if not Comes_From_Source (Pnod)
+ and then Nkind (Pnod) = N_Explicit_Dereference
+ and then Nkind (Parent (Pnod)) = N_Attribute_Reference
+ and then (Attribute_Name (Parent (Pnod)) = Name_Size
+ or else Attribute_Name (Parent (Pnod)) = Name_Alignment)
+ then
return;
elsif not Is_Checked_Storage_Pool (Pool) then
end if;
end if;
- -- Come here to compelete the analysis
+ -- If the right-hand side is a string literal, introduce a temporary
+ -- for it, for use in the generated loop that will follow.
+
+ if Nkind (Rhs) = N_String_Literal then
+ declare
+ Temp : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_T);
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (L_Type, Loc),
+ Expression => Relocate_Node (Rhs));
+
+ Insert_Action (N, Decl);
+ Rewrite (Rhs, New_Occurrence_Of (Temp, Loc));
+ R_Type := Etype (Temp);
+ end;
+ end if;
+
+ -- Come here to complete the analysis
-- Loop_Required: Set to True if we know that a loop is required
-- regardless of overlap considerations.
Expr := Expression (Expr);
end if;
- Expr := New_Copy (Expr);
+ Expr := New_Copy_Tree (Expr);
-- Add conversion to proper type to do range check if required
-- Note that for runtime units, we allow out of range interrupt
-- --
-- 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- --
-- When applied to a variable, the default initialization must not be
-- done. As it is already done when the pragma is found, we just get rid
-- of the call the initialization procedure which followed the object
- -- declaration.
+ -- declaration. The call is inserted after the declaration, but validity
+ -- checks may also have been inserted and the initialization call does
+ -- not necessarily appear immediately after the object declaration.
-- We can't use the freezing mechanism for this purpose, since we
-- have to elaborate the initialization expression when it is first
procedure Expand_Pragma_Import (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N)));
Typ : Entity_Id;
- After_Def : Node_Id;
+ Init_Call : Node_Id;
begin
if Ekind (Def_Id) = E_Variable then
Typ := Etype (Def_Id);
- After_Def := Next (Parent (Def_Id));
- if Has_Non_Null_Base_Init_Proc (Typ)
- and then Nkind (After_Def) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (After_Def))
- and then Entity (Name (After_Def)) = Base_Init_Proc (Typ)
- then
- Remove (After_Def);
+ -- Loop to ???
+
+ Init_Call := Next (Parent (Def_Id));
+ while Present (Init_Call) and then Init_Call /= N loop
+ if Has_Non_Null_Base_Init_Proc (Typ)
+ and then Nkind (Init_Call) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (Init_Call))
+ and then Entity (Name (Init_Call)) = Base_Init_Proc (Typ)
+ then
+ Remove (Init_Call);
+ exit;
+ else
+ Next (Init_Call);
+ end if;
+ end loop;
-- Any default initialization expression should be removed
-- (e.g., null defaults for access objects, zero initialization
-- have explicit initialization, so the expression must have
-- been generated by the compiler.
- elsif Present (Expression (Parent (Def_Id))) then
+ if No (Init_Call)
+ and then Present (Expression (Parent (Def_Id)))
+ then
Set_Expression (Parent (Def_Id), Empty);
end if;
end if;
Make_Object_Declaration (Loc,
Defining_Identifier => Excep_Internal,
Object_Definition =>
- New_Reference_To (Standard_Integer, Loc));
+ New_Reference_To (RTE (RE_Exception_Code), Loc));
Insert_Action (N, Excep_Object);
Analyze (Excep_Object);
else
Code :=
- Unchecked_Convert_To (Standard_Integer,
+ Unchecked_Convert_To (RTE (RE_Exception_Code),
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Import_Value), Loc),
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To
(RTE (RE_Register_VMS_Exception), Loc),
- Parameter_Associations => New_List (Code)));
-
- Analyze_And_Resolve (Code, Standard_Integer);
+ Parameter_Associations => New_List (
+ Code,
+ Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access)))));
+
+ Analyze_And_Resolve (Code, RTE (RE_Exception_Code));
Analyze (Call);
end if;
Present_Expr for N_Variant nodes. */
#define Set_Alignment einfo__set_alignment
-#define Set_Esize einfo__set_esize
-#define Set_RM_Size einfo__set_rm_size
#define Set_Component_Bit_Offset einfo__set_component_bit_offset
#define Set_Component_Size einfo__set_component_size
+#define Set_Esize einfo__set_esize
+#define Set_Mechanism einfo__set_mechanism
+#define Set_RM_Size einfo__set_rm_size
#define Set_Present_Expr sinfo__set_present_expr
extern void Set_Alignment (Entity_Id, Uint);
+extern void Set_Component_Bit_Offset (Entity_Id, Uint);
extern void Set_Component_Size (Entity_Id, Uint);
extern void Set_Esize (Entity_Id, Uint);
+extern void Set_Mechanism (Entity_Id, Mechanism_Type);
extern void Set_RM_Size (Entity_Id, Uint);
-extern void Set_Component_Bit_Offset (Entity_Id, Uint);
extern void Set_Present_Expr (Node_Id, Uint);
/* Test if the node N is the name of an entity (i.e. is an identifier,
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2004 Ada Core Technologies, 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- --
return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
end Create_New_File;
+ -----------------------------
+ -- Create_Output_Text_File --
+ -----------------------------
+
+ function Create_Output_Text_File (Name : String) return File_Descriptor is
+ function C_Create_File
+ (Name : C_File_Name) return File_Descriptor;
+ pragma Import (C, C_Create_File, "__gnat_create_output_file");
+
+ C_Name : String (1 .. Name'Length + 1);
+
+ begin
+ C_Name (1 .. Name'Length) := Name;
+ C_Name (C_Name'Last) := ASCII.NUL;
+ return C_Create_File (C_Name (C_Name'First)'Address);
+ end Create_Output_Text_File;
+
----------------------
-- Create_Temp_File --
----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
Fmode : Mode) return File_Descriptor;
-- Creates new file with given name for writing, returning file descriptor
-- for subsequent use in Write calls. File descriptor returned is
- -- Invalid_FD if file cannot be successfully created
+ -- Invalid_FD if file cannot be successfully created.
+
+ function Create_Output_Text_File (Name : String) return File_Descriptor;
+ -- Creates new text file with given name suitable to redirect standard
+ -- output, returning file descriptor. File descriptor returned is
+ -- Invalid_FD if file cannot be successfully created.
function Create_New_File
(Name : String;
-- Check if there is at least one argument that is not a switch
for Index in 1 .. Last_Switches.Last loop
- if Last_Switches.Table (Index)(1) = '-' then
+ if Last_Switches.Table (Index)(1) /= '-' then
Add_Sources := False;
exit;
end if;
extern struct Exception_Data Non_Ada_Error;
#define Coded_Exception system__vms_exception_table__coded_exception
-extern struct Exception_Data *Coded_Exception (int);
+extern struct Exception_Data *Coded_Exception (Exception_Code);
+
+#define Base_Code_In system__vms_exception_table__base_code_in
+extern Exception_Code Base_Code_In (Exception_Code);
#endif
/* Define macro symbols for the VMS conditions that become Ada exceptions.
__gnat_error_handler (int *sigargs, void *mechargs)
{
struct Exception_Data *exception = 0;
+ Exception_Code base_code;
+
char *msg = "";
char message[256];
long prvhnd;
}
#ifdef IN_RTS
- /* See if it's an imported exception. Mask off severity bits. */
- exception = Coded_Exception (sigargs[1] & 0xfffffff8);
+ /* See if it's an imported exception. Beware that registered exceptions
+ are bound to their base code, with the severity bits masked off. */
+ base_code = Base_Code_In ((Exception_Code) sigargs [1]);
+ exception = Coded_Exception (base_code);
+
if (exception)
{
msgdesc.len = 256;
exception->Name_Length = 19;
/* The full name really should be get sys$getmsg returns. ??? */
exception->Full_Name = "IMPORTED_EXCEPTION";
- exception->Import_Code = sigargs[1] & 0xfffffff8;
+ exception->Import_Code = base_code;
}
#endif
Set_Referenced (E);
end if;
- -- Check for pragma Unreferenced given
-
- if Has_Pragma_Unreferenced (E) then
+ -- Check for pragma Unreferenced given and reference is within
+ -- this source unit (occasion for possible warning to be issued)
+ if Has_Pragma_Unreferenced (E)
+ and then In_Same_Extended_Unit (Sloc (E), Sloc (N))
+ then
-- A reference as a named parameter in a call does not count
-- as a violation of pragma Unreferenced for this purpose.
Table_Name => "Make.Q");
-- This is the actual Q.
-
-- Package Mains is used to store the mains specified on the command line
-- and to retrieve them when a project file is used, to verify that the
-- files exist and that they belong to a project file.
Name_Len := Linker_Switches.Table (J + 1)'Length;
Name_Buffer (1 .. Name_Len) :=
Linker_Switches.Table (J + 1).all;
-
- -- Put in canonical case to detect suffixs such as ".EXE" on
- -- Windows or VMS.
-
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- -- If target has an executable suffix and it has not been
- -- specified then it is added here.
-
- if Executable_Suffix'Length /= 0
- and then Name_Buffer
- (Name_Len - Executable_Suffix'Length + 1 .. Name_Len)
- /= Executable_Suffix
- then
- -- Get back the original name to keep the case on Windows
-
- Name_Buffer (1 .. Name_Len) :=
- Linker_Switches.Table (J + 1).all;
-
- -- Add the executable suffix
-
- Name_Buffer (Name_Len + 1 ..
- Name_Len + Executable_Suffix'Length) :=
- Executable_Suffix;
- Name_Len := Name_Len + Executable_Suffix'Length;
-
- else
- -- Get back the original name to keep the case on Windows
-
- Name_Buffer (1 .. Name_Len) :=
- Linker_Switches.Table (J + 1).all;
- end if;
-
Executable := Name_Enter;
Verbose_Msg (Executable, "final executable");
-- Automatically add the executable suffix if it has not been
-- specified explicitly.
- if Executable_Suffix'Length /= 0
- and then (Argv'Length <= Executable_Suffix'Length
- or else Argv (Argv'Last - Executable_Suffix'Length + 1
- .. Argv'Last) /= Executable_Suffix)
- then
- Add_Switch
- (Argv & Executable_Suffix,
- Linker,
- And_Save => And_Save);
- else
- Add_Switch (Argv, Linker, And_Save => And_Save);
- end if;
+ declare
+ Canonical_Argv : String := Argv;
+ begin
+ -- Get the file name in canonical case to accept as is
+ -- names ending with ".EXE" on VMS and Windows.
+
+ Canonical_Case_File_Name (Canonical_Argv);
+
+ if Executable_Suffix'Length /= 0
+ and then (Canonical_Argv'Length <= Executable_Suffix'Length
+ or else Canonical_Argv
+ (Canonical_Argv'Last -
+ Executable_Suffix'Length + 1
+ .. Canonical_Argv'Last)
+ /= Executable_Suffix)
+ then
+ Add_Switch
+ (Argv & Executable_Suffix,
+ Linker,
+ And_Save => And_Save);
+ else
+ Add_Switch (Argv, Linker, And_Save => And_Save);
+ end if;
+ end;
end if;
-- If the previous switch has set the Object_Directory_Present flag
if not Processed_Projects.Get (Data.Name) then
Processed_Projects.Set (Data.Name, True);
- -- If it is a library project, add it to Library_Projs
-
- if Project /= For_Project and then Data.Library then
- Library_Projs.Increment_Last;
- Library_Projs.Table (Library_Projs.Last) := Project;
- end if;
-
- -- Call Process_Project recursively for any imported project
+ -- Call Process_Project recursively for any imported project.
+ -- We first process the imported projects to guarantee that
+ -- we have a proper reverse order for the libraries.
while Imported /= Empty_Project_List loop
Element := Project_Lists.Table (Imported);
Imported := Element.Next;
end loop;
+
+ -- If it is a library project, add it to Library_Projs
+
+ if Project /= For_Project and then Data.Library then
+ Library_Projs.Increment_Last;
+ Library_Projs.Table (Library_Projs.Last) := Project;
+ end if;
+
end if;
end Process_Project;
-- Start of processing for Process_Imported_Libraries
begin
- -- Build list of library projects imported directly or indirectly
+ -- Build list of library projects imported directly or indirectly,
+ -- in the reverse order.
Process_Project (For_Project);
- -- If there are more that one library project file, make sure
- -- that if libA depends on libB, libB is first in order.
+ -- Add the -L and -l switches and, if the Rpath option is supported,
+ -- add the directory to the Rpath.
+ -- As the library projects are in the wrong order, process from the
+ -- last to the first.
- if Library_Projs.Last > 1 then
- declare
- Index : Integer := 1;
- Proj1 : Project_Id;
- Proj2 : Project_Id;
- List : Project_List := Empty_Project_List;
-
- begin
- Library_Loop : while Index < Library_Projs.Last loop
- Proj1 := Library_Projs.Table (Index);
- List := Projects.Table (Proj1).Imported_Projects;
-
- List_Loop : while List /= Empty_Project_List loop
- Proj2 := Project_Lists.Table (List).Project;
-
- for J in Index + 1 .. Library_Projs.Last loop
- if Proj2 = Library_Projs.Table (J) then
- Library_Projs.Table (J) := Proj1;
- Library_Projs.Table (Index) := Proj2;
- exit List_Loop;
- end if;
- end loop;
-
- List := Project_Lists.Table (List).Next;
- end loop List_Loop;
-
- if List = Empty_Project_List then
- Index := Index + 1;
- end if;
- end loop Library_Loop;
- end;
- end if;
-
- -- Now that we have a correct order, add the -L and -l switches and,
- -- if the Rpath option is supported, add the directory to the Rpath.
-
- for Index in 1 .. Library_Projs.Last loop
+ for Index in reverse 1 .. Library_Projs.Last loop
Current := Library_Projs.Table (Index);
+ Get_Name_String (Projects.Table (Current).Library_Dir);
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
- new String'
- ("-L" &
- Get_Name_String
- (Projects.Table (Current).Library_Dir));
+ new String'("-L" & Name_Buffer (1 .. Name_Len));
if Path_Option /= null then
- Add_Rpath
- (Get_Name_String
- (Projects.Table (Current).Library_Dir));
+ Add_Rpath (Name_Buffer (1 .. Name_Len));
end if;
Opts.Increment_Last;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
with Prj.Part;
with Prj.PP;
with Prj.Tree; use Prj.Tree;
+with Prj.Util; use Prj.Util;
with Snames; use Snames;
with Table; use Table;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.Expect; use GNAT.Expect;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regexp; use GNAT.Regexp;
-with GNAT.Regpat; use GNAT.Regpat;
package body Prj.Makr is
+ function Dup (Fd : File_Descriptor) return File_Descriptor;
+ pragma Import (C, Dup);
+
+ procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
+ pragma Import (C, Dup2);
+
+ Gcc : constant String := "gcc";
+ Gcc_Path : String_Access := null;
+
Non_Empty_Node : constant Project_Node_Id := 1;
-- Used for the With_Clause of the naming project
Source_List_FD : File_Descriptor;
- Matcher : constant Pattern_Matcher :=
- Compile (Expression => "expected|Unit.*\)|No such");
-
Args : Argument_List (1 .. Preproc_Switches'Length + 6);
--- (1 => new String'("-c"),
--- 2 => new String'("-gnats"),
--- 3 => new String'("-gnatu"),
--- 4 => new String'("-x"),
--- 5 => new String'("ada"),
--- 6 => null);
type SFN_Pragma is record
Unit : String_Access;
Dir : Dir_Type;
Process : Boolean := True;
- begin
- if Opt.Verbose_Mode then
- Output.Write_Str ("Processing directory """);
- Output.Write_Str (Dir_Name);
- Output.Write_Line ("""");
- end if;
+ Temp_File_Name : String_Access := null;
+ begin
-- Avoid processing several times the same directory.
for Index in 1 .. Processed_Directories.Last loop
end loop;
if Process then
+ if Opt.Verbose_Mode then
+ Output.Write_Str ("Processing directory """);
+ Output.Write_Str (Dir_Name);
+ Output.Write_Line ("""");
+ end if;
+
Processed_Directories. Increment_Last;
Processed_Directories.Table (Processed_Directories.Last) :=
new String'(Dir_Name);
+
-- Get the source file names from the directory.
-- Fails if the directory does not exist.
if Matched = True then
declare
- PD : Process_Descriptor;
- Result : Expect_Match;
+ FD : File_Descriptor;
+ Success : Boolean;
+ Saved_Output : File_Descriptor;
+ Saved_Error : File_Descriptor;
begin
+ -- If we don't have yet the path of the compiler,
+ -- get it now.
+
+ if Gcc_Path = null then
+ Gcc_Path := Locate_Exec_On_Path (Gcc);
+
+ if Gcc_Path = null then
+ Prj.Com.Fail ("could not locate " & Gcc);
+ end if;
+ end if;
+
+ -- If we don't have yet the file name of the
+ -- temporary file, get it now.
+
+ if Temp_File_Name = null then
+ Create_Temp_File (FD, Temp_File_Name);
+
+ if FD = Invalid_FD then
+ Prj.Com.Fail
+ ("could not create temporary file");
+ end if;
+
+ Close (FD);
+ Delete_File (Temp_File_Name.all, Success);
+ end if;
+
Args (Args'Last) := new String'
- (Dir_Name &
- Directory_Separator &
- Str (1 .. Last));
+ (Dir_Name &
+ Directory_Separator &
+ Str (1 .. Last));
+
+ -- Create the temporary file
+
+ FD := Create_Output_Text_File
+ (Name => Temp_File_Name.all);
+
+ if FD = Invalid_FD then
+ Prj.Com.Fail
+ ("could not create temporary file");
+ end if;
+
+ -- Save the standard output and error
+
+ Saved_Output := Dup (Standout);
+ Saved_Error := Dup (Standerr);
+
+ -- Set the standard output and error to the temporary
+ -- file.
+
+ Dup2 (FD, Standout);
+ Dup2 (FD, Standerr);
+
+ -- And spawn the compiler
+
+ Spawn (Gcc_Path.all, Args, Success);
+
+ -- Restore the standard output and error
+ Dup2 (Saved_Output, Standout);
+ Dup2 (Saved_Error, Standerr);
+
+ -- Close the temporary file
+
+ Close (FD);
+
+ -- And close the saved standard output and error to
+ -- avoid too many file descriptors.
+
+ Close (Saved_Output);
+ Close (Saved_Error);
+
+ -- Now that standard output is restored, check if
+ -- the compiler ran correctly.
+
+ -- Read the first line of the temporary file:
+ -- it should contain the kind and name of the unit.
+
+ declare
+ File : Text_File;
+ Text_Line : String (1 .. 1_000);
+ Text_Last : Natural;
begin
- Non_Blocking_Spawn
- (PD, "gcc", Args, Err_To_Out => True);
- Expect (PD, Result, Matcher);
+ Open (File, Temp_File_Name.all);
+
+ if not Is_Valid (File) then
+ Prj.Com.Fail
+ ("could not read temporary file");
+ end if;
- exception
- when Process_Died =>
+ if End_Of_File (File) then
if Opt.Verbose_Mode then
- Output.Write_Str ("(process died) ");
+ if not Success then
+ Output.Write_Str ("(process died) ");
+ end if;
+
+ Output.Write_Line ("not a unit");
end if;
- Result := Expect_Timeout;
- end;
+ else
+ Get_Line (File, Text_Line, Text_Last);
+ Close (File);
- if Result /= Expect_Timeout then
+ -- Now that we have read the line, delete the
+ -- temporary file, it is not needed anymore.
+ -- On VMS, this avoids several version of the
+ -- file, if it were only delete after all
+ -- sources were parsed.
- -- If we got a unit name, this is a valid source
- -- file.
+ Delete_File (Temp_File_Name.all, Success);
- declare
- S : constant String := Expect_Out_Match (PD);
+ -- Find the first closing parenthesis
- begin
- if S'Length >= 13
- and then S (S'First .. S'First + 3) = "Unit"
- then
- if Opt.Verbose_Mode then
- Output.Write_Str
- (S (S'Last - 4 .. S'Last - 1));
- Output.Write_Str (" of ");
- Output.Write_Line
- (S (S'First + 5 .. S'Last - 7));
+ for J in 1 .. Text_Last loop
+ if Text_Line (J) = ')' then
+ Text_Last := J;
+ exit;
end if;
+ end loop;
+
+ declare
+ S : constant String :=
+ Text_Line (1 .. Text_Last);
+
+ begin
+ if S'Length >= 13
+ and then S (S'First .. S'First + 3) = "Unit"
+ then
+ if Opt.Verbose_Mode then
+ Output.Write_Str
+ (S (S'Last - 4 .. S'Last - 1));
+ Output.Write_Str (" of ");
+ Output.Write_Line
+ (S (S'First + 5 .. S'Last - 7));
+ end if;
- if Project_File then
-
- -- Add the corresponding attribute in the
- -- Naming package of the naming project.
-
- declare
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind =>
- N_Declarative_Item);
-
- Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind =>
- N_Attribute_Declaration);
-
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- And_Expr_Kind => Single);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term,
- And_Expr_Kind => Single);
-
- Value : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- And_Expr_Kind => Single);
-
- begin
- Set_Next_Declarative_Item
- (Decl_Item,
- To => First_Declarative_Item_Of
- (Naming_Package));
- Set_First_Declarative_Item_Of
- (Naming_Package, To => Decl_Item);
- Set_Current_Item_Node
- (Decl_Item, To => Attribute);
-
- if
- S (S'Last - 5 .. S'Last) = "(spec)"
+ if Project_File then
+
+ -- Add the corresponding attribute in
+ -- the Naming package of the naming
+ -- project.
+
+ declare
+ Decl_Item : constant Project_Node_Id
+ := Default_Project_Node
+ (Of_Kind =>
+ N_Declarative_Item);
+
+ Attribute : constant Project_Node_Id
+ := Default_Project_Node
+ (Of_Kind =>
+ N_Attribute_Declaration);
+
+ Expression : constant Project_Node_Id
+ := Default_Project_Node
+ (Of_Kind => N_Expression,
+ And_Expr_Kind => Single);
+
+ Term : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind => N_Term,
+ And_Expr_Kind => Single);
+
+ Value : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind =>
+ N_Literal_String,
+ And_Expr_Kind =>
+ Single);
+
+ begin
+ Set_Next_Declarative_Item
+ (Decl_Item,
+ To => First_Declarative_Item_Of
+ (Naming_Package));
+ Set_First_Declarative_Item_Of
+ (Naming_Package, To => Decl_Item);
+ Set_Current_Item_Node
+ (Decl_Item, To => Attribute);
+
+ -- Is it a spec or a body?
+
+ if S (S'Last - 5 .. S'Last) =
+ "(spec)"
+ then
+ Set_Name_Of
+ (Attribute, To => Name_Spec);
+ else
+ Set_Name_Of
+ (Attribute,
+ To => Name_Body);
+ end if;
+
+ -- Get the name of the unit
+
+ Name_Len := S'Last - S'First - 11;
+ Name_Buffer (1 .. Name_Len) :=
+ (To_Lower
+ (S (S'First + 5 ..
+ S'Last - 7)));
+ Set_Associative_Array_Index_Of
+ (Attribute, To => Name_Find);
+
+ Set_Expression_Of
+ (Attribute, To => Expression);
+ Set_First_Term
+ (Expression, To => Term);
+ Set_Current_Term (Term, To => Value);
+
+ -- And set the name of the file
+
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) :=
+ Str (1 .. Last);
+ Set_String_Value_Of
+ (Value, To => Name_Find);
+ end;
+
+ -- Add source file name to source list
+ -- file.
+
+ Last := Last + 1;
+ Str (Last) := ASCII.LF;
+
+ if Write (Source_List_FD,
+ Str (1)'Address,
+ Last) /= Last
then
- Set_Name_Of
- (Attribute, To => Name_Spec);
- else
- Set_Name_Of
- (Attribute,
- To => Name_Body);
+ Prj.Com.Fail ("disk full");
end if;
-
- Name_Len := S'Last - S'First - 11;
- Name_Buffer (1 .. Name_Len) :=
- (To_Lower
- (S (S'First + 5 .. S'Last - 7)));
- Set_Associative_Array_Index_Of
- (Attribute, To => Name_Find);
-
- Set_Expression_Of
- (Attribute, To => Expression);
- Set_First_Term (Expression, To => Term);
- Set_Current_Term (Term, To => Value);
-
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) :=
- Str (1 .. Last);
- Set_String_Value_Of
- (Value, To => Name_Find);
- end;
-
- -- Add source file name to source list
- -- file.
-
- Last := Last + 1;
- Str (Last) := ASCII.LF;
-
- if Write (Source_List_FD,
- Str (1)'Address,
- Last) /= Last
- then
- Prj.Com.Fail ("disk full");
+ else
+ -- Add an entry in the SFN_Pragmas
+ -- table.
+
+ SFN_Pragmas.Increment_Last;
+ SFN_Pragmas.Table (SFN_Pragmas.Last) :=
+ (Unit => new String'
+ (S (S'First + 5 .. S'Last - 7)),
+ File => new String'(Str (1 .. Last)),
+ Spec => S (S'Last - 5 .. S'Last)
+ = "(spec)");
end if;
- else
- -- Add an entry in the SFN_Pragmas table
-
- SFN_Pragmas.Increment_Last;
- SFN_Pragmas.Table (SFN_Pragmas.Last) :=
- (Unit => new String'
- (S (S'First + 5 .. S'Last - 7)),
- File => new String'(Str (1 .. Last)),
- Spec => S (S'Last - 5 .. S'Last)
- = "(spec)");
- end if;
- else
- if Opt.Verbose_Mode then
- Output.Write_Line ("not a unit");
+ else
+ if Opt.Verbose_Mode then
+ Output.Write_Line ("not a unit");
+ end if;
end if;
- end if;
- end;
-
- else
- if Opt.Verbose_Mode then
- Output.Write_Line ("not a unit");
+ end;
end if;
- end if;
-
- Close (PD);
+ end;
end;
else
if Element.Value /= No_Name then
declare
Source_Directory : constant String :=
- Get_Name_String (Element.Value);
+ Get_Name_String (Element.Display_Value);
begin
if Current_Verbosity = High then
exit when Name_Len = 0;
- -- Canonical_Case_File_Name
- -- (Name_Buffer (1 .. Name_Len));
-
declare
File_Name : constant Name_Id := Name_Find;
Dir : constant String :=
begin
if Current_Verbosity = High then
Write_Str ("Find_Source_Dirs (""");
- end if;
-
- Get_Name_String (From);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- -- Directory := Name_Buffer (1 .. Name_Len);
- -- Why is above line commented out ???
-
- if Current_Verbosity = High then
Write_Str (Directory);
Write_Line (""")");
end if;
* *
* C Implementation File *
* *
- * 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 is compared against the ttype entries associated with actions in the
examined context to see if one of these actions matches. */
- bool handled_by_others;
- /* Indicates wether a "when others" may catch this exception, also filled by
- Propagate_Exception.
-
- This is used to decide if a GNAT_OTHERS ttype entry matches. */
-
int n_cleanups_to_trigger;
/* Number of cleanups on the propagation way for the occurrence. This is
initialized to 0 by Propagate_Exception and computed by the personality
#endif
+/* With CHOICE an exception choice representing an "exception - when"
+ argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated
+ occurrence, return true iif the latter matches the former, that is, if
+ PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE.
+ This takes care of the special Non_Ada_Error case on VMS. */
+
+#define Is_Handled_By_Others __gnat_is_handled_by_others
+#define Language_For __gnat_language_for
+#define Import_Code_For __gnat_import_code_for
+
+extern bool Is_Handled_By_Others (_Unwind_Ptr e);
+extern char Language_For (_Unwind_Ptr e);
+
+extern Exception_Code Import_Code_For (_Unwind_Ptr e);
+
+static int
+is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
+{
+ /* Pointer to the GNAT exception data corresponding to the propagated
+ occurrence. */
+ _Unwind_Ptr E = propagated_exception->id;
+
+ /* Base matching rules: An exception data (id) matches itself, "when
+ all_others" matches anything and "when others" matches anything unless
+ explicitely stated otherwise in the propagated occurrence. */
+
+ bool is_handled =
+ choice == E
+ || choice == GNAT_ALL_OTHERS
+ || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
+
+ /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
+ may have different exception data pointers that should match for the
+ same condition code, if both an export and an import have been
+ registered. The import code for both the choice and the propagated
+ occurrence are expected to have been masked off regarding severity
+ bits already (at registration time for the former and from within the
+ low level exception vector for the latter). */
+#ifdef VMS
+ #define Non_Ada_Error system__aux_dec__non_ada_error
+ extern struct Exception_Data Non_Ada_Error;
+
+ is_handled |=
+ (Language_For (E) == 'V'
+ && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
+ && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
+ && Import_Code_For (choice) == Import_Code_For (E))
+ || choice == (_Unwind_Ptr)&Non_Ada_Error));
+#endif
+
+ return is_handled;
+}
+
/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
UW_CONTEXT in REGION. */
{
/* See if the filter we have is for an exception which matches
the one we are propagating. */
- _Unwind_Ptr eid = get_ttype_entry_for (region, ar_filter);
+ _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter);
- if (eid == gnat_exception->id
- || eid == GNAT_ALL_OTHERS
- || (eid == GNAT_OTHERS && gnat_exception->handled_by_others))
+ if (is_handled_by (choice, gnat_exception))
{
action->ttype_filter = ar_filter;
- action->ttype_entry = eid;
+ action->ttype_entry = choice;
action->kind = handler;
return;
}
* *
* C Header File *
* *
- * 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- *
* *
****************************************************************************/
+
+typedef unsigned Exception_Code;
+/* C counterpart of what System.Standard_Library defines. */
+
struct Exception_Data
{
char Handled_By_Others;
char Lang;
int Name_Length;
char *Full_Name, Htable_Ptr;
- int Import_Code;
+ Exception_Code Import_Code;
};
typedef struct Exception_Data *Exception_Id;
-- --
-- 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- --
RE_Shared_Var_WOpen, -- System.Shared_Storage
RE_Abort_Undefer_Direct, -- System.Standard_Library
+ RE_Exception_Code, -- System.Standard_Library
RE_Exception_Data_Ptr, -- System.Standard_Library
RE_Integer_Address, -- System.Storage_Elements
RE_Shared_Var_WOpen => System_Shared_Storage,
RE_Abort_Undefer_Direct => System_Standard_Library,
+ RE_Exception_Code => System_Standard_Library,
RE_Exception_Data_Ptr => System_Standard_Library,
RE_Integer_Address => System_Storage_Elements,
-- --
-- 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- --
end;
-- If we were given a stream (call from xxx.C_Streams.Open), then set
- -- full name to null and that is all we have to do in this case so
- -- skip to end of processing.
+ -- the full name to the given one, and skip to end of processing.
if Stream /= NULL_Stream then
- Fullname (1) := ASCII.Nul;
- Full_Name_Len := 1;
+ Full_Name_Len := Name'Length + 1;
+ Fullname (1 .. Full_Name_Len - 1) := Name;
+ Fullname (Full_Name_Len) := ASCII.Nul;
-- Normal case of Open or Create
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 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- --
type Exception_Data_Ptr is access all Exception_Data;
-- An equivalent of Exception_Id that is public
+ type Exception_Code is mod 2 ** 32;
+ -- A scalar value bound to some exception data. Typically used for
+ -- imported or exported exceptions on VMS. Having a separate type for this
+ -- is useful to enforce consistency throughout the various run-time units
+ -- handling such codes, and having it unsigned is the most appropriate
+ -- choice for it's currently single use on VMS.
+
+ -- ??? The construction in Cstand has no way to access the proper type
+ -- node for Exception_Code, and currently uses Standard_Unsigned as a
+ -- fallback. The representations shall match, and the size clause below
+ -- is aimed at ensuring that.
+
+ for Exception_Code'Size use Integer'Size;
+
-- The following record defines the underlying representation of exceptions
-- WARNING! Any changes to this may need to be reflectd in the following
-- built (by Register_Exception in s-exctab.adb) for converting between
-- identities and names.
- Import_Code : Integer;
+ Import_Code : Exception_Code;
-- Value for imported exceptions. Needed only for the handling of
-- Import/Export_Exception for the VMS case, but present in all
-- implementations (we might well extend this mechanism for other
type Dummy_Wrapper;
type Access_Dummy_Wrapper is access all Dummy_Wrapper;
+ pragma No_Strict_Aliasing (Access_Dummy_Wrapper);
+ -- Needed to avoid possible incorrect aliasing situations from
+ -- instantiation of Unchecked_Conversion in body of Ada.Task_Attributes.
+
for Access_Dummy_Wrapper'Storage_Size use 0;
- -- This is a stand-in for the generic type Wrapper defined in
- -- Ada.Task_Attributes. The real objects allocated are always
+ -- Access_Dummy_Wrapper is a stand-in for the generic type Wrapper defined
+ -- in Ada.Task_Attributes. The real objects allocated are always
-- of type Wrapper, no Dummy_Wrapper objects are ever created.
type Deallocator is access procedure (P : in out Access_Node);
-- This package provides facilities to register a thread to the runtime,
-- and allocate its task specific datas.
--- pragma Thread_Body is currently supported for:
--- VxWorks AE653 with the restricted / cert runtime
+-- This package is currently implemented for:
+-- VxWorks AE653 rts-cert
+-- VxWorks AE653 rts-full (not rts-kernel)
with Ada.Exceptions;
-- used for Exception_Occurrence
with System.Soft_Links;
-- used for TSD
+with Unchecked_Conversion;
+
package System.Threads is
subtype EO is Ada.Exceptions.Exception_Occurrence;
-- by the GNAT runtime.
type ATSD_Access is access ATSD;
+ function From_Address is new Unchecked_Conversion (Address, ATSD_Access);
-- Get/Set for the attributes of the current thread
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
package body System.VMS_Exception_Table is
- use System.Standard_Library;
+ use type SSL.Exception_Code;
type HTable_Headers is range 1 .. 37;
-- Ada exception.
type Exception_Code_Data is record
- Code : Natural;
- Except : Exception_Data_Ptr;
+ Code : SSL.Exception_Code;
+ Except : SSL.Exception_Data_Ptr;
HTable_Ptr : Exception_Code_Data_Ptr;
end record;
function Get_HT_Link (T : Exception_Code_Data_Ptr)
return Exception_Code_Data_Ptr;
- function Hash (F : Natural) return HTable_Headers;
- function Get_Key (T : Exception_Code_Data_Ptr) return Natural;
+ function Hash (F : SSL.Exception_Code) return HTable_Headers;
+ function Get_Key (T : Exception_Code_Data_Ptr) return SSL.Exception_Code;
package Exception_Code_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
Null_Ptr => null,
Set_Next => Set_HT_Link,
Next => Get_HT_Link,
- Key => Natural,
+ Key => SSL.Exception_Code,
Get_Key => Get_Key,
Hash => Hash,
Equal => "=");
+ ------------------
+ -- Base_Code_In --
+ ------------------
+
+ function Base_Code_In
+ (Code : SSL.Exception_Code) return SSL.Exception_Code
+ is
+ begin
+ return Code and not 2#0111#;
+ end Base_Code_In;
+
---------------------
-- Coded_Exception --
---------------------
- function Coded_Exception (X : Natural) return Exception_Data_Ptr is
+ function Coded_Exception
+ (X : SSL.Exception_Code) return SSL.Exception_Data_Ptr
+ is
Res : Exception_Code_Data_Ptr;
begin
-- Get_HT_Link --
-----------------
- function Get_HT_Link (T : Exception_Code_Data_Ptr)
- return Exception_Code_Data_Ptr is
+ function Get_HT_Link
+ (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr
+ is
begin
return T.HTable_Ptr;
end Get_HT_Link;
-- Get_Key --
-------------
- function Get_Key (T : Exception_Code_Data_Ptr) return Natural is
+ function Get_Key (T : Exception_Code_Data_Ptr)
+ return SSL.Exception_Code
+ is
begin
return T.Code;
end Get_Key;
-- Hash --
----------
- function Hash (F : Natural) return HTable_Headers is
+ function Hash
+ (F : SSL.Exception_Code) return HTable_Headers
+ is
+ Headers_Magnitude : constant SSL.Exception_Code :=
+ SSL.Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1);
+
begin
- return HTable_Headers
- (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1);
+ return HTable_Headers (F mod Headers_Magnitude + 1);
end Hash;
----------------------------
-- Register_VMS_Exception --
----------------------------
- procedure Register_VMS_Exception (Code : Integer) is
- Excode : constant Integer := (Code / 8) * 8;
- -- Mask off lower 3 bits which are the severity
+ procedure Register_VMS_Exception
+ (Code : SSL.Exception_Code;
+ E : SSL.Exception_Data_Ptr)
+ is
+ -- We bind the exception data with the base code found in the
+ -- input value, that is with the severity bits masked off.
+
+ Excode : constant SSL.Exception_Code := Base_Code_In (Code);
begin
- -- This allocates an empty exception that gets filled in by
- -- __gnat_error_handler when the exception is raised. Allocating
- -- it here prevents having to allocate it each time the exception
- -- is raised.
+ -- The exception data registered here is mostly filled prior to this
+ -- call and by __gnat_error_handler when the exception is raised. We
+ -- still need to fill a couple of components for exceptions that will
+ -- be used as propagation filters (exception data pointer registered
+ -- as choices in the unwind tables): in some import/export cases, the
+ -- exception pointers for the choice and the propagated occurrence may
+ -- indeed be different for a single import code, and the personality
+ -- routine attempts to match the import codes in this case.
+
+ E.Lang := 'V';
+ E.Import_Code := Excode;
if Exception_Code_HTable.Get (Excode) = null then
- Exception_Code_HTable.Set
- (new Exception_Code_Data'
- (Excode,
- new Exception_Data'
- (Not_Handled_By_Others => False,
- Lang => 'V',
- Name_Length => 0,
- Full_Name => null,
- HTable_Ptr => null,
- Import_Code => 0,
- Raise_Hook => null),
- null));
+ Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null));
end if;
end Register_VMS_Exception;
-- --
-- S p e c --
-- --
--- Copyright (C) 1997 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
-- where there is at least one Import/Export exception present.
with System.Standard_Library;
+
package System.VMS_Exception_Table is
- procedure Register_VMS_Exception (Code : Integer);
+ package SSL renames System.Standard_Library;
+
+ procedure Register_VMS_Exception
+ (Code : SSL.Exception_Code;
+ E : SSL.Exception_Data_Ptr);
-- Register an exception in the hash table mapping with a VMS
-- condition code.
private
- function Coded_Exception (X : Natural)
- return System.Standard_Library.Exception_Data_Ptr;
+ function Base_Code_In (Code : SSL.Exception_Code) return SSL.Exception_Code;
+ -- Value of Code with the severity bits masked off.
+
+ function Coded_Exception (X : SSL.Exception_Code)
+ return SSL.Exception_Data_Ptr;
-- Given a VMS condition, find and return it's allocated Ada exception
- -- (called only from a-init.c).
+ -- (called only from init.c).
end System.VMS_Exception_Table;
-- actual must correspond to a discriminant of the formal.
elsif Has_Discriminants (Act_T)
+ and then not Has_Unknown_Discriminants (Act_T)
and then Has_Discriminants (Ancestor)
then
Actual_Discr := First_Discriminant (Act_T);
-- for constrainedness, but the check here is added for
-- completeness.
- elsif Has_Discriminants (Act_T) then
+ elsif Has_Discriminants (Act_T)
+ and then not Has_Unknown_Discriminants (Act_T)
+ then
Error_Msg_NE
("actual for & must not have discriminants", Actual, Gen_T);
Abandon_Instantiation (Actual);
end if;
end if;
- -- In GNAT mode, if target is an access type, access type must be
- -- declared in the same source unit as the unchecked conversion.
-
--- if GNAT_Mode and then Is_Access_Type (Target) then
--- if not In_Same_Source_Unit (Target, N) then
--- Error_Msg_NE
--- ("unchecked conversion not in same unit as&", N, Target);
--- end if;
--- end if;
+ -- If unchecked conversion to access type, and access type is
+ -- declared in the same unit as the unchecked conversion, then
+ -- set the No_Strict_Aliasing flag (no strict aliasing is
+ -- implicit in this situation).
+
+ if Is_Access_Type (Target) and then
+ In_Same_Source_Unit (Target, N)
+ then
+ Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
+ end if;
-- Generate N_Validate_Unchecked_Conversion node for back end in
-- case the back end needs to perform special validation checks.
Set_Is_First_Subtype (T);
Make_Class_Wide_Type (T);
+ if Unknown_Discriminants_Present (N) then
+ Set_Discriminant_Constraint (T, No_Elist);
+ end if;
+
Build_Derived_Record_Type (N, Parent_Type, T);
end Analyze_Private_Extension_Declaration;
if Ekind (Full_Base) = E_Record_Type
and then Has_Discriminants (Full_Base)
and then Has_Discriminants (Priv) -- might not, if errors
+ and then not Has_Unknown_Discriminants (Priv)
and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv))
then
Create_Constrained_Components
-- --
-- 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- --
Check_References (Gen_Id);
end;
+ Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
End_Scope;
Check_Subprogram_Order (N);
Error_Pragma_Arg ("pragma% requires access type", Arg1);
end if;
- Set_No_Strict_Aliasing (Base_Type (E_Id));
+ Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
end if;
end No_Strict_Alias;
{
unsigned int align = known_alignment (gnu_result);
tree gnu_obj_type = TREE_TYPE (gnu_result_type);
- unsigned int oalign
- = TREE_CODE (gnu_obj_type) == FUNCTION_TYPE
- ? FUNCTION_BOUNDARY : TYPE_ALIGN (gnu_obj_type);
+ unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
if (align != 0 && align < oalign && ! TYPE_ALIGN_OK (gnu_obj_type))
post_error_ne_tree_2
-- for a directory.
S_Bind_Shared : aliased constant S := "/SHARED " &
- "-shared";
- -- /SHARED (D)
+ "-shared,!-static";
+ -- /SHARED
-- /NOSHARED
--
-- Link against a shared GNAT run time when available.
--
-- When looking for source files also look in directories specified.
+ S_Bind_Static : aliased constant S := "/STATIC " &
+ "-static,!-shared";
+ -- /STATIC
+ -- /NOSTATIC
+ --
+ -- Link against a static GNAT run time.
+
S_Bind_Store : aliased constant S := "/STORE_TRACEBACKS " &
"-E";
-- /STORE_TRACEBACKS (D)
S_Bind_Shared 'Access,
S_Bind_Slice 'Access,
S_Bind_Source 'Access,
+ S_Bind_Static 'Access,
S_Bind_Store 'Access,
S_Bind_Time 'Access,
S_Bind_Verbose 'Access,
OSDN Git Service
