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

Annotation of /trunk/zutil.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Sun Apr 13 19:38:04 2008 UTC (12 years, 6 months ago) by plugwash
File size: 12810 byte(s)
initial import

1 plugwash 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.22