paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 12:18:30 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
fpc/packages/ide/fp.pas

622 lines
15 KiB
ObjectPascal
Raw Permalink Blame History

{
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;
OverrideLastDirOption:=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);
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}
var
_GDBVersion: String;
BEGIN
{$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;
{$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;
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)}
StreamError:=nil;
{$ifdef DEBUG}
if CloseImmediately then
writeln('Used time is ',getrealtime-StartTime:0:2);
{$endif DEBUG}
END.
Reference in New Issue View Git Blame Copy Permalink