Return to generic_lists.adb CVS log

Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Polynomials

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;