tpsystools_4.04/source/StUtils.pas

// Upgraded to Delphi 2009: Sebastian Zierer

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StUtils.pas 4.04                            *}
{*********************************************************}
{* SysTools: Assorted utility routines                   *}
{*********************************************************}

{$I StDefine.inc}

unit StUtils;

interface

uses
  Windows, SysUtils, Classes,

  StConst, StBase, StDate,
  StStrL; { long string routines }

function SignL(L : LongInt) : Integer;
  {-return sign of LongInt value}
function SignF(F : Extended) : Integer;
  {-return sign of floating point value}

function MinWord(A, B : Word) : Word;
  {-Return the smaller of A and B}
function MidWord(W1, W2, W3 : Word) : Word;
  {-return the middle of three Word values}
function MaxWord(A, B : Word) : Word;
  {-Return the greater of A and B}

function MinLong(A, B : LongInt) : LongInt;
  {-Return the smaller of A and B}
function MidLong(L1, L2, L3 : LongInt) : LongInt;
  {-return the middle of three LongInt values}
function MaxLong(A, B : LongInt) : LongInt;
  {-Return the greater of A and B}

function MinFloat(F1, F2 : Extended) : Extended;
  {-return the lesser of two floating point values}
function MidFloat(F1, F2, F3 : Extended) : Extended;
  {-return the middle of three floating point values}
function MaxFloat(F1, F2 : Extended) : Extended;
  {-return the greater of two floating point values}

{-Assorted utility routines. }

function MakeInteger16(H, L : Byte): SmallInt;
  {-Construct an integer from two bytes}

function MakeWord(H, L : Byte) : Word;
  {-Construct a word from two bytes}

function SwapNibble(B : Byte) : Byte;
  {-Swap the high and low nibbles of a byte}

function SwapWord(L : LongInt) : LongInt;
  {-Swap the low- and high-order words of a long integer}

procedure SetFlag(var Flags : Word; FlagMask : Word);
  {-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}

procedure ClearFlag(var Flags : Word; FlagMask : Word);
  {-Clear bit(s) in the parameter Flags. The bits to clear are specified in Flagmask}

function FlagIsSet(Flags, FlagMask : Word) : Boolean;
  {-Return True if the bit specified by FlagMask is set in Flags}

procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
  {-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}

procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
  {-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}

function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
  {-Return True if the bit specified by FlagMask is set in the Flags parameter}

procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
  {-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}


procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
  {-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}


function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
  {-Return True if the bit specified by FlagMask is set in Flags}

procedure ExchangeBytes(var I, J : Byte);
  {-Exchange the values in two bytes}

procedure ExchangeWords(var I, J : Word);
  {-Exchange the values in two words}

procedure ExchangeLongInts(var I, J : LongInt);
  {-Exchange the values in two long integers}

procedure ExchangeStructs(var I, J; Size : Cardinal);
  {-Exchange the values in two structures}


procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
  {-Fill memory with a word-sized filler}

procedure FillStruct(var Dest; Count : Cardinal; var Filler; FillerSize : Cardinal);
  {-Fill memory with a variable sized filler}

function AddWordToPtr(P : Pointer; W : Word) : Pointer;
  {-Add a word to a pointer.}

implementation

const
  ecOutOfMemory = 8;

function MakeInteger16(H, L : Byte): SmallInt;
begin
  Word(Result) := (H shl 8) or L;  {!!.02}
end;

function SwapNibble(B : Byte) : Byte;
begin
  Result := (B shr 4) or (B shl 4);
end;

function SwapWord(L : LongInt) : LongInt; register;
asm
  ror eax,16;
end;

procedure SetFlag(var Flags : Word; FlagMask : Word);
begin
  Flags := Flags or FlagMask;
end;

procedure ClearFlag(var Flags : Word; FlagMask : Word);
begin
  Flags := Flags and (not FlagMask);
end;


function FlagIsSet(Flags, FlagMask : Word) : Boolean;
begin
  Result := (FlagMask AND Flags <> 0);
end;

procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
begin
  Flags := Flags or FlagMask;
end;

procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
begin
  Flags := Flags and (not FlagMask);
end;

