[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]
{ Borland Pascal Extended Function Library - EFLIB (C) Johan Larsson, 1996
Memory engine; handles allocation of data blocks; rewritten Usenet version
EFLIB IS PROTECTED BY THE COPYRIGHT LAW AND MAY NOT BE COPIED, SOLD OR
MANIPULATED. FOR MORE INFORMATION, SEE PROGRAM MANUAL!
THIS IS A SPECIAL RELEASE OF EFLIBS MEMORY ENGINE TO BE PUBLISHED
IN USENET / SWAGS. THE SOURCE CODE MAY FREELY BE USED NON-COMMERCIALY AS
LONG AS CREDIT IS GIVEN TO THE PROGRAMMER. THIS UNIT IS INDEPENDENT OF
OTHER EFLIB COMPONENTS AND DO NOT CONTAIN ALL THE FEATURES INCLUDED
IN THE REAL VERSION.
EFLIB is a free OOP toolkit for Borland Pascal. It's free for non-
commerical use only, and not for business or educational use. EFLIB
is available through Internet at http://www.ts.umu.se/~jola/EFLIB/.
Johan Larsson can be reached via E-MAIL (jola@ts.umu.se) or common
mail (Istidsgatan 33, 2tr., S-906 55 UMEA, Sweden). }
unit EFLIBMEM;
INTERFACE
type { Object that handles a dynamic DOS memory allocation }
AllocationObjectPointerType = ^AllocationObjectType;
AllocationObjectType = object
public
{ Constructors and destructors }
constructor Initialize (ThisSize : word); { Initializes object }
constructor InitializeEmpty; { Initializes empty object }
destructor Intercept; virtual; { Intercepts object }
{ Miscellaneous methods }
procedure Allocate (ThisSize : word); virtual; { Allocates memory (bytes) }
procedure Dispose; virtual; { Disposes memory }
{ Transferration methods }
procedure MoveIn (Source : pointer; SourceSize,
Position : word); virtual; { Moves data into object }
procedure MoveOut (Destination : pointer;
DestinationSize, Position : word);
virtual; { Moves data out of object }
{ Data access methods }
function DataPointer (Position : word) : pointer; { Returns a data pointer }
virtual;
function DataSize : word; virtual; { Returns the data size }
{ Status methods }
function IsAllocated : boolean; { Is memory allocated? }
private
{ Fields }
Data : pointer; { Data allocation pointer }
Size : word; { Data size in bytes }
{ Internal methods }
procedure Clear; virtual; { Clear memory }
procedure Error; virtual; { Error handler }
end;
{ This unit should compile in both real mode and protected mode Borland
Pascal, but in protected mode, the following procedures must be
replaced; }
procedure MoveFAST (var Source, Target; Size : word);
procedure FillWord (var Destination; Count, Data : word);
IMPLEMENTATION
{$B-} {$IFNDEF DEBUG} {$I-} {$S-} {$R-} {$Q-} {$ENDIF}
{ *** AllocationObjectType *** }
{ Initializes object and allocate specified bytes of memory }
constructor AllocationObjectType.Initialize (ThisSize : word);
begin
{ Prepare object (reset fields) }
InitializeEmpty;
{ Allocate ThisSize number of bytes on the heap }
Allocate (ThisSize);
end;
{ Initializes object without any data }
constructor AllocationObjectType.InitializeEmpty;
begin
{ Clear allocation variable and reset links }
Data := NIL; Size := 0;
end;
{ Intercepts object }
destructor AllocationObjectType.Intercept;
begin
{ Dispose allocated data }
if IsAllocated then Dispose;
end;
{ Allocate memory into AllocationObjectType }
procedure AllocationObjectType.Allocate (ThisSize : word);
begin
{ Allocate memory on the heap }
GetMem (Data, ThisSize);
Size := ThisSize; { Adjust size variable }
end;
{ Dispose memory from AllocationObjectType }
procedure AllocationObjectType.Dispose;
begin
{ Dispose memory from the heap }
if Assigned(Data) then FreeMem (Data, Size);
{ Reset fields }
Data := NIL; Size := 0;
end;
{ Move a data block into object data block }
procedure AllocationObjectType.MoveIn (Source : pointer; SourceSize, Position : word);
begin
{ Check that data pointer isn't NIL }
if Assigned(Source) then begin
{ Allocate data if no allocation exists }
if not IsAllocated then Allocate (SourceSize);
{ Move data from source to current object (prevent overflow) }
if IsAllocated and (Size >= SourceSize + Position) then
MoveFAST (Source^, DataPointer(Position)^, SourceSize)
else Error; { Error; fatal memory allocation error }
end else Error; { Error; couldn't access data resource }
end;
{ Move data out of object data block }
procedure AllocationObjectType.MoveOut (Destination : pointer; DestinationSize, Position : word);
begin
if Assigned(Destination) then { Check that destination is valid }
MoveFAST (DataPointer(Position)^, Destination^, DestinationSize)
else Error; { Error; couldn't access data resource }
end;
{ Returns a pointer to a byte inside allocated data or NIL if no allocation
exists. }
function AllocationObjectType.DataPointer (Position : word) : pointer;
begin
if IsAllocated then DataPointer := Ptr(Seg(Data^), Ofs(Data^) + Position)
else DataPointer := NIL; { No allocation exists! }
end;
{ Returns the size of the allocated data }
function AllocationObjectType.DataSize : word;
begin
if IsAllocated then DataSize := Size else DataSize := 0;
end;
{ Returns TRUE if AllocationObjectType contains an allocated pointer }
function AllocationObjectType.IsAllocated : boolean;
begin
IsAllocated := Assigned(Data) and (Size > 0);
end;
{ Clear allocated memory (set all bytes to zero) }
procedure AllocationObjectType.Clear;
begin
if IsAllocated then FillChar (Data, Size, 0)
else Error; { Error; no allocation exists }
end;
{ Method for memory allocation error handling }
procedure AllocationObjectType.Error;
begin
RunError (203);
end;
{ Fast 16-bit memory moving routine with overlap protection. Performance
is about 36% better than Borland Pascal 7.0's internal memory moving
routine. }
procedure MoveFAST (var Source, Target; Size : word); assembler;
asm
PUSH DS
PUSH ES
LDS SI, Source
LES DI, Target
MOV CX, Size
CLD
{ If an overlap of source and target occurs, copy data backwards }
CMP SI, DI
JAE @2
ADD SI, CX
ADD DI, CX
DEC SI
DEC DI
STD
SHR CX, 1
JAE @1
MOVSB
@1:
DEC SI
DEC DI
JMP @3
@2:
SHR CX, 1
JNC @3
MOVSB
@3:
REP MOVSW
POP ES
POP DS
end;
{ Fills a variable with word-sized data }
procedure FillWord (var Destination; Count, Data : word); assembler;
asm
LES DI, Destination
MOV CX, Count
MOV AX, Data
CLD
REP STOSW
end;
end. { unit }
[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]