{
Copyright (C) 1998-99 Free Software Foundation, Inc.

Authors: Dr Abimbola A. Olowofoyeku (The African Chief) <laa12@keele.ac.uk>
           Homepage: http://ourworld.compuserve.com/homepages/African_Chief
         Peter Gerwinski <peter@gerwinski.de>
         Frank Heckenbach <frank@pascal.gnu.de>

BP compatible System unit for GPC

This unit is released as part of the GNU Pascal project. It implements
some -- more or less exotic -- BP compatibility features. Even many BP
don't need them, but they're here for maximum compatibility. Most of
BP's System unit's features are built-into the compiler or the RTS.

The unit depends on the conditional defines __BP_INTEGERS__ and
__BP_RANDOM__. If __BP_INTEGERS__ is defined, the integer data types
will be redefined to the sizes they have in BP. Note that this might
cause problems, e.g. when passing var parameters of integer types
between units that do and don't use System.

If __BP_RANDOM__ is defined, this unit will provide an exactly BP
compatible random number generator. In particular, the range for
integer randoms is only 16 bits, as in BP. It also provides the
RandSeed variable, and if it's set to the same value, it produces
exactly the same sequence of random numbers as BP's random generator
does (whoever might need this... ;-). Even the Randomize function
behaves exactly like BP's Randomize. However, this will not be noted
unless one explicitly tests for it.

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as published by
the Free Software Foundation, version 2.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
License for more details.

You should have received a copy of the GNU Library General Public License
along with this library; see the file COPYING.LIB.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.
}

{.$define __BP_RANDOM__}   { BP compatible random number generator }
{.$define __BP_INTEGERS__} { BP compatible integer type sizes }

{$if __GPC_RELEASE__ < 19981206}
{$error This unit requires GPC release 19981206 or newer}
{$endif}

unit System;

interface

uses GPC;

var
  { Procedure to be executed at the end of the program }
  ExitProc : ^procedure = nil;

  { Contains all the command line arguments passed to the program,
    concatenated, with spaces between them (Delphi compatibility) }
  CmdLine : CString;

  { Contains the process ID (Delphi compatibility) }
  HInstance : asmname '_p_pid' Integer;

  {$ifdef __BP_RANDOM__}
  { Random seed, initialized by Randomized, but can also be initialized manually }
  RandSeed : Integer (32) = 0;
  {$endif}

