Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {$I SWITCHES.PAS}
- UNIT FDBArrays;
- {
- FILE: FDBArray.pas
- ABSTRACT: General flat memory array "objects".
- Copyright (c) 1994- Falcon AS
- SYSTEM: General ("Falcon System IV")
- MODULE: Database related
- RELATED FILES:
- WARNING: Do not add Constructors, Destructors, or Virtual methods to
- the objects in this unit. It will break the source by adding
- a VMT and make it impossible to export/import these objects
- as flat array data from f.x. DLL's.
- REVISION HISTORY:
- VERSION DATE COMMENT BY
- ------- ------ ----------------------------------------- -----------
- 1.0.000 Initial version Lars Fosdal
- }
- INTERFACE
- USES
- TypeDefs;
- CONST
- MaxArrayItems = 8000; {Allow upto 8000 doubles in a 64K block}
- {When 32-bit flat memory arrives, it might be desirable
- to increase this limit :-) }
- TYPE
- IDInfo = RECORD {Block "Header-Header" :-)}
- CASE Integer OF
- 0 : (Position : OpenByteTable); {x x} {Typecast for indexed access}
- 1 : (ID : Word; {2 2} {Data dependant ID}
- TypeID : Word; {2 4} {Type dependant ID}
- Version : Word; {2 6} {Type ID dependant version number}
- Format : Word; {2 8} {Compression type, etc.}
- Flags : LongInt); {4 12} {Dirty, etc}
- END; {Rec IDInfo}
- pBlockHeader = ^TBlockHeader;
- TBlockHeader = OBJECT(TRecord)
- Block : IDInfo; {12 12} {Block ID/Version}
- CompSize : LongInt; { 4 16} {Compressed size (incl.header)}
- TrueSize : LongInt; { 4 20} {Uncompressed size (incl.header)}
- CompSum : LongInt; { 4 24} {Compressed chksum (excl.header)}
- TrueSum : LongInt; { 4 28} {Uncompressed chksum (excl.header)}
- Reserved : ARRAY[1..4] OF LongInt;{16 44} {Reserved for future use}
- PROCEDURE AssignID(DataID, TypeID, Version, Format:Word);
- FUNCTION IsDirty:Boolean;
- PROCEDURE SetDirty;
- PROCEDURE ClearDirty;
- FUNCTION IsCompressed:Boolean;
- FUNCTION Size:LongInt;
- FUNCTION Duplicate:Pointer;
- FUNCTION CheckSum(SizeOfHeader:LongInt):LongInt;
- FUNCTION Compress(SizeOfHeader:LongInt; Format:Word):Pointer;
- FUNCTION Uncompress(SizeOfHeader:LongInt):Pointer;
- END; {OBJ TBlockHeader}
- TYPE
- pArrayBase = ^TArrayBase;
- TArrayBase = OBJECT(TBlockHeader) {44 44} {Standard array header}
- ItemSize : Word; { 2 46} {Data item size}
- Rsvd : Word; { 2 48} {Reserved}
- Count : LongInt; { 4 52} {Number of Items utilized}
- Limit : LongInt; { 4 56} {Max. number of Items}
- Spare : ARRAY[1..2] OF LongInt; { 8 64} {Reserved}
- PROCEDURE InitArray(_ItemSize:Word; _Limit:LongInt);
- FUNCTION ItemAddress(Index:LongInt):Pointer;
- FUNCTION Append(CONST NewItem):LongInt;
- PROCEDURE Get(Index:LongInt; VAR Item);
- FUNCTION Put(Index:LongInt; CONST Item):LongInt;
- FUNCTION Insert(Index:LongInt; CONST NewItem):LongInt;
- FUNCTION Delete(Index:LongInt):LongInt;
- FUNCTION AppendBlock(CONST NewArrayBase):LongInt;
- FUNCTION InsertBlock(Index:LongInt; CONST NewArrayBase):LongInt;
- FUNCTION DeleteBlock(Index,Items:LongInt):LongInt;
- FUNCTION DuplicateBlock(Index, Items:LongInt):Pointer;
- FUNCTION DeleteAll:LongInt;
- FUNCTION FreeCount:LongInt;
- FUNCTION isEmpty:Boolean;
- FUNCTION isFull:Boolean;
- PROCEDURE Inspect(VAR oFile:Text);
- END; {TArrayBase}
- TYPE
- pByteArray = ^TByteArray;
- TByteArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF Byte;
- FUNCTION Append(NewItem:Byte):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:Byte):LongInt;
- END; {REC TByteArray}
- TYPE
- pSmallIntArray = ^TSmallIntArray;
- TSmallIntArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF SmallInt;
- FUNCTION Append(NewItem:SmallInt):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:SmallInt):LongInt;
- END; {REC TSmallIntArray}
- TYPE
- pWordArray = ^TWordArray;
- TWordArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF Word;
- FUNCTION Append(NewItem:Word):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:Word):LongInt;
- END; {REC TWordArray}
- TYPE
- pLongIntArray = ^TLongIntArray;
- TLongIntArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF LongInt;
- FUNCTION Append(NewItem:LongInt):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:LongInt):LongInt;
- END; {REC TLongIntArray}
- TYPE
- pTimeArray = ^TTimeArray;
- TTimeArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF TTime;
- FUNCTION Append(NewItem:TTime):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:TTime):LongInt;
- END; {REC TTimeArray}
- TYPE
- pRealArray = ^TRealArray;
- TRealArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF Real;
- FUNCTION Append(NewItem:Real):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:Real):LongInt;
- FUNCTION PackToLFD:pRealArray;
- FUNCTION UnpackLFD:pRealArray;
- END; {REC TRealArray}
- TYPE
- pDoubleArray = ^TDoubleArray;
- TDoubleArray = OBJECT(TArrayBase)
- Item : ARRAY [0..MaxArrayItems-1] OF Double;
- FUNCTION Append(NewItem:Double):LongInt;
- FUNCTION Insert(Index:LongInt; NewItem:Double):LongInt;
- FUNCTION PackToLFD:pDoubleArray;
- FUNCTION UnpackLFD:pDoubleArray;
- END; {REC TDoubleArray}
- FUNCTION BlockNew(BlockSize:LongInt; VAR Block):LongInt;
- FUNCTION BlockDuplicate(VAR Block):Pointer;
- PROCEDURE BlockDispose(VAR Block);
- FUNCTION ArraySize(ItemSize:Word; Limit:LongInt):LongInt;
- FUNCTION ArrayNew(CONST ItemSize:Word; VAR ArrayBase; ItemLimit:LongInt):LongInt;
- PROCEDURE ArrayDispose(VAR ArrayBase);
- FUNCTION ArrayResize(VAR ArrayBase; ItemLimit:LongInt):LongInt;
- {$IFNDEF NoLog}
- FUNCTION DateTimeStr(PDT:TTime):String;
- FUNCTION SplitIDStr(PDT:TTime):String;
- {$ENDIF}
- IMPLEMENTATION
- USES
- {$IFNDEF NoLog}
- LFErrLog, WinInfo, LFString,
- {$ENDIF}
- FDBMagic,
- {$IFNDEF Win32}
- PKWare,
- {$ENDIF}
- WinDate;
- {$IFNDEF NoLog}
- FUNCTION DateTimeStr(PDT:TTime):String;
- VAR
- DT : TUnpackedTime;
- sep : String[3];
- {$IFNDEF Delphi}
- Result : String;
- {$ENDIF}
- BEGIN
- UnpackDT(PDT, DT);
- sep := WinIntl^.sDate[0];
- Result:=SwapAll(' ','0',IntStr(DT.Year ,4)+Sep+IntStr(DT.Month,2)+Sep+IntStr(DT.Day,2));
- IF PDT.Time<>0
- THEN Result:=Result+' '+SwapAll(' ','0',IntStr(DT.Hour,2)+Char(WinIntl^.sTime^)
- +IntStr(DT.Min,2)+Char(WinIntl^.sTime^)
- +IntStr(DT.Sec,2));
- {$IFNDEF Delphi}
- DateTimeStr:=Result;
- {$ENDIF}
- END; {FUNC DateTimeStr}
- FUNCTION SplitIDStr(PDT:TTime):String;
- VAR
- DT : TUnpackedTime;
- sep : String[3];
- {$IFNDEF Delphi}
- Result : String;
- {$ENDIF}
- BEGIN
- UnpackDT(PDT, DT);
- sep := WinIntl^.sDate[0];
- Result:=SwapAll(' ','0',IntStr(DT.Year ,4)+Sep+IntStr(DT.Month,2)+Sep+IntStr(DT.Day,2));
- Result:=Result+' '+IntStr(PDT.Time,0);
- {$IFNDEF Delphi}
- SplitIDStr:=Result;
- {$ENDIF}
- END; {FUNC SplitIDStr}
- {$ENDIF}
- {------------------------------------------------------------ Block Primitives ---}
- FUNCTION BlockNew(BlockSize:LongInt; VAR Block):LongInt;
- VAR
- ItemPtr : pBlockHeader Absolute Block;
- BEGIN
- GetMem(ItemPtr, BlockSize);
- IF Assigned(ItemPtr)
- THEN BEGIN
- BlockNew:=BlockSize;
- FillChar(ItemPtr^, BlockSize, 0);
- ItemPtr^.TrueSize:=BlockSize;
- END
- ELSE BlockNew:=0;
- END; {FUNC BlockNew}
- PROCEDURE BlockDispose(VAR Block);
- VAR
- ItemPtr : pBlockHeader Absolute Block;
- BEGIN
- IF Assigned(ItemPtr)
- THEN BEGIN
- FreeMem(ItemPtr, ItemPtr^.Size);
- ItemPtr:=nil;
- END;
- END; {PROC BlockDispose}
- FUNCTION BlockDuplicate(VAR Block):Pointer;
- VAR
- Original : pBlockHeader Absolute Block;
- Replica : pBlockHeader;
- BEGIN
- BlockNew(Original^.Size, Replica);
- IF Assigned(Replica)
- THEN Move(Original^, Replica^, Original^.Size);
- BlockDuplicate:=Replica;
- END; {FUNC BlockDuplicate}
- {------------------------------------------------------ Array Block Primitives ---}
- TYPE
- pDummyArray = ^TDummyArray;
- TDummyArray = OBJECT(TArrayBase) {for manipulation purposes}
- Data : OpenByteTable;
- END;
- FUNCTION ArraySize(ItemSize:Word; Limit:LongInt):LongInt;
- { - Calculate memory needed for an array}
- BEGIN
- ArraySize:=SizeOf(TArrayBase)+(ItemSize*Limit);
- END; {FUNC ArraySize}
- FUNCTION ArrayNew(CONST ItemSize:Word; VAR ArrayBase; ItemLimit:LongInt):LongInt;
- { - Allocate a new array - Returns New Array pointer and size in bytes}
- VAR
- Arry : pArrayBase Absolute ArrayBase;
- BEGIN
- ArrayNew:=BlockNew( ArraySize(ItemSize, ItemLimit), Arry);
- IF Assigned(Arry)
- THEN Arry^.InitArray(ItemSize, ItemLimit);
- END; {FUNC ArrayNew}
- PROCEDURE ArrayDispose(VAR ArrayBase);
- { - DeAllocate an existing array}
- BEGIN
- BlockDispose(ArrayBase);
- END; {PROC ArrayDispose}
- FUNCTION ArrayResize(VAR ArrayBase; ItemLimit:LongInt):LongInt;
- { - Shrink or grow an Array - Returns new Array pointer and size in bytes}
- VAR
- Size : LongInt;
- CopyLen : LongInt;
- Old : pArrayBase Absolute ArrayBase;
- Arry : pArrayBase;
- BEGIN
- Size:=ArrayNew(Old^.ItemSize, Arry, ItemLimit);
- IF Size>Old^.Size
- THEN CopyLen:=Old^.Size
- ELSE CopyLen:=Size;
- Move(Old^, Arry^, CopyLen);
- Arry^.TrueSize:=Size;
- Arry^.Limit:=ItemLimit;
- IF Arry^.Count>ItemLimit
- THEN Arry^.Count:=ItemLimit;
- ArrayDispose(Old);
- Old:=Arry;
- ArrayResize:=Size;
- END; {FUNC ArrayResize}
- {------------------------------------------------------------- TBlockHeader ---}
- FUNCTION TBlockHeader.IsDirty:Boolean;
- BEGIN
- IsDirty:=Block.Flags and $0001 = $0001;
- END; {FUNC TBlockHeader.IsDirty}
- PROCEDURE TBlockHeader.SetDirty;
- BEGIN
- Block.Flags:=Block.Flags or $0001;
- END; {PROC TBlockHeader.SetDirty}
- PROCEDURE TBlockHeader.ClearDirty;
- BEGIN
- Block.Flags:=Block.Flags and $FFFE;
- END; {PROC TBlockHeader.ClearDirty}
- FUNCTION TBlockHeader.IsCompressed:Boolean;
- BEGIN
- IsCompressed:=Block.Format<>0;
- END; {FUNC TBlockHeader.IsCompressed}
- FUNCTION TBlockHeader.Size:LongInt;
- BEGIN
- IF IsCompressed
- THEN Size:=CompSize
- ELSE Size:=TrueSize;
- END; {FUNC TBlockHeader.Size}
- FUNCTION TBlockHeader.Duplicate:Pointer;
- { - Duplicate a block - Returns pointer to new block}
- VAR
- ptr : Pointer;
- BEGIN
- ptr:=@Self;
- Duplicate:=BlockDuplicate(ptr);
- END; {FUNC TBlockHeader.Duplicate}
- FUNCTION TBlockHeader.CheckSum(SizeOfHeader:LongInt):LongInt;
- BEGIN
- CheckSum:=0;
- END; {FUNC TBlockHeader.CheckSum}
- FUNCTION TBlockHeader.Compress(SizeOfHeader:LongInt; Format:Word):Pointer;
- VAR
- NewBlock : pBlockHeader;
- Original : pBlockHeader;
- BEGIN
- NewBlock:=nil;
- Original:=pBlockHeader(@Self);
- {$IFNDEF Win32}
- IF Original^.TrueSize > SizeOfHeader
- THEN BEGIN
- IF (Format and icp_LZW = icp_LZW)
- THEN BEGIN
- {$IFOPT R+}{$R-}{$DEFINE RPlus}{$ENDIF}
- ImplodeInit(Original^.TrueSize - SizeOfHeader,
- @Original^.Block.Position[SizeOfHeader]);
- {$IFDef Rplus}{$R+}{$UNDEF RPlus}{$ENDIF}
- IF ImplodeData
- THEN BEGIN
- WITH PKZ
- DO BEGIN
- BlockNew(TargetPos + SizeOfHeader, NewBlock);
- Move(Original^, NewBlock^, SizeOfHeader);
- {$IFOPT R+}{$R-}{$DEFINE RPlus}{$ENDIF}
- Move(Target^, NewBlock^.Block.Position[SizeOfHeader], TargetPos);
- {$IFDef Rplus}{$R+}{$UNDEF RPlus}{$ENDIF}
- NewBlock^.CompSize:=TargetPos + SizeOfHeader;
- NewBlock^.Block.Format:=NewBlock^.Block.Format or icp_LZW;
- END;
- Format:=Format and not icp_LZW;
- END
- {$IFNDEF NoLog}
- ELSE LogError('PKZ compression failed - Leaving data uncompressed!')
- {$ENDIF};
- ImplodeDone;
- END; {icp_LZW}
- END;
- {$ENDIF}
- IF not Assigned(NewBlock)
- THEN NewBlock:=Original^.Duplicate;
- IF Assigned(Original) and (Original<>NewBlock) and (Original<>@Self)
- THEN BlockDispose(Original);
- Compress:=NewBlock;
- END; {FUNC TBlockHeader.Compress}
- FUNCTION TBlockHeader.Uncompress(SizeOfHeader:LongInt):Pointer;
- VAR
- NewBlock : pBlockHeader;
- Original : pBlockHeader;
- BEGIN
- NewBlock:=nil;
- Original:=pBlockHeader(@Self);
- {$IFDEF Win32}
- {//Incomplete}
- {$ELSE}
- IF (Original^.Block.Format and icp_LZW = icp_LZW)
- THEN BEGIN
- BlockNew(Original^.TrueSize, NewBlock);
- Move(Original^, NewBlock^, SizeOfHeader);
- {$IFOPT R+}{$R-}{$DEFINE RPlus}{$ENDIF}
- ExplodeInit(Original^.CompSize - SizeOfHeader,
- @Original^.Block.Position[SizeOfHeader],
- Original^.TrueSize - SizeOfHeader,
- @NewBlock^.Block.Position[SizeOfHeader]);
- {$IFDef Rplus}{$R+}{$UNDEF RPlus}{$ENDIF}
- IF ExplodeData
- THEN BEGIN
- NewBlock^.CompSize:=0;
- NewBlock^.Block.Format:=NewBlock^.Block.Format and not icp_LZW;
- END
- ELSE BEGIN
- {$IFNDEF NoLog}
- LogError('PKZ decompression failed - Leaving data compressed!');
- {$ENDIF}
- BlockDispose(NewBlock);
- END;
- ExplodeDone;
- END; {icp_LZW}
- {$ENDIF}
- IF not Assigned(NewBlock)
- THEN NewBlock:=Original^.Duplicate;
- IF Assigned(Original) and (Original<>NewBlock) and (Original<>@Self)
- THEN BlockDispose(Original);
- Uncompress:=NewBlock;
- END; {FUNC TBlockHeader.Uncompress}
- PROCEDURE TBlockHeader.AssignID(DataID, TypeID, Version, Format:Word);
- BEGIN
- Block.ID:=DataID;
- Block.TypeID:=TypeID;
- Block.Version:=Version;
- Block.Format:=Format;
- END; {PROC TBlockHeader.AssignID}
- {------------------------------------------------------------ TArrayBase ---}
- {$IFOPT R+} {$DEFINE RPlus} {$R-} {$ENDIF}
- PROCEDURE TArrayBase.InitArray(_ItemSize:Word; _Limit:LongInt);
- BEGIN
- ItemSize:=_ItemSize;
- Limit:=_Limit;
- END; {PROC TArrayBase.Init}
- FUNCTION TArrayBase.DuplicateBlock(Index,Items:LongInt):Pointer;
- { - Copy a partial Array - Returns pointer to new array}
- VAR
- Original : TDummyArray Absolute Self;
- Arry : pDummyArray;
- BEGIN
- Arry:=nil;
- WITH Original
- DO BEGIN
- IF (Count>0) and (Index<Count)
- THEN BEGIN
- IF Index+Items>Count
- THEN Items:=Count-Index+1;
- ArrayNew(ItemSize, Arry, Items);
- IF Assigned(Arry)
- THEN BEGIN
- Arry^.Block:=Original.Block;
- Move(Data[Index*ItemSize], Arry^.Data[0], Items*ItemSize);
- Arry^.Count:=Items;
- END;
- END
- ELSE Arry:=nil;
- END;
- DuplicateBlock:=Arry;
- END; {FUNC TArrayBase.DuplicateBlock}
- FUNCTION TArrayBase.ItemAddress(Index:LongInt):Pointer;
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF (Index<Count) and (Index>-1)
- THEN ItemAddress:=@Original.Data[Index*ItemSize]
- ELSE ItemAddress:=nil;
- END; {FUNC TArrayBase.ItemAddress}
- FUNCTION TArrayBase.Append(CONST NewItem):LongInt;
- { - Append an item to the array - return number of items or -1 if failure}
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF Count<Limit
- THEN BEGIN
- Move(NewItem, Original.Data[Count*ItemSize], ItemSize);
- SetDirty;
- Inc(Count);
- Append:=Count;
- END
- ELSE Append:=-1;
- END; {FUNC TArrayBase.Append}
- PROCEDURE TArrayBase.Get(Index:LongInt; VAR Item);
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF (Index<Count)
- THEN BEGIN
- Move(Original.Data[Index*ItemSize], Item, ItemSize);
- END;
- END; {PROC TArrayBase.Get}
- FUNCTION TArrayBase.Put(Index:LongInt; CONST Item):LongInt;
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF (Index<Count)
- THEN BEGIN
- Move(Item, Original.Data[Index*ItemSize], ItemSize);
- SetDirty;
- Put:=Index;
- END
- ELSE Put:=-1;
- END; {FUNC TArrayBase.Put}
- FUNCTION TArrayBase.Insert(Index:LongInt; CONST NewItem):LongInt;
- { - Insert an item in the array - Return number of items or -1 if failure}
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF Count<Limit
- THEN BEGIN
- IF Index>Count
- THEN Index:=Count;
- IF Index<>Count
- THEN Move(Original.Data[Index*ItemSize],
- Original.Data[(Index+1)*ItemSize], (Count-Index)*ItemSize);
- Move(NewItem, Original.Data[Index*ItemSize], ItemSize);
- Inc(Count);
- Insert:=Count;
- SetDirty;
- END
- ELSE Insert:=-1;
- END; {FUNC TArrayBase.Insert}
- FUNCTION TArrayBase.Delete(Index:LongInt):LongInt;
- { - Delete an item from the array - return number of items or -1 if failure}
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF Count>0
- THEN BEGIN
- IF Index<=Count
- THEN BEGIN
- IF Index<>Count-1
- THEN Move(Original.Data[(Index+1)*ItemSize],
- Original.Data[Index*ItemSize], ((Count-Index)-1)*ItemSize);
- Dec(Count);
- FillChar(Original.Data[Count*ItemSize], ItemSize, 0);
- SetDirty;
- END;
- Delete:=Count;
- END
- ELSE Delete:=-1;
- END; {FUNC TArrayBase.Delete}
- FUNCTION TArrayBase.AppendBlock(CONST NewArrayBase):LongInt;
- { - Append another array, return number of items or -1 if failure}
- VAR
- Original : TDummyArray Absolute Self;
- Apnd : pDummyArray Absolute NewArrayBase;
- BEGIN
- IF Count+Apnd^.Count <= Limit
- THEN BEGIN
- Move(Apnd^.Data, Original.Data[Count*ItemSize], Apnd^.Count*ItemSize);
- Count:=Count+Apnd^.Count;
- AppendBlock:=Count;
- SetDirty;
- END
- ELSE AppendBlock:=-1;
- END; {FUNC TArrayBase.AppendBlock}
- FUNCTION TArrayBase.InsertBlock(Index:LongInt; CONST NewArrayBase):LongInt;
- { - Insert another array - return number of items or -1 if failure}
- VAR
- Original : TDummyArray Absolute Self;
- Apnd : pDummyArray Absolute NewArrayBase;
- BEGIN
- IF (Count+Apnd^.Count <= Limit) and (Apnd^.Count>0)
- THEN BEGIN
- IF Index>Count
- THEN Index:=Count;
- IF Index<>Count
- THEN Move(Original.Data[(Index)*ItemSize],
- Original.Data[(Index+Apnd^.Count)*ItemSize],
- (Count-Index)*ItemSize);
- Move(Apnd^.Data, Original.Data[Index*ItemSize], Apnd^.Count*ItemSize);
- Count:=Count+Apnd^.Count;
- InsertBlock:=Count;
- SetDirty;
- END
- ELSE InsertBlock:=-1;
- END; {FUNC TArrayBase.InsertBlock}
- FUNCTION TArrayBase.DeleteBlock(Index,Items:LongInt):LongInt;
- { - Delete a section of an array, return number of items or -1 if failure}
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- IF (Count>0) and (Items>0)
- THEN BEGIN
- IF Index<Count
- THEN BEGIN
- IF (Index+Items)>Count
- THEN Items:=Count-Index
- ELSE IF (Index+Items) < Count
- THEN Move(Original.Data[(Index+Items)*ItemSize],
- Original.Data[Index*ItemSize], ((Count-Index)-Items)*ItemSize);
- Count:=Count-Items;
- FillChar(Original.Data[Count*ItemSize], Items*ItemSize, 0);
- SetDirty;
- END;
- DeleteBlock:=Count;
- END
- ELSE DeleteBlock:=-1;
- END; {FUNC TArrayBase.DeleteBlock}
- {$IFDEF Rplus} {$UNDEF RPlus} {$R+} {$ENDIF}
- FUNCTION TArrayBase.DeleteAll:LongInt;
- { - Resets array count and clears contents - always returns 0}
- VAR
- Original : TDummyArray Absolute Self;
- BEGIN
- FillChar(Original.Data, Limit*ItemSize, 0);
- Count:=0;
- DeleteAll:=0;
- SetDirty;
- END; {PROC TArrayBase.DeleteAll}
- FUNCTION TArrayBase.FreeCount:LongInt;
- { - Returns the number of free positions}
- BEGIN
- FreeCount:=Count-Limit;
- END; {FUNC TArrayBase.FreeCount}
- FUNCTION TArrayBase.IsEmpty:Boolean;
- BEGIN
- IsEmpty:=Count=0;
- END; {FUNC TArrayBase.IsEmpty:Boolean}
- FUNCTION TArrayBase.isFull:Boolean;
- { - Returns TRUE if the array is full}
- BEGIN
- isFull:=FreeCount=0;
- END; {FUNC TArrayBase.isFull}
- PROCEDURE TArrayBase.Inspect(VAR oFile:Text);
- BEGIN
- Writeln(oFile, ' IS=', ItemSize, ' Max=',Limit,' n=',Count);
- END; {PROC TArrayBase.Inspect}
- {---------------------------------------------------------------- TByteArray ---}
- FUNCTION TByteArray.Append(NewItem:Byte):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TByteArray.Append}
- FUNCTION TByteArray.Insert(Index:LongInt; NewItem:Byte):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TByteArray.Insert}
- {---------------------------------------------------------------- TSmallIntArray ---}
- FUNCTION TSmallIntArray.Append(NewItem:SmallInt):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TSmallIntArray.Append}
- FUNCTION TSmallIntArray.Insert(Index:LongInt; NewItem:SmallInt):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TSmallIntArray.Insert}
- {---------------------------------------------------------------- TWordArray ---}
- FUNCTION TWordArray.Append(NewItem:Word):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TWordArray.Append}
- FUNCTION TWordArray.Insert(Index:LongInt; NewItem:Word):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TWordArray.Insert}
- {---------------------------------------------------------------- TLongIntArray ---}
- FUNCTION TLongIntArray.Append(NewItem:LongInt):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TLongIntArray.Append}
- FUNCTION TLongIntArray.Insert(Index:LongInt; NewItem:LongInt):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TLongIntArray.Insert}
- {---------------------------------------------------------------- TTimeArray ---}
- FUNCTION TTimeArray.Append(NewItem:TTime):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TTimeArray.Append}
- FUNCTION TTimeArray.Insert(Index:LongInt; NewItem:TTime):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TTimeArray.Insert}
- {---------------------------------------------------------------- TRealArray ---}
- FUNCTION TRealArray.Append(NewItem:Real):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TRealArray.Append}
- FUNCTION TRealArray.Insert(Index:LongInt; NewItem:Real):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TRealArray.Insert}
- FUNCTION TRealArray.PackToLFD:pRealArray;
- BEGIN
- PackToLFD:=@Self; {/// Incomplete}
- END; {FUNC TRealArray.PackToLFD}
- FUNCTION TRealArray.UnpackLFD:pRealArray;
- BEGIN
- UnpackLFD:=@Self; {/// Incomplete}
- END; {FUNC TRealArray.UnpackLFD}
- {---------------------------------------------------------------- TDoubleArray ---}
- FUNCTION TDoubleArray.Append(NewItem:Double):LongInt;
- BEGIN
- Append:=Inherited Append(NewItem);
- END; {FUNC TDoubleArray.Append}
- FUNCTION TDoubleArray.Insert(Index:LongInt; NewItem:Double):LongInt;
- BEGIN
- Insert:=Inherited Insert(Index, NewItem);
- END; {FUNC TDoubleArray.Insert}
- FUNCTION TDoubleArray.PackToLFD:pDoubleArray;
- VAR
- LFDArray : pDummyArray;
- LFDLimit,
- iDouble,
- iLFD : LongInt;
- iLen : Integer;
- BEGIN
- LFDArray:=Duplicate;
- (* LFDLimit:=(Limit*ItemSize) - (11+SizeOf(Count)+SizeOf(Limit));
- iDouble:=0;
- iLFD:=0;
- {$IFOPT R+} {$DEFINE Rplus} {$R-} {$ENDIF}
- Move(Count, LFDArray^.Data[iLFD], SizeOf(Count)); iLFD:=iLFD+SizeOf(Count);
- Move(Limit, LFDArray^.Data[iLFD], SizeOf(Limit)); iLFD:=iLFD+SizeOf(Limit);
- WHILE (iDouble<Count) and (iLFD<LFDLimit)
- DO BEGIN
- iLen:=DoubleToLFD(Item[iDouble], LFDArray^.Data[iLFD]);
- iLFD:=iLFD+iLen;
- Inc(iDouble);
- END;
- {$IFDEF Rplus} {$R-} {$UNDEF Rplus} {$ENDIF}
- IF iDouble<Count
- THEN BEGIN
- ArrayDispose(LFDArray);
- LFDArray:=@Self;
- END
- ELSE BEGIN
- iLen:=((iLFD+SizeOf(Count)+SizeOf(Limit)) DIV ItemSize)+1;
- ArrayResize(LFDArray, iLen);
- LFDArray^.Block.Format:=LFDArray^.Block.Format or icp_LFD;
- LFDArray^.CompSize:=LFDArray^.TrueSize;
- END;
- *)
- PackToLFD:=pDoubleArray(LFDArray);
- END; {FUNC TDoubleArray.PackToLFD}
- FUNCTION TDoubleArray.UnpackLFD:pDoubleArray;
- VAR
- DoubleArray : pDoubleArray;
- LFDArray : TDummyArray Absolute Self;
- LFDLimit,
- iDouble,
- iLFD : LongInt;
- iLen : Integer;
- nLimit,
- nCount : LongInt;
- BEGIN
- iLFD:=0;
- {$IFOPT R+} {$DEFINE Rplus} {$R-} {$ENDIF}
- Move(LFDArray.Data[iLFD], nCount, SizeOf(Count)); iLFD:=iLFD+SizeOf(Count);
- Move(LFDArray.Data[iLFD], nLimit, SizeOf(Limit)); iLFD:=iLFD+SizeOf(Limit);
- iDouble:=0;
- LFDLimit:=Limit*ItemSize - (SizeOf(Count)+SizeOf(Limit));
- ArrayNew(ItemSize, DoubleArray, nLimit);
- (*
- WHILE (iDouble<nCount) and (iLFD<LFDLimit)
- DO BEGIN
- iLen:=LFDtoDouble(LFDArray.Data[iLFD], DoubleArray^.Item[iDouble]);
- iLFD:=iLFD+iLen;
- Inc(iDouble);
- END;
- DoubleArray^.Count:=iDouble;
- *)
- {$IFDEF Rplus} {$R-} {$UNDEF Rplus} {$ENDIF}
- UnpackLFD:=DoubleArray; {/// Incomplete}
- END; {FUNC TDoubleArray.UnpackLFD}
- END.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement