1 unit memman; 2 3 interface 4 getmemorynull5function 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 getmemorynull20function 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