freepascal.compiler/packages/ide/fp.pas

{
    This file is part of the Free Pascal Integrated Development Environment
    Copyright (c) 1998-2000 by Berczi Gabor

    Main program of the IDE

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
program FP;

{$ifdef Windows}
{ some windows versions, namely at least XP x64 don't like if the IDE stack
  is too big }
{$maxstacksize 3000000}
{$ifdef IncRes}
{$R fpw32t.rc}
{$R fpw32ico.rc}
{$endif IncRes}
{$endif Windows}

{$I globdir.inc}
(**********************************************************************)
(* CONDITIONAL DEFINES                                                *)
(*  - NODEBUG    No Debugging support                                 *)
(*  - i386       Target is an i386 IDE                                *)
(**********************************************************************)

uses
{$ifdef Windows}
  windows,
{$endif Windows}
{$ifndef NODEBUG}
{$ifdef Windows}
  {$ifdef USE_MINGW_GDB}
    fpmingw,
  {$else}
    fpcygwin,
  {$endif}
{$endif Windows}
{$endif NODEBUG}
{$ifdef IDEHeapTrc}
  PPheap,
{$endif IDEHeapTrc}
{$ifdef Use_DBGHEAP}
  dbgheap,
{$endif Use_DBGHEAP}
{$ifdef go32v2}
  dpmiexcp,
{$endif go32v2}
{$ifdef VESA}
  vesa,
{$endif VESA}
  keyboard,video,mouse,
{$ifdef HasSignal}
  fpcatch,
{$endif HasSignal}
  Dos,Objects,
  BrowCol,Version,
{$ifndef NODEBUG}
  {$ifdef GDBMI}
    gdbmiint,
  {$else GDBMI}
    gdbint,
  {$endif GDBMI}
{$endif NODEBUG}
  FVConsts,
  Drivers,Views,App,Dialogs,HistList,
  Menus,StdDlg,Validate,
  WEditor,WCEdit,
{$ifdef COLORSEL}
  ColorSel,
{$endif COLORSEL}
  ASCIITab,
  WUtils,WViews,WHTMLScn,WHelp,
  FPIDE,FPCalc,FPCompil,
  FPIni,FPViews,FPConst,FPVars,FPUtils,FPHelp,FPSwitch,FPUsrScr,
  FPTools,
{$ifndef NODEBUG}
  FPDebug,FPRegs,
{$ifdef GDBMI}
  gdbmiproc,
{$endif GDBMI}
{$endif}
  FPTemplt,FPRedir,FPDesk,
  FPCodTmp,FPCodCmp,

  systems,globtype,globals;


Const
  DummyMouseDriver : TMouseDriver = (
    useDefaultQueue : true;
    InitDriver      : nil;
    DoneDriver      : nil;
    DetectMouse     : nil;
    ShowMouse       : nil;
    HideMouse       : nil;
    GetMouseX       : nil;
    GetMouseY       : nil;
    GetMouseButtons : nil;
    SetMouseXY      : nil;
    GetMouseEvent   : nil;
    PollMouseEvent  : nil;
    PutMouseEvent   : nil;
  );

{$ifdef useresstrings}
resourcestring
{$else}
const
{$endif}
      { caught signals or abnormal exits }
            { Debugger messages and status hints }
      error_programexitedwitherror = #3'Program generated a RTE %d'#13+
                                     #3'at address $%s.'#13+
                                     #3'Save your sources and restart the IDE.';
      error_programexitedwithsignal = #3'Program generated a signal %d.'#13+
                                      #3'Save your sources and restart the IDE.';

      continue_despite_error = #3'The IDE generated an internal error'#13+
                            #3'Do you really want to continue?'#13+
                            #3'The IDE could be in an unstable state.';

      leaving_after_error = #3'The IDE generated an internal error'#13+
                            #3'and will now be closed.';

{$ifdef DEBUG}
const
  CloseImmediately : boolean = false;
var
  StartTime : real;

  function getrealtime : real;
  var
    h,m,s,s100 : word;
  begin
    gettime(h,m,s,s100);
    getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
  end;

{$endif DEBUG}

procedure ProcessParams(BeforeINI: boolean);

  function IsSwitch(const Param: string): boolean;
  begin
    IsSwitch:=(Param<>'') and (Param[1]<>DirSep) { <- allow UNIX root-relative paths            }
          and (Param[1] in ['-','/']);           { <- but still accept dos switch AnsiChar, eg. '/' }
  end;

var I: Sw_integer;
    Param: string;
begin
  for I:=1 to ParamCount do
  begin
    Param:=System.ParamStr(I);
    if IsSwitch(Param) then
      begin
        Param:=copy(Param,2,255);
        if Param<>'' then
        if UpcaseStr(copy(Param,1,2))='HM' then
          { HeapMonitor }
          begin
            if (copy(Param,3,1)='+') or (copy(Param,3,1)='') then
              StartupOptions:=StartupOptions or soHeapMonitor
            else
            if (copy(Param,3,1)='-') then
              StartupOptions:=StartupOptions and not soHeapMonitor;
            OverrideHeapMonitor:=true;
          end else
{$ifdef go32v2}
        if (UpcaseStr(Param)='NOLFN') or (UpcaseStr(Param)='N') then
          begin
            LFNSupport:=false;
          end else
{$endif go32v2}
{$ifdef VESA}
        if UpcaseStr(Param)='NOVESA' then
          begin
            disableVESA:=true;
          end else
        if UpcaseStr(Param)='VESA' then
          begin
(* Force using VESA although it may have been disabled by default *)
            disableVESA:=false;
          end else
{$endif VESA}
        if UpcaseStr(Param)='README' then
          begin
            ShowReadme:=true;
          end else
        case Upcase(Param[1]) of
          'C' : { custom config file (BP compatiblity) }
           if BeforeINI then
            begin
              delete(param,1,1); // delete C
              if (length(Param)>=1) and (Param[1] in['=',':']) then
                Delete(Param,1,1); { eat optional separator }
              IniFileName:=MakeFileNameExt(Param,IniExt);
              DesktopFileName:=MakeFileNameExt(Param,DesktopExt);
              SwitchesFileName:=MakeFileNameExt(Param,SwitchesExt);
              DirInfoFileName:=MakeFileNameExt(Param,DirInfoExt);
            end;
{$ifdef GDBMI}
          'G' : { custom GDB exec file (GDBMI mode only) }
           if BeforeINI then
            begin
              delete(param,1,1); // delete C
              if (length(Param)>=1) and (Param[1] in['=',':']) then
                Delete(Param,1,1); { eat optional separator }
              GDBProgramName:=Param;
            end;
{$endif def GDBMI}
          'R' : { enter the directory last exited from (BP comp.) }
            begin
              Param:=copy(Param,2,255);
              if (Param='') or (Param='+') then
                StartupOptions:=StartupOptions or soReturnToLastDir
              else
              if (Param='-') then
                StartupOptions:=StartupOptions and (not soReturnToLastDir);
              OverrideLastDirOption:=true;
            end;
          'S' :
             if Length(Param)=1 then
               begin
                 UseMouse:=false;
                 DoneMouse;
                 SetMouseDriver(DummyMouseDriver);
                 ButtonCount:=0;
               end;
{          'F' :
             if Length(Param)=1 then
               NoExtendedFrame:=true;}
{$ifdef Unix}
          'T' :  DebuggeeTTY:=Copy(Param,2,High(Param));
{$endif Unix}
         { 'M' : TryToMaximizeScreen:=true;}
{$ifdef DEBUG}
          'Z' : UseOldBufStreamMethod:=true;
          'X' : CloseImmediately:=true;
{$endif DEBUG}
        end;
      end
    else
      if not BeforeINI then
        TryToOpenFileMulti(nil,Param,0,0,{false}true);
  end;
end;

Procedure MyStreamError(Var S: TStream);
var ErrS: string;
begin
  case S.Status of
    stGetError : ErrS:='Get of unregistered object type';
    stPutError : ErrS:='Put of unregistered object type';
  else ErrS:='';
  end;
  if ErrS<>'' then
  begin
    if (application<>nil) and (ideapp.displaymode=dmIDE) then
      ErrorBox('Stream error: '+#13+ErrS,nil)
    else

      writeln('Error: ',ErrS);
  end;
end;

procedure DelTempFiles;
begin
  DeleteFile(FPOutFileName);
  DeleteFile(FPErrFileName);
  DeleteFile(GDBOutFileName);
  DeleteFile(GDBOutPutFileName);
  DeleteFile(GREPOutName);
  DeleteFile(GREPErrName);
end;

procedure RegisterIDEObjects;
begin
  RegisterApp;
  RegisterCodeComplete;
  RegisterCodeTemplates;
{$ifdef COLORSEL}
  RegisterColorSel;
{$endif COLORSEL}
  RegisterAsciiTab;
  RegisterDialogs;
  RegisterWEditor;
  RegisterWCEdit;
  RegisterFPCalc;
  RegisterFPCompile;
  RegisterFPTools;
  RegisterFPViews;
{$ifndef NODEBUG}
  RegisterFPDebugViews;
  RegisterFPRegsViews;
{$endif}
  RegisterMenus;
  RegisterStdDlg;
  RegisterSymbols;
  RegisterObjects;
  RegisterValidate;
  RegisterViews;

  RegisterWHTMLScan;
  RegisterWUtils;
  RegisterWViews;
end;

var CanExit : boolean;
    SetJmpRes : longint;
    StoreExitProc : pointer;
    ErrS : String;
    P : record
          l1 : longint;
          s : pstring;
        end;
const
  ExitIntercepted : boolean = false;
  SeenExitCode : longint =0;
  SeenErrorAddr : pointer = nil;
  UserWantsToGoOn: boolean = false;


procedure InterceptExit;
begin
{$IFDEF HasSignal}
  if StopJmpValid then
    begin
      ExitIntercepted:=true;
      SeenExitCode:=ExitCode;
      SeenErrorAddr:=ErrorAddr;
      LongJmp(StopJmp,1);
    end;
{$ENDIF}
end;


procedure InitCompilerSwitches;
  begin
    default_settings.globalswitches:=[cs_check_unit_name];
    default_settings.moduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
    default_settings.localswitches:=[cs_typed_const_writable];
  end;

{$IFDEF HASAMIGA}
procedure SetAmigaWindowTitle;
begin
  { window title first, then screen title, shown when the window is active }
  Video.SetWindowTitle(
     'Free Pascal IDE',
     'Free Pascal IDE '+VersionStr+' ['+{$i %date%}+'] - Compiler '+Full_Version_String);
end;
{$ENDIF}
{The square bullet needs an MS-DOS code page. On Unix it is for sure the code
 page is not available before video is initialized. (And only in certain
 circumstances after that, so, use a plain ascii character as bullet on Unix.)}

{$if defined(unix) or defined(HASAMIGA)}
const bullet='*';
{$else}
const bullet=#254;
{$endif}

{ For DOS in program active current directory is actual system current }
{ directory. Have to save and restore on exit.                         }
{$ifdef go32v2}
var
  DirectoryInvokeFpFrom : String;
  ChDirRes : Word;
{$endif}

var
  _GDBVersion: String;

BEGIN
{$ifdef go32v2}
  GetDir(0,DirectoryInvokeFpFrom);  {save for restore on exit}
{$endif}
{$IFDEF HasSignal}
  EnableCatchSignals;
{$ENDIF}
{$ifdef DEV}
  HeapLimit:=4096;
{$endif}
  HistorySize:=16384;

  { Startup info }
  writeln(bullet+' Free Pascal IDE Version '+VersionStr+' ['+{$i %date%}+']');
  writeln(bullet+' Compiler Version '+Full_Version_String);

  { Process params before printing GDB version because of /G option }
  ProcessParams(true);

{$ifndef NODEBUG}

  _GDBVersion:=GDBVersion;
  while pos(#13#3,_GDBVersion)<>0 do
    Delete(_GDBVersion,pos(#13#3,_GDBVersion),2);
  writeln(bullet+' GDB Version '+_GDBVersion);

 {$ifdef Windows}
  {$ifndef USE_MINGW_GDB}
   {$ifdef GDBMI}
   { No reason to talk about cygwin DLL if we don't use it }
   if using_cygwin_gdb then
   {$endif GDBMI}
     begin
       writeln(bullet+' Cygwin "',GetCygwinFullName,'" version ',GetCygwinVersionString);
       CheckCygwinVersion;
     end;
  {$endif}
 {$endif Windows}
{$endif NODEBUG}

{$ifdef DEBUG}
  StartTime:=getrealtime;
{$endif DEBUG}

  InitDirs;

  RegisterIDEObjects;
  StreamError:=@MyStreamError;

  ShowReadme:=ShowReadme or (LocateFile(INIFileName)='');
  if LocateFile(INIFileName)<>'' then
    writeln(bullet+' Using configuration files from: ',DirOf(LocateFile(INIFileName)));

  InitCompilerSwitches;

{$ifdef VESA}
  writeln(stderr,'If program stops, try again using -novesa option');
  flush(stderr);
  InitVESAScreenModes;
  if RegisteredVesaVideoModeCount > 0 then
    SetVESAVideoDriver;
{$endif}
  InitRedir;
{$ifndef NODEBUG}
  InitBreakpoints;
  InitWatches;
{$endif}
  InitReservedWords;
  InitHelpFiles;
  InitSwitches;
  InitINIFile;
  InitUserScreen;
  InitTools;
  InitTemplates;
  InitCodeTemplates;
  InitCodeComplete;

  { init target information etc. }
  InitSystems;

  IDEApp.Init;
  CheckINIFile;
  ReadSwitches(SwitchesPath);
  { load all options after init because of open files }
  ReadINIFile;
  InitDesktopFile;
  LoadDesktop;

  {Adjust to current directory, might be changed by LoadDesktop.}
  IDEapp.CurDirChanged;

  {Menubar might be changed because of loading INI file.}
  IDEapp.reload_menubar;

  { Handle Standard Units }
  if UseAllUnitsInCodeComplete then
    AddAvailableUnitsToCodeComplete(false);

  if UseStandardUnitsInCodeComplete and not assigned(UnitsCodeCompleteWords) then
    AddStandardUnitsToCodeComplete;

  { why are the screen contents parsed at startup? Gabor
    to be able to find location of error in last compilation
    from command line PM }
  ParseUserScreen;

{$IFDEF HASAMIGA}
  SetAmigaWindowTitle;
{$ENDIF}

  { Update IDE }
  IDEApp.Update;
  IDEApp.UpdateMode;
  IDEApp.UpdateTarget;
  IDEApp.UpdateClockAndHeap;

  ProcessParams(false);

  if ShowReadme then
  begin
    PutCommand(Application,evCommand,cmShowReadme,nil);
    ShowReadme:=false; { do not show next time }
  end;

  StoreExitProc:=ExitProc;
  ExitProc:=@InterceptExit;


  repeat
{$IFDEF HasSignal}
     SetJmpRes:=setjmp(StopJmp);
     StopJmpValid:=true;
{$ENDIF}
    UserWantsToGoOn:=false;

    if SetJmpRes=0 then
      begin
{$ifdef DEBUG}
        if not CloseImmediately then
{$endif DEBUG}
          IDEApp.Run;
      end
    else
      begin
        if (SetJmpRes=1) and ExitIntercepted then
          begin
            { If ExitProc=@InterceptExit then
              ExitProc:=StoreExitProc;}
            Str(SeenExitCode,ErrS);
            if (application<>nil) and (ideapp.displaymode=dmIDE) then
              begin
                P.l1:=SeenExitCode;
                ErrS:=hexstr(PtrUInt(SeenErrorAddr),sizeof(PtrUInt)*2);
                P.s:=@ErrS;
                if OKCancelBox(error_programexitedwitherror,@P)=cmCancel then
                  UserWantsToGoOn:=true;
              end
            else
              writeln('Abnormal exit error: ',ErrS);
          end
        else
          begin
            Str(SetJmpRes,ErrS);
          { Longjmp was called by fpcatch }
            if (application<>nil) and (ideapp.displaymode=dmIDE) then
              begin
                P.l1:=SetJmpRes;
                if OKCancelBox(error_programexitedwithsignal,@P)=cmCancel then
                  UserWantsToGoOn:=true;
              end
            else
              writeln('Signal error: ',ErrS);
          end;
        if ideapp.displaymode=dmUser then
          begin
            writeln('Fatal exception occurred while in user screen mode. File save message boxes');
            writeln('cannot be displayed. We are sorry, but need to terminate now.');
            halt(255);
          end;
      end;

    if (AutoSaveOptions and asEditorFiles)=0 then
      CanExit:=IDEApp.AskSaveAll
    else
      CanExit:=IDEApp.SaveAll;
{$IFDEF HasSignal}
     StopJmpValid:=false;
{$ENDIF}
    if (SetJmpRes<>0) then
      begin
        if (not CanExit) or UserWantsToGoOn then
          begin
            if ConfirmBox(continue_despite_error,nil,false)=cmNo then
              CanExit:=true
            else
              CanExit:=false;
          end
        else
          begin
            ErrorBox(leaving_after_error,nil);
          end;
      end;
  until CanExit;

  If ExitProc=pointer(@InterceptExit) then
    ExitProc:=StoreExitProc;
  IDEApp.AutoSave;

  DoneDesktopFile;

  DelTempFiles;
  IDEApp.Done;
  WriteSwitches(SwitchesPath);

{$IFDEF HasSignal}
   DisableCatchSignals;
{$ENDIF}

  DoneCodeComplete;
  DoneCodeTemplates;
  DoneTemplates;
  DoneTools;
  DoneUserScreen;
  DoneSwitches;
  DoneHelpFiles;
  DoneHelpFilesTypes;
  DoneReservedWords;
  DoneToolMessages;
  DoneBrowserCol;
{$ifndef NODEBUG}
  DoneDebugger;
  DoneBreakpoints;
  DoneWatches;
{$endif}
{$ifdef unix}
  Video.ClearScreen;
{$endif unix}
{  Video.DoneVideo;
  Keyboard.DoneKeyboard;}
{$ifdef VESA}
  DoneVESAScreenModes;
{$endif}
{$if defined(unix)}
  Keyboard.RestoreStartMode;
{$endif defined(unix)}
{$if defined(windows)}
  SetConsoleMode(GetStdHandle(cardinal(Std_Input_Handle)),StartupConsoleMode);
{$endif defined(windows)}
{$ifdef go32v2}
  {$push}
  {$i-}
  ChDir(DirectoryInvokeFpFrom); {restore active directory we invoke fp from }
  ChDirRes:=IOResult;
  if (ChDirRes<>0) then
    writeln('Failed to restore start up directory ',DirectoryInvokeFpFrom,' error=',ChDirRes);
  {$pop}
{$endif}
  StreamError:=nil;
{$ifdef DEBUG}
  if CloseImmediately then
    writeln('Used time is ',getrealtime-StartTime:0:2);
{$endif DEBUG}
END.