PROGRAM MAKEINL;  {$C-} {$I-}

(* Version 2.0  22.11.1985 *)

(* Alle mit "WeCx" im Kommentar eingefassten Routinen
   von Werner Cirsovius

   WeC1: Prozedur "TabToSpace" - wandelt Tabulatoren um in Leerzeichen
         Sonst funktioniert "Pos(' DS ',..." nicht.

*)

Const    Left      : String[3]  = '(* ';
         Right     : String[3]  = ' *)';
         PRN       : String[4]  = '.PRN';
         INL       : String[4]  = '.INL';
         Leerstrg  : String[17] = '                 ';
         Arrow     : String[8]  = ' -----> ';
         Header    : String[9]  = 'Inline'#13#10'(';
         Tail      : String[5]  = '$00);';
         Syoflow   : String[19] = 'Too many Variables'^G;
         Noexist   : String[9]  = 'No File !';
         Diskerr   : String[11] = 'Disk full !';
         Direrr    : String[10] = 'DIR full !';
         NoSymbol  : String[8]  = '????????';
         Unknown   : String[22] = 'Error, cause unknown !';
         ASEGerr   : String[24] = 'Code must be relative !'^G;
         Warning   : String[30] = 'Overwrite sourcefile ?  (Y/N)'^G;
         Insert    : String[19] = 'MaKe-Inline Utility';
         Version   : String[39] = 'Version 2.0 - 11/1985 (C) Ulrich  Fuchs';


Type     String_255  =  String[255];
         Listpointer =  ^List;
         List        =  Record
                          ExtrnSymbol : String[20];
                          Pointer     : Listpointer;
                        End;


Var      Prntext, Inltext                           : Text;

         Textline, Newline, Opcode,
         ASMtext, Filename, Inlname, Upcaseline     : String_255;
         Oldline                                    : Integer;

         EXTlist, StartOfList, SearchPointer        : Listpointer;

         Mustdef,
         Continue, Skip, Ready,
         Extern, Quit, NoError, First               : Boolean;

         Ch                                         : Char;


Procedure ToUpper(VAR  Strg : String_255);

Var  Count : byte;

Begin
  For Count := 1 to Length(Strg) do
    Strg[Count] := Upcase(Strg[Count]);
End;(*ToUpper*)

(* WeC1 *)
Procedure TabToSpace(VAR  Strg : String_255);

Var  Count : byte;
     Col   : byte;
     WrkStr: String_255;

  Procedure StChr(Ch : Char);
  Begin
    WrkStr := WrkStr + Ch;
    Col := Col + 1;
  End;
Begin
  WrkStr:='';
  Col := 1;
  For Count := 1 to Length(Strg) do
    If Strg[Count] = ^I then
      repeat
        StChr(' ');
      until (Col mod 8) = 0
      else StChr(Strg[Count]);
  Strg := WrkStr;
End;(*TabToSpace*)
(* WeC1 *)

Procedure Check_for_Err;

Var  Error : Byte;

