File: dbf\b_tree_file.adb

    1 --::::::::::
    2 --btrefile.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 
   12 with unchecked_deallocation,
   13      direct_io;
   14 
   15 package body b_tree_file is
   16 
   17   seek_softly: constant boolean  := true;
   18   comp_softly: constant boolean  := true;
   19 
   20   tree_degree: constant positive := degree;
   21   node_length: constant positive := 2 * tree_degree;
   22 
   23   --------------------------------------------------------------------------
   24 
   25   subtype node_position is long_integer range 0..long_integer'last;
   26 
   27   --------------------------------------------------------------------------
   28 
   29   type element is
   30   record
   31      node : node_position := 0;
   32      item : item_type;
   33      data : data_type;
   34   end record;
   35 
   36   type    elem_count is new integer range  0..node_length;
   37   subtype elem_index is elem_count  range  1..elem_count'last;
   38 
   39   --------------------------------------------------------------------------
   40 
   41   type elements      is array (elem_index range <>) of element;
   42   type elem_sequence is
   43   record
   44     len: elem_count := 0;
   45     seq: elements (1..elem_count'last);
   46   end record;
   47 
   48   --------------------------------------------------------------------------
   49 
   50   type elem_location is
   51   record
   52      node: node_position := 0;
   53      slot: elem_index    := 1;
   54      less: boolean       := false;
   55   end record;
   56 
   57   --------------------------------------------------------------------------
   58 
   59   type step_array    is array (1..node_position'size) of elem_location;
   60   type step_sequence is
   61   record
   62      len: natural     := 0;
   63      seq: step_array;
   64   end record;
   65 
   66   --------------------------------------------------------------------------
   67 
   68   type node_record is
   69   record
   70      left: node_position := 0;
   71      data: elem_sequence;
   72   end record;
   73 
   74   --------------------------------------------------------------------------
   75 
   76   type node_access  is access node_record;
   77   procedure release is new unchecked_deallocation (node_record, node_access);
   78 
   79   --------------------------------------------------------------------------
   80 
   81   package node_io is new direct_io (node_record); use node_io;
   82   subtype io_pos  is node_io.positive_count;
   83 
   84   --------------------------------------------------------------------------
   85 
   86   type tree_object is
   87   record
   88     file: node_io.file_type;
   89     path: step_sequence;
   90     curr: elem_location;
   91     node: node_access := null;
   92     mode: tree_mode;
   93   end record;
   94 
   95   --------------------------------------------------------------------------
   96 
   97   io_mode: constant array (tree_mode) of node_io.file_mode :=
   98                                         (in_tree    => node_io.in_file    ,
   99                                          inout_tree => node_io.inout_file ,
  100                                          out_tree   => node_io.inout_file );
  101 
  102   --------------------------------------------------------------------------
  103 
  104   function length (item: step_sequence) return natural is
  105   begin
  106       return item.len;
  107   end;
  108 
  109   --------------------------------------------------------------------------
  110 
  111   procedure clear  (what: in out step_sequence) is
  112   begin
  113      what.len := 0;
  114   end;
  115 
  116   --------------------------------------------------------------------------
  117 
  118   procedure append (tail: in elem_location; to: in out step_sequence) is
  119   begin
  120      to.len := to.len + 1;
  121      to.seq (to.len) := tail;
  122   end;
  123 
  124   --------------------------------------------------------------------------
  125 
  126   procedure discard (from: in out step_sequence;
  127                      tail:    out elem_location) is
  128   begin
  129      tail     := from.seq (from.len);
  130      from.len := from.len - 1;
  131   end;
  132 
  133   --------------------------------------------------------------------------
  134 
  135   function min (a, b: in elem_count) return elem_count is
  136   begin
  137     if a < b then return a;
  138              else return b;
  139     end if;
  140   end;
  141 
  142   --------------------------------------------------------------------------
  143 
  144   procedure set_length (item: in out elem_sequence; len: in elem_count) is
  145   begin
  146      item.len := min (len, item.seq'last);
  147   end;
  148 
  149   --------------------------------------------------------------------------
  150 
  151   function find_ge (items: in elem_sequence;
  152                      item: in item_type) return elem_index is
  153     left, right, mid: elem_index;
  154   begin
  155     left  := 1;
  156     right := items.len;
  157     loop
  158        exit when left >= right;
  159        mid := elem_index'val((elem_index'pos(left) + elem_index'pos(right)) / 2);
  160        if not (item < items.seq (mid).item)
  161        then
  162           left  := elem_index'succ (mid);
  163        else
  164           right := mid;
  165        end if;
  166     end loop;
  167     return left;
  168   end;
  169 
  170   --------------------------------------------------------------------------
  171 
  172   function find_le (items: in elem_sequence;
  173                     item:  in item_type) return elem_index is
  174      left, right, mid: elem_index;
  175   begin
  176     left  := 1;
  177     right := items.len;
  178     loop
  179        exit when left >= right;
  180        mid := elem_index'val((elem_index'pos(left) + elem_index'pos(right)) / 2);
  181        if items.seq (mid).item < item
  182        then
  183           left  := elem_index'succ(mid);
  184        else
  185           right := mid;
  186        end if;
  187     end loop;
  188     return left;
  189   end;
  190 
  191   --------------------------------------------------------------------------
  192 
  193   function length (item: elem_sequence) return elem_count is
  194   begin
  195       return item.len;
  196   end;
  197 
  198   --------------------------------------------------------------------------
  199 
  200   procedure append (tail: in elements; to: in out elem_sequence) is
  201      len: elem_count;
  202   begin
  203      if tail'length > 0
  204      then
  205         len := min(tail'length, to.seq'last - to.len);
  206         to.seq (to.len + 1 .. to.len + len) :=
  207         tail(tail'first .. tail'first + len - 1);
  208         to.len := to.len + len;
  209      end if;
  210   end;
  211 
  212   --------------------------------------------------------------------------
  213 
  214   procedure append (tail: in element; to: in out elem_sequence) is
  215   begin
  216      if  to.seq'last > to.len then
  217          to.len := to.len + 1;
  218          to.seq(to.len) := tail;
  219      end if;
  220   end;
  221 
  222   --------------------------------------------------------------------------
  223 
  224   procedure extend (item: in out elem_sequence;
  225                     frag: in     elem_count;
  226                     from: in     elem_index) is
  227 
  228   begin
  229      for n in reverse from..item.len
  230      loop
  231          item.seq (n + frag) := item.seq (n);
  232      end loop;
  233      item.len := item.len + frag;
  234   end;
  235 
  236   --------------------------------------------------------------------------
  237 
  238   procedure amend (item: in out elem_sequence;
  239                    frag: in     elements;
  240                    from: in     elem_index) is
  241   begin
  242      item.seq (from..from + frag'length - 1) := frag;
  243   end;
  244 
  245   --------------------------------------------------------------------------
  246 
  247   procedure insert (item: in out elem_sequence;
  248                     frag: in     elements;
  249                     from: in     elem_index) is
  250 
  251   begin
  252       if frag'length > 0
  253       then
  254          extend (item, frag'length, from);
  255          amend  (item, frag,        from);
  256       end if;
  257   end;
  258 
  259   --------------------------------------------------------------------------
  260 
  261   procedure insert (item: in out elem_sequence;
  262                     frag: in     element;
  263                     from: in     elem_index) is
  264 
  265   begin
  266       extend (item, 1, from);
  267       item.seq (from) := frag;
  268   end;
  269 
  270   --------------------------------------------------------------------------
  271 
  272   procedure delete (item: in out elem_sequence;
  273                     from: in     elem_index;
  274                     num:  in     elem_index := 1) is
  275 
  276 
  277   begin
  278       for n in from + num..item.len
  279       loop
  280           item.seq (n - num) := item.seq (n);
  281       end loop;
  282       item.len := item.len - num;
  283   end;
  284 
  285   --------------------------------------------------------------------------
  286 
  287   procedure set    (item: in out elem_sequence; value: in elements) is
  288   begin
  289      item.len := value'length;
  290      if item.len > 0
  291      then
  292         item.seq (1..item.len) := value;
  293      end if;
  294   end;
  295 
  296   --------------------------------------------------------------------------
  297 
  298   procedure set    (item: in out elem_sequence; value: in element) is
  299   begin
  300      item.seq (1) := value;
  301      item.len     := 1;
  302   end;
  303 
  304   --------------------------------------------------------------------------
  305 
  306   procedure clear (item: in out elem_sequence; from: in elem_index := 1) is
  307   begin
  308      set_length (item, from - 1);
  309   end;
  310 
  311   --------------------------------------------------------------------------
  312 
  313   procedure ensure_status (file: in tree_type) is
  314   begin
  315       if not is_open (file)
  316       then
  317          raise status_error;
  318       end if;
  319   end;
  320 
  321   --------------------------------------------------------------------------
  322 
  323   procedure except_mode (file: in tree_type; mode: tree_mode) is
  324   begin
  325       if file.mode = mode
  326       then
  327          raise mode_error;
  328       end if;
  329   end;
  330 
  331   --------------------------------------------------------------------------
  332 
  333   procedure put_node (file: in     tree_type;
  334                       tonp: in     node_position;
  335                       node: in     node_access) is
  336   begin
  337 
  338      -- WARNING !!!
  339      -- When size(file) = index(file) = tonp
  340      -- meridian v4.11 writes data record to tonp + 1,
  341      -- reset (file) temporary avoids this strange reaction.
  342 
  343      reset (file.file);
  344      write (file.file, node.all, io_pos (tonp));
  345   end;
  346 
  347   procedure get_node (file: in     tree_type;
  348                       tonp: in     node_position;
  349                       node: in     node_access) is
  350   begin
  351      read  (file.file, node.all, io_pos (tonp));
  352   end;
  353 
  354   procedure put_node (file: in     tree_type;
  355                       tonp: in     node_position) is
  356   begin
  357      put_node (file, tonp, file.node);
  358   end;
  359 
  360   procedure get_node (file: in     tree_type;
  361                       tonp: in     node_position) is
  362   begin
  363      get_node (file, tonp, file.node);
  364   end;
  365 
  366   --------------------------------------------------------------------------
  367 
  368   function is_equal (file: in tree_type; item: item_type) return boolean is
  369     curr: elem_location renames file.curr;
  370     data: elem_sequence renames file.node.data;
  371   begin
  372     if comp_softly
  373     then
  374        return not (data.seq (curr.slot).item < item xor curr.less);
  375     else
  376        return item = data.seq (curr.slot).item;
  377     end if;
  378   end;
  379 
  380   --------------------------------------------------------------------------
  381 
  382   procedure seek_root (file: in tree_type) is
  383   begin
  384     if file.curr.node /= 1
  385     then
  386        get_node (file, 1);
  387        file.curr.node  := 1;
  388        clear (file.path);
  389     end if;
  390   end;
  391 
  392   --------------------------------------------------------------------------
  393 
  394   procedure seek_right (file: in tree_type) is
  395     next: node_position;
  396     curr: elem_location renames file.curr;
  397     data: elem_sequence renames file.node.data;
  398   begin
  399 
  400     curr.less := false;
  401     loop
  402 
  403       curr.slot := data.len;
  404       next      := data.seq (curr.slot).node;
  405 
  406       exit when next = 0;
  407 
  408       append (curr, file.path);
  409       get_node (file, next);
  410 
  411       curr.node := next;
  412 
  413     end loop;
  414   end;
  415 
  416   --------------------------------------------------------------------------
  417 
  418   procedure seek_left (file: in tree_type) is
  419     next: node_position;
  420     curr: elem_location renames file.curr;
  421     data: elem_sequence renames file.node.data;
  422   begin
  423 
  424     curr.less := true;
  425     loop
  426 
  427       curr.slot := 1;
  428       next      := file.node.left;
  429 
  430       exit when next = 0;
  431 
  432       append   (curr, file.path);
  433       get_node (file, next);
  434 
  435       curr.node := next;
  436 
  437     end loop;
  438   end;
  439 
  440   --------------------------------------------------------------------------
  441 
  442   procedure seek_leaf (file: in tree_type; item: in item_type) is
  443     item_inside: boolean;
  444     next: node_position;
  445     curr: elem_location renames file.curr;
  446   begin
  447 
  448     if seek_softly
  449     then
  450 
  451        seek_up: loop
  452 
  453           curr.slot  := find_le (file.node.data, item);
  454           curr.less  := item < file.node.data.seq (curr.slot).item;
  455 
  456           if    curr.slot = length (file.node.data)
  457           then
  458              item_inside :=     curr.less;
  459           elsif curr.slot = 1
  460           then
  461              item_inside := not curr.less;
  462           else
  463              item_inside := true;
  464           end if;
  465 
  466           exit when item_inside;
  467           exit when length (file.path) = 0;
  468 
  469           discard (file.path, curr);
  470 
  471           get_node (file, curr.node);
  472 
  473        end loop seek_up;
  474 
  475     else
  476           seek_root (file);
  477 
  478           curr.slot := find_le (file.node.data, item);
  479           curr.less := item < file.node.data.seq (curr.slot).item;
  480 
  481     end if;
  482 
  483     seek_down: loop
  484        if curr.less
  485        then
  486          if curr.slot = 1
  487          then
  488             next := file.node.left;
  489          else
  490             next := file.node.data.seq (curr.slot - 1).node;
  491          end if;
  492        else
  493          next  := file.node.data.seq (curr.slot).node;
  494        end if;
  495 
  496        exit when next = 0;
  497 
  498        append (curr, file.path);
  499 
  500        get_node (file, next);
  501 
  502        curr.node  := next;
  503        curr.slot  := find_le (file.node.data, item);
  504        curr.less  := item < file.node.data.seq (curr.slot).item;
  505     end loop seek_down;
  506 
  507   end seek_leaf;
  508 
  509   --------------------------------------------------------------------------
  510 
  511   procedure seek_pred (file: in tree_type; okay: in out boolean) is
  512 
  513     curr: elem_location renames file.curr;
  514     data: elem_sequence renames file.node.data;
  515     next: node_position;
  516     last: node_position;
  517 
  518     function next_node (elem: in elem_index) return node_position is
  519     begin
  520        if elem = 1
  521        then
  522           return file.node.left;
  523        else
  524           return data.seq (elem - 1).node;
  525        end if;
  526     end;
  527 
  528   begin
  529     okay := false;
  530     if data.len > 0
  531     then
  532 
  533        next := next_node (curr.slot);
  534 
  535        if next /= 0
  536        then
  537 
  538          curr.less := true;
  539 
  540          append     (curr, file.path);
  541          get_node   (file, next);
  542          seek_right (file);
  543          okay      := true;
  544 
  545        else
  546           last := curr.node;
  547           loop
  548 
  549             if curr.slot > 1
  550             then
  551                curr.slot := curr.slot - 1;
  552                okay      := true;
  553                exit;
  554             end if;
  555 
  556             exit when length (file.path) = 0;
  557 
  558             discard (file.path, curr);
  559 
  560             if not curr.less
  561             then
  562                okay      := true;
  563                exit;
  564             end if;
  565           end loop;
  566 
  567           if last /= curr.node
  568           then
  569              get_node (file, curr.node);
  570           end if;
  571        end if;
  572     end if;
  573   end seek_pred;
  574 
  575   --------------------------------------------------------------------------
  576 
  577   procedure seek_succ (file: in tree_type; okay: out boolean) is
  578 
  579     curr: elem_location renames file.curr;
  580     data: elem_sequence renames file.node.data;
  581     next: node_position;
  582 
  583     function next_node (elem: in elem_index) return node_position is
  584     begin
  585        return data.seq (elem).node;
  586     end;
  587 
  588   begin
  589     okay := false;
  590     if data.len > 0
  591     then
  592        next := next_node (curr.slot);
  593 
  594        if next /= 0
  595        then
  596 
  597          curr.less := false;
  598 
  599          append     (curr, file.path);
  600          get_node   (file, next);
  601          seek_left  (file);
  602          okay      := true;
  603 
  604        else
  605 
  606           loop
  607 
  608             if curr.slot < length (data)
  609             then
  610                curr.slot := curr.slot + 1;
  611                okay      := true;
  612                exit;
  613             end if;
  614 
  615             exit when length (file.path) = 0;
  616 
  617             discard  (file.path, curr);
  618             get_node (file, curr.node);
  619 
  620             if curr.less
  621             then
  622                okay      := true;
  623                exit;
  624             end if;
  625           end loop;
  626 
  627        end if;
  628     end if;
  629   end seek_succ;
  630 
  631   --------------------------------------------------------------------------
  632 
  633   procedure seek_item (file: in tree_type;
  634                        item: in item_type;
  635                        okay: in out boolean) is
  636 
  637     curr: elem_location renames file.curr;
  638     data: elem_sequence renames file.node.data;
  639 
  640   begin
  641 
  642     seek_leaf (file, item);
  643 
  644     okay := false;
  645 
  646     if data.len > 0
  647     then
  648        if is_equal (file, item)
  649        then
  650           okay := true;
  651        else
  652           seek_pred (file, okay);
  653 
  654           if okay
  655           then
  656             curr.less := item < data.seq (curr.slot).item;
  657             okay      := is_equal (file, item);
  658           end if;
  659        end if;
  660     end if;
  661   end seek_item;
  662 
  663   --------------------------------------------------------------------------
  664 
  665   procedure destroy (file: in out tree_type) is
  666      procedure release is new unchecked_deallocation (tree_object, tree_type);
  667   begin
  668     if file /= null
  669     then
  670       if is_open (file.file)
  671       then
  672          close (file.file);
  673       end if;
  674       if file.node /= null
  675       then
  676          release (file.node);
  677       end if;
  678       release (file);
  679     end if;
  680   end;
  681 
  682   --------------------------------------------------------------------------
  683 
  684   procedure create(file : in out tree_type;
  685                    mode : in tree_mode := inout_tree;
  686                    name : in string := "";
  687                    form : in string := "") is
  688   begin
  689      file      := new tree_object;
  690      file.node := new node_record;
  691 
  692      file.mode := mode;
  693      create (file.file, io_mode (mode), name, form);
  694 
  695      file.node.left  := 0;
  696 
  697      clear  (file.node.data);
  698      clear  (file.path);
  699 
  700      file.curr.less  := false;
  701      file.curr.node  := 1;
  702      file.curr.slot  := 1;
  703 
  704      put_node (file, file.curr.node);
  705 
  706   exception
  707      when others => destroy (file);
  708                     raise;
  709   end;
  710 
  711   --------------------------------------------------------------------------
  712 
  713   procedure open(file : in out tree_type;
  714                  mode : in tree_mode;
  715                  name : in string := "";
  716                  form : in string := "") is
  717   begin
  718      file      := new tree_object;
  719      file.node := new node_record;
  720      file.mode := mode;
  721 
  722      open  (file.file, io_mode (mode), name, form);
  723      file.curr.node := 0;
  724      seek_root(file);
  725   exception
  726      when others => destroy (file); raise;
  727   end;
  728 
  729   --------------------------------------------------------------------------
  730 
  731   procedure close (file : in out tree_type) is
  732   begin
  733      ensure_status (file);
  734      close (file.file);
  735      destroy (file);
  736   end;
  737 
  738   --------------------------------------------------------------------------
  739 
  740   procedure delete (file : in out tree_type) is
  741   begin
  742      ensure_status (file);
  743      delete  (file.file);
  744      destroy (file);
  745   end;
  746 
  747   --------------------------------------------------------------------------
  748 
  749   function is_open (file : in tree_type) return boolean is
  750   begin
  751      if file /= null
  752      then
  753         return is_open (file.file);
  754      end if;
  755      return false;
  756   end;
  757 
  758   --------------------------------------------------------------------------
  759 
  760   function name (file : in tree_type) return string is
  761   begin
  762      ensure_status (file);
  763      return name (file.file);
  764   end;
  765 
  766   --------------------------------------------------------------------------
  767 
  768   function form (file : in tree_type) return string is
  769   begin
  770      ensure_status (file);
  771      return form (file.file);
  772   end;
  773 
  774   --------------------------------------------------------------------------
  775 
  776   function mode (file : in tree_type) return tree_mode is
  777   begin
  778      ensure_status (file);
  779      return file.mode;
  780   end;
  781 
  782   --------------------------------------------------------------------------
  783 
  784   procedure reset  (file : in out tree_type) is
  785   begin
  786      ensure_status (file);
  787      reset (file.file);
  788      seek_root (file);
  789   end;
  790 
  791   --------------------------------------------------------------------------
  792 
  793   procedure reset  (file : in out tree_type;
  794                     mode : in     tree_mode) is
  795   begin
  796      ensure_status (file);
  797      reset (file.file, io_mode (mode));
  798      seek_root (file);
  799   end;
  800 
  801   --------------------------------------------------------------------------
  802 
  803   procedure condalloc (node: in out node_access) is
  804   begin
  805      if node = null
  806      then
  807         node := new node_record;
  808      end if;
  809   end;
  810 
  811   --------------------------------------------------------------------------
  812 
  813   procedure insert (file : in out tree_type;
  814                     item : in item_type;
  815                     data : in data_type) is
  816 
  817     upd : boolean := false;
  818     temp: node_access := null;
  819     npos: node_position;
  820     elem: element;
  821     left: node_position;  -- left node of element
  822 
  823     procedure split_node is
  824     begin
  825 
  826        condalloc (temp);
  827 
  828        if file.curr.slot <= elem_count (tree_degree + 1)
  829        then
  830 
  831           set (temp.data, file.node.data.seq (elem_count (tree_degree) + 1..
  832                                               elem_count (tree_degree) * 2));
  833 
  834           set_length (file.node.data, elem_count (tree_degree));
  835 
  836           if file.curr.slot <= elem_count (tree_degree)
  837           then
  838              insert (file.node.data, elem, file.curr.slot);
  839              elem := file.node.data.seq (elem_count (tree_degree) + 1);
  840           end if;
  841        else
  842           if file.curr.slot = elem_count (tree_degree) + 2
  843           then
  844              set    (temp.data, elem);
  845              append (file.node.data.seq (elem_count (tree_degree) + 2..
  846                                          elem_count (node_length)), temp.data);
  847           else
  848 
  849              set (temp.data, file.node.data.seq (elem_count (tree_degree) + 2..
  850                                                  elem_count (node_length)));
  851 
  852              if file.curr.slot = elem_count (node_length) and then
  853                 file.curr.less = false
  854              then
  855                 append (elem, temp.data);
  856              else
  857                 insert (temp.data, elem, file.curr.slot);
  858              end if;
  859 
  860           end if;
  861           elem := file.node.data.seq (elem_count (tree_degree) + 1);
  862        end if;
  863        set_length (file.node.data, elem_count (tree_degree));
  864 
  865        temp.left := elem.node;
  866 
  867        npos := node_position (size (file.file) + 1);
  868 
  869        temp.left     := elem.node;
  870        elem.node     := npos;
  871 
  872        put_node (file, npos, temp); -- temp is always right
  873 
  874     end split_node;
  875 
  876   begin
  877 
  878     ensure_status (file);
  879     except_mode   (file, in_tree);
  880 
  881     elem.item  := item;
  882     elem.data  := data;
  883     elem.node  := 0;
  884 
  885     if length (file.node.data) < 1
  886     then
  887        append (elem, file.node.data);
  888     else
  889 
  890        seek_leaf (file, item);
  891 
  892        inserting: loop
  893 
  894           if length (file.node.data) < elem_count (node_length)
  895           then
  896              if file.curr.slot < length (file.node.data)
  897              then
  898                insert (file.node.data, elem, file.curr.slot);
  899              else
  900                if file.curr.less
  901                then
  902                   insert (file.node.data, elem, file.curr.slot);
  903                else
  904                   append (elem, file.node.data);
  905                end if;
  906              end if;
  907 
  908              exit inserting;
  909 
  910           else
  911 
  912              split_node;
  913 
  914              if length (file.path) = 0 -- root node here
  915              then
  916                 -- append old root to file
  917                 npos := node_position (size (file.file) + 1);
  918 
  919                 put_node (file, npos);
  920 
  921                 set (file.node.data, elem);
  922 
  923                 file.node.left := npos;
  924                 file.curr.less := false;
  925                 file.curr.slot := 1;
  926 
  927                 exit inserting;
  928 
  929              else
  930                 put_node (file, file.curr.node);
  931              end if;
  932 
  933              discard (file.path, file.curr);
  934 
  935              get_node (file, file.curr.node);
  936 
  937           end if;
  938 
  939        end loop inserting;
  940     end if;
  941 
  942     -- update changes of curr node
  943     put_node (file, file.curr.node);
  944 
  945     if temp /= null
  946     then
  947        release (temp);
  948     end if;
  949 
  950   exception
  951       when others => release (temp);
  952                      raise;
  953   end insert;
  954 
  955   --------------------------------------------------------------------------
  956 
  957   procedure modify (file : in out tree_type;
  958                     item : in item_type;
  959                     data : in data_type;
  960                     ok   : out boolean) is
  961 
  962   begin
  963 
  964     ok := false;
  965 
  966     ensure_status (file);
  967     except_mode   (file, in_tree);
  968 
  969     declare
  970        elms: elem_sequence renames file.node.data;
  971        curr: elem_location renames file.curr;
  972        okay: boolean;
  973     begin
  974        seek_item     (file, item, okay);
  975 
  976        if okay
  977        then
  978 
  979           elms.seq (curr.slot).data := data;
  980           put_node (file, curr.node);
  981 
  982           ok   := true;
  983        end if;
  984     end;
  985   end modify;
  986 
  987   --------------------------------------------------------------------------
  988 
  989   procedure junk    (elem:  in     element;
  990                      left:  in     node_access;
  991                      right: in     node_access) is
  992   begin
  993 
  994       append (elem, left.data);
  995       left.data.seq (left.data.len).node := right.left;
  996       append (right.data.seq (1..right.data.len), left.data);
  997 
  998   end;
  999 
 1000   --------------------------------------------------------------------------
 1001 
 1002   procedure balance (elem:  in out element;
 1003                      left:  in     node_access;
 1004                      right: in     node_access) is
 1005 
 1006      num: elem_count := elem_count (abs (integer(length (left.data)) -
 1007                                          integer(length (right.data))) / 2);
 1008 
 1009   begin
 1010 
 1011      if num >= 1
 1012      then
 1013         if length (left.data) < length (right.data)
 1014         then
 1015 
 1016            append (elem, left.data);
 1017            left.data.seq (left.data.len).node := right.left;
 1018 
 1019            append (right.data.seq (1..num - 1), left.data);
 1020 
 1021            declare
 1022               last: element renames right.data.seq (num);
 1023            begin
 1024               right.left := last.node;
 1025               elem.data  := last.data;
 1026               elem.item  := last.item;
 1027            end;
 1028 
 1029            delete (right.data, 1, num);
 1030 
 1031         else
 1032 
 1033            extend (right.data, num, 1);
 1034 
 1035            right.data.seq (num).data := elem.data;
 1036            right.data.seq (num).item := elem.item;
 1037            right.data.seq (num).node := right.left;
 1038 
 1039            declare
 1040               spos: elem_index := (left.data.len - num + 1);
 1041               last: element renames left.data.seq (spos);
 1042            begin
 1043 
 1044               amend (right.data, left.data.seq (spos + 1..left.data.len), 1);
 1045 
 1046               right.left := last.node;
 1047               elem.data  := last.data;
 1048               elem.item  := last.item;
 1049 
 1050               delete (left.data, spos, num);
 1051 
 1052            end;
 1053 
 1054         end if;
 1055      end if;
 1056   end;
 1057 
 1058   --------------------------------------------------------------------------
 1059 
 1060   procedure delete (file : in out tree_type;
 1061                     item : in item_type;
 1062                     data : out data_type;
 1063                     ok   : out boolean) is
 1064 
 1065     tmpr: node_access := null;
 1066     tmpl: node_access := null;
 1067 
 1068     next: node_position;
 1069     fore: elem_location;
 1070     elem: element;
 1071     okay: boolean;
 1072 
 1073     function left (elem: in elem_index) return node_position is
 1074     begin
 1075        if elem = 1
 1076        then
 1077           return file.node.left;
 1078        else
 1079           return file.node.data.seq (elem - 1).node;
 1080        end if;
 1081     end;
 1082 
 1083     procedure swap (a, b: in out node_access) is
 1084        t: node_access;
 1085     begin
 1086        t := a; a := b; b := t;
 1087     end;
 1088 
 1089   begin
 1090 
 1091     ok := false;
 1092 
 1093     ensure_status (file);
 1094     except_mode   (file,  in_tree);
 1095     except_mode   (file, out_tree);
 1096 
 1097     declare
 1098        curr: elem_location renames file.curr;
 1099        fino: node_access   renames file.node;
 1100     begin
 1101 
 1102        seek_item (file, item, okay);
 1103 
 1104        if okay
 1105        then
 1106 
 1107           data := fino.data.seq (curr.slot).data;
 1108           next := left (curr.slot);
 1109 
 1110           if next /= 0
 1111           then
 1112 
 1113              tmpl      := fino;
 1114              fino      := new node_record;
 1115 
 1116              fore      := curr;
 1117              curr.less := true;
 1118 
 1119              append     (curr, file.path);
 1120              get_node   (file, next, fino);
 1121 
 1122              curr.node := next;
 1123 
 1124              seek_right (file);
 1125 
 1126              tmpl.data.seq (fore.slot).data := fino.data.seq (curr.slot).data;
 1127              tmpl.data.seq (fore.slot).item := fino.data.seq (curr.slot).item;
 1128 
 1129              put_node (file, fore.node, tmpl);
 1130 
 1131           end if;
 1132 
 1133           delete (fino.data, curr.slot);
 1134 
 1135           loop
 1136 
 1137              exit when length (file.path)  = 0;
 1138              exit when length (fino.data) >= elem_count (tree_degree);
 1139 
 1140              condalloc (tmpl);
 1141              condalloc (tmpr);
 1142 
 1143              discard (file.path, curr); -- prepare to reading root
 1144 
 1145              -- save old root
 1146 
 1147              if curr.less
 1148              then
 1149                 swap (tmpl, fino);
 1150                 get_node (file, curr.node, fino);
 1151                 get_node (file, fino.data.seq (curr.slot).node, tmpr);
 1152 
 1153              else
 1154                 swap (tmpr, fino);
 1155                 get_node (file, curr.node       , fino);
 1156                 get_node (file, left (curr.slot), tmpl);
 1157 
 1158              end if;
 1159 
 1160              if  integer (length (tmpl.data)) +
 1161                  integer (length (tmpr.data)) < node_length
 1162              then
 1163                  junk (fino.data.seq (curr.slot), tmpl, tmpr);
 1164 
 1165                  next := left (curr.slot);
 1166                  delete (fino.data, curr.slot);
 1167 
 1168                  if length (fino.data) = 0
 1169                  then
 1170                     swap (tmpl, fino);
 1171                  else
 1172                     put_node (file, next, tmpl);
 1173                  end if;
 1174 
 1175              else
 1176                  balance  (fino.data.seq (curr.slot), tmpl, tmpr);
 1177                  put_node (file, fino.data.seq (curr.slot).node, tmpr);
 1178                  put_node (file, left (curr.slot), tmpl);
 1179 
 1180              end if;
 1181 
 1182           end loop;
 1183 
 1184           put_node (file, curr.node, fino);
 1185 
 1186           ok   := true;
 1187 
 1188           release (tmpl);
 1189           release (tmpr);
 1190 
 1191        end if;
 1192 
 1193     end;
 1194 
 1195   exception
 1196     when others => release (tmpl);
 1197                    release (tmpr);
 1198                    raise;
 1199   end delete;
 1200 
 1201   --------------------------------------------------------------------------
 1202 
 1203   procedure get_first(file : in tree_type;
 1204                       item : out item_type;
 1205                       data : out data_type;
 1206                       ok   : out boolean) is 
 1207 
 1208 
 1209   begin
 1210     ok := false;
 1211 
 1212     ensure_status (file);
 1213     except_mode   (file, out_tree);
 1214 
 1215     declare
 1216        elms: elem_sequence renames file.node.data;
 1217        curr: elem_location renames file.curr;
 1218     begin
 1219        if elms.len > 0
 1220        then
 1221          seek_root  (file);
 1222          seek_left  (file);
 1223 
 1224          item := elms.seq (curr.slot).item;
 1225          data := elms.seq (curr.slot).data;
 1226 
 1227          ok := true;
 1228        end if;
 1229     end;
 1230   end get_first; 
 1231 
 1232   --------------------------------------------------------------------------
 1233 
 1234   procedure get_last(file : in tree_type;
 1235                      item : out item_type;
 1236                      data : out data_type;
 1237                      ok   : out boolean) is
 1238 
 1239   begin
 1240     ok := false;
 1241 
 1242     ensure_status (file);
 1243     except_mode   (file, out_tree);
 1244 
 1245     declare
 1246        elms: elem_sequence renames file.node.data;
 1247        curr: elem_location renames file.curr;
 1248     begin
 1249        if elms.len > 0
 1250        then
 1251          seek_root  (file);
 1252          seek_right (file);
 1253 
 1254          item := elms.seq (curr.slot).item;
 1255          data := elms.seq (curr.slot).data;
 1256 
 1257          ok   := true;
 1258        end if;
 1259     end;
 1260   end get_last; 
 1261 
 1262   --------------------------------------------------------------------------
 1263 
 1264   procedure get_ge(file : in tree_type;
 1265                    item : in out item_type;
 1266                    data : out data_type;
 1267                    ok   : out boolean) is 
 1268 
 1269   begin
 1270 
 1271     ok := false;
 1272 
 1273     ensure_status (file);
 1274     except_mode   (file, out_tree);
 1275 
 1276     declare
 1277        elms: elem_sequence renames file.node.data;
 1278        curr: elem_location renames file.curr;
 1279        elem: element;
 1280        okay: boolean := false;
 1281     begin
 1282 
 1283        if elms.len > 0
 1284        then
 1285 
 1286           seek_leaf (file, item);
 1287 
 1288           if is_equal (file, item)
 1289           then
 1290              okay := true;
 1291           else
 1292              if curr.less
 1293              then
 1294 
 1295                 elem.item := elms.seq (curr.slot).item;
 1296                 elem.data := elms.seq (curr.slot).data;
 1297 
 1298                 seek_pred (file, okay);
 1299 
 1300                 if okay
 1301                 then
 1302                    curr.less := item < elms.seq (curr.slot).item;
 1303                    okay      := is_equal (file, item);
 1304                 end if;
 1305 
 1306                 if not okay
 1307                 then
 1308                    item := elem.item;
 1309                    data := elem.data;
 1310                    ok   := true;
 1311                 end if;
 1312              else
 1313                 seek_succ (file, okay);
 1314              end if;
 1315           end if;
 1316 
 1317           if okay
 1318           then
 1319             item := elms.seq (curr.slot).item;
 1320             data := elms.seq (curr.slot).data;
 1321             ok   := okay;
 1322           end if;
 1323 
 1324        end if;
 1325     end;
 1326   end get_ge;
 1327 
 1328   --------------------------------------------------------------------------
 1329 
 1330   procedure get_le(file : in tree_type;
 1331                    item : in out item_type;
 1332                    data : out data_type;
 1333                    ok   : out boolean) is 
 1334 
 1335   begin
 1336 
 1337     ok := false;
 1338 
 1339     ensure_status (file);
 1340     except_mode   (file, out_tree);
 1341 
 1342     declare
 1343        elms: elem_sequence renames file.node.data;
 1344        curr: elem_location renames file.curr;
 1345        elem: element;
 1346        okay: boolean := false;
 1347     begin
 1348 
 1349        if elms.len > 0
 1350        then
 1351           seek_leaf (file, item);
 1352 
 1353           if is_equal (file, item)
 1354           then
 1355              okay := true;
 1356           else
 1357              if not curr.less
 1358              then
 1359 
 1360                 elem.item := elms.seq (curr.slot).item;
 1361                 elem.data := elms.seq (curr.slot).data;
 1362 
 1363                 seek_succ (file, okay);
 1364 
 1365                 if okay
 1366                 then
 1367                    curr.less := item < elms.seq (curr.slot).item;
 1368                    okay      := is_equal (file, item);
 1369                 end if;
 1370 
 1371                 if not okay
 1372                 then
 1373                    item := elem.item;
 1374                    data := elem.data;
 1375                    ok   := true;
 1376                 end if;
 1377              else
 1378                 seek_pred (file, okay);
 1379              end if;
 1380 
 1381           end if;
 1382 
 1383           if okay
 1384           then
 1385             item := elms.seq (curr.slot).item;
 1386             data := elms.seq (curr.slot).data;
 1387             ok   := okay;
 1388           end if;
 1389 
 1390        end if;
 1391     end;
 1392 
 1393   end get_le;
 1394 
 1395   --------------------------------------------------------------------------
 1396 
 1397   procedure get_lt(file : in tree_type;
 1398                    item : in out item_type;
 1399                    data : out data_type;
 1400                    ok   : out boolean) is 
 1401 
 1402   begin
 1403 
 1404     ok := false;
 1405 
 1406     ensure_status (file);
 1407     except_mode   (file, out_tree);
 1408 
 1409     declare
 1410        elms: elem_sequence renames file.node.data;
 1411        curr: elem_location renames file.curr;
 1412        elem: element;
 1413        okay: boolean := false;
 1414     begin
 1415 
 1416        if elms.len > 0
 1417        then
 1418 
 1419           seek_leaf (file, item);
 1420 
 1421           if curr.less
 1422           then
 1423              seek_pred (file, okay);
 1424              if okay
 1425              then
 1426                 curr.less := item < elms.seq (curr.slot).item;
 1427              end if;
 1428           else
 1429              okay := true;
 1430           end if;
 1431 
 1432           if okay
 1433           then
 1434              if is_equal (file, item)
 1435              then
 1436                 seek_pred (file, okay);
 1437              end if;
 1438           end if;
 1439 
 1440           if okay
 1441           then
 1442             item := elms.seq (curr.slot).item;
 1443             data := elms.seq (curr.slot).data;
 1444             ok   := okay;
 1445           end if;
 1446 
 1447        end if;
 1448     end;
 1449 
 1450   end get_lt;
 1451 
 1452   --------------------------------------------------------------------------
 1453 
 1454   procedure get_gt(file : in tree_type;
 1455                    item : in out item_type;
 1456                    data : out data_type;
 1457                    ok   : out boolean) is
 1458 
 1459   begin
 1460 
 1461     ok := false;
 1462 
 1463     ensure_status (file);
 1464     except_mode   (file, out_tree);
 1465 
 1466     declare
 1467        elms: elem_sequence renames file.node.data;
 1468        curr: elem_location renames file.curr;
 1469        elem: element;
 1470        okay: boolean := false;
 1471     begin
 1472 
 1473        if elms.len > 0
 1474        then
 1475 
 1476           seek_leaf (file, item);
 1477 
 1478           if not curr.less
 1479           then
 1480              seek_succ (file, okay);
 1481              if okay
 1482              then
 1483                 curr.less := item < elms.seq (curr.slot).item;
 1484              end if;
 1485           else
 1486              okay := true;
 1487           end if;
 1488 
 1489           if okay
 1490           then
 1491              if is_equal (file, item)
 1492              then
 1493                 seek_succ (file, okay);
 1494              end if;
 1495           end if;
 1496 
 1497           if okay
 1498           then
 1499             item := elms.seq (curr.slot).item;
 1500             data := elms.seq (curr.slot).data;
 1501             ok   := okay;
 1502           end if;
 1503 
 1504        end if;
 1505     end;
 1506 
 1507   end get_gt;
 1508 
 1509 begin
 1510    if tree_degree < 2
 1511    then
 1512       raise program_error;
 1513    end if;
 1514 end b_tree_file;
 1515