Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBOGEN.ZIP/LIBRARY1.GEN

Text File | 1987-11-20 | 11.0 KB | 344 lines

(*--------------------------------------------------------------------------*)
(*  GetSysId ----- Determine which computer we are running on               *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

 Type
   String4 = String[4];

   Function IntToHex(IntNum : integer): string4;
   const
      HexChars : array[0..15] of char = '0123456789ABDCEF';
   VAR
      Temp      : byte;
      TempStr   : String[2];
  begin {intToHex}
    Temp     := hi(IntNum);
    TempSTr  := Hexchars[Temp shr 4] + HexChars[Temp and $0F];
    Temp     := Lo(IntNum);
    IntToHex := TempStr + HexChars[Temp shr 4] +
                          HexChars[Temp and $0F]
  end;

Function  GetSysID : char;
    Var
      SysId    : byte;
    Begin
      SysID := mem[$F000:$FFFE];
      Case SysId of
         $FF : GetSysId := 'P';
         $FE : GetSysId := 'X';
         $FD : GetSysId := 'J';
         $FC : GetSysId := 'A';
       Else
          GetSysId := 'U'
     end;
end;

(*----------------------------------------------------------------------*)
(*         Int24, Int24ON, Int24OFF, --- handle critical DOS errors     *)
(*----------------------------------------------------------------------*)

(*----------------------------------------------------------------------*)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        This code is slightly modified from some written by Bela      *)
(*        Lubkin.                                                       *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

CONST
   INT24Err     : BOOLEAN = FALSE;
   INT24ErrCode : BYTE    = 0;
   OldINT24     : ARRAY[1..2] OF INTEGER = (0,0);
VAR
   RegisterSet: RegPack;

(*----------------------------------------------------------------------*)
(*         Int24 --- set up DOS Interrupt 24 critical error handler     *)
(*----------------------------------------------------------------------*)

PROCEDURE Int24;

BEGIN (* Int24 *)

   INLINE
     ($2E/$C6/$06/ INT24Err /$01/$89/$EC/$83/$C4/$08/$89/$F8/$2E/$A2/
      INT24ErrCode /$58/$B0/$FF/$5B/$59/$5A/$5E/$5F/$5D/$1F/$07/$CF);
    { Turbo:  PUSH BP                    (Save caller's stack frame
              MOV  BP,SP                   Set up this procedure's stack frame
              PUSH BP                     ?)
      Inline: MOV  BYTE CS:[INT24Err],1  Set INT24Err to True
              MOV  SP,BP                 Get correct SP;  ADD: Discard saved
              ADD  SP,8                    BP, INT 24 return address & flags
              MOV  AX,DI                 Get INT 24 error code
              MOV  CS:[INT24ErrCode],AL  Save it in INT24ErrCode
              POP  AX                    Pop all registers
              MOV  AL,0FFH               Set FCB call error flag:
              POP  BX                      will cause Turbo I/O error on file
              POP  CX                      operations, no error on character
              POP  DX                      operations
              POP  SI
              POP  DI
              POP  BP
              POP  DS
              POP  ES
              IRET                       Return to next instruction }

End   (* Int24 *);

(*----------------------------------------------------------------------*)
(*              Int24ON --- Turn ON handling of interrupt 24            *)
(*----------------------------------------------------------------------*)

PROCEDURE Int24On;

BEGIN (* Int24ON *)

   INT24Err:=False;

   WITH RegisterSet DO
      BEGIN

         AX:=$3524;

         MsDos(RegisterSet);

         IF ( OldINT24[1] OR OldINT24[2] ) = 0 THEN
            BEGIN
               OldINT24[1] := ES;
               OldINT24[2] := BX;
            END;

         DS := CSeg;
         DX := Ofs(INT24);
         AX := $2524;

         MsDos( RegisterSet );

     END;

END   (* Int24ON *);

(*----------------------------------------------------------------------*)
(*             Int24OFF --- Turn OFF handling of interrupt 24            *)
(*----------------------------------------------------------------------*)

PROCEDURE Int24OFF;

BEGIN (* Int24OFF *)

   INT24Err:=False;

   IF ( OldINT24[1] <> 0 ) THEN
      WITH RegisterSet DO
         BEGIN

            DS := OldINT24[1];
            DX := OldINT24[2];
            AX := $2524;

            MsDos( RegisterSet );

         END;

    OldINT24[1] := 0;
    OldINT24[2] := 0;

END   (* Int24OFF *);

(*----------------------------------------------------------------------*)
(*      Int24Result --- Check for Turbo I/O or critical DOS error       *)
(*----------------------------------------------------------------------*)

FUNCTION INT24Result: INTEGER;

VAR
   I : INTEGER;

BEGIN (* INT24Result *)

   I := IOResult;

   IF INT24Err THEN
      BEGIN
         I := I + 256 * INT24ErrCode;
         INT24On;
      END;

   INT24Result := I;

END   (* INT24Result *);

   Type
     String255 =  String[255];
(*-----------------------------------------------------------------*)
(*                                                                 *)
(*                          StringOf                               *)
(*                                                                 *)
(*  This function returns a string of the character represented by *)
(*  ASCIINUM repeated NUM times.  This is similar to BASIC's STRING*)
(*  function.                                                      *)
(*-----------------------------------------------------------------*)

Function StringOf(ASCIINum,Num: Byte): String255;

Var
  Str: String255;
  StrLen: Byte absolute Str;
  S: Byte;

Begin
StrLen := Num;
For S := 1 to Num Do
  Str[S] := Chr(ASCIINum);
StringOf := Str;
End;

(*-----------------------------------------------------------------*)
(*               Min --- Find minimum of two integers              *)
(*-----------------------------------------------------------------*)

Function Min( A, B: Integer ) : Integer;

(*-----------------------------------------------------------------*)
(*                                                                 *)
(*   Function: Min                                                 *)
(*                                                                 *)
(*   Purpose:  Returns smaller of two numbers                      *)
(*                                                                 *)
(*   Calling sequence:                                             *)
(*                                                                 *)
(*      Smaller := Min( A , B ) : Integer;                         *)
(*                                                                 *)
(*         A       --- 1st input integer number                    *)
(*         B       --- 2nd input integer number                    *)
(*         Smaller --- smaller of A, B returned                    *)
(*                                                                 *)
(*                                                                 *)
(*   Calls:  None                                                  *)
(*                                                                 *)
(*                                                                 *)
(*-----------------------------------------------------------------*)

Begin (* Min *)

   IF A < B Then
      Min := A
   Else
      Min := B;

End   (* Min *);

(*-----------------------------------------------------------------*)
(*               Max --- Find maximum of two integers              *)
(*-----------------------------------------------------------------*)

Function Max( A, B: Integer ) : Integer;

(*-----------------------------------------------------------------*)
(*                                                                 *)
(*   Function:  Max                                                *)
(*                                                                 *)
(*   Purpose:  Returns larger of two numbers                       *)
(*                                                                 *)
(*   Calling sequence:                                             *)
(*                                                                 *)
(*      Larger := MAX( A , B ) : Integer;                          *)
(*                                                                 *)
(*         A       --- 1st input integer number                    *)
(*         B       --- 2nd input integer number                    *)
(*         Larger  --- Larger of A, B returned                     *)
(*                                                                 *)
(*                                                                 *)
(*   Calls:  None                                                  *)
(*                                                                 *)
(*-----------------------------------------------------------------*)

Begin (* Max *)

   IF A > B Then
      Max := A
   Else
      Max := B;

End   (* Max *);

function Power(Number, Exponent: real): real;


begin
   if Number >0.0 then
      Power := exp(Exponent * ln(Number))
   else
      Power := 0.0
end;

function exists(ThisFile : anystr):boolean;
var
  tempFile : text;  {We can get away with assigning a text file to ANY
                     filename because we aren't going to do any input/output}
begin
  assign(tempFile,ThisFile);
  {$I-}
  reset(tempFile);
  {$I+}
  if IOResult = 0 then exists := true
    else exists := false;
  close(tempFile);
end;

Function Time : shortstr;
var
MSDOS_REGS : regpack;
hour,Minutes, Sec : String[2];


begin
  MSDOS_REGS.AX := $2C00;
  intr($21,MSDOS_REGS);
  With MSDOS_REGS do
  begin
    Str(CX shr 8, Hour);
    STR(CX mod 256, minutes);
    STR(DX SHR 8, Sec);
  end;
  IF Length(Hour) < 2 then Hour := '0' + hour;
  IF Length(minutes) < 2 then minutes := '0' + minutes;
  IF Length(Sec) < 2 then Sec := '0' + Sec;
  Time := Hour + ':'+minutes+':'+Sec;
end;

Function Date : shortstr;
var
MSDOS_REgS : regpack;
Month, Day : string[2];
Year       : string[4];

begin
  MSDOS_REGS.AX := $2A00;
  Intr($21,MSDOS_REGS);
  With MSDOS_REGS do
    begin
      STR(CX,Year);
      STR(DX shr 8, Month);
      STR(DX mod 256, DAY);
    end;
  Year := Copy(Year,3,2);
  IF Length(Month) < 2 then Month := '0' + Month;
  IF Length(Day) < 2 then Day := '0' + Day;
  Date := Month + '/' + Day + '/' + Year;
end;

Function Julian(year,month,day:integer):real;

begin
 if month > 0.0 then  julian := year*365.25+(month-1)*30.44+day
 else
   julian := 0.0;

end;