{*************************************************************************}
{*                       Pascal Link-80 version 3.2                      *}
{*                                                                       *}
{*      Program to produce an INLINE-statement from an M80 REL-file      *}
{*                                                                       *}
{*          Programmed in Turbo Pascal by J.A.C.G. van der Valk          *}
{*              van Langendonckstraat 2 / 3076 SL Rotterdam              *}
{*                           Phone: 010-4320625                          *}
{*                                                                       *}
{*                Copyright 1986 by J.A.C.G. van der Valk                *}
{*                                                                       *}
{*************************************************************************}
{*                                                                       *}
{*  This code is donated to public domain for non-commercial use only!   *}
{*    It is prohibited to sell this code (or any part of it) to third    *}
{*  parties ; to use this code code for any other commercial gain or to  *}
{*  distribute any program (in source or object form) ,developed by use  *}
{*     of the code in this file, on a commercial basis without prior     *}
{*                   written permission by the author.                   *}
{*                                                                       *}
{*************************************************************************}
const
  PrtOn=^P; PrtOff=^N; Bell=^G; LF=^J; CR=^M; UP=^K;

type
  symboltype = string[8];
  fnamtype   = string[20];
  anystring  = string[80];
  hextype    = string[2];
  FileRecord = array [0..127] of byte;
  LoadItem   = record
                 typecode:byte;
                 contents:byte;
               end;

var
  FileBuffer : FileRecord;
  count,                { counter for lay out of .INC file        }
  offset,               { offset for PC-relative code             }
  DataSize,             { size of Data - segment                  }
  ProgSize,             { size of Code - segment                  }
  ErrorCnt,             { number of fatal errors detected         }
  EntryCnt,             { number of entry sumbols defined         }
  Maxloc,               { maximum for LC on the heap              }
  LC,                   { Location Counter                        }
  Pbase,                { Base for LC in Code Segment             }
  Dbase,                { Base for LC in Data Segment             }
  Tsize,                { Total Size of Code + Data               }
  BitCnt,               { Number of bits  read from .REL-file     }
  ByteCnt,              { Current Byte-number in .REL-file        }
  ExtCnt,               { Counter for external symbol storage     }
  i                     { general purpose counter                 }
  :integer;
  STOP    : boolean;    { Flag for terminating .REL-file reading  }
  PrtOut  : boolean;    { Flag for shadow-output on printer       }
  symbol  : symboltype; { symbol in special link items            }
  s       : string[5];  { string for LC in inl-file               }
  fnam    : string[15]; { file - name of .REL file                }
  WrkRec  : LoadItem;   { variable for storing temporary code     }
  c       : char;       { dummy character                         }

  relfil  : file;       { .REL - file from M80 assembler          }
  inlfil,               { file for inline statement               }
  fentry,               { file for table of entry points          }
  f       : text;       { file for listing on LST: or CON:        }
  dsk     : byte;       { current disk number                     }

label
   9999;                { label to EXIT the program               }

{*************************************************************************}
{*                                                                       *}
{*  This code is donated to public domain for non-commercial use only!   *}
{*    It is prohibited to sell this code (or any part of it) to third    *}
{*  parties ; to use this code code for any other commercial gain or to  *}
{*      distribute any program (in whatever form) ,developed by use      *}
{*     of the code in this file, on a commercial basis without prior     *}
{*                   written permission by the author.                   *}
{*                                                                       *}
{*************************************************************************}

Procedure ClrEos;
var i:byte;
begin
  for i:=14 to 24 do
  begin
    gotoxy(1,i);clreol
  end;
end;

