File: dbf\unsigned_io.adb

    1 --::::::::::
    2 --unsignio.adb
    3 --::::::::::
    4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
    5 --                  Moscow, Russia,
    6 --                  Voice:   7 (095) 398-23-38
    7 --                  e-mail:  edv@edv.msk.ru
    8 -- This is free software; you can  freely  redistribute  it  and/or
    9 -- modify  it  without any restrictions.  Please report any errors.
   10 -- All corrections will be made as soon as possible.
   11 with direct_io;
   12 with unchecked_deallocation, unchecked_conversion;
   13 package body unsigned_io is
   14 
   15   package bio is new direct_io(byte);
   16 
   17   type file_object is 
   18     record
   19       f : bio.file_type; 
   20     end record; 
   21 
   22   bio_mode : constant array(file_mode) of bio.file_mode := 
   23    (in_file => bio.in_file, 
   24     inout_file => bio.inout_file, 
   25     out_file => bio.out_file); 
   26 
   27   bin_mode : constant array(bio.file_mode) of file_mode := 
   28    (bio.in_file => in_file, 
   29     bio.inout_file => inout_file, 
   30     bio.out_file => out_file); 
   31 
   32   procedure destroy (file : in out file_type) is
   33      procedure free is new unchecked_deallocation(file_object, file_type);
   34   begin
   35       free (file);
   36       file := null;
   37   end;
   38 
   39   procedure create(file : in out file_type;
   40                    mode : in file_mode := inout_file; 
   41                    name : in string := ""; 
   42                    form : in string := "") is 
   43   begin
   44     file := new file_object; 
   45     bio.create(file.f, bio_mode(mode), name, form); 
   46   exception
   47     when constraint_error =>  destroy (file);
   48                               raise status_error;
   49     when others =>            destroy (file);
   50                               raise;
   51   end create; 
   52 
   53   procedure open(file : in out file_type; 
   54                  mode : in file_mode; 
   55                  name : in string; 
   56                  form : in string := "") is 
   57   begin
   58     file := new file_object; 
   59     bio.open(file.f, bio_mode(mode), name, form); 
   60   exception
   61     when constraint_error => destroy (file);
   62                              raise status_error;
   63     when others =>           destroy (file);
   64                              raise;
   65   end open; 
   66 
   67   procedure close(file : in out file_type) is 
   68   begin
   69     bio.close(file.f); 
   70     destroy (file);
   71   exception
   72     when constraint_error => 
   73       raise status_error; 
   74     when others => 
   75       raise; 
   76   end close; 
   77 
   78   procedure delete(file : in out file_type) is 
   79   begin
   80     bio.delete(file.f); 
   81     destroy (file);
   82   exception
   83     when constraint_error => 
   84       raise status_error; 
   85     when others => 
   86       raise; 
   87   end delete; 
   88 
   89   procedure reset(file : in out file_type; 
   90                   mode : in file_mode) is 
   91   begin
   92     bio.reset(file.f, bio_mode(mode)); 
   93   exception
   94     when constraint_error => 
   95       raise status_error; 
   96     when others => 
   97       raise; 
   98   end reset; 
   99 
  100   procedure reset(file : in out file_type) is 
  101   begin
  102     bio.reset(file.f); 
  103   exception
  104     when constraint_error => 
  105       raise status_error; 
  106     when others => 
  107       raise; 
  108   end reset; 
  109 
  110   function mode(file : in file_type) return file_mode is 
  111   begin
  112     return bin_mode(bio.mode(file.f)); 
  113   exception
  114     when constraint_error => 
  115       raise status_error; 
  116     when others => 
  117       raise; 
  118   end mode; 
  119 
  120   function name(file : in file_type) return string is 
  121   begin
  122     return bio.name(file.f); 
  123   exception
  124     when constraint_error => 
  125       raise status_error; 
  126     when others => 
  127       raise; 
  128   end name; 
  129 
  130   function form(file : in file_type) return string is 
  131   begin
  132     return bio.form(file.f); 
  133   exception
  134     when constraint_error => 
  135       raise status_error; 
  136     when others => 
  137       raise; 
  138   end form; 
  139 
  140   function is_open(file : in file_type) return boolean is 
  141   begin
  142     if file = null then 
  143       return false; 
  144     end if; 
  145     return bio.is_open(file.f); 
  146   exception
  147     when others => 
  148       raise; 
  149   end is_open; 
  150 
  151   procedure read(file : in file_type; 
  152                  item : out byte) is 
  153   begin
  154     bio.read(file.f, item); 
  155   exception
  156     when constraint_error => 
  157       raise status_error; 
  158     when others => 
  159       raise; 
  160   end read; 
  161 
  162   procedure read(file : in file_type; 
  163                  item : out byte; 
  164                  from : in positive_count) is 
  165   begin
  166     bio.read(file.f, item, bio.count(from)); 
  167   exception
  168     when constraint_error => 
  169       raise status_error; 
  170     when others => 
  171       raise; 
  172   end read; 
  173 
  174   procedure read(file : in file_type; 
  175                  item : out byte_string) is
  176   begin
  177     for n in item'range loop
  178       bio.read(file.f, item(n)); 
  179     end loop; 
  180   exception
  181     when constraint_error => 
  182       raise status_error; 
  183     when others => 
  184       raise; 
  185   end read; 
  186 
  187   procedure read(file : in file_type; 
  188                  item : out byte_string;
  189                  from : in positive_count) is 
  190   begin
  191     set_index(file, from); 
  192     read(file, item); 
  193   exception
  194     when constraint_error => 
  195       raise status_error; 
  196     when others => 
  197       raise; 
  198   end read; 
  199 
  200   procedure write(file : in file_type; 
  201                   item : in byte) is 
  202   begin
  203     bio.write(file.f, item); 
  204   exception
  205     when constraint_error => 
  206       raise status_error; 
  207     when others => 
  208       raise; 
  209   end write; 
  210 
  211   procedure write(file : in file_type; 
  212                   item : in byte; 
  213                   to   : in positive_count) is 
  214   begin
  215     bio.write(file.f, item, bio.count(to)); 
  216   exception
  217     when constraint_error => 
  218       raise status_error; 
  219     when others => 
  220       raise; 
  221   end write; 
  222 
  223   procedure write(file : in file_type; 
  224                   item : in byte_string) is
  225   begin
  226     for n in item'range loop
  227       bio.write(file.f, item(n)); 
  228     end loop; 
  229   exception
  230     when constraint_error => 
  231       raise status_error; 
  232     when others => 
  233       raise; 
  234   end write; 
  235 
  236   procedure write(file : in file_type; 
  237                   item : in byte_string;
  238                   to   : in positive_count) is 
  239   begin
  240     set_index(file, to); 
  241     write(file, item); 
  242   exception
  243     when constraint_error => 
  244       raise status_error; 
  245     when others => 
  246       raise; 
  247   end write; 
  248 
  249   procedure set_index(file : in file_type; 
  250                       to   : in positive_count) is 
  251   begin
  252     bio.set_index(file.f, bio.count(to)); 
  253   exception
  254     when constraint_error => 
  255       raise status_error; 
  256     when others => 
  257       raise; 
  258   end set_index; 
  259 
  260   function index(file : in file_type) return positive_count is 
  261   begin
  262     return count(bio.index(file.f)); 
  263   exception
  264     when constraint_error => 
  265       raise status_error; 
  266     when others => 
  267       raise; 
  268   end index; 
  269 
  270   function size(file : in file_type) return count is 
  271   begin
  272     return count(bio.size(file.f)); 
  273   exception
  274     when constraint_error => 
  275       raise status_error; 
  276     when others => 
  277       raise; 
  278   end size; 
  279 
  280   function end_of_file(file : in file_type) return boolean is 
  281   begin
  282     return bio.end_of_file(file.f); 
  283   exception
  284     when constraint_error => 
  285       raise status_error; 
  286     when others => 
  287       raise; 
  288   end end_of_file; 
  289 
  290   procedure write_bytes (file:   in out file_type;
  291                         data:   in     data_type) is
  292 
  293       subtype byte_array is byte_string (1..data_type'size/byte'size);
  294       function convert is new unchecked_conversion (data_type, byte_array);
  295       buf: byte_array := convert (data);
  296   begin
  297       write (file, buf);
  298   end;
  299 
  300   procedure read_bytes (file:   in out file_type;
  301                        data:      out data_type) is
  302 
  303       subtype byte_array is byte_string (1..data_type'size/byte'size);
  304       function convert is new unchecked_conversion (byte_array, data_type);
  305       buf: byte_array;
  306   begin
  307       read (file, buf);
  308       data := convert (buf);
  309   end;
  310 
  311 end unsigned_io;
  312