1{ 2 This file is part of the Free Pascal Run Time Library (rtl) 3 Copyright (c) 1999-2005 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13 14{$if defined(VER2_0) or not defined(FPC_TESTGENERICS)} 15 16{****************************************************************************} 17{* TFPListEnumerator *} 18{****************************************************************************} 19 20constructor TFPListEnumerator.Create(AList: TFPList); 21begin 22 inherited Create; 23 FList := AList; 24 FPosition := -1; 25end; 26 27function TFPListEnumerator.GetCurrent: Pointer; 28begin 29 Result := FList[FPosition]; 30end; 31 32function TFPListEnumerator.MoveNext: Boolean; 33begin 34 Inc(FPosition); 35 Result := FPosition < FList.Count; 36end; 37 38{****************************************************************************} 39{* TFPList *} 40{****************************************************************************} 41 42Const 43 // Ratio of Pointer and Word Size. 44 WordRatio = SizeOf(Pointer) Div SizeOf(Word); 45 46procedure TFPList.RaiseIndexError(Index : Integer); 47begin 48 // We should be able to remove this, but unfortunately it is marked protected. 49 Error(SListIndexError, Index); 50end; 51 52Procedure TFPList.CheckIndex(AIndex : Integer); 53 54begin 55 If (AIndex < 0) or (AIndex >= FCount) then 56 Error(SListIndexError, AIndex); // Don't use RaiseIndexError, exception address will be better if we use error. 57end; 58 59function TFPList.Get(Index: Integer): Pointer; 60begin 61 CheckIndex(Index); 62 Result:=FList^[Index]; 63end; 64 65procedure TFPList.Put(Index: Integer; Item: Pointer); 66begin 67 CheckIndex(Index); 68 Flist^[Index] := Item; 69end; 70 71function TFPList.Extract(Item: Pointer): Pointer; 72var 73 i : Integer; 74begin 75 i := IndexOf(item); 76 if i >= 0 then 77 begin 78 Result := item; 79 Delete(i); 80 end 81 else 82 result := nil; 83end; 84 85procedure TFPList.SetCapacity(NewCapacity: Integer); 86begin 87 If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then 88 Error (SListCapacityError, NewCapacity); 89 if NewCapacity = FCapacity then 90 exit; 91 ReallocMem(FList, SizeOf(Pointer)*NewCapacity); 92 FCapacity := NewCapacity; 93end; 94 95procedure TFPList.SetCount(NewCount: Integer); 96begin 97 if (NewCount < 0) or (NewCount > MaxListSize)then 98 Error(SListCountError, NewCount); 99 If NewCount > FCount then 100 begin 101 If NewCount > FCapacity then 102 SetCapacity(NewCount); 103 If FCount < NewCount then 104 FillWord(Flist^[FCount], (NewCount-FCount) * WordRatio, 0); 105 end; 106 FCount := Newcount; 107end; 108 109destructor TFPList.Destroy; 110begin 111 Self.Clear; 112 inherited Destroy; 113end; 114 115Procedure TFPList.AddList(AList : TFPList); 116 117Var 118 I : Integer; 119 120begin 121 If (Capacity<Count+AList.Count) then 122 Capacity:=Count+AList.Count; 123 For I:=0 to AList.Count-1 do 124 Add(AList[i]); 125end; 126 127 128function TFPList.Add(Item: Pointer): Integer; 129begin 130 if FCount = FCapacity then 131 Self.Expand; 132 FList^[FCount] := Item; 133 Result := FCount; 134 FCount := FCount + 1; 135end; 136 137procedure TFPList.Clear; 138begin 139 if Assigned(FList) then 140 begin 141 SetCount(0); 142 SetCapacity(0); 143 FList := nil; 144 end; 145end; 146 147procedure TFPList.Delete(Index: Integer); 148begin 149 CheckIndex(Index); 150 FCount := FCount-1; 151 System.Move (FList^[Index+1], FList^[Index], (FCount - Index) * SizeOf(Pointer)); 152 // Shrink the list if appropriate: 153 // If capacity>256 and the list is less than a quarter filled, shrink to 1/2 the size. 154 // Shr is used because it is faster than div. 155 if (FCapacity > 256) and (FCount < FCapacity shr 2) then 156 begin 157 FCapacity := FCapacity shr 1; 158 ReallocMem(FList, SizeOf(Pointer) * FCapacity); 159 end; 160end; 161 162class procedure TFPList.Error(const Msg: string; Data: PtrInt); 163begin 164 Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame); 165end; 166 167procedure TFPList.Exchange(Index1, Index2: Integer); 168var 169 Temp : Pointer; 170begin 171 CheckIndex(Index1); 172 CheckIndex(Index2); 173 Temp := FList^[Index1]; 174 FList^[Index1] := FList^[Index2]; 175 FList^[Index2] := Temp; 176end; 177 178function TFPList.Expand: TFPList; 179var 180 IncSize : Longint; 181begin 182 if FCount < FCapacity then exit(self); 183 { 184 For really big lists, (128Mb elements), increase with fixed amount: 16Mb elements (=1/8th of 128Mb). 185 For big lists (8mb elements), increase with 1/8th of the size 186 For moderate lists (128 or more, increase with 1/4th the size 187 For smaller sizes, increase with 16 or 4 188 } 189 if FCapacity > 128*1024*1024 then IncSize := 16*1024*1024 190 else if FCapacity > 8*1024*1024 then IncSize := FCapacity shr 3 191 else if FCapacity > 128 then IncSize := FCapacity shr 2 192 else if FCapacity > 8 then IncSize := 16 193 else IncSize := 4; 194 SetCapacity(FCapacity + IncSize); 195 Result := Self; 196end; 197 198function TFPList.First: Pointer; 199begin 200 If FCount = 0 then 201 Result := Nil 202 else 203 Result := Items[0]; 204end; 205 206function TFPList.GetEnumerator: TFPListEnumerator; 207begin 208 Result := TFPListEnumerator.Create(Self); 209end; 210 211function TFPList.IndexOf(Item: Pointer): Integer; 212 213Var 214 C : Integer; 215 216begin 217 Result:=0; 218 C:=Count; 219 while (Result<C) and (Flist^[Result]<>Item) do 220 Inc(Result); 221 If Result>=C then 222 Result:=-1; 223end; 224 225function TFPList.IndexOfItem(Item: Pointer; Direction: TDirection): Integer; 226 227begin 228 if Direction=fromBeginning then 229 Result:=IndexOf(Item) 230 else 231 begin 232 Result:=Count-1; 233 while (Result >=0) and (Flist^[Result]<>Item) do 234 Result:=Result - 1; 235 end; 236end; 237 238procedure TFPList.Insert(Index: Integer; Item: Pointer); 239begin 240 if (Index < 0) or (Index > FCount )then 241 Error(SlistIndexError, Index); 242 iF FCount = FCapacity then Self.Expand; 243 if Index<FCount then 244 System.Move(Flist^[Index], Flist^[Index+1], (FCount - Index) * SizeOf(Pointer)); 245 FList^[Index] := Item; 246 FCount := FCount + 1; 247end; 248 249function TFPList.Last: Pointer; 250begin 251{ Wouldn't it be better to return nil if the count is zero ?} 252 If FCount = 0 then 253 Result := nil 254 else 255 Result := Items[FCount - 1]; 256end; 257 258procedure TFPList.Move(CurIndex, NewIndex: Integer); 259var 260 Temp : Pointer; 261begin 262 CheckIndex(CurIndex); 263 CheckIndex(NewIndex); 264 Temp := FList^[CurIndex]; 265 if NewIndex > CurIndex then 266 System.Move(FList^[CurIndex+1], FList^[CurIndex], (NewIndex - CurIndex) * SizeOf(Pointer)) 267 else 268 System.Move(FList^[NewIndex], FList^[NewIndex+1], (CurIndex - NewIndex) * SizeOf(Pointer)); 269 FList^[NewIndex] := Temp; 270end; 271 272function TFPList.Remove(Item: Pointer): Integer; 273begin 274 Result := IndexOf(Item); 275 If Result <> -1 then 276 Self.Delete(Result); 277end; 278 279procedure TFPList.Pack; 280var 281 NewCount, 282 i : integer; 283 pdest, 284 psrc : PPointer; 285begin 286 NewCount:=0; 287 psrc:=@FList^[0]; 288 pdest:=psrc; 289 For I:=0 To FCount-1 Do 290 begin 291 if assigned(psrc^) then 292 begin 293 pdest^:=psrc^; 294 inc(pdest); 295 inc(NewCount); 296 end; 297 inc(psrc); 298 end; 299 FCount:=NewCount; 300end; 301 302// Needed by Sort method. 303 304Procedure QuickSort(FList: PPointerList; L, R : Longint; 305 Compare: TListSortCompare); 306var 307 I, J : Longint; 308 P, Q : Pointer; 309begin 310 repeat 311 I := L; 312 J := R; 313 P := FList^[ (L + R) div 2 ]; 314 repeat 315 while Compare(P, FList^[i]) > 0 do 316 I := I + 1; 317 while Compare(P, FList^[J]) < 0 do 318 J := J - 1; 319 If I <= J then 320 begin 321 Q := FList^[I]; 322 Flist^[I] := FList^[J]; 323 FList^[J] := Q; 324 I := I + 1; 325 J := J - 1; 326 end; 327 until I > J; 328 // sort the smaller range recursively 329 // sort the bigger range via the loop 330 // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion 331 if J - L < R - I then 332 begin 333 if L < J then 334 QuickSort(FList, L, J, Compare); 335 L := I; 336 end 337 else 338 begin 339 if I < R then 340 QuickSort(FList, I, R, Compare); 341 R := J; 342 end; 343 until L >= R; 344end; 345 346procedure TFPList.Sort(Compare: TListSortCompare); 347begin 348 if Not Assigned(FList) or (FCount < 2) then exit; 349 QuickSort(Flist, 0, FCount-1, Compare); 350end; 351 352 353procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer); 354var 355 i : integer; 356 p : pointer; 357begin 358 For I:=0 To Count-1 Do 359 begin 360 p:=FList^[i]; 361 if assigned(p) then 362 proc2call(p,arg); 363 end; 364end; 365 366 367procedure TFPList.ForEachCall(proc2call:TListStaticCallback;arg:pointer); 368var 369 i : integer; 370 p : pointer; 371begin 372 For I:=0 To Count-1 Do 373 begin 374 p:=FList^[i]; 375 if assigned(p) then 376 proc2call(p,arg); 377 end; 378end; 379 380procedure TFPList.CopyMove (aList : TFPList); 381var r : integer; 382begin 383 Clear; 384 for r := 0 to aList.count-1 do 385 Add (aList[r]); 386end; 387 388procedure TFPList.MergeMove (aList : TFPList); 389var r : integer; 390begin 391 For r := 0 to aList.count-1 do 392 if self.indexof(aList[r]) < 0 then 393 self.Add (aList[r]); 394end; 395 396procedure TFPList.DoCopy(ListA, ListB : TFPList); 397begin 398 if assigned (ListB) then 399 CopyMove (ListB) 400 else 401 CopyMove (ListA); 402end; 403 404procedure TFPList.DoDestUnique(ListA, ListB : TFPList); 405 procedure MoveElements (src, dest : TFPList); 406 var r : integer; 407 begin 408 self.clear; 409 for r := 0 to src.count-1 do 410 if dest.indexof(src[r]) < 0 then 411 self.Add (src[r]); 412 end; 413 414var dest : TFPList; 415begin 416 if assigned (ListB) then 417 MoveElements (ListB, ListA) 418 else 419 try 420 dest := TFPList.Create; 421 dest.CopyMove (self); 422 MoveElements (ListA, dest) 423 finally 424 dest.Free; 425 end; 426end; 427 428procedure TFPList.DoAnd(ListA, ListB : TFPList); 429var r : integer; 430begin 431 if assigned (ListB) then 432 begin 433 self.clear; 434 for r := 0 to ListA.count-1 do 435 if ListB.indexOf (ListA[r]) >= 0 then 436 self.Add (ListA[r]); 437 end 438 else 439 begin 440 for r := self.Count-1 downto 0 do 441 if ListA.indexof (Self[r]) < 0 then 442 self.delete (r); 443 end; 444end; 445 446procedure TFPList.DoSrcUnique(ListA, ListB : TFPList); 447var r : integer; 448begin 449 if assigned (ListB) then 450 begin 451 self.Clear; 452 for r := 0 to ListA.Count-1 do 453 if ListB.indexof (ListA[r]) < 0 then 454 self.Add (ListA[r]); 455 end 456 else 457 begin 458 for r := self.count-1 downto 0 do 459 if ListA.indexof (self[r]) >= 0 then 460 self.delete (r); 461 end; 462end; 463 464procedure TFPList.DoOr(ListA, ListB : TFPList); 465begin 466 if assigned (ListB) then 467 begin 468 CopyMove (ListA); 469 MergeMove (ListB); 470 end 471 else 472 MergeMove (ListA); 473end; 474 475procedure TFPList.DoXOr(ListA, ListB : TFPList); 476var r : integer; 477 l : TFPList; 478begin 479 if assigned (ListB) then 480 begin 481 self.Clear; 482 for r := 0 to ListA.count-1 do 483 if ListB.indexof (ListA[r]) < 0 then 484 self.Add (ListA[r]); 485 for r := 0 to ListB.count-1 do 486 if ListA.indexof (ListB[r]) < 0 then 487 self.Add (ListB[r]); 488 end 489 else 490 try 491 l := TFPList.Create; 492 l.CopyMove (Self); 493 for r := self.count-1 downto 0 do 494 if listA.indexof (self[r]) >= 0 then 495 self.delete (r); 496 for r := 0 to ListA.count-1 do 497 if l.indexof (ListA[r]) < 0 then 498 self.add (ListA[r]); 499 finally 500 l.Free; 501 end; 502end; 503 504 505procedure TFPList.Assign (ListA: TFPList; AOperator: TListAssignOp=laCopy; ListB: TFPList=nil); 506begin 507 case AOperator of 508 laCopy : DoCopy (ListA, ListB); // replace dest with src 509 laSrcUnique : DoSrcUnique (ListA, ListB); // replace dest with src that are not in dest 510 laAnd : DoAnd (ListA, ListB); // remove from dest that are not in src 511 laDestUnique : DoDestUnique (ListA, ListB); // remove from dest that are in src 512 laOr : DoOr (ListA, ListB); // add to dest from src and not in dest 513 laXOr : DoXOr (ListA, ListB); // add to dest from src and not in dest, remove from dest that are in src 514 end; 515end; 516 517{$else} 518 519{ generics based implementation of TFPList follows } 520 521procedure TFPList.Assign(Source: TFPList); 522begin 523 inherited Assign(Source); 524end; 525 526type 527 TFPPtrListSortCompare = function(const Item1, Item2: Pointer): Integer; 528 529procedure TFPList.Sort(Compare: TListSortCompare); 530begin 531 inherited Sort(TFPPtrListSortCompare(Compare)); 532end; 533 534procedure TFPList.ForEachCall(Proc2call: TListCallback; Arg: Pointer); 535var 536 I: integer; 537begin 538 for I:=0 to Count-1 do 539 proc2call(InternalItems[I],arg); 540end; 541 542 543procedure TFPList.ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer); 544var 545 I: integer; 546begin 547 for I:=0 to Count-1 do 548 Proc2call(InternalItems[I], Arg); 549end; 550 551{$endif} 552 553{****************************************************************************} 554{* TListEnumerator *} 555{****************************************************************************} 556 557constructor TListEnumerator.Create(AList: TList); 558begin 559 inherited Create; 560 FList := AList; 561 FPosition := -1; 562end; 563 564function TListEnumerator.GetCurrent: Pointer; 565begin 566 Result := FList[FPosition]; 567end; 568 569function TListEnumerator.MoveNext: Boolean; 570begin 571 Inc(FPosition); 572 Result := FPosition < FList.Count; 573end; 574 575{****************************************************************************} 576{* TList *} 577{****************************************************************************} 578 579{ TList = class(TObject) 580 private 581 FList: TFPList; 582} 583 584function TList.Get(Index: Integer): Pointer; 585begin 586 Result := FList.Get(Index); 587end; 588 589procedure TList.Grow; 590begin 591 // Only for compatibility with Delphi. Not needed. 592end; 593 594procedure TList.Put(Index: Integer; Item: Pointer); 595var p : pointer; 596begin 597 p := get(Index); 598 FList.Put(Index, Item); 599 if assigned (p) then 600 Notify (p, lnDeleted); 601 if assigned (Item) then 602 Notify (Item, lnAdded); 603end; 604 605function TList.Extract(item: Pointer): Pointer; 606var c : integer; 607begin 608 c := FList.Count; 609 Result := FList.Extract(item); 610 if c <> FList.Count then 611 Notify (Result, lnExtracted); 612end; 613 614procedure TList.Notify(Ptr: Pointer; Action: TListNotification); 615begin 616 if Assigned(FObservers) then 617 Case ACtion of 618 lnAdded : FPONotifyObservers(Self,ooAddItem,Ptr); 619 lnExtracted : FPONotifyObservers(Self,ooDeleteItem,Ptr); 620 lnDeleted : FPONotifyObservers(Self,ooDeleteItem,Ptr); 621 end; 622end; 623 624function TList.GetCapacity: integer; 625begin 626 Result := FList.Capacity; 627end; 628 629procedure TList.SetCapacity(NewCapacity: Integer); 630begin 631 FList.SetCapacity(NewCapacity); 632end; 633 634function TList.GetCount: Integer; 635begin 636 Result := FList.Count; 637end; 638 639procedure TList.SetCount(NewCount: Integer); 640begin 641 if NewCount < FList.Count then 642 while FList.Count > NewCount do 643 Delete(FList.Count - 1) 644 else 645 FList.SetCount(NewCount); 646end; 647 648constructor TList.Create; 649begin 650 inherited Create; 651 FList := TFPList.Create; 652end; 653 654destructor TList.Destroy; 655begin 656 if Assigned(Flist) then 657 Clear; 658 If Assigned(FObservers) then 659 begin 660 FPONotifyObservers(Self,ooFree,Nil); 661 FreeAndNil(FObservers); 662 end; 663 FreeAndNil(FList); 664 inherited Destroy; 665end; 666 667procedure TList.FPOAttachObserver(AObserver: TObject); 668 669Var 670 I : IFPObserver; 671 672begin 673 If Not AObserver.GetInterface(SGUIDObserver,I) then 674 Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]); 675 If not Assigned(FObservers) then 676 FObservers:=TFPList.Create; 677 FObservers.Add(I); 678end; 679 680procedure TList.FPODetachObserver(AObserver: TObject); 681Var 682 I : IFPObserver; 683 684begin 685 If Not AObserver.GetInterface(SGUIDObserver,I) then 686 Raise EObserver.CreateFmt(SErrNotObserver,[AObserver.ClassName]); 687 If Assigned(FObservers) then 688 begin 689 FObservers.Remove(I); 690 If (FObservers.Count=0) then 691 FreeAndNil(FObservers); 692 end; 693end; 694 695procedure TList.FPONotifyObservers(ASender: TObject; 696 AOperation: TFPObservedOperation; Data : Pointer); 697 698Var 699 I : Integer; 700 Obs : IFPObserver; 701 702begin 703 If Assigned(FObservers) then 704 For I:=FObservers.Count-1 downto 0 do 705 begin 706 Obs:=IFPObserver(FObservers[i]); 707 Obs.FPOObservedChanged(ASender,AOperation,Data); 708 end; 709end; 710 711function TList.Add(Item: Pointer): Integer; 712begin 713 Result := FList.Add(Item); 714 if Item <> nil then 715 Notify(Item, lnAdded); 716end; 717 718Procedure TList.AddList(AList : TList); 719var 720 I: Integer; 721begin 722 { this only does FList.AddList(AList.FList), avoiding notifications } 723 FList.AddList(AList.FList); 724 725 { make lnAdded notifications } 726 for I := 0 to AList.Count - 1 do 727 if AList[I] <> nil then 728 Notify(AList[I], lnAdded); 729end; 730 731procedure TList.Clear; 732 733begin 734 While (FList.Count>0) do 735 Delete(Count-1); 736end; 737 738procedure TList.Delete(Index: Integer); 739 740var P : pointer; 741 742begin 743 P:=FList.Get(Index); 744 FList.Delete(Index); 745 if assigned(p) then 746 Notify(p, lnDeleted); 747end; 748 749class procedure TList.Error(const Msg: string; Data: PtrInt); 750begin 751 Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame); 752end; 753 754procedure TList.Exchange(Index1, Index2: Integer); 755begin 756 FList.Exchange(Index1, Index2); 757 FPONotifyObservers(Self,ooChange,Nil); 758end; 759 760function TList.Expand: TList; 761begin 762 FList.Expand; 763 Result:=Self; 764end; 765 766function TList.First: Pointer; 767begin 768 Result := FList.First; 769end; 770 771function TList.GetEnumerator: TListEnumerator; 772begin 773 Result := TListEnumerator.Create(Self); 774end; 775 776function TList.IndexOf(Item: Pointer): Integer; 777begin 778 Result := FList.IndexOf(Item); 779end; 780 781procedure TList.Insert(Index: Integer; Item: Pointer); 782begin 783 FList.Insert(Index, Item); 784 if Item <> nil then 785 Notify(Item,lnAdded); 786end; 787 788function TList.Last: Pointer; 789begin 790 Result := FList.Last; 791end; 792 793procedure TList.Move(CurIndex, NewIndex: Integer); 794begin 795 FList.Move(CurIndex, NewIndex); 796end; 797 798function TList.Remove(Item: Pointer): Integer; 799begin 800 Result := IndexOf(Item); 801 if Result <> -1 then 802 Self.Delete(Result); 803end; 804 805procedure TList.Pack; 806begin 807 FList.Pack; 808end; 809 810procedure TList.Sort(Compare: TListSortCompare); 811begin 812 FList.Sort(Compare); 813end; 814 815procedure TList.CopyMove (aList : TList); 816var r : integer; 817begin 818 Clear; 819 for r := 0 to aList.count-1 do 820 Add (aList[r]); 821end; 822 823procedure TList.MergeMove (aList : TList); 824var r : integer; 825begin 826 For r := 0 to aList.count-1 do 827 if self.indexof(aList[r]) < 0 then 828 self.Add (aList[r]); 829end; 830 831procedure TList.DoCopy(ListA, ListB : TList); 832begin 833 if assigned (ListB) then 834 CopyMove (ListB) 835 else 836 CopyMove (ListA); 837end; 838 839procedure TList.DoDestUnique(ListA, ListB : TList); 840 procedure MoveElements (src, dest : TList); 841 var r : integer; 842 begin 843 self.clear; 844 for r := 0 to src.count-1 do 845 if dest.indexof(src[r]) < 0 then 846 self.Add (src[r]); 847 end; 848 849var dest : TList; 850begin 851 if assigned (ListB) then 852 MoveElements (ListB, ListA) 853 else 854 try 855 dest := TList.Create; 856 dest.CopyMove (self); 857 MoveElements (ListA, dest) 858 finally 859 dest.Free; 860 end; 861end; 862 863procedure TList.DoAnd(ListA, ListB : TList); 864var r : integer; 865begin 866 if assigned (ListB) then 867 begin 868 self.clear; 869 for r := 0 to ListA.count-1 do 870 if ListB.indexOf (ListA[r]) >= 0 then 871 self.Add (ListA[r]); 872 end 873 else 874 begin 875 for r := self.Count-1 downto 0 do 876 if ListA.indexof (Self[r]) < 0 then 877 self.delete (r); 878 end; 879end; 880 881procedure TList.DoSrcUnique(ListA, ListB : TList); 882var r : integer; 883begin 884 if assigned (ListB) then 885 begin 886 self.Clear; 887 for r := 0 to ListA.Count-1 do 888 if ListB.indexof (ListA[r]) < 0 then 889 self.Add (ListA[r]); 890 end 891 else 892 begin 893 for r := self.count-1 downto 0 do 894 if ListA.indexof (self[r]) >= 0 then 895 self.delete (r); 896 end; 897end; 898 899procedure TList.DoOr(ListA, ListB : TList); 900begin 901 if assigned (ListB) then 902 begin 903 CopyMove (ListA); 904 MergeMove (ListB); 905 end 906 else 907 MergeMove (ListA); 908end; 909 910procedure TList.DoXOr(ListA, ListB : TList); 911var r : integer; 912 l : TList; 913begin 914 if assigned (ListB) then 915 begin 916 self.Clear; 917 for r := 0 to ListA.count-1 do 918 if ListB.indexof (ListA[r]) < 0 then 919 self.Add (ListA[r]); 920 for r := 0 to ListB.count-1 do 921 if ListA.indexof (ListB[r]) < 0 then 922 self.Add (ListB[r]); 923 end 924 else 925 try 926 l := TList.Create; 927 l.CopyMove (Self); 928 for r := self.count-1 downto 0 do 929 if listA.indexof (self[r]) >= 0 then 930 self.delete (r); 931 for r := 0 to ListA.count-1 do 932 if l.indexof (ListA[r]) < 0 then 933 self.add (ListA[r]); 934 finally 935 l.Free; 936 end; 937end; 938 939 940procedure TList.Assign (ListA: TList; AOperator: TListAssignOp=laCopy; ListB: TList=nil); 941begin 942 case AOperator of 943 laCopy : DoCopy (ListA, ListB); // replace dest with src 944 laSrcUnique : DoSrcUnique (ListA, ListB); // replace dest with src that are not in dest 945 laAnd : DoAnd (ListA, ListB); // remove from dest that are not in src 946 laDestUnique : DoDestUnique (ListA, ListB); // remove from dest that are in src 947 laOr : DoOr (ListA, ListB); // add to dest from src and not in dest 948 laXOr : DoXOr (ListA, ListB); // add to dest from src and not in dest, remove from dest that are in src 949 end; 950end; 951 952 953function TList.GetList: PPointerList; 954begin 955 Result := PPointerList(FList.List); 956end; 957 958 959{****************************************************************************} 960{* TThreadList *} 961{****************************************************************************} 962 963 964constructor TThreadList.Create; 965 begin 966 inherited Create; 967 FDuplicates:=dupIgnore; 968{$ifdef FPC_HAS_FEATURE_THREADING} 969 InitCriticalSection(FLock); 970{$endif} 971 FList:=TList.Create; 972 end; 973 974 975destructor TThreadList.Destroy; 976 begin 977 LockList; 978 try 979 FList.Free; 980 inherited Destroy; 981 finally 982 UnlockList; 983{$ifdef FPC_HAS_FEATURE_THREADING} 984 DoneCriticalSection(FLock); 985{$endif} 986 end; 987 end; 988 989 990procedure TThreadList.Add(Item: Pointer); 991 begin 992 LockList; 993 try 994 if (Duplicates=dupAccept) or 995 // make sure it's not already in the list 996 (FList.IndexOf(Item)=-1) then 997 FList.Add(Item) 998 else if (Duplicates=dupError) then 999 FList.Error(SDuplicateItem,PtrUInt(Item)); 1000 finally 1001 UnlockList; 1002 end; 1003 end; 1004 1005 1006procedure TThreadList.Clear; 1007 begin 1008 Locklist; 1009 try 1010 FList.Clear; 1011 finally 1012 UnLockList; 1013 end; 1014 end; 1015 1016 1017function TThreadList.LockList: TList; 1018 begin 1019 Result:=FList; 1020{$ifdef FPC_HAS_FEATURE_THREADING} 1021 System.EnterCriticalSection(FLock); 1022{$endif} 1023 end; 1024 1025 1026procedure TThreadList.Remove(Item: Pointer); 1027 begin 1028 LockList; 1029 try 1030 FList.Remove(Item); 1031 finally 1032 UnlockList; 1033 end; 1034 end; 1035 1036 1037procedure TThreadList.UnlockList; 1038 begin 1039{$ifdef FPC_HAS_FEATURE_THREADING} 1040 System.LeaveCriticalSection(FLock); 1041{$endif} 1042 end; 1043