Procedure Error(Errno:integer);
begin
  write(Bell,'Error ',Errno:2,' ');
  case Errno of
  0: begin
       writeln('Unsupported Special Link item');
       writeln('please consult the PL80-manual!');
     end;
  1: begin
       writeln('Code size exeeds available workspace');
       writeln('Split source-code if possible!');
       write('Continue anyhow (Y/N)? :');
       read(kbd,c);if Upcase(c)='Y' then writeln('Y') else writeln('N');
       Stop:=(Upcase(c)<>'Y');
     end;
  2: begin
       writeln('COMMON blocks are not supported');
       writeln('please take notice of the PL80-manual!');
     end;
  3: begin
       writeln('Heap-overflow while linking');
       writeln('Check ORG-statements in source-code!');
       Stop:=true;
     end;
  4: begin
       writeln('Heap-overflow on Chaining External : ',symbol);
       writeln('Split source-code if possible!');
       stop:=true
     end;
  end;{ of case }
  ErrorCnt:=ErrorCnt+1;
end;

procedure Directory(s:fnamtype);

const
  extend      =  12;
  setDMA      =  26;
  searchFirst =  17;
  searchNext  =  18;

var
  FCB                                         :array[0..32] of char;
  directorynamen                              :array[0..3,0..31] of char;
  drivenaam                                   :char;
  dot,index,regelaantal,directorycode         :integer;

begin
  for index:=1 to length(s) do s[index]:=Upcase(s[index]);
  drivenaam:=chr(Bdos(25)+65);
  if s[2]=':' then
  begin
    drivenaam:=Upcase(s[1]);
    s:=copy(s,3,255);
  end;
  if Length(s)=0 then s:='*.*';
  writeln('Drive : ',drivenaam);
  if (s[1]='*') and (s[2]='.') then s:='????????'+copy(s,2,255);
  dot:=Pos('.',s);
  if dot>0 then for index:=dot to 8 do Insert(' ',s,dot);
  if (s[9]='.') and (s[10]='*') then s:=copy(s,1,9)+'???';
  if dot>0 then delete(s,9,1);
  for index:=Length(s) to 10 do s:=s+' ';
  FCB[0]:=chr(ord(drivenaam)-64);
  for index:=1 to 11 do FCB[index]:=s[index];
  for index:=12 to 32 do FCB[index]:=chr(0);

  bdos(setDMA,addr(directorynamen));
  directorycode:=bdos(searchfirst,addr(FCB));
  regelaantal:=0;
  if directorycode=255 then writeln('No files *.REL found');
  while directorycode<255 do
  begin
    if directorynamen[directorycode,extend]=chr(0)
    then
    begin
      if regelaantal>0 then write(' | ');
      write(copy(directorynamen[directorycode],2,8), '.');
      for index:=9 to 11 do
      write(chr(127 and ord(directorynamen[directorycode,index])));
      regelaantal:=(regelaantal+1)mod 5;
      if regelaantal=0 then writeln;
    end;
    directorycode:=bdos(searchnext);
  end;
  if regelaantal>0 then writeln;
end;

procedure MemWrite(nn:integer;var WrkRec:LoadItem);
begin
  if nn<=Maxloc then
  move(WrkRec,mem[nn*sizeof(LoadItem)+HeapPtr],sizeof(LoadItem))
  else Error(3);
end;

procedure MemRead(nn:integer;var WrkRec:LoadItem);
begin
  if nn<= Maxloc then
  move(mem[nn*sizeof(LoadItem)+HeapPtr],WrkRec,sizeof(LoadItem));
end;

Procedure StoreExtrnl(symbol:symboltype);
var WrkRec:LoadItem;
    i:byte;
begin
  if (Tsize+(ExtCnt+1)*9) >= Maxloc then Error(4)
  else begin
    for i:=0 to 8 do
    begin
      WrkRec.typecode:=3;
      WrkRec.contents:=ord(symbol[i]);
      MemWrite((Tsize+ExtCnt*9+i),WrkRec);
    end;
    ExtCnt:=ExtCnt+1;
  end;
end;

Procedure GetExtrnl(nn:integer;var symbol:symboltype);
var WrkRec:LoadItem;
    i:byte;
begin
  for i:=0 to 8 do
  begin
    MemRead((Tsize+ExtCnt*9+i),WrkRec);
    symbol[i]:=chr(WrkRec.contents);
  end;
end;

Function Hex(b:byte):hextype;
const HexTabl:string[16]='0123456789ABCDEF';
begin
  Hex:=HexTabl[(b shr 4)+1] + HexTabl[(b and $0F)+1];
