ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/TWU1.ZIP/TWU1EQU.PAS

Pascal/Delphi Source File | 1991-06-03 | 13.6 KB | 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.