From da574a866b86e92f0305e68ddb7f1993365fb5dd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 21 May 2014 14:39:44 +0200 Subject: [multiple changes] 2014-05-21 Robert Dewar * stand.adb (Tree_Read): Read missing entities. (Tree_Write): Write missing entities. 2014-05-21 Ben Brosgol * gnat_ugn.texi: Wordsmithing edits to Coupling Metrics Control section in gnatmetric chapter. 2014-05-21 Robert Dewar * exp_ch6.adb (Expand_Actuals): Spec moved here, since not used outside Exp_Ch6 (Expand_Actuals): Deal with proper insertion of post-call copy write back (see detailed comment in code). * exp_ch6.ads (Expand_Actuals): Moved to body, not used outside Exp_Ch6. * tbuild.ads: Minor reformatting. 2014-05-21 Robert Dewar * stand.ads: Add warning about adding new entities and Tree_Read/Tree_Write. 2014-05-21 Robert Dewar * sem_util.adb (Set_Entity_With_Checks): Don't complain about references to restricted entities within the units in which they are declared. 2014-05-21 Robert Dewar * gnat1drv.adb (Check_Bad_Body): Use Source_File_Is_Body to simplify the needed test, and also deal with failure to catch situations with non-standard names. * sinput-l.ads, sinput-l.adb (Source_File_Is_No_Body): New function (Source_File_Is_Subunit): Removed, no longer used. 2014-05-21 Javier Miranda * exp_ch4.adb (Expand_Allocator_Expression.Apply_Accessibility_Check): for a renaming of an access to interface object there is no need to generate extra code to reference the tag. From-SVN: r210696 --- gcc/ada/sinput-l.adb | 128 ++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 101 insertions(+), 27 deletions(-) (limited to 'gcc/ada/sinput-l.adb') diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index e2dbed3..c084555 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -795,9 +795,106 @@ package body Sinput.L is Prep_Buffer (Prep_Buffer_Last) := C; end Put_Char_In_Prep_Buffer; - ----------------------------------- - -- Source_File_Is_Pragma_No_Body -- - ----------------------------------- + ------------------------- + -- Source_File_Is_Body -- + ------------------------- + + function Source_File_Is_Body (X : Source_File_Index) return Boolean is + Pcount : Natural; + + begin + Initialize_Scanner (No_Unit, X); + + -- Loop to look for subprogram or package body + + loop + case Token is + + -- PRAGMA, WITH, USE (which can appear before a body) + + when Tok_Pragma | Tok_With | Tok_Use => + + -- We just want to skip any of these, do it by skipping to a + -- semicolon, but check for EOF, in case we have bad syntax. + + loop + if Token = Tok_Semicolon then + Scan; + exit; + elsif Token = Tok_EOF then + return False; + else + Scan; + end if; + end loop; + + -- PACKAGE + + when Tok_Package => + Scan; -- Past PACKAGE + + -- We have a body if and only if BODY follows + + return Token = Tok_Body; + + -- FUNCTION or PROCEDURE + + when Tok_Procedure | Tok_Function => + Pcount := 0; + + -- Loop through tokens following PROCEDURE or FUNCTION + + loop + Scan; + + case Token is + + -- For parens, count paren level (note that paren level + -- can get greater than 1 if we have default parameters). + + when Tok_Left_Paren => + Pcount := Pcount + 1; + + when Tok_Right_Paren => + Pcount := Pcount - 1; + + -- EOF means something weird, probably no body + + when Tok_EOF => + return False; + + -- BEGIN or IS or END definitely means body is present + + when Tok_Begin | Tok_Is | Tok_End => + return True; + + -- Semicolon means no body present if at outside any + -- parens. If within parens, ignore, since it could be + -- a parameter separator. + + when Tok_Semicolon => + if Pcount = 0 then + return False; + end if; + + -- Skip anything else + + when others => + null; + end case; + end loop; + + -- Anything else in main scan means we don't have a body + + when others => + return False; + end case; + end loop; + end Source_File_Is_Body; + + ---------------------------- + -- Source_File_Is_No_Body -- + ---------------------------- function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is begin @@ -826,27 +923,4 @@ package body Sinput.L is return Token = Tok_EOF; end Source_File_Is_No_Body; - ---------------------------- - -- Source_File_Is_Subunit -- - ---------------------------- - - function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is - begin - Initialize_Scanner (No_Unit, X); - - -- We scan past junk to the first interesting compilation unit token, to - -- see if it is SEPARATE. We ignore WITH keywords during this and also - -- PRIVATE. The reason for ignoring PRIVATE is that it handles some - -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. - - while Token = Tok_With - or else Token = Tok_Private - or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) - loop - Scan; - end loop; - - return Token = Tok_Separate; - end Source_File_Is_Subunit; - end Sinput.L; -- cgit v1.1