end;

procedure center(str:anystring);
var i:integer;
begin
  for i:=1 to (80-length(str)) div 2 do write(' ');
  writeln(str);
end;

procedure conout(c:char);
const Prt:boolean=false;
begin
  if c=PrtOn then Prt:=true
  else if c=PrtOff then Prt:=false
  else begin
    Bios(3,ord(c));
    if Prt and (c<>Bell)
    then Bios(4,ord(c));
  end;
end;

procedure init;
var i     : integer;
    dummy : real;
begin
  BitCnt:=-1; ByteCnt:=-1; STOP:=False; ErrorCnt:=0;
  EntryCnt:=0; ExtCnt:=0; count:=0;
  LC:=0; Pbase:=0; ProgSize:=-1;
  dummy:=memavail; if dummy<0 then dummy:=dummy+65536.0;
  Maxloc:=Trunc(dummy/sizeof(LoadItem))-1;
  conoutptr:=addr(conout);

  { Hello messages }
  ClrScr; writeln;
  center(' P A S C A L   L I N K  -  80 ');
  writeln;
  center('version: 3.2 / dd:17-07-1986');
  center('Programmed by  J.A.C.G. van der Valk');
  center('van Langendonckstraat 2 / 3076  SL  Rotterdam');
  center('Phone : 010 - 4320625');
  writeln;
  center('(c) 1986 by FalconSoft (tm)');
  writeln(LF);
  writeln('Free work space : ',Maxloc:5,' bytes');
  writeln;
  Directory('*.rel');

  dsk:=Bdos(25); { get current disk }
  { Input requests }
  writeln('Hit <RETURN> } to toggle default drive (A/B)',LF);
  write('Name of .REL - file to convert ? : '); readln(fnam);
  for i:=1 to length(fnam) do fnam[i]:=Upcase(fnam[i]);
  i:=Pos('.',fnam);
  if i>0 then delete(fnam,i,255);
  if (fnam[2]=':') and (Length(fnam)=2) then
  begin
    dsk:=ord(fnam[1])-65;
    if dsk in [0,1] then Bdos(14,dsk);
    fnam:='  ';
  end;

  {$I-}
  assign(relfil,fnam+'.REL');reset(relfil);
  while IOresult<>0 do
  begin
    ClrEol;
    if (fnam[2]=':') and (Length(fnam)>0) then
    begin
      dsk:=ord(fnam[1])-65;
      if dsk in[0,1] then Bdos(14,dsk);
      fnam:=copy(fnam,3,255);
    end else
    if length(Fnam)=0 then
    begin
      if dsk=1 then dsk:=0 else dsk:=1 ;
      Bdos(14,dsk);
      ClrEos;gotoxy(1,14);Directory('*.rel');
      writeln('Hit <RETURN> to toggle default drive (A/B)',LF);
      write('Name of .REL - file to convert ? : ');
      readln(fnam);
      ClrEol;
    end else
    begin
      ClrEos;gotoxy(1,14);Directory('*.rel');
      writeln('Hit <RETURN> to toggle default drive (A/B)',LF,LF);
      write(Bell,'File ',chr(dsk+65),':',fnam,'.REL not found',CR,UP);
      write('Name of .REL - file to convert ? : '); ClrEol; readln(fnam);
    end;
    for i:=1 to length(fnam) do fnam[i]:=Upcase(fnam[i]);
    i:=Pos('.',fnam);
    if i>0 then delete(fnam,i,255);
    if (fnam[2]=':') and (Length(fnam)=2) then
    begin
      dsk:=ord(fnam[1])-65;
      if dsk in[0,1] then Bdos(14,dsk);
      fnam:='  ';
    end;
    assign(relfil,fnam+'.REL'); reset(relfil);
  end;
  {$I+}
  if fnam[2]=':' then fnam:=copy(fnam,3,255);
  { delete drive specification if still present }

  ClrEol;
  Bdos(13);      { reset disk system }
  Bdos(14,dsk);  { restore previous default drive }
  write('Send output to LST: device also (Y/N)? :');read(kbd,c);
  if Upcase(c)='Y' then writeln('Y',PrtOn) else writeln('N');
  writeln;
