Annotation of OpenXM_contrib/PHC/Ada/Math_Lib/Polynomials/generic_lists.adb, Revision 1.1
1.1 ! maekawa 1: package body Generic_Lists is
! 2:
! 3: -- INTERNAL DATA :
! 4:
! 5: type Node is record
! 6: The_Item : Item;
! 7: Next : List;
! 8: end record;
! 9:
! 10: Free_List : List := null;
! 11:
! 12: -- AUXILIARIES :
! 13:
! 14: procedure Set_Next ( The_Node : in out Node; To_Next : in List ) is
! 15: begin
! 16: The_Node.Next := To_Next;
! 17: end Set_Next;
! 18:
! 19: function Next_Of ( The_Node : in Node ) return List is
! 20: begin
! 21: return The_Node.Next;
! 22: end Next_Of;
! 23:
! 24: procedure Free ( l : in out List ) is
! 25:
! 26: tmp : List;
! 27:
! 28: begin
! 29: while l /= null loop
! 30: tmp := l;
! 31: l := Next_Of(l.all);
! 32: Set_Next(tmp.all,Free_List);
! 33: Free_List := tmp;
! 34: end loop;
! 35: end Free;
! 36:
! 37: function New_Item return List is
! 38:
! 39: tmp : List;
! 40:
! 41: begin
! 42: if Free_List = null
! 43: then return new Node;
! 44: else tmp := Free_List;
! 45: Free_List := Next_Of(tmp.all);
! 46: Set_Next(tmp.all,null);
! 47: return tmp;
! 48: end if;
! 49: end New_Item;
! 50:
! 51: -- CONSTRUCTORS :
! 52:
! 53: procedure Construct ( i : in Item; l : in out List ) is
! 54:
! 55: tmp : List;
! 56:
! 57: begin
! 58: tmp := New_Item;
! 59: tmp.The_Item := i;
! 60: tmp.Next := l;
! 61: l := tmp;
! 62: exception
! 63: when Storage_Error => raise Overflow;
! 64: end Construct;
! 65:
! 66: procedure Append ( first,last : in out List; i : in Item ) is
! 67: begin
! 68: if Is_Null(first)
! 69: then Construct(i,first);
! 70: last := first;
! 71: else declare
! 72: tmp : List;
! 73: begin
! 74: Construct(i,tmp);
! 75: Swap_Tail(last,tmp);
! 76: last := Tail_Of(last);
! 77: end;
! 78: end if;
! 79: end Append;
! 80:
! 81: procedure Concat ( first,last : in out List; l : in List ) is
! 82:
! 83: tmp : List := l;
! 84:
! 85: begin
! 86: while not Is_Null(tmp) loop
! 87: Append(first,last,Head_Of(tmp));
! 88: tmp := Tail_Of(tmp);
! 89: end loop;
! 90: end Concat;
! 91:
! 92: procedure Set_Head ( l : in out List; i : in Item ) is
! 93: begin
! 94: l.The_Item := i;
! 95: exception
! 96: when Constraint_Error => raise List_Is_Null;
! 97: end Set_Head;
! 98:
! 99: procedure Swap_Tail ( l1,l2 : in out List ) is
! 100:
! 101: tmp : List;
! 102:
! 103: begin
! 104: tmp := l1.Next;
! 105: l1.Next := l2;
! 106: l2 := tmp;
! 107: exception
! 108: when Constraint_Error => raise List_Is_Null;
! 109: end Swap_Tail;
! 110:
! 111: procedure Copy ( l1 : in List; l2 : in out List ) is
! 112:
! 113: From_Index : List := l1;
! 114: To_Index : List;
! 115:
! 116: begin
! 117: Free(l2);
! 118: if l1 /= null
! 119: then l2 := New_Item;
! 120: l2.The_Item := From_Index.The_Item;
! 121: To_Index := l2;
! 122: From_Index := From_Index.Next;
! 123: while From_Index /= null loop
! 124: To_Index.Next := New_Item;
! 125: To_Index := To_Index.Next;
! 126: To_Index.The_Item := From_Index.The_Item;
! 127: From_Index := From_Index.Next;
! 128: end loop;
! 129: end if;
! 130: exception
! 131: when Storage_Error => raise Overflow;
! 132: end Copy;
! 133:
! 134: -- SELECTORS :
! 135:
! 136: function Is_Equal ( l1,l2 : List ) return boolean is
! 137:
! 138: left_index : List := l1;
! 139: right_index : List := l2;
! 140:
! 141: begin
! 142: while left_index /= null loop
! 143: if left_index.The_Item /= right_index.The_Item
! 144: then return False;
! 145: end if;
! 146: left_index := left_index.Next;
! 147: right_index := right_index.Next;
! 148: end loop;
! 149: return (right_index = null);
! 150: exception
! 151: when Constraint_Error => return false;
! 152: end Is_Equal;
! 153:
! 154: function Length_Of ( l : List ) return natural is
! 155:
! 156: cnt : natural := 0;
! 157: tmp : List := l;
! 158:
! 159: begin
! 160: while not Is_Null(tmp) loop
! 161: cnt := cnt + 1;
! 162: tmp := Tail_Of(tmp);
! 163: end loop;
! 164: return cnt;
! 165: end Length_Of;
! 166:
! 167: function Is_Null ( l : list ) return boolean is
! 168: begin
! 169: return (l = null);
! 170: end Is_Null;
! 171:
! 172: function Head_Of ( l : List ) return Item is
! 173: begin
! 174: return l.The_Item;
! 175: exception
! 176: when Constraint_Error => raise List_Is_Null;
! 177: end Head_Of;
! 178:
! 179: function Tail_Of ( l : List ) return List is
! 180: begin
! 181: return l.Next;
! 182: exception
! 183: when Constraint_Error => raise List_Is_Null;
! 184: end Tail_Of;
! 185:
! 186: -- DESTRUCTOR :
! 187:
! 188: procedure Clear ( l : in out List ) is
! 189: begin
! 190: Free(l);
! 191: end Clear;
! 192:
! 193: end Generic_Lists;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>