File: dbf\unsigned.adb

    1 --::::::::::
    2 --unsigned.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 unchecked_conversion;
   12 
   13 package body unsigned is
   14 
   15     use_dir_cvt: constant boolean := TRUE;
   16 
   17     function to_long_word (buf: byte_string) return long_word is
   18        item: long_word := 0;
   19     begin
   20        for b in reverse buf'range
   21        loop
   22          item := item * 2 ** byte'size + long_word (buf(b));
   23        end loop;
   24        return item;
   25     end;
   26 
   27     function to_byte_string (item: long_word) return long_word_bytes is
   28        buf: long_word_bytes := (others => 0);
   29        tmp: long_word := item;
   30     begin
   31        for b in buf'range
   32        loop
   33          buf (b) := byte (tmp mod 2 ** byte'size);
   34          tmp     := tmp  /  2 ** byte'size;
   35          exit when tmp = 0;
   36        end loop;
   37        return buf;
   38     end;
   39 
   40     function value (item: long_word_bytes) return long_word is
   41     begin
   42       return to_long_word (item);
   43     end;
   44 
   45     function value (item: word_bytes) return word is
   46     begin
   47       return word (to_long_word (item));
   48     end;
   49 
   50     function value (item: word) return word_bytes is
   51     begin
   52        return to_byte_string (long_word (item)) (word_bytes'range);
   53     end;
   54 
   55     function value (item: long_word) return long_word_bytes is
   56     begin
   57        return to_byte_string (item);
   58     end;
   59 
   60     function value (item:  byte_string) return standard.string is
   61 
   62 --    subtype bs_type is byte_string (item'range);
   63 --    subtype ss_type is      string (item'range);
   64 
   65 --    function to_ss is new unchecked_conversion (bs_type, ss_type);
   66     begin
   67 --    if use_dir_cvt
   68 --    then
   69 --       return to_ss (item);
   70 --    else
   71          declare
   72             x: standard.string (item'range);
   73             b: constant := character'pos (character'last) + 1;
   74          begin
   75             if character'pos(character'last) = byte'pos(byte'last)
   76             then
   77                for i in x'range
   78                loop
   79                     x(i) := standard.character'val (item (i));
   80                end loop;
   81             else
   82                for i in x'range
   83                loop
   84                     x(i) := standard.character'val(item(i) rem b);
   85                end loop;
   86             end if;
   87             return x;
   88          end;
   89 --    end if;
   90     end;
   91 
   92     function  value (item: standard.string) return  byte_string is
   93 
   94 --    subtype bs_type is byte_string (item'range);
   95 --    subtype ss_type is      string (item'range);
   96 
   97 --    function to_bs is new unchecked_conversion (ss_type, bs_type);
   98     begin
   99 --    if use_dir_cvt
  100 --    then
  101 --       return to_bs (item);
  102 --    else
  103          declare
  104             x:  byte_string (item'range);
  105          begin
  106             for i in x'range
  107             loop
  108                  x(i) := standard.character'pos (item (i));
  109             end loop;
  110             return x;
  111          end;
  112 --    end if;
  113     end;
  114 
  115 end unsigned;
  116