Begin
  Error := IOResult;
  NoError := Error = 0;

  If Error <> 0 then
    Begin
      Writeln(#13#10#10#7);
      Case Error of
        $01  :   Writeln(Noexist);
        $F0  :   Writeln(Diskerr);
        $F1  :   Writeln(DIRerr);
      Else Writeln(Unknown);
      End;
    End;
End;(*Check_for_Err*)


Procedure Select_Name(Var Name1,Name2 : String_255);

Var   Laenge2,N               : Byte;

Begin
  N := Pos('/',Filename);
  Laenge2 := Length(Filename) - N;

  If N > 0 then
    Begin
      Name2 := Copy(Filename,N + 1,Laenge2);
      Name1 := Copy(Filename,1,N - 1);

      If (Laenge2 = 2) and (Name2[2] = ':') then
        Begin
          If Pos(':',Name1) = 0 then
            Name2 := Concat(Name2,Name1)
          Else
            Name2 := Concat(Name2,Copy(Name1,3,N - 3));
        End;
    End
  Else
    Begin
      Name1 := Filename;
      Name2 := Filename;
    End;
End;(*Select_Name*)


Procedure Get_Name;

VAR  Count, Punktpos : Byte;

Begin
  If First then
    Begin
      Filename := '';
      For Count := 1 to Mem[$80] - 1  do
      Filename := Filename + Char(Mem[$81 + Count]);
    End;
  If (Filename = '') or Not First then
    Begin
      Write(#10'*');
      Readln(Filename);
    End;

  First := False;
  Quit := Filename = '';

  ToUpper(Filename);

  Select_Name(Filename,Inlname);

  If Pos('.',Filename) = 0 then Filename := Concat(Filename,PRN);

  If Pos('.',Inlname) =0 then
    If Pos(':',Inlname) <> 4 then
      Inlname := Concat(Inlname,INL);

  If Filename = Inlname then
    Begin
      Write(Warning);
      Repeat
        Read(KBD,Ch);
        Ch := Upcase(CH);
      until Ch in ['N','Y'];

      writeln;
      If Ch <> 'Y' then Get_Name;
    End;

End;(*Get_Name*)


Procedure Form_Newline;

Var  LineLength, Start, ExternalPos, Count       : Byte;
     ASEGerrFound, Comment,
     Code, Jump, Switch, Special                 : Boolean;
     ProgCounter, Labelposition, Offset, Result  : Integer;
     FirstChar                                   : Char;
     Switchcode                                  : String[4];
     Strg                                        : String[6];



Procedure Fill_up (Var Line : String_255; Spaces : Integer);

Var  Index : Byte;

Begin
  For Index := 1 to Spaces - Length(Line) do Line := Line + ' ';
End;(*Fill_up*)


Procedure Insert_Symbol;

Var  Found           : Boolean;

Begin
  Found  := False;
  SearchPointer := StartOfList;

  While (SearchPointer <> NIL) and Not Found do
    Begin
      Found := Pos(SearchPointer^.ExtrnSymbol,Upcaseline) > 0;
      If Found then Opcode := Opcode + SearchPointer^.ExtrnSymbol + '/';
      Searchpointer := SearchPointer^.Pointer;
    End;

  If Not Found then Opcode := Opcode + NoSymbol + '/';
End;(*Insert_Symbol*)


Procedure Calculate_Address;

Begin
  Strg := '$' + Copy(Textline,14,4);
  Val(Strg,Labelposition,Result);
  Offset := Labelposition  - ProgCounter - 1;
  Str(Offset,Strg);
  If Offset < 0 then
    Opcode := Opcode + '*' + Strg + '/'
  Else
    Opcode := Opcode + '*+' + Strg
     + '/';
End;(*Calculate_Address*)

Procedure  Define_Space;

Var ToDefine, Count       : Integer;
    Defline               : String[80];

Begin
  ToDefine := ProgCounter - Oldline;
  Count := 0;

  While Count < ToDefine do
    Begin
      Defline := '';
      Repeat
        Defline := Defline + '$00/';
        Count := Count + 1;
      Until (Count Mod 4 = 0) or (Count = ToDefine);
      Writeln(Defline);
      Writeln(Inltext,Defline);
    End;
Mustdef := False;
End; (* Define_Space *)


Begin
  Ready := Textline = 'Macros:';

(* WeC1 *)
  TabToSpace(Textline);
(* WeC1 *)

  Linelength := Length(Textline);
  Upcaseline := Textline;
  ToUpper(Upcaseline);

  ASEGerrFound := Pos('ASEG',Upcaseline) > 0;
  If  ASEGerrFound then
    If (Pos(';',Textline) > Count) or (Pos(';',Textline) = 0) then
      Begin
        Ready := True;
        Writeln(ASEGerr);
      End;

  ExternalPos := Pos('EXT',Upcaseline);
  If ExternalPos > 0 then
    Begin
      Upcaseline := Copy(Textline,ExternalPos,Linelength - ExternalPos + 1);
      Count := Pos(' ',Upcaseline);
      Upcaseline := Copy(Upcaseline,Count + 1,Length(Upcaseline) - Count);
      While Upcaseline[1] = ' ' do Delete(Upcaseline,1,1);

      If (MemAvail >  SizeOf(List)) or (MemAvail < 0) then
        Begin
          New(EXTlist);
          EXTlist^.ExtrnSymbol:= Upcaseline;
          EXTlist^.Pointer := StartOfList;
          StartOfList := EXTlist;
        End
      Else
        Begin
          NoError := False;
          Writeln(Syoflow);
        End;
   End;

   Code := (Textline[7] = #39) or (Textline[7] = '!');

   Count := 1;
   FirstChar := ^A;
   While (Count <= Linelength) and (FirstChar <= ' ') do
     Begin
       FirstChar := Textline[Count];
       Count := Count + 1;
     End;
   Comment := FirstChar = ';';

   Skip := Not (Code or Comment);

   If Comment then
     Begin
       ASMtext := Left + Copy(Textline,Count,Linelength - Count + 1);
       Fill_up(Asmtext,59);
       Newline := Leerstrg + ASMtext + Right;
     End;

   If Code then
     Begin
       Strg := '$' + Copy(Textline,3,4);
       Val(Strg,ProgCounter,Result);

       Newline := Copy(Textline,11,LineLength - 10);

       If Mustdef then Define_Space;

       Switch := (Newline[1] in ['D','E','F']) and (Newline[2] = 'D');
       If Switch then
         Begin
           Switchcode := '$' + Copy(Newline,1,2) + '/';
           Delete(Newline,1,3);
         End;

       Extern := (Newline[8] = '*');
       Jump := (Newline[8] = #39) or (Newline[8] = '!');
       Special := Jump or Extern;

       If Newline[1] > ' ' then
         Opcode := '$' + Copy(Newline,1,2) + '/'
       Else
         Begin
           Mustdef := (Pos(' DS ',Upcaseline) > 0)
                       or (Pos(' DEFS ',Upcaseline) > 0);
           Oldline := ProgCounter;
           Opcode := Leerstrg;
         End;

       If not Special then
         Begin
           If Newline[6] <> ' ' then
             Opcode := Opcode + '$' + Copy(Newline,6,2) + '/';

           If Newline[4] <> ' ' then
             Opcode := Opcode + '$' + Copy(Newline,4,2) + '/';

           If Newline[6] = ' ' then
             If Newline[7] > ' ' then
               Opcode := Opcode + '$' + Copy(Newline,7,2) + '/';

           If Newline[9] = ' ' then
             If Newline[10] > ' ' then
               Opcode := Opcode + '$' + Copy(Newline,10,2) + '/';

           If Newline[3] > ' ' then
             Opcode := '$' + Copy(Newline,3,2) + '/'
                        + '$' + Copy(Newline,1,2) + '/';

           If Newline[9] > ' ' then
             Opcode := Opcode + '$' + Copy(Newline,8,2) + '/'
                        + '$' + Copy(Newline,6,2) + '/';


         End;


       If Extern then Insert_Symbol;
       If Jump then Calculate_Address;
       If Switch then Opcode := Switchcode + Opcode;

       Fill_up(Opcode,17);

       ASMtext := Left + Copy(Textline,33,Linelength - 32);
       Fill_up(ASMtext,59);
       Newline := Opcode + ASMtext + Right;

   End;
 End;(*Form_Newline*)


(* Main *)

Begin
  First := True;
  Mustdef := False;
  Write(#10#10,Insert,#13#10,Version,#13#10#10);
  Repeat
    Ready := False;
    Continue := True;
    Get_Name;
    If Not Quit then
      Begin
        StartOfList := NIL;
        Writeln(#10,Filename,Arrow,Inlname,#10);
        Assign(Prntext,Filename);
        Assign(Inltext,Inlname);
        Reset(Prntext);
        Check_for_Err;
        If NoError then
          Begin
            Rewrite(Inltext);
            Check_for_Err;
 
            Writeln(Inltext,Header);
            Writeln(Header);

            While Not Eof(Prntext) and NoError and Not Ready and Continue do
              Begin
                Readln(Prntext,Textline);
                Form_Newline;
                If Not Skip then
                  Begin
                    Writeln(Newline);
                    Writeln(Inltext,Newline);
                    Check_for_Err;
                  End;
                  If Keypressed then
                    Begin
                      Read(KBD,Ch);
                      Continue := Ch <> ^X;
                    End;
              End;

            Writeln(Inltext,Tail);
            Writeln(Tail);
          End;
      End;

    Close(Prntext);
    Close(Inltext);

  until Quit;
End.