function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
begin
  Result := (FlagMask AND Flags <> 0);
end;

procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
begin
  Flags := Flags or FlagMask;
end;

procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
begin
  Flags := Flags and (not FlagMask);
end;

function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
begin
  Result := FlagMask = (Flags and FlagMask);
end;

procedure ExchangeBytes(var I, J : Byte);
register;
asm
  mov  cl, [eax]
  mov  ch, [edx]
  mov  [edx], cl
  mov  [eax], ch
end;

procedure ExchangeWords(var I, J : Word);
register;
asm
  mov  cx, [eax]
  push ecx
  mov  cx, [edx]
  mov  [eax], cx
  pop  ecx
  mov  [edx], cx
end;

procedure ExchangeLongInts(var I, J : LongInt);
register;
asm
  mov  ecx, [eax]
  push ecx
  mov  ecx, [edx]
  mov  [eax], ecx
  pop  ecx
  mov  [edx], ecx
end;

procedure ExchangeStructs(var I, J; Size : Cardinal);
register;
asm
  push edi
  push ebx
  push ecx
  shr  ecx, 2
  jz   @@LessThanFour

@@AgainDWords:
  mov  ebx, [eax]
  mov  edi, [edx]
  mov  [edx], ebx
  mov  [eax], edi
  add  eax, 4
  add  edx, 4
  dec  ecx
  jnz  @@AgainDWords

@@LessThanFour:
  pop  ecx
  and  ecx, $3
  jz   @@Done
  mov  bl, [eax]
  mov  bh, [edx]
  mov  [edx], bl
  mov  [eax], bh
  inc  eax
  inc  edx
  dec  ecx
  jz   @@Done

  mov  bl, [eax]
  mov  bh, [edx]
  mov  [edx], bl
  mov  [eax], bh
  inc  eax
  inc  edx
  dec  ecx
  jz   @@Done

  mov  bl, [eax]
  mov  bh, [edx]
  mov  [edx], bl
  mov  [eax], bh

@@Done:
  pop  ebx
  pop  edi
end;

procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
asm
  push edi
  mov   edi,Dest
  mov   ax,Filler
  mov   ecx,Count
  cld
  rep  stosw
  pop   edi
end;

procedure FillStruct(var Dest; Count : Cardinal; var Filler;
  FillerSize : Cardinal);
register;
asm
  or   edx, edx
  jz   @@Exit

  push edi
  push esi
  push ebx
  mov  edi, eax
  mov  ebx, ecx

@@NextStruct:
  mov  esi, ebx
  mov  ecx, FillerSize
  shr  ecx, 1
  rep  movsw
  adc  ecx, ecx
  rep  movsb
  dec  edx
  jnz  @@NextStruct

  pop  ebx
  pop  esi
  pop  edi

@@Exit:
end;

function AddWordToPtr(P : Pointer; W : Word) : Pointer;
begin
  Result := Pointer(LongInt(P)+W);
end;

function MakeWord(H, L : Byte) : Word;
begin
  Result := (Word(H) shl 8) or L;
end;

function MinWord(A, B : Word) : Word;
begin
  if A < B then
     Result := A
  else
     Result := B;
end;

function MaxWord(A, B : Word) : Word;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;

function MinLong(A, B : LongInt) : LongInt;
begin
  if A < B then
    Result := A
  else
    Result := B;
end;

function MaxLong(A, B : LongInt) : LongInt;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;

function SignL(L : LongInt) : Integer;
  {-return sign of LongInt value}
begin
  if L < 0 then
    Result := -1
  else if L = 0 then
    Result := 0
  else
    Result := 1;
end;

function SignF(F : Extended) : Integer;
  {-return sign of floating point value}
begin
  if F < 0 then
    Result := -1
  else if F = 0 then
    Result := 0
  else
    Result := 1;
end;

function MidWord(W1, W2, W3 : Word) : Word;
  {return the middle of three Word values}
begin
  Result := StUtils.MinWord(StUtils.MinWord(StUtils.MaxWord(W1, W2),
                            StUtils.MaxWord(W2, W3)), StUtils.MaxWord(W1, W3));
end;

function MidLong(L1, L2, L3 : LongInt) : LongInt;
  {return the middle of three LongInt values}
begin
  Result := StUtils.MinLong(StUtils.MinLong(StUtils.MaxLong(L1, L2),
                            StUtils.MaxLong(L2, L3)), StUtils.MaxLong(L1, L3));
end;

function MidFloat(F1, F2, F3 : Extended) : Extended;
  {return the middle of three floating point values}
begin
  Result := MinFloat(MinFloat(MaxFloat(F1, F2), MaxFloat(F2, F3)), MaxFloat(F1, F3));
end;

function MinFloat(F1, F2 : Extended) : Extended;
  {-return the lesser of two floating point values}
begin
  if F1 <= F2 then
    Result := F1
  else
    Result := F2;
end;

function MaxFloat(F1, F2 : Extended) : Extended;
  {-return the greater of two floating point values}
begin
  if F1 > F2 then
    Result := F1
  else
    Result := F2;
end;


end.


1	// Upgraded to Delphi 2009: Sebastian Zierer
2
3	(* *** BEGIN LICENSE BLOCK ***
4	* Version: MPL 1.1
5	*
6	* The contents of this file are subject to the Mozilla Public License Version
7	* 1.1 (the "License"); you may not use this file except in compliance with
8	* the License. You may obtain a copy of the License at
9	* http://www.mozilla.org/MPL/
10	*
11	* Software distributed under the License is distributed on an "AS IS" basis,
12	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13	* for the specific language governing rights and limitations under the
14	* License.
15	*
16	* The Original Code is TurboPower SysTools
17	*
18	* The Initial Developer of the Original Code is
19	* TurboPower Software
20	*
21	* Portions created by the Initial Developer are Copyright (C) 1996-2002
22	* the Initial Developer. All Rights Reserved.
23	*
24	* Contributor(s):
25	*
26	* *** END LICENSE BLOCK *** *)
27
28	{*********************************************************}
29	{* SysTools: StUtils.pas 4.04 *}
30	{*********************************************************}
31	{* SysTools: Assorted utility routines *}
32	{*********************************************************}
33
34	{$I StDefine.inc}
35
36	unit StUtils;
37
38	interface
39
40	uses
41	Windows, SysUtils, Classes,
42
43	StConst, StBase, StDate,
44	StStrL; { long string routines }
45
46	function SignL(L : LongInt) : Integer;
47	{-return sign of LongInt value}
48	function SignF(F : Extended) : Integer;
49	{-return sign of floating point value}
50
51	function MinWord(A, B : Word) : Word;
52	{-Return the smaller of A and B}
53	function MidWord(W1, W2, W3 : Word) : Word;
54	{-return the middle of three Word values}
55	function MaxWord(A, B : Word) : Word;
56	{-Return the greater of A and B}
57
58	function MinLong(A, B : LongInt) : LongInt;
59	{-Return the smaller of A and B}
60	function MidLong(L1, L2, L3 : LongInt) : LongInt;
61	{-return the middle of three LongInt values}
62	function MaxLong(A, B : LongInt) : LongInt;
63	{-Return the greater of A and B}
64
65	function MinFloat(F1, F2 : Extended) : Extended;
66	{-return the lesser of two floating point values}
67	function MidFloat(F1, F2, F3 : Extended) : Extended;
68	{-return the middle of three floating point values}
69	function MaxFloat(F1, F2 : Extended) : Extended;
70	{-return the greater of two floating point values}
71
72	{-Assorted utility routines. }
73
74	function MakeInteger16(H, L : Byte): SmallInt;
75	{-Construct an integer from two bytes}
76
77	function MakeWord(H, L : Byte) : Word;
78	{-Construct a word from two bytes}
79
80	function SwapNibble(B : Byte) : Byte;
81	{-Swap the high and low nibbles of a byte}
82
83	function SwapWord(L : LongInt) : LongInt;
84	{-Swap the low- and high-order words of a long integer}
85
86	procedure SetFlag(var Flags : Word; FlagMask : Word);
87	{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
88
89	procedure ClearFlag(var Flags : Word; FlagMask : Word);
90	{-Clear bit(s) in the parameter Flags. The bits to clear are specified in Flagmask}
91
92	function FlagIsSet(Flags, FlagMask : Word) : Boolean;
93	{-Return True if the bit specified by FlagMask is set in Flags}
94
95	procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
96	{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
97
98	procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
99	{-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
100
101	function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
102	{-Return True if the bit specified by FlagMask is set in the Flags parameter}
103
104	procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
105	{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
106
107
108	procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
109	{-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
110
111
112	function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
113	{-Return True if the bit specified by FlagMask is set in Flags}
114
115	procedure ExchangeBytes(var I, J : Byte);
116	{-Exchange the values in two bytes}
117
118	procedure ExchangeWords(var I, J : Word);
119	{-Exchange the values in two words}
120
121	procedure ExchangeLongInts(var I, J : LongInt);
122	{-Exchange the values in two long integers}
123
124	procedure ExchangeStructs(var I, J; Size : Cardinal);
125	{-Exchange the values in two structures}
126
127
128	procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
129	{-Fill memory with a word-sized filler}
130
131	procedure FillStruct(var Dest; Count : Cardinal; var Filler; FillerSize : Cardinal);
132	{-Fill memory with a variable sized filler}
133
134	function AddWordToPtr(P : Pointer; W : Word) : Pointer;
135	{-Add a word to a pointer.}
136
137	implementation
138
139	const
140	ecOutOfMemory = 8;
141
142	function MakeInteger16(H, L : Byte): SmallInt;
143	begin
144	Word(Result) := (H shl 8) or L; {!!.02}
145	end;
146
147	function SwapNibble(B : Byte) : Byte;
148	begin
149	Result := (B shr 4) or (B shl 4);
150	end;
151
152	function SwapWord(L : LongInt) : LongInt; register;
153	asm
154	ror eax,16;
155	end;
156
157	procedure SetFlag(var Flags : Word; FlagMask : Word);
158	begin
159	Flags := Flags or FlagMask;
160	end;
161
162	procedure ClearFlag(var Flags : Word; FlagMask : Word);
163	begin
164	Flags := Flags and (not FlagMask);
165	end;
166
167
168	function FlagIsSet(Flags, FlagMask : Word) : Boolean;
169	begin
170	Result := (FlagMask AND Flags <> 0);
171	end;
172
173	procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
174	begin
175	Flags := Flags or FlagMask;
176	end;
177
178	procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
179	begin
180	Flags := Flags and (not FlagMask);
181	end;
182
183	function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
184	begin
185	Result := (FlagMask AND Flags <> 0);
186	end;
187
188	procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
189	begin
190	Flags := Flags or FlagMask;
191	end;
192
193	procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
194	begin
195	Flags := Flags and (not FlagMask);
196	end;
197
198	function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
199	begin
200	Result := FlagMask = (Flags and FlagMask);
201	end;
202
203	procedure ExchangeBytes(var I, J : Byte);
204	register;
205	asm
206	mov cl, [eax]
207	mov ch, [edx]
208	mov [edx], cl
209	mov [eax], ch
210	end;
211
212	procedure ExchangeWords(var I, J : Word);
213	register;
214	asm
215	mov cx, [eax]
216	push ecx
217	mov cx, [edx]
218	mov [eax], cx
219	pop ecx
220	mov [edx], cx
221	end;
222
223	procedure ExchangeLongInts(var I, J : LongInt);
224	register;
225	asm
226	mov ecx, [eax]
227	push ecx
228	mov ecx, [edx]
229	mov [eax], ecx
230	pop ecx
231	mov [edx], ecx
232	end;
233
234	procedure ExchangeStructs(var I, J; Size : Cardinal);
235	register;
236	asm
237	push edi
238	push ebx
239	push ecx
240	shr ecx, 2
241	jz @@LessThanFour
242
243	@@AgainDWords:
244	mov ebx, [eax]
245	mov edi, [edx]
246	mov [edx], ebx
247	mov [eax], edi
248	add eax, 4
249	add edx, 4
250	dec ecx
251	jnz @@AgainDWords
252
253	@@LessThanFour:
254	pop ecx
255	and ecx, $3
256	jz @@Done
257	mov bl, [eax]
258	mov bh, [edx]
259	mov [edx], bl
260	mov [eax], bh
261	inc eax
262	inc edx
263	dec ecx
264	jz @@Done
265
266	mov bl, [eax]
267	mov bh, [edx]
268	mov [edx], bl
269	mov [eax], bh
270	inc eax
271	inc edx
272	dec ecx
273	jz @@Done
274
275	mov bl, [eax]
276	mov bh, [edx]
277	mov [edx], bl
278	mov [eax], bh
279
280	@@Done:
281	pop ebx
282	pop edi
283	end;
284
285	procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
286	asm
287	push edi
288	mov edi,Dest
289	mov ax,Filler
290	mov ecx,Count
291	cld
292	rep stosw
293	pop edi
294	end;
295
296	procedure FillStruct(var Dest; Count : Cardinal; var Filler;
297	FillerSize : Cardinal);
298	register;
299	asm
300	or edx, edx
301	jz @@Exit
302
303	push edi
304	push esi
305	push ebx
306	mov edi, eax
307	mov ebx, ecx
308
309	@@NextStruct:
310	mov esi, ebx
311	mov ecx, FillerSize
312	shr ecx, 1
313	rep movsw
314	adc ecx, ecx
315	rep movsb
316	dec edx
317	jnz @@NextStruct
318
319	pop ebx
320	pop esi
321	pop edi
322
323	@@Exit:
324	end;
325
326	function AddWordToPtr(P : Pointer; W : Word) : Pointer;
327	begin
328	Result := Pointer(LongInt(P)+W);
329	end;
330
331	function MakeWord(H, L : Byte) : Word;
332	begin
333	Result := (Word(H) shl 8) or L;
334	end;
335
336	function MinWord(A, B : Word) : Word;
337	begin
338	if A < B then
339	Result := A
340	else
341	Result := B;
342	end;
343
344	function MaxWord(A, B : Word) : Word;
345	begin
346	if A > B then
347	Result := A
348	else
349	Result := B;
350	end;
351
352	function MinLong(A, B : LongInt) : LongInt;
353	begin
354	if A < B then
355	Result := A
356	else
357	Result := B;
358	end;
359
360	function MaxLong(A, B : LongInt) : LongInt;
361	begin
362	if A > B then
363	Result := A
364	else
365	Result := B;
366	end;
367
368	function SignL(L : LongInt) : Integer;
369	{-return sign of LongInt value}
370	begin
371	if L < 0 then
372	Result := -1
373	else if L = 0 then
374	Result := 0
375	else
376	Result := 1;
377	end;
378
379	function SignF(F : Extended) : Integer;
380	{-return sign of floating point value}
381	begin
382	if F < 0 then
383	Result := -1
384	else if F = 0 then
385	Result := 0
386	else
387	Result := 1;
388	end;
389
390	function MidWord(W1, W2, W3 : Word) : Word;
391	{return the middle of three Word values}
392	begin
393	Result := StUtils.MinWord(StUtils.MinWord(StUtils.MaxWord(W1, W2),
394	StUtils.MaxWord(W2, W3)), StUtils.MaxWord(W1, W3));
395	end;
396
397	function MidLong(L1, L2, L3 : LongInt) : LongInt;
398	{return the middle of three LongInt values}
399	begin
400	Result := StUtils.MinLong(StUtils.MinLong(StUtils.MaxLong(L1, L2),
401	StUtils.MaxLong(L2, L3)), StUtils.MaxLong(L1, L3));
402	end;
403
404	function MidFloat(F1, F2, F3 : Extended) : Extended;
405	{return the middle of three floating point values}
406	begin
407	Result := MinFloat(MinFloat(MaxFloat(F1, F2), MaxFloat(F2, F3)), MaxFloat(F1, F3));
408	end;
409
410	function MinFloat(F1, F2 : Extended) : Extended;
411	{-return the lesser of two floating point values}
412	begin
413	if F1 <= F2 then
414	Result := F1
415	else
416	Result := F2;
417	end;
418
419	function MaxFloat(F1, F2 : Extended) : Extended;
420	{-return the greater of two floating point values}
421	begin
422	if F1 > F2 then
423	Result := F1
424	else
425	Result := F2;
426	end;
427
428
429	end.
430
431
432