{$M $FF02,1,1}
{$i-,r-,s-}

program PreCompiler (input, output);

uses
  crt, CAL;

const
  MainProcsEndUBASM = 1442;

var
  n                 : boolean;
  CurDir, p0, Tekst : string;
  Tekst2, Temp      : string;
  wTemp             : string;
  Spaces            : string;
  LabelTekst        : array[0..11] of string;
  _LabelTekst       : string;
  START, EINDE, STEP: string;
  I,J, Q, cq        : longint;
  L                 : text;
  T, T2, T3         : text;
  LijnenBronCode    : longint;
  x, y              : integer;
  c                 : longint;
  c2                : longint;
  TerminatorTotal   : longint;
  Repeats           : longint;
  qc                : longint;
  VName, Einde2     : string;
  fors, reps        : longint;
  Labels            : longint;
  lc                : longint;

  function  CalculateLines (FileName : string) : longint;
    var
      Totaal, c : longint;
      B         : byte;
      F         : file;
    begin
      Totaal:= 0;
      assign (F, FileName);
      reset (F, 1);
      for c:= 1 to filesize (F) do begin
        blockread (F, B, 1);
        if B = 13 then inc (Totaal, 1);
      end;
      close (F);
      inc (Totaal, 1);
      CalculateLines:= Totaal;
    end;

procedure CopyFile (Tekst, Tekst2 : string);
  var
    Buffer2: array[0..1025] of shortint;
    Size   : longint;
    F,F2   : file;
    c      : longint;
  begin
    {$I-}
    assign (F, Tekst);
    reset (F, 1);
    assign (F2, Tekst2);
    rewrite (F2, 1);
    Size:= filesize (F);
    for c:= 1 to Size div 1024 do begin
      blockread (F, Buffer2, 1024);
      blockwrite (F2, Buffer2, 1024);
    end;
    Size:= Size mod 1024;
    blockread (F, Buffer2, SIze);
    blockwrite (F2, Buffer2, Size);
    close (F);
    close (F2)
  end;

function AllSpaces (Tekst : string) : boolean;
  var
   Zo    : boolean;
   c     : integer;
  begin
    Zo:= Tekst = '';
    for c:= 1 to length(Tekst) do
      if Tekst[c] <> ' ' then
        Zo:= false;
    AllSpaces:= Zo
  end;

begin
  nosound;
  fors:= 0;
  reps:= 0;
  Repeats:= -1;
  textmode (co80);
  clrscr;
  writeln;
  textcolor (white);
  write ('U');
  textcolor (lightgray);
  write ('ltra ');
  textcolor (lightgreen);
  write ('B');
  textcolor (white);
  write ('asic - ');
  textcolor (lightgray);
  writeln ('compiler for bas to UBASM.PAS, before linking with TPC.EXE .');
  writeln;
  if (paramcount < 1) then begin
    textcolor (yellow);
    getdir (0, CurDir);
    p0:= paramstr (0);
    CurDir:= UpString (CurDir);
    p0:= UpString (p0);
    Tekst:= p0;
    if pos (CurDir, p0) > 0 then
      delete (Tekst, 1, length (CurDir));
    if Tekst[1] in ['\', '/'] then delete (Tekst, 1, 1);
    writeln ('Usage: ', Tekst, ' <Source_FileName>[.BAS]');
    halt (0);
  end;
  Tekst:= paramstr (1);
  Tekst:= upstring (Tekst);
  if pos ('.', Tekst) = 0 then Tekst:= Tekst + '.BAS';
  writeln;
  x:= wherex;
  y:= wherey;
  LijnenBronCode:= CalculateLines (Tekst);
  TerminatorTotal:= CalculateLines ('UBASM.PAS');

  if LijnenBronCode > 2577 then begin
    textcolor (red);
    writeln;
    writeln ('Error: source code ', Tekst, ' too big.');
    halt (0);
  end;
  Spaces:= '  ';
  Tekst2:= Tekst;
  delete (Tekst2, pos ('.', Tekst2), 255);
  Tekst2:= Tekst2 + '.PAS';
  assign (T3, Tekst2);
  rewrite (T3);
  assign (T2, 'UBASM.PAS');
  reset (T2);
  assign (T, Tekst);
  reset (T);

  for c:= 1 to MainProcsEndUBASM do begin
    gotoxy (x, y);
    write ('Writing header: ', c : 11);
    readln (T2, Tekst);
    writeln (T3, Tekst);
  end;

  writeln;
  x:= wherex;
  y:= wherey;

  writeln ('PASS 1 (to orientate GOTO -statements ...');
  Labels:= 0;
  for c:= 1 to LijnenBronCode do begin
    readln (T, Tekst);
    if pos('LABEL', Tekst) >0 then
      inc (Labels, 1);
  end;
  close (T);
  reset (T);
  writeln ('Possibly ', Labels, ' Goto Statements...');
  x:= wherex;
  y:= wherey;

  if Labels > 0 then write (T3, 'label ');

  lc:= 0;
  for c:= 1 to LijnenBronCode do begin
    readln (T, Tekst);
    Tekst:= UpString (Tekst);
    if pos ('LABEL', Tekst) > 0 then begin
      inc (lc, 1);
      gotoxy (x, y);
      write (Tekst:80);
      while (Tekst[1] = ' ') do delete (Tekst, 1, 1);
      delete (Tekst, 1, 5);
      if lc < Labels then
        writeln (T3, Tekst, ', ')
          else
            writeln (T3, Tekst, ';');
    end;
  end;

  close (T);
  reset (T);

  writeln;

  x:= wherex;
  y:= wherey;

  for c:= MainProcsEndUBASM + 1 to TerminatorTotal do begin
    readln (T2, Tekst);
    gotoxy (x, y);
    write (Tekst:80);
    writeln (T3, Tekst);
  end;

  x:= wherex;
  y:= wherey;
  writeln (T3, ' ExecuteCommand (', '''', 'DIM QUIT[8]', '''', ');');
  for c:= 1 to LijnenBronCode do begin

    gotoxy (x, y);
    writeln ('Pre - compiling... :  ', c : 11, ' .. ... .. ['+char (c mod 16 + 37)+']');
    readln (T, Tekst);
    write (Tekst);
   if not (AllSpaces(Tekst)) then begin
    Tekst:= UpString (Tekst);
    while (Tekst[1] = ' ') do
      delete (Tekst, 1, 1);
    n:= false;
    if (pos ('LABEL', Tekst) > 0) (*and (Repeats < 11)*) then begin
      while (Tekst[1] = ' ') do delete (Tekst, 1, 1);
      delete (Tekst, 1, 5);
      writeln (T3, Tekst, ':;');
(*      inc (Repeats, 1);
      delete (Tekst, 1, pos ('LABEL', Tekst) + 4);
      str (Repeats, _LabelTekst);
      _LabelTekst:= 'LABEL_REPEAT' + _LabelTekst;
      LabelTekst[Repeats] := Tekst;
      while (pos (' ', LabelTekst[Repeats]) > 0) do
        delete (LabelTekst[Repeats], pos (' ', LabelTekst[Repeats]), 1);
      writeln (T3, _LabelTekst+':;');
     *)
    end;
    if (pos ('GOTO', Tekst) > 0) and (pos('IFGOTO', Tekst) = 0)
      and (pos('GOTOXY', Tekst) = 0) (*and (Repeats > -1)*) then begin
(*      delete (Tekst, 1, pos('GOTO', Tekst) + 3);
      for cq:= 0 to 11 do
        if pos (LabelTekst[cq], Tekst) > 0 then qc:= cq;
      str (qc, _LabelTekst);
      _LabelTekst:= 'LABEL_REPEAT' + _LabelTekst;
      writeln (T3, 'goto '+_LabelTekst+';');
      dec (Repeats, 1);
     *)
     writeln (T3, Tekst, ';');
     n:= true;
    end else
    if pos ('IFGOTO', Tekst) > 0 then begin
      while (Tekst[1] = ' ') do delete (Tekst, 1, 1);
      delete (Tekst, 1, 6);
      writeln (T3, 'if Evaluate(LoadVariable(', '''', 'JUMPER', '''', ')) = 1 then goto ', tekst, ';');
      n:= true;
    end;
    if (pos ('FOR', Tekst) > 0) and (pos('INPUT', Tekst) = 0)
      and (pos ('OUTPUT', Tekst) = 0) then begin
      inc (fors, 1);
      if pos ('=', Tekst) > 0 then begin
        VName:= copy (Tekst, pos ('FOR', Tekst)+3, (pos ('=', Tekst)-1)-(pos ('FOR', Tekst)+3)+1);
        while pos (' ', VName) > 0 do
          delete (VName, pos(' ', VName), 1);
      end
        else
          VName:= 'INDEX';
      delete (Tekst, 1, pos ('FOR', Tekst) + 2);
      if pos ('=', Tekst) > 0 then delete  (Tekst, 1, pos('=', Tekst));
      START:= copy (Tekst, 1, pos ('TO', Tekst) - 1);
      delete (Tekst, 1, pos ('TO', Tekst) + 1);
      EINDE:= Tekst;
      Step:= '1';
      if pos ('STEP', Einde) > 0 then begin
        Step:= copy (Einde, pos('STEP', Einde) + 4, 255);
        Einde2:= Step;
        delete (Einde2, 1, pos ('STEP', Einde) + 3);
        Step:= Einde2;
        Q:= round (Evaluate(Step));
        str (Q-1, STEP);
      end
        else
          Q:= 0;
      I:= round (Evaluate(START));
      J:= round (Evaluate(EINDE));
      if J < I then begin
        Temp:= 'DOWNTO';
      end else begin
        Temp:= 'TO';
      end;
      str (I, START);
      str (J, EINDE);
      writeln (T3, 'FOR ForLoopIndex[', fors, ']:= ', START, ' '+Temp+' ', EINDE, ' DO BEGIN');
      writeln (T3, '  str (ForLoopIndex[', fors, ']', ', ForLoopIndexStr);');
      writeln (T3, '  SaveVariable (', '''', VName, '''', ',', 'ForLoopIndexStr', ');');
      if Temp = 'TO' then
        writeln (T3, '  ExecuteCommand (', '''', 'LET ', VName, ' = ', VName, ' + ', Q, '''', ')', ';')
          else
            writeln (T3, '  ExecuteCommand (', '''', 'LET ', VName, ' = ', VName, ' - ', Q,  '''', ')', ';');
(*      str (Repeats, LABelTekst);*)
(*      LabelTekst:= '  LABEL_REPEAT'+LabelTekst+':;';

      writeln (T3, LabelTekst);
*)
      Spaces:= '    ';
      n:= true;
    end;
    if (pos ('NEXT', Tekst) > 0) then begin
      wTemp:= Tekst;

(*      str (Repeats, LABelTekst);
      LabelTekst:= '  LABEL_REPEAT'+LabelTekst+';';
*)

(*      if (I > J) then
        writeln (T3, '  dec (ForLoopIndex[', fors, '], ', STEP+');')
          else
            writeln (T3, '  inc (ForLoopIndex[', fors, '], ', STEP+');');
*)
      writeln (T3, 'END;');
      Spaces:= '  ';
      if fors >0 then begin
        dec (fors, 1);
      end else begin
        writeln ('Compile time error: "NEXT" without "FOR" in line ', c);
        halt (33);
      end;
      n:= true;
    end;
    if (pos ('REPEAT', Tekst) > 0) and (pos ('END', Tekst) = 0) then begin
      inc (reps, 1);
      writeln (T3, ' reps:= ', reps, ';');
      writeln (T3, ' SaveVariable (''QUIT[', reps, ']', '''', ', ', '''', '0', '''', ');');
      writeln (T3, ' REPEAT');
      n:= true;
    end;
    if (pos ('END REPEAT', Tekst) > 0) then begin
      writeln (T3, ' UNTIL Evaluate (LOadVariable (''QUIT[', reps, ']', '''', ')) = 1;');
      dec (reps, 1);
      writeln (T3, ' reps:= ', reps, ';');
      n:= true;
    end;
    if (not n) then
      writeln (T3, Spaces+'EXECUTECOMMAND (' + ''''+Tekst+''''+');');
   end;
  end;

  writeln;

  writeln (T3, '');
  writeln (T3, 'END.');
  close (T);
  close (T2);
  close (T3);
  textcolor (darkgray);
  writeln ('All done!');
end.