end;

function getbit:byte;
var mask:byte;
begin
  BitCnt:=(BitCnt+1) mod 8;
  if BitCnt=0
  then ByteCnt:=(ByteCnt+1) mod 128;
  if ByteCnt+BitCnt=0 then
  begin
    BlockRead(RelFil,FileBuffer,1);
  end;
  Mask:=128 shr BitCnt;
  if (FileBuffer[Bytecnt] and mask)=0
  then Getbit:=0 else Getbit:=1;
end;

function RelCode:byte;
begin
  relcode:=(GetBit shl 1) + GetBit;
end;

function CtrlField:integer;
begin
  CtrlField:=(GetBit shl 3) +
  (GetBit shl 2) + (GetBit shl 1) +
  GetBit;
end;

function GetByte:byte;
var i,B:byte;
begin
  B:=0;
  for i:=7 downto 0
  do B:=B+(GetBit shl i);
  Getbyte:=B;
end;

function GetInteger:integer;
begin
  GetInteger:=GetByte + Swap(GetByte);
end;

Procedure GetAfield(var yy,nn:integer);
begin
  yy:=RelCode;
  nn:=GetInteger;
end;

Procedure GetBfield(var symbol:symboltype);
var i,zzz:byte;
begin
  zzz:=GetBit*4+GetBit*2+GetBit;
  if zzz=0 then zzz:=8;
  symbol:='';
  for i:=1 to zzz do symbol:=symbol+chr(GetByte);
end;

Procedure LoadByte;
begin
  WrkRec.typecode:=0;
  WrkRec.contents:=GetByte;
  MemWrite(LC,WrkRec);
  LC:=LC+1;
end;

Procedure LoadProgRel;
var x:integer;
begin
  x:=GetInteger+Pbase;
  WrkRec.typecode:=1;
  WrkRec.contents:=lo(x);
  MemWrite(LC,WrkRec);
  WrkRec.contents:=hi(x);
  MemWrite(LC+1,WrkRec);
  LC:=LC+2;
end;

Procedure LoadDataRel;
var x:integer;
begin
  x:=GetInteger+Dbase;
  WrkRec.typecode:=1;
  WrkRec.contents:=lo(x);
  MemWrite(LC,WrkRec);
  WrkRec.contents:=hi(x);
  MemWrite(LC+1,WrkRec);
  LC:=LC+2;
end;

Procedure LoadCommRel;
var x:integer;
begin
  x:=GetInteger;
  LC:=LC+2;
end;

Procedure SpecialLink;
var x,yy,nn,nextloc,nextcode:integer;
begin
  Case CtrlField of
  0: begin
       GetBfield(symbol);
       writeln('Entry symbol             --> ',symbol);
     end;
  1: begin
       GetBfield(symbol);
       writeln('Select COMMON block      --> ',symbol);
       Error(2);
     end;
  2: begin
       GetBfield(symbol);
       writeln('Program Name             --> ',symbol);
     end;
  3: begin
       GetBfield(symbol);
       writeln('Request library search   --> ',symbol);
       Error(0);
     end;
  4: begin
       GetBfield(symbol);
       writeln('Extention Link item      --> ',symbol);
       Error(0);stop:=true;
     end;
  5: begin
       GetAfield(yy,nn);GetBfield(symbol);
       writeln('Define COMMON size       --> ',symbol);
       writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
       Error(0);
     end;
  6: begin
       GetAfield(yy,nn);GetBfield(symbol);
       writeln('Chain External           --> ',symbol);
       case yy of
       1: nn:=nn+Pbase;
       2: nn:=nn+Dbase;
       3: begin
            nn:=nn+Tsize;
            Error(2);
          end;
       end;{ of case }
       MemRead(nn,WrkRec);
       writeln('loc = $',Hex(hi(nn)),Hex(lo(nn)));
       nextloc:=nn;nextcode:=yy;
       if nn+yy=0 then
       writeln('WARNING: Chain is empty, inspect source code!');
       while nextcode+nextloc>0 do
       begin
         nextloc:=WrkRec.contents;
         nextcode:=WrkRec.typecode;
         WrkRec.contents:=lo(ExtCnt);
         WrkRec.typecode:=2;
         MemWrite(nn,WrkRec);
         MemRead(nn+1,WrkRec);
         nextloc:=nextloc+swap(WrkRec.contents);
         if nextcode+nextloc>0 then
         writeln('loc = $',hex(hi(nextloc)),hex(lo(nextloc)));
         WrkRec.typecode:=2;WrkRec.contents:=hi(ExtCnt);
         MemWrite(nn+1,WrkRec);
         nn:=nextloc;MemRead(nn,WrkRec);
       end;
       StoreExtrnl(symbol);
     end;
  7: begin
       GetAfield(yy,nn);GetBfield(symbol);
       writeln('Define Entry point       --> ',symbol);
       writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
       case yy of
       1:nn:=nn+Pbase;
       2:nn:=nn+dbase;
       3:begin
           ErrorCnt:=ErrorCnt+1;
           writeln('Error: entry in common block');
         end;
       end;{ of case }
       if EntryCnt=0 then
       begin
         assign(fentry,fnam+'.ENT');rewrite(fentry);
         writeln(fentry,'Table of Entry symbols ');
         writeln(fentry,'corresponding to ',fnam,'.INL');
         writeln(fentry);
       end;
       write(fentry,symbol);
       for x:=1 to 8-length(symbol) do write(fentry,' ');
       writeln(fentry,' = $',hex(hi(nn)),Hex(lo(nn)));
       EntryCnt:=EntryCnt+1;
     end;
  8: begin
       getAfield(yy,nn);
       write('External - offset        --> ');
       writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
       Error(0);
     end;
  9: begin
       getAfield(yy,nn);
       write('External + offset        --> ');
       writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
       Error(0);
    end;
 10:begin
      getAfield(yy,nn);
      write('Define Size of DATA area  --> ');
      writeln('$',Hex(hi(nn)),Hex(lo(nn)));
      DataSize:=nn;
    end;
 11:begin
      GetAfield(yy,nn);
      write('Set Loading LC to ');
      case yy of
      1: write('CSEG');
      2: write('DSEG');
      3: write('COMM');
      end;{ of case }
      writeln('    --> $',Hex(hi(nn)),Hex(lo(nn)));
      case yy of
      1: LC:=Pbase+nn;
      2: LC:=Dbase+nn;
      3: LC:=Tsize+nn;
      end;{ of case }
    end;
 12:begin
      getAfield(yy,nn);
      write('Chain Address             --> ');
      writeln('$',Hex(yy),'  $',Hex(hi(nn)),Hex(lo(nn)));
      nextloc:=nn;nextcode:=yy;
      while nextcode+nextloc>0 do
      begin
        nextloc:=WrkRec.contents;WrkRec.contents:=LC;
        nextcode:=WrkRec.typecode;
        MemWrite(nn,WrkRec);MemRead(nn+1,WrkRec);
        nextloc:=nextloc+swap(WrkRec.contents);
        writeln('loc = $',hex(hi(nextloc)),hex(lo(nextloc)));
        WrkRec.contents:=LC;
        MemWrite(nn+1,WrkRec);
        nn:=nextloc;MemRead(nn,WrkRec);
      end;
    end;
 13:begin
      getAfield(yy,ProgSize);
      writeln('Define PROGRAM Size       --> $',
      Hex(hi(ProgSize)),Hex(lo(ProgSize)));
      Dbase:=ProgSize+3;{ create space for JP ENDofDSEG }
      Tsize:=ProgSize+DataSize;
      if datasize>0 then tsize:=tsize+3;
      if Tsize>Maxloc then Error(1)
      else begin
        WrkRec.typecode:=0; WrkRec.contents:=0;
        for x:=0 to Tsize-1 do MemWrite(x,WrkRec);
        { Block-Data space (DS) initialized to null-bytes }
      end;
    end;
 14:begin
      getAfield(yy,nn);
      writeln('END of PROGRAM');
      Bitcnt:=-1; { forces to next byte boundary }
    end;
 15:begin
      Stop:=true;
      writeln('END of FILE');
    end;
  end;{ of case }
