home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / unity / d5 / JRZIP.ZIP / Zlib / ZUTIL.PAS < prev   
Pascal/Delphi Source File  |  2000-05-01  |  13KB  |  547 lines
  1. Unit ZUtil;
  2.  
  3. {
  4.   Copyright (C) 1998 by Jacques Nomssi Nzali
  5.   For conditions of distribution and use, see copyright notice in readme.txt
  6. }
  7.  
  8. interface
  9.  
  10. {$I zconf.inc}
  11.  
  12. { Type declarations }
  13.  
  14. type
  15.   {Byte   = usigned char;  8 bits}
  16.   Bytef  = byte;
  17.   charf  = byte;
  18.  
  19. {$IFDEF FPC}
  20.   int    = longint;
  21. {$ELSE}
  22.   int    = integer;
  23. {$ENDIF}
  24.  
  25.   intf   = int;
  26. {$IFDEF MSDOS}
  27.   uInt   = Word;
  28. {$ELSE}
  29.   {$IFDEF FPC}
  30.     uInt   = longint;     { 16 bits or more }
  31.     {$INFO Cardinal}
  32.   {$ELSE}
  33.     uInt   = cardinal;     { 16 bits or more }
  34.   {$ENDIF}
  35. {$ENDIF}
  36.   uIntf  = uInt;
  37.  
  38.   Long   = longint;
  39. {$ifdef Delphi5}  
  40.   uLong  = Cardinal;
  41. {$else}
  42. //  uLong  = LongInt;      { 32 bits or more }
  43.   uLong = LongWord;           { DelphiGzip: LongInt is Signed, longword not }
  44. {$endif}
  45.   uLongf = uLong;
  46.  
  47.   voidp  = pointer;
  48.   voidpf = voidp;
  49.   pBytef = ^Bytef;
  50.   pIntf  = ^intf;
  51.   puIntf = ^uIntf;
  52.   puLong = ^uLongf;
  53.  
  54.   ptr2int = uInt;
  55. { a pointer to integer casting is used to do pointer arithmetic.
  56.   ptr2int must be an integer type and sizeof(ptr2int) must be less
  57.   than sizeof(pointer) - Nomssi }
  58.  
  59. const
  60.   {$IFDEF MAXSEG_64K}
  61.   MaxMemBlock = $FFFF;
  62.   {$ELSE}
  63.   MaxMemBlock = MaxInt;
  64.   {$ENDIF}
  65.  
  66. type
  67.   zByteArray = array[0..(MaxMemBlock div SizeOf(Bytef))-1] of Bytef;
  68.   pzByteArray = ^zByteArray;
  69. type
  70.   zIntfArray = array[0..(MaxMemBlock div SizeOf(Intf))-1] of Intf;
  71.   pzIntfArray = ^zIntfArray;
  72. type
  73.   zuIntArray = array[0..(MaxMemBlock div SizeOf(uInt))-1] of uInt;
  74.   PuIntArray = ^zuIntArray;
  75.  
  76. { Type declarations - only for deflate }
  77.  
  78. type
  79.   uch  = Byte;
  80.   uchf = uch; { FAR }
  81.   ush  = Word;
  82.   ushf = ush;
  83.   ulg  = LongInt;
  84.  
  85.   unsigned = uInt;
  86.  
  87.   pcharf = ^charf;
  88.   puchf = ^uchf;
  89.   pushf = ^ushf;
  90.  
  91. type
  92.   zuchfArray = zByteArray;
  93.   puchfArray = ^zuchfArray;
  94. type
  95.   zushfArray = array[0..(MaxMemBlock div SizeOf(ushf))-1] of ushf;
  96.   pushfArray = ^zushfArray;
  97.  
  98. procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
  99. function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
  100. procedure zmemzero(destp : pBytef; len : uInt);
  101. procedure zcfree(opaque : voidpf; ptr : voidpf);
  102. function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
  103.  
  104. implementation
  105.  
  106. {$ifdef ver80}
  107.   {$define Delphi16}
  108. {$endif}
  109. {$ifdef ver70}
  110.   {$define HugeMem}
  111. {$endif}
  112. {$ifdef ver60}
  113.   {$define HugeMem}
  114. {$endif}
  115.  
  116. {$IFDEF CALLDOS}
  117. uses
  118.   WinDos;
  119. {$ENDIF}
  120. {$IFDEF Delphi16}
  121. uses
  122.   WinTypes,
  123.   WinProcs;
  124. {$ENDIF}
  125. {$IFNDEF FPC}
  126.   {$IFDEF DPMI}
  127.   uses
  128.     WinAPI;
  129.   {$ENDIF}
  130. {$ENDIF}
  131.  
  132. {$IFDEF CALLDOS}
  133. { reduce your application memory footprint with $M before using this }
  134. function dosAlloc (Size : Longint) : Pointer;
  135. var
  136.   regs: TRegisters;
  137. begin
  138.   regs.bx := (Size + 15) div 16; { number of 16-bytes-paragraphs }
  139.   regs.ah := $48;                { Allocate memory block }
  140.   msdos(regs);
  141.   if regs.Flags and FCarry <> 0 then
  142.     DosAlloc := NIL
  143.   else
  144.     DosAlloc := Ptr(regs.ax, 0);
  145. end;
  146.  
  147.  
  148. function dosFree(P : pointer) : boolean;
  149. var
  150.   regs: TRegisters;
  151. begin
  152.   dosFree := FALSE;
  153.   regs.bx := Seg(P^);             { segment }
  154.   if Ofs(P) <> 0 then
  155.     exit;
  156.   regs.ah := $49;                { Free memory block }
  157.   msdos(regs);
  158.   dosFree := (regs.Flags and FCarry = 0);
  159. end;
  160. {$ENDIF}
  161.  
  162. type
  163.   LH = record
  164.     L, H : word;
  165.   end;
  166.  
  167. {$IFDEF HugeMem}
  168.   {$define HEAP_LIST}
  169. {$endif}
  170.  
  171. {$IFDEF HEAP_LIST} {--- to avoid Mark and Release --- }
  172. const
  173.   MaxAllocEntries = 50;
  174. type
  175.   TMemRec = record
  176.     orgvalue,
  177.     value : pointer;
  178.     size: longint;
  179.   end;
  180. const
  181.   allocatedCount : 0..MaxAllocEntries = 0;
  182. var
  183.   allocatedList : array[0..MaxAllocEntries-1] of TMemRec;
  184.  
  185.  function NewAllocation(ptr0, ptr : pointer; memsize : longint) : boolean;
  186.  begin
  187.    if (allocatedCount < MaxAllocEntries) and (ptr0 <> NIL) then
  188.    begin
  189.      with allocatedList[allocatedCount] do
  190.      begin
  191.        orgvalue := ptr0;
  192.        value := ptr;
  193.        size := memsize;
  194.      end;
  195.      Inc(allocatedCount);  { we don't check for duplicate }
  196.      NewAllocation := TRUE;
  197.    end
  198.    else
  199.      NewAllocation := FALSE;
  200.  end;
  201. {$ENDIF}
  202.  
  203. {$IFDEF HugeMem}
  204.  
  205. { The code below is extremely version specific to the TP 6/7 heap manager!!}
  206. type
  207.   PFreeRec = ^TFreeRec;
  208.   TFreeRec = record
  209.     next: PFreeRec;
  210.     size: Pointer;
  211.   end;
  212. type
  213.   HugePtr = voidpf;
  214.  
  215.  
  216.  procedure IncPtr(var p:pointer;count:word);
  217.  { Increments pointer }
  218.  begin
  219.    inc(LH(p).L,count);
  220.    if LH(p).L < count then
  221.      inc(LH(p).H,SelectorInc);  { $1000 }
  222.  end;
  223.  
  224.  procedure DecPtr(var p:pointer;count:word);
  225.  { decrements pointer }
  226.  begin
  227.    if count > LH(p).L then
  228.      dec(LH(p).H,SelectorInc);
  229.    dec(LH(p).L,Count);
  230.  end;
  231.  
  232.  procedure IncPtrLong(var p:pointer;count:longint);
  233.  { Increments pointer; assumes count > 0 }
  234.  begin
  235.    inc(LH(p).H,SelectorInc*LH(count).H);
  236.    inc(LH(p).L,LH(Count).L);
  237.    if LH(p).L < LH(count).L then
  238.      inc(LH(p).H,SelectorInc);
  239.  end;
  240.  
  241.  procedure DecPtrLong(var p:pointer;count:longint);
  242.  { Decrements pointer; assumes count > 0 }
  243.  begin
  244.    if LH(count).L > LH(p).L then
  245.      dec(LH(p).H,SelectorInc);
  246.    dec(LH(p).L,LH(Count).L);
  247.    dec(LH(p).H,SelectorInc*LH(Count).H);
  248.  end;
  249.  { The next section is for real mode only }
  250.  
  251. function Normalized(p : pointer)  : pointer;
  252. var
  253.   count : word;
  254. begin
  255.   count := LH(p).L and $FFF0;
  256.   Normalized := Ptr(LH(p).H + (count shr 4), LH(p).L and $F);
  257. end;
  258.  
  259. procedure FreeHuge(var p:HugePtr; size : longint);
  260. const
  261.   blocksize = $FFF0;
  262. var
  263.   block : word;
  264. begin
  265.   while size > 0 do
  266.   begin
  267.     { block := minimum(size, blocksize); }
  268.     if size > blocksize then
  269.       block := blocksize
  270.     else
  271.       block := size;
  272.  
  273.     dec(size,block);
  274.     freemem(p,block);
  275.     IncPtr(p,block);    { we may get ptr($xxxx, $fff8) and 31 bytes left }
  276.     p := Normalized(p); { to free, so we must normalize }
  277.   end;
  278. end;
  279.  
  280. function FreeMemHuge(ptr : pointer) : boolean;
  281. var
  282.   i : integer; { -1..MaxAllocEntries }
  283. begin
  284.   FreeMemHuge := FALSE;
  285.   i := allocatedCount - 1;
  286.   while (i >= 0) do
  287.   begin
  288.     if (ptr = allocatedList[i].value) then
  289.     begin
  290.       with allocatedList[i] do
  291.         FreeHuge(orgvalue, size);
  292.  
  293.       Move(allocatedList[i+1], allocatedList[i],
  294.            SizeOf(TMemRec)*(allocatedCount - 1 - i));
  295.       Dec(allocatedCount);
  296.       FreeMemHuge := TRUE;
  297.       break;
  298.     end;
  299.     Dec(i);
  300.   end;
  301. end;
  302.  
  303. procedure GetMemHuge(var p:HugePtr;memsize:Longint);
  304. const
  305.   blocksize = $FFF0;
  306. var
  307.   size : longint;
  308.   prev,free : PFreeRec;
  309.   save,temp : pointer;
  310.   block : word;
  311. begin
  312.   p := NIL;
  313.   { Handle the easy cases first }
  314.   if memsize > maxavail then
  315.     exit
  316.   else
  317.     if memsize <= blocksize then
  318.     begin
  319.       getmem(p, memsize);
  320.       if not NewAllocation(p, p, memsize) then
  321.       begin
  322.         FreeMem(p, memsize);
  323.         p := NIL;
  324.       end;
  325.     end
  326.     else
  327.     begin
  328.       size := memsize + 15;
  329.  
  330.       { Find the block that has enough space }
  331.       prev := PFreeRec(@freeList);
  332.       free := prev^.next;
  333.       while (free <> heapptr) and (ptr2int(free^.size) < size) do
  334.       begin
  335.         prev := free;
  336.         free := prev^.next;
  337.       end;
  338.  
  339.       { Now free points to a region with enough space; make it the first one and
  340.         multiple allocations will be contiguous. }
  341.  
  342.       save := freelist;
  343.       freelist := free;
  344.       { In TP 6, this works; check against other heap managers }
  345.       while size > 0 do
  346.       begin
  347.         { block := minimum(size, blocksize); }
  348.         if size > blocksize then
  349.           block := blocksize
  350.         else
  351.           block := size;
  352.         dec(size,block);
  353.         getmem(temp,block);
  354.       end;
  355.  
  356.       { We've got what we want now; just sort things out and restore the
  357.         free list to normal }
  358.  
  359.       p := free;
  360.       if prev^.next <> freelist then
  361.       begin
  362.         prev^.next := freelist;
  363.         freelist := save;
  364.       end;
  365.  
  366.       if (p <> NIL) then
  367.       begin
  368.         { return pointer with 0 offset }
  369.         temp := p;
  370.         if Ofs(p^)<>0 Then
  371.           p := Ptr(Seg(p^)+1,0);  { hack }
  372.         if not NewAllocation(temp, p, memsize + 15) then
  373.         begin
  374.           FreeHuge(temp, size);
  375.           p := NIL;
  376.         end;
  377.       end;
  378.  
  379.     end;
  380. end;
  381.  
  382. {$ENDIF}
  383.  
  384. procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt);
  385. begin
  386.   Move(sourcep^, destp^, len);
  387. end;
  388.  
  389. function zmemcmp(s1p, s2p : pBytef; len : uInt) : int;
  390. var
  391.   j : uInt;
  392.   source,
  393.   dest : pBytef;
  394. begin
  395.   source := s1p;
  396.   dest := s2p;
  397.   for j := 0 to pred(len) do
  398.   begin
  399.     if (source^ <> dest^) then
  400.     begin
  401.       zmemcmp := 2*Ord(source^ > dest^)-1;
  402.       exit;
  403.     end;
  404.     Inc(source);
  405.     Inc(dest);
  406.   end;
  407.   zmemcmp := 0;
  408. end;
  409.  
  410. procedure zmemzero(destp : pBytef; len : uInt);
  411. begin
  412.   FillChar(destp^, len, 0);
  413. end;
  414.  
  415. procedure zcfree(opaque : voidpf; ptr : voidpf);
  416. {$ifdef Delphi16}
  417. var
  418.   Handle : THandle;
  419. {$endif}
  420. {$IFDEF FPC}
  421. var
  422.   memsize : uint;
  423. {$ENDIF}
  424. begin
  425.   {$IFDEF DPMI}
  426.   {h :=} GlobalFreePtr(ptr);
  427.   {$ELSE}
  428.     {$IFDEF CALL_DOS}
  429.     dosFree(ptr);
  430.     {$ELSE}
  431.       {$ifdef HugeMem}
  432.       FreeMemHuge(ptr);
  433.       {$else}
  434.         {$ifdef Delphi16}
  435.         Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) }
  436.         GlobalUnLock(Handle);
  437.         GlobalFree(Handle);
  438.         {$else}
  439.           {$IFDEF FPC}
  440.           Dec(puIntf(ptr));
  441.           memsize := puIntf(ptr)^;
  442.           FreeMem(ptr, memsize+SizeOf(uInt));
  443.           {$ELSE}
  444.           FreeMem(ptr);  { Delphi 2,3,4 }
  445.           {$ENDIF}
  446.         {$endif}
  447.       {$endif}
  448.     {$ENDIF}
  449.   {$ENDIF}
  450. end;
  451.  
  452. function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf;
  453. var
  454.   p : voidpf;
  455.   memsize : uLong;
  456. {$ifdef Delphi16}
  457.   handle : THandle;
  458. {$endif}
  459. begin
  460.   memsize := uLong(items) * size;
  461.   {$IFDEF DPMI}
  462.   p := GlobalAllocPtr(gmem_moveable, memsize);
  463.   {$ELSE}
  464.     {$IFDEF CALLDOS}
  465.     p := dosAlloc(memsize);
  466.     {$ELSE}
  467.       {$ifdef HugeMem}
  468.       GetMemHuge(p, memsize);
  469.       {$else}
  470.         {$ifdef Delphi16}
  471.         Handle := GlobalAlloc(HeapAllocFlags, memsize);
  472.         p := GlobalLock(Handle);
  473.         {$else}
  474.           {$IFDEF FPC}
  475.           GetMem(p, memsize+SizeOf(uInt));
  476.           puIntf(p)^:= memsize;
  477.           Inc(puIntf(p));
  478.           {$ELSE}
  479.           GetMem(p, memsize);  { Delphi: p := AllocMem(memsize); }
  480.           {$ENDIF}
  481.         {$endif}
  482.       {$endif}
  483.     {$ENDIF}
  484.   {$ENDIF}
  485.   zcalloc := p;
  486. end;
  487.  
  488. {$WARNINGS OFF}
  489. end.
  490.  
  491. { edited from a SWAG posting:
  492.  
  493. In Turbo Pascal 6, the heap is the memory allocated when using the Procedures 'New' and
  494. 'GetMem'. The heap starts at the address location pointed to by 'Heaporg' and
  495. grows to higher addresses as more memory is allocated. The top of the heap,
  496. the first address of allocatable memory space above the allocated memory
  497. space, is pointed to by 'HeapPtr'.
  498.  
  499. Memory is deallocated by the Procedures 'Dispose' and 'FreeMem'. As memory
  500. blocks are deallocated more memory becomes available, but..... When a block
  501. of memory, which is not the top-most block in the heap is deallocated, a gap
  502. in the heap will appear. to keep track of these gaps Turbo Pascal maintains
  503. a so called free list.
  504.  
  505. The Function 'MaxAvail' holds the size of the largest contiguous free block
  506. _in_ the heap. The Function 'MemAvail' holds the sum of all free blocks in
  507. the heap.
  508.  
  509. TP6.0 keeps track of the free blocks by writing a 'free list Record' to the
  510. first eight Bytes of the freed memory block! A (TP6.0) free-list Record
  511. contains two four Byte Pointers of which the first one points to the next
  512. free memory block, the second Pointer is not a Real Pointer but contains the
  513. size of the memory block.
  514.  
  515. Summary
  516.  
  517. TP6.0 maintains a linked list with block sizes and Pointers to the _next_
  518. free block. An extra heap Variable 'Heapend' designate the end of the heap.
  519. When 'HeapPtr' and 'FreeList' have the same value, the free list is empty.
  520.  
  521.  
  522.                      TP6.0     Heapend
  523.                 ┌─────────┐ <────
  524.                 │         │
  525.                 │         │
  526.                 │         │
  527.                 │         │
  528.                 │         │
  529.                 │         │
  530.                 │         │
  531.                 │         │  HeapPtr
  532.              ┌─>├─────────┤ <────
  533.              │  │         │
  534.              │  ├─────────┤
  535.              └──│  Free   │
  536.              ┌─>├─────────┤
  537.              │  │         │
  538.              │  ├─────────┤
  539.              └──│  Free   │  FreeList
  540.                 ├─────────┤ <────
  541.                 │         │  Heaporg
  542.                 ├─────────┤ <────
  543.  
  544.  
  545. }
  546. {$WARNINGS ON}
  547.