File: dbf\array_handler.adb

    1 --::::::::::
    2 --arrahand.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 choice, program_log;
   12 package body array_handler is
   13 
   14    function min is new choice (integer, "<=");
   15    function max is new choice (integer, ">=");
   16 
   17    package log is new program_log ("array_handler", toolname);
   18    use log;
   19 
   20    assfals: constant string := ": false assertion";
   21    adachks: constant string := ": system checking";
   22    on_elem: constant string := " on elem";
   23    on_arry: constant string := " on array";
   24    on_fild: constant string := " on field";
   25 
   26    procedure info (vol: string; first, last: integer) is
   27    begin
   28         log.message (vol & " (" & integer'image(first) & ", " &
   29                                   integer'image(last ) & ")");
   30    end;
   31 
   32    -----------------------------------------------------------------------
   33 
   34    function length (item: object) return natural is
   35    begin
   36       return item.len;
   37    end;
   38 
   39    -----------------------------------------------------------------------
   40 
   41    function value  (item: object; position: positive) return elem_type is
   42    begin
   43       if extra_check then
   44           assert (position in 1..item.len, "value" & on_elem & assfals);
   45       end if;
   46       return item.data (position);
   47    end;
   48 
   49    -----------------------------------------------------------------------
   50 
   51    function value (item: object;
   52       first, last: natural) return elem_array is
   53    begin
   54       return item.data(max (first, 1).. min (item.len, last));
   55    end;
   56 
   57    -----------------------------------------------------------------------
   58 
   59    function value  (item: object) return elem_array is
   60    begin
   61       return item.data (1..item.len);
   62    end;
   63 
   64    -----------------------------------------------------------------------
   65 
   66    function empty  (item: object) return boolean is
   67    begin
   68       return item.len = 0;
   69    end;
   70 
   71    -----------------------------------------------------------------------
   72 
   73    function value (item: elem_array) return object is
   74    begin
   75       return (width => item'length,
   76          len   => item'length,
   77          data  => item);
   78    end;
   79 
   80    -----------------------------------------------------------------------
   81 
   82    function value (item: elem_type)  return object is
   83    begin
   84       return (width  =>  1,
   85               len    =>  1,
   86               data   => (1..1 => item));
   87    end;
   88 
   89    -----------------------------------------------------------------------
   90 
   91   function "&"  (left: object; right: object) return object is
   92      tmp: object (left.len + right.len);
   93   begin
   94      set (tmp, left);  append (right, tmp);
   95      return tmp;
   96   end;
   97 
   98    -----------------------------------------------------------------------
   99 
  100    function "&" (left: object; right: elem_array) return object is
  101       tmp: object(left.len + right'length);
  102    begin
  103       set (tmp, left); append (right, tmp);
  104       return tmp;
  105    end;
  106 
  107    -----------------------------------------------------------------------
  108 
  109    function "&" (left: elem_array; right: object) return object is
  110       tmp: object(right.len + left'length);
  111    begin
  112       set (tmp, left); append (right, tmp);
  113       return tmp;
  114    end;
  115 
  116    -----------------------------------------------------------------------
  117 
  118    function "&"  (left: object; right: elem_type ) return object is
  119       tmp: object(left.len + 1);
  120    begin
  121       set (tmp, left); append (right, tmp);
  122       return tmp;
  123    end;
  124 
  125    -----------------------------------------------------------------------
  126 
  127    function "&"  (left: elem_type; right: object) return object is
  128       tmp: object(right.len + 1);
  129    begin
  130       set (tmp, left); append (right, tmp);
  131       return tmp;
  132    end;
  133 
  134    -----------------------------------------------------------------------
  135 
  136    procedure set (item: in out object; value: in object) is
  137    begin
  138       if extra_check then
  139          assert (value.len <= item.width, "set" & on_fild & assfals);
  140       end if;
  141       item.len := min(item.width, value.len);
  142       if item.len > 0
  143       then
  144          item.data(1..item.len) := value.data(1 .. item.len);
  145       end if;
  146    end;
  147 
  148    -----------------------------------------------------------------------
  149 
  150    procedure set (item: in out object; value: in elem_array) is
  151    begin
  152       if extra_check then
  153           assert (value'length <= item.width, "set" & on_arry & assfals);
  154       end if;
  155       item.len := min(item.width, value'length);
  156       if item.len > 0
  157       then
  158            item.data(1..item.len) := value(value'first..item.len + value'first - 1);
  159       end if;
  160    end;
  161 
  162    -----------------------------------------------------------------------
  163 
  164    procedure set (item: in out object; value: in elem_type) is
  165    begin
  166       item.data(1) := value;
  167       item.len     := 1;
  168    end;
  169 
  170    -----------------------------------------------------------------------
  171 
  172    procedure set   (item: in out object;
  173                    value: in elem_type;
  174                    times: in positive) is
  175    begin
  176       set_length (item, times);
  177       for i in 1..length (item)
  178       loop
  179          item.data(i) := value;
  180       end loop;
  181    end;
  182    -----------------------------------------------------------------------
  183 
  184    procedure clear (item: in out object; from: in positive := 1) is
  185    begin
  186       set_length (item, from - 1);
  187    end;
  188 
  189    -----------------------------------------------------------------------
  190 
  191    procedure set_length (item: in out object; len: in natural) is
  192    begin
  193       item.len := min (len, item.width);
  194    end;
  195 
  196    -----------------------------------------------------------------------
  197 
  198    procedure append (tail: in object; to: in out object) is
  199       len: natural;
  200    begin
  201       len := min(tail.len, to.width - to.len);
  202       if extra_check then
  203            assert (tail.len <= len, "append" & on_fild & assfals);
  204       end if;
  205       to.data(to.len + 1 .. to.len + len) := tail.data(1..len);
  206       to.len := to.len + len;
  207    end;
  208 
  209    -----------------------------------------------------------------------
  210 
  211    procedure append (tail: in elem_array; to: in out object) is
  212       len: natural;
  213    begin
  214       len := min(tail'length, to.width - to.len);
  215       if extra_check then
  216             assert (tail'length <= len, "append" & on_arry & assfals);
  217       end if;
  218       to.data(to.len + 1 .. to.len + len) :=
  219       tail(tail'first .. tail'first + len - 1);
  220       to.len := to.len + len;
  221    end;
  222 
  223    -----------------------------------------------------------------------
  224 
  225    procedure append (tail: in elem_type ; to: in out object) is
  226    begin
  227       if extra_check then
  228           assert (to.width > to.len, "append" & on_elem & assfals);
  229       end if;
  230       if  to.width > to.len then
  231           to.len := to.len + 1;
  232           to.data(to.len) := tail;
  233       end if;
  234    end;
  235 
  236    -----------------------------------------------------------------------
  237 
  238    procedure append (tail: in object; to: in out object;
  239                      len:  in natural;
  240                      pos:  in positive := 1) is
  241       m: integer;
  242    begin
  243       m := min (min (tail.len - pos + 1, to.width - to.len), len);
  244       if m > 0 then
  245          to.data(to.len + 1 .. to.len + len) := tail.data(pos..m);
  246          to.len := to.len + m;
  247       end if;
  248    end;
  249 
  250    -----------------------------------------------------------------------
  251 
  252    procedure amend (item: in out object; by: in object; position: in positive) is
  253       len: natural;
  254    begin
  255       len := min(by.len, item.width - position);
  256       if extra_check then
  257            assert (by.len <= len, "amend" & on_fild & assfals);
  258       end if;
  259       item.data(position .. position + len - 1) :=  by.data(1 .. len);
  260       item.len := max (item.len, len + position - 1);
  261    end;
  262 
  263    -----------------------------------------------------------------------
  264 
  265    procedure amend (item: in out object; by: in elem_array; position: in positive) is
  266       len: natural;
  267    begin
  268       len := min(by'length, item.width - position);
  269       if extra_check then
  270             assert (by'length <= len, "amend" & on_arry & assfals);
  271       end if;
  272       item.data(position .. position + len - 1) :=
  273       by(by'first .. by'first + len - 1);
  274       item.len := max (item.len, len + position - 1);
  275    end;
  276 
  277    -----------------------------------------------------------------------
  278 
  279    procedure amend (item: in out object; by: in elem_type ; position: in positive) is
  280    begin
  281       if extra_check then
  282             assert (1 <= item.len, "amend" & on_arry & assfals);
  283       end if;
  284       item.data(position) := by;
  285    end;
  286 
  287    -----------------------------------------------------------------------
  288 
  289    function locate (frag: elem_array;
  290                   within: object;
  291                     from: positive := 1;
  292                       to: positive := positive'last) return natural is
  293       last_try: constant integer := (min (within.len, to) - frag'length + 1);
  294    begin
  295 
  296       if frag'length = 0 or else from > last_try
  297       then
  298          return 0;
  299       end if;
  300 
  301       if frag'length = 1 then
  302          return locate (frag(frag'first), within, from, to);
  303       end if;
  304 
  305       declare
  306          pos: natural := from;
  307          equ: natural := 0;
  308          sub: array (frag'range) of positive;
  309 
  310          procedure subseq_check is
  311             o: integer;
  312          begin
  313 
  314             for i in sub'range
  315             loop
  316                 sub (i) := i;
  317             end loop;
  318 
  319             for n in frag'first..(frag'last / 2)
  320             loop
  321                for m in n..(frag'last - n)
  322                loop
  323                   o := m + n;
  324                   if frag(frag'first..n) = frag(m + 1..o) and then
  325                      sub (o) > m
  326                   then
  327                      sub (o) := m;
  328                   end if;
  329                end loop;
  330             end loop;
  331          end subseq_check;
  332 
  333       begin
  334 
  335          pos := locate (frag(frag'first), within, from, last_try);
  336          if pos < 1 -- not in from..last_try
  337          then
  338              return 0;
  339          end if;
  340 
  341          subseq_check;
  342 
  343          loop
  344 
  345             exit when pos > last_try;
  346 
  347             for f in frag'range -- frag'first..frag'last
  348             loop
  349                exit when within.data (pos + equ) /= frag (f);
  350                equ := equ + 1;
  351             end loop;
  352 
  353             if equ > 0 then
  354                if equ = frag'length then
  355                   return pos;
  356                end if;
  357 
  358                pos := pos + sub (sub'first + equ - 1);
  359                equ := 0;
  360             else
  361                pos := pos + 1;
  362                pos := locate (frag(frag'first), within, pos, to);
  363                exit when pos = 0;
  364             end if;
  365 
  366          end loop;
  367       end;
  368       return 0;
  369    end locate;
  370 
  371    -----------------------------------------------------------------------
  372 
  373    function locate (frag: object;
  374                   within: object;
  375                     from: positive := 1;
  376                       to: positive := positive'last) return natural is
  377    begin
  378       return locate (frag.data (1 .. frag.len), within, from, to);
  379    end;
  380 
  381    -----------------------------------------------------------------------
  382 
  383    function locate (frag: elem_type;
  384                   within: object;
  385                     from: positive := 1;
  386                     to:   positive := positive'last) return natural is
  387    begin
  388       for n in from..min (within.len, to)
  389       loop
  390          if within.data(n) = frag
  391          then
  392             return natural(n);
  393          end if;
  394       end loop;
  395       return 0;
  396    end;
  397 
  398    -----------------------------------------------------------------------
  399 
  400    procedure delete (item: in out object; from, to: positive) is
  401    begin
  402        if item.len > 0 and then
  403           from <= to
  404        then
  405           if to > item.len then
  406                clear (item, from);
  407           else
  408                set (item, item.data (1     ..from - 1) &
  409                           item.data (to + 1..item.len));
  410           end if;
  411        end if;
  412    exception
  413        when others => error ("delete" & adachks); raise;
  414    end;
  415 
  416    -----------------------------------------------------------------------
  417 
  418    procedure expand (item: in out object; from, to: positive) is
  419    begin
  420         set (item, item.data (1     ..to      )  &
  421                    item.data (from  ..item.len));
  422    exception
  423        when others => error ("expand" & adachks); raise;
  424    end;
  425 
  426    -----------------------------------------------------------------------
  427 
  428    procedure exchange (item_a, item_b: in out object) is
  429    begin
  430       if extra_check then
  431           assert (item_a.len <= item_b.width and
  432                   item_b.len <= item_a.width,
  433                   "exchange" & on_fild & assfals);
  434       end if;
  435       if item_a.len = 0
  436       then
  437           if item_b.len = 0
  438           then
  439               return;
  440           end if;
  441           set (item_a, item_b); item_b.len := 0; return;
  442       end  if;
  443 
  444       if  item_b.len = 0
  445       then
  446           set (item_b, item_a); item_a.len := 0; return;
  447       end if;
  448 
  449       if  item_a.len > item_b.len
  450       then
  451           declare
  452              elm: elem_type;
  453           begin
  454              for n in 1..item_b.len
  455              loop
  456                 elm := item_a.data(n);
  457                 item_a.data(n) := item_b.data(n);
  458                 item_b.data(n) := elm;
  459              end loop;
  460              append (item_a.data(item_b.len + 1..item_a.len), item_b);
  461              clear (item_a, item_b.len + 1);
  462           end;
  463           return;
  464       elsif item_b.len > item_a.len
  465       then
  466           declare
  467              elm: elem_type;
  468           begin
  469              for n in 1..item_a.len
  470              loop
  471                 elm := item_b.data(n);
  472                 item_b.data(n) := item_a.data(n);
  473                 item_a.data(n) := elm;
  474              end loop;
  475              append (item_b.data(item_a.len + 1..item_b.len), item_b);
  476              clear (item_b, item_a.len + 1);
  477           end;
  478           return;
  479       else -- if  item_a.len = item_b.len then
  480           declare
  481              elm: elem_type;
  482           begin
  483              for n in 1..item_a.len
  484              loop
  485                 elm := item_a.data(n);
  486                 item_a.data(n) := item_b.data(n);
  487                 item_b.data(n) := elm;
  488              end loop;
  489           end;
  490           return;
  491       end if;
  492 
  493       raise program_error;
  494 
  495    end;
  496 
  497    -----------------------------------------------------------------------
  498 
  499    procedure insert (item:    in out object;
  500                      frag:    in     object;
  501                      from:    in     positive;
  502                      replace: in     natural := 0) is
  503    begin
  504              insert (item     => item,
  505                      frag     => value(frag),
  506                      from     => from,
  507                      replace  => replace);
  508    end;
  509 
  510    -----------------------------------------------------------------------
  511 
  512    procedure insert (item:    in out object;
  513                      frag:    in     elem_array;
  514                      from:    in     positive;
  515                      replace: in     natural := 0) is
  516 
  517    begin
  518        if replace < frag'length then
  519              expand (item, from + replace, from + frag'length - 1);
  520        elsif replace > frag'length then
  521              delete (item, from + frag'length, from + replace - 1);
  522        end if;
  523        amend  (item, frag, from);
  524    exception
  525        when others => error ("insert" & on_arry & assfals); raise;
  526    end;
  527 
  528    -----------------------------------------------------------------------
  529 
  530    procedure insert (item:    in out object;
  531                      frag:    in     elem_type;
  532                      from:    in     positive;
  533                      replace: in     natural := 0) is
  534    begin
  535        if replace < 1 then
  536              expand (item, from, from);
  537        elsif replace > 1 then
  538              delete (item, from + 1, from + replace - 1);
  539        end if;
  540 
  541        amend  (item, frag, from);
  542    exception
  543        when others => error ("insert" & on_elem & assfals); raise;
  544    end;
  545 
  546    -----------------------------------------------------------------------
  547 
  548    function suffix (a, b: object) return natural is
  549         m:  natural := min(a.len, b.len);
  550    begin
  551         for i in 0..m - 1
  552         loop
  553              if a.data(a.len - i) /= b.data(b.len - i) then
  554                 return i;
  555              end if;
  556         end loop;
  557         return m;
  558    end;
  559 
  560    -----------------------------------------------------------------------
  561 
  562    function prefix (a, b: object) return natural is
  563         m:  natural := min(a.len, b.len);
  564    begin
  565         for i in 1..m
  566         loop
  567              if a.data(i) /= b.data(i) then
  568                 return i - 1;
  569              end if;
  570         end loop;
  571         return m;
  572    end;
  573 
  574    -----------------------------------------------------------------------
  575 
  576    function translating_poly_in  (left:  in object;
  577                       right: in operand;
  578                       from:  in positive := 1;
  579                       to:    in positive := positive'last) return result is
  580    begin
  581       return op (value (left, from, to), right);
  582    end;
  583 
  584    -----------------------------------------------------------------------
  585 
  586    function translating_mono_in   (right: in object;
  587                        from: in positive := 1;
  588                        to:   in positive := positive'last) return result is
  589    begin
  590       return value (value (right, from, to));
  591    end;
  592 
  593    -----------------------------------------------------------------------
  594 
  595    procedure transforming_poly_in_out (left:  in out object;
  596                           right: in operand;
  597                           from:  in positive := 1;
  598                           to:    in positive := positive'last) is
  599       tmp: elem_array (max (from, 1).. min (length(left), to));
  600    begin
  601       op (tmp, right);
  602       set (left, tmp);
  603    end;
  604 
  605    -----------------------------------------------------------------------
  606 
  607    procedure transforming_mono_in_out (right: in out object;
  608                           from:  in positive := 1;
  609                           to:    in positive := positive'last) is
  610       tmp: elem_array (max (from, 1).. min (right.len, to));
  611    begin
  612       op (tmp);
  613       set (right, tmp);
  614    end;
  615 
  616    -----------------------------------------------------------------------
  617 
  618    procedure transfering_mono_in (item:   in object;
  619                         from: in positive := 1;
  620                         to:   in positive := positive'last) is
  621    begin
  622       op (value (item, from, to));
  623    end;
  624 
  625    -----------------------------------------------------------------------
  626 
  627    procedure transfering_mono_out (item:  in out object;
  628                         from: in positive := 1;
  629                         to:   in positive := positive'last) is
  630       tmp: elem_array (max (from, 1).. min (length(item), to));
  631    begin
  632       op (tmp);
  633       amend (item, tmp, from);
  634    end;
  635 
  636    -----------------------------------------------------------------------
  637 
  638    procedure transfering_mono_out_changes (item: in out object) is
  639       tmp: elem_array (1..item.width);
  640       len: natural := 0;
  641    begin
  642       op (tmp, len);
  643       set (item, tmp (1..len));
  644    end;
  645 
  646    -----------------------------------------------------------------------
  647 
  648    procedure transfering_poly_in (file:   in control;
  649                       item:   in object;
  650                         from: in positive := 1;
  651                         to:   in positive := positive'last) is
  652    begin
  653       op (file, item.data(max (from, 1)..min (item.len, to)));
  654    end;
  655 
  656    -----------------------------------------------------------------------
  657 
  658    procedure transfering_poly_in_out (file: in control;
  659                           item: in out object;
  660                           from: in positive := 1;
  661                             to: in positive := positive'last) is
  662    begin
  663       op (file, item.data(max (from, 1)..min (item.len, to)));
  664    end;
  665 
  666    -----------------------------------------------------------------------
  667 
  668    procedure transfering_poly_out ( file: in control;
  669                         item: in out object;
  670                         from: in positive := 1;
  671                         to:   in positive := positive'last) is
  672    begin
  673       op (file, item.data(max (from, 1)..min (item.len, to)));
  674    end;
  675 
  676    -----------------------------------------------------------------------
  677 
  678    procedure transfering_poly_out_changes (file: in control;
  679                                item: in out object) is
  680    begin
  681       op (file, item.data, item.len);
  682       item.len := min(item.len, item.width);
  683    end;
  684 
  685 end array_handler;
  686