program sct80;

{ **  8080 to Z80 source code translator  ** }
{ **  Version 2.10                7/1/85  ** }
{ **  aus c't 5/85 .. Seite 94 ff         ** }

const   tab      = 9;        { ^I }
        wlen     = 12;       { laenge short string }
        linlen   = 90;       { input-zlen }
        max      = 250;      { max mnenomics }
        maxmac   = 50;       { max. macros }
        version  : string[50] = 'Version 2.11, 25/7/87, SCT80.PAS';

type    strings  = string[linlen];    { zeilen }
        alfa     = string[wlen];       { datenstring }
        option   = (noop,op,op8,op16, { optionen fuer operanden- }
                   exad,rst,sta,stax, { umformungen              }
                   LIB,INC,SBCD,SDED,SSPD,
                   shld,ldax);
        oldnew   = record             { struktur fuer mnenomics }
                   new  :  alfa;      { neuer operator }
                   old  :  alfa;      { alter operator }
                   opt  :  option     { op-umformung }
                   end;

var     mnem     : array [1..max] of oldnew;
        rsts     : array [0..7]   of alfa;   {rst-adressen}
        mactab   : array [1..maxmac] of string[20];
        data     : text;                     { daten-file }
        old, new : text;                     { i/o-files }
        eop,                                 { end-of-process }
        plab,                                { doppelp. anfuegen }
        found    : boolean;                  { antw. von search }
        instr    : strings;                  { input string }
        position,                            { mnem array idx von search }
        erc,                                 { error-counter }
        cc,                                  { global char count }
        mc,                                  { macro counter }
        max1,                                { mnenomic counter }
        olc, nlc : integer;                  { old/new line counter }
        status   : option;

procedure error (msg : strings);
begin
   erc := erc + 1;
   write('** ERROR -- ',msg,' at source line #',olc:4);
   writeln(', destination line #',nlc:4);
end;

{ getword holt das naechste wort aus dem input-file,
  aufruf erfolgt, wenn syntax label oder operand erwartet }

procedure getword (var str, test : strings);
var   i : integer;
      ch : char;

   procedure newstr; { line-buffer neu einlesen }
   var   tmp : strings;
   begin
      cc := cc-1;
      tmp := copy(str,1,cc);
      while (cc < length(str)) and (str[cc+1] <> '!') do
      begin
         cc := cc+1;
         tmp[cc] := str[cc];
      end;
      delete(str,1,cc);
      while (str[1] <= '!') and (length(str) > 0) do
         delete(str,1,1);
      while (tmp[cc] <= '!') and (0 < cc) do
         cc := cc-1;
      tmp[0] := chr(cc);
      writeln(new,tmp);
      nlc := nlc+1;
      while (length(str) < 1) and not eof(old) do
      begin
         readln(old,str);
         olc := olc + 1;
         if (length(str) < 1) then
         begin
            writeln(new,str);
            nlc := nlc+1;
         end
      end;
      if (length(str) < 1) then
         eop := true;
      cc := 1; { getword neu initialisieren }
      ch := UpCase(str[cc]);
   end;

   procedure NewLine;
   Var   temp : strings;
         i    : integer;
   begin
      i := cc;
      temp := copy(str,1,cc-1);
      repeat
         cc := cc-1
      until (temp[cc] > '!') or (cc < 1);
      temp[0] := chr(cc);        { laenge ohne blanks setzen }
      writeln(new,temp);         { wegschreiben }
      nlc := nlc+1;              { zaehler erhoehen }
      delete(str,1,i);           { aus str deleten }
      while (str[1] <= '!') and (length(str) > 0) do
         delete(str,1,1);        { neuen anfang suchen }
      cc := 1;
      ch := UpCase(str[cc]);
   end;

begin { getword }
   ch := UpCase(str[cc]);
   if (length(str) < cc) then
      newstr;
   while (ch = ';') or (ch <= '!') and not (eop) do { zeilennummern ueberlesen }
   begin
      if (ch = ';') or (length(str) <= cc) then
         newstr                                     { kommentar }
      else if (ch = '!') then
         newline                                    { MAC Zeilenterminator }
      else
         begin
            delete(str,cc,1);
            ch := UpCase(str[cc]);                     { weitersuchen }
         end;
   end;
   i := 0;
   while (ch > '!') and not (ch in [';',':']) and (length(str) >= cc) do
      begin
         i := i+1;
         test[i] := ch;  { und einlesen }
         delete(str,cc,1);
{         if (str[cc] = '$') then
            delete(str,cc,1); }
         ch := UpCase(str[cc])
      end;
   While (ch = ':') and (length(str) >= cc) do
      begin
         i := i+1;
         test[i] := ch;
         delete(str,cc,1);
         ch := str[cc];
      end;
   Test[0] := chr(i);
end; {getword}

{ getopr holt neuen operanden aus dem eingabe-file }

procedure getopr (var str, opr : strings);
var  i, oi : integer;
     exit  : boolean;

   procedure word; { operand ist z.zt. label }
   begin
      repeat
         i := i+1;
         opr[i] := UpCase(str[cc]);
         delete(str,cc,1);
{         if (str[cc] = '$') then
            delete(str,cc,1);}
      until not (Upcase(str[cc]) in ['.','#','?'..'Z','_','0'..'9']) or
            (cc > length(str));
   end;

   procedure chars; { character string }
   var   delim : char;   { string delimiter }
   begin
      delim := str[cc];
      repeat
         i := i+1;
         opr[i] := str[cc];
         delete(str,cc,1);
      until (str[cc] = delim) or (cc >= length(str));
      i := i+1;
      opr[i] := str[cc];
      delete(str,cc,1);
   end;

   procedure numbers;  { zahlenkonstante }
   begin
      repeat {evtlle $-zeichen eliminieren }
         {if (str[cc] = '$') then
            delete(str,cc,1);}
         i := i+1;
         opr[i] := UpCase(str[cc]);
         delete(str,cc,1);
      until not (Upcase(str[cc]) in ['0'..'9','A'..'Z','$']) or
            (cc > length(str));
   end;

   procedure operator; { einzelner operator }
   begin
      i := i+1;
      opr[i] := str[cc];
      delete(str,cc,1);
   end;

begin {getopr}
  i := 0;
  oi := 0;
  exit := false;
  while (str[cc] < '!') and (cc <= length(str)) do
     delete(str,cc,1);
  while (str[cc] <> '!') and (cc <= length(str)) and (str[cc] <> ';') and
        not (exit) do
     begin
        if (Upcase(str[cc]) in ['?'..'Z','_']) then
           Word
        else if (str[cc] in ['0'..'9']) then {erstes Zeichen Ziffer}
           Numbers
        else if (str[cc] in ['''','"']) then
           Chars
        else if (str[cc] in ['$','&','('..'/','<'..'>']) then
           Operator;
        While (str[cc] < '!') and (cc <= length(str)) do
           begin
              i := i+1;
              opr[i] := str[cc];
              delete(str,cc,1);
           end;
        If (i <= oi) then
           begin
              ERROR('in operand');
              exit := true;
           end;
        OI := i;
     end;
  While (i > 0) and (opr[i] < '!') do
     i := i-1;
  Opr[0] := chr(i);
end;

{ search : binaere suche im mnem-array }

procedure Search (Var test : strings;
                  Var k    : integer;
                  Var found: boolean);

Var   i, j : integer;
begin
   i := 1;
   j := max1;
   repeat
      k := (i + j) div 2;
      if test <= mnem[k].old then
         j := k-1;
      if test >= mnem[k].old then
         i := k+1;
   until (i > j);
   if ((i-1) > j) then
      begin
         found := true; { Suchergebniss in found zurueck }
         test := mnem[k].new; { neuer operatr in test }
      end
   else
      found := false;
end;

{ checkop : operanden-umformung }

procedure checkop ( position : integer; Var Test : strings);

   procedure change_m (var opr : strings);
   var  cpos, mpos : 0..wlen;
   begin { M durch (HL) ersetzen }
      mpos := pos('M',opr);
      cpos := pos(',',opr);
      if (mpos <> 0) then
         if (mpos < cpos) or (length(opr) = 3) or (length(opr) = 1) then
            begin
               delete(opr,mpos,1);
               insert('(HL)',opr,mpos)
            end
   end; { change_m }

   procedure extadd ( var opr : strings);
   begin {extended adressierung }
      insert('(',opr,1);  { operand in klammern setzen }
      opr := concat(opr,')');
   end; { extadd }

   procedure change_exreg (var opr : strings);
   { extended register fuer z80 uebersetzen }
   begin
      case opr[1] of
         'B' : insert('C',opr,2);
         'D' : insert('E',opr,2);
         'H' : insert('L',opr,2);
         'P' : if (opr[2]='S') and (opr[3]='W') then
                  begin
                     delete(opr,1,3); {delete psw }
                     insert('AF',opr,1)
                  end
      end
   end; { change exreg }

begin {checkop }
   case mnem[position].opt OF
      op8   : change_m(test); {8-bit-operand}
      op16  : change_exreg(test); {16-bit-operand}
      exad  : extadd(test); {klammern setzen}
      sta   : begin
                 extadd(test);
                 test := concat(test,',A')
              end;
      stax  : begin
                 if test='B' then
                    test := '(BC),A'
                 else if test='D' then
                    test := '(DE),A';
              end;
      shld  : begin
                 extadd(test);
                 test := concat(test,',HL');
              end;
      sded  : begin
                 extadd(test);
                 test := concat(test,',DE');
              end;
      sbcd  : begin
                 extadd(test);
                 test := concat(test,',BC');
              end;
      sspd  : begin
                 extadd(test);
                 test := concat(test,',SP');
              end;
      ldax  : begin
                 change_exreg(test);
                 extadd(test);
              end;
      LIB   : TEST := CONCAT(TEST,'.LIB');
      INC   : TEST := CONCAT(TEST,',(C)');
      rst   : if (length(test) = 1) and (test[1] in ['0'..'7']) then
                 test := rsts[ord(test[1])-48];
   end;
end; {checkop }

function macro(word : strings):boolean;
var i : integer;
begin
   i := 1;
   While (mc > i) and (mactab[i] <> word) do
      i := i+1;
   Macro := (MactAB[I] = Word);
end;

procedure enter (word : strings);
begin
   mactab[mc] := word;
   mc := mc+1;
   if (mc > maxmac) then
      begin
         ERROR('Macro Tabel overflow');
         mc := 1;
      end
end;

procedure setup; { SetUp Files}
var name : string[20];
    ch : char;

begin
   writeln;
   write('     source filename ? : ');
   readln(name);
   assign(old,name);
   write('destination filename ? : ');
   readln(name);
   assign(new,name);
   assign(data,'SCT80.DAT');
   Write('check labels  (y/n)  ? : ');
   readln(ch);
   plab := (ch in ['J','j','Y','y']);
   reset(data);
   rewrite(new);
   reset(old);
end;

procedure initary; { daten lesen und array aufbauen }
var option_str : alfa;
begin
   position := 1;
   while not (eof(data)) and (position <= max) do
      begin
         with mnem[position] do
            begin
               readln(data,old);
               readln(data,new);
               readln(data,option_str);
               if (option_str = 'NOOP') then
                  opt := noop
               else if (option_str = 'INC') then
                  opt := inc
               else if (option_str = 'OP') then
                  opt := op
               else if (option_str = 'OP8') then
                  opt := op8
               else if (option_str = 'OP16') then
                  opt := op16
               else if (option_str = 'EXAD') then
                  opt := exad
               else if (option_str = 'STA') then
                  opt := STA
               else if (option_str = 'STAX') then
                  opt := STAX
               else if (option_str = 'SHLD') then
                  opt := shld
               else if (option_str = 'SDED') then
                  opt := sded
               else if (option_str = 'SBCD') then
                  opt := sbcd
               else if (option_str = 'SSPD') then
                  opt := sSpd
               else if (option_str = 'LDAX') then
                  opt := ldax
               ELSE IF (OPTION_STR = 'LIB') then
                  OPT := LIB
               else if (option_str = 'RST') then
                  opt := rst;
               readln(data);
               position := position+1;
            end
      end;
   if not (eof(data)) then
      ERROR('Symbol Tabel overflow');
   max1 := position-1;
   rsts[0] := '00H';
   rsts[1] := '08H';
   rsts[2] := '10H';
   rsts[3] := '18H';
   rsts[4] := '20H';
   rsts[5] := '28H';
   rsts[6] := '30H';
   rsts[7] := '38H';
end;

procedure work;
var test : strings;

   procedure newwrite(var str, test : strings);
   begin
      if (pos('^',test) > 0) then
         test[pos('^',test)] := chr(tab);
      if (cc > length(str)) then
         str := concat(str,test)
      else
         insert(test,str,cc);
      cc := cc+length(test);
      if (cc < length(str)) then
         begin
            insert(chr(tab),str,cc);
            cc := cc+1;
         end
   end; {newwrite}

   function nextword(line, sstr : strings) : boolean;
   var result : boolean;
       li, si : integer;
   begin
      li := 1;
      si := 1;
      result := false;
      while not (line[li] in ['A'..'Z','a'..'z'])
            and (li < length(line)) do
         li := li+1;
      while (UpCase(line[li]) = Upcase(sstr[si]))
            and (li < length(line))
            and not (result) do
         if (si = length(sstr)) then
            result := true
         else
            begin
               li := li+1;
               si := si+1;
            end;
         if (result)
            and (line[li+1] > '!') then {nur anfang stimmt}
            result := false;
         NextWord := result
   end; {nextword}

   procedure labtst;
   begin { pruefe auf ':' }
      if (plab) then
         if (NextWord(instr,'EQU'))
            or (NextWord(instr,'SET')) then
            begin
               if (test[length(test)]=':') then
                  delete(test,length(test),1); {eliminiere ':'}
            end
         else
            if (test[length(test)]<>':') then
                  test := concat(test,':');
         if (length(test) < 8) then
            test := concat(test,chr(tab));
   end; {labtst}

   procedure poper; {process operand}
   var operand : strings;
   begin
      if (pos('^',test) <> 0) then {trenne operand ab}
         begin
            operand := copy(test,pos('^',test),
                            length(test)-pos('^',test)+1);
            delete(test,pos('^',test),length(test)-pos('^',test)+1);
         end
      else
         operand := ''; {no operand}
      newwrite(instr,test);
      getopr(instr,test);
      checkop(position,test);
      test := concat(operand,test);
      if (pos('^',test) <> 0) then
         delete(test,pos('^',test),1);
   end; {poper}

begin {work}
   while not (eop) do
      begin
         getword(instr,test);
         search(test,position,found); {test = neuer mnenomic}
         status := mnem[position].opt;
         if not (found) then
            begin
               if (NextWord(instr,'MACRO')) then
                  enter(test)
               else
                  if not (macro(Test)) then {kein eingetragenes macro}
                     labtst {label ?}
                  else
                     begin
                        status := op;
                        found := true;
                     end
            end
         else
            if (cc = 1) then
               begin
                  INSERT(chr(tab),instr,1);
                  CC := CC+1;
                  insert(chr(tab),instr,1);
                  cc := cc+1;
               end;
         if (status <> noop) and (found) then
            poper; {operand behandeln}
         newwrite(instr,test);
      end;
end; {Work}

procedure stat;
begin
   Writeln;
   Writeln('process complete');
   Writeln('input lines     : ',olc);
   Writeln('output lines    : ',nlc);
   writeln('macros found    : ',mc-1);
   writeln;
   if (erc >0) then
      Writeln(erc,' errors found')
   else
      Writeln('No errors found');
end;

begin {MAIN}
   writeln('8080 to Z80 Source Code Translator V 2.1');
   SetUp;
   Initary;
   eop := False;
   erc := 0;
   cc := 1;
   mc := 1;
   olc := 1;
   nlc := 0;
   readln(old,instr);
   Writeln(new,'.Z80');
   nlc := nlc+1;
   Work;
   Stat;
   Close(New);
end.