1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . H E L P E R S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26------------------------------------------------------------------------------ 27 28package body Ada.Containers.Helpers is 29 30 package body Generic_Implementation is 31 32 use type SAC.Atomic_Unsigned; 33 34 ------------ 35 -- Adjust -- 36 ------------ 37 38 procedure Adjust (Control : in out Reference_Control_Type) is 39 pragma Warnings (Off); 40 -- GNAT warns here if checks are turned off, but assertions on 41 pragma Assert (T_Check); -- not called if check suppressed 42 pragma Warnings (On); 43 begin 44 if Control.T_Counts /= null then 45 Lock (Control.T_Counts.all); 46 end if; 47 end Adjust; 48 49 ---------- 50 -- Busy -- 51 ---------- 52 53 procedure Busy (T_Counts : in out Tamper_Counts) is 54 begin 55 if T_Check then 56 SAC.Increment (T_Counts.Busy); 57 end if; 58 end Busy; 59 60 -------------- 61 -- Finalize -- 62 -------------- 63 64 procedure Finalize (Control : in out Reference_Control_Type) is 65 pragma Warnings (Off); 66 pragma Assert (T_Check); -- not called if check suppressed 67 pragma Warnings (On); 68 begin 69 if Control.T_Counts /= null then 70 Unlock (Control.T_Counts.all); 71 Control.T_Counts := null; 72 end if; 73 end Finalize; 74 75 -- No need to protect against double Finalize here, because these types 76 -- are limited. 77 78 procedure Finalize (Busy : in out With_Busy) is 79 pragma Warnings (Off); 80 pragma Assert (T_Check); -- not called if check suppressed 81 pragma Warnings (On); 82 begin 83 Unbusy (Busy.T_Counts.all); 84 end Finalize; 85 86 procedure Finalize (Lock : in out With_Lock) is 87 pragma Warnings (Off); 88 pragma Assert (T_Check); -- not called if check suppressed 89 pragma Warnings (On); 90 begin 91 Unlock (Lock.T_Counts.all); 92 end Finalize; 93 94 ---------------- 95 -- Initialize -- 96 ---------------- 97 98 procedure Initialize (Busy : in out With_Busy) is 99 pragma Warnings (Off); 100 pragma Assert (T_Check); -- not called if check suppressed 101 pragma Warnings (On); 102 begin 103 Generic_Implementation.Busy (Busy.T_Counts.all); 104 end Initialize; 105 106 procedure Initialize (Lock : in out With_Lock) is 107 pragma Warnings (Off); 108 pragma Assert (T_Check); -- not called if check suppressed 109 pragma Warnings (On); 110 begin 111 Generic_Implementation.Lock (Lock.T_Counts.all); 112 end Initialize; 113 114 ---------- 115 -- Lock -- 116 ---------- 117 118 procedure Lock (T_Counts : in out Tamper_Counts) is 119 begin 120 if T_Check then 121 SAC.Increment (T_Counts.Lock); 122 SAC.Increment (T_Counts.Busy); 123 end if; 124 end Lock; 125 126 -------------- 127 -- TC_Check -- 128 -------------- 129 130 procedure TC_Check (T_Counts : Tamper_Counts) is 131 begin 132 if T_Check and then T_Counts.Busy > 0 then 133 raise Program_Error with 134 "attempt to tamper with cursors"; 135 end if; 136 137 -- The lock status (which monitors "element tampering") always 138 -- implies that the busy status (which monitors "cursor tampering") 139 -- is set too; this is a representation invariant. Thus if the busy 140 -- bit is not set, then the lock bit must not be set either. 141 142 pragma Assert (T_Counts.Lock = 0); 143 end TC_Check; 144 145 -------------- 146 -- TE_Check -- 147 -------------- 148 149 procedure TE_Check (T_Counts : Tamper_Counts) is 150 begin 151 if T_Check and then T_Counts.Lock > 0 then 152 raise Program_Error with 153 "attempt to tamper with elements"; 154 end if; 155 end TE_Check; 156 157 ------------ 158 -- Unbusy -- 159 ------------ 160 161 procedure Unbusy (T_Counts : in out Tamper_Counts) is 162 begin 163 if T_Check then 164 SAC.Decrement (T_Counts.Busy); 165 end if; 166 end Unbusy; 167 168 ------------ 169 -- Unlock -- 170 ------------ 171 172 procedure Unlock (T_Counts : in out Tamper_Counts) is 173 begin 174 if T_Check then 175 SAC.Decrement (T_Counts.Lock); 176 SAC.Decrement (T_Counts.Busy); 177 end if; 178 end Unlock; 179 180 ----------------- 181 -- Zero_Counts -- 182 ----------------- 183 184 procedure Zero_Counts (T_Counts : out Tamper_Counts) is 185 begin 186 if T_Check then 187 T_Counts := (others => <>); 188 end if; 189 end Zero_Counts; 190 191 end Generic_Implementation; 192 193end Ada.Containers.Helpers; 194