end;

begin
  init;
  While not STOP do
  begin
    if Getbit=0 then loadbyte
    else begin
    case relcode of
    0:SpecialLink;
    1:LoadProgRel;
    2:LoadDataRel;
    3:LoadCommRel;
    end;{ of case }
    end;
  end;

  writeln(LF,LF,'diagnostics for linkage of file ',fnam,'.REL',LF);
  writeln('Free workspace available : ',Maxloc:5,' bytes');
  if Tsize<Maxloc then
  writeln('Total workspace used     : ',(Tsize+ExtCnt*9):5,' bytes')
  else writeln('Code size exeeds work space');
  writeln('Total code size          : ',Tsize:5,' bytes');
  writeln('Code segment size        : ',Progsize:5,' bytes');
  writeln('Data segment size        : ',Datasize:5,' bytes');
  if Tsize<Maxloc then
  begin
    if ExtCnt>0 then
    writeln('number of externals      : ',ExtCnt:5)
    else writeln('no externals used');
    if EntryCnt>0 then
    writeln('number of entry-points   : ',EntryCnt:5)
    else writeln('no entry points defined');
  end;

  LC:=0;
  if EntryCnt>0 then close(fentry);
  if ErrorCnt>0 then
  begin
    writeln(f);
    writeln(ErrorCnt:3,' fatal error(s) detected',LF);
    write('make inline-file anyway (Y/N)? ');read(kbd,c);
    if Upcase(c)<>'Y' then
    begin
      writeln('N');
      if EntryCnt>0 then erase(fentry);
      goto 9999;
    end else writeln('Y');
  end else writeln('no fatal errors detected');

  writeln(PrtOff);
  writeln('creating ',fnam,'.INL...');
  write('Bytes written : ',#27,'.0');
  assign(inlfil,fnam+'.INL');rewrite(inlfil);
  write(inlfil,' INLINE({00000} ');

  while LC < Tsize do
  begin
    MemRead(LC,WrkRec);
    case WrkRec.typecode of
    0: begin
         write(inlfil,'$',Hex(WrkRec.contents));
         LC:=LC+1;
       end;
    1: begin
         offset:=WrkRec.contents;
         MemRead(LC+1,WrkRec);
         offset:=offset+swap(WrkRec.contents)-LC;
         if offset>0 then write(inlfil,'*+',offset)
                     else write(inlfil,'*',offset);
         LC:=LC+2;
       end;
    2: begin
         ExtCnt:=WrkRec.contents;
         MemRead(LC+1,WrkRec);
         ExtCnt:=ExtCnt+swap(WrkRec.contents);
         GetExtrnl(ExtCnt,symbol);
         write(inlfil,symbol);
         LC:=LC+2;
       end;
     else
       begin
         write('Internal error, program aborted');
         close(inlfil);erase(inlfil);
         goto 9999;
       end;
     end;{ of case }

     if LC < Tsize
     then write(inlfil,'/') else writeln(inlfil,');');
     if (LC=ProgSize) and (Datasize>0) then
     begin
       writeln(inlfil,'$C3/*+',Tsize-LC-1,'/');
       LC:=LC+3;
       writeln(inlfil,'        { start of DATA segment }');
       Str(LC,s);for i:=length(s) to 4 do s:='0'+s;
       write(inlfil,'        {',s,'} ');
       count:=0;
     end;
     count:=(count+1) mod 10;
     if count=0 then
     begin
       writeln(inlfil);
       Str(LC,s);for i:=length(s) to 4 do s:='0'+s;
       write(inlfil,'        {',s,'} ');
     end;
     write(LC:5,^H,^H,^H,^H,^H);
   end;
   close(inlfil);
9999:
  writeln(#27,'.2');
  close(relfil);
end.