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

Pascal/Delphi Source File | 1992-03-08 | 13.4 KB | 478 lines

unit fortlink;

{ TPFORT unit to link in fortran routines.  Version 1.82 }

{ Version 1.82- Restored 5.0/5.5 compatibility; added UnLoadFort }
{ Version 1.81- Added test for valid procedure addresses }
{ Version 1.8 - Cleaned up memory management, added version tests and
                Loaderror variable & messages }
{ Version 1.7 - added FortErrorFlag }
{ Version 1.5 - added Ext_Pointer function                                   }
{ Version 1.4 - added Size_Table types and variable for CHARACTER support    }
{ Version 1.3 - fixed bug in loader, and changes type of extra_space to
                longint }


{ Conditional defines: }

{.define OPRO_VER}   { Define this if you own Object Professional. }

{$ifdef ver40}
  TPFORT will *not* work with TP 4.0.
{$endif}

{$ifdef ver50}
  Warning:  TPFORT has not been tested with TP 5.0.  Remove this line at
  your own risk!
  {$define tp4heap}
{$endif}

{$ifdef ver55}
  {$define tp4heap}
{$endif}

interface
  uses dos
{$IFNDEF OPRO_VER} ; {$ELSE} ,opint,opdos,opinline; {$ENDIF}

type
  extval     = longint;
  double_ptr = ^double;
  realarray  = array[1..65520 div sizeof(double)] of double;
  size_table_array = array[0..65519 div sizeof(word)] of word;
                     { Array of CHARACTER variable sizes.  Note that entry
                       0 seems to be unused. }
  size_table_ptr = ^size_table_array;

const
  maxprocs  = 32;  { Recompile this as large as necessary.
                     Overhead is 4*maxprocs }
  extra_space : longint = 1024;  { Extra memory to give to Fortran Loader }
  FortParas   : word = 0;        { Paragraphs currently allocated to Loader }

  linkedprocs   : word = 0;  { The number of procedures linked so far.  Use
                               for automatic procedure numbering in unit
                               initializations }
  fortlink_version = 18;

var
  fortloaded    : boolean;   { True indicates Fortran routines are in memory }
  fortsafe      : boolean;   { True indicates you're in Fortran mode }
  size_table    : ^size_table_ptr; { Points to __fcclenv; see docs.  }
  FortErrorFlag : ^word;     { Points to _MERRQQ; see docs. }
  calltp_version: word;
  calltp_numprocs:word;
  Loaderror     : word;      { 0 = no error
                               1 = version mismatch (see calltp_version)
                               2 = too many procedures (max = maxprocs)
                               3 = too few procedures (min = linkedprocs)
                                   numprocs
                               4 = badly formed procedure address
                             101 = not enough memory
                             102 = no call back
                             103 = DOS error (read System.DOSError variable)
                           }

{  NOT supposed to be interfaced, but external_val needs one }
type
  proc_ref = record
    zero,addr_ofs : word;
  end;
  proc_ref_array = array[1..maxprocs] of proc_ref;
  proc_array = array[1..maxprocs] of pointer;

  result = record       { An array of these are stored at FortSS:FortSP }
   case integer of
   1 : (i   : integer);
   2 : (l   : longint);
   3 : (s   : single);
   4 : (d   : double);
  end;

var
  numprocs : word;    { The actual number of Fortran procedures linked }
  procs : proc_array; { An array of pointers to them }
  FortStackLimit,
  FortDS,
  FortSS,
  FortSP,
  TPStackLimit : word;

function loadfort(prog:string;TPentry:pointer):boolean;
{ The procedure to load the Fortran routines.  Returns true on success. }

procedure unloadfort;
{ Unloads the Fortran routines. }

procedure callfort(procnum:word);
{ The procedure to call the Fortran routine number procnum }
{ Works for SUBROUTINES and FUNCTIONS with values up to 4 bytes (except REAL*4)}

procedure fsingle(procnum:word);
{ Simulates a Fortran REAL*4 Function call }

procedure fdouble(procnum:word);
{ Simulates a Fortran Double Precision Function call }

procedure fpointer(procnum:word);
{ Simulates a Fortran Function call with a value up to 8 bytes long, by
  returning a pointer to it.  Can reserve space for longer return values by
  passing multiple copies of the function to CALLTP, and only using the
  first.
}

function fort_external(procnum:word):extval;
{ Procedure to return value to be passed as an external reference }
Inline(
  $59/                   {      pop    cx}
  $49/                   {      dec    cx}
  $D1/$E1/               {      shl    cx,1}
  $D1/$E1/               {      shl    cx,1}
  $BB/>PROCS/            {      mov    bx,>procs}
  $01/$CB/               {      add    bx,cx}
  $FF/$77/$02/           {      push   [bx+2]}
  $FF/$37/               {      push   [bx]}
  $31/$C0/               {      xor    ax,ax}
  $89/$E2);              {      mov    dx,sp}

function pas_external(proc:pointer):extval;
{ Procedure to return value to be passed as an external reference for
  a Pascal procedure - NOT a function
}
Inline(
  $31/$C0/               {      xor    ax,ax}
  $89/$E2);              {      mov    dx,sp}

procedure clean_external;
Inline(
  $83/$C4/$04);          {       add sp,4}

function ext_pointer(ext:extval):pointer;
{ Convert external routine value into pointer to the entry point. }

procedure Enter_Pascal;
{ Set up Pascal context. Always use with Leave_Pascal! }

procedure Leave_Pascal;
{ Restore Fortran context. Always use with Enter_Pascal! }
Inline(
  $5F/                   {        pop     di    ;  Restore DI,}
  $5E/                   {        pop     si    ;  SI,        }
  $1F/                   {        pop     ds    ;  DS,        }
  $9D);                  {        popf          ;  and the flags}

implementation

const
  copyright   : string[49] = 'TPFORT 1.82 copyright (c) 1989-1992, D.J. Murdoch';
  rights      : string[20] = 'All rights reserved.';

{$IFNDEF OPRO_VER}
{$I opro.inc}
{$ENDIF}

{$l callfort.obj}

procedure callfort(procnum:word); external;

procedure fsingle(procnum:word); external;

procedure fdouble(procnum:word); external;

procedure fpointer(procnum:word); external;

procedure Enter_Pascal; external;

procedure Leave_Pascal; external;

function ext_pointer(ext:extval):pointer;
begin
  ext_pointer := ptr(sseg,ext shr 16);
end;

procedure SaveTPDS; external;

{$f+}
procedure F1_handler(
     Addresses:word;NumArgs:pointer;Return:pointer;  { From CALLTP call }
     MERRQQ:pointer; StackLimit:word;
     FccLenvAddr:pointer; Version:word;              { Added by CALLTP }
     Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word);
interrupt;
var
  procrefs : proc_ref_array absolute addresses;
  i : word;
begin
  InterruptsOn;
  calltp_version := version;
  if version <> fortlink_version then
  begin
    loaderror := 1;
    exit;
  end;
  numprocs := word(numargs^);
  calltp_numprocs := numprocs;
  if numprocs > maxprocs then
  begin
    loaderror := 2;
    exit;
  end;
  if numprocs < linkedprocs then
  begin
    loaderror := 3;
    exit;
  end;
  for i := 1 to numprocs do
  begin
    if procrefs[i].zero <> 0 then
    begin
      loaderror := 4;
      exit;
    end;
    procs[numprocs + 1 - i] := pointer(ptr(DS,procrefs[i].addr_ofs)^);
  end;
  FortErrorFlag  := MERRQQ;
  FortStackLimit := StackLimit;
  FortDS    := DS;
  FortSS    := sseg;
  FortSP    := ofs(procrefs[numprocs])
               + sizeof(proc_ref)           { This removes the procedure
                                              references from the stack, }
               - numprocs*(sizeof(result)); { and leaves room for saved
                                              results }
  Size_Table := FccLenvAddr;
  fortloaded:= true;
  loaderror := 0;
end;
{$f-}

procedure UseFortStack(var Regs:Intregisters);
{ This routine sets us up in the Fortran stack, then calls the TPentry routine }
begin
  TPStackLimit := system.stacklimit;
  system.stacklimit := FortStackLimit;
  FortSafe := true;
  FarCall(ptr(regs.CS,regs.IP));
  FortSafe := false;
  system.stacklimit := TPStackLimit;
end;

function env_paras:word;
var
  env_seg_mcb : word;
begin
  env_seg_mcb := memw[prefixseg:$2c] - 1;
  env_paras   := memw[env_seg_mcb:3];
end;

function mem_needed(prog:string):longint;
{  Function to calculate the number of paragraphs required to load the program
   whose path is given in prog }
type
  exe_header = record
    sig,
    remainder,
    pages,
    relocs,
    header,
    min_extra : word;
  end;

var
  p : file of exe_header;
  h : exe_header;
begin
  mem_needed := 0;
  assign(p,prog);
  {$i-} reset(p);
        read(p,h);
        close(p);
  {$i+}
  if ioresult <> 0 then
    exit;

  with h do
  begin
    if sig = $5a4d then
    begin
      if remainder in [0,4] then
        remainder := 512;
      mem_needed := longint(pages)*512 - 16*longint(header)
                   + 16*longint(min_extra) - (512-longint(remainder))
                                                  { Load image size }
             + 32                                 { two MCBs        }
             + 16*longint(env_paras)              { a new environment }
             + extra_space;

    end
    else
      exit;
  end;
end;

{$IfDef TP4Heap}

Function MemTop:Pointer;
begin
  MemTop := Ptr(Seg(FreePtr^)+$1000,0);
end;

Function HeapEnd:Pointer;
Begin
  if Ofs(FreePtr^) = 0 then
    HeapEnd := MemTop
  else
    HeapEnd := Normalized(FreePtr);
end;

Function FreeListSize:Word;
Begin
  FreeListSize:=PtrDiff(MemTop,HeapEnd);
  writeln('Free list size = ',PtrDiff(MemTop,HeapEnd));
End;
{$EndIf}

function loadfort(prog:string;TPentry:pointer):boolean;
const
  link_vector = $F1;
  link_handle = 16;
  all_of_memory : word = $FFFF;
var
  regs : IntRegisters;
  execblock : pointer;
  blocksize : longint;
  state87 : array[1..94] of byte;
  ParasWeHave : word;
  ParasWeWant : word;
  ParasAvailable : word;
{$ifdef TP4Heap}
  NewFreePtr : pointer;
{$endif}
begin
  loadfort := false;
  if not fortloaded then
  begin
    writeln(copyright);
    if not InitVector(link_vector,link_handle,@f1_handler) then
    begin
      writeln('Can''t get F1! Aborting.');
      exit;
    end;

    blocksize := mem_needed(prog);
    if blocksize = 0 then
      writeln('Can''t determine memory requirements! Will attempt to load...')
    else
    begin
      {Current DOS memory allocation read from memory control block}
      ParasWeHave := MemW[Pred(PrefixSeg):3];
      FortParas   := blocksize div 16;
      ParasWeWant := ParasWeHave - FortParas;
      ParasAvailable := PtrDiff(HeapEnd,HeapPtr) div 16;

      if (ParasAvailable < ParasWeWant) or (not SetBlock(ParasWeWant)) then
      begin
        writeln('Not enough memory available to load ',prog);
        writeln('Needed: ',blocksize,' Available: ',ParasAvailable*16);
        loaderror := 101;
        exit;
      end;

      { Shrink the heap }

{$ifdef TP4Heap}
      {Copy the free list and its pointer down}
      NewFreePtr:=Ptr(Seg(FreePtr^)-FortParas,Ofs(FreePtr^));
      Move(FreePtr^,NewFreePtr^,FreeListSize);
      FreePtr:=NewFreePtr;
{$else}
      Heapend := Ptr(seg(HeapEnd^)-FortParas,ofs(HeapEnd^));
{$endif}
    end;

    writeln('Executing Fortran loader...');
    loaderror := 102;  { Prepare for no call back }

    { Save 8087 state }
    Inline($cd/$39/$B6/state87);   {        fsave word ptr [bp+state87]}

    swapvectors;
    exec(prog,'');
    swapvectors;

    { Restore 8087 state }
    Inline($cd/$39/$A6/state87);   {        frstor word ptr [bp+state87]}

    RestoreVector(link_handle);

    if doserror <> 0 then
    begin
      writeln('DOS error ',doserror,' on exec.');
      loaderror := 103;
      exit;
    end;

    if not fortloaded then
    begin
      write('ERROR ',loaderror,':  ');
      case loaderror of
         1 : writeln('FORTLINK version ',fortlink_version,' CALLTP version ',
                     calltp_version);
         2 : writeln('Too many procedures: CALLTP.numprocs=',calltp_numprocs,
                     ' max=',maxprocs);
         3 : writeln('Too few procedures: CALLTP.numprocs=',calltp_numprocs,
                     ' FORTLINK.Linkedprocs =',linkedprocs);
         4 : writeln('Bad procedure address.  Use EXTERNAL; use /Gb flag in MS Fortran 5.1.');
       102 : writeln('No CALLTP call.');
       else
         writeln('Unknown.');
      end;
      exit;
    end;

    if not Setblock(ParasWeHave) then
      writeln('Warning: unable to reclaim memory');

    { Copy the emulator data to the Fortran segment }
    move(ptr(sseg,0)^,ptr(FortSS,0)^,system.stacklimit);
  end;

  Regs.IP := ofs(TPEntry^);
  Regs.CS := seg(TPEntry^);

  SwapStackAndCallNear(ofs(UseFortstack), ptr(FortSS,FortSP), Regs);

  loadfort := true;
end;

Procedure UnloadFort;
{$ifdef TP4Heap}
Var
  NewFreePtr:Pointer;
{$endif}
Begin
  If Fortloaded and (not FortSafe) then
  Begin
{$Ifdef TP4heap}
    {Copy the free list and its pointer up}
    NewFreePtr:=Ptr(Seg(FreePtr^)+FortParas,Ofs(FreePtr^));
    Move(FreePtr^,NewFreePtr^,FreeListSize);
    FreePtr:=NewFreePtr;
{$else}
    {Restore original HeapEnd}
    HeapEnd:=Ptr(Seg(HeapEnd^)+FortParas,Ofs(HeapEnd^));
{$EndIf}
    FortParas := 0;
    Fortloaded:=False;
  End;
End;

begin
  fortloaded := false;
  fortsafe   := false;
  SaveTPDS;
{$IFNDEF OPRO_VER}
  opint_init;
{$ENDIF}
end.