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-2018, 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 begin 40 if Control.T_Counts /= null then 41 Lock (Control.T_Counts.all); 42 end if; 43 end Adjust; 44 45 ---------- 46 -- Busy -- 47 ---------- 48 49 procedure Busy (T_Counts : in out Tamper_Counts) is 50 begin 51 if T_Check then 52 SAC.Increment (T_Counts.Busy); 53 end if; 54 end Busy; 55 56 -------------- 57 -- Finalize -- 58 -------------- 59 60 procedure Finalize (Control : in out Reference_Control_Type) is 61 begin 62 if Control.T_Counts /= null then 63 Unlock (Control.T_Counts.all); 64 Control.T_Counts := null; 65 end if; 66 end Finalize; 67 68 -- No need to protect against double Finalize here, because these types 69 -- are limited. 70 71 procedure Finalize (Busy : in out With_Busy) is 72 pragma Warnings (Off); 73 pragma Assert (T_Check); -- not called if check suppressed 74 pragma Warnings (On); 75 begin 76 Unbusy (Busy.T_Counts.all); 77 end Finalize; 78 79 procedure Finalize (Lock : in out With_Lock) is 80 pragma Warnings (Off); 81 pragma Assert (T_Check); -- not called if check suppressed 82 pragma Warnings (On); 83 begin 84 Unlock (Lock.T_Counts.all); 85 end Finalize; 86 87 ---------------- 88 -- Initialize -- 89 ---------------- 90 91 procedure Initialize (Busy : in out With_Busy) is 92 pragma Warnings (Off); 93 pragma Assert (T_Check); -- not called if check suppressed 94 pragma Warnings (On); 95 begin 96 Generic_Implementation.Busy (Busy.T_Counts.all); 97 end Initialize; 98 99 procedure Initialize (Lock : in out With_Lock) is 100 pragma Warnings (Off); 101 pragma Assert (T_Check); -- not called if check suppressed 102 pragma Warnings (On); 103 begin 104 Generic_Implementation.Lock (Lock.T_Counts.all); 105 end Initialize; 106 107 ---------- 108 -- Lock -- 109 ---------- 110 111 procedure Lock (T_Counts : in out Tamper_Counts) is 112 begin 113 if T_Check then 114 SAC.Increment (T_Counts.Lock); 115 SAC.Increment (T_Counts.Busy); 116 end if; 117 end Lock; 118 119 -------------- 120 -- TC_Check -- 121 -------------- 122 123 procedure TC_Check (T_Counts : Tamper_Counts) is 124 begin 125 if T_Check and then T_Counts.Busy > 0 then 126 raise Program_Error with 127 "attempt to tamper with cursors"; 128 end if; 129 130 -- The lock status (which monitors "element tampering") always 131 -- implies that the busy status (which monitors "cursor tampering") 132 -- is set too; this is a representation invariant. Thus if the busy 133 -- bit is not set, then the lock bit must not be set either. 134 135 pragma Assert (T_Counts.Lock = 0); 136 end TC_Check; 137 138 -------------- 139 -- TE_Check -- 140 -------------- 141 142 procedure TE_Check (T_Counts : Tamper_Counts) is 143 begin 144 if T_Check and then T_Counts.Lock > 0 then 145 raise Program_Error with 146 "attempt to tamper with elements"; 147 end if; 148 end TE_Check; 149 150 ------------ 151 -- Unbusy -- 152 ------------ 153 154 procedure Unbusy (T_Counts : in out Tamper_Counts) is 155 begin 156 if T_Check then 157 SAC.Decrement (T_Counts.Busy); 158 end if; 159 end Unbusy; 160 161 ------------ 162 -- Unlock -- 163 ------------ 164 165 procedure Unlock (T_Counts : in out Tamper_Counts) is 166 begin 167 if T_Check then 168 SAC.Decrement (T_Counts.Lock); 169 SAC.Decrement (T_Counts.Busy); 170 end if; 171 end Unlock; 172 173 ----------------- 174 -- Zero_Counts -- 175 ----------------- 176 177 procedure Zero_Counts (T_Counts : out Tamper_Counts) is 178 begin 179 if T_Check then 180 T_Counts := (others => <>); 181 end if; 182 end Zero_Counts; 183 184 end Generic_Implementation; 185 186end Ada.Containers.Helpers; 187