If you are compiling the unit in Delphi mode, you’ll need to use the syntax of Delphi.
* Generics are defined without the GENERIC keyword.
* Generics are specialized without the SPECIALIZE keyword.
* To define class-local types and variables, visibility specifiers need
to be placed before the TYPE and VAR keywords.
* Implementations of the methods of a generic class must include the
type parameters of the class.
Please check if the attached file works.
On February 14, 2012, David Copeland wrote:
> Under FPC 2.4.2 I have been using RBTree unit that uses generics. With
> 2.6.0 it fails to compile. I know that there have been changes for 2.6.0
> but I have checked the syntax in the 2.6.0 Language Reference and cannot
> see why the error is occurring. I have also looked in Mantis but don't
> know if anything there relates to my problem. I have excerpted the code
> below and attached the complete unit.
>
> ==================
>
> unit FOS_REDBLACKTREE_GEN;
>
> // (c) Copyright FirmOS Business Solutions GmbH
> // Author Helmut Hartl, Franz Schober
>
> }
> //{$MODE OBJFPC}
> {$MODE DELPHI}
> {$H+}
>
> interface
>
> type
> TRB_NodeColor=(R,B);
>
> { TGFOS_RBTree }
> {$B-}
> generic TGFOS_RBTree<_TKey,_TStore> = class(TInterfacedObject)
>
> *** The error occurs at the line above.
>
> Free Pascal Compiler version 2.6.0 [2012/02/08] for x86_64
> Copyright (c) 1993-2011 by Florian Klaempfl and others
> Target OS: Linux for x86-64
> Compiling FOS_REDBLACKTREE_GEN.pas
> FOS_REDBLACKTREE_GEN.pas(48,11) Fatal: Syntax error, "=" expected but
> "identifier TGFOS_RBTREE" found
> Fatal: Compilation aborted
>
>
> type public
> PFOS_RB_NodeG=^TFOS_RB_NodeG;
> _PStore =^_TStore;
> TFOS_RB_NodeG = packed record
> k: _TKey;
> left, right, parent: PFOS_RB_NodeG;
> col: TRB_NodeColor;
> val:_TStore;
> end;
> TCompareKeys = function (const Item1, Item2: _TKey):
> Integer;
> TGUndefined = function :_Tstore;
> TGUndefinedKey = function :_TKey;
> TGFOS_RB_OnItem = procedure (const Item:_TStore) of object;
> TGFOS_RB_OnItemN = procedure (const Item:_TStore);
>
>
> ==================
>
> Thanks for any help.
>
>
>
>
> _______________________________________________
> fpc-pascal maillist - fpc-pascal@lists.freepascal.org
> http://lists.freepascal.org/mailman/listinfo/fpc-pascal
--
Best Regards,
J.-c. Chu
unit FOS_REDBLACKTREE_GEN;
// (c) Copyright FirmOS Business Solutions GmbH
// Author Helmut Hartl, Franz Schober
{ // New Style BSD Licence (OSI)
Copyright (c) 2001-2009, FirmOS Business Solutions GmbH
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
* Neither the name of the <FirmOS Business Solutions GmbH> nor the names
of its contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
}
//{$MODE OBJFPC}
{$MODE DELPHI}
{$H+}
interface
type
TRB_NodeColor=(R,B);
{ TGFOS_RBTree }
{$B-}
TGFOS_RBTree<_TKey,_TStore> = class(TInterfacedObject)
public
type
PFOS_RB_NodeG=^TFOS_RB_NodeG;
_PStore =^_TStore;
TFOS_RB_NodeG = packed record
k: _TKey;
left, right, parent: PFOS_RB_NodeG;
col: TRB_NodeColor;
val:_TStore;
end;
TCompareKeys = function (const Item1, Item2: _TKey): Integer;
TGUndefined = function :_Tstore;
TGUndefinedKey = function :_TKey;
TGFOS_RB_OnItem = procedure (const Item:_TStore) of object;
TGFOS_RB_OnItemN = procedure (const Item:_TStore);
private
var
_Count: QWord;
_Compare: TCompareKeys;
_Undef: TGUndefined;
_UndefKey: TGUndefinedKey;
root: PFOS_RB_NodeG;
leftmost: PFOS_RB_NodeG;
rightmost: PFOS_RB_NodeG;
procedure RotLeft (var x: PFOS_RB_NodeG);
procedure RotRight (var x: PFOS_RB_NodeG);
function Min (var x: PFOS_RB_NodeG): PFOS_RB_NodeG;
function Max (var x: PFOS_RB_NodeG): PFOS_RB_NodeG;
procedure _Delete (z: PFOS_RB_NodeG);
function _Find (key:_TKey):PFOS_RB_NodeG;
function _FindNextPrev (key:_TKey;const next:boolean):PFOS_RB_NodeG;
procedure _fast_erase (x: PFOS_RB_NodeG;const
DoFreeItem:TGFOS_RB_OnItem);
procedure _fast_eraseN (x: PFOS_RB_NodeG;const
DoFreeItem:TGFOS_RB_OnItemN);
protected
procedure RBInc (var x: PFOS_RB_NodeG);
procedure RBDec (var x: PFOS_RB_NodeG);
public
constructor Create (const Compare:TCompareKeys;const
Undef:TGUndefined;const UndefKey:TGUndefinedKey);
destructor Destroy; override;
procedure Clear (const DoFreeItem: TGFOS_RB_OnItem);
procedure ClearN (const DoFreeItem: TGFOS_RB_OnItemN);
function Find (const key:_TKey;out store:_TStore):Boolean;
// Delivers True on Find
function Delete (const key:_TKey;out Store:_TStore):Boolean;
// Deletes the Item from the Directory, returns true on found
function AddCheck (const key:_TKey;var Store:_TStore):Boolean;
// Delivers Old Value on FIND
function Add (const key:_TKey;const Store:_TStore):Boolean;
// Ignores new value if old value exists
function FindNext (var key:_TKey;out Store:_TStore):Boolean;
// Delivers false if no next element
function FindPrev (var key:_TKey;out Store:_TStore):Boolean;
// Delivers true if no prev element
function FirstNode (out key:_TKey;out Store:_TStore):boolean;
function LastNode (out key:_TKey;out Store:_TStore):boolean;
function Count :QWord;
end;
TFOS_RB_Tree_SS = TGFOS_RBTree<string,string>;
TFOS_RB_Tree_II = TGFOS_RBTree<integer,integer>;
//Default Sorting & Value functions
function Default_RB_String_Compare(const S1, S2: string): Integer;
function Default_RB_String_Undef:string;
function Default_RB_Integer_Compare(const d1, d2: integer): Integer;
function Default_RB_Integer_Undef:integer;
implementation
function Default_RB_String_Compare(const S1, S2: string): Integer;
var count1, count2,i: integer;
p1,p2:pointer;
begin
Count1 := Length(S1);Count2 := Length(S2);
if count1=count2 then begin
i := 0;
result := 0;
p1:=pointer(s1);
p2:=pointer(s2);
while (result=0) and (I<count1) do begin
result:=byte(P1^)-byte(P2^);
P1:=pchar(P1)+1;P2:=pchar(P2)+1;
inc(i);
end;
end else
if Count1>Count2 then begin
result:=1;
exit;
end else begin
result:=-1;
exit;
end;
end;
function Default_RB_String_Undef:string;
begin
result:='';
end;
function Default_RB_Integer_Compare(const d1, d2: integer): Integer;
begin
if d1=d2 then begin
result := 0;
end else
if d1>d2 then begin
result:=1;
end else begin
result:=-1;
end;
end;
function Default_RB_Integer_Undef:integer;
begin
result:=0;
end;
constructor TGFOS_RBTree<_TKey, _TStore>.Create(const
Compare:TCompareKeys;const Undef:TGUndefined;const UndefKey:TGUndefinedKey);
begin
inherited Create;
_Count:=0;
_Compare:=Compare;
_Undef:=Undef;
_UndefKey:=UndefKey;
root := nil;
leftmost := nil;
rightmost := nil;
end;
function TGFOS_RBTree<_TKey, _TStore>.Delete(const key: _TKey;out
store:_TStore): Boolean;
var n:PFOS_RB_NodeG;
begin
n:=_Find(key);
if not assigned(n) then begin
store:=_Undef;
result:=false;
end else begin
store:=n.val;
_Delete(n);
dec(_count);
result:=true;
end;
end;
destructor TGFOS_RBTree<_TKey, _TStore>.Destroy;
begin
inherited Destroy;
end;
function TGFOS_RBTree<_TKey, _TStore>.FirstNode(out key: _TKey; out Store:
_TStore): boolean;
begin
if Assigned(leftmost) then begin
result := true;
key := leftmost.k;
Store := leftmost.val;
end else begin
result := false;
key := _UndefKey;
Store := _Undef;
end;
end;
function TGFOS_RBTree<_TKey, _TStore>.LastNode(out key: _TKey; out Store:
_TStore): boolean;
begin
if Assigned(rightmost) then begin
result := true;
key := rightmost.k;
Store := rightmost.val;
end else begin
result := false;
key := _UndefKey;
Store := _Undef;
end;
end;
function TGFOS_RBTree<_TKey, _TStore>.Count: QWord;
begin
result:=_Count;
end;
function TGFOS_RBTree<_TKey, _TStore>.FindNext(var key: _TKey;out
Store:_TStore):Boolean;
var n:PFOS_RB_NodeG;
begin
n:=_FindNextPrev(key,true);
if assigned(n)then begin
result :=true;
Store :=n.val;
key :=n.k;
end else begin
result :=false;
Store :=_Undef;
key :=_UndefKey;
end;
end;
function TGFOS_RBTree<_TKey, _TStore>.FindPrev(var key: _TKey;out
Store:_TStore):Boolean;
var n:PFOS_RB_NodeG;
begin
n:=_FindNextPrev(key,false);
if assigned(n)then begin
result :=true;
Store :=n.val;
key :=n.k;
end else begin
result :=false;
Store :=_Undef;
key :=_UndefKey;
end;
end;
procedure TGFOS_RBTree<_TKey, _TStore>.Clear(const DoFreeItem:TGFOS_RB_OnItem);
begin
if (root <> nil) then _fast_erase(root,DoFreeItem);
root := nil;
leftmost := nil;
rightmost := nil;
_count:=0;
end;
procedure TGFOS_RBTree<_TKey, _TStore>.ClearN(const DoFreeItem:
TGFOS_RB_OnItemN);
begin
if (root <> nil) then _fast_eraseN(root,DoFreeItem);
root := nil;
leftmost := nil;
rightmost := nil;
_count:=0;
end;
function TGFOS_RBTree<_TKey, _TStore>.Find(const key: _TKey;out store:_TStore):
Boolean;
var nd:PFOS_RB_NodeG;
begin
nd:=_Find(key);
if assigned(nd) then begin
store:=nd.val;
result:=true;
end else begin
store:=_Undef;
result:=false;
end;
end;
procedure TGFOS_RBTree<_TKey, _TStore>.RotLeft(var x: PFOS_RB_NodeG);
var
y: PFOS_RB_NodeG;
begin
y := x^.right;
x^.right := y^.left;
if (y^.left <> nil) then begin
y^.left^.parent := x;
end;
y^.parent := x^.parent;
if (x = root) then begin
root := y;
end else if (x = x^.parent^.left) then begin
x^.parent^.left := y;
end else begin
x^.parent^.right := y;
end;
y^.left := x;
x^.parent := y;
end;
procedure TGFOS_RBTree<_TKey, _TStore>.RotRight(var x: PFOS_RB_NodeG);
var
y: PFOS_RB_NodeG;
begin
y := x^.left;
x^.left := y^.right;
if (y^.right <> nil) then begin
y^.right^.parent := x;
end;
y^.parent := x^.parent;
if (x = root) then begin
root := y;
end else if (x = x^.parent^.right) then begin
x^.parent^.right := y;
end else begin
x^.parent^.left := y;
end;
y^.right := x;
x^.parent := y;
end;
function TGFOS_RBTree<_TKey, _TStore>.Min(var x: PFOS_RB_NodeG): PFOS_RB_NodeG;
begin
Result := x;
while (Result^.left <> nil) do Result := Result^.left;
end;
function TGFOS_RBTree<_TKey, _TStore>.Max(var x: PFOS_RB_NodeG): PFOS_RB_NodeG;
begin
Result := x;
while (Result^.right <> nil) do Result := Result^.right;
end;
function TGFOS_RBTree<_TKey, _TStore>.AddCheck(const key: _TKey;var
Store:_TStore):Boolean;
var x, y, z, zpp: PFOS_RB_NodeG;
cmp: Integer;
begin
z := New(PFOS_RB_NodeG);
{ Initialize fields in new node z }
z^.k := key;
z^.left := nil;
z^.right := nil;
z^.col := R;
z^.val:=Store;
{ Maintain leftmost and rightmost nodes }
if (leftmost = nil) then begin
leftmost := z;
end else
if (_Compare(key, leftmost^.k) < 0) then begin
leftmost := z;
end;
if (rightmost = nil) then begin
rightmost := z;
end else
if (_Compare(key, rightmost^.k) > 0) then begin
rightmost := z;
end;
{ Insert node z }
y := nil;
x := root;
while (x <> nil) do begin
y := x;
cmp := _Compare(key, x^.k);
if (cmp < 0) then begin
x := x^.left;
end else if (cmp > 0) then begin
x := x^.right;
end else begin
{ val already exists in tree. }
Dispose(z);
Store:=x.val; // Return old Store
result:=false; //Return old Value
exit;
end;
end;
inc(_Count);
z^.parent := y;
if (y = nil) then begin
root := z;
end else if (_Compare(key, y^.k) < 0) then begin
y^.left := z;
end else begin
y^.right := z;
end;
store:=z.val;
result:=true;
{ Rebalance tree }
repeat
if (z=root) then break;
if not (z^.parent^.col = R) then break;
zpp := z^.parent^.parent;
if (z^.parent = zpp^.left) then begin
y := zpp^.right;
if ((y <> nil) and (y^.col = R)) then begin
z^.parent^.col := B;
y^.col := B;
zpp^.col := R;
z := zpp;
end else begin
if (z = z^.parent^.right) then begin
z := z^.parent;
RotLeft(z);
end;
z^.parent^.col := B;
zpp^.col := R;
RotRight(zpp);
end;
end else begin
y := zpp^.left;
if ((y <> nil) and (y^.col = R)) then begin
z^.parent^.col := B;
y^.col := B;
zpp.col := R;
z := zpp;
end else begin
if (z = z^.parent^.left) then begin
z := z^.parent;
RotRight(z);
end;
z^.parent^.col := B;
zpp.col := R;
RotLeft(zpp);
end;
end;
until false;
root^.col := B;
end;
function TGFOS_RBTree<_TKey, _TStore>.Add(const key: _TKey; const Store:
_TStore): Boolean;
var temp:_TStore;
begin
temp:=Store;
result:=AddCheck(key,temp);
end;
procedure TGFOS_RBTree<_TKey, _TStore>._Delete(z: PFOS_RB_NodeG);
var w, x, y, x_parent: PFOS_RB_NodeG;
tmpcol: TRB_NodeColor;
begin
y := z;
x := nil;
x_parent := nil;
if (y^.left = nil) then begin { z has at most one non-null child. y = z. }
x := y^.right; { x might be null. }
end else begin
if (y^.right = nil) then begin { z has exactly one non-null child. y = z. }
x := y^.left; { x is not null. }
end else begin
{ z has two non-null children. Set y to }
y := y^.right; { z's successor. x might be null. }
while (y^.left <> nil) do begin
y := y^.left;
end;
x := y^.right;
end;
end;
if (y <> z) then begin
{ "copy y's sattelite data into z" }
{ relink y in place of z. y is z's successor }
z^.left^.parent := y;
y^.left := z^.left;
if (y <> z^.right) then begin
x_parent := y^.parent;
if (x <> nil) then begin
x^.parent := y^.parent;
end;
y^.parent^.left := x; { y must be a child of left }
y^.right := z^.right;
z^.right^.parent := y;
end else begin
x_parent := y;
end;
if (root = z) then begin
root := y;
end else if (z^.parent^.left = z) then begin
z^.parent^.left := y;
end else begin
z^.parent^.right := y;
end;
y^.parent := z^.parent;
tmpcol := y^.col;
y^.col := z^.col;
z^.col := tmpcol;
y := z; { y now points to node to be actually deleted }
end else begin { y = z }
x_parent := y^.parent;
if (x <> nil) then begin
x^.parent := y^.parent;
end;
if (root = z) then begin
root := x;
end else begin
if (z^.parent^.left = z) then begin
z^.parent^.left := x;
end else begin
z^.parent^.right := x;
end;
end;
if (leftmost = z) then begin
if (z^.right = nil) then begin { z^.left must be null also }
leftmost := z^.parent;
end else begin
leftmost := Min(x);
end;
end;
if (rightmost = z) then begin
if (z^.left = nil) then begin { z^.right must be null also }
rightmost := z^.parent;
end else begin { x == z^.left }
rightmost := Max(x);
end;
end;
end;
{ Rebalance tree }
if (y^.col = B) then begin
repeat
if (x=root) then break;
if x<>nil then begin
if (x^.col<>B) then break;
end;
if (x = x_parent^.left) then begin
w := x_parent^.right;
if (w^.col = R) then begin
w^.col := B;
x_parent^.col := R;
RotLeft(x_parent);
w := x_parent^.right;
end;
if (((w^.left = nil) or
(w^.left^.col = B)) and
((w^.right = nil) or
(w^.right^.col = B))) then begin
w^.col := R;
x := x_parent;
x_parent := x_parent^.parent;
end else begin
if ((w^.right = nil) or (w^.right^.col = B)) then begin
w^.left^.col := B;
w^.col := R;
RotRight(w);
w := x_parent^.right;
end;
w^.col := x_parent^.col;
x_parent^.col := B;
if (w^.right <> nil) then begin
w^.right^.col := B;
end;
RotLeft(x_parent);
x := root;
end
end else begin
w := x_parent^.left;
if (w^.col = R) then begin
w^.col := B;
x_parent^.col := R;
RotRight(x_parent);
w := x_parent^.left;
end;
if (((w^.right = nil) or
(w^.right^.col = B)) and
((w^.left = nil) or
(w^.left^.col = B))) then begin
w^.col := R;
x := x_parent;
x_parent := x_parent^.parent;
end else begin
if (w^.left = nil) or (w^.left^.col = B) then begin
w^.right^.col := B;
w^.col := R;
RotLeft(w);
w := x_parent^.left;
end;
w^.col := x_parent^.col;
x_parent^.col := B;
if (w^.left <> nil) then begin
w^.left^.col := B;
end;
RotRight(x_parent);
x := root;
end;
end;
until false;
if (x <> nil) then begin
x^.col := B;
end;
end;
dispose(y);
end;
function TGFOS_RBTree<_TKey, _TStore>._Find(key: _TKey): PFOS_RB_NodeG;
var cmp: integer;
node: PFOS_RB_NodeG;
begin
result:=nil;
node := root;
while (node <> nil) do begin
cmp := _Compare(node^.k, key);
if cmp < 0 then begin
node := node^.right;
end else if cmp > 0 then begin
node := node^.left;
end else begin
result:=node;
break;
end;
end;
end;
function TGFOS_RBTree<_TKey, _TStore>._FindNextPrev(key: _TKey;const
next:boolean): PFOS_RB_NodeG;
var cmp: integer;
node: PFOS_RB_NodeG;
begin
result:=nil;
node := root;
while true do begin
if node=nil then exit;
cmp := _Compare(node^.k, key);
if cmp < 0 then begin
if node^.right<>nil then begin
node := node^.right;
end else begin
result:=node;
if not next then exit;
break;
end;
end else if cmp > 0 then begin
if node^.left<>nil then begin
node := node^.left;
end else begin
result:=node;
if next then exit;
break;
end;
end else begin
if (node.left=nil) and (node.right=nil) and (node.parent=nil) then begin
result:=nil;
exit;
end else begin
result:=node;
break;
end;
end;
end;
if next then begin
if result=rightmost then begin
result:=nil;
end else begin
RBInc(result);
end;
end else begin
if result=leftmost then begin
result:=nil;
end else begin
RBDec(result);
end;
end;
end;
procedure TGFOS_RBTree<_TKey, _TStore>._fast_erase(x: PFOS_RB_NodeG;const
DoFreeItem:TGFOS_RB_OnItem);
begin
if (x^.left <> nil) then _fast_erase(x^.left,DoFreeItem);
if (x^.right <> nil) then _fast_erase(x^.right,DoFreeItem);
if assigned(DoFreeItem) then DoFreeItem(x.val);
dispose(x);
end;
procedure TGFOS_RBTree<_TKey, _TStore>._fast_eraseN(x: PFOS_RB_NodeG; const
DoFreeItem: TGFOS_RB_OnItemN);
begin
if (x^.left <> nil) then _fast_eraseN(x^.left,DoFreeItem);
if (x^.right <> nil) then _fast_eraseN(x^.right,DoFreeItem);
if assigned(DoFreeItem) then DoFreeItem(x.val);
dispose(x);
end;
procedure TGFOS_RBTree<_TKey, _TStore>.RBInc(var x: PFOS_RB_NodeG);
var y: PFOS_RB_NodeG;
begin
if (x^.right <> nil) then begin
x := x^.right;
while (x^.left <> nil) do begin
x := x^.left;
end;
end else begin
y := x^.parent;
while (x = y^.right) do begin
x := y;
y := y^.parent;
end;
if (x^.right <> y) then
x := y;
end
end;
procedure TGFOS_RBTree<_TKey, _TStore>.RBDec(var x: PFOS_RB_NodeG);
var y: PFOS_RB_NodeG;
begin
if (x^.left <> nil) then begin
y := x^.left;
while (y^.right <> nil) do begin
y := y^.right;
end;
x := y;
end else begin
y := x^.parent;
while (x = y^.left) do begin
x := y;
y := y^.parent;
end;
x := y;
end
end;
end.
smime.p7s
Description: S/MIME Cryptographic Signature
_______________________________________________ fpc-pascal maillist - fpc-pascal@lists.freepascal.org http://lists.freepascal.org/mailman/listinfo/fpc-pascal
