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

program PreCompiler (input, output);

uses
  crt, CAL;

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;

  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;
  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 TerminatorTotal do begin
    gotoxy (x, y);
    write ('Writing header: ', c : 11);
    readln (T2, Tekst);
    writeln (T3, Tekst);
  end;

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

  for c:= 1 to LijnenBronCode do begin

    gotoxy (x, y);
    write ('Pre - compiling... :  ', c : 11, ' .. ... .. ['+char (c mod 16 + 37)+']');
    readln (T, 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
      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 (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);
    end;
    if (pos ('FOR', Tekst) > 0) and (pos('INPUT', Tekst) = 0)
      and (pos ('OUTPUT', Tekst) = 0) then begin
      delete (Tekst, 1, pos ('FOR', Tekst) + 2);
      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);
        delete (Einde, 1, pos ('STEP', Einde) + 3);
      end;
      Q:= round (Evaluate(STEP));
      str (Q-1, STEP);
      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:= ', START, ' '+Temp+' ', EINDE, ' DO BEGIN');
      writeln (T3, '  str (ForLoopIndex, ForLoopIndexStr);');
      writeln (T3, '  SaveVariable (''INDEX'', ForLoopIndexStr);');
(*      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, '+STEP+');')
          else
            writeln (T3, '  inc (ForLoopIndex, '+STEP+');');
      writeln (T3, 'END;');
      Spaces:= '  ';
      n:= true;
    end;
    if (pos ('REPEAT', Tekst) > 0) and (pos ('END', Tekst) = 0) then begin
      writeln (T3, ' SaveVariable (''QUIT'', ''0'');');
      writeln (T3, ' REPEAT');
      n:= true;
    end;
    if (pos ('END REPEAT', Tekst) > 0) then begin
      writeln (T3, ' UNTIL Evaluate (LOadVariable (''QUIT'')) = 1;');
      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.
