1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . S E Q U E N T I A L _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, 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-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the generic template for Sequential_IO, i.e. the code that gets 33-- duplicated. We absolutely minimize this code by either calling routines 34-- in System.File_IO (for common file functions), or in System.Sequential_IO 35-- (for specialized Sequential_IO functions) 36 37with Interfaces.C_Streams; use Interfaces.C_Streams; 38with System; 39with System.CRTL; 40with System.File_Control_Block; 41with System.File_IO; 42with System.Storage_Elements; 43with Ada.Unchecked_Conversion; 44 45package body Ada.Sequential_IO is 46 47 package FIO renames System.File_IO; 48 package FCB renames System.File_Control_Block; 49 package SIO renames System.Sequential_IO; 50 package SSE renames System.Storage_Elements; 51 52 SU : constant := System.Storage_Unit; 53 54 subtype AP is FCB.AFCB_Ptr; 55 subtype FP is SIO.File_Type; 56 57 function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); 58 function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); 59 60 use type System.CRTL.size_t; 61 62 ----------- 63 -- Close -- 64 ----------- 65 66 procedure Close (File : in out File_Type) is 67 begin 68 FIO.Close (AP (File)'Unrestricted_Access); 69 end Close; 70 71 ------------ 72 -- Create -- 73 ------------ 74 75 procedure Create 76 (File : in out File_Type; 77 Mode : File_Mode := Out_File; 78 Name : String := ""; 79 Form : String := "") 80 is 81 begin 82 SIO.Create (FP (File), To_FCB (Mode), Name, Form); 83 end Create; 84 85 ------------ 86 -- Delete -- 87 ------------ 88 89 procedure Delete (File : in out File_Type) is 90 begin 91 FIO.Delete (AP (File)'Unrestricted_Access); 92 end Delete; 93 94 ----------------- 95 -- End_Of_File -- 96 ----------------- 97 98 function End_Of_File (File : File_Type) return Boolean is 99 begin 100 return FIO.End_Of_File (AP (File)); 101 end End_Of_File; 102 103 ---------- 104 -- Form -- 105 ---------- 106 107 function Form (File : File_Type) return String is 108 begin 109 return FIO.Form (AP (File)); 110 end Form; 111 112 ------------- 113 -- Is_Open -- 114 ------------- 115 116 function Is_Open (File : File_Type) return Boolean is 117 begin 118 return FIO.Is_Open (AP (File)); 119 end Is_Open; 120 121 ---------- 122 -- Mode -- 123 ---------- 124 125 function Mode (File : File_Type) return File_Mode is 126 begin 127 return To_SIO (FIO.Mode (AP (File))); 128 end Mode; 129 130 ---------- 131 -- Name -- 132 ---------- 133 134 function Name (File : File_Type) return String is 135 begin 136 return FIO.Name (AP (File)); 137 end Name; 138 139 ---------- 140 -- Open -- 141 ---------- 142 143 procedure Open 144 (File : in out File_Type; 145 Mode : File_Mode; 146 Name : String; 147 Form : String := "") 148 is 149 begin 150 SIO.Open (FP (File), To_FCB (Mode), Name, Form); 151 end Open; 152 153 ---------- 154 -- Read -- 155 ---------- 156 157 procedure Read (File : File_Type; Item : out Element_Type) is 158 Siz : constant size_t := (Item'Size + SU - 1) / SU; 159 Rsiz : size_t; 160 161 begin 162 FIO.Check_Read_Status (AP (File)); 163 164 -- For non-definite type or type with discriminants, read size and 165 -- raise Program_Error if it is larger than the size of the item. 166 167 if not Element_Type'Definite 168 or else Element_Type'Has_Discriminants 169 then 170 FIO.Read_Buf 171 (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); 172 173 -- For a type with discriminants, we have to read into a temporary 174 -- buffer if Item is constrained, to check that the discriminants 175 -- are correct. 176 177 pragma Extensions_Allowed (On); 178 -- Needed to allow Constrained reference here 179 180 if Element_Type'Has_Discriminants 181 and then Item'Constrained 182 then 183 declare 184 RsizS : constant SSE.Storage_Offset := 185 SSE.Storage_Offset (Rsiz - 1); 186 187 type SA is new SSE.Storage_Array (0 .. RsizS); 188 189 for SA'Alignment use Standard'Maximum_Alignment; 190 -- We will perform an unchecked conversion of a pointer-to-SA 191 -- into pointer-to-Element_Type. We need to ensure that the 192 -- source is always at least as strictly aligned as the target. 193 194 type SAP is access all SA; 195 type ItemP is access all Element_Type; 196 197 pragma Warnings (Off); 198 -- We have to turn warnings off for function To_ItemP, 199 -- because it gets analyzed for all types, including ones 200 -- which can't possibly come this way, and for which the 201 -- size of the access types differs. 202 203 function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP); 204 205 pragma Warnings (On); 206 207 Buffer : aliased SA; 208 209 pragma Unsuppress (Discriminant_Check); 210 211 begin 212 FIO.Read_Buf (AP (File), Buffer'Address, Rsiz); 213 Item := To_ItemP (Buffer'Access).all; 214 return; 215 end; 216 end if; 217 218 -- In the case of a non-definite type, make sure the length is OK. 219 -- We can't do this in the variant record case, because the size is 220 -- based on the current discriminant, so may be apparently wrong. 221 222 if not Element_Type'Has_Discriminants and then Rsiz > Siz then 223 raise Program_Error; 224 end if; 225 226 FIO.Read_Buf (AP (File), Item'Address, Rsiz); 227 228 -- For definite type without discriminants, use actual size of item 229 230 else 231 FIO.Read_Buf (AP (File), Item'Address, Siz); 232 end if; 233 end Read; 234 235 ----------- 236 -- Reset -- 237 ----------- 238 239 procedure Reset (File : in out File_Type; Mode : File_Mode) is 240 begin 241 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); 242 end Reset; 243 244 procedure Reset (File : in out File_Type) is 245 begin 246 FIO.Reset (AP (File)'Unrestricted_Access); 247 end Reset; 248 249 ----------- 250 -- Write -- 251 ----------- 252 253 procedure Write (File : File_Type; Item : Element_Type) is 254 Siz : constant size_t := (Item'Size + SU - 1) / SU; 255 256 begin 257 FIO.Check_Write_Status (AP (File)); 258 259 -- For non-definite types or types with discriminants, write the size 260 261 if not Element_Type'Definite 262 or else Element_Type'Has_Discriminants 263 then 264 FIO.Write_Buf 265 (AP (File), Siz'Address, size_t'Size / System.Storage_Unit); 266 end if; 267 268 FIO.Write_Buf (AP (File), Item'Address, Siz); 269 end Write; 270 271end Ada.Sequential_IO; 272