procedure Abort_Handler (Sig : Signal) is
pragma Unreferenced (Sig);
- T : Task_ID := Self;
+ T : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2003 Free Software Fundation --
+-- Copyright (C) 1998-2004 Free Software Fundation --
-- --
-- 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- --
task body Server_Task is
Desc : Handler_Desc renames Descriptors (Interrupt);
- Self_Id : Task_ID := STPO.Self;
+ Self_Id : constant Task_ID := STPO.Self;
Temp : Parameterless_Handler;
begin
is
pragma Warnings (Off, Info);
- Scp : Sigcontext_Ptr := To_Sigcontext_Ptr (M);
+ Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M);
procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
pragma Import (C, Exc_Unwind, "exc_unwind");
function Check_Sleep (Reason : Task_States) return Boolean is
pragma Unreferenced (Reason);
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
-----------------
task body Server_Task is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
Tmp_Handler : Parameterless_Handler;
Tmp_ID : Task_ID;
Tmp_Entry_Index : Task_Entry_Index;
procedure Timer_Sleep_AST (ID : Address) is
Result : Interfaces.C.int;
- Self_ID : Task_ID := To_Task_ID (ID);
+ Self_ID : constant Task_ID := To_Task_ID (ID);
begin
Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
procedure Interrupt_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
- AST_Self_ID : Task_ID := To_Task_ID (ID);
+ AST_Self_ID : constant Task_ID := To_Task_ID (ID);
begin
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
---------------------
procedure RMS_AST_Handler (ID : Address) is
- AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
+ AST_Self_ID : constant Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
Result : Interfaces.C.int;
begin
----------
function Self return Unsigned_Longword is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
begin
Self_ID.Common.LL.AST_Pending := True;
return To_Unsigned_Longword (Self);
procedure Starlet_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
- AST_Self_ID : Task_ID := To_Task_ID (ID);
+ AST_Self_ID : constant 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);
+2004-04-01 Robert Dewar <dewar@gnat.com>
+
+ * checks.adb: Minor reformatting throughout
+ Note that prev checkin added RM reference to alignment warning
+
+2004-04-01 Ed Schonberg <schonberg@gnat.com>
+
+ * exp_aggr.adb (Get_Component_Val): Treat a string literal as
+ non-static when building aggregate for bit-packed array.
+
+ * exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a
+ function call that is itself the actual in a procedure call, build
+ temporary for it.
+
+ * exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is
+ a string literal, create a temporary for it, constant folding only
+ handles scalars here.
+
+2004-04-01 Vincent Celier <celier@gnat.com>
+
+ * ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC,
+ Error_Msg_SP): New empty procedures to instantiate the Scanner.
+ (Style, Scanner): Instantiations of Styleg and Scng to be able to scan
+ tokens.
+ (Accumulate_Checksum, Initialize_Checksum): Remove procedures.
+ (Get_File_Checksum): Use the instantiated scanner to scan all the tokens
+ and get the checksum.
+
+ * make.adb (Gnatmake): Do not insert into Q the Main_Source if it is
+ already in the Q.
+ Increase the Marking_Label at the end of the Multiple_Main_Loop,
+ instead of at the beginning.
+
+ * osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~'
+ directly.
+ (Osint package elaboration): Change Multi_Unit_Index_Character to '$' if
+ on VMS.
+
+ * osint.ads (Multi_Unit_Index_Character): New Character global variable
+
+ * osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character,
+ not '~' directly.
+
+ * par.adb: Remove test on file name to detect language defined units.
+ Add test on unit name, after parsing, to detect language defined units
+ that are not compiled with -gnatg (except System.RPC and its children)
+
+ * par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the
+ following units without style checking.
+
+ * switch-c.adb: Change -gnatC to -gnateI
+
+ * usage.adb: Document new switch -gnateInnn
+
+ * scng.adb (Accumulate_Token_Checksum): New procedure
+ (Scan): Call Accumulate_Token_Checksum after each identifier, reserved
+ word or literal number.
+ (Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral
+ numbers.
+
+2004-04-01 Thomas Quinot <quinot@act-europe.fr>
+
+ * a-tasatt.adb,
+ g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb,
+ switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb,
+ 5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb,
+ 5vtpopde.adb: Add missing 'constant' keywords.
+
+2004-04-01 Javier Miranda <miranda@gnat.com>
+
+ * par-ch4.adb: (P_Allocator): Code cleanup
+
+ * sem_ch3.adb (Access_Definition): Properly set the null-excluding
+ attribute.
+
+ * sinfo.ads: Complete documentation of previous change
+
+2004-04-01 Pascal Obry <obry@gnat.com>
+
+ * gnatlink.adb (Process_Binder_File): Remove duplicate linker options
+ only on VMS. This special handling was done because an old GNU/ld bug
+ on Windows which has been fixed.
+
+2004-04-01 GNAT Script <nobody@gnat.com>
+
+ * Make-lang.in: Makefile automatically updated
+
2004-03-31 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, make_type_from_size):
ada/debug.o \
ada/einfo.o \
ada/elists.o \
+ ada/err_vars.o \
+ ada/errout.o \
+ ada/erroutc.o \
ada/fmap.o \
ada/fname.o \
ada/g-hesora.o \
ada/s-wchcnv.o \
ada/s-wchcon.o \
ada/s-wchjis.o \
+ ada/scng.o \
+ ada/scans.o \
ada/sdefault.o \
ada/sinfo.o \
ada/sinput.o \
+ ada/sinput-c.o \
ada/snames.o \
ada/stand.o \
ada/stringt.o \
ada/switch-b.o \
ada/switch.o \
+ ada/style.o \
+ ada/styleg.o \
+ ada/stylesw.o \
ada/system.o \
ada/table.o \
ada/targparm.o \
ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/ali.ads \
ada/ali-util.ads ada/ali-util.adb ada/alloc.ads ada/binderr.ads \
- ada/casing.ads ada/debug.ads ada/gnat.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/interfac.ads ada/lib.ads ada/namet.ads ada/namet.adb ada/opt.ads \
- ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \
- ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-exctab.adb \
- ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-rident.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/unchconv.ads ada/unchdeal.ads ada/widechar.ads
+ ada/casing.ads ada/csets.ads ada/debug.ads ada/err_vars.ads \
+ ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \
+ ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/rident.ads ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads \
+ ada/sinput.adb ada/sinput-c.ads ada/snames.ads ada/stringt.ads \
+ ada/stringt.adb ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
+ ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \
+ ada/s-rident.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/types.adb ada/uintp.ads ada/uintp.adb \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
+ ada/widechar.ads
ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/ali.ads \
ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads ada/debug.ads \
ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/ali-util.ads \
ada/ali-util.adb ada/alloc.ads ada/bcheck.ads ada/bcheck.adb \
- ada/binderr.ads ada/butil.ads ada/casing.ads ada/debug.ads \
- ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
- ada/lib.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \
- ada/output.ads ada/rident.ads ada/system.ads ada/s-crc32.ads \
- ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.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/unchconv.ads \
- ada/unchdeal.ads ada/widechar.ads
+ ada/binderr.ads ada/butil.ads ada/casing.ads ada/csets.ads \
+ ada/debug.ads ada/err_vars.ads ada/fname.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \
+ ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \
+ ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput-c.ads \
+ ada/snames.ads ada/stringt.ads ada/styleg.ads ada/styleg.adb \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.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/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/widechar.ads
ada/binde.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/alloc.ads \
ada/binde.ads ada/binde.adb ada/binderr.ads ada/butil.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/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/opt.ads ada/output.ads ada/sinput.ads \
+ ada/sinput-c.ads ada/sinput-c.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-memory.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/unchconv.ads \
+ ada/unchdeal.ads
+
ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/osint.ads \
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute_Handle
is
- TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to get the reference of a ";
+ TT : constant Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to get the reference of a ";
begin
if TT = null then
procedure Reinitialize
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
- TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to Reinitialize a ";
+ TT : constant Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to Reinitialize a ";
begin
if TT = null then
(Val : Attribute;
T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
- TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to Set the Value of a ";
+ TT : constant Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to Set the Value of a ";
begin
if TT = null then
-----------
function Value
- (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute
is
- TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to get the Value of a ";
+ TT : constant Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to get the Value of a ";
begin
if TT = null then
-- --
-- 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 Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
-
-with System.CRC32;
-with System.Memory;
+with Scans; use Scans;
+with Scng;
+with Sinput.C;
+with Snames; use Snames;
+with Styleg;
package body ALI.Util is
+ -- Empty procedures needed to instantiate Scng. Error procedures are
+ -- empty, because we don't want to report any errors when computing
+ -- a source checksum.
+
+ procedure Post_Scan;
+
+ procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+
+ procedure Error_Msg_S (Msg : String);
+
+ procedure Error_Msg_SC (Msg : String);
+
+ procedure Error_Msg_SP (Msg : String);
+
+ -- Instantiation of Styleg, needed to instantiate Scng
+
+ package Style is new Styleg
+ (Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
+
+ -- A Scanner is needed to get checksum of a source (procedure
+ -- Get_File_Checksum).
+
+ package Scanner is new Scng
+ (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP, Style);
+
type Header_Num is range 0 .. 1_000;
function Hash (F : File_Name_Type) return Header_Num;
Hash => Hash,
Equal => "=");
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Accumulate_Checksum (C : Character; Csum : in out Word);
- pragma Inline (Accumulate_Checksum);
- -- This routine accumulates the checksum given character C. During the
- -- scanning of a source file, this routine is called with every character
- -- in the source, excluding blanks, and all control characters (except
- -- that ESC is included in the checksum). Upper case letters not in string
- -- literals are folded by the caller. See Sinput spec for the documentation
- -- of the checksum algorithm. Note: checksum values are only used if we
- -- generate code, so it is not necessary to worry about making the right
- -- sequence of calls in any error situation.
-
- procedure Initialize_Checksum (Csum : out Word);
- -- Sets initial value of Csum before any calls to Accumulate_Checksum
-
- -------------------------
- -- Accumulate_Checksum --
- -------------------------
-
- procedure Accumulate_Checksum (C : Character; Csum : in out Word) is
- begin
- System.CRC32.Update (System.CRC32.CRC32 (Csum), C);
- end Accumulate_Checksum;
-
---------------------
-- Checksums_Match --
---------------------
return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error;
end Checksums_Match;
- -----------------------
- -- Get_File_Checksum --
- -----------------------
-
- function Get_File_Checksum (Fname : Name_Id) return Word is
- Src : Source_Buffer_Ptr;
- Hi : Source_Ptr;
- Csum : Word;
- Ptr : Source_Ptr;
-
- Bad : exception;
- -- Raised if file not found, or file format error
+ pragma Warnings (Off);
+ -- To avoid warnings on non referenced parameters of the error procedures
- use ASCII;
- -- Make control characters visible
+ ---------------
+ -- Error_Msg --
+ ---------------
+ procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
begin
- Read_Source_File (Fname, 0, Hi, Src);
-
- -- If we cannot find the file, then return an impossible checksum,
- -- impossible becaues checksums have the high order bit zero, so
- -- that checksums do not match.
-
- if Src = null then
- raise Bad;
- end if;
-
- Initialize_Checksum (Csum);
- Ptr := 0;
-
- loop
- case Src (Ptr) is
-
- -- Spaces and formatting information are ignored in checksum
-
- when ' ' | CR | LF | VT | FF | HT =>
- Ptr := Ptr + 1;
-
- -- EOF is ignored unless it is the last character
-
- when EOF =>
- if Ptr = Hi then
- System.Memory.Free (Src.all'Address);
- return Csum;
- else
- Ptr := Ptr + 1;
- end if;
+ null;
+ end Error_Msg;
- -- Non-blank characters that are included in the checksum
+ pragma Warnings (Off);
+ -- To avoid warnings on non referenced parameters of the error procedures
- when '#' | '&' | '*' | ':' | '(' | ',' | '.' | '=' | '>' |
- '<' | ')' | '/' | ';' | '|' | '!' | '+' | '_' |
- '0' .. '9' | 'a' .. 'z'
- =>
- Accumulate_Checksum (Src (Ptr), Csum);
- Ptr := Ptr + 1;
+ -----------------
+ -- Error_Msg_S --
+ -----------------
- -- Upper case letters, fold to lower case
-
- when 'A' .. 'Z' =>
- Accumulate_Checksum
- (Character'Val (Character'Pos (Src (Ptr)) + 32), Csum);
- Ptr := Ptr + 1;
-
- -- Left bracket, really should do wide character thing here,
- -- but for now, don't bother.
-
- when '[' =>
- raise Bad;
-
- -- Minus, could be comment
-
- when '-' =>
- if Src (Ptr + 1) = '-' then
- Ptr := Ptr + 2;
-
- while Src (Ptr) >= ' ' or else Src (Ptr) = HT loop
- Ptr := Ptr + 1;
- end loop;
-
- else
- Accumulate_Checksum ('-', Csum);
- Ptr := Ptr + 1;
- end if;
-
- -- String delimited by double quote
-
- when '"' =>
- Accumulate_Checksum ('"', Csum);
-
- loop
- Ptr := Ptr + 1;
- exit when Src (Ptr) = '"';
-
- if Src (Ptr) < ' ' then
- raise Bad;
- end if;
-
- Accumulate_Checksum (Src (Ptr), Csum);
- end loop;
-
- Accumulate_Checksum ('"', Csum);
- Ptr := Ptr + 1;
-
- -- String delimited by percent
-
- when '%' =>
- Accumulate_Checksum ('%', Csum);
-
- loop
- Ptr := Ptr + 1;
- exit when Src (Ptr) = '%';
-
- if Src (Ptr) < ' ' then
- raise Bad;
- end if;
+ procedure Error_Msg_S (Msg : String) is
+ begin
+ null;
+ end Error_Msg_S;
- Accumulate_Checksum (Src (Ptr), Csum);
- end loop;
+ ------------------
+ -- Error_Msg_SC --
+ ------------------
- Accumulate_Checksum ('%', Csum);
- Ptr := Ptr + 1;
+ procedure Error_Msg_SC (Msg : String) is
+ begin
+ null;
+ end Error_Msg_SC;
- -- Quote, could be character constant
+ ------------------
+ -- Error_Msg_SP --
+ ------------------
- when ''' =>
- Accumulate_Checksum (''', Csum);
+ procedure Error_Msg_SP (Msg : String) is
+ begin
+ null;
+ end Error_Msg_SP;
- if Src (Ptr + 2) = ''' then
- Accumulate_Checksum (Src (Ptr + 1), Csum);
- Accumulate_Checksum (''', Csum);
- Ptr := Ptr + 3;
+ pragma Warnings (On);
- -- Otherwise assume attribute char. We should deal with wide
- -- character cases here, but that's hard, so forget it.
+ -----------------------
+ -- Get_File_Checksum --
+ -----------------------
- else
- Ptr := Ptr + 1;
- end if;
+ function Get_File_Checksum (Fname : Name_Id) return Word is
+ Full_Name : Name_Id;
+ Source_Index : Source_File_Index;
+ begin
+ Full_Name := Find_File (Fname, Osint.Source);
- -- Upper half character, more to be done here, we should worry
- -- about folding Latin-1, folding other character sets, and
- -- dealing with the nasty case of upper half wide encoding.
+ -- If we cannot find the file, then return an impossible checksum,
+ -- impossible becaues checksums have the high order bit zero, so
+ -- that checksums do not match.
- when Upper_Half_Character =>
- Accumulate_Checksum (Src (Ptr), Csum);
- Ptr := Ptr + 1;
+ if Full_Name = No_File then
+ return Checksum_Error;
+ end if;
- -- Escape character, we should do the wide character thing here,
- -- but for now, do not bother.
+ Source_Index := Sinput.C.Load_File (Get_Name_String (Full_Name));
- when ESC =>
- raise Bad;
+ if Source_Index = No_Source_File then
+ return Checksum_Error;
+ end if;
- -- Invalid control characters
+ Scanner.Initialize_Scanner (Types.No_Unit, Source_Index);
- when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
- SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
- EM | FS | GS | RS | US | DEL
- =>
- raise Bad;
+ -- Make sure that the project language reserved words are not
+ -- recognized as reserved words, but as identifiers. The byte info for
+ -- those names have been set if we are in gnatmake.
- -- Invalid graphic characters
+ Set_Name_Table_Byte (Name_Project, 0);
+ Set_Name_Table_Byte (Name_Extends, 0);
+ Set_Name_Table_Byte (Name_External, 0);
- when '$' | '?' | '@' | '`' | '\' |
- '^' | '~' | ']' | '{' | '}'
- =>
- raise Bad;
+ -- Scan the complete file to compute its checksum
- end case;
+ loop
+ Scanner.Scan;
+ exit when Token = Tok_EOF;
end loop;
- exception
- when Bad =>
- System.Memory.Free (Src.all'Address);
- return Checksum_Error;
+ return Scans.Checksum;
end Get_File_Checksum;
----------
Interfaces.Reset;
end Initialize_ALI_Source;
- -------------------------
- -- Initialize_Checksum --
- -------------------------
+ ---------------
+ -- Post_Scan --
+ ---------------
- procedure Initialize_Checksum (Csum : out Word) is
+ procedure Post_Scan is
begin
- System.CRC32.Initialize (System.CRC32.CRC32 (Csum));
- end Initialize_Checksum;
+ null;
+ end Post_Scan;
--------------
-- Read_ALI --
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
- Ck_Node : Node_Id)
- return Node_Id;
+ Ck_Node : Node_Id) return Node_Id;
-- In the access type case, guard the test with a test to ensure
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result;
+ Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Length_Checks, except it doesn't modify
-- anything, just returns a list of nodes as described in the spec of
-- this package for the Range_Check function.
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result;
+ Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
-- just returns a list of nodes as described in the spec of this package
-- for the Range_Check function.
function Build_Discriminant_Checks
(N : Node_Id;
- T_Typ : Entity_Id)
- return Node_Id
+ T_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Cond : Node_Id;
is
function Within_Range_Of
(Target_Type : Entity_Id;
- Check_Type : Entity_Id)
- return Boolean;
+ Check_Type : Entity_Id) return Boolean;
-- Given a requirement for checking a range against Target_Type, and
-- and a range Check_Type against which a check has already been made,
-- determines if the check against check type is sufficient to ensure
function Within_Range_Of
(Target_Type : Entity_Id;
- Check_Type : Entity_Id)
- return Boolean
+ Check_Type : Entity_Id) return Boolean
is
begin
if Target_Type = Check_Type then
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
- Ck_Node : Node_Id)
- return Node_Id
+ Ck_Node : Node_Id) return Node_Id
is
begin
if Nkind (Cond) = N_Or_Else then
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
- Warn_Node : Node_Id := Empty)
- return Check_Result
+ Warn_Node : Node_Id := Empty) return Check_Result
is
begin
return Selected_Range_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result
+ Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
S_Typ : Entity_Id;
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
+ -- Comments required ???
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
function Length_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Exptyp'Length
function Length_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Expr'Length
function Length_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
function Length_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
- Warn_Node : Node_Id)
- return Check_Result
+ Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
S_Typ : Entity_Id;
function Discrete_Range_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Low_Bound (Expr) < Typ'First
-- or else
function Discrete_Expr_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id;
+ Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Expr < Typ'First
-- or else
function Get_E_First_Or_Last
(E : Entity_Id;
Indx : Nat;
- Nam : Name_Id)
- return Node_Id;
+ Nam : Name_Id) return Node_Id;
-- Returns expression to compute:
-- E'First or E'Last
function Range_Equal_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
function Range_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id;
+ Indx : Nat) return Node_Id;
-- Return expression to compute:
-- Expr'First < Typ'First or else Expr'Last > Typ'Last
function Discrete_Expr_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ Typ : Entity_Id) return Node_Id
is
begin
return
function Discrete_Range_Cond
(Expr : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ Typ : Entity_Id) return Node_Id
is
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
function Get_E_First_Or_Last
(E : Entity_Id;
Indx : Nat;
- Nam : Name_Id)
- return Node_Id
+ Nam : Name_Id) return Node_Id
is
N : Node_Id;
LB : Node_Id;
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
-
end Get_N_First;
----------------
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
-
end Get_N_Last;
------------------
function Range_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
function Range_Equal_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
function Range_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
- Indx : Nat)
- return Node_Id
+ Indx : Nat) return Node_Id
is
begin
return
Analyze_And_Resolve (N, Ctyp);
- -- Must have a compile time value
+ -- Must have a compile time value. String literals have to
+ -- be converted into temporaries as well, because they cannot
+ -- easily be converted into their bit representation.
- if not Compile_Time_Known_Value (N) then
+ if not Compile_Time_Known_Value (N)
+ or else Nkind (N) = N_String_Literal
+ then
raise Not_Handled;
end if;
loop
if Nkind (Par) = N_Procedure_Call_Statement then
return True;
+
+ elsif Nkind (Par) = N_Function_Call then
+ return False;
+
else
Par := Parent (Par);
end if;
-- conversion is analyzed immediately so that subsequent processing
-- can work with an analyzed Rhs (and e.g. look at its Etype)
+ -- If the right-hand side is a string literal, create a temporary for
+ -- it, constant-folding is not ready to wrap the bit representation
+ -- of a string literal.
+
+ if Nkind (Rhs) = N_String_Literal then
+ declare
+ Decl : Node_Id;
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
+ Object_Definition => New_Occurrence_Of (Ctyp, Loc),
+ Expression => New_Copy_Tree (Rhs));
+
+ Insert_Actions (N, New_List (Decl));
+ Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc);
+ end;
+ end if;
+
Rhs := Convert_To (Ctyp, Rhs);
Set_Parent (Rhs, N);
Analyze_And_Resolve (Rhs, Ctyp);
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
S : String (1 .. 1024);
Last : Natural;
- It : Pointer := Iterator'Unrestricted_Access;
+ It : constant Pointer := Iterator'Unrestricted_Access;
Current : Depth := It.Current_Depth;
NL : Positive;
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
- elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
+ elsif not (Hostparm.OpenVMS
+ and then
+ Is_Option_Present (Next_Line (Nfirst .. Nlast)))
+ then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
else
while Last_Argument + Args'Length > Arguments'Last loop
declare
- New_Arguments : Argument_List_Access :=
- new Argument_List (1 .. Arguments'Last * 2);
-
+ New_Arguments : constant Argument_List_Access :=
+ new Argument_List (1 .. Arguments'Last * 2);
begin
New_Arguments (1 .. Last_Argument) :=
Arguments (1 .. Last_Argument);
Check_Source_Files := True;
All_Sources := False;
- Insert_Q (Main_Source);
- Mark (Main_Source);
+ -- Only insert in the Q if it is not already done, to avoid simultaneous
+ -- compilations if -jnnn is used.
+
+ if not Is_Marked (Main_Source) then
+ Insert_Q (Main_Source);
+ Mark (Main_Source);
+ end if;
First_Compiled_File := No_File;
Most_Recent_Obj_File := No_File;
Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop
- -- Increase the marking label to be sure to check sources
- -- for all executables.
-
- Marking_Label := Marking_Label + 1;
-
- -- Make sure it is not 0, which is the default value for
- -- a file that has never been marked.
-
- if Marking_Label = 0 then
- Marking_Label := 1;
- end if;
-
-- First, find the executable name and path
Executable := No_File;
end;
end if;
end if;
+
+ -- Increase the marking label to be sure to check sources
+ -- for all executables.
+
+ Marking_Label := Marking_Label + 1;
+
+ -- Make sure it is not 0, which is the default value for
+ -- a file that has never been marked.
+
+ if Marking_Label = 0 then
+ Marking_Label := 1;
+ end if;
end loop Multiple_Main_Loop;
if Failed_Links.Last > 0 then
end Verbose_Msg;
begin
+ -- Make sure that in case of failure, the temp files will be deleted
+
Prj.Com.Fail := Make_Failed'Access;
MLib.Fail := Make_Failed'Access;
- -- Make sure that in case of failure, the temp files will be deleted
end Make;
Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
begin
Name_Len := Dot_Index - 1;
- Add_Char_To_Name_Buffer ('~');
+ Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
Dot_Index := Name_Len + 1;
Add_Str_To_Name_Buffer (Exten);
end loop;
if Munit_Index /= 0 then
- Add_Char_To_Name_Buffer ('~');
+ Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
Add_Nat_To_Name_Buffer (Munit_Index);
end if;
type Actual_Source_Ptr is access Actual_Source_Buffer;
-- This is the pointer type for the physical buffer allocated
- Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
+ Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
-- And this is the actual physical buffer
begin
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
+ -- On VMS, '~' is not allowed in file names. Change the multi unit
+ -- index character to '$'.
+
+ if Hostparm.OpenVMS then
+ Multi_Unit_Index_Character := '$';
+ end if;
+
-- Following should be removed by having above function return
-- Integer'Last as indication of no maximum instead of -1 ???
package Osint is
+ Multi_Unit_Index_Character : Character := '~';
+ -- The character before the index of the unit in a multi-unit source,
+ -- in ALI and object file names. This is not a constant, because it is
+ -- changed to '$' on VMS.
+
Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
Project_Include_Path_File : constant String := "ADA_PRJ_INCLUDE_FILE";
-- Skip tokens to end of file, so that the -gnatl listing
-- will be complete in this situation, but no need to parse
- -- the remaining units.
+ -- the remaining units; no style checking either.
- while Token /= Tok_EOF loop
- Scan;
- end loop;
+ declare
+ Save_Style_Check : constant Boolean := Style_Check;
+ begin
+ Style_Check := False;
+
+ while Token /= Tok_EOF loop
+ Scan;
+ end loop;
+
+ Style_Check := Save_Style_Check;
+ end;
return Comp_Unit_Node;
-- Scan Null_Exclusion if present (Ada 0Y (AI-231))
- if Extensions_Allowed then
- Null_Exclusion_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
-
- -- If Ada 95, null exclusion never present
-
- else
- Null_Exclusion_Present := False;
- end if;
-
+ Null_Exclusion_Present := P_Null_Exclusion;
+ Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
Type_Node := P_Subtype_Mark_Resync;
if Token = Tok_Apostrophe then
else
Save_Opt_Config_Switches (Save_Config_Switches);
- -- Special processing for language defined units. For this purpose
- -- we do NOT consider the renamings in annex J as predefined. That
- -- allows users to compile their own versions of these files, and
- -- in particular, in the VMS implementation, the DEC versions can
- -- be substituted for the standard Ada 95 versions.
-
- if Is_Predefined_File_Name
- (Fname => File_Name (Current_Source_File),
- Renamings_Included => False)
- then
- Set_Opt_Config_Switches
- (Is_Internal_File_Name (File_Name (Current_Source_File)));
-
- -- If this is the main unit, disallow compilation unless the -gnatg
- -- (GNAT mode) switch is set (from a user point of view, the rule is
- -- that language defined units cannot be recompiled).
-
- -- However, an exception is s-rpc, and its children. We test this
- -- by looking at the characters after the minus. The rule is that
- -- only s-rpc and its children have names starting s-rp.
-
- Get_Name_String (File_Name (Current_Source_File));
-
- if (Name_Len < 5 or else Name_Buffer (1 .. 4) /= "s-rp")
- and then Current_Source_Unit = Main_Unit
- and then not GNAT_Mode
- and then Operating_Mode = Generate_Code
- then
- Error_Msg_SC ("language defined units may not be recompiled");
- end if;
- end if;
-
-- The following loop runs more than once in syntax check mode
-- where we allow multiple compilation units in the same file
-- and in Multiple_Unit_Per_file mode where we skip units till
Save_Operating_Mode : constant Operating_Mode_Type :=
Operating_Mode;
+ Save_Style_Check : constant Boolean := Style_Check;
+
+
begin
Operating_Mode := Check_Syntax;
+ Style_Check := False;
Discard_Node (P_Compilation_Unit);
Operating_Mode := Save_Operating_Mode;
+ Style_Check := Save_Style_Check;
-- If we are at an end of file, and not yet at the right
-- unit, then we have a fatal error. The unit is missing.
-- check syntax mode we are interested in all units in the file.
else
- Discard_Node (P_Compilation_Unit);
+ declare
+ Comp_Unit_Node : constant Node_Id := P_Compilation_Unit;
+
+ begin
+ -- If parsing was successful and we are not in check syntax
+ -- mode, check that language defined units are compiled in
+ -- GNAT mode. For this purpose we do NOT consider renamings
+ -- in annex J as predefined. That allows users to compile
+ -- their own versions of these files, and in particular,
+ -- in the VMS implementation, the DEC versions can be
+ -- substituted for the standard Ada 95 versions. Another
+ -- exception is System.RPC and its children. This allows
+ -- a user to supply their own communication layer.
+
+ if Comp_Unit_Node /= Error
+ and then Operating_Mode = Generate_Code
+ and then Current_Source_Unit = Main_Unit
+ and then not GNAT_Mode
+ then
+ declare
+ Name : constant String :=
+ Get_Name_String
+ (Unit_Name (Current_Source_Unit));
+ begin
+ if (Name = "ada" or else
+ Name = "calendar" or else
+ Name = "interfaces" or else
+ Name = "system" or else
+ Name = "machine_code" or else
+ Name = "unchecked_conversion" or else
+ Name = "unchecked_deallocation"
+ or else (Name'Length > 4
+ and then
+ Name (Name'First .. Name'First + 3) =
+ "ada.")
+ or else (Name'Length > 11
+ and then
+ Name (Name'First .. Name'First + 10) =
+ "interfaces.")
+ or else (Name'Length > 7
+ and then
+ Name (Name'First .. Name'First + 6) =
+ "system."))
+ and then Name /= "system.rpc"
+ and then
+ (Name'Length < 11
+ or else Name (Name'First .. Name'First + 10) /=
+ "system.rpc.")
+ then
+ Error_Msg
+ ("language defined units may not be recompiled",
+ Sloc (Unit (Comp_Unit_Node)));
+ end if;
+ end;
+ end if;
+ end;
-- All done if at end of file
if not SS_Ratio_Dynamic then
declare
- Fixed_Stack : Fixed_Stack_Ptr := To_Fixed_Stack_Ptr (Stk);
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (Stk);
begin
Fixed_Stack.Top := 0;
Mode : Call_Modes;
Block : out Communication_Block)
is
- Self_ID : Task_ID := STPO.Self;
+ Self_ID : constant Task_ID := STPO.Self;
Entry_Call : Entry_Call_Link;
Initially_Abortable : Boolean;
Ceiling_Violation : Boolean;
-- Local Subprograms --
-----------------------
+ procedure Accumulate_Token_Checksum;
+ pragma Inline (Accumulate_Token_Checksum);
+
procedure Accumulate_Checksum (C : Character);
pragma Inline (Accumulate_Checksum);
-- This routine accumulates the checksum given character C. During the
Accumulate_Checksum (Character'Val (C mod 256));
end Accumulate_Checksum;
+ -------------------------------
+ -- Accumulate_Token_Checksum --
+ -------------------------------
+
+ procedure Accumulate_Token_Checksum is
+ begin
+ System.CRC32.Update
+ (System.CRC32.CRC32 (Checksum),
+ Character'Val (Token_Type'Pos (Token)));
+ end Accumulate_Token_Checksum;
+
----------------------------
-- Determine_Token_Casing --
----------------------------
-- Procedure to scan integer literal. On entry, Scan_Ptr points to
-- a digit, on exit Scan_Ptr points past the last character of
-- the integer.
+ --
-- For each digit encountered, UI_Int_Value is multiplied by 10,
-- and the value of the digit added to the result. In addition,
-- the value in Scale is decremented by one for each actual digit
C := Source (Scan_Ptr);
if C = '_' then
- Accumulate_Checksum ('_');
+ -- We do not want to accumulate the '_' in the checksum,
+ -- so that 1_234 is equivalent to 1234, and does not
+ -- trigger compilation in "minimal recompilation"
+ -- (gnatmake -m).
loop
Scan_Ptr := Scan_Ptr + 1;
end if;
+ Accumulate_Token_Checksum;
+
return;
end Nlit;
-- of the corresponding keyword.
Token_Name := No_Name;
+ Accumulate_Token_Checksum;
return;
-- It is an identifier after all
else
Token := Tok_Identifier;
+ Accumulate_Token_Checksum;
Post_Scan;
return;
end if;
end Scan;
+
--------------------------
-- Set_Comment_As_Token --
--------------------------
-- Ada 95 semantics. In Ada 0Y, anonymous access must specify if the
-- null value is allowed; in Ada 95 the null value is not allowed
- if Extensions_Allowed
- and then Null_Exclusion_Present (N)
- then
- Set_Can_Never_Be_Null (Anon_Type);
+ if Extensions_Allowed then
+ Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
else
- Set_Can_Never_Be_Null (Anon_Type);
+ Set_Can_Never_Be_Null (Anon_Type, True);
end if;
-- The anonymous access type is as public as the discriminated type or
-- subprogram that defines it. It is imported (for back-end purposes)
-- if the designated type is.
- Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
+ Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
-- Ada 0Y (AI-50217): Propagate the attribute that indicates that the
-- designated type comes from the limited view (for back-end purposes).
- Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
+ Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
-- Ada 0Y (AI-231): Propagate the access-constant attribute
--------------------------------
-- SUBTYPE_DECLARATION ::=
- -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
+ -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
-- The subtype indication field is set to Empty for subtypes
-- declared in package Standard (Positive, Natural).
-- directly in the tree as a subtype mark. The N_Subtype_Indication
-- node is used only if a constraint is present.
+ -- Note: [For Ada 0Y (AI-231)]: Because Ada 0Y extends this rule with
+ -- the null-exclusion part (see AI-231), we had to introduce a new
+ -- attribute in all the parents of subtype_indication nodes to indicate
+ -- if the null-exclusion is present.
+
-- Note: the reason that this node has expression fields is that a
-- subtype indication can appear as an operand of a membership test.
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
- -- SUBTYPE_INDICATION [:= EXPRESSION];
+ -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- | SINGLE_TASK_DECLARATION
----------------------------------
-- DERIVED_TYPE_DEFINITION ::=
- -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
+ -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
+ -- [RECORD_EXTENSION_PART]
-- Note: ABSTRACT, record extension part not permitted in Ada 83 mode
-------------------------------
-- COMPONENT_DEFINITION ::=
- -- [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
+ -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Note: although the syntax does not permit a component definition to
-- be an anonymous array (and the parser will diagnose such an attempt
-------------------------------------
-- DISCRIMINANT_SPECIFICATION ::=
- -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
+ -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
-- [:= DEFAULT_EXPRESSION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
-- [:= DEFAULT_EXPRESSION]
-- ACCESS_TO_OBJECT_DEFINITION
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
+ --------------------------
+ -- 3.10 Null Exclusion --
+ --------------------------
+
+ -- NULL_EXCLUSION ::= not null
+
---------------------------------------
-- 3.10 Access To Object Definition --
---------------------------------------
-- ACCESS_TO_OBJECT_DEFINITION ::=
- -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
+ -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER]
+ -- SUBTYPE_INDICATION
-- N_Access_To_Object_Definition
-- Sloc points to ACCESS
-------------------------------------------
-- ACCESS_TO_SUBPROGRAM_DEFINITION
- -- access [protected] procedure PARAMETER_PROFILE
- -- | access [protected] function PARAMETER_AND_RESULT_PROFILE
+ -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
+ -- | [NULL_EXCLUSION] access [protected] function
+ -- PARAMETER_AND_RESULT_PROFILE
-- Note: access to subprograms are not permitted in Ada 83 mode
-- 3.10 Access Definition --
-----------------------------
- -- ACCESS_DEFINITION ::= access SUBTYPE_MARK
+ -- ACCESS_DEFINITION ::=
+ -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
-- N_Access_Definition
-- Sloc points to ACCESS
--------------------
-- ALLOCATOR ::=
- -- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+ -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
-- Sprint syntax (when storage pool present)
-- new xxx (storage_pool = pool)
----------------------------------
-- PARAMETER_SPECIFICATION ::=
- -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
+ -- DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK
-- [:= DEFAULT_EXPRESSION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
-- [:= DEFAULT_EXPRESSION]
type Actual_Source_Ptr is access Actual_Source_Buffer;
-- This is the pointer type for the physical buffer allocated
- Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
+ Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
-- And this is the actual physical buffer
begin
ASIS_Mode := True;
end if;
- -- Processing for C switch
-
- when 'C' =>
- Ptr := Ptr + 1;
- Scan_Pos (Switch_Chars, 999, Ptr, Multiple_Unit_Index);
-
-- Processing for d switch
when 'd' =>
Full_Path_Name_For_Brief_Errors := True;
return;
+ -- -gnateI (index of unit in multi-unit source)
+
+ when 'I' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, 999, Ptr, Multiple_Unit_Index);
+
-- -gnatem (mapping file)
when 'm' =>
-- --
-- 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- --
elsif Last = Switches'Last then
declare
- New_Switches : Argument_List_Access := new Argument_List
- (1 .. Switches'Length + Switches'Length);
+ New_Switches : constant Argument_List_Access :=
+ new Argument_List
+ (1 .. Switches'Length + Switches'Length);
begin
New_Switches (1 .. Switches'Length) := Switches.all;
Last := Switches'Length;
end if;
-- If this is the first switch, Last designates the first component
+
if Last = 0 then
Last := Switches'First;
-
else
Last := Last + 1;
end if;
when 'e' =>
- -- Only -gnateD and -gnatep= need to be store in an ALI
- -- file.
+ -- Only -gnateD and -gnatep= need storing in ALI file
Storing (First_Stored) := 'e';
Ptr := Ptr + 1;
return;
end if;
- if Switch_Chars (Ptr) = 'D' then
- -- gnateD
+ -- Processing for -gnateD
+ if Switch_Chars (Ptr) = 'D' then
Storing (First_Stored + 1 ..
First_Stored + Max - Ptr + 1) :=
Switch_Chars (Ptr .. Max);
(Storing (Storing'First ..
First_Stored + Max - Ptr + 1));
- else
- -- gnatep=
+ -- Processing for -gnatep=
+ else
Ptr := Ptr + 1;
if Ptr = Max then
declare
To_Store : String (1 .. Max - Ptr + 9);
-
begin
To_Store (1 .. 8) := "-gnatep=";
To_Store (9 .. Max - Ptr + 9) :=
Write_Switch_Char ("ef");
Write_Line ("Full source path in brief error messages");
+ -- Line for -gnateI switch
+
+ Write_Switch_Char ("eInnn");
+ Write_Line ("Index in multi-unit source, e.g. -gnateI2");
+
-- Line for -gnatem switch
Write_Switch_Char ("em=?");
projects / gcc.git / commitdiff