(*@@ doesn't work well -- when GPC gets short strings, it will be unnecessary *)
{$ifdef __BORLAND_PASCAL__}
type
  String = String [255];
{$endif}

{ Short BP compatible integer types if wanted }
{$ifdef __BP_INTEGERS__}
type
  ShortInt  = Integer  (8);
  Byte      = Cardinal (8);
  Word      = Cardinal (16);
  LongInt   = Integer  (32);
  Comp      = Integer  (64);
  Integer   = Integer  (16);

const
  MaxInt     = High (Integer);
  MaxLongInt = High (LongInt);
{$endif}

{ Return the lowest-order byte of x }
function  Lo (x : LongestInt) : Byte;

{ Return the lowest-but-one-order byte of x }
function  Hi (x : LongestInt) : Byte;

{ Swap the lowest- and lowest-but-one-order bytes, mask out the higher ones }
function  Swap (x : LongestInt) : Word;

{ Store the current directory name (on the given drive number if
  drive <> 0) in s }
procedure GetDir (Drive : Byte; var s : String);

{ Heap management stuff }

const
  { Possible return values for HeapError }
  HeapErrorRunError = 0;
  HeapErrorNil      = 1;
  HeapErrorRetry    = 2;

var
  { If assigned to a function, it will be called when memory allocations
    do not find enough free memory. }
  HeapError : ^function (Size : Word) : Integer = nil;

{ Just returns HeapErrorNil, so when assigned to HeapError, GetMem and
  New will return nil pointers instead of causing a runtime error when
  the allocation fails. }
function  HeapErrorNilReturn (Size : Word) : Integer;

{ Return the total free memory/biggest free memory block. Except under
  Win32 and DJGPP, these are expensive routines -- try to avoid them.
  Under Win32, MaxAvail returns the same as MemAvail, so don't rely on
  being able to allocate a block of memory as big as MaxAvail indicates.
  Generally it's preferable to not use these functions at all in order
  to do a safe allocation, but just try to allocate the needed memory
  using HeapErrorNilReturn or CGetMem, and check for nil. }
function  MemAvail : MedInt;
function  MaxAvail : MedInt;

implementation

function Lo (x : LongestInt) : Byte;
begin
  Lo := LongestCard (x) and $ff
end;

function Hi (x : LongestInt) : Byte;
begin
  Hi := (LongestCard (x) div $100) and $ff
end;

function Swap (x : LongestInt) : Word;
begin
  Swap := (LongestCard (x) and $ff) * $100 + (LongestCard (x) div $100) and $ff
end;

procedure GetDir (Drive : Byte; var s : String);
begin
  if Drive = 0
    then s := FExpand (DirSelf)
    else s := FExpand (Succ ('a', Drive - 1) + ':')
end;

{ Heap management stuff }

var
  OldGetMem    : GetMemType;
  OldFreeMem   : FreeMemType;
  MaxAvailSave : Pointer = nil;
  MaxAvailSize : SizeType = 0;

function BPGetMem (Size : SizeType) = Result : Pointer;
var Status : Integer;
begin
  if (MaxAvailSave <> nil) and (Size <= MaxAvailSize) then
    begin
      if Size = MaxAvailSize
        then Result := MaxAvailSave
        else Result := ReAlloc (MaxAvailSave, Size);
      MaxAvailSave := nil;
      MaxAvailSize := 0;
      if Result <> nil then Exit
    end;
  if HeapError = nil
    then Result := OldGetMem^ (Size)
    else
      begin
        repeat
          Result := CGetMem (Size);
          if Result = nil
            then Status := HeapError^ (Size)
            else Status := 1
        until Status <> 2;
        if Status <> 1 then
          RuntimeErrorInteger (853, Size) { out of heap when allocating %d bytes }
      end
end;

procedure BPFreeMem (aPointer : Pointer);
begin
  if MaxAvailSave <> nil then
    begin
      CFreeMem (MaxAvailSave);
      MaxAvailSave := nil;
      MaxAvailSize := 0
    end;
  OldFreeMem^ (aPointer)
end;

function HeapErrorNilReturn (Size : Word) : Integer;
begin
  HeapErrorNilReturn := HeapErrorNil
end;

{$ifdef __DJGPP__}
type
  DPMIFreeInfo = record
    largest_available_free_block_in_bytes,
    maximum_unlocked_page_allocation_in_pages,
    maximum_locked_page_allocation_in_pages,
    linear_address_space_size_in_pages,
    total_number_of_unlocked_pages,
    total_number_of_free_pages,
    total_number_of_physical_pages,
    free_linear_address_space_in_pages,
    size_of_paging_file_partition_in_pages : Word;
    reserved : array [0..2] of Word;
  end;

function DPMIGetFreeMemInfo (var Info : DPMIFreeInfo) : Integer;
  asmname '__dpmi_get_free_memory_information';

function DPMIGetPageSize (var Size : Word) : Integer;
  asmname '__dpmi_get_page_size';

{$ignore-function-results}

function MemAvail : MedInt;
var
  D : DPMIFreeInfo;
  W : Word;
begin
  DPMIGetFreeMemInfo (D);
  DPMIGetPageSize (W);
  MemAvail := (D.total_number_of_unlocked_pages * W)
end;

function MaxAvail : MedInt;
var
  D : DPMIFreeInfo;
  W : Word;
begin
  DPMIGetFreeMemInfo (D);
  DPMIGetPageSize (W);
  MaxAvail := (D.total_number_of_free_pages * W)
end;

{$elif defined (_WIN32)}

type
  TMemoryStatus = record
    dwLength,
    dwMemoryLoad,
    dwTotalPhys,
    dwAvailPhys,
    dwTotalPageFile,
    dwAvailPageFile,
    dwTotalVirtual,
    dwAvailVirtual : Integer;
  end;

procedure GlobalMemoryStatus (var Buffer : TMemoryStatus);
  asmname 'GlobalMemoryStatus'; attribute (stdcall);

function MemAvail : MedInt;
var
  T : TMemoryStatus;
begin
  T.dwLength := SizeOf (TMemoryStatus);
  GlobalMemoryStatus (T);
  MemAvail := Min (T.dwAvailPhys + T.dwAvailPageFile, T.dwAvailVirtual)
end;

function MaxAvail : MedInt;
begin
  MaxAvail := MemAvail
end;

{$else} { other operating systems }

const
  { Parameters for MemAvail and MaxAvail }
  StartSize     = $100000; { 1MB }
  MinSize       = $10;
  PrecisionBits = 5;

function FindLargestMemBlock (var p : Pointer) : SizeType;
var
  Size, Step : SizeType;
  c : Integer;
begin
  Size := StartSize;
  p := CGetMem (Size);
  while p <> nil do
    begin
      Size := 2 * Size;
      CFreeMem (p);
      p := CGetMem (Size)
    end;
  repeat
    Size := Size div 2;
    p := CGetMem (Size)
  until (p <> nil) or (Size <= MinSize);
  c := PrecisionBits;
  Step := Size;
  while (c > 0) and (Size >= 2 * MinSize) and (p <> nil) do
    begin
      Dec (c);
      CFreeMem (p);
      Inc (Size, Step);
      Step := Step div 2;
      repeat
        Dec (Size, Step);
        p := CGetMem (Size)
      until (p <> nil) or (Size <= MinSize)
    end;
  if p = nil then
    Size := 0
  else if Size = 0 then
    p := nil;
  FindLargestMemBlock := Size
end;

function MaxAvail : MedInt;
begin
  if MaxAvailSave <> nil then CFreeMem (MaxAvailSave);
  MaxAvailSize := FindLargestMemBlock (MaxAvailSave);
  MaxAvail := MaxAvailSize
end;

function MemAvail : MedInt;
type
  PMemList = ^TMemList;
  TMemList = record
    Next : PMemList
  end;
var
  TotalSize, NewSize : SizeType;
  MemList, p : PMemList;
  LargeEnough : Boolean;
begin
  TotalSize := MaxAvail;
  MemList := nil;
  repeat
    NewSize := FindLargestMemBlock (p);
    Inc (TotalSize, NewSize);
    LargeEnough := (NewSize >= SizeOf (p^)) and (NewSize >= TotalSize shr PrecisionBits);
    if LargeEnough then
      begin
        p^.Next := MemList;
        MemList := p
      end
  until not LargeEnough;
  if p <> nil then CFreeMem (p);
  while MemList <> nil do
    begin
      p := MemList;
      MemList := MemList^.Next;
      CFreeMem (p)
    end;
  MemAvail := TotalSize
end;
{$endif}

{$ifdef __BP_RANDOM__}
{ BP compatible random number generator }
(*@@$R-*)
procedure NextRand;
begin
  RandSeed := $8088405 * RandSeed + 1
end;
(*@@$R+*)

function BP_RandInt (Range : LongestCard) : LongestCard;
type Card64 = Cardinal (64);
begin
  NextRand;
  BP_RandInt := (Card64 (RandSeed) * (Range mod $10000)) div $100000000
end;

function BP_RandReal : LongestReal;
begin
  NextRand;
  BP_RandReal := RandSeed / $100000000 + 0.5
end;

procedure BP_Randomize;
var Time : TimeStamp;
begin
  GetTimeStamp (Time);
  with Time do
    RandSeed := ((Second * $100 + (MicroSecond div 10000)) * $100 + Hour) * $100 + Minute
end;
{$endif}

to begin do
  begin
    OldGetMem    := GetMemPtr;
    OldFreeMem   := FreeMemPtr;
    GetMemPtr    := @BPGetMem;
    FreeMemPtr   := @BPFreeMem;
    {$ifdef __BP_RANDOM__}
    RandomizePtr := @BP_Randomize;
    RandRealPtr  := @BP_RandReal;
    RandIntPtr   := @BP_RandInt;
    {$endif}
    var CmdLineStr : static TString;
    var i : Integer;
    CmdLineStr := ParamStr (1);
    for i := 2 to ParamCount do CmdLineStr := CmdLineStr + ' ' + ParamStr (i);
    CmdLine := CmdLineStr
  end;

to end do
  while ExitProc <> nil do
    begin
      var Tmp : ^procedure;
      Tmp := ExitProc;
      ExitProc := nil;
      Tmp^
    end;
end.
