l4/pkg/ocaml/contrib/stdlib/queue.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*        François Pottier, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: queue.ml 7032 2005-08-26 12:10:47Z doligez $ *)
  15
  16 exception Empty
  17
  18 (* O'Caml currently does not allow the components of a sum type to be
  19    mutable. Yet, for optimal space efficiency, we must have cons cells
  20    whose [next] field is mutable. This leads us to define a type of
  21    cyclic lists, so as to eliminate the [Nil] case and the sum
  22    type. *)
  23
  24 type 'a cell = {
  25     content: 'a;
  26     mutable next: 'a cell
  27   }
  28
  29 (* A queue is a reference to either nothing or some cell of a cyclic
  30    list. By convention, that cell is to be viewed as the last cell in
  31    the queue. The first cell in the queue is then found in constant
  32    time: it is the next cell in the cyclic list. The queue's length is
  33    also recorded, so as to make [length] a constant-time operation.
  34
  35    The [tail] field should really be of type ['a cell option], but
  36    then it would be [None] when [length] is 0 and [Some] otherwise,
  37    leading to redundant memory allocation and accesses. We avoid this
  38    overhead by filling [tail] with a dummy value when [length] is 0.
  39    Of course, this requires bending the type system's arm slightly,
  40    because it does not have dependent sums. *)
  41
  42 type 'a t = {
  43     mutable length: int;
  44     mutable tail: 'a cell
  45   }
  46
  47 let create () = {
  48   length = 0;
  49   tail = Obj.magic None
  50 }
  51
  52 let clear q =
  53   q.length <- 0;
  54   q.tail <- Obj.magic None
  55
  56 let add x q =
  57   q.length <- q.length + 1;
  58   if q.length = 1 then
  59     let rec cell = {
  60       content = x;
  61       next = cell
  62     } in
  63     q.tail <- cell
  64   else
  65     let tail = q.tail in
  66     let head = tail.next in
  67     let cell = {
  68       content = x;
  69       next = head
  70     } in
  71     tail.next <- cell;
  72     q.tail <- cell
  73
  74 let push =
  75   add
  76
  77 let peek q =
  78   if q.length = 0 then
  79     raise Empty
  80   else
  81     q.tail.next.content
  82
  83 let top =
  84   peek
  85
  86 let take q =
  87   if q.length = 0 then raise Empty;
  88   q.length <- q.length - 1;
  89   let tail = q.tail in
  90   let head = tail.next in
  91   if head == tail then
  92     q.tail <- Obj.magic None
  93   else
  94     tail.next <- head.next;
  95   head.content
  96
  97 let pop =
  98   take
  99
 100 let copy q =
 101   if q.length = 0 then
 102     create()
 103   else
 104     let tail = q.tail in
 105
 106     let rec tail' = {
 107       content = tail.content;
 108       next = tail'
 109     } in
 110
 111     let rec copy cell =
 112       if cell == tail then tail'
 113       else {
 114         content = cell.content;
 115         next = copy cell.next
 116       } in
 117
 118     tail'.next <- copy tail.next;
 119     {
 120       length = q.length;
 121       tail = tail'
 122     }
 123
 124 let is_empty q =
 125   q.length = 0
 126
 127 let length q =
 128   q.length
 129
 130 let iter f q =
 131   if q.length > 0 then
 132     let tail = q.tail in
 133     let rec iter cell =
 134       f cell.content;
 135       if cell != tail then
 136         iter cell.next in
 137     iter tail.next
 138
 139 let fold f accu q =
 140   if q.length = 0 then
 141     accu
 142   else
 143     let tail = q.tail in
 144     let rec fold accu cell =
 145       let accu = f accu cell.content in
 146       if cell == tail then
 147         accu
 148       else
 149         fold accu cell.next in
 150     fold accu tail.next
 151
 152 let transfer q1 q2 =
 153   let length1 = q1.length in
 154   if length1 > 0 then
 155     let tail1 = q1.tail in
 156     clear q1;
 157     if q2.length > 0 then begin
 158       let tail2 = q2.tail in
 159       let head1 = tail1.next in
 160       let head2 = tail2.next in
 161       tail1.next <- head2;
 162       tail2.next <- head1
 163     end;
 164     q2.length <- q2.length + length1;
 165     q2.tail <- tail1