home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / PMLINK.LBR / PMLINK.PQS / PMLINK.PAS
Pascal/Delphi Source File  |  2000-06-30  |  7KB  |  227 lines
  1. Program PMLINK;
  2.   Const MaxInd = $1500; MaxSym = 255;
  3.  
  4.   type    PrgInd    =0 .. MaxInd;    SymInd    = 1..MaxSym;
  5.     SymString = string[6];    Fname    = string[14];
  6.     AnyString = string[127];
  7.     Bits      = 0..8;    ItemT    = 0..15;
  8.     FlagT      = (Norm,Rel,Ext,NegOffs,PosOffs);
  9.     ByteRec      = record Low,High: byte end;
  10.  
  11.   Var    Prog:    array[PrgInd] of
  12.           record Flag:FlagT; Cont: byte end;
  13.     PC:    integer;    OffsPtr: byte;
  14.     SymTab:    array[SymInd] of SymString;
  15.     OffsTab:    array[1..255] of record OPC, Value: integer end;
  16.     Finis,ErrFlag,EoPrg,EoFile: boolean;
  17.     RelFile:    file;    InlFile: text;
  18.     BytePtr:    0..128;    BitCnt:    Bits;
  19.     Buffer:    array[0..127] of byte;
  20.     WB:    ByteRec;    WW: integer absolute WB;
  21.     PrgName:    SymString;
  22.     PrgLen:    integer;    SymPtr:    SymInd;
  23.     AField:    integer;    BField: string[7];
  24.  
  25. {$I F:pmlink.bit}    {Bit-Management}
  26. {$I F:pmlink.utl}    {Utilities}
  27.  
  28.   function RetrWd (N: integer): integer; {fetches 16-bit word from WB:}
  29.     Var WB: ByteRec;    WW: integer absolute WB;
  30.   Begin
  31.     with WB do
  32.       Begin Low := Prog[N].Cont; High := Prog[Succ(N)].Cont End;
  33.     RetrWd := WW
  34.   End;
  35.  
  36.  Procedure FirstPass;
  37.  
  38.    Procedure RelErr (Mess: Symstring);
  39.    Begin Writeln ('PC = ',Hex(PC),', Modul: ',PrgName,
  40.         ',  ',Mess,' relative; Argument: ',Hex(GetWord)) End;
  41.  
  42.    Procedure SpLErr (Item: ItemT);
  43.    Begin Writeln ('PC = ',Hex(PC),', Modul: ',PrgName,', Item: ',Item:2,
  44.         ', AField: ',Hex(AField),', BField: ',BField) End;
  45.  
  46.    Procedure Store (Bt: byte; F: FlagT);
  47.    Begin
  48.      With Prog[PC] do Begin FLAG := F; Cont := Bt End;
  49.      PC := Succ(PC)
  50.    End;
  51.  
  52.    Procedure GetAField;
  53.    Begin
  54.      case GetBits(2) of
  55.        0,1: AField := GetWord;
  56.        2:   RelErr ('Data');
  57.        3:   RelErr ('Common')
  58.      End
  59.    End;
  60.  
  61.    Procedure GetBField; var N: 1..6;
  62.    Begin
  63.      BField[0] := Chr(GetBits(3));
  64.      For N:=1 to Length(BField) do BField[N] := Chr(GetByte)
  65.    End;
  66.  
  67.    Procedure SetExtern; var Next: integer;
  68.    Begin
  69.      SymTab[SymPtr] := BField;
  70.      repeat
  71.        Next := RetrWd(AField);
  72.        with Prog[AField] do Begin Cont := SymPtr; Flag := Ext End;
  73.        Prog[Succ(AField)].Cont := 0; {starting with No Offset}
  74.        AField := Next
  75.      until Next=0;
  76.      SymPtr := Succ(SymPtr)
  77.    End;
  78.  
  79.    Procedure SetOffs; var N: byte;
  80.    Begin
  81.      For N := 1 to Pred(OffsPtr) do
  82.        Prog[Succ(OffsTab[N].OPC)].Cont := N {Pointer to entry in Offset-table}
  83.    End;
  84.  
  85.    Procedure ExtLink; var N: 1..7;
  86.    Begin
  87.      BField[0] := Chr(Max(Succ(GetBits(3)),2));
  88.      For N:=1 to Length(BField) do BField[N] := Chr(GetByte)
  89.    End;
  90.  
  91.    Procedure DefOffs (Offset: integer);
  92.    Begin
  93.      with OffsTab[OffsPtr] do Begin OPC := PC; Value := Offset End;
  94.      OffsPtr := Succ(OffsPtr)
  95.    End;
  96.  
  97.    Procedure StoreWd (Word: integer; F:FlagT);
  98.    Begin Store (Lo(Word),F); Store (Hi(Word),F) End;
  99.  
  100.    Procedure SpLink; var Item: ItemT;
  101.    Begin
  102.      Item := GetBits(4); AField :=0; BField := '';
  103.      if Item in [5..14] then GetAField;
  104.      if Item in [0..3,5..7] then GetBField
  105.      else case Item of
  106.        4:    ExtLink;    {Extension link item}
  107.        15:    EoFile := true
  108.      End;
  109.      case Item of
  110.        1,3..5,11,12: SpLErr (Item);    {Error - no processing}
  111.        2:    PrgName := BField;
  112.        6:    SetExtern;
  113.        8:    DefOffs (-AField);
  114.        9:    DefOffs (AField);
  115.        14,15:    Begin PrgLen := PC; BitCnt :=0; EoPrg := true End
  116.      End                {Program or File end}
  117.    End; {SpLink}
  118.  
  119.  Begin    {FirstPass}
  120.    PC :=0; SymPtr := 1; OffsPtr := 1; EoPrg := false;
  121.    repeat
  122.      if GetBits(1)=0 then Store(GetByte,Norm)
  123.      else case GetBits(2) of
  124.        0:    SpLink;    {special Link Item}
  125.        1:    StoreWd (GetWord,Rel);
  126.        2:    RelErr ('Data');
  127.        3:    RelErr ('Common')
  128.      End
  129.    until EoPrg;
  130.    SetOffs
  131.  End;    {FirstPass}
  132.  
  133.  Procedure SecPass;
  134.  
  135.    Procedure Header;
  136.    Begin
  137.      Writeln (InlFile); Write (InlFile,'  begin');
  138.      If PrgName <>'' then Write (InlFile,' {Modul ',PrgName,'}');
  139.      Writeln (InlFile); Write (InlFile,'    InLine (')
  140.    End;
  141.  
  142.    Procedure WriteLine;
  143.  
  144.      Var EndLine: boolean; ItemCnt: 0..15; LPos: 0..70;
  145.  
  146.      Procedure AdjustLpos; var K,N: 0..7;
  147.      Begin
  148.        K := ItemCnt * 4 - LPos -1; LPos := LPos + K;
  149.        For N:=1 to K do Write (InlFile,' ')
  150.      End;
  151.  
  152.      Procedure WriteItem;
  153.  
  154.        Procedure WriteNorm;
  155.        Begin
  156.          Write (InlFile,'$',Copy(Hex(Prog[PC].Cont),3,2));
  157.          PC := Succ(PC); LPos := LPos + 3; ItemCnt := Succ(ItemCnt)
  158.        End;
  159.  
  160.        Procedure WriteRel; var Item: string[5]; Value: integer;
  161.        Begin
  162.          Value := RetrWd(PC) - PC; Str(Value,Item);
  163.          If Value >=0 then Item := '+' + Item;
  164.          Write (InlFile,'*',Item);
  165.          PC := Succ(Succ(PC)); ItemCnt := ItemCnt + 2;
  166.          LPos := Lpos + Succ(Length(Item))
  167.        End;
  168.  
  169.        Procedure WriteExtern;
  170.          Var Name: SymString;
  171.          OP: byte;    Offset: integer; OffStr: string[6];
  172.        Begin
  173.          Name := SymTab[Prog[PC].Cont]; PC := Succ(PC);
  174.          OP := Prog[PC].Cont;        PC := Succ(PC);
  175.          if OP>0 then
  176.      Begin Offset := OffsTab[OP].Value; Str(Offset,OffStr);
  177.            if Offset>0 then Name := Name + '+';
  178.            Name := Name + OffStr End;
  179.          Write (InlFile,Name);
  180.      ItemCnt := ItemCnt + 2; LPos := LPos + Length(Name)
  181.        End;
  182.      Begin    {WriteItem}
  183.        case Prog[PC].Flag of
  184.          Norm: WriteNorm;
  185.          Rel:  WriteRel;
  186.          Ext:  WriteExtern
  187.        End;
  188.      End;    {WriteItem}
  189.  
  190.    Begin        {WriteLine}
  191.      Writeln (InlFile); Write (InlFile,'  {',Hex(PC),'}     ');
  192.      If Odd(PC) then
  193.        Begin Write (InlFile,'    '); ItemCnt :=1; LPos := 4 End
  194.        else Begin ItemCnt :=0; LPos :=0 End;
  195.      repeat
  196.        WriteItem;
  197.        EoPrg := (PC>=PrgLen); EndLine := (ItemCnt>15); AdjustLPos;
  198.        if not EoPrg then Begin Write (InlFile,'/'); LPos := Succ(LPos) End;
  199.      until (EndLine or EoPrg)
  200.    End;            {WriteLine}
  201.  
  202.    Procedure ClosePrg;
  203.    Begin
  204.      Writeln (InlFile,')'); Write (InlFIle,'  end;');
  205.      If PrgNAme<>'' then Write (InlFile,'  {',PrgName,'}');
  206.      Writeln (InlFile)
  207.    End;
  208.  
  209.  Begin            {SecPass}
  210.    PC := 0; EoPrg := false; Header;
  211.    repeat WriteLine until EoPrg;
  212.    ClosePrg
  213.  End;            {SecPass}
  214.  
  215.  Begin            {PMLink}
  216.    repeat
  217.      OpenFiles; Writeln;
  218.      If not (Finis or ErrFlag) then
  219.      Begin
  220.        repeat
  221.          FirstPass; if not EoFile then SecPass
  222.        until EoFile;
  223.        Close (InlFile)
  224.      End
  225.    until Finis
  226.  End.
  227. as