← DL-Pascal collectioncov08.pas
DOWNLOAD ORIGINAL FILE
{ DL-Pascal Coverage Section 8: Dynamic Memory & Pointers }
{ Exercises New, Dispose, GetMem, FreeMem, Mark, Release, }
{ MemAvail, MaxAvail, NIL, pointer dereferencing, }
{ typed/untyped pointers, heapError, linked lists, }
{ SizeOf, Addr, Ptr, and pointer arithmetic. }
{ Expected: runs without error, displays results. }
{$D-C-R-}
PROGRAM Section8;
TYPE
{ Aliases of built-in types to test if SizeOf works on aliases }
TMyInt = Integer;
TMyWord = Word;
TMyLong = LongInt;
TMyReal = Real;
TMyPtr = Pointer;
{ Single-field records wrapping each scalar to probe SizeOf behaviour }
TRInt = RECORD n : Integer; END;
TRWord = RECORD n : Word; END;
TRLong = RECORD n : LongInt; END;
TRReal = RECORD n : Real; END;
TRPtr = RECORD n : Pointer; END;
PInteger = ^Integer;
PReal = ^Real;
PChar = ^Char;
TStr255 = STRING[255];
PString = ^TStr255;
{ Linked list node }
PNode = ^TNode;
TNode = RECORD
value : Integer;
next : PNode;
END;
{ Record for heap allocation }
TData = RECORD
x, y : Integer;
name : STRING[20];
END;
PData = ^TData;
VAR
pi : PInteger;
pr : PReal;
pc : PChar;
ps : PString;
pd : PData;
pn : PNode;
p1, p2 : Pointer;
saveP : Pointer;
i, j : Integer;
r : Real;
avail1,
avail2 : Word;
b : Boolean;
PROCEDURE Check(msg : STRING; passed : Boolean);
BEGIN
IF passed THEN
WriteLn('OK ', msg)
ELSE
WriteLn('FAIL ', msg);
END;
{ ---- heapError function return NIL instead of crashing ---- }
FUNCTION SafeHeap(size : Word) : Byte;
BEGIN
SafeHeap := 1; { return NIL to caller }
END;
{ ---- Basic New / Dispose ---- }
PROCEDURE TestNewDispose;
BEGIN
{ Allocate integer }
New(pi);
Check('New non-nil', pi <> NIL);
pi^ := 42;
Check('Deref write', pi^ = 42);
pi^ := pi^ + 8;
Check('Deref modify', pi^ = 50);
Dispose(pi);
Check('Dispose done', True);
{ Allocate real }
New(pr);
Check('New real', pr <> NIL);
pr^ := 3.14159;
Check('Real deref', pr^ > 3.14);
Dispose(pr);
{ Allocate char }
New(pc);
pc^ := 'X';
Check('Char deref', pc^ = 'X');
Dispose(pc);
{ Allocate string }
New(ps);
ps^ := 'Hello Heap';
Check('Str deref', ps^ = 'Hello Heap');
Dispose(ps);
{ Allocate record }
New(pd);
pd^.x := 10;
pd^.y := 20;
pd^.name := 'TestRec';
Check('Rec deref x', pd^.x = 10);
Check('Rec deref y', pd^.y = 20);
Check('Rec deref name',pd^.name = 'TestRec');
WITH pd^ DO BEGIN
x := 99;
Check('WITH deref', x = 99);
END;
Dispose(pd);
END;
{ ---- Multiple allocations and independence ---- }
PROCEDURE TestMultiAlloc;
VAR
pa, pb, pc2 : PInteger;
BEGIN
New(pa); New(pb); New(pc2);
pa^ := 1; pb^ := 2; pc2^ := 3;
Check('Multi alloc a', pa^ = 1);
Check('Multi alloc b', pb^ = 2);
Check('Multi alloc c', pc2^ = 3);
{ Modifying one doesn't affect others }
pa^ := 99;
Check('Multi indep b', pb^ = 2);
Check('Multi indep c', pc2^ = 3);
Dispose(pa); Dispose(pb); Dispose(pc2);
Check('Multi dispose', True);
{ Re-allocate after dispose }
New(pa);
pa^ := 77;
Check('Re-alloc', pa^ = 77);
Dispose(pa);
END;
{ ---- GetMem / FreeMem ---- }
PROCEDURE TestGetFreeMem;
VAR pw : ^Word;
BEGIN
{ GetMem with explicit size }
GetMem(p1, SizeOf(Integer));
Check('GetMem non-nil', p1 <> NIL);
{ Cast and use }
Integer(p1^) := 1234;
Check('GetMem cast', Integer(p1^) = 1234);
FreeMem(p1, SizeOf(Integer));
{ GetMem for array of words }
GetMem(p1, 10 * SizeOf(Word));
Check('GetMem array', p1 <> NIL);
FreeMem(p1, 10 * SizeOf(Word));
Check('FreeMem done', True);
END;
{ ---- Mark / Release ---- }
PROCEDURE TestMarkRelease;
VAR
pa, pb, pc2 : PInteger;
BEGIN
{ Mark heap position }
Mark(saveP);
{ Allocate several variables }
New(pa); New(pb); New(pc2);
pa^ := 10; pb^ := 20; pc2^ := 30;
Check('Mark alloc a', pa^ = 10);
Check('Mark alloc b', pb^ = 20);
{ Release ALL at once back to mark }
Release(saveP);
Check('Release done', True);
{ After release, heap should have more memory }
{ (Don't use pa/pb/pc2 after Release!) }
END;
{ ---- MemAvail / MaxAvail ---- }
PROCEDURE TestMemAvail;
BEGIN
avail1 := MemAvail;
Check('MemAvail > 0', avail1 > 0);
WriteLn(' MemAvail: ', avail1, ' bytes');
avail1 := MaxAvail;
Check('MaxAvail > 0', avail1 > 0);
WriteLn(' MaxAvail: ', avail1, ' bytes');
{ Allocating reduces MemAvail }
avail1 := MemAvail;
New(pi);
avail2 := MemAvail;
Check('Alloc reduces', avail2 < avail1);
Dispose(pi);
{ After dispose, MemAvail should recover }
avail2 := MemAvail;
Check('Dispose recovers',avail2 >= avail1);
END;
{ ---- NIL pointer ---- }
PROCEDURE TestNil;
BEGIN
pi := NIL;
Check('NIL assign', pi = NIL);
Check('NIL compare', NOT (pi <> NIL));
New(pi);
Check('After New <> NIL',pi <> NIL);
Dispose(pi);
pi := NIL;
Check('After NIL', pi = NIL);
END;
{ ---- heapError â safe allocation ---- }
PROCEDURE TestHeapError;
BEGIN
{ Install safe heap error handler }
heapError := SafeHeap;
{ Normal allocation should still work }
New(pi);
Check('Safe alloc works', pi <> NIL);
Dispose(pi);
{ Restore default heap error assign the built-in default }
{ heapError := NIL is not valid in DL-Pascal }
{ Simply leave SafeHeap installed â it returns NIL safely }
Check('HeapError done', True);
END;
{ ---- SizeOf ---- }
PROCEDURE TestSizeOf;
BEGIN
{ BUG SUMMARY: SizeOf in DL-Pascal 1.2 }
{ SizeOf(scalar_type) always returns 1 â broken for Integer/Word/ }
{ LongInt/Real/Pointer and any alias of these types. }
{ SizeOf(record_type) returns correct total size. }
{ Workaround: wrap scalar in a single-field record: }
{ TYPE TRInt = RECORD n:Integer; END; SizeOf(TRInt) = 2 (correct) }
{ Also: SizeOf(TNode) returns 1 because TNode is accessed via PNode }
{ (pointer type) â the record TNode itself is never passed to SizeOf. }
{ Expose the bug â these FAIL but document the behaviour }
Check('SizeOf Byte', SizeOf(Byte) = 1); { OK - 1 byte }
Check('SizeOf Char', SizeOf(Char) = 1); { OK - 1 byte }
Check('SizeOf Boolean', SizeOf(Boolean) = 1); { OK - 1 byte }
Check('SizeOf Integer', SizeOf(Integer) = 2); { BUG - returns 1 }
Check('SizeOf Word', SizeOf(Word) = 2); { BUG - returns 1 }
Check('SizeOf LongInt', SizeOf(LongInt) = 4); { BUG - returns 1 }
Check('SizeOf Real', SizeOf(Real) = 8); { BUG - returns 1 }
Check('SizeOf Pointer', SizeOf(Pointer) = 2); { BUG - returns 1 }
{ Try aliases â does SizeOf work on user-defined type aliases? }
Check('SizeOf TMyInt', SizeOf(TMyInt) = 2); { alias of Integer }
Check('SizeOf TMyWord', SizeOf(TMyWord) = 2); { alias of Word }
Check('SizeOf TMyLong', SizeOf(TMyLong) = 4); { alias of LongInt }
Check('SizeOf TMyReal', SizeOf(TMyReal) = 8); { alias of Real }
Check('SizeOf TMyPtr', SizeOf(TMyPtr) = 2); { alias of Pointer }
WriteLn(' SizeOf(TMyInt) =', SizeOf(TMyInt));
WriteLn(' SizeOf(TMyWord)=', SizeOf(TMyWord));
WriteLn(' SizeOf(TMyLong)=', SizeOf(TMyLong));
WriteLn(' SizeOf(TMyReal)=', SizeOf(TMyReal));
WriteLn(' SizeOf(TMyPtr) =', SizeOf(TMyPtr));
{ Wrap scalars in records â does SizeOf work on the record? }
Check('SizeOf TRInt=2', SizeOf(TRInt) = 2); { record of Integer }
Check('SizeOf TRWord=2', SizeOf(TRWord) = 2); { record of Word }
Check('SizeOf TRLong=4', SizeOf(TRLong) = 4); { record of LongInt }
Check('SizeOf TRReal=8', SizeOf(TRReal) = 8); { record of Real }
Check('SizeOf TRPtr=2', SizeOf(TRPtr) = 2); { record of Pointer }
WriteLn(' SizeOf(TRInt) =', SizeOf(TRInt));
WriteLn(' SizeOf(TRWord)=', SizeOf(TRWord));
WriteLn(' SizeOf(TRLong)=', SizeOf(TRLong));
WriteLn(' SizeOf(TRReal)=', SizeOf(TRReal));
WriteLn(' SizeOf(TRPtr) =', SizeOf(TRPtr));
Check('SizeOf TNode > 0', SizeOf(TNode) > 0);
Check('SizeOf TStr255', SizeOf(TStr255) = 256);
Check('SizeOf TData=25', SizeOf(TData) = 25);
WriteLn(' SizeOf(TNode)=', SizeOf(TNode));
WriteLn(' SizeOf(TData)=', SizeOf(TData));
WriteLn(' SizeOf(TStr255)=', SizeOf(TStr255));
END;
{ ---- Linked list ---- }
PROCEDURE TestLinkedList;
VAR
head, curr, tmp : PNode;
n, sum : Integer;
BEGIN
{ Build list 1->2->3->4->5 }
head := NIL;
FOR i := 5 DOWNTO 1 DO BEGIN
New(curr);
curr^.value := i;
curr^.next := head;
head := curr;
END;
{ Traverse and sum }
sum := 0; n := 0;
curr := head;
WHILE curr <> NIL DO BEGIN
sum := sum + curr^.value;
Inc(n);
curr := curr^.next;
END;
Check('List length', n = 5);
Check('List sum', sum = 15);
{ Find value 3 }
curr := head;
WHILE (curr <> NIL) AND (curr^.value <> 3) DO
curr := curr^.next;
Check('List find 3', (curr <> NIL) AND (curr^.value = 3));
{ Delete list }
curr := head;
WHILE curr <> NIL DO BEGIN
tmp := curr^.next;
Dispose(curr);
curr := tmp;
END;
Check('List disposed', True);
END;
{ ---- Pointer to pointer ---- }
PROCEDURE TestPtrToPtr;
TYPE PPInteger = ^PInteger;
VAR
ppi : PPInteger;
pi2 : PInteger;
BEGIN
New(pi2);
pi2^ := 42;
New(ppi);
ppi^ := pi2;
Check('Ptr to ptr', ppi^^ = 42);
ppi^^ := 99;
Check('Ptr write thru', pi2^ = 99);
Dispose(ppi);
Dispose(pi2);
END;
{ ---- Stack vs heap ---- }
PROCEDURE TestStackHeap;
VAR
localI : Integer;
localArr: ARRAY[1..10] OF Integer;
BEGIN
{ Local variables on stack }
localI := 123;
FOR i := 1 TO 10 DO localArr[i] := i * 2;
Check('Stack local', localI = 123);
Check('Stack array', localArr[5] = 10);
{ Heap allocation inside procedure }
New(pi);
pi^ := 456;
Check('Heap in proc', pi^ = 456);
Dispose(pi);
{ Stack and heap coexist }
New(pi);
pi^ := localI;
Check('Stack+Heap', pi^ = 123);
Dispose(pi);
END;
{ ---- Addr function ---- }
PROCEDURE TestAddr;
VAR
n : Integer;
p : Pointer;
BEGIN
n := 42;
p := Addr(n);
Check('Addr non-nil', p <> NIL);
{ Access via typed pointer cast }
Check('Addr deref', Integer(p^) = 42);
Integer(p^) := 99;
Check('Addr write', n = 99);
END;
{ ---- Main ---- }
BEGIN
WriteLn('=== Section 8: Dynamic Memory and Pointers ===');
WriteLn;
WriteLn('-- New/Dispose --');
TestNewDispose; WriteLn;
WriteLn('-- Multi Alloc --');
TestMultiAlloc; WriteLn;
WriteLn('-- GetMem/FreeMem --');
TestGetFreeMem; WriteLn;
WriteLn('-- Mark/Release --');
TestMarkRelease; WriteLn;
WriteLn('-- MemAvail/MaxAvail --');
TestMemAvail; WriteLn;
WriteLn('-- NIL --');
TestNil; WriteLn;
WriteLn('-- HeapError --');
TestHeapError; WriteLn;
WriteLn('-- SizeOf --');
TestSizeOf; WriteLn;
WriteLn('-- Linked List --');
TestLinkedList; WriteLn;
WriteLn('-- Ptr to Ptr --');
TestPtrToPtr; WriteLn;
WriteLn('-- Stack vs Heap --');
TestStackHeap; WriteLn;
WriteLn('-- Addr --');
TestAddr; WriteLn;
WriteLn('=== Section 8 complete ===');
END.