1 unit memman;
2 
3 interface
4 
getmemorynull5 function getmemory(size:longint):pointer;
6 procedure freememory(var p:pointer;doit:boolean);
7 procedure shownotfree;
8 
9 implementation
10 type
11  pliste=^tliste;
12  tliste=record
13           p:pointer;
14           size:longint;
15           next:pliste;
16         end;
17 var
18  l:pliste;
19 
getmemorynull20 function getmemory(size:longint):pointer;
21 var
22  p:pointer;
23  x:pliste;
24 begin
25  if size<1 then begin writeln('Getmemory Size: ',size); end;
26  getmem(p,size);
27  new(x);
28  if p=nil then begin writeln('Getmem failed!'); halt; end;
29  if x=nil then begin writeln('new(x) in getmemory failed!'); halt; end;
30  x^.p:=p;
31  x^.size:=size;
32  x^.next:=l^.next;
33 
34  l^.next:=x;
35  getmemory:=p;
36 end;
37 
38 procedure shownotfree;
39 var
40  x:pliste;
41  ll:longint;
42 begin
43  x:=l^.next;
44  ll:=0;
45  while x<>nil do begin
46   writeln('Not free',x^.size);
47   inc(ll,x^.size);
48   x:=x^.next;
49  end;
50  if ll<>0 then writeln('Together: ',ll);
51 end;
52 
53 procedure freememory(var p:pointer;doit:boolean);
54 var
55  x,y:pliste;
56  t:pliste;
57 begin
58  if p=nil then begin writeln('FREEMEMORY: NOT FOUND (NIL)'); exit; end;
59  x:=l^.next;
60  y:=l;
61  while x<>Nil do begin
62   if x^.p=p then begin
63 	if doit then begin
64 {			fillchar(p^,x^.size,0)}
65 			freemem(p,x^.size);
66 	end;
67 	y^.next:=x^.next;
68     dispose(x);
69 	p:=nil;
70     exit;
71   end;
72   x:=x^.next;
73   y:=y^.next;
74  end;
75  writeln('FREEMEMORY: NOT FOUND');
76 end;
77 
78 var
79  x:pliste;
80 begin
81  new(x);
82  x^.size:=999999999;
83  x^.p:=nil;
84  x^.next:=nil;
85  l:=x;
86 end.
87