/* Sample program #3 for Project Rosetta Stone

   Coded by Barry L. Wolman on 10 December 1972

   The three entries in this program implement the "buddy" storage allocation
   method described by Knuth.  An external segment "m$" of 65536 words is used
   as the allocation pool.  The internal static array "x" holds the index
   of the first available block of words of size 2**n;  the first word of an
   available block holds the index of the next available block a value of -1
   indicating the end of the list.  The list of available blocks is not
   ordered.

   The entry "init" initializes the pool to contain one block of size 65536.

   The entry "get" obtains a block of size 2**n.  If a block of proper size
   is available, the first such block is removed from the list of available
   blocks.  If there is no block of size 2**n, get calls itself to get a block
   of size 2**(n+1);  it splits the block into two halves, one of which it
   uses and the other (the "buddy") it puts on the list of blocks of size 2**n.
   An error code is returned if n is out of range or if the request cannot
   be satisfied.

   The entry "free" is called to return a block of size 2**n.  An error code
   will be returned if
          1.        n is out of range
          2.        the block index is not a multiple of 2**n
          3.        the block is already on the available list
          4.        a smaller available block is included in the block being fre
          5.        a larger available block includes the block being freed
   If the "buddy" of the block being returned is also available, they are
   combined into a block of size 2**(n+1) and that block is checked.

                                                                      */


init:     proc;

dcl       m$(0:65535) fixed binary external,
          x(0:16) fixed binary internal static,
          two(0:16) fixed binary internal static
           init (1,2,4,8,16,32,64,128,256,512,1024,
                 2048,4096,8192,16384,32768,65536);

dcl       (i,j,k,n,pj,buddy) fixed binary,
          (max,unspec) builtin;

          x = -1;
          x(16) = 0;
          m$(0) = -1;
          return;

get:      entry(ng) returns(fixed binary);

dcl       ng fixed binary;

          if ng < 0 | ng > 16 then return(-1) ;

          k = x(ng);
          if k >= 0
          then do;
               x(ng) = m$(k);
               return(k);
               end;

          k = get(ng+1);
          if k < 0 then return(-1);

          unspec(buddy) = bool(unspec(k),unspec(two(ng)),"0110"b);
          m$(buddy) = x(ng);
          x(ng) = buddy;

          return(k);

free:     entry(index,nf) returns(fixed binary);

dcl       (index,nf) fixed binary;

          n = nf;
          if n < 0 | n > 16 then return(-1);

          i = index;
          if mod(i,two(n)) ^= 0 then return(-1);

          do k = 0 to 16;
               do j = x(k) repeat(m$(j)) while(j >= 0);
                    if bool(unspec(i),unspec(j),"0110"b)
                     < unspec(two(max(n,k)))
                    then return(-1);
                    end;
               end;

loop:     unspec(buddy) = bool(unspec(i),unspec(two(n)),"0110"b);

          pj = -1;
          do j = x(n) repeat(m$(j)) while(j >= 0);
               if j = buddy
               then do;
                    if pj < 0 then x(n) = m$(j); else m$(pj) = m$(j);

                    if i > buddy then i = buddy;
                    n = n + 1;
                    goto loop;
                    end;

               pj = j ;
               end;

          m$(i) = x(n);
          x(n) = i;
          return(0);

          end;