/[pngwrite]/trunk/zutil.pas
ViewVC logotype

Contents of /trunk/zutil.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5