-- Storage-related Declarations
type Address is new Long_Integer;
- subtype Short_Address is Address
- range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
- for Short_Address'Object_Size use 32;
Null_Address : constant Address;
Storage_Unit : constant := 8;
with System.OS_Interface;
-- used for various type, constant, and operations
+with System.Aux_DEC;
+-- used for Short_Address
+
with System.Parameters;
with System.Tasking;
--------------------
function To_unsigned_long is new
- Unchecked_Conversion (System.Short_Address, unsigned_long);
+ Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long);
function Interrupt_Wait (Mask : access Interrupt_Mask)
return Interrupt_ID
-- Storage-related Declarations
type Address is private;
- subtype Short_Address is Address;
Null_Address : constant Address;
Storage_Unit : constant := 8;
-- Storage-related Declarations
type Address is private;
- subtype Short_Address is Address;
Null_Address : constant Address;
Storage_Unit : constant := 8;
+2004-05-10 Doug Rupp <rupp@gnat.com>
+
+ * 5qsystem.ads: Remove Short_Address subtype declaration. Moved to
+ system.aux_dec.
+
+ * s-auxdec.ads: Add Short_Address subtype (moved here from System).
+
+ * Makefile.in: [VMS]: Add translation for 5qauxdec.ads.
+
+ * init.c: [VMS] Macroize LIB$ calls for IA64 and Alpha.
+ Fixes undefined symbols in IA64 gnatlib.
+
+ * 5vinmaop.adb: Reference s-auxdec for Short_Address.
+
+ * 5xsystem.ads, 5vsystem.ads: Back out last change (addition of subtype
+ Short_Address). This will be moved to system.auxdec.
+
+2004-05-10 Thomas Quinot <quinot@act-europe.fr>
+
+ * sem_util.adb: Replace test for presence of a node that is always
+ present with a call to Discard_Node.
+
+ * sem_ch10.adb (Analyze_Compilation_Unit): Remove superfluous call to
+ Analyze on the library unit node after generation of distribution stub
+ constructs. The call was a no-op because Unit_Node has already been
+ Analyzed, and the tree fragments for the distribution stubs are
+ analyzed as they are inserted in Exp_Dist.
+ Update comment regarding to distribution stubs to reflect that we
+ do not generate stub in separate files anymore.
+
+ * einfo.ads: Clarify the fact that a tagged private type has the
+ E_Record_Type_With_Private Ekind.
+
+ * erroutc.adb: Minor reformatting
+
+ * erroutc.ads (Max_Msg_Length): Increase to cover possible larger
+ values if line length is increased using -gnatyM (noticed during code
+ reading).
+
+ * eval_fat.adb: Minor reformatting
+ Put spaces around exponentiation operator
+
+2004-05-10 Ed Schonberg <schonberg@gnat.com>
+
+ PR ada/15005
+ * sem_util.adb (Is_Dependent_Component_Of_Mutable_Object): If prefix
+ has been rewritten as an explicit dereference, retrieve type of
+ original node to check for possibly unconstrained record type.
+
+2004-05-10 Ed Schonberg <schonberg@gnat.com>
+
+ * exp_ch7.adb (Check_Visibly_Controlled): If given operation is not
+ overriding, use the operation of the parent unconditionally.
+
+ * sem_ch4.adb (Remove_Address_Interpretations): Remove address
+ operation when either operand is a literal, to avoid further
+ ambiguities.
+
+ * sem_ch6.adb (New_Overloaded_Entity): If new entity is inherited and
+ overridden by a previous explicit declaration, mark the previous entity
+ as overriding.
+
+ * sem_disp.adb (Check_Dispatching_Operation): New predicate
+ Is_Visibly_Controlled, to determine whether a declaration of a
+ primitive control operation for a derived type overrides an inherited
+ one. Add warning if the explicit declaration does not override.
+
+2004-05-10 Vincent Celier <celier@gnat.com>
+
+ * gnatls.adb (Gnatls): Initialize Snames, to avoid assertion error in
+ some cases when the sources are no longer present.
+
+ * make.adb (Collect_Arguments): Fail if an external source, not part
+ of any project need to be compiled, when switch -x has not been
+ specified.
+
+ * makeusg.adb: Document new switch -x
+
+ * opt.ads (External_Unit_Compilation_Allowed): New Boolean flag,
+ defaulted to False.
+
+ * switch-m.adb (Scan_Make_Switches): New switch -x
+
+ * vms_data.ads: Add VMS qualifier /NON_PROJECT_UNIT_COMPILATION for
+ gnatmake switch -x.
+
+ * gnat_ugn.texi: Document new gnatmake switch -x
+
+2004-05-10 Eric Botcazou <ebotcazou@act-europe.fr>
+
+ * misc.c (gnat_init_options): Set flag_zero_initialized_in_bss to 0.
+
+ * utils.c (create_var_decl): Do not modify the DECL_COMMON flag.
+ (process_attributes): Likewise.
+
+2004-05-10 Joel Brobecker <brobecker@gnat.com>
+
+ * s-inmaop.ads: Fix spelling mistake in one of the comments.
+
+2004-05-10 Robert Dewar <dewar@gnat.com>
+
+ * gnat_ugn.texi: Document that for config pragma files, the maximum
+ line length is always 32767.
+
+ * gnat_rm.texi: For pragma Eliminate, note that concatenation of string
+ literals is now allowed.
+
+ * gnat-style.texi: Remove statement about splitting long lines before
+ an operator rather than after, since we do not follow this rule at all.
+ Clarify rule (really lack of rule) for spaces around exponentiation
+
+ * sem_elim.adb: Allow concatenation of string literals as well as a
+ single string literal for pragma arguments.
+
+ * sem_prag.ads, sem_prag.adb: (Is_Config_Static_String): New function
+
+ * a-textio.adb (Terminate_Line): Do not add line feed if nothing
+ written for append case.
+
+ * frontend.adb: Changes to avoid checking max line length in config
+ pragma files.
+
+ * g-os_lib.ads: Minor reformatting
+
+ * mlib-utl.adb: Do not define Max_Line_Length locally (definition was
+ wrong in any case. Instead use standard value. Noticed during code
+ reading.
+
+ * opt.ads (Max_Line_Length): New field, used to implement removal of
+ limitation on length of lines when scanning config pragma files.
+
+ * osint.ads, prj-dect.adb, prj-strt.adb, prj-tree.adb,
+ makeutl.ads, makeutl.adb: Minor reformatting
+
+ * scn.adb: Do not check line length while scanning config pragma files
+ Do not check line length while scanning out license information
+
+ * scng.adb: Changes to avoid line length checks while parsing config
+ pragma files.
+
+2004-05-10 GNAT Script <nobody@gnat.com>
+
+ * Make-lang.in: Makefile automatically updated
+
2004-05-05 Arnaud Charlet <charlet@act-europe.fr>
* osint.adb (Find_Program_Name): Fix handling of VMS version
ada/erroutc.ads ada/exp_ch11.ads ada/exp_ch7.ads ada/exp_ch7.adb \
ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_tss.ads ada/exp_util.ads \
ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
+ ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
+ ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \
ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \
ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-htable.ads \
ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \
- ada/sem_elim.ads ada/sem_elim.adb ada/sinfo.ads ada/sinfo.adb \
- ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \
- ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
- ada/s-htable.adb ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/sem_elim.ads ada/sem_elim.adb ada/sem_prag.ads ada/sinfo.ads \
+ ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-htable.adb ada/s-imgenu.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \
+ s-auxdec.ads<5qauxdec.ads \
s-crtl.ads<5xcrtl.ads \
s-osinte.adb<5xosinte.adb \
s-osinte.ads<5xosinte.ads \
-- --
-- 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- --
-- because it is too much of a nuisance to have these odd line
-- feeds when nothing has been written to the file.
+ -- We also avoid this for files opened in append mode, in
+ -- accordance with (RM A.8.2(10))
+
elsif (File /= Standard_Err and then File /= Standard_Out)
and then (File.Line = 1 and then File.Page = 1)
+ and then Mode (File) = Out_File
then
New_Line (File);
end if;
-- A record subtype, created by a record subtype declaration.
E_Record_Type_With_Private,
- -- Used for types defined by a private extension declaration. Includes
- -- the fields for both private types and for record types (with the
- -- sole exception of Corresponding_Concurrent_Type which is obviously
- -- not needed). This entity is considered to be both a record type and
+ -- Used for types defined by a private extension declaration, and
+ -- for tagged private types. Includes the fields for both private
+ -- types and for record types (with the sole exception of
+ -- Corresponding_Concurrent_Type which is obviously not needed).
+ -- This entity is considered to be both a record type and
-- a private type.
E_Record_Subtype_With_Private,
-- A subtype of a type defined by a private extension declaration.
E_Private_Type,
- -- A private type, created by a private type declaration that does
- -- not have the keyword limited.
+ -- A private type, created by a private type declaration
+ -- that has neither the keyword limited nor the keyword tagged.
E_Private_Subtype,
-- A subtype of a private type, created by a subtype declaration used
E_Limited_Private_Type,
-- A limited private type, created by a private type declaration that
- -- has the keyword limited.
+ -- has the keyword limited, but not the keyword tagged.
E_Limited_Private_Subtype,
-- A subtype of a limited private type, created by a subtype declaration
-- --
-- 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- --
with Casing; use Casing;
with Debug; use Debug;
with Err_Vars; use Err_Vars;
-with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
function Buffer_Ends_With (S : String) return Boolean is
Len : constant Natural := S'Length;
-
begin
return
Msglen > Len
-- Returns True for a message that is to be purged. Also adjusts
-- error counts appropriately.
+ ------------------
+ -- To_Be_Purged --
+ ------------------
+
function To_Be_Purged (E : Error_Msg_Id) return Boolean is
begin
if E /= No_Error_Msg
-- This packages contains global variables and routines common to error
-- reporting packages, including Errout and Prj.Err.
-with Hostparm;
with Table;
with Types; use Types;
Manual_Quote_Mode : Boolean := False;
-- Set True in manual quotation mode
- Max_Msg_Length : constant := 256 + 2 * Hostparm.Max_Line_Length;
- -- Maximum length of error message. The addition of Max_Line_Length
+ Max_Msg_Length : constant := 1024 + 2 * Int (Column_Number'Last);
+ -- Maximum length of error message. The addition of 2 * Column_Number'Last
-- ensures that two insertion tokens of maximum length can be accomodated.
- -- The value of 256 is an arbitrary value that should be more than long
- -- enough to accomodate any reasonable message.
+ -- The value of 1024 is an arbitrary value that should be more than long
+ -- enough to accomodate any reasonable message (and for that matter, some
+ -- pretty unreasonable messages!)
Msg_Buffer : String (1 .. Max_Msg_Length);
-- Buffer used to prepare error messages
type Radix_Power_Table is array (Int range 1 .. 4) of Int;
- Radix_Powers : constant Radix_Power_Table
- := (Radix**1, Radix**2, Radix**3, Radix**4);
+ Radix_Powers : constant Radix_Power_Table :=
+ (Radix ** 1, Radix ** 2, Radix ** 3, Radix ** 4);
function Float_Radix return T renames Ureal_2;
-- Radix expressed in real form
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Fname; use Fname;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
-with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
begin
if Is_Derived_Type (Typ)
and then Comes_From_Source (E)
- and then Is_Overriding_Operation (E)
- and then
- (not Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Root_Type (Typ)))))
+ and then not Is_Overriding_Operation (E)
then
- -- We know that the explicit operation on the type overrode
+ -- We know that the explicit operation on the type does not override
-- the inherited operation of the parent, and that the derivation
-- is from a private type that is not visibly controlled.
Parent_Type := Etype (Typ);
Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
- if Present (Op)
- and then Is_Hidden (Op)
- and then Scope (Scope (Typ)) /= Scope (Op)
- and then not In_Open_Scopes (Scope (Typ))
- then
- -- If the parent operation is not visible, and the derived
- -- type is not declared in a child unit, then the explicit
- -- operation does not override, and we must use the operation
- -- of the parent.
-
+ if Present (Op) then
E := Op;
-- Wrap the object to be initialized into the proper
-- --
-- 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- --
begin
-- We always analyze config files with style checks off, since
-- we don't want a miscellaneous gnat.adc that is around to
- -- discombobulate intended -gnatg or -gnaty compilations.
+ -- discombobulate intended -gnatg or -gnaty compilations. We
+ -- also disconnect checking for maximum line length.
Opt.Style_Check := False;
Style_Check := False;
+ Opt.Max_Line_Length := Int (Column_Number'Last);
-- Capture current suppress options, which may get modified
-- Restore style check, but if config file turned on checks, leave on!
Opt.Style_Check := Save_Style_Check or Style_Check;
+ Opt.Max_Line_Length := Hostparm.Max_Line_Length;
-- Capture any modifications to suppress options from config pragmas
-- Time/Date Stuff --
---------------------
+ type OS_Time is private;
-- The OS's notion of time is represented by the private type OS_Time.
-- This is the type returned by the File_Time_Stamp functions to obtain
-- the time stamp of a specified file. Functions and a procedure (modeled
-- cases but rather the actual (time-zone independent) time stamp of the
-- file (of course in Unix systems, this *is* in GMT form).
- type OS_Time is private;
Invalid_Time : constant OS_Time;
+ -- A special unique value used to flag an invalid time stamp value
subtype Year_Type is Integer range 1900 .. 2099;
subtype Month_Type is Integer range 1 .. 12;
subtype Hour_Type is Integer range 0 .. 23;
subtype Minute_Type is Integer range 0 .. 59;
subtype Second_Type is Integer range 0 .. 59;
+ -- Declarations similar to those in Calendar, breaking down the time
+
function GM_Year (Date : OS_Time) return Year_Type;
function GM_Month (Date : OS_Time) return Month_Type;
function GM_Hour (Date : OS_Time) return Hour_Type;
function GM_Minute (Date : OS_Time) return Minute_Type;
function GM_Second (Date : OS_Time) return Second_Type;
+ -- Functions to extract information from OS_Time value
function "<" (X, Y : OS_Time) return Boolean;
function ">" (X, Y : OS_Time) return Boolean;
Hour : out Hour_Type;
Minute : out Minute_Type;
Second : out Second_Type);
+ -- Analogous to the routine of similar name in Calendar, takes an OS_Time
+ -- and splits it into its component parts with obvious meanings.
----------------
-- File Stuff --
@itemize @bullet
@item
-Every operator must be surrounded by spaces, except for the
-exponentiation operator.
+Every operator must be surrounded by spaces. An exception is that
+this rule does not apply to the exponentiation operator, for which
+there are no specific layout rules. The reason for this exception
+is that sometimes it makes clearer reading to leave out the spaces
+around exponentiation.
@cindex Operators
@smallexample @c adanocomment
@end smallexample
@item
-When folding a long line, fold before an operator, not after.
-
-@item
Use parentheses where they clarify the intended association of operands
with operators:
@cindex Parenthesization of expressions
Result_Type => result_SUBTYPE_NAME]
PARAMETER_TYPES ::= (SUBTYPE_NAME @{, SUBTYPE_NAME@})
-SUBTYPE_NAME ::= STRING_LITERAL
+SUBTYPE_NAME ::= STRING_VALUE
SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
-SOURCE_TRACE ::= STRING_LITERAL
+SOURCE_TRACE ::= STRING_VALUE
+
+STRING_VALUE ::= STRING_LITERAL @{& STRING_LITERAL@}
@end smallexample
@noindent
Use PARAMETER_AND_RESULT_TYPE_PROFILE to specify the profile of the subprogram
to be eliminated in a manner similar to that used for the extended
@code{Import} and @code{Export} pragmas, except that the subtype names are
-always given as string literals. At the moment, this form of distinguishing
+always given as strings. At the moment, this form of distinguishing
overloaded subprograms is implemented only partially, so we do not recommend
using it for practical subprogram elimination.
Alternatively, the @code{Source_Location} parameter is used to specify
which overloaded alternative is to be eliminated by pointing to the
location of the DEFINING_PROGRAM_UNIT_NAME of this subprogram in the
-source text. The string literal submitted as SOURCE_TRACE should have
-the following format:
+source text. The string literal (or concatenation of string literals)
+given as SOURCE_TRACE must have the following format:
@smallexample @c ada
SOURCE_TRACE ::= SOURCE_LOCATION@{LBRACKET SOURCE_LOCATION RBRACKET@}
Indicates the verbosity of the parsing of GNAT project files.
See @ref{Switches Related to Project Files}.
+@item ^-x^/NON_PROJECT_UNIT_COMPILATION^
+@cindex @option{^-x^/NON_PROJECT_UNIT_COMPILATION^} (@code{gnatmake})
+Indicates that sources that are not part of any Project File may be compiled.
+Normally, when using Project Files, only sources that are part of a Project
+File may be compile. When this switch is used, a source outside of all Project
+Files may be compiled. The ALI file and the object file will be put in the
+object directory of the main Project. The compilation switches used will only
+be those specified on the command line.
+
@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value}
Indicates that external variable @var{name} has the value @var{value}.
The Project Manager will use this value for occurrences of
@cindex @option{^-gnatyM^/MAX_LINE_LENGTH^} (@command{gnatstub})
(@var{n} is a non-negative integer). Set the maximum line length in the
body stub to @var{n}; the default is 79. The maximum value that can be
-specified is 32767.
+specified is 32767. Note that in the special case of configuration
+pragma files, the maximum is always 32767 regardless of whether or
+not this switch appears.
@item ^-gnaty^/STYLE_CHECKS=^@var{n}
@cindex @option{^-gnaty^/STYLE_CHECKS=^} (@command{gnatstub})
with Osint.L; use Osint.L;
with Output; use Output;
with Rident; use Rident;
+with Snames;
with Targparm; use Targparm;
with Types; use Types;
Namet.Initialize;
Csets.Initialize;
+ Snames.Initialize;
-- Loop to scan out arguments
#elif defined (VMS)
-#ifdef IN_RTS
+#ifdef __IA64
+#define lib_get_curr_invo_context LIB$I64_GET_CURR_INVO_CONTEXT
+#define lib_get_prev_invo_context LIB$I64_GET_PREV_INVO_CONTEXT
+#define lib_get_invo_handle LIB$I64_GET_INVO_HANDLE
+#else
+#define lib_get_curr_invo_context LIB$GET_CURR_INVO_CONTEXT
+#define lib_get_prev_invo_context LIB$GET_PREV_INVO_CONTEXT
+#define lib_get_invo_handle LIB$GET_INVO_HANDLE
+#endif
+
+#if defined (IN_RTS) && !defined (__IA64)
/* The prehandler actually gets control first on a condition. It swaps the
stack pointer and calls the handler (__gnat_error_handler). */
mstate = (long *) (*Get_Machine_State_Addr) ();
if (mstate != 0)
{
- LIB$GET_CURR_INVO_CONTEXT (&curr_icb);
- LIB$GET_PREV_INVO_CONTEXT (&curr_icb);
- LIB$GET_PREV_INVO_CONTEXT (&curr_icb);
- curr_invo_handle = LIB$GET_INVO_HANDLE (&curr_icb);
+ lib_get_curr_invo_context (&curr_icb);
+ lib_get_prev_invo_context (&curr_icb);
+ lib_get_prev_invo_context (&curr_icb);
+ curr_invo_handle = lib_get_invo_handle (&curr_icb);
*mstate = curr_invo_handle;
}
Raise_From_Signal_Handler (exception, msg);
__gnat_install_handler (void)
{
long prvhnd;
-#ifdef IN_RTS
+#if defined (IN_RTS) && !defined (__IA64)
char *c;
c = (char *) xmalloc (2049);
Project => Arguments_Project,
Path => Arguments_Path_Name);
- -- If the source is not a source of a project file,
- -- we simply add the saved gcc switches.
+ -- If the source is not a source of a project file, check if
+ -- this is allowed.
if Arguments_Project = No_Project then
+ if not External_Unit_Compilation_Allowed then
+ Make_Failed ("external source, not part of any projects, " &
+ "cannot be compiled (", Source_File_Name, ")");
+ end if;
+
+ -- If it is allowed, simply add the saved gcc switches
Add_Arguments (The_Saved_Gcc_Switches.all);
Write_Str (" -vPx Specify verbosity when parsing GNAT Project Files");
Write_Eol;
+ -- Line for -x
+
+ Write_Str (" -x " &
+ "Allow compilation of needed units external to the projects");
+ Write_Eol;
+
-- Line for -X
Write_Str (" -Xnm=val Specify an external reference for GNAT " &
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
-with Osint; use Osint;
-with Prj; use Prj;
+with Namet; use Namet;
+with Osint; use Osint;
+with Prj; use Prj;
with Prj.Ext;
with Prj.Util;
-with Snames; use Snames;
+with Snames; use Snames;
with Table;
-with Types; use Types;
+with Types; use Types;
with System.HTable;
-- Identify either a mono-unit source (when Index = 0) or a specific unit
-- in a multi-unit source.
+ -- There follow many global undocumented declarations, comments needed ???
+
Max_Mask_Num : constant := 2048;
subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
if Last_Linker_Option = Linker_Options_Buffer'Last then
declare
New_Buffer : constant String_List_Access :=
- new String_List
- (1 .. Linker_Options_Buffer'Last +
- Linker_Option_Initial_Count);
+ new String_List
+ (1 .. Linker_Options_Buffer'Last +
+ Linker_Option_Initial_Count);
begin
New_Buffer (Linker_Options_Buffer'Range) :=
Linker_Options_Buffer.all;
or else Equal_Pos >= Finish
then
return False;
-
else
Prj.Ext.Add
(External_Name => Argv (Start .. Equal_Pos - 1),
function Is_Marked
(Source_File : File_Name_Type;
- Index : Int := 0)
- return Boolean
+ Index : Int := 0) return Boolean
is
begin
return Marks.Get (K => (File => Source_File, Index => Index));
-----------------------------
function Linker_Options_Switches
- (Project : Project_Id)
- return String_List
+ (Project : Project_Id) return String_List
is
+ procedure Recursive_Add_Linker_Options (Proj : Project_Id);
+ -- The recursive routine used to add linker options
----------------------------------
-- Recursive_Add_Linker_Options --
----------------------------------
- procedure Recursive_Add_Linker_Options (Proj : Project_Id);
-
procedure Recursive_Add_Linker_Options (Proj : Project_Id) is
- Data : Project_Data;
+ Data : Project_Data;
Linker_Package : Package_Id;
- Options : Variable_Value;
- Imported : Project_List;
+ Options : Variable_Value;
+ Imported : Project_List;
+
begin
if Proj /= No_Project then
Data := Projects.Table (Proj);
end if;
end Recursive_Add_Linker_Options;
+ -- Start of processing for Linker_Options_Switches
+
begin
Linker_Opts.Init;
is
begin
if Switch /= null then
-
declare
Sw : String (1 .. Switch'Length);
Start : Positive;
Start : Natural;
Finish : Natural;
Result : Int := 0;
+
begin
Get_Name_String (ALI_File);
-- the character that precedes a unit index, this is not the ALI file
-- of a unit in a multi-unit source.
- if Start > Finish or else
- Start = 1 or else
- Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
+ if Start > Finish
+ or else Start = 1
+ or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
then
return 0;
end if;
-- Build the index from the digit(s)
while Start <= Finish loop
- Result := (Result * 10) + Character'Pos (Name_Buffer (Start))
- - Character'Pos ('0');
+ Result := Result * 10 +
+ Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
Start := Start + 1;
end loop;
-- --
------------------------------------------------------------------------------
-with GNAT.OS_Lib; use GNAT.OS_Lib;
with Osint;
-with Prj; use Prj;
-with Types; use Types;
+with Prj; use Prj;
+with Types; use Types;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package Makeutl is
type Fail_Proc is access procedure
- (S1 : String; S2 : String := ""; S3 : String := "");
+ (S1 : String;
+ S2 : String := "";
+ S3 : String := "");
Do_Fail : Fail_Proc := Osint.Fail'Access;
+ -- Comment required ???
function Unit_Index_Of (ALI_File : File_Name_Type) return Int;
-- Find the index of a unit in a source file. Return zero if the file
-- is not a multi-unit source file.
function Is_External_Assignment (Argv : String) return Boolean;
- -- Verify that an external assignment switch is syntactically correct.
- -- Correct forms are
+ -- Verify that an external assignment switch is syntactically correct
+ --
+ -- Correct forms are:
+ --
-- -Xname=value
-- -X"name=other value"
+ --
-- Assumptions: 'First = 1, Argv (1 .. 2) = "-X"
-- When this function returns True, the external assignment has
-- been entered by a call to Prj.Ext.Add, so that in a project
-- file, External ("name") will return "value".
+ function Linker_Options_Switches (Project : Project_Id) return String_List;
+ -- Comment required ???
+
-- 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.
- function Linker_Options_Switches (Project : Project_Id) return String_List;
-
package Mains is
-- Mains are stored in a table. An index is used to retrieve the mains
function Is_Marked
(Source_File : File_Name_Type;
- Index : Int := 0)
- return Boolean;
+ Index : Int := 0) return Boolean;
-- Returns True if the unit was previously marked.
procedure Delete_All_Marks;
save_argc = argc;
save_argv = argv;
+ /* Uninitialized really means uninitialized in Ada. */
+ flag_zero_initialized_in_bss = 0;
+
return CL_Ada;
}
abort ();
}
-
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2003, Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-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- --
Success : Boolean;
Line_Length : Natural := 0;
- Max_Line_Length : constant := 200; -- arbitrary
begin
Initialize;
Line_Length := Ar_Name'Length;
for J in Arguments'Range loop
+
-- Make sure the Output buffer does not overflow
- if Line_Length + 1 + Arguments (J)'Length > Max_Line_Length then
+ if Line_Length + 1 + Arguments (J)'Length >
+ Integer (Opt.Max_Line_Length)
+ then
Write_Eol;
Line_Length := 0;
end if;
-- effect if an explicit Link_Name is supplied (a link name is always
-- used exactly as given).
+ External_Unit_Compilation_Allowed : Boolean := False;
+ -- GNATMAKE
+ -- When True (set by gnatmake switch -x), allow compilation of sources
+ -- that are not part of any project file.
+
Float_Format : Character := ' ';
-- GNAT
-- A non-blank value indicates that a Float_Format pragma has been
-- extension, as set by the appropriate switch. If no switch is given,
-- then this value is initialized by Osint to the appropriate value.
+ Max_Line_Length : Int := Hostparm.Max_Line_Length;
+ -- This is a copy of Max_Line_Length used by the scanner. It is usually
+ -- set to be a copy of Hostparm.Max_Line_Length, and is used to check
+ -- the maximum line length in the scanner when style checking is inactive.
+ -- The only time it is set to a different value is during the scanning of
+ -- configuration pragma files, where we want to turn off all checking and
+ -- in particular we want to allow long lines. So we reset this value to
+ -- Column_Number'Last during scanning of configuration pragma files.
+
Maximum_Processes : Positive := 1;
-- GNATMAKE
-- Maximum number of processes that should be spawned to carry out
if Command_Name (Cindex2) in '0' .. '9' then
for J in reverse Cindex1 .. Cindex2 loop
-
if Command_Name (J) = '.' or Command_Name (J) = ';' then
Cindex2 := J - 1;
exit;
-- gives the total number of filenames found on the command line.
No_Index : constant := -1;
+ -- Value used in Add_File to indicate that no index is specified
+ -- for a main.
procedure Add_File (File_Name : String; Index : Int := No_Index);
-- Called by the subprogram processing the command line for each
- -- file name found.
+ -- file name found. The index, when not defaulted to No_Index
+ -- is the index of the subprogram in its source, zero indicating
+ -- that the source is not multi-unit.
procedure Find_Program_Name;
-- Put simple name of current program being run (excluding the directory
-- Set, if appropriate the index case insensitivity flag
elsif Attributes.Table (Current_Attribute).Kind_2 in
- Case_Insensitive_Associative_Array ..
- Optional_Index_Case_Insensitive_Associative_Array
+ Case_Insensitive_Associative_Array ..
+ Optional_Index_Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, To => True);
end if;
Expect (Tok_Integer_Literal, "integer literal");
if Token = Tok_Integer_Literal then
+
+ -- Set the source index value from given literal
+
declare
Index : constant Int :=
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg ("index cannot be zero", Token_Ptr);
-
else
- -- Set the index
Set_Source_Index_Of (Attribute, To => Index);
end if;
end;
Scan;
+ -- Check for possible index expression
+
if Token = Tok_At then
if not Optional_Index then
Error_Msg ("index not allowed here", Token_Ptr);
Scan;
end if;
+ -- Set the index value
+
else
Scan;
Expect (Tok_Integer_Literal, "integer literal");
begin
if Index = 0 then
Error_Msg ("index cannot be zero", Token_Ptr);
-
else
- -- Set the index
Set_Source_Index_Of (Term_Id, To => Index);
end if;
end;
(Project_Nodes.Table (Node).Kind = N_Variable_Reference
or else
Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration)
- and then
- Project_Nodes.Table (To).Kind = N_String_Type_Declaration);
+ and then
+ Project_Nodes.Table (To).Kind = N_String_Type_Declaration);
if Project_Nodes.Table (Node).Kind = N_Variable_Reference then
Project_Nodes.Table (Node).Field3 := To;
pragma Assert
(Node /= Empty_Node
and then
- (Project_Nodes.Table (Node).Kind = N_Literal_String
- or else
- Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
+ (Project_Nodes.Table (Node).Kind = N_Literal_String
+ or else
+ Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
return Project_Nodes.Table (Node).Src_Index;
end Source_Index_Of;
-- String_Type_Of --
--------------------
- function String_Type_Of
- (Node : Project_Node_Id) return Project_Node_Id
- is
+ function String_Type_Of (Node : Project_Node_Id) return Project_Node_Id is
begin
pragma Assert
(Node /= Empty_Node
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package System.Aux_DEC is
pragma Elaborate_Body (Aux_DEC);
+ subtype Short_Address is Address;
+ -- In some versions of System.Aux_DEC, notably that for VMS on the
+ -- ia64, there are two address types (64-bit and 32-bit), and the
+ -- name Short_Address is used for the short address form. To avoid
+ -- difficulties (in regression tests and elsewhere) with units that
+ -- reference Short_Address, it is provided for other targets as a
+ -- synonum for the normal Address type, and, as in the case where
+ -- the lengths are different, Address and Short_Address can be
+ -- freely inter-converted.
+
type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1;
for Integer_8'Size use 8;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998, 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- --
package System.Interrupt_Management.Operations is
procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID);
- -- Mask the calling thread for the interrupt
pragma Inline (Thread_Block_Interrupt);
+ -- Mask the calling thread for the interrupt
procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID);
- -- Unmask the calling thread for the interrupt
pragma Inline (Thread_Unblock_Interrupt);
+ -- Unmask the calling thread for the interrupt
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask);
-- Set the interrupt mask of the calling thread
+
procedure Set_Interrupt_Mask
(Mask : access Interrupt_Mask;
OMask : access Interrupt_Mask);
+ pragma Inline (Set_Interrupt_Mask);
-- Set the interrupt mask of the calling thread while returning the
-- previous Mask.
- pragma Inline (Set_Interrupt_Mask);
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask);
- -- Get the interrupt mask of the calling thread
pragma Inline (Get_Interrupt_Mask);
+ -- Get the interrupt mask of the calling thread
function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID;
- -- Wait for the interrupts specified in Mask and return
- -- the interrupt received. Upon error it return 0.
pragma Inline (Interrupt_Wait);
+ -- Wait for the interrupts specified in Mask and return
+ -- the interrupt received. Return 0 upon error.
procedure Install_Default_Action (Interrupt : Interrupt_ID);
- -- Set the sigaction of the Interrupt to default (SIG_DFL).
pragma Inline (Install_Default_Action);
+ -- Set the sigaction of the Interrupt to default (SIG_DFL).
procedure Install_Ignore_Action (Interrupt : Interrupt_ID);
- -- Set the sigaction of the Interrupt to ignore (SIG_IGN).
pragma Inline (Install_Ignore_Action);
+ -- Set the sigaction of the Interrupt to ignore (SIG_IGN).
procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask);
- -- Get a Interrupt_Mask with all the interrupt masked
pragma Inline (Fill_Interrupt_Mask);
+ -- Get a Interrupt_Mask with all the interrupt masked
procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask);
- -- Get a Interrupt_Mask with all the interrupt unmasked
pragma Inline (Empty_Interrupt_Mask);
+ -- Get a Interrupt_Mask with all the interrupt unmasked
procedure Add_To_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID);
- -- Mask the given interrupt in the Interrupt_Mask
pragma Inline (Add_To_Interrupt_Mask);
+ -- Mask the given interrupt in the Interrupt_Mask
procedure Delete_From_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID);
- -- Unmask the given interrupt in the Interrupt_Mask
pragma Inline (Delete_From_Interrupt_Mask);
+ -- Unmask the given interrupt in the Interrupt_Mask
function Is_Member
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID) return Boolean;
- -- See if a given interrupt is masked in the Interrupt_Mask
pragma Inline (Is_Member);
+ -- See if a given interrupt is masked in the Interrupt_Mask
procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask);
- -- Assigment needed for limited private type Interrupt_Mask.
pragma Inline (Copy_Interrupt_Mask);
+ -- Assigment needed for limited private type Interrupt_Mask.
procedure Interrupt_Self_Process (Interrupt : Interrupt_ID);
- -- raise an Interrupt process-level
pragma Inline (Interrupt_Self_Process);
+ -- Raise an Interrupt process-level
-- The following objects serve as constants, but are initialized
-- in the body to aid portability. These actually belong to the
-- System.Interrupt_Management but since Interrupt_Mask is a
-- private type we can not have them declared there.
+ -- Why not make these deferred constants that are initialized using
+ -- function calls in the private part???
+
Environment_Mask : aliased Interrupt_Mask;
-- This mask represents the mask of Environment task when this package
-- is being elaborated, except the signals being
with Atree; use Atree;
with Csets; use Csets;
-with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Scans; use Scans;
procedure Check_End_Of_Line is
Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
-
begin
- if Len > Hostparm.Max_Line_Length then
- Error_Long_Line;
-
- elsif Style_Check then
+ if Style_Check then
Style.Check_Line_Terminator (Len);
+ elsif Len > Opt.Max_Line_Length then
+ Error_Long_Line;
end if;
end Check_End_Of_Line;
function Determine_License return License_Type is
GPL_Found : Boolean := False;
+ Result : License_Type;
function Contains (S : String) return Boolean;
-- See if current comment contains successive non-blank characters
or else Source (Scan_Ptr + 1) /= '-'
then
if GPL_Found then
- return GPL;
+ Result := GPL;
+ exit;
else
- return Unknown;
+ Result := Unknown;
+ exit;
end if;
elsif Contains ("Asaspecialexception") then
if GPL_Found then
- return Modified_GPL;
+ Result := Modified_GPL;
+ exit;
end if;
elsif Contains ("GNUGeneralPublicLicense") then
Contains
("ThisspecificationisderivedfromtheAdaReferenceManual")
then
- return Unrestricted;
+ Result := Unrestricted;
+ exit;
end if;
Skip_EOL;
end;
end if;
end loop;
+
+ return Result;
end Determine_License;
----------------------------
begin
Error_Msg
("this line is too long",
- Current_Line_Start + Hostparm.Max_Line_Length);
+ Current_Line_Start + Source_Ptr (Opt.Max_Line_Length));
end Error_Long_Line;
------------------------
with Csets; use Csets;
with Err_Vars; use Err_Vars;
-with Hostparm; use Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Scans; use Scans;
if Style_Check and Style_Check_Max_Line_Length then
Style.Check_Line_Terminator (Len);
- elsif Len > Hostparm.Max_Line_Length then
+ -- If style checking is inactive, check maximum line length against
+ -- standard value. Note that we take this from Opt.Max_Line_Length
+ -- rather than Hostparm.Max_Line_Length because we do not want to
+ -- impose any limit during scanning of configuration pragma files,
+ -- and Opt.Max_Line_Length (normally set to Hostparm.Max_Line_Length)
+ -- is reset to Column_Number'Max during scanning of such files.
+
+ elsif Len > Opt.Max_Line_Length then
Error_Long_Line;
end if;
end Check_End_Of_Line;
begin
Error_Msg
("this line is too long",
- Current_Line_Start + Hostparm.Max_Line_Length);
+ Current_Line_Start + Source_Ptr (Opt.Max_Line_Length));
end Error_Long_Line;
-------------------------------
end;
end if;
- -- Generate distribution stub files if requested and no error
+ -- Generate distribution stubs if requested and no error
if N = Main_Cunit
and then (Distribution_Stub_Mode = Generate_Receiver_Stub_Body
Add_Stub_Constructs (N);
end if;
- -- Reanalyze the unit with the new constructs
-
- Analyze (Unit_Node);
end if;
if Nkind (Unit_Node) = N_Package_Declaration
-- subprograms are used to hide its operators, they will be
-- truly hidden.
- procedure Remove_Address_Interpretations;
+ type Operand_Position is (First_Op, Second_Op);
+
+ procedure Remove_Address_Interpretations (Op : Operand_Position);
-- Ambiguities may arise when the operands are literal and the
-- address operations in s-auxdec are visible. In that case, remove
-- the interpretation of a literal as Address, to retain the semantics
-- of Address as a private type.
------------------------------------
- -- Remove_Address_Intereprtations --
+ -- Remove_Address_Interpretations --
------------------------------------
- procedure Remove_Address_Interpretations is
+ procedure Remove_Address_Interpretations (Op : Operand_Position) is
Formal : Entity_Id;
begin
while Present (It.Nam) loop
Formal := First_Entity (It.Nam);
- if Is_Descendent_Of_Address (Etype (Formal))
- or else
- (Present (Next_Entity (Formal))
- and then
- Is_Descendent_Of_Address
- (Etype (Next_Entity (Formal))))
- then
+ if Op = Second_Op then
+ Formal := Next_Entity (Formal);
+ end if;
+
+ if Is_Descendent_Of_Address (Etype (Formal)) then
Remove_Interp (I);
end if;
Get_Next_Interp (I, It);
end loop;
- -- Remove corresponding predefined operator, which is
- -- always added to the overload set, unless it is a universal
- -- operation.
-
if No (Abstract_Op) then
return;
- -- Remove address interpretations if we have a universal
- -- interpretation. This avoids literals being interpreted
- -- as type Address, which is never appropriate.
-
elsif Nkind (N) in N_Op then
- if Nkind (N) in N_Unary_Op
- and then Present (Universal_Interpretation (Right_Opnd (N)))
- then
- Remove_Address_Interpretations;
+ -- Remove interpretations that treat literals as addresses.
+ -- This is never appropriate.
- elsif Nkind (N) in N_Binary_Op
- and then Present (Universal_Interpretation (Right_Opnd (N)))
- and then Present (Universal_Interpretation (Left_Opnd (N)))
- then
- Remove_Address_Interpretations;
+ if Nkind (N) in N_Binary_Op then
+ declare
+ U1 : constant Boolean :=
+ Present (Universal_Interpretation (Right_Opnd (N)));
+ U2 : constant Boolean :=
+ Present (Universal_Interpretation (Left_Opnd (N)));
- else
- Get_First_Interp (N, I, It);
- while Present (It.Nam) loop
- if Scope (It.Nam) = Standard_Standard then
- Remove_Interp (I);
+ begin
+ if U1 and then not U2 then
+ Remove_Address_Interpretations (Second_Op);
+
+ elsif U2 and then not U1 then
+ Remove_Address_Interpretations (First_Op);
end if;
- Get_Next_Interp (I, It);
- end loop;
+ if not (U1 and U2) then
+
+ -- Remove corresponding predefined operator, which is
+ -- always added to the overload set.
+
+ Get_First_Interp (N, I, It);
+ while Present (It.Nam) loop
+ if Scope (It.Nam) = Standard_Standard then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end;
end if;
elsif Nkind (N) = N_Function_Call
and then
Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
then
+
declare
Arg1 : constant Node_Id := First (Parameter_Associations (N));
+ U1 : constant Boolean :=
+ Present (Universal_Interpretation (Arg1));
+ U2 : constant Boolean :=
+ Present (Next (Arg1)) and then
+ Present (Universal_Interpretation (Next (Arg1)));
begin
- if Present (Universal_Interpretation (Arg1))
- and then
- (No (Next (Arg1))
- or else Present (Universal_Interpretation (Next (Arg1))))
- then
- Remove_Address_Interpretations;
+ if U1 and then not U2 then
+ Remove_Address_Interpretations (First_Op);
- else
+ elsif U2 and then not U1 then
+ Remove_Address_Interpretations (Second_Op);
+ end if;
+
+ if not (U1 and U2) then
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
if Scope (It.Nam) = Standard_Standard
end if;
-- If the removal has left no valid interpretations, emit
- -- error message now an label node as illegal.
+ -- error message now and label node as illegal.
if Present (Abstract_Op) then
Get_First_Interp (N, I, It);
end if;
-- In any case the implicit operation remains hidden by
- -- the existing declaration.
+ -- the existing declaration, which is overriding.
+ Set_Is_Overriding_Operation (E);
return;
-- Within an instance, the renaming declarations for
-- --
-- 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- --
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
+with Stand; use Stand;
with Sinfo; use Sinfo;
with Uintp; use Uintp;
Has_Dispatching_Parent : Boolean := False;
Body_Is_Last_Primitive : Boolean := False;
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
+ -- Check whether T is derived from a visibly controlled type.
+ -- This is true if the root type is declared in Ada.Finalization.
+ -- If T is derived instead from a private type whose full view
+ -- is controlled, an explicit Initialize/Adjust/Finalize subprogram
+ -- does not override the inherited one.
+
+ ---------------------------
+ -- Is_Visibly_Controlled --
+ ---------------------------
+
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
+ Root : constant Entity_Id := Root_Type (T);
+ begin
+ return Chars (Scope (Root)) = Name_Finalization
+ and then Chars (Scope (Scope (Root))) = Name_Ada
+ and then Scope (Scope (Scope (Root))) = Standard_Standard;
+ end Is_Visibly_Controlled;
+
+ -- Start of processing for Check_Dispatching_Operation
+
begin
if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then
return;
if Present (Old_Subp) then
Check_Subtype_Conformant (Subp, Old_Subp);
- Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
- Set_Is_Overriding_Operation (Subp);
+ if (Chars (Subp) = Name_Initialize
+ or else Chars (Subp) = Name_Adjust
+ or else Chars (Subp) = Name_Finalize)
+ and then Is_Controlled (Tagged_Type)
+ and then not Is_Visibly_Controlled (Tagged_Type)
+ then
+ Set_Is_Overriding_Operation (Subp, False);
+ Error_Msg_NE
+ ("operation does not override inherited&?", Subp, Subp);
+ else
+ Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
+ Set_Is_Overriding_Operation (Subp);
+ end if;
else
Add_Dispatching_Operation (Tagged_Type, Subp);
end if;
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Sinput; use Sinput;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Sem_Prag; use Sem_Prag;
+with Sinput; use Sinput;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
with Table;
with GNAT.HTable; use GNAT.HTable;
+
package body Sem_Elim is
No_Elimination : Boolean;
Data.Entity_Scope (1) := Chars (Arg_Ent);
- elsif Nkind (Arg_Entity) = N_String_Literal then
- String_To_Name_Buffer (Strval (Arg_Entity));
+ elsif Is_Config_Static_String (Arg_Entity) then
Data.Entity_Name := Name_Find;
Data.Entity_Node := Arg_Entity;
else
- Error_Msg_N
- ("wrong form for Entity_Argument parameter of pragma%",
- Arg_Unit_Name);
return;
end if;
else
if Present (Arg_Parameter_Types) then
- -- Case of one name, which looks like a parenthesized literal
- -- rather than an aggregate.
+ -- Here for aggregate case
- if Nkind (Arg_Parameter_Types) = N_String_Literal
- and then Paren_Count (Arg_Parameter_Types) = 1
- then
+ if Nkind (Arg_Parameter_Types) = N_Aggregate then
+ Data.Parameter_Types :=
+ new Names
+ (1 .. List_Length (Expressions (Arg_Parameter_Types)));
+
+ Lit := First (Expressions (Arg_Parameter_Types));
+ for J in Data.Parameter_Types'Range loop
+ if Is_Config_Static_String (Lit) then
+ Data.Parameter_Types (J) := Name_Find;
+ Next (Lit);
+ else
+ return;
+ end if;
+ end loop;
+
+ -- Otherwise we must have case of one name, which looks like a
+ -- parenthesized literal rather than an aggregate.
+
+ elsif Paren_Count (Arg_Parameter_Types) /= 1 then
+ Error_Msg_N
+ ("wrong form for argument of pragma Eliminate",
+ Arg_Parameter_Types);
+ return;
+
+ elsif Is_Config_Static_String (Arg_Parameter_Types) then
String_To_Name_Buffer (Strval (Arg_Parameter_Types));
if Name_Len = 0 then
Data.Parameter_Types := new Names'(1 => Name_Find);
end if;
- -- Otherwise must be an aggregate
-
- elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
- or else Present (Component_Associations (Arg_Parameter_Types))
- or else No (Expressions (Arg_Parameter_Types))
- then
- Error_Msg_N
- ("Parameter_Types for pragma% must be list of string literals",
- Arg_Parameter_Types);
- return;
-
- -- Here for aggregate case
-
else
- Data.Parameter_Types :=
- new Names
- (1 .. List_Length (Expressions (Arg_Parameter_Types)));
-
- Lit := First (Expressions (Arg_Parameter_Types));
- for J in Data.Parameter_Types'Range loop
- if Nkind (Lit) /= N_String_Literal then
- Error_Msg_N
- ("parameter types for pragma% must be string literals",
- Lit);
- return;
- end if;
-
- String_To_Name_Buffer (Strval (Lit));
- Data.Parameter_Types (J) := Name_Find;
- Next (Lit);
- end loop;
+ return;
end if;
end if;
-- Process Result_Types argument
if Present (Arg_Result_Type) then
-
- if Nkind (Arg_Result_Type) /= N_String_Literal then
- Error_Msg_N
- ("Result_Type argument for pragma% must be string literal",
- Arg_Result_Type);
+ if Is_Config_Static_String (Arg_Result_Type) then
+ Data.Result_Type := Name_Find;
+ else
return;
end if;
- String_To_Name_Buffer (Strval (Arg_Result_Type));
- Data.Result_Type := Name_Find;
+ -- Here if no Result_Types argument
else
Data.Result_Type := No_Name;
-- Process Source_Location argument
if Present (Arg_Source_Location) then
-
- if Nkind (Arg_Source_Location) /= N_String_Literal then
- Error_Msg_N
- ("Source_Location argument for pragma% must be string literal",
- Arg_Source_Location);
+ if Is_Config_Static_String (Arg_Source_Location) then
+ Data.Source_Location := Name_Find;
+ else
return;
end if;
-
- String_To_Name_Buffer (Strval (Arg_Source_Location));
- Data.Source_Location := Name_Find;
-
else
Data.Source_Location := No_Name;
end if;
when Unknown_Pragma =>
raise Program_Error;
-
end case;
exception
and then
(Is_Generic_Instance (Result)
or else Nkind (Parent (Declaration_Node (Result))) =
- N_Subprogram_Renaming_Declaration)
+ N_Subprogram_Renaming_Declaration)
and then Present (Alias (Result))
loop
Result := Alias (Result);
return Result;
end Get_Base_Subprogram;
+ -----------------------------
+ -- Is_Config_Static_String --
+ -----------------------------
+
+ function Is_Config_Static_String (Arg : Node_Id) return Boolean is
+
+ function Add_Config_Static_String (Arg : Node_Id) return Boolean;
+ -- This is an internal recursive function that is just like the
+ -- outer function except that it adds the string to the name buffer
+ -- rather than placing the string in the name buffer.
+
+ ------------------------------
+ -- Add_Config_Static_String --
+ ------------------------------
+
+ function Add_Config_Static_String (Arg : Node_Id) return Boolean is
+ N : Node_Id;
+ C : Char_Code;
+
+ begin
+ N := Arg;
+
+ if Nkind (N) = N_Op_Concat then
+ if Add_Config_Static_String (Left_Opnd (N)) then
+ N := Right_Opnd (N);
+ else
+ return False;
+ end if;
+ end if;
+
+ if Nkind (N) /= N_String_Literal then
+ Error_Msg_N ("string literal expected for pragma argument", N);
+ return False;
+
+ else
+ for J in 1 .. String_Length (Strval (N)) loop
+ C := Get_String_Char (Strval (N), J);
+
+ if not In_Character_Range (C) then
+ Error_Msg
+ ("string literal contains invalid wide character",
+ Sloc (N) + 1 + Source_Ptr (J));
+ return False;
+ end if;
+
+ Add_Char_To_Name_Buffer (Get_Character (C));
+ end loop;
+ end if;
+
+ return True;
+ end Add_Config_Static_String;
+
+ -- Start of prorcessing for Is_Config_Static_String
+
+ begin
+ Name_Len := 0;
+ return Add_Config_Static_String (Arg);
+ end Is_Config_Static_String;
+
-----------------------------------------
-- Is_Non_Significant_Pragma_Reference --
-----------------------------------------
-- --
-- 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- --
-- False is returned, then the argument is treated as an entity reference
-- to the operator.
+ function Is_Config_Static_String (Arg : Node_Id) return Boolean;
+ -- This is called for a configuration pragma that requires either a
+ -- string literal or a concatenation of string literals. We cannot
+ -- use normal static string processing because it is too early in
+ -- the case of the pragma appearing in a configuration pragmas file.
+ -- If Arg is of an appropriate form, then this call obtains the string
+ -- (doing any necessary concatenations) and places it in Name_Buffer,
+ -- setting Name_Len to its length, and then returns True. If it is
+ -- not of the correct form, then an appropriate error message is
+ -- posted, and False is returned.
+
procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
-- Called at the start of processing compilation unit N to deal with
-- any special issues regarding pragmas. In particular, we have to
Rtyp := Typ;
end if;
- if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn))
- or else not Rep
- then
+ Discard_Node (
+ Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
+
+ if not Rep then
return;
end if;
P_Aliased := True;
end if;
+ -- A discriminant check on a selected component may be
+ -- expanded into a dereference when removing side-effects.
+ -- Recover the original node and its type, which may be
+ -- unconstrained.
+
+ elsif Nkind (P) = N_Explicit_Dereference
+ and then not (Comes_From_Source (P))
+ then
+ P := Original_Node (P);
+ Prefix_Type := Etype (P);
+
else
-- Check for prefix being an aliased component ???
null;
+
end if;
if Is_Access_Type (Prefix_Type)
Ptr := Ptr + 1;
Verbose_Mode := True;
+ -- Processing for x switch
+
+ when 'x' =>
+ Ptr := Ptr + 1;
+ External_Unit_Compilation_Allowed := True;
+
-- Processing for z switch
when 'z' =>
|| (static_flag && ! init_const)))
assign_init = var_init, var_init = 0;
- DECL_COMMON (var_decl) = !flag_no_common;
DECL_INITIAL (var_decl) = var_init;
TREE_READONLY (var_decl) = const_flag;
DECL_EXTERNAL (var_decl) = extern_flag;
DECL_SECTION_NAME (decl)
= build_string (IDENTIFIER_LENGTH (attr_list->name),
IDENTIFIER_POINTER (attr_list->name));
- DECL_COMMON (decl) = 0;
}
else
post_error ("?section attributes are not supported for this target",
-- will execute the elaboration routines of the package and its closure,
-- then the finalization routines.
+ S_Make_Nonpro : aliased constant S := "/NON_PROJECT_UNIT_COMPILATION " &
+ "-x";
+ -- /NON_PROJECT_UNIT_COMPILATION
+ --
+ -- Normally, when using project files, a unit that is not part of any
+ -- project file, cannot be compile. These units may be compile, when
+ -- needed, if this qualifier is specified.
+
S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
"-nostdinc";
-- /NOSTD_INCLUDES
S_Make_Minimal 'Access,
S_Make_Nolink 'Access,
S_Make_Nomain 'Access,
+ S_Make_Nonpro 'Access,
S_Make_Nostinc 'Access,
S_Make_Nostlib 'Access,
S_Make_Object 'Access,
OSDN Git Service
