[multiple changes]
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. From-SVN: r79494
This commit is contained in:
Arnaud Charlet
parent
0bb1600af1
commit
e6f6961425
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -150,9 +150,9 @@ package GNAT.Sockets.Constants is
|
||||
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;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -104,7 +104,7 @@ package body Specific is
|
||||
-- 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;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -84,8 +84,7 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
|
||||
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);
|
||||
@ -122,8 +121,7 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
|
||||
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);
|
||||
@ -136,6 +134,7 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
|
||||
procedure Task_Synch is
|
||||
Synch_Self_ID : constant Task_ID := Self;
|
||||
|
||||
begin
|
||||
if Single_Lock then
|
||||
Lock_RTS;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -68,7 +68,7 @@ package body Specific is
|
||||
|
||||
function Self return Task_ID is
|
||||
begin
|
||||
return To_Task_Id (ATCB_Key);
|
||||
return To_Task_ID (ATCB_Key);
|
||||
end Self;
|
||||
|
||||
end Specific;
|
||||
|
||||
@ -1,3 +1,203 @@
|
||||
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
|
||||
|
||||
@ -1201,9 +1201,10 @@ ada/cuintp.o : ada/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
|
||||
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 \
|
||||
|
||||
@ -1308,7 +1308,7 @@ endif
|
||||
# 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)
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -145,11 +145,6 @@ package body Exception_Propagation is
|
||||
-- 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
|
||||
@ -174,8 +169,7 @@ package body Exception_Propagation is
|
||||
|
||||
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.
|
||||
|
||||
@ -195,8 +189,7 @@ package body Exception_Propagation is
|
||||
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.
|
||||
@ -215,14 +208,32 @@ package body Exception_Propagation is
|
||||
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;
|
||||
@ -285,8 +296,7 @@ package body Exception_Propagation is
|
||||
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
|
||||
@ -401,7 +411,6 @@ package body Exception_Propagation is
|
||||
-- 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
|
||||
@ -459,6 +468,39 @@ package body Exception_Propagation is
|
||||
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 --
|
||||
-----------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -566,14 +566,18 @@ package body Ada.Numerics.Generic_Complex_Types is
|
||||
-- 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
|
||||
@ -585,8 +589,8 @@ package body Ada.Numerics.Generic_Complex_Types is
|
||||
|
||||
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
|
||||
@ -606,12 +610,12 @@ package body Ada.Numerics.Generic_Complex_Types is
|
||||
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;
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
-- 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- --
|
||||
@ -322,10 +322,6 @@ package body Ada.Task_Attributes is
|
||||
(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);
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -432,7 +432,6 @@ package body Ada.Text_IO.Fixed_IO is
|
||||
+ Boolean'Pos (not Exact)
|
||||
* (Scale - 1);
|
||||
|
||||
|
||||
procedure Put_Character (C : Character);
|
||||
pragma Inline (Put_Character);
|
||||
-- Add C to the output string To, updating Last
|
||||
@ -550,7 +549,6 @@ package body Ada.Text_IO.Fixed_IO is
|
||||
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;
|
||||
|
||||
@ -615,6 +615,21 @@ __gnat_open_create (char *path, int fmode)
|
||||
return fd < 0 ? -1 : fd;
|
||||
}
|
||||
|
||||
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)
|
||||
{
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* 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- *
|
||||
@ -63,6 +63,7 @@ extern int __gnat_stat (char *,
|
||||
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 *);
|
||||
|
||||
@ -1100,6 +1100,13 @@ package body CStand is
|
||||
-- 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);
|
||||
@ -1120,7 +1127,7 @@ package body CStand is
|
||||
"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");
|
||||
|
||||
@ -34,6 +34,7 @@
|
||||
#include "convert.h"
|
||||
#include "ggc.h"
|
||||
#include "obstack.h"
|
||||
#include "target.h"
|
||||
|
||||
#include "ada.h"
|
||||
#include "types.h"
|
||||
@ -2801,6 +2802,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
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
|
||||
@ -2950,7 +2955,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
}
|
||||
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
|
||||
@ -3002,7 +3008,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|
||||
}
|
||||
}
|
||||
|
||||
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,
|
||||
@ -5794,12 +5800,8 @@ compute_field_positions (tree gnu_type,
|
||||
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
|
||||
@ -5871,6 +5873,20 @@ validate_size (Uint uint_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
|
||||
|
||||
@ -4184,23 +4184,35 @@ package body Exp_Ch3 is
|
||||
-- (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;
|
||||
|
||||
if Present (Alias (Subp)) then
|
||||
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);
|
||||
|
||||
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);
|
||||
@ -5275,6 +5287,7 @@ package body Exp_Ch3 is
|
||||
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;
|
||||
|
||||
@ -154,8 +154,9 @@ package body Exp_Ch4 is
|
||||
-- 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;
|
||||
@ -1401,7 +1402,8 @@ package body Exp_Ch4 is
|
||||
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;
|
||||
@ -2968,12 +2970,6 @@ package body Exp_Ch4 is
|
||||
-- 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)));
|
||||
@ -5124,6 +5120,7 @@ package body Exp_Ch4 is
|
||||
|
||||
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))
|
||||
@ -5396,23 +5393,13 @@ package body Exp_Ch4 is
|
||||
|
||||
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
|
||||
@ -6532,6 +6519,7 @@ package body Exp_Ch4 is
|
||||
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;
|
||||
@ -6563,7 +6551,17 @@ package body Exp_Ch4 is
|
||||
-- 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
|
||||
|
||||
@ -478,7 +478,29 @@ package body Exp_Ch5 is
|
||||
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.
|
||||
|
||||
@ -7237,7 +7237,7 @@ package body Exp_Ch9 is
|
||||
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
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -272,7 +272,9 @@ package body Exp_Prag is
|
||||
-- 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
|
||||
@ -281,19 +283,27 @@ package body Exp_Prag is
|
||||
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
|
||||
@ -301,7 +311,9 @@ package body Exp_Prag is
|
||||
-- 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;
|
||||
@ -391,7 +403,7 @@ package body Exp_Prag is
|
||||
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);
|
||||
@ -453,7 +465,7 @@ package body Exp_Prag is
|
||||
|
||||
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),
|
||||
@ -466,9 +478,14 @@ package body Exp_Prag is
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name => New_Reference_To
|
||||
(RTE (RE_Register_VMS_Exception), Loc),
|
||||
Parameter_Associations => New_List (Code)));
|
||||
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, Standard_Integer);
|
||||
Analyze_And_Resolve (Code, RTE (RE_Exception_Code));
|
||||
Analyze (Call);
|
||||
end if;
|
||||
|
||||
|
||||
@ -57,17 +57,19 @@ extern Boolean Debug_Flag_NN;
|
||||
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,
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -660,6 +660,23 @@ package body GNAT.OS_Lib is
|
||||
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 --
|
||||
----------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -191,7 +191,12 @@ pragma Elaborate_Body (OS_Lib);
|
||||
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;
|
||||
|
||||
@ -1338,7 +1338,7 @@ begin
|
||||
-- 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;
|
||||
|
||||
@ -1344,7 +1344,10 @@ extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */
|
||||
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.
|
||||
@ -1374,6 +1377,8 @@ long
|
||||
__gnat_error_handler (int *sigargs, void *mechargs)
|
||||
{
|
||||
struct Exception_Data *exception = 0;
|
||||
Exception_Code base_code;
|
||||
|
||||
char *msg = "";
|
||||
char message[256];
|
||||
long prvhnd;
|
||||
@ -1410,8 +1415,11 @@ __gnat_error_handler (int *sigargs, void *mechargs)
|
||||
}
|
||||
|
||||
#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;
|
||||
@ -1424,7 +1432,7 @@ __gnat_error_handler (int *sigargs, void *mechargs)
|
||||
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
|
||||
|
||||
|
||||
@ -275,10 +275,12 @@ package body Lib.Xref is
|
||||
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.
|
||||
|
||||
|
||||
@ -180,7 +180,6 @@ package body Make is
|
||||
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.
|
||||
@ -4345,39 +4344,6 @@ package body Make is
|
||||
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");
|
||||
@ -6493,18 +6459,30 @@ package body Make is
|
||||
-- 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
|
||||
|
||||
@ -671,14 +671,9 @@ package body MLib.Prj is
|
||||
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);
|
||||
@ -689,69 +684,40 @@ package body MLib.Prj is
|
||||
|
||||
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;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -34,18 +34,26 @@ with Prj.Com;
|
||||
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
|
||||
|
||||
@ -123,16 +131,7 @@ package body Prj.Makr is
|
||||
|
||||
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;
|
||||
@ -164,13 +163,9 @@ package body Prj.Makr is
|
||||
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
|
||||
@ -181,9 +176,16 @@ package body Prj.Makr is
|
||||
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.
|
||||
|
||||
@ -248,158 +250,262 @@ package body Prj.Makr is
|
||||
|
||||
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
|
||||
Args (Args'Last) := new String'
|
||||
(Dir_Name &
|
||||
Directory_Separator &
|
||||
Str (1 .. Last));
|
||||
-- If we don't have yet the path of the compiler,
|
||||
-- get it now.
|
||||
|
||||
begin
|
||||
Non_Blocking_Spawn
|
||||
(PD, "gcc", Args, Err_To_Out => True);
|
||||
Expect (PD, Result, Matcher);
|
||||
if Gcc_Path = null then
|
||||
Gcc_Path := Locate_Exec_On_Path (Gcc);
|
||||
|
||||
exception
|
||||
when Process_Died =>
|
||||
if Opt.Verbose_Mode then
|
||||
Output.Write_Str ("(process died) ");
|
||||
end if;
|
||||
|
||||
Result := Expect_Timeout;
|
||||
end;
|
||||
|
||||
if Result /= Expect_Timeout then
|
||||
|
||||
-- If we got a unit name, this is a valid source
|
||||
-- file.
|
||||
|
||||
declare
|
||||
S : constant String := Expect_Out_Match (PD);
|
||||
|
||||
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)"
|
||||
then
|
||||
Set_Name_Of
|
||||
(Attribute, To => Name_Spec);
|
||||
else
|
||||
Set_Name_Of
|
||||
(Attribute,
|
||||
To => Name_Body);
|
||||
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");
|
||||
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");
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
|
||||
else
|
||||
if Opt.Verbose_Mode then
|
||||
Output.Write_Line ("not a unit");
|
||||
if Gcc_Path = null then
|
||||
Prj.Com.Fail ("could not locate " & Gcc);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Close (PD);
|
||||
-- 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));
|
||||
|
||||
-- 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
|
||||
Open (File, Temp_File_Name.all);
|
||||
|
||||
if not Is_Valid (File) then
|
||||
Prj.Com.Fail
|
||||
("could not read temporary file");
|
||||
end if;
|
||||
|
||||
if End_Of_File (File) then
|
||||
if Opt.Verbose_Mode then
|
||||
if not Success then
|
||||
Output.Write_Str ("(process died) ");
|
||||
end if;
|
||||
|
||||
Output.Write_Line ("not a unit");
|
||||
end if;
|
||||
|
||||
else
|
||||
Get_Line (File, Text_Line, Text_Last);
|
||||
Close (File);
|
||||
|
||||
-- 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.
|
||||
|
||||
Delete_File (Temp_File_Name.all, Success);
|
||||
|
||||
-- Find the first closing parenthesis
|
||||
|
||||
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);
|
||||
|
||||
-- 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
|
||||
Prj.Com.Fail ("disk full");
|
||||
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");
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end;
|
||||
end;
|
||||
|
||||
else
|
||||
|
||||
@ -667,7 +667,7 @@ package body Prj.Nmsc is
|
||||
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
|
||||
@ -691,9 +691,6 @@ package body Prj.Nmsc is
|
||||
|
||||
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 :=
|
||||
@ -2721,15 +2718,6 @@ package body Prj.Nmsc is
|
||||
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;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* 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- *
|
||||
@ -482,12 +482,6 @@ typedef struct
|
||||
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
|
||||
@ -846,6 +840,59 @@ get_call_site_action_for (_Unwind_Context *uw_context,
|
||||
|
||||
#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. */
|
||||
|
||||
@ -907,14 +954,12 @@ get_action_description_for (_Unwind_Context *uw_context,
|
||||
{
|
||||
/* 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;
|
||||
}
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
* *
|
||||
* 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- *
|
||||
@ -30,13 +30,17 @@
|
||||
* *
|
||||
****************************************************************************/
|
||||
|
||||
|
||||
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;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -1049,6 +1049,7 @@ package Rtsfind is
|
||||
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
|
||||
@ -1989,6 +1990,7 @@ package Rtsfind is
|
||||
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,
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -774,12 +774,12 @@ package body System.File_IO is
|
||||
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
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -97,6 +97,20 @@ package System.Standard_Library is
|
||||
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
|
||||
@ -131,7 +145,7 @@ package System.Standard_Library is
|
||||
-- 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
|
||||
|
||||
@ -57,9 +57,13 @@ package System.Tasking.Task_Attributes is
|
||||
|
||||
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);
|
||||
|
||||
@ -34,8 +34,9 @@
|
||||
-- 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
|
||||
@ -43,6 +44,8 @@ with Ada.Exceptions;
|
||||
with System.Soft_Links;
|
||||
-- used for TSD
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package System.Threads is
|
||||
|
||||
subtype EO is Ada.Exceptions.Exception_Occurrence;
|
||||
@ -54,6 +57,7 @@ package System.Threads is
|
||||
-- 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
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -38,7 +38,7 @@ pragma Elaborate_All (System.HTable);
|
||||
|
||||
package body System.VMS_Exception_Table is
|
||||
|
||||
use System.Standard_Library;
|
||||
use type SSL.Exception_Code;
|
||||
|
||||
type HTable_Headers is range 1 .. 37;
|
||||
|
||||
@ -49,8 +49,8 @@ package body System.VMS_Exception_Table is
|
||||
-- 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;
|
||||
|
||||
@ -61,8 +61,8 @@ package body System.VMS_Exception_Table is
|
||||
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,
|
||||
@ -71,16 +71,29 @@ package body System.VMS_Exception_Table is
|
||||
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
|
||||
@ -98,8 +111,9 @@ package body System.VMS_Exception_Table is
|
||||
-- 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;
|
||||
@ -108,7 +122,9 @@ package body System.VMS_Exception_Table is
|
||||
-- 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;
|
||||
@ -117,39 +133,44 @@ package body System.VMS_Exception_Table is
|
||||
-- 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;
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -35,9 +35,14 @@
|
||||
-- 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.
|
||||
|
||||
@ -45,9 +50,12 @@ package System.VMS_Exception_Table is
|
||||
|
||||
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;
|
||||
|
||||
@ -7892,6 +7892,7 @@ package body Sem_Ch12 is
|
||||
-- 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);
|
||||
@ -7923,7 +7924,9 @@ package body Sem_Ch12 is
|
||||
-- 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);
|
||||
|
||||
@ -3852,15 +3852,16 @@ package body Sem_Ch13 is
|
||||
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 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 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 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.
|
||||
|
||||
@ -2142,6 +2142,10 @@ package body Sem_Ch3 is
|
||||
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;
|
||||
|
||||
@ -6575,6 +6579,7 @@ package body Sem_Ch3 is
|
||||
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
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -401,6 +401,7 @@ package body Sem_Ch6 is
|
||||
Check_References (Gen_Id);
|
||||
end;
|
||||
|
||||
Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope);
|
||||
End_Scope;
|
||||
Check_Subprogram_Order (N);
|
||||
|
||||
|
||||
@ -7508,7 +7508,7 @@ package body Sem_Prag is
|
||||
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;
|
||||
|
||||
|
||||
@ -1695,9 +1695,7 @@ tree_transform (Node_Id gnat_node)
|
||||
{
|
||||
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
|
||||
|
||||
@ -517,8 +517,8 @@ package VMS_Data is
|
||||
-- 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.
|
||||
@ -537,6 +537,13 @@ package VMS_Data is
|
||||
--
|
||||
-- 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)
|
||||
@ -636,6 +643,7 @@ package VMS_Data is
|
||||
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,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user