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	torben	2671	// 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