zutil.pas

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