* add TList to cclasses, remove classes dependency from t_win32

compiler/cclasses.pas

@@ -47,6 +47,57 @@ interface
           procedure stop;
        end;
 
+{*******************************************************
+   TList (Copied from FCL, exception handling stripped)
+********************************************************}
+
+const
+   MaxListSize = Maxint div 16;
+   SListIndexError = 'List index exceeds bounds (%d)';
+   SListCapacityError = 'The maximum list capacity is reached (%d)';
+   SListCountError = 'List count too large (%d)';
+type
+{ TList class }
+
+   PPointerList = ^TPointerList;
+   TPointerList = array[0..MaxListSize - 1] of Pointer;
+   TListSortCompare = function (Item1, Item2: Pointer): Integer;
+
+   TList = class(TObject)
+   private
+     FList: PPointerList;
+     FCount: Integer;
+     FCapacity: Integer;
+   protected
+     function Get(Index: Integer): Pointer;
+     procedure Grow; virtual;
+     procedure Put(Index: Integer; Item: Pointer);
+     procedure SetCapacity(NewCapacity: Integer);
+     procedure SetCount(NewCount: Integer);
+   public
+     destructor Destroy; override;
+     function Add(Item: Pointer): Integer;
+     procedure Clear; dynamic;
+     procedure Delete(Index: Integer);
+     class procedure Error(const Msg: string; Data: Integer); virtual;
+     procedure Exchange(Index1, Index2: Integer);
+     function Expand: TList;
+     function Extract(item: Pointer): Pointer;
+     function First: Pointer;
+     procedure Assign(Obj:TList);
+     function IndexOf(Item: Pointer): Integer;
+     procedure Insert(Index: Integer; Item: Pointer);
+     function Last: Pointer;
+     procedure Move(CurIndex, NewIndex: Integer);
+     function Remove(Item: Pointer): Integer;
+     procedure Pack;
+     procedure Sort(Compare: TListSortCompare);
+     property Capacity: Integer read FCapacity write SetCapacity;
+     property Count: Integer read FCount write SetCount;
+     property Items[Index: Integer]: Pointer read Get write Put; default;
+     property List: PPointerList read FList;
+   end;
+
 {********************************************
                 TLinkedList
 ********************************************}
@@ -353,59 +404,343 @@ implementation
 
 
 {*****************************************************************************
-                                 Stack
+                                 TList
 *****************************************************************************}
 
-{$ifdef fixLeaksOnError}
-constructor TStack.init;
+Const
+   // Ratio of Pointer and Word Size.
+   WordRatio = SizeOf(Pointer) Div SizeOf(Word);
+
+function TList.Get(Index: Integer): Pointer;
+
 begin
-  head := nil;
+   If (Index<0) or (Index>=FCount) then
+     Error(SListIndexError,Index);
+   Result:=FList^[Index];
 end;
 
-procedure TStack.push(p: pointer);
-var s: PStackItem;
+
+
+procedure TList.Grow;
+
 begin
-  New(s);
-  s^.data := p;
-  s^.Next := head;
-  head := s;
+   // Only for compatibility with Delphi. Not needed.
 end;
 
-function TStack.pop: pointer;
-var s: PStackItem;
+
+
+procedure TList.Put(Index: Integer; Item: Pointer);
+
 begin
-  pop := top;
-  if assigned(head) then
+   if (Index<0) or (Index>=FCount) then
+     Error(SListIndexError,Index);
+   Flist^[Index]:=Item;
+end;
+
+
+function TList.Extract(item: Pointer): Pointer;
+var
+   i : Integer;
+begin
+   result:=nil;
+   i:=IndexOf(item);
+   if i>=0 then
     begin
-      s := head^.Next;
-      dispose(head);
-      head := s;
-    end
+      Result:=item;
+      FList^[i]:=nil;
+      Delete(i);
+    end;
+end;
+
+
+procedure TList.SetCapacity(NewCapacity: Integer);
+
+Var NewList,ToFree : PPointerList;
+
+begin
+   If (NewCapacity<0) or (NewCapacity>MaxListSize) then
+      Error (SListCapacityError,NewCapacity);
+   if NewCapacity=FCapacity then
+     exit;
+   ReallocMem(FList,SizeOf(Pointer)*NewCapacity);
+   FCapacity:=NewCapacity;
 end;
 
-function TStack.top: pointer;
+
+
+procedure TList.SetCount(NewCount: Integer);
+
 begin
-  if not isEmpty then
-    top := head^.data
-  else top := NIL;
+   If (NewCount<0) or (NewCount>MaxListSize)then
+     Error(SListCountError,NewCount);
+   If NewCount<FCount then
+     FCount:=NewCount
+   else If NewCount>FCount then
+     begin
+     If NewCount>FCapacity then
+       SetCapacity (NewCount);
+     If FCount<NewCount then
+       FillWord (Flist^[FCount],(NewCount-FCount)* WordRatio ,0);
+     FCount:=Newcount;
+     end;
 end;
 
-function TStack.isEmpty: boolean;
+
+
+destructor TList.Destroy;
+
 begin
-  isEmpty := head = nil;
+   Self.Clear;
+   inherited Destroy;
 end;
 
-destructor TStack.done;
-var temp: PStackItem;
+
+Function TList.Add(Item: Pointer): Integer;
+
 begin
-  while head <> nil do
-    begin
-      temp := head^.Next;
-      dispose(head);
-      head := temp;
-    end;
+   Self.Insert (Count,Item);
+   Result:=Count-1;
+end;
+
+
+
+Procedure TList.Clear;
+
+begin
+   If Assigned(FList) then
+     begin
+     FreeMem (Flist,FCapacity*SizeOf(Pointer));
+     FList:=Nil;
+     FCapacity:=0;
+     FCount:=0;
+     end;
+end;
+
+
+Procedure TList.Delete(Index: Integer);
+
+Var
+   OldPointer :Pointer;
+
+begin
+   If (Index<0) or (Index>=FCount) then
+     Error (SListIndexError,Index);
+   FCount:=FCount-1;
+   OldPointer:=Flist^[Index];
+   System.Move (FList^[Index+1],FList^[Index],(FCount-Index)*SizeOf(Pointer));
+   // Shrink the list if appropiate
+   if (FCapacity > 256) and (FCount < FCapacity shr 2) then
+   begin
+     FCapacity := FCapacity shr 1;
+     ReallocMem(FList, SizeOf(Pointer) * FCapacity);
+   end;
+end;
+
+
+class procedure TList.Error(const Msg: string; Data: Integer);
+  var
+   s:string;
+   p:longint;
+begin
+   p:=pos('%d',Msg);
+   writeln(copy(Msg,1,pred(p)),Data,copy(Msg,p+3,255));
+end;
+
+procedure TList.Exchange(Index1, Index2: Integer);
+
+var Temp : Pointer;
+
+begin
+   If ((Index1>=FCount) or (Index1<0)) then
+     Error(SListIndexError,Index1);
+   If ((Index2>=FCount) or (Index2<0)) then
+     Error(SListIndexError,Index2);
+   Temp:=FList^[Index1];
+   FList^[Index1]:=FList^[Index2];
+   FList^[Index2]:=Temp;
+end;
+
+
+
+function TList.Expand: TList;
+
+Var IncSize : Longint;
+
+begin
+   if FCount<FCapacity then exit;
+   IncSize:=4;
+   if FCapacity>3 then IncSize:=IncSize+4;
+   if FCapacity>8 then IncSize:=IncSize+8;
+   if FCapacity>127 then Inc(IncSize, FCapacity shr 2);
+   SetCapacity(FCapacity+IncSize);
+   Result:=Self;
+end;
+
+
+function TList.First: Pointer;
+
+begin
+   If FCount=0 then
+     Result:=Nil
+   else
+     Result:=Items[0];
+end;
+
+
+
+function TList.IndexOf(Item: Pointer): Integer;
+
+begin
+   Result:=0;
+   While (Result<FCount) and (Flist^[Result]<>Item) do Result:=Result+1;
+   If Result=FCount  then Result:=-1;
+end;
+
+
+
+procedure TList.Insert(Index: Integer; Item: Pointer);
+
+begin
+   If (Index<0) or (Index>FCount )then
+     Error(SlistIndexError,Index);
+   IF FCount=FCapacity Then Self.Expand;
+   If Index<FCount then
+     System.Move(Flist^[Index],Flist^[Index+1],(FCount-Index)*SizeOf(Pointer));
+   FList^[Index]:=Item;
+   FCount:=FCount+1;
+end;
+
+
+
+function TList.Last: Pointer;
+
+begin
+   // Wouldn't it be better to return nil if the count is zero ?
+   If FCount=0 then
+     Result:=Nil
+   else
+     Result:=Items[FCount-1];
+end;
+
+
+procedure TList.Move(CurIndex, NewIndex: Integer);
+
+Var Temp : Pointer;
+
+begin
+   If ((CurIndex<0) or (CurIndex>Count-1)) then
+     Error(SListIndexError,CurIndex);
+   If (NewINdex<0) then
+     Error(SlistIndexError,NewIndex);
+   Temp:=FList^[CurIndex];
+   FList^[CurIndex]:=Nil;
+   Self.Delete(CurIndex);
+   // ?? If NewIndex>CurIndex then NewIndex:=NewIndex-1;
+   // Newindex changes when deleting ??
+   Self.Insert (NewIndex,Nil);
+   FList^[NewIndex]:=Temp;
+end;
+
+
+function TList.Remove(Item: Pointer): Integer;
+
+begin
+   Result:=IndexOf(Item);
+   If Result<>-1 then
+     Self.Delete (Result);
+end;
+
+
+
+Procedure TList.Pack;
+
+Var  {Last,I,J,}Runner : Longint;
+
+begin
+   // Not the fastest; but surely correct
+   For Runner:=Fcount-1 downto 0 do
+     if Items[Runner]=Nil then Self.Delete(Runner);
+{ The following may be faster in case of large and defragmented lists
+   If count=0 then exit;
+   Runner:=0;I:=0;
+   TheLast:=Count;
+   while runner<count do
+     begin
+     // Find first Nil
+     While (FList^[Runner]<>Nil) and (Runner<Count) do Runner:=Runner+1;
+     if Runner<Count do
+       begin
+       // Start searching for non-nil from last known nil+1
+       if i<Runner then I:=Runner+1;
+       While (Flist[I]^=Nil) and (I<Count) do I:=I+1;
+       // Start looking for last non-nil of block.
+       J:=I+1;
+       While (Flist^[J]<>Nil) and (J<Count) do J:=J+1;
+       // Move block and zero out
+       Move (Flist^[I],Flist^[Runner],J*SizeOf(Pointer));
+       FillWord (Flist^[I],(J-I)*WordRatio,0);
+       // Update Runner and Last to point behind last block
+       TheLast:=Runner+(J-I);
+       If J=Count then
+          begin
+          // Shortcut, when J=Count we checked all pointers
+          Runner:=Count
+       else
+          begin
+          Runner:=TheLast;
+          I:=j;
+       end;
+     end;
+   Count:=TheLast;
+}
+end;
+
+// Needed by Sort method.
+
+Procedure QuickSort (Flist : PPointerList; L,R : Longint;
+                      Compare : TListSortCompare);
+
+Var I,J : Longint;
+     P,Q : Pointer;
+
+begin
+  Repeat
+    I:=L;
+    J:=R;
+    P:=FList^[ (L+R) div 2 ];
+    repeat
+      While Compare(P,FList^[i])>0 Do I:=I+1;
+      While Compare(P,FList^[J])<0 Do J:=J-1;
+      If I<=J then
+        begin
+        Q:=Flist^[I];
+        Flist^[I]:=FList^[J];
+        FList^[J]:=Q;
+        I:=I+1;
+        J:=j-1;
+        end;
+    Until I>J;
+    If L<J then QuickSort (FList,L,J,Compare);
+    L:=I;
+  Until I>=R;
+end;
+
+procedure TList.Sort(Compare: TListSortCompare);
+
+begin
+   If Not Assigned(FList) or (FCount<2) then exit;
+   QuickSort (Flist, 0, FCount-1,Compare);
+end;
+
+procedure TList.Assign(Obj:TList);
+// Principle copied from TCollection
+
+var i : Integer;
+begin
+   Clear;
+   For I:=0 To Obj.Count-1 Do
+     Add(Obj[i]);
 end;
-{$endif fixLeaksOnError}
 
 
 {****************************************************************************
@@ -1956,7 +2291,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.30  2004-01-15 15:16:17  daniel
+  Revision 1.31  2004-04-28 18:02:54  peter
+    * add TList to cclasses, remove classes dependency from t_win32
+
+  Revision 1.30  2004/01/15 15:16:17  daniel
     * Some minor stuff
     * Managed to eliminate speed effects of string compression
 

compiler/systems/t_win32.pas

@@ -40,7 +40,7 @@ interface
 {$ifdef GDB}
        gdb,
 {$endif}
-       import,export,link,cgobj,i_win32,classes;
+       import,export,link,cgobj,i_win32;
 
 
   const
@@ -1656,7 +1656,10 @@ initialization
 end.
 {
   $Log$
-  Revision 1.31  2004-04-24 17:32:05  peter
+  Revision 1.32  2004-04-28 18:02:54  peter
+    * add TList to cclasses, remove classes dependency from t_win32
+
+  Revision 1.31  2004/04/24 17:32:05  peter
   index number generation for mixed index-nonindexed fixed, patch by Pavel V. Ozerski
 
   Revision 1.30  2004/03/18 11:44:07  olle