1---------------------------------------------------------------------- 2-- Rules.Unsafe_Paired_Calls.Signatures - Package body -- 3-- -- 4-- This module is (c) Adalog 2004-2016. -- 5-- The Ada Controller is free software; you can redistribute it -- 6-- and/or modify it under terms of the GNU General Public License -- 7-- as published by the Free Software Foundation; either version 2, -- 8-- or (at your option) any later version. This unit is distributed -- 9-- in the hope that it will be useful, but WITHOUT ANY WARRANTY; -- 10-- without even the implied warranty of MERCHANTABILITY or FITNESS -- 11-- FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 12-- for more details. You should have received a copy of the GNU -- 13-- General Public License distributed with this program; see file -- 14-- COPYING. If not, write to the Free Software Foundation, 59 -- 15-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- 16-- -- 17-- As a special exception, if other files instantiate generics -- 18-- from the units of this program, or if you link this unit with -- 19-- other files to produce an executable, this unit does not by -- 20-- itself cause the resulting executable to be covered by the GNU -- 21-- General Public License. This exception does not however -- 22-- invalidate any other reasons why the executable file might be -- 23-- covered by the GNU Public License. -- 24-- -- 25-- This software is distributed in the hope that it will be -- 26-- useful, but WITHOUT ANY WARRANTY; without even the implied -- 27-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- 28-- PURPOSE. -- 29---------------------------------------------------------------------- 30 31-- ASIS 32with 33 Asis.Declarations, 34 Asis.Elements, 35 Asis.Expressions, 36 Asis.Statements; 37 38-- Adalog 39with 40 Thick_Queries, 41 Utilities; 42 43package body Rules.Unsafe_Paired_Calls.Services is 44 45 Nil_Signature : constant Nesting_Signature := Nesting_Signature (Asis.Nil_Element_List); 46 47 ------------------------------------ 48 -- Effective_Last_Statement_Index -- 49 ------------------------------------ 50 51 function Effective_Last_Statement_Index (Stats : Asis.Statement_List) return Asis.List_Index is 52 use Asis, Asis.Elements; 53 use Utilities; 54 begin 55 for S in reverse Stats'Range loop 56 case Statement_Kind (Stats (S)) is 57 when A_Return_Statement | An_Exit_Statement | A_Null_Statement => 58 null; 59 when others => 60 return S; 61 end case; 62 end loop; 63 64 -- Statement list contains only return, exit and null statements... 65 -- we shouldn't be here! 66 Failure ("No effective statement in statements list"); 67 end Effective_Last_Statement_Index; 68 69 70 ------------------------- 71 -- Is_Boolean_Constant -- 72 ------------------------- 73 74 function Is_Boolean_Constant (Expr : Asis.Expression) return Boolean is 75 use Asis, Asis.Declarations, Asis.Elements, Asis.Expressions; 76 use Thick_Queries, Utilities; 77 78 Decl : Asis.Declaration; 79 begin 80 if Expression_Kind (Expr) /= An_Identifier then 81 return False; 82 end if; 83 84 Decl := Corresponding_Name_Declaration (Ultimate_Name (Expr)); 85 if Declaration_Kind (Decl) /= A_Constant_Declaration then 86 return False; 87 end if; 88 89 if To_Upper (Full_Name_Image (Subtype_Simple_Name (Object_Declaration_View (Decl)))) /= "STANDARD.BOOLEAN" then 90 return False; 91 end if; 92 93 return True; 94 end Is_Boolean_Constant; 95 96 97 ------------------------------------------------------------------ 98 -- Exported subprograms 99 ------------------------------------------------------------------ 100 101 ------------------------------ 102 -- Effective_Last_Statement -- 103 ------------------------------ 104 105 function Effective_Last_Statement (Stats : Asis.Statement_List) return Asis.Statement is 106 begin 107 return Stats (Effective_Last_Statement_Index (Stats)); 108 end Effective_Last_Statement; 109 110 111 --------------- 112 -- Signature -- 113 --------------- 114 115 function Signature (Stmt : Asis.Statement) return Nesting_Signature is 116 use Asis.Elements; 117 118 function Enclosing_Signature (Elem : Asis.Element) return Nesting_Signature is 119 use Asis, Asis.Statements; 120 begin 121 case Element_Kind (Elem) is 122 when A_Statement => 123 case Statement_Kind (Elem) is 124 when An_If_Statement => 125 if Conditionals_Allowed.Value = Off then 126 raise Invalid_Nesting with "nested calls not allowed"; 127 end if; 128 declare 129 Expr : constant Asis.Expression := Condition_Expression (Statement_Paths (Elem) (1)); 130 begin 131 if not Is_Boolean_Constant (Expr) then 132 raise Invalid_Nesting with "if condition is not a boolean constant"; 133 end if; 134 return Enclosing_Signature (Enclosing_Element (Elem)) & Elem & Expr; 135 end; 136 when others => 137 return Nil_Signature; 138 end case; 139 140 when A_Path => 141 case Path_Kind (Elem) is 142 when An_If_Path | An_Else_Path => 143 -- Only one non effective statement allowed, must be the first statement 144 declare 145 Stats : constant Asis.Statement_List := Thick_Queries.Statements (Elem); 146 begin 147 if Effective_Last_Statement_Index (Stats) /= Stats'First then 148 raise Invalid_Nesting with "path contains disallowed statements"; 149 end if; 150 end; 151 return Enclosing_Signature (Enclosing_Element (Elem)) & Elem; 152 when others => 153 raise Invalid_Nesting with "call in disallowed structured statement"; 154 end case; 155 156 when others => 157 return Nil_Signature; 158 end case; 159 end Enclosing_Signature; 160 161 begin -- Signature 162 return Enclosing_Signature (Enclosing_Element (Stmt)) & Stmt; 163 end Signature; 164 165 ------------------- 166 -- Matching_Call -- 167 ------------------- 168 169 function Matching_Call (Stat : Asis.Statement; Signature : Nesting_Signature) return Asis.Statement is 170 -- A signature contains only statements (if statements, procedure call) or paths (if_path, else_path) 171 use Asis, Asis.Elements, Asis.Expressions, Asis.Statements; 172 use Thick_Queries, Utilities; 173 174 Current : Asis.Element := Stat; 175 begin 176 case Statement_Kind (Stat) is 177 when An_If_Statement | A_Procedure_Call_Statement | An_Entry_Call_Statement => 178 null; 179 when others => 180 return Nil_Element; 181 end case; 182 183 for E in Signature'Range loop 184 case Element_Kind (Signature (E)) is 185 when An_Expression => 186 declare 187 Expr : constant Asis.Expression := Condition_Expression (Statement_Paths (Current) (1)); 188 begin 189 if not Is_Boolean_Constant (Expr) then 190 return Nil_Element; 191 end if; 192 if not Is_Equal (Corresponding_Name_Declaration (Ultimate_Name (Signature (E))), 193 Corresponding_Name_Declaration (Ultimate_Name (Expr))) 194 then 195 return Nil_Element; 196 end if; 197 end; 198 199 when A_Statement => 200 case Statement_Kind (Signature (E)) is 201 when An_If_Statement => 202 if Statement_Kind (Current) /= An_If_Statement then 203 return Nil_Element; 204 end if; 205 when A_Procedure_Call_Statement | An_Entry_Call_Statement => 206 if Statement_Kind (Current) /= Statement_Kind (Signature (E)) then 207 return Nil_Element; 208 end if; 209 when others => 210 Failure ("Bad signature: not a call statement", Signature (E)); 211 end case; 212 213 when A_Path => 214 declare 215 If_Paths : constant Asis.Path_List := Statement_Paths (Current); 216 begin 217 case Path_Kind (Signature (E)) is 218 when An_If_Path => 219 Current := If_Paths (1); 220 when An_Else_Path => 221 if If_Paths'Length = 1 or else Path_Kind (If_Paths (2)) /= An_Else_Path then 222 return Nil_Element; 223 end if; 224 Current := If_Paths (2); 225 when others => 226 Failure ("Bad signature: bad path", Signature (E)); 227 end case; 228 end; 229 Current := Sequence_Of_Statements (Current) (1); 230 231 when others => 232 Failure ("Bad signature: unexpected element", Signature (E)); 233 end case; 234 end loop; 235 236 return Current; 237 end Matching_Call; 238 239end Rules.Unsafe_Paired_Calls.Services; 240