Program WinPas;
{$APPTYPE CONSOLE}
{$X+}
{
***************************************************************************
*                                                                         *
*                    -  WinPascal compiler v0.01b  -                      *
*                 Open Source project by Blooshed Software		  *
*		     http://www.bloodshed.nu/winpascal/                   *
*               See ToDo.txt to know what's need to be added.		  *
*		  Please read README.TXT for more informations            *
*                                                                         *
***************************************************************************

}
uses Globals, Gen_Code, Errors, SysUtils;

Procedure GetChar;
begin
  if Not Eof(Source) then Read(Source,Look)
                     else Look := '.';

  If Look = #13 then Inc(LineCount);
end;

procedure SkipSpace;
begin
  While (look in [Cr,Lf,Tab_,' ']) AND (Not Eof(Source)) do
    GetChar;
end;

Procedure Parse_Directive;
begin
  if Look in ['C','c'] then
     Console_App := True;
  if Look in ['G','g'] then
     Gui_App := True;
end;

Procedure GetToken;
label
  restart;
var
  i,j : word;
  x   : boolean;
  last: char;
begin
RESTART:
  Current_String := '';
  Current_Token  := _Unknown;
  Current_Number := 0;
  SkipSpace;
  Case Look of
    '{'  : begin
             GetChar;
             if Look = '$' then
                begin
                  GetChar;
                  Parse_Directive;
                end;

             repeat
               GetChar;
             until Look = '}';
             GetChar;
             Goto Restart;
           end;

    '('  : begin
             getchar;
             if look = '*' then
             begin
               getchar;
               repeat
                 last := look;
                 getchar;
               until (last = '*') and (look = ')');
               getchar;

               Goto Restart;
             end
             else
               current_token := _lparen;
           end;

    '''' : begin
             getchar;
             current_string := '';
             x := false;
             repeat
               case look of
                 cr    : abort_('String exceeds line');
                 ''''  : begin
                           getchar;
                           if look <> '''' then
                             x := true
                           else
                             current_string := current_string + look;
                         end;
               else
                 current_string := current_string + look;
                 getchar;
               end;
             until x;
             current_token := _string_constant;
           end;

    '$'  : begin
             GetChar;
             While (UpCase(Look) in ['0'..'9','A'..'F']) do
             begin
               Current_Number := Current_Number SHL 4 +
                                 Pos(UpCase(Look),HexCode)-1;
               GetChar;
             end;
             Current_Token := _numeric_constant;
           end;
    '0'..'9' : begin
                 while look in ['0'..'9'] do
                 begin
                   Current_Number := Current_Number * 10 +
                                     Pos(Look,HexCode)-1;
                   GetChar;
                 end;
                 current_token := _numeric_constant;
               end;
    '_','A'..'Z',
        'a'..'z'   : begin
                       While UpCase(Look) in ['_','0'..'9',
                                                  'A'..'Z',
                                                  'a'..'z' ] do
                       begin
                         Current_String := Current_String + UpCase(Look);
                         GetChar;
                         for i := 0 to MaxToken do
                           if Current_String = TokenName[i] then
                           begin
                             Current_Token := Token(i);
                           end;
                       end;
                       If Current_Token = _Unknown then
                         Current_Token := _name;
                     end;
  else
    Current_String := UpCase(Look); GetChar;
    Repeat
      J := 0;
      For i := 0 to MaxToken do
        if (Current_string+UpCase(Look)) = TokenName[i] then
          J := i;
      If J <> 0 then
      begin
        Current_String := Current_String + UpCase(Look);
        GetChar;
      end;
    Until J = 0;

    For i := 0 to MaxToken do
      if Current_String = TokenName[i] then
        J := i;
    Current_Token := Token(j);
  end; { Case Look }

end;


function GetName:String;
begin
  if Current_Token = _Name then
     GetName := '_' + UpperCase(Current_String)
  else
    Expected('Name');

    GetToken;
end;

function GetNumber:Integer;
begin
  GetNumber := Current_Number;
  GetToken;
end;

Procedure AddSymbol(_Name : String; _Kind : Integer);
var i : integer;
    Duplicate : boolean;
Begin
  for i := 0 to SymbolCount do
   if SymbolTable[i].Name = UpperCase(_Name) then
      begin
         Duplicate := True;
         Abort_('Duplicate identifier '+ Copy(_Name,2,Length(_Name)-1));
      end;

  for i := 0 to ProcCount do
   if ProcTable[i].Name = UpperCase(_Name) then
      begin
         Duplicate := True;
         Abort_('Duplicate identifier '+ Copy(_Name,2,Length(_Name)-1));
      end;

  if Duplicate = false then
    begin
     SymbolTable[SymbolCount].Name := _Name;
     SymbolTable[SymbolCount].Kind := _Kind;
     Inc(SymbolCount);
    end;
End;

Procedure DumpSymbols;
var
  i, x : integer;
Begin
  WriteLn(Dest);
  WriteLn(Dest,TAB,'.data');

  for i := 0 to SymbolCount - 1 do
    case TypeTable[SymbolTable[i].Kind].Size of
     1,2,4 :  WriteLn(Dest,TAB,SymbolTable[i].Name,'  ','DB',TAB,
                      TypeTable[SymbolTable[i].Kind].Size,TAB,'DUP (?)');
    end;

  WriteLn(Dest,TAB,'.code');
End;

Function LookType(_Name : String):Integer;
{ True if _NAME is in table }
Var
  q,r : Integer;
Begin
  r := -1;
  For q := 0 to TypeCount-1 do
    If TypeTable[q].Name = _Name then
      r := q;
  LookType := r;
End;

Procedure CheckType(_Name : String);
Begin
  If (LookType(_Name) = -1) then
    Expected('type');
End;

(* Function DoStringConst(S : String):String;
Begin
  StringConst[StringCount] := S;
  DoStringConst := '_STR'+Numb(StringCount);
  Inc(StringCount);
End; *)

(**********************
    Parsing Routines
 **********************)

function IsCompareOp(x : token): boolean;
begin
  IsCompareOp := x in [_equal.._not_eq];
end;

function IsAddOp(x : token): boolean;
begin
  IsAddOp := x in [_plus,_minus];
end;

function IsMulOp(x : token): boolean;
begin
  IsMulOp := x in [_mul,_div];
end;

procedure Match(x : Token);
begin
  If Current_Token <> X then
  begin
    If Ord(X) <= MaxToken then
      Expected(TokenName[ord(x)])
    else
      Abort_('Unknown Token expected, compiler error!');
  end
  else
    GetToken;
end;

(*************************
    Expression Parser
 *************************)

function  Expression:integer; Forward;
function  Value:integer;
var
  kind : integer;
begin
  kind := -1;
  If Current_Token = _lparen then
  begin
    Match(_lparen);
    kind := Expression;
    Match(_rparen);
  end
  else
  begin
    If Current_Token = _name then
      Kind := GenCode(_LoadVar,0,GetName)
    else
      If Current_Token = _numeric_constant then
        Kind := GenCode(_LoadConst,GetNumber,'')
      else
        Error('Error in expression');
  end;
end;

procedure Factor;
var
  tmp : token;
  kind : integer;
begin
  kind := Value;
  while IsCompareOp(Current_Token) do
  begin
    GenCode(_Push,kind,'');
    tmp := Current_Token;
    Match(tmp);
    Value;

    case tmp of
      _equal       : begin
                       GenCode(_PopSub,     kind,'');
                       GenCode(_Logical,    kind,'');
                     end;
      _not_eq      : begin
                       GenCode(_PopSub,     kind,'');
                       GenCode(_Logical_Not,kind,'');
                     end;
      _greater     : GenCode(Greater,       kind,'');
      _less        : GenCode(Less,          kind,'');
      _greater_eq  : begin
                       GenCode(Less,        kind,'');
                       GenCode(_Logical_Not,kind,'');
                     end;
      _less_eq     : begin
                       GenCode(Greater,     kind,'');
                       GenCode(_Logical_Not,kind,'');
                     end;
    end;
  end;
end;

procedure Multiply;
begin
  Match(_mul);
  Factor;
  GenCode(_PopMul,0,'');
end;

procedure Divide;
begin
  Match(_div);
  Factor;
  GenCode(_PopDiv,0,'');
end;

procedure Term;
begin
  Factor;
  while IsMulOp(Current_Token) do
  begin
    GenCode(_Push,0,'');
    case Current_Token of
      _mul : Multiply;
      _div : Divide;
    end;
  end;
end;

procedure Add;
begin
  Match(_plus);
  Term;
  GenCode(_PopAdd,0,'');
end;

procedure Subtract;
begin
  Match(_minus);
  Term;
  GenCode(_PopSub,0,'');
end;

function Expression : integer;     { returns expression type }
var
  kind : integer;
begin
  kind := -1;
  If IsAddOp(Current_Token) then GenCode(_Clear,0,'')
                            else Term;
  while IsAddOp(Current_Token) do
  begin
    GenCode(_Push,0,'');
    case Current_Token of
      _plus   : Add;
      _minus  : Subtract;
    end;
  end;
  Expression := kind;
end;

(*************************
     Statement Parser
 *************************)

procedure Statement; Forward;
procedure Call_Proc(s : string); Forward;

procedure DoBoolean(s : string);
begin
  case Current_Token of
       _True : begin
                 GenCode(_LoadConst,1,'');
                 GenCode(_Store,0,s);
               end;
       _False: begin
                 GenCode(_LoadConst,0,'');
                 GenCode(_Store,0,s);
               end;
  else Abort_('Boolean expression expected');
  end;
  GetToken;
end;

procedure Assignment;
var
  tmp : string;
  i : integer;
begin
  Tmp := GetName;

  for i := 0 to ProcCount do
      if ProcTable[i].Name = Tmp then
         begin
           Call_Proc(Tmp);
           Exit;
         end;

  Match(_assign);
  for i := 0 to SymbolCount-1 do
      if SymbolTable[i].Name = Tmp then
         begin
           DoBoolean(Tmp);
           Exit;
         end;

  Expression;
  GenCode(_Store,0,Tmp);
end;

procedure While_Loop;
var
  TestLabel,
  DoneLabel : LabelStr;
  tmp : string;
  i   : integer;
begin
  Match(_While);

  TestLabel := NewLabel;
  DoneLabel := NewLabel;

  GenCode(_PutLabel,0,TestLabel);
  Expression;
  GenCode(_IfNotJumpTo,0,DoneLabel);
  Match(_do);

  if Current_Token = _Name then
     begin
       tmp := '_'+Current_String;
       Match(_Name);

       for i := 0 to ProcCount do
         begin
           if ProcTable[i].Name = tmp then
              GenCode(_CallMacro,-100,tmp);
         end;
     end
  else Statement;

  GenCode(_JumpTo,0,TestLabel);

  GenCode(_PutLabel,0,DoneLabel);
end;

procedure For_Loop;
var
  DoneLabel,
  TestLabel   : LabelStr;
  Index,Limit, tmp : String;
  i            : integer;
begin
  Match(_For);
  TestLabel  := NewLabel;
  DoneLabel  := NewLabel;

  Index := GetName;
  Limit := 'Lim'+Index;
  AddSymbol(Limit,_Long);
  Match(_assign);
  Expression;  GenCode(_Store,0,Index);
  Match(_to);
  Expression;  GenCode(_Store,0,Limit);

  GenCode(_PutLabel,0,TestLabel);
  Match(_do);
  GenCode(_LoadVar,0,Index);
  GenCode(_Push,0,'');
  GenCode(_LoadVar,0,Limit);
  GenCode(Greater,0,'');
  GenCode(_IfJumpTo,0,DoneLabel);


  Statement;

  GenCode(_Inc_Const,1,Index);
  GenCode(_JumpTo,0,TestLabel);

  GenCode(_PutLabel,0,DoneLabel);
end;

procedure If_Then_Else;
var
  ElseLabel,
  DoneLabel  : LabelStr;
  i          : integer;
  tmp        : string;
begin
  Match(_If);

  ElseLabel := NewLabel;
  DoneLabel := NewLabel;

  Expression;
  Match(_then);
  GenCode(_IfNotJumpTo,0,ElseLabel);


  if Current_Token = _Name then
     begin
       tmp := '_'+Current_String;
       Match(_Name);

       for i := 0 to ProcCount do
         begin
           if ProcTable[i].Name = tmp then
              GenCode(_CallMacro,-100,tmp);
         end;
     end
  else Statement;

  If Current_Token = _Separator then
    GenCode(_PutLabel,0,ElseLabel)
  else
  begin
    Match(_else);
    GenCode(_JumpTo,0,DoneLabel);
    GenCode(_PutLabel,0,ElseLabel);
    Statement;
  end;

  GenCode(_PutLabel,0,DoneLabel);
end;

procedure BlockStatement;
begin
  Match(_Begin);

  while Current_Token <> _End do
  begin
    If Current_Token = _Separator then
      GetToken
    else
      Statement;
  end;
  Match(_End);
  if ProcB = True then
     begin
       ProcB := False;
       Match(_separator);
       writeln(Inc_Proc,'ENDM');
       WriteLn(Inc_Proc);
     end;
end;

procedure VarStatement(var kind : integer);
var
  Name : NameStr;
begin
  Name := GetName;
  If (Current_Token = _Comma) then
  begin
    Match(_Comma);
    VarStatement(kind);
  end
  else
  begin
    Match(_Colon);
    kind := LookType(GetName);
    If Kind = -1 then Expected('TYPE');
  end;
  AddSymbol(Name,kind);
end;

procedure VarBlock;
var
  kind : integer;
begin
  Match(_Var);
  while (Current_Token = _Name) do
  begin
    if ProcB = True then kind := -10;
    VarStatement(kind);
    Match(_separator);
  end;
end;

procedure ProcStatement;
var
  NameProc : NameStr;
begin
  NameProc := GetName;

  If Current_Token = _lparen then
  begin
    Match(_lparen);
    repeat GetToken until Current_Token = _rparen;
    { parse procedures params but do nothing (for the moment) }
  end;

  Match(_separator);

  ProcTable[ProcCount].Name := NameProc;
  Inc(ProcCount);

  if ProcCount = 1 then
   begin
     Assign(Inc_Proc,Name+'.inc');
     ReWrite(Inc_Proc);
     GenCode(_IncludeProc,0,Name);

     If IOresult <> 0 then
        begin
             WriteLn('Error opening output file, ',Name,'.inc');
             Halt(2);
        end;
   end;

  writeln(Inc_Proc,'.MACRO '+NameProc);

  IncProc := True;
  ProcB := True;

  if Current_Token = _Var then
     VarBlock;
  BlockStatement;
end;

procedure ProcBlock;
begin
  Match(_Procedure);

  if Current_Token <> _Name then
     Expected('Identifier');

    ProcStatement;
end;

procedure Repeat_Loop;
var tmp : string;
    i   : integer;
var
  Start : LabelStr;
begin
  Match(_Repeat);

  Start := NewLabel;
  GenCode(_PutLabel,0,Start);

  repeat
    If Current_Token <> _Until then
    begin
      if Current_Token = _Name then
       begin
         tmp := '_'+Current_String;
         Match(_Name);

         for i := 0 to ProcCount do
           begin
             if ProcTable[i].Name = tmp then
                GenCode(_CallMacro,-101,tmp);
           end;
       end
    else Statement;

      Match(_separator);
    end;
  until Current_Token = _Until;

  Match(_Until);

  Expression;
  GenCode(_IfNotJumpTo,0,Start);
end;

Procedure Write_Work(WriteType : Token);
Var
  sx : string;
Begin
  If Current_Token = _Lparen then
  begin
    Match(_lparen);
    Repeat
      if Current_Token = _String_Constant then
      begin
        sx := Current_String;
        Match(_String_Constant);

        if ProcB = False then
          begin
           if WriteType = _Write then
             EmitLn('Write('''+sx+''')')
           else EmitLn('WriteLn('''+sx+''')');
          end
          else begin
           if WriteType = _Write then
              EmitInc('Write('''+sx+''')')
           else EmitInc('WriteLn('''+sx+''')');
          end;
      end
      else
        begin
          Expression;
          if ProcB = False then
          begin
            if WriteType = _Write then
               EmitLn('Write(EAX)')
            else EmitLn('WriteLn(EAX)');
          end
          else begin
            if WriteType = _Write then
               EmitInc('Write(EAX)')
            else EmitInc('WriteLn(EAX)');
          end;
       end;
      if Current_Token <> _Rparen then
         Match(_comma);
    Until Current_Token = _Rparen;
    Match(_Rparen);
  end;
End;

Procedure MessageBox_Work;
Var
  Title, Message, VarString : string;
Begin
  If Current_Token = _Lparen then      { Fix for WriteLn; (No Operands) }
  begin
    Match(_lparen);
    Repeat
      if Current_Token = _String_Constant then
      begin
        Title := Current_String;
        Match(_String_Constant);

        Match(_Comma);

        if Current_Token = _String_Constant then
           begin
                Message := Current_String;
                Match(_String_Constant);

                Inc(StringCount);
                Str(StringCount,VarString);

                if ProcB = False then
                begin
                     EmitLn('.data');
                     WriteLn(Dest,'      N', StringCount ,' db '+ ''''+Title+''',0');
                     Inc(StringCount);
                     WriteLn(Dest,'      N', StringCount ,' db '+ ''''+Message+''',0' );
                     EmitLn('hwin dd 0');
                     EmitLn('.code');
                     GenCode(_PutBox,0,'');
                end
                else begin
                     EmitInc('.data');
                     WriteLn(Inc_Proc,'      N', StringCount ,' db '+ ''''+Title+''',0');
                     Inc(StringCount);
                     WriteLn(Inc_Proc,'      N', StringCount ,' db '+ ''''+Message+''',0' );
                     EmitInc('hwin dd 0');
                     EmitInc('.code');
                     GenCode(_PutBox,0,'');
                end;
           end;
      end
      else
        begin
          Expression;
        end;
      if Current_Token <> _Rparen then
         Match(_comma);
    Until Current_Token = _Rparen;
    Match(_Rparen);
  end;
End;

procedure Read_Work(r_type : Token);
begin
  if Current_Token = _separator then
     begin
       Match(_separator);
       if r_type = _Read then
          GenCode(_PutRead,0,'')
       else GenCode(_PutRead,1,'');
     end
  else Expected(';');
end;

Procedure Color_Work;
Var
  i, j : longint;
Begin
  If Current_Token = _Lparen then      { Fix for WriteLn; (No Operands) }
  begin
    Match(_lparen);
    Repeat
      if Current_Token = _numeric_constant then
      begin
        i := Current_number;
        Match(_numeric_constant);

        Match(_Comma);

        if Current_Token = _numeric_constant then
           begin
                j := Current_Number;
                Match(_numeric_constant);
                if ProcB = False then
                   WriteLn(Dest,'      color(',i,',',j,')')
                else WriteLn(Inc_Proc,'      color(',i,',',j,')');
           end;
      end;

      if Current_Token <> _Rparen then
         Match(_comma);
    Until Current_Token = _Rparen;
    Match(_Rparen);
  end;
End;

procedure Call_Proc(s : string);
begin
  GenCode(_CallMacro,-100,s);
  Match(_separator);
end;

procedure Statement;
var i : integer;
    tmp : string;
begin
  Case Current_Token of
    _while  : while_Loop;
    _repeat : repeat_loop;
    _for    : for_loop;
    _if     : if_then_else;
    _begin  : BlockStatement;

    _Write  : begin
                Match(_Write);
                Write_Work(_Write);
              end;
    _WriteLn: begin
                Match(_WriteLn);
                Write_Work(_Writeln);
              end;
    _MessageBox : begin
                   Match(_MessageBox);
                   MessageBox_Work;
                 end;
    _Read   : begin
               Match(_Read);
               Read_Work(_Read);
              end;
    _ReadLn   : begin
                 Match(_ReadLn);
                 Read_Work(_ReadLn);
                end;
    _Color    : begin
                 Match(_Color);
                 Color_Work;
                end;
  else
    Assignment;
  end;
end;

(****************************
         Program Parser
 ****************************)

procedure _Program_;
var
  lib : text;
  buf : string;
  done : boolean;
begin
  If Current_Token = _Program then
  begin
    Match(_Program);
    ProgramName := GetName;
    Match(_separator);
  end;

  GenCode(_ProgramInit,0,ProgramName);

  Done := False;
  begin
    repeat
    Case Current_Token of
      _Var  : VarBlock;
      _Procedure : ProcBlock;
    else
      Done := True;
    End;
    until Done;
  end;

  BlockStatement;

  GenCode(_ProgramExit,0,'');

  (* WriteLn(Dest,'; ***** Library Code ***** ');

  Assign(Lib,'LIB.ASM');
  {$I-}  Reset(Lib); {$I+}
  If IOresult = 0 then
  begin
    while not eof(lib) do
    begin
      readln(lib,buf);
      writeln(Dest,buf);
    end;
    close(lib);
  end;

  WriteLn(Dest,'; ***** Library Ends *****');
  *)
  DumpSymbols;

  { DumpStrings; }

  WriteLn(Dest,'End Start');
end;

(**************************
        Main Program
 **************************)

procedure Init;
begin
  LineCount   := 0;
  LabelCount  := 0;
  SymbolCount := 0;
  StringCount := 0;

  TypeTable[0] := TypeInteger;
  TypeTable[1] := TypeByte;
  TypeTable[2] := TypeLong;
  TypeTable[3] := TypeBoolean;
  TypeTable[4] := TypeString;

  TypeCount    := 5;

  ProgramName := 'NONAME';
  GetChar;
  GetToken;
end;

procedure Usage(Help : boolean);
begin
  WriteLn('WinPascal compiler v0.001 - Open source project from Bloodshed Software');
  WriteLn('http://www.bloodshed.nu/winpascal/');
  WriteLn;
  if Help = true then
  begin
       WriteLn('Usage : WinPas filename (.PAS assumed) [-x] ');
       WriteLn('Options:');
       WriteLn('-c : create a console application');
       WriteLn('-? : show this help');
       Halt(0);
  end;
end;

Begin
  if ParamCount = 0 then Usage(True);
  Name := ParamStr(1);

  if Pos('-?',ParamStr(2)) <> 0 then Usage(True);
  if (Pos('-c',ParamStr(2)) or Pos('-C',ParamStr(2))) <> 0 then
     Console_App := True
  else if (Pos('-g',ParamStr(2)) or Pos('-G',ParamStr(2))) <> 0 then
     Gui_App := True;

  Usage(False);
  if Pos('.pas',Name) <> 0 then
     begin
          Writeln('.pas extension is assumed');
          Halt;
     end
  else
     Assign(Source,Name+'.pas');

{$I-} Reset(Source); {$I+}
  If IOresult <> 0 then
  begin
    WriteLn('Error opening input file ',Name,'.pas');
    Halt(1);
  end;

  Assign(Dest,Name+'.ASM');

{$I-} ReWrite(Dest); {$I+}

  If IOresult <> 0 then
  begin
   WriteLn('Error opening output file, ',Name,'.asm');
   Halt(2);
  end;

  Init;
  _Program_;

  Close(Source);
  Close(Dest);

  if IncProc = True then
     begin
     WriteLn(Inc_Proc,'END');
     Close(Inc_Proc);
     end;

  WriteLn('Total of ',LineCount,' lines compiled');
End.