{$X+}
unit compiler;
{$IFDEF FPC}
  {$MODE DELPHI} {$H+}
{$ENDIF}
(***************************************)
(* Copyright (C) 2013, SHIRAISHI Kazuo *)
(***************************************)



interface
uses  SysUtils, Classes, Types, Forms, Dialogs, ComCtrls, Controls, Graphics,
     {$IFDEF Darwin}LazFileUtils,MacApplicationRes,{$ENDIF}
      struct,codefrm;

function GenerateCode:boolean;
function InvokeCompiler(const FName:string; ReBuild:boolean):boolean;
procedure ExecuteFile(const FName:string);
function MakeFileName:string;


var
   changedir:procedure;
   setIndentOption:procedure;
   setOperation:procedure;
   setRunOption:procedure;
   setRunOption2:procedure;
   setDebug:procedure;
   setLineEndMarker:procedure;
   setRefferingPath:procedure;
var
   ProgramOnRunning:string='';
   ParactMain:boolean=false;
implementation

uses
     {$IFDEF Windows}
     windows,shellapi,
     {$ENDIF}
     Process, FileUtil,
     MainFrm,  setpath,  repoform,
     objlist, base,base0,arithmet,
     myutils,texthand,express,statemen,control,graphic{,graphsys},
     helpctex,math2sub,sconsts,merge;

type
  TBackUp=class(TThread)
       text1:ansistring;
       fName:ansistring;
    constructor create(const s,f:AnsiString);
    procedure execute;override;
  end;

constructor TBackUp.create(const s,f:AnsiString);
begin
   inherited create(false);
   text1:=s;
   FName:=f;
end;

procedure TBackUp.execute;
var
  t:Text;
begin
  assignFile(t,fname);
  try
    rewrite(t);
    write(t,text1);
    close(t)
  except
  end;
end;



var
    ReCompile:boolean=false;

function compile:boolean;
begin
 Screen.cursor:=crHourGlass;
 compile:=true;
 recompile:=false;

 try
    struct.compile;
 except
   on E:Exception do
      begin
          compile:=false;
          currentprogram.deletestatements; //2011.3.9 追加
          currentprogram.freeall;
          if E is EReCompile then
             recompile:=true
          else if not (E is SyntaxError) then
             ShowMessage(s_internalErrorCompiling+EOL+E.message +EOL+Contact);
      end;
 end;
 Screen.cursor:=crDefault;
end;

function CompilePrg:boolean;
var
   ErrorMes:string;
begin
    FrameForm.Memo1.lines.BeginUpdate;

   //extype:=0;
   InitSeed;
   GraphMode:=false;
   textMode:=false;
   UseCharInput:=false;
   ParactMain:=false;
   ReCompile:=false;
   repeat
         ParactTbl.clear;
         StructureDefs.clear;
         ShareMessDefs.clear;

       SetPrecisionMode(InitialPrecisionMode,true);

       indent:=-1;
       USEnest:=0;

       DoStack:=TList.Create;
       ForStack:=TList.create;
       WhenStack:=TList.create;
       WhenStack.add(nil);
       WhenUseStack:=TList.create;
       WhenUseStack.add(nil);
       CurrentSeizeBlock:=nil;
       SeizeBlock:=nil;
       NamedSeizeList.clear;

       result:=false;
       pass:=1;

       try
         if compile then
            begin
               pass:=2;
               currentprogram.deletestatements;
               currentprogram.VarTablesRebuild;
               result:=compile;
            end;
       finally
         DoStack.Free;
         ForStack.free;
         WhenStack.free;
         WhenUseStack.free;
         KeyWordTablesFreeAll;
         Pass:=0;
       end;
   until recompile=false;

   FrameForm.Memo1.lines.EndUpdate;
   //  エラーを表示する
   if result=false then
       begin
         SelectLine(FrameForm.memo1,exline);

         ErrorMes:= s_SyntaxError+' at line ' + IntToStr(exline+1)+ EOL +
                     statusmes.murgeWithOR ;
         if HelpContext=0 then
              MessageDlg( ErrorMes, mtWarning, [mbOK],HelpContext)
         else
              MessageDlg( ErrorMes, mtWarning, [mbOK,mbHelp],HelpContext);
         with FrameForm do
           Memo1.SelStart:=LineIndex(FrameForm.Memo1,exline)+expos+exinsertcount-1;
         end;
end;


procedure SetTranslatingNow(s:boolean);
begin
   TranslatingNow:=s;
   with FrameForm do
      begin
        TBRun.enabled:=not s;
        TBStep.enabled:=not s;
        //TBBreak.enabled:=not s;     //falseを維持する
        TBCut.enabled:=not s;
        TBPaste.enabled:=not s;
        TBUndo.enabled:=not s;
        if not permitMicrosoft then
           begin
              TBDecimal.enabled:=not s;
              TBHighPrecision.enabled:=not s;
              TBBinary.enabled:=not s;
              TBComplex.enabled:=not s;
              TBRational.enabled:=not s;
              TBDeg.enabled:=not s;
           end;
        Option1.enabled:=not s;
        SetUp1.enabled:=not s;
        Window1.enabled:=not s;
       Run2.enabled:=not s;
       Break1.enabled:=not s;
       Step1.enabled:=not s;
       Exit1.enabled:=not s;
       //Close1.enabled:=not s;
       merge1.enabled:=not s;
       Cut1.enabled:=not s;
       Paste1.enabled:=not s;
       Delete1.enabled:=not s;
       Undo1.enabled:=not s;
       Repalce1.enabled:=not s;
       deleteLabelNumber1.enabled:=not s;
       addLabelNumber1.enabled:=not s;
       CaseChange1.enabled:=not s;
       ToolBox1.enabled:=not s;
       Memo1.ReadOnly:=s;
   end;

   with FrameForm do // PopUp menus
     begin
       PopUpMenu1.autoPopUp:=not s;
       Cut2.enabled:=not s;
       copy2.enabled:=not s;
       paste2.enabled:=not s;
       Delete2.enabled:=not s;
       SelectAll2.enabled:=not s;
     end;

   with CodeForm  do begin
       Run2.enabled:=not s;
       File1.enabled:=not s;
       Edit1.enabled:=not s;
   end;

   if s then
      FrameForm.StatusBar1.Panels[3].text:=s_OnCompiling
   else
      FrameForm.StatusBar1.Panels[3].text:='';
   FrameForm.StatusBar1.update;
   Application.ProcessMessages;
end;

procedure SetInvokingNow(s:boolean);
begin
   SetTranslatingNow(s);
end;

procedure SetExecutingNow(s:boolean);
begin
   with FrameForm do
      begin
        TBBreak.enabled:=s;
        TBRun.enabled:=not s;
        TBStep.enabled:=not s;
        Run2.enabled:=not s;
        Step1.enabled:=not s;
        Exit1.enabled:=not s;
      end;

   With FrameForm do
     begin
      N12.Visible:=s;
      PopUpRun1.visible:=not s;
     end;

   with CodeForm  do
      begin
       Run2.enabled:=not s;
      end;

   if s then
      FrameForm.StatusBar1.Panels[3].text:=s_OnExecuting
   else
      FrameForm.StatusBar1.Panels[3].text:=statusBarMems3;
   FrameForm.StatusBar1.UpDate;
   Application.ProcessMessages;
end;
{**************}
{Generate Codes}
{**************}


function GenCode(var success:boolean):AnsiString;
var
  svModified:boolean;
begin
    result:='';
    success:=false;
    EXLINEAppear:=false;
    EXTYPEAppear:=initialUseEXTYPE;
    DebugVariables.clear;

    BreakFlags.LongFlag:=false;
    bkDirective:=bkStep;
   if TextHand.memo<>nil then exit;   {再入防止}
   TextHand.memo:=FrameForm.memo1;
   ChainFile:='';

   MergedLineNumber:=-1;

   svModified:=FrameForm.Memo1.Modified;

   if permitMicrosoft then
      InitialPrecisionMode:=PrecisionNative
   else
      InitialPrecisionMode:=InitialPrecisionMode0;
   initialCharacterByte:=initialCharacterByte0;

   Application.ProcessMessages;

   ParactTbl:=TParactTBL.create;
   StructureDefs:=TStructureDefs.Create;
   ShareMessDefs:=TShareMessDefs.Create;

   try
      try
           HelpContext:=0;
           StatusMes.clear;

           if CompilePrg then
              begin
                   ProgramOnRunning:=FrameForm.OpenDialog1.FileName;
                   //FrameForm.Caption:=AppTitle + ;
                   FrameForm.Memo1.Modified:=false;

                   try
                     result:=CurrentProgram.Code;
                     success:=true;
                     //FrameForm.Caption:=AppTitle;
                   except
                      on E:ECodeNotYet do
                         begin
                            MessageDlg(E.message , mtWarning, [mbOK],HelpContext) ;
                            SelectLine(Frameform.memo1,E.st.linenumb);
                         end;
                      on E:SyntaxError do
                         begin
                            MessageDlg(StatusMes.murgeWithOR , mtWarning, [mbOK],HelpContext) ;
                            SelectLine(Frameform.memo1, exline);
                         end;
                      on E:Exception do
                          ShowMessage(E.message );
                   end;
             end;
      finally
           currentprogram.deletestatements;
           currentprogram.freeall;
         ParactTbl.free;
         StructureDefs.free;
         ShareMessDefs.free;

      end;
   except

   end;
   if MergedLineNumber>0 then RemoveMergedText;

   FrameForm.memo1.Modified:=svModified;
   TextHand.memo:=nil;

end;


function GenerateCode:boolean;
begin
    //FrameForm.Break1Click(nil);
    SetTranslatingNow(True);
    CodeForm.Caption:=ChangeFileExt(ExtractFileName(FrameForm.OpenDialog1.FileName), '' );
    CodeForm.Memo1.Lines.text:=GenCode(result);
    SetTranslatingNow(False);
end;

function ShellExec(s1,s2:string; opWaitFor:boolean; const CurDir:Ansistring):boolean;
var
   AProcess: TProcess;
begin
   CtrlBreakHit:=false;
   result:=false;
   AProcess := TProcess.Create(FrameForm);
   AProcess.CommandLine :=s1 + ' ' +s2;
   AProcess.CurrentDirectory:=CurDir;
   AProcess.showWindow:=swoMinimize;
   try
   try
      AProcess.Execute;
      if opWaitFor then
        while Aprocess.running  do
           begin
              Application.processmessages;
              sleep(40);
              if CtrlBreakHit then AProcess.terminate(0);
           end;

      result:=Aprocess.ExitStatus=0;
   finally
      AProcess.Free;
   end;
   except
   end;
end;

{$IFDEF Windows}
function ShellExecEX(const s1,s2:AnsiString; opWaitFor:boolean; const CurDir:AnsiString ):boolean;
var
   tsh : TSHELLEXECUTEINFOA;
   lpdwExitCode:dword;
const verb:string='open';
begin
   CtrlBreakHit:=false;
   with tsh do
      begin
            cbSize:=Sizeof(tsh);
            fmask:=SEE_MASK_NOCLOSEPROCESS; // プロセスハンドルをクローズしない
            WND:=CodeForm.Handle;
            lpVerb:=pchar(verb);   // 'open';
            lpFile:=PChar(s1);
            lpParameters:=Pchar(s2);
            lpDirectory:=PChar(CurDir);
            nShow:=SW_HIDE;
      end;

   result:=ShellExecuteExA(@tsh);
   if result then
      begin
          // hProcessがシグナル状態になるまで待つ
         if opWaitFor then
              while WaitForSingleObject(tsh.hProcess,100)=WAIT_TIMEOUT do
                 begin
                    Application.processmessages;
                    sleep(40);
                    if CtrlBreakHit then TerminateProcess(tsh.hProcess,0);
                 end;
         CloseHandle(tsh.hProcess);
      end ;
end;
{$ELSE}
function ShellExecEX(const s1,s2:AnsiString; opWaitFor:boolean; const CurDir:AnsiString ):boolean;
begin
   result:=ShellExec(s1,s2,opWaitfor, CurDir)
end;
{$ENDIF}

function GetAppPath:string;
var
   AppPath:String;
begin
   Apppath:=ExtractFileDir(application.exename);
   {$IFDEF Darwin}
   //Apppath:=copy(Apppath, 1,pos('BASICAcc.app',Apppath)-2);
   {$ENDIF}
   result:=AppPath;
end;


function MakeFileName:string;
begin
   result:=GetAppPath+'/output/NoName.lpr';
end;


function InvokeCompiler(const FName:string;Rebuild:boolean):boolean;
var
   SystemStackSize:int64;
   s1,s2,s3:string;
   AppPath:string;
   FPCPath,LazarusPath,UnitPath1,UnitPath2,PrintersPath,CairocanvasPath,SynEditPath,SynEditPath2,LazUtilsPath:string;
   //c:boolean;
   TargetCPU,TargetOS:string;
   Optilevel:string;
   lclType:string;

begin
{$IFDEF Windows}
   lclType:='win32';
{$ENDIF}
{$IFDEF LclGTK}
   lclType:='gtk';
{$ENDIF}
{$IFDEF LclGTK2}
   lclType:='gtk2';
{$ENDIF}
{$IFDEF LclQt}
   lclType:='qt';
{$ENDIF}
{$IFDEF Darwin}
 if TargetCPU64 then
   lclType:='cocoa'
 else
   lclType:='carbon';
{$ENDIF}

  result:=false;
  AppPath:=GetAppPath;
  {$IFDEF Windows}
  IF AppPath<>UTF8ToNative(AppPath) then
     begin
        MessageDlg(
        'BASICAcc must be placed on a folder whose path-name contains no non-ASCII caharacters'
        , mtError, [mbOK],0);
        exit;
     end;
  {$ENDIF}

  if TargetCPU64 then
     begin
        FPCPath:=SetPath.Path3;
        LazarusPath:=SetPath.Path4;
     end
  else
     begin
        FPCPath:=SetPath.Path1;
        LazarusPath:=SetPath.Path2;
     end;

  {$IFDEF Windows}
   FPCPath:=FPCPath+'\fpc.exe';
  {$ELSE}
   {$IFDEF Darwin}
     if TargetCPU64 then
        FPCPath:=FPCPath+'/ppcx64'
     else
        FPCPath:=FPCPath+'/ppc386';
   {$ELSE}
    FPCPath:=FPCPath+'/fpc';
   {$ENDIF}
  {$ENDIF}

  if TargetCPU64 then
     TargetCPU:='x86_64'
  else
     TargetCPU:='i386';

  if TargetCPU64 then
     Optilevel:=IntToStr(base0.OptimizeLevel64)
  else
     Optilevel:=IntToStr(base0.OptimizeLevel32);

{$IFDEF Windows}
   if TargetCPU64 then
     TargetOS:='win64'
   else
     TargetOS:='win32';
{$ENDIF}
{$IFDEF Linux}
   TargetOS:='linux';
{$ENDIF}
{$IFDEF Darwin}
   TargetOS:='darwin';
{$ENDIF}

   Unitpath1:=Lazaruspath  +'/lcl/units/'+TargetCPU+'-'+TargetOS ;
   Unitpath2:=UnitPath1+'/'+LclType;
   PrintersPath:=LazarusPath
                 +'/components/printers/lib/'+TargetCPU+'-'+TargetOS+'/'+LclType;
   CairoCanvasPath:=LazarusPath                                                      //Lazarus 1.1
                 +'/components/cairocanvas/lib/'+TargetCPU+'-'+TargetOS+'/'+LclType;
   SynEditPath:=LazarusPath
                 +'/components/synedit/units/'+TargetCPU+'-'+TargetOS;
   SynEditPath2:=SynEditpath+'/'+LclType;
   LazUtilsPath:= LazarusPath
                            +'/components/lazutils/lib/'+TargetCPU+'-'+TargetOS ;

    if not FileExists(FPCPath) then
       begin
         showMessage(FPCPath+' not found'+EOL+'do setup FPC Path');
         exit;
       end;
    if not DirectoryExists(Unitpath1) then
       begin
         showMessage(Unitpath1+' not found'+EOL+'do setup Lazarus Path');
         exit;
       end;

   ReportForm.hide;
   setInvokingNow(true);
   sleep(10);
   Application.ProcessMessages;

  if TargetCPU64 then
     SystemStackSize:=SystemStackSize64
  else
     SystemStackSize:=SystemStackSize32;

     //dir2:=ExtractFileDir(frameForm.OpenDialog1.FileName);
   SysUtils.DeleteFile(ChangeFileExt(FName,'.err'));
   SysUtils.DeleteFile(GetApppath+'/output/BASICunit.*');
   CopyFile(GetAppPath+'/source/NoName.lpr', FName, [cffPreserveTime, cffOverwriteFile]);
   {$IFNDEF Darwin}
   CopyFile(GetAppPath+'/source/NoName.res', GetAppPath+'/output/NoName.res', [cffPreserveTime, cffOverwriteFile]);
   {$ENDIF}
   CodeForm.Memo1.Lines.SaveToFile(GetApppath+'/output/BASICunit.pas');

   s1:=FPCPath;                //'C:\Lazarus\FPC\2.2.4\bin\i386-win32\fpc.exe';

   s2:='';
   //s2:=s2 +' -g -gl -gh -Xg ';      // debug
   s2:=s2+' -v0 ';          // Show nothing except errors

 if Rebuild then
    s2:=s2
      +' -B ';                   // Rebuild

   if UseHeapForArrays32 and not TargetCPU64 or UseHeapForArrays64 and TargetCpu64 then
    s2:=s2
      +' -dHeapArrays ';

   if OmitIndexCheck then
    s2:=s2
      +' -dOmitIndexCheck ';

  if UseAltLongIntRound or TargetCPU64 then
    s2:=s2
      +' -dUseAltLongIntRound ' ;

  if TargetCPU64 then
    s2:=s2
     +' -Px86_64 ';

  if TargetCPU64 and availSSE41 then
    s2:=s2
     +' -dAvailSSE41 ';

  if UseSmartLink then
   s2:=s2+' -CX -XX ';

   s2:=s2
     +' -Rintel'
     +' -MObjFPC'
    {$IFDEF Linux}
     +' -Fu'+CairocanvasPath    // bug ?
    {$ENDIF}
     +' -Fu'+PrintersPath
     +' -Fu'+SynEditPath
     +' -Fu'+SynEditPath2
     +' -Fu'+LazUtilsPath
     +' -Fu'+UnitPath1         //'C:\Lazarus\lcl\units\i386-win32'
     +' -Fu'+Unitpath2         //'C:\Lazarus\lcl\units\i386-win32\win32'
     +' -Fu'+AppPath+'/output'
     +' -Fu'+AppPath+'/source'
     +' -Fu'+AppPath
     +' -Fe'+ChangeFileExt(FName,'.err')
     +' -FE'+AppPath+'/output'
     +' -Sgix';       // Enable LABEL and GOTO, Turn on inlining, Enable exception keywords
 if OptiLevel<>'0' then
   s2:=s2
     +' -O'+OptiLevel+' ';          // Optimization Level
 if TargetCPU64 then
    if CfAVX2 then
       s2:=s2
          +' -CfAVX2 '
    else if CfAVX then
       s2:=s2
          +' -CfAVX ';
 if TargetCPU64 then
    s2:=s2
      +base0.AdditionalOptions64
 else
    s2:=s2
      +base0.AdditionalOptions32;
 if (TargetCPU64 and OoFastMath64) or (not TargetCPU64 and OoFastMath32) then
   s2:=s2
     +' -OoFastMath ';    // Use registers

 s2:=s2
     +' -Ci+ '         // enables I/O check
     +' -Ct+ '         // enables stack Check
     +' -Cg- '         // Disable generationg PIC code
     +' -Xs+ '         // Strip the symbols from the executable.
     +' -dLCL '
   {$IFDEF Windows}
     +' -dLclWin32 '
   {$ENDIF}
   {$IFDEF LclGTK2}
     +' -dLclGTK2 '
   {$ENDIF}
   {$IFDEF Darwin}
   ;if TargetCPU64 then
      s2:=s2+' -dLcLCocoa '
    else
      s2:=s2+' -dLclCarbon ';
    s2:=s2
   {$ENDIF}
   {$IFDEF LclQt}
     +' -dLclQt '
   {$ENDIF}
   {$IFDEF Windows}
     +' -WG '          // Windows GUI application
   {$ELSE}
     +' -Cs' +IntToStr(SystemStackSize)+' '
   {$ENDIF}
   {$IFDEF Darwin}
     //+' -Fl/sw/lib '
     //+' -Fl/usr/X11R6/lib '
   {$ENDIF}
   {$IF FPC_FULlVERSION< 20600}
     +' -St+ '         // Allow static keyword in objects
   {$ENDIF}
     + FName ;


   result:=ShellExec(PChar(s1),PChar(s2),true, GetCurrentDir);   //fpcでコンパイル
   if result=false then
      if Rebuild=false then
         result:=InvokeCompiler(FName,true)                //再試行
      else
         begin
            with CodeForm do
              begin
               visible:=True;
               WindowState:=wsNormal;
               BringToFront;
              end;
            s3:=ChangeFileExt(FName,'.err');
            if fileExists(s3) then
                ReportForm.memo1.lines.LoadFromFile(s3)
            else
                ReportForm.memo1.lines.add('Confirm that FPC has been installed correctly.');
            ReportForm.show

         end;
   setInvokingNow(false);
end;

procedure ExecuteFile(const FName:string);
var
   s1,s2,s3,s4:string;
   dir1,dir2:string;
begin
  setExecutingNow(true);
  dir1:=GetCurrentDir;
  dir2:=ExtractFileDir(frameForm.OpenDialog1.FileName);
  SetCurrentDir(dir2);
  s2:='';
 {$IFDEF Windows}
  s1:=ChangeFileExt(FName,'.exe');
 {$ELSE}
   {$IFDEF Darwin}
   s1:='open';
   s2:=ChangeFileExt(FName,'.app');
   //CopyFile(GetAppPath+'/source/NoName.app', GetAppPath+'/output/NoName.app', [cffOverwriteFile]);
   s3:=ChangeFileExt(FName,'');
   s4:=ExtractFileNameOnly(s3);
   if not fileexists(s3+'.app') then
      begin
       CreateMacOSXApplicationResources(s3,s4,'');
       ShellExecEx('ln', '-s -s ../../../'+s4+' '+s3+'.app/Contents/MacOS/'+s4,true, dir2);
      end;
   {$ELSE}
   s1:=ChangeFileExt(FName,'');
   {$ENDIF}
 {$ENDIF}
  ShellExecEx(PChar(s1),Pchar(s2),true, dir2);     // 実行
  SetCurrentDir(dir1);
  setExecutingNow(false);
end;



procedure noefect;
begin
end;

function dummy:TStatement;
begin
   dummy:=nil
end;


begin
  setIndentOption:=noefect;
   setoperation:=noefect;
   setRunOption:=noefect;
   setRunOption2:=noefect;
   setDebug:=noefect;
   changedir:=noefect;
   setLineEndMarker:=noefect;
   setRefferingPath:=noefect;

end.
