home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
t
/
twu1.zip
/
TWU1EQU.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-06-03
|
14KB
|
408 lines
{ ------------------------------------------------------------- }
{ This UNIT defines CONSTs, TYPEs, PROCEDUREs and FUNCTIONs of }
{ general utility to the program. It also enables a Heap Error }
{ Function which causes the Heap Manager to return NIL if any }
{ Heap Allocation Request (NEW or GETMEM) finds insufficient }
{ Heap Space to satisfy the request. Two variables are defined }
{ which allow tracking of Heap utilization to be performed by a }
{ using program. There is very little in this unit that is }
{ specific to ".TPU" files per-se. }
{ ------------------------------------------------------------- }
Unit TWU1EQU;
(*****************)
(**) INTERFACE (**) Uses Dos;
(*****************)
Const
_FilNamLen = SizeOf(Dos.NameStr)+SizeOf(Dos.ExtStr)-2;
_FilDirLen = SizeOf(Dos.DirStr)-1+_FilNamLen;
Type
_FileSpec = String[_FilNamLen]; { Max Size of Name.Extension }
_FileXpnd = String[_FilDirLen]; { Max Size of above plus Path }
_StrByte = String[2]; { String for Hex Byte Display }
_StrWord = String[4]; { String for Hex Word Display }
_StrAddr = String[5]; { String for Hex Addr Display }
_DateStr = String[10]; { String for Date/Time Display }
_Paragraph= Array[0..15] of Byte; { 8086 Paragraph Size }
_Compare = Function(VAR A,B):Boolean; { QuickSort Calls This }
Var _HeapHighWaterMark, { Max Heap Utilization Pointer }
_HeapOriginalMark : Pointer; { Min Heap Utilization Pointer }
Function PtrDelta(P,Q: Pointer): LongInt; { Pointer Differential }
Function HexB(Arg:Byte): _StrByte; { Byte to Hex String }
Function HexW(Arg:Word): _StrWord; { Word to Hex String }
Function HexA(Arg:LongInt): _StrAddr; { Addr to Hex String }
Function FormatDate(Date: Word): _DateStr; { Date Stamp to String }
Function FormatTime(Time: Word): _DateStr; { Time Stamp to String }
Procedure QuickSort(V: Pointer; { To Array of Records }
Cnt: Word; { Record Count }
Len: Word; { Record Length }
ALessB: _Compare); { Compare Function }
Procedure TrimString(VAR S: String); { Removes Trailing Blanks }
function LoWord(A: LongInt): Word;
inline(
$58/ { POP AX }
$5A); { POP DX }
function HiWord(A: LongInt): Word;
inline(
$5A/ { POP DX }
$58); { POP AX }
function LoByte(A: Word): Byte;
inline(
$5A/ { POP AX }
$32/$E4); { XOR AH,AH }
function HiByte(A: Word): Byte;
inline(
$5A/ { POP AX }
$8A/$C4/ { MOV AL,AH }
$32/$E4); { XOR AH,AH }
Function PtrAdjust(A: Pointer; I: Word):Pointer;
INLINE( $5A/ { POP DX ;I }
$58/ { POP AX ;Ofs(A^) }
$03/$C2/ { ADD AX,DX ;Ofs(A^)+I }
$5A); { POP DX ;Seg(A^) }
(**********************)
(**) IMPLEMENTATION (**)
(**********************)
{ Procedure Below Removes Trailing Blanks from a String } {.CP27}
Procedure TrimString(VAR S: String);
{ begin while (Length(S)>0) AND (S[Length(S)]=' ') Do
Delete(S,Length(s),1) end }
ASSEMBLER; {$S-}
ASM
LES DI,S { Get String Pointer }
MOV CX,ES { Get Segment Value }
CMP CX,DI { Check for Nil Pointer }
JNZ @RUN { Don't Match-Not Nil }
JCXZ @SKIP { Nil if Selector zero }
@RUN:
XOR CX,CX { Clean-Up CX }
MOV CL,ES:[DI] { Fetch String Length }
JCXZ @SKIP { Exit if Null String }
STD { Set RTL Direction }
MOV DX,DI { Save String Offset }
MOV AL,' ' { Load Blank Comparand }
ADD DI,CX { Point to String End }
REPZ SCASB { Scan for Non-Blank }
JZ @NONE { NONE FOUND }
INC CX { Repair CX }
@NONE:
MOV DI,DX { Point to String }
MOV ES:[DI],CL { Save New Length Byte }
@SKIP:
END; {$S+}
{ Function Below Computes the SIGNED Difference between the } {.CP36}
{ EFFECTIVE Values of two pointers, P and Q. The result is }
{ negative if P^ < Q^, non-negative otherwise. }
Function PtrDelta(P, Q: Pointer): LongInt; { Pointer Differential }
(* --------------------- Equivalent Pascal Code
Var Lp, Lq : LongInt;
Begin
Lp := LongInt(Seg(P^)) SHL 4 + Ofs(P^); { Convert P to LongInt }
Lq := LongInt(Seg(Q^)) SHL 4 + Ofs(Q^); { Convert Q to LongInt }
PtrDelta := Lp - Lq; { Return Difference }
*)
ASSEMBLER; {$S-}
ASM
MOV CL,04h { Set Shift Amount }
XOR DH,DH { Zero DH }
LES DI,[DWORD PTR P] { Fetch P to ES:DI }
MOV AX,ES { AX = Seg(P^) }
MOV DL,AH { Copy Hi Byte to DL }
SHR DL,CL { Align Hi Bits in DL }
SHL AX,CL { Align Lo Bits in AX }
ADD DI,AX { Lo Order Sum in DI }
ADC DX,0 { Hi Order Sum in DX }
{ DX:DI = LongInt(P^) }
XOR BH,BH
LES SI,[DWORD PTR Q] { Fetch Q to ES:SI }
MOV AX,ES { AX = Seg(Q^) }
MOV BL,AH { Copy Hi Byte to BL }
SHR BL,CL { Align Hi Bits in BL }
SHL AX,CL { Align Lo Bits in AX }
ADD SI,AX { Lo Order Sum in SI }
ADC BX,0 { Hi Order Sum in BX }
MOV AX,DI { AX = LO(LongInt(P^)) }
SUB AX,SI { AX = Lo Difference }
SBB DX,BX { DX = Hi Difference }
End; {PtrDelta} {$S+}
{ Function Below Formats Directory Time-Stamp for Display } {.CP44}
Function FormatTime(Time : Word): _DateStr;
VAR Ww: _DateStr;
BEGIN
ASM { Emit Tight Fast Code }
CLD { Clear Direction Flag }
MOV AX,SS { Load String Segment }
MOV ES,AX
LEA DI,[BYTE PTR Ww] { Load String Offset }
MOV AL,8 { String Length = 8 }
STOSB
MOV DX,'00' { Load ASCII Zero Zones }
MOV AX,Time { Fetch Time }
MOV CL,11 { Set Shift Bit Count }
SHR AX,CL { Align Hours }
CALL @Emit { Encode and Store it }
MOV AL,':' { Insert : after Hours }
STOSB
MOV AX,Time { Fetch Time }
MOV CL,5 { Set Shift Bit Count }
SHR AX,CL { Align Minutes }
AND AL,3Fh { Extract Minutes }
CALL @Emit { Encode and Store it }
MOV AL,':' { Insert : after Minutes}
STOSB
MOV AL,[Byte Ptr Time] { Fetch Low Time Byte }
AND AL,1Fh { Extract Seconds / 2 }
SHL AL,1 { Convert to Seconds }
CALL @Emit { Encode and Store it }
JMP @Exit { Skip Around Proc }
@Emit:
AAM { Convert AL to Decimal }
XCHG AH,AL { Swap Resulting Digits }
OR AX,DX { Add ASCII Zones }
STOSW { Store String Result }
RETN { Return to caller }
@Exit:
End;
FormatTime := Ww;
END; {FormatTime}
{ Function Below Formats Directory Date-Stamp for Display } {.CP49}
Function FormatDate(Date : Word): _DateStr;
VAR Ww: _DateStr;
BEGIN
ASM { Emit Tight Fast Code }
CLD { Clear Direction Flag }
MOV AX,SS { Load String Segment }
MOV ES,AX
LEA DI,[BYTE PTR Ww] { Load String Offset }
MOV AL,10 { String Length = 10 }
STOSB
MOV DX,'00' { Load ASCII Zero Zones }
MOV AX,Date { Fetch Date }
MOV CL,5 { Set Shift Bit Count }
SHR AX,CL { Align Month }
AND AL,0Fh { Extract Month }
CALL @Emit { Encode and Store it }
MOV AL,'/' { Insert / after Month }
STOSB
MOV AL,[Byte Ptr Date] { Fetch Date }
AND AL,1Fh { Extract Day of Month }
CALL @Emit { Encode and Store it }
MOV AL,'/' { Insert / after Day }
STOSB
MOV CL,9 { Set Shift Bit Count }
MOV AX,Date { Fetch Date }
SHR AX,CL { Align Year Bits }
ADD AX,1980 { Add 1980 }
MOV BL,100 { Set up Divisor }
DIV BL { AH= Year, AL= Century }
MOV BL,AH { Save Year Byte }
CALL @Emit { Encode and Store Cent }
MOV AX,BX { Fetch Year Byte }
CALL @Emit { Encode and Store Year }
JMP @Exit { Skip Around Proc }
@Emit:
AAM { Convert AL to Decimal }
XCHG AH,AL { Swap Resulting Digits }
OR AX,DX { Add ASCII Zones }
STOSW { Store String Result }
RETN { Return to caller }
@Exit:
End;
FormatDate := Ww;
END; {FormatDate}
{ Function Below Converts a byte to Printable Hex } {.CP22}
(*
FUNCTION HexB(Arg:byte): _StrByte;
CONST HexTab : ARRAY[0..15] OF Char = '0123456789ABCDEF';
BEGIN HexB := HexTab[Arg SHR 4] + HexTab[Arg AND $F] END;
*)
{$S-} FUNCTION HexB(Arg:byte): _StrByte; ASSEMBLER;
CONST HexTab : ARRAY[0..15] OF Char = '0123456789ABCDEF';
ASM
LES DI,@RESULT { Point to Function Result }
MOV AX,2 { Get Result String Length }
STOSB { Store in Result String }
LEA BX,HexTab { Point to Translate Table }
MOV AL,Arg { Fetch Argument Byte }
MOV CL,4 { Set Shift Counter }
SHL AX,CL { Put Hi Nibble in AH }
SHR AL,CL { Put Lo Nibble in AL }
XLAT { Translate Lo Nibble }
XCHG AH,AL { Swap Hi and Lo Nibbles }
XLAT { Translate Hi Nibble }
STOSW { Emit Translated Nibbles }
END; {HexB}{$S+}
{ Function Below Converts a Word to Printable Hex } {.CP04}
FUNCTION HexW(Arg:Word): _StrWord;
BEGIN HexW := HexB(HI(Arg)) + HexB(LO(Arg)) END;
{ Function Below Converts a Addr to Printable Hex } {.CP08}
FUNCTION HexA(Arg:LongInt): _StrAddr;
Var PreFix : _StrByte;
BEGIN
PreFix := HexB(LoByte(HiWord(Arg)));
HexA := PreFix[2] + HexW(LoWord(Arg))
END;
{ Heap Error Function Returns NIL if Allocation Fails } {.CP11}
Function HeapErrorProc(Arg : Word): Integer; FAR;
Begin
If Arg = 0 Then { Heap Pointer Being Raised }
If PtrDelta(System.HeapPtr,_HeapHighWaterMark) > 0
Then _HeapHighWaterMark := System.HeapPtr;
HeapErrorProc := 1; { Allow NIL Return by HeapMgr }
End; {HeapErrorProc}
{ --------------------------------------------------------------- }
{ QuickSort Algorithm by C.A.R. Hoare. Non-Recursive adaptation }
{ from "ALGORITHMS + DATA STRUCTURES = PROGRAMS" by Niklaus Wirth }
{ Prentice-Hall, 1976. Generalized for untyped arguments. }
{ --------------------------------------------------------------- }
Procedure QuickSort(V: Pointer; { To Array of Records }
Cnt: Word; { Record Count }
Len: Word; { Record Length }
ALessB: _Compare); { Compare Function }
Type SortRec = Record Lt, Rt: Integer End;
SortStak = Array[0..1] of SortRec;
Var StkT, StkM, Ki, Kj, M: Word; Rt, Lt, I, J: Integer;
Ps: ^SortStak; Pw, Px: Pointer;
Procedure Push(Left, Right: Integer);
Begin Ps^[StkT].Lt := Left; Ps^[StkT].Rt := Right; Inc(StkT); End;
Procedure Pop(VAR Left, Right: Integer);
Begin Dec(StkT); Left := Ps^[StkT].Lt; Right := Ps^[StkT].Rt; End;
Begin {QSort}
If (Cnt > 1) AND (V <> Nil) Then
Begin
StkT := Cnt - 1; { Record Count - 1 }
Lt := 1; { Safety Valve }
{ We need a stack of Log2(n-1) entries plus 1 spare for safety }
Repeat StkT := StkT SHR 1; Inc(Lt); Until StkT = 0; { 1+Log2(n-1) }
StkM := Lt * SizeOf(SortRec) + Len + Len; { Stack Size + 2 records }
GetMem(Ps,StkM); { Allocate Memory }
If Ps = Nil Then RunError(215); { Catastrophic Error }
Pw := @Ps^[Lt]; { Swap Area Pointer }
Px := Ptr(Seg(Pw^),Ofs(Pw^)+Len); { Hold Area Pointer }
Lt := 0; Rt := Cnt - 1; { Initial Partition }
Push(Lt,Rt); { Push Entire Table }
WHILE StkT > 0 Do Begin { QuickSort Main Loop }
Pop(Lt,Rt); { Get Next Partition }
Repeat
I := Lt; J := Rt; { Set Work Pointers }
{ Save Record at Partition Mid-Point in Hold Area }
M := (LongInt(Lt) + Rt) DIV 2;
Move(Ptr(Seg(V^),Ofs(V^)+ M * Len)^,Px^,Len);
{ Get Useful Offsets to speed loops }
Ki := I * Len + Ofs(V^); Kj := J * Len + Ofs(V^);
Repeat
{ Find Left-Most Entry >= Mid-Point Entry }
While ALessB(Ptr(Seg(V^),Ki)^,Px^) Do
Begin Inc(Ki,Len); Inc(I) End;
{ Find Right-Most Entry <= Mid-Point Entry }
While ALessB(Px^,Ptr(Seg(V^),Kj)^) Do
Begin Dec(Kj,Len); Dec(J) End;
{ If I > J, the partition has been exhausted }
If I <= J Then
Begin
If I < J Then { we have two records to exchange }
Begin
Move(Ptr(Seg(V^),Ki)^,Pw^,Len);
Move(Ptr(Seg(V^),Kj)^,Ptr(Seg(V^),Ki)^,Len);
Move(Pw^,Ptr(Seg(V^),Kj)^,Len);
End;
Inc(I); Dec(J); Inc(Ki,Len); Dec(Kj,Len);
End; { If I <= J }
Until I > J; { Until All Swaps Done }
{ We now have two partitions. At left are all records }
{ < X, and at right are all records > X. The larger }
{ partition is stacked and we re-partition the residue }
{ until time to pop a deferred partition. }
If (J-Lt) < (Rt-I)
Then { Right-Most Partition is Larger }
Begin
If I < Rt Then Push(I,Rt); { Stack Right Side }
Rt := J; { Resume with Left }
End
Else { Left-Most Partition is Larger }
Begin
If Lt < J Then Push(Lt,J); { Stack Left Side }
Lt := I; { Resume with Right }
End;
Until Lt >= Rt; { QuickSort is now Complete }
END;
FreeMem(Ps,StkM); { Free Stack and Work Areas }
End;
End; {QSort}
Begin {Unit Initialization}
System.HeapError := @HeapErrorProc;
_HeapHighWaterMark := System.HeapPtr;
_HeapOriginalMark := System.HeapOrg;
End.