mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 10:19:30 +02:00
* detect arithmetic overflows for constants at compile time
* use try..except instead of setjmp
This commit is contained in:
peter
parent
b989cd1d4e
commit
d3b559cfcc
@ -25,14 +25,6 @@ Unit catch;
|
||||
|
||||
{$i fpcdefs.inc}
|
||||
|
||||
{$ifdef go32v2}
|
||||
{ go32v2 stack check goes nuts if ss is not the data selector (PM) }
|
||||
{$S-}
|
||||
{$endif}
|
||||
{$ifdef watcom} // wiktor: pewnei nie potrzeba
|
||||
{$S-}
|
||||
{$endif}
|
||||
|
||||
{$ifdef DEBUG}
|
||||
{$define NOCATCH}
|
||||
{$endif DEBUG}
|
||||
@ -61,14 +53,17 @@ uses
|
||||
|
||||
{$ifdef has_signal}
|
||||
Var
|
||||
NewSignal,OldSigSegm,
|
||||
OldSigInt,OldSigFPE : SignalHandler;
|
||||
NewSignal,
|
||||
OldSigInt : SignalHandler;
|
||||
{$endif}
|
||||
|
||||
Const in_const_evaluation : boolean = false;
|
||||
|
||||
Implementation
|
||||
|
||||
uses
|
||||
sysutils;
|
||||
|
||||
{$ifdef has_signal}
|
||||
{$ifdef unix}
|
||||
Procedure CatchSignal(Sig : Longint);cdecl;
|
||||
@ -77,22 +72,8 @@ Function CatchSignal(Sig : longint):longint;
|
||||
{$endif}
|
||||
begin
|
||||
case Sig of
|
||||
SIGSEGV : begin
|
||||
{ Temporary message - until we get an error number... }
|
||||
writeln ('Panic : Internal compiler error, exiting.');
|
||||
internalerror(9999);
|
||||
end;
|
||||
SIGFPE : begin
|
||||
If in_const_evaluation then
|
||||
Writeln('FPE error computing constant expression')
|
||||
else
|
||||
Writeln('FPE error inside compiler');
|
||||
Stop(1);
|
||||
end;
|
||||
SIGINT : begin
|
||||
WriteLn('Ctrl-C Signaled!');
|
||||
Stop(1);
|
||||
end;
|
||||
SIGINT :
|
||||
raise Exception.Create('Ctrl-C Signaled!');
|
||||
end;
|
||||
{$ifndef unix}
|
||||
CatchSignal:=0;
|
||||
@ -104,18 +85,18 @@ begin
|
||||
{$ifndef nocatch}
|
||||
{$ifdef has_signal}
|
||||
NewSignal:=SignalHandler(@CatchSignal);
|
||||
{$ifndef sunos}
|
||||
OldSigSegm:={$ifdef havelinuxrtl10}Signal{$else}{$ifdef Unix}fpSignal{$else}Signal{$endif}{$endif} (SIGSEGV,NewSignal);
|
||||
{$endif} // lxrun on solaris hooks this for handling linux-calls!
|
||||
OldSigInt:={$ifdef havelinuxrtl10}Signal{$else}{$ifdef Unix}fpSignal{$else}Signal{$endif}{$endif} (SIGINT,NewSignal);
|
||||
OldSigFPE:={$ifdef havelinuxrtl10}Signal{$else}{$ifdef Unix}fpSignal{$else}Signal{$endif}{$endif} (SIGFPE,NewSignal);
|
||||
OldSigInt:={$ifdef havelinuxrtl10}Signal{$else}{$ifdef Unix}fpSignal{$else}Signal{$endif}{$endif} (SIGINT,NewSignal);
|
||||
{$endif}
|
||||
{$endif nocatch}
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.20 2004-10-15 09:14:16 mazen
|
||||
Revision 1.21 2005-01-26 16:23:28 peter
|
||||
* detect arithmetic overflows for constants at compile time
|
||||
* use try..except instead of setjmp
|
||||
|
||||
Revision 1.20 2004/10/15 09:14:16 mazen
|
||||
- remove $IFDEF DELPHI and related code
|
||||
- remove $IFDEF FPCPROCVAR and related code
|
||||
|
||||
|
||||
@ -122,9 +122,6 @@ uses
|
||||
{ dpmiexcp, }
|
||||
{$endif WATCOM}
|
||||
{$endif}
|
||||
{$ifdef USEEXCEPT}
|
||||
tpexcept,
|
||||
{$endif USEEXCEPT}
|
||||
{$ifdef BrowserLog}
|
||||
browlog,
|
||||
{$endif BrowserLog}
|
||||
@ -132,6 +129,7 @@ uses
|
||||
{$ELSE USE_SYSUTILS}
|
||||
dos,
|
||||
{$ENDIF USE_SYSUTILS}
|
||||
sysutils,
|
||||
verbose,comphook,systems,
|
||||
cutils,cclasses,globals,options,fmodule,parser,symtable,
|
||||
assemble,link,import,export,tokens,pass_1
|
||||
@ -245,16 +243,6 @@ var
|
||||
CompilerInited : boolean;
|
||||
olddo_stop : tstopprocedure;
|
||||
|
||||
{$ifdef USEEXCEPT}
|
||||
procedure RecoverStop(err:longint);
|
||||
begin
|
||||
if recoverpospointer<>nil then
|
||||
LongJmp(recoverpospointer^,1)
|
||||
else
|
||||
Stop(err);
|
||||
end;
|
||||
{$endif USEEXCEPT}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Compiler
|
||||
@ -286,10 +274,6 @@ begin
|
||||
DoneSymtable;
|
||||
DoneGlobals;
|
||||
donetokens;
|
||||
{$ifdef USEEXCEPT}
|
||||
recoverpospointer:=nil;
|
||||
longjump_used:=false;
|
||||
{$endif USEEXCEPT}
|
||||
end;
|
||||
|
||||
|
||||
@ -372,83 +356,80 @@ function Compile(const cmd:string):longint;
|
||||
|
||||
var
|
||||
starttime : real;
|
||||
{$ifdef USEEXCEPT}
|
||||
recoverpos : jmp_buf;
|
||||
{$endif}
|
||||
{$ifdef HASGETHEAPSTATUS}
|
||||
hstatus : THeapStatus;
|
||||
{$endif HASGETHEAPSTATUS}
|
||||
begin
|
||||
olddo_stop:=do_stop;
|
||||
do_stop:=@minimal_stop;
|
||||
{ Initialize the compiler }
|
||||
InitCompiler(cmd);
|
||||
try
|
||||
try
|
||||
{ Initialize the compiler }
|
||||
InitCompiler(cmd);
|
||||
|
||||
{ show some info }
|
||||
Message1(general_t_compilername,FixFileName(system.paramstr(0)));
|
||||
Message1(general_d_sourceos,source_info.name);
|
||||
Message1(general_i_targetos,target_info.name);
|
||||
Message1(general_t_exepath,exepath);
|
||||
WritePathList(general_t_unitpath,unitsearchpath);
|
||||
WritePathList(general_t_includepath,includesearchpath);
|
||||
WritePathList(general_t_librarypath,librarysearchpath);
|
||||
WritePathList(general_t_objectpath,objectsearchpath);
|
||||
{ show some info }
|
||||
Message1(general_t_compilername,FixFileName(system.paramstr(0)));
|
||||
Message1(general_d_sourceos,source_info.name);
|
||||
Message1(general_i_targetos,target_info.name);
|
||||
Message1(general_t_exepath,exepath);
|
||||
WritePathList(general_t_unitpath,unitsearchpath);
|
||||
WritePathList(general_t_includepath,includesearchpath);
|
||||
WritePathList(general_t_librarypath,librarysearchpath);
|
||||
WritePathList(general_t_objectpath,objectsearchpath);
|
||||
|
||||
{$ifdef USEEXCEPT}
|
||||
if setjmp(recoverpos)=0 then
|
||||
begin
|
||||
recoverpospointer:=@recoverpos;
|
||||
do_stop:=@recoverstop;
|
||||
{$endif USEEXCEPT}
|
||||
starttime:=getrealtime;
|
||||
{$ifdef PREPROCWRITE}
|
||||
if parapreprocess then
|
||||
parser.preprocess(inputdir+inputfile+inputextension)
|
||||
else
|
||||
{$endif PREPROCWRITE}
|
||||
parser.compile(inputdir+inputfile+inputextension);
|
||||
if status.errorcount=0 then
|
||||
begin
|
||||
starttime:=getrealtime-starttime;
|
||||
if starttime<0 then
|
||||
starttime:=starttime+3600.0*24.0;
|
||||
Message2(general_i_abslines_compiled,tostr(status.compiledlines),tostr(trunc(starttime))+
|
||||
'.'+tostr(trunc(frac(starttime)*10)));
|
||||
end;
|
||||
{$ifdef USEEXCEPT}
|
||||
end;
|
||||
{$endif USEEXCEPT}
|
||||
starttime:=getrealtime;
|
||||
|
||||
{ Stop is always called, so we come here when a program is compiled or not }
|
||||
do_stop:=olddo_stop;
|
||||
{ Stop the compiler, frees also memory }
|
||||
{ no message possible after this !! }
|
||||
DoneCompiler;
|
||||
{ Compile the program }
|
||||
{$ifdef PREPROCWRITE}
|
||||
if parapreprocess then
|
||||
parser.preprocess(inputdir+inputfile+inputextension)
|
||||
else
|
||||
{$endif PREPROCWRITE}
|
||||
parser.compile(inputdir+inputfile+inputextension);
|
||||
|
||||
{ Set the return value if an error has occurred }
|
||||
if status.errorcount=0 then
|
||||
Compile:=0
|
||||
else
|
||||
Compile:=1;
|
||||
{ Show statistics }
|
||||
if status.errorcount=0 then
|
||||
begin
|
||||
starttime:=getrealtime-starttime;
|
||||
if starttime<0 then
|
||||
starttime:=starttime+3600.0*24.0;
|
||||
Message2(general_i_abslines_compiled,tostr(status.compiledlines),tostr(trunc(starttime))+
|
||||
'.'+tostr(trunc(frac(starttime)*10)));
|
||||
end;
|
||||
finally
|
||||
{ no message possible after this !! }
|
||||
DoneCompiler;
|
||||
end;
|
||||
except
|
||||
|
||||
DoneVerbose;
|
||||
Message(general_e_compilation_aborted);
|
||||
|
||||
DoneVerbose;
|
||||
|
||||
Raise;
|
||||
end;
|
||||
{$ifdef SHOWUSEDMEM}
|
||||
{$ifdef HASGETHEAPSTATUS}
|
||||
GetHeapStatus(hstatus);
|
||||
Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb');
|
||||
GetHeapStatus(hstatus);
|
||||
Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb');
|
||||
{$else HASGETHEAPSTATUS}
|
||||
Writeln('Memory used (heapsize): ',DStr(system.Heapsize shr 10),' Kb');
|
||||
Writeln('Memory used (heapsize): ',DStr(system.Heapsize shr 10),' Kb');
|
||||
{$endif HASGETHEAPSTATUS}
|
||||
{$endif SHOWUSEDMEM}
|
||||
{$ifdef fixLeaksOnError}
|
||||
do_stop;
|
||||
{$endif fixLeaksOnError}
|
||||
|
||||
{ Set the return value if an error has occurred }
|
||||
if status.errorcount=0 then
|
||||
result:=0
|
||||
else
|
||||
result:=1;
|
||||
end;
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.51 2005-01-09 20:24:43 olle
|
||||
Revision 1.52 2005-01-26 16:23:28 peter
|
||||
* detect arithmetic overflows for constants at compile time
|
||||
* use try..except instead of setjmp
|
||||
|
||||
Revision 1.51 2005/01/09 20:24:43 olle
|
||||
* rework of macro subsystem
|
||||
+ exportable macros for mode macpas
|
||||
|
||||
|
||||
@ -112,6 +112,7 @@ general_i_hint=01016_I_Hint:
|
||||
% Prefix for Hints
|
||||
general_e_path_does_not_exist=01017_E_Path "$1" does not exist
|
||||
% The specified path does not exist.
|
||||
general_e_compilation_aborted=01018_E_Compilation aborted
|
||||
% \end{description}
|
||||
#
|
||||
# Scanner
|
||||
@ -996,6 +997,8 @@ parser_w_implicit_uses_of_variants_unit=03211_W_Implicit uses of Variants unit
|
||||
parser_e_no_static_method_in_interfaces=03212_E_Class and static methods can't be used in INTERFACES
|
||||
% The specifier \var{class} and directive \var{static} can't be used in interfaces
|
||||
% because all methods of an interfaces must be public.
|
||||
parser_e_arithmetic_operation_overflow=03213_E_Overflow in arithmetic operation
|
||||
% An operation on two integers values produced an overflow
|
||||
% \end{description}
|
||||
#
|
||||
# Type Checking
|
||||
@ -2315,7 +2318,7 @@ S*2Tlinux_Linux
|
||||
**2*_l : Show linenumbers r : Rhide/GCC compatibility mode
|
||||
**2*_a : Show everything x : Executable info (Win32 only)
|
||||
**2*_v : write fpcdebug.txt with p : Write tree.log with parse tree
|
||||
**2*_ lots of debugging info
|
||||
**2*_ lots of debugging info
|
||||
3*1W<x>_Win32-like target options
|
||||
3*2WB<x>_Set Image base to Hexadecimal <x> value
|
||||
3*2WC_Specify console type application
|
||||
|
||||
@ -17,6 +17,7 @@ const
|
||||
general_i_note=01015;
|
||||
general_i_hint=01016;
|
||||
general_e_path_does_not_exist=01017;
|
||||
general_e_compilation_aborted=01018;
|
||||
scan_f_end_of_file=02000;
|
||||
scan_f_string_exceeds_line=02001;
|
||||
scan_f_illegal_char=02002;
|
||||
@ -277,6 +278,7 @@ const
|
||||
parser_e_proc_already_external=03210;
|
||||
parser_w_implicit_uses_of_variants_unit=03211;
|
||||
parser_e_no_static_method_in_interfaces=03212;
|
||||
parser_e_arithmetic_operation_overflow=03213;
|
||||
type_e_mismatch=04000;
|
||||
type_e_incompatible_types=04001;
|
||||
type_e_not_equal_types=04002;
|
||||
@ -648,9 +650,9 @@ const
|
||||
option_info=11024;
|
||||
option_help_pages=11025;
|
||||
|
||||
MsgTxtSize = 37912;
|
||||
MsgTxtSize = 37975;
|
||||
|
||||
MsgIdxMax : array[1..20] of longint=(
|
||||
18,68,213,59,57,46,100,20,35,60,
|
||||
19,68,214,59,57,46,100,20,35,60,
|
||||
40,1,1,1,1,1,1,1,1,1
|
||||
);
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -69,6 +69,7 @@ interface
|
||||
implementation
|
||||
|
||||
uses
|
||||
sysutils,
|
||||
globtype,systems,
|
||||
cutils,verbose,globals,widestr,
|
||||
symconst,symtype,symdef,symsym,symtable,defutil,defcmp,
|
||||
@ -265,6 +266,7 @@ implementation
|
||||
((rt = pointerconstn) or (rt = niln)) and
|
||||
(nodetype in [ltn,lten,gtn,gten,equaln,unequaln,subn])) then
|
||||
begin
|
||||
t:=nil;
|
||||
{ when comparing/substracting pointers, make sure they are }
|
||||
{ of the same type (JM) }
|
||||
if (lt = pointerconstn) and (rt = pointerconstn) then
|
||||
@ -317,24 +319,81 @@ implementation
|
||||
lv := lv * tpointerdef(right.resulttype.def).pointertype.def.size;
|
||||
case nodetype of
|
||||
addn :
|
||||
if (lt <> pointerconstn) then
|
||||
t := genintconstnode(lv+rv)
|
||||
else
|
||||
t := cpointerconstnode.create(lv+rv,left.resulttype);
|
||||
begin
|
||||
{$ifopt Q-}
|
||||
{$define OVERFLOW_OFF}
|
||||
{$Q+}
|
||||
{$endif}
|
||||
try
|
||||
if (lt <> pointerconstn) then
|
||||
t := genintconstnode(lv+rv)
|
||||
else
|
||||
t := cpointerconstnode.create(lv+rv,left.resulttype);
|
||||
except
|
||||
on E:EIntOverflow do
|
||||
begin
|
||||
Message(parser_e_arithmetic_operation_overflow);
|
||||
{ Recover }
|
||||
t:=genintconstnode(0)
|
||||
end;
|
||||
end;
|
||||
{$ifdef OVERFLOW_OFF}
|
||||
{$Q-}
|
||||
{$undef OVERFLOW_OFF}
|
||||
{$endif}
|
||||
end;
|
||||
subn :
|
||||
if (lt=pointerconstn) and (rt=pointerconstn) and
|
||||
(tpointerdef(rd).pointertype.def.size>1) then
|
||||
t := genintconstnode((lv-rv) div tpointerdef(left.resulttype.def).pointertype.def.size)
|
||||
else if (lt <> pointerconstn) or (rt = pointerconstn) then
|
||||
t := genintconstnode(lv-rv)
|
||||
else
|
||||
t := cpointerconstnode.create(lv-rv,left.resulttype);
|
||||
begin
|
||||
{$ifopt Q-}
|
||||
{$define OVERFLOW_OFF}
|
||||
{$Q+}
|
||||
{$endif}
|
||||
try
|
||||
if (lt=pointerconstn) and (rt=pointerconstn) and
|
||||
(tpointerdef(rd).pointertype.def.size>1) then
|
||||
t := genintconstnode((lv-rv) div tpointerdef(left.resulttype.def).pointertype.def.size)
|
||||
else if (lt <> pointerconstn) or (rt = pointerconstn) then
|
||||
t := genintconstnode(lv-rv)
|
||||
else
|
||||
t := cpointerconstnode.create(lv-rv,left.resulttype);
|
||||
except
|
||||
on E:EIntOverflow do
|
||||
begin
|
||||
Message(parser_e_arithmetic_operation_overflow);
|
||||
{ Recover }
|
||||
t:=genintconstnode(0)
|
||||
end;
|
||||
end;
|
||||
{$ifdef OVERFLOW_OFF}
|
||||
{$Q-}
|
||||
{$undef OVERFLOW_OFF}
|
||||
{$endif}
|
||||
end;
|
||||
muln :
|
||||
if (torddef(ld).typ <> u64bit) or
|
||||
(torddef(rd).typ <> u64bit) then
|
||||
t:=genintconstnode(lv*rv)
|
||||
else
|
||||
t:=genintconstnode(int64(qword(lv)*qword(rv)));
|
||||
begin
|
||||
{$ifopt Q-}
|
||||
{$define OVERFLOW_OFF}
|
||||
{$Q+}
|
||||
{$endif}
|
||||
try
|
||||
if (torddef(ld).typ <> u64bit) or
|
||||
(torddef(rd).typ <> u64bit) then
|
||||
t:=genintconstnode(lv*rv)
|
||||
else
|
||||
t:=genintconstnode(int64(qword(lv)*qword(rv)));
|
||||
except
|
||||
on E:EIntOverflow do
|
||||
begin
|
||||
Message(parser_e_arithmetic_operation_overflow);
|
||||
{ Recover }
|
||||
t:=genintconstnode(0)
|
||||
end;
|
||||
end;
|
||||
{$ifdef OVERFLOW_OFF}
|
||||
{$Q-}
|
||||
{$undef OVERFLOW_OFF}
|
||||
{$endif}
|
||||
end;
|
||||
xorn :
|
||||
if is_integer(ld) then
|
||||
t:=genintconstnode(lv xor rv)
|
||||
@ -2071,7 +2130,11 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.136 2005-01-16 11:56:37 peter
|
||||
Revision 1.137 2005-01-26 16:23:28 peter
|
||||
* detect arithmetic overflows for constants at compile time
|
||||
* use try..except instead of setjmp
|
||||
|
||||
Revision 1.136 2005/01/16 11:56:37 peter
|
||||
* fixed some tabs
|
||||
|
||||
Revision 1.135 2005/01/16 11:13:40 peter
|
||||
|
||||
@ -46,9 +46,6 @@ implementation
|
||||
{$ifdef BrowserLog}
|
||||
browlog,
|
||||
{$endif BrowserLog}
|
||||
{$ifdef UseExcept}
|
||||
tpexcept,
|
||||
{$endif UseExcept}
|
||||
{$ifdef GDB}
|
||||
gdb,
|
||||
{$endif GDB}
|
||||
@ -369,10 +366,6 @@ implementation
|
||||
|
||||
var
|
||||
olddata : polddata;
|
||||
{$ifdef USEEXCEPT}
|
||||
recoverpos : jmp_buf;
|
||||
oldrecoverpos : pjmp_buf;
|
||||
{$endif useexcept}
|
||||
begin
|
||||
inc(compile_level);
|
||||
parser_current_file:=filename;
|
||||
@ -516,191 +509,161 @@ implementation
|
||||
|
||||
{ If the compile level > 1 we get a nice "unit expected" error
|
||||
message if we are trying to use a program as unit.}
|
||||
{$ifdef USEEXCEPT}
|
||||
if setjmp(recoverpos)=0 then
|
||||
begin
|
||||
oldrecoverpos:=recoverpospointer;
|
||||
recoverpospointer:=@recoverpos;
|
||||
{$endif USEEXCEPT}
|
||||
|
||||
if (token=_UNIT) or (compile_level>1) then
|
||||
begin
|
||||
current_module.is_unit:=true;
|
||||
proc_unit;
|
||||
end
|
||||
else
|
||||
proc_program(token=_LIBRARY);
|
||||
{$ifdef USEEXCEPT}
|
||||
recoverpospointer:=oldrecoverpos;
|
||||
end
|
||||
else
|
||||
begin
|
||||
recoverpospointer:=oldrecoverpos;
|
||||
longjump_used:=true;
|
||||
end;
|
||||
{$endif USEEXCEPT}
|
||||
|
||||
{ restore old state }
|
||||
done_module;
|
||||
|
||||
if assigned(current_module) then
|
||||
begin
|
||||
{ module is now compiled }
|
||||
tppumodule(current_module).state:=ms_compiled;
|
||||
|
||||
{ free ppu }
|
||||
if assigned(tppumodule(current_module).ppufile) then
|
||||
try
|
||||
if (token=_UNIT) or (compile_level>1) then
|
||||
begin
|
||||
tppumodule(current_module).ppufile.free;
|
||||
tppumodule(current_module).ppufile:=nil;
|
||||
end;
|
||||
current_module.is_unit:=true;
|
||||
proc_unit;
|
||||
end
|
||||
else
|
||||
proc_program(token=_LIBRARY);
|
||||
finally
|
||||
{ restore old state }
|
||||
done_module;
|
||||
|
||||
{ free scanner }
|
||||
if assigned(current_module.scanner) then
|
||||
begin
|
||||
if current_scanner=tscannerfile(current_module.scanner) then
|
||||
current_scanner:=nil;
|
||||
tscannerfile(current_module.scanner).free;
|
||||
current_module.scanner:=nil;
|
||||
end;
|
||||
end;
|
||||
if assigned(current_module) then
|
||||
begin
|
||||
{ module is now compiled }
|
||||
tppumodule(current_module).state:=ms_compiled;
|
||||
|
||||
if (compile_level>1) then
|
||||
begin
|
||||
with olddata^ do
|
||||
{ free ppu }
|
||||
if assigned(tppumodule(current_module).ppufile) then
|
||||
begin
|
||||
{ restore scanner }
|
||||
c:=oldc;
|
||||
pattern:=oldpattern;
|
||||
orgpattern:=oldorgpattern;
|
||||
token:=oldtoken;
|
||||
idtoken:=oldidtoken;
|
||||
akttokenpos:=oldtokenpos;
|
||||
block_type:=old_block_type;
|
||||
{ restore cg }
|
||||
parse_only:=oldparse_only;
|
||||
{ restore asmlists }
|
||||
exprasmlist:=oldexprasmlist;
|
||||
datasegment:=olddatasegment;
|
||||
bsssegment:=oldbsssegment;
|
||||
codesegment:=oldcodesegment;
|
||||
consts:=oldconsts;
|
||||
debuglist:=olddebuglist;
|
||||
withdebuglist:=oldwithdebuglist;
|
||||
importssection:=oldimports;
|
||||
exportssection:=oldexports;
|
||||
resourcesection:=oldresource;
|
||||
rttilist:=oldrttilist;
|
||||
picdata:=oldpicdata;
|
||||
resourcestringlist:=oldresourcestringlist;
|
||||
{ object data }
|
||||
ResourceStrings:=OldResourceStrings;
|
||||
objectlibrary:=oldobjectlibrary;
|
||||
{ restore previous scanner }
|
||||
if assigned(old_compiled_module) then
|
||||
current_scanner:=tscannerfile(old_compiled_module.scanner)
|
||||
else
|
||||
current_scanner:=nil;
|
||||
if assigned(current_scanner) then
|
||||
parser_current_file:=current_scanner.inputfile.name^;
|
||||
{ restore symtable state }
|
||||
refsymtable:=oldrefsymtable;
|
||||
symtablestack:=oldsymtablestack;
|
||||
macrosymtablestack:=oldmacrosymtablestack;
|
||||
defaultsymtablestack:=olddefaultsymtablestack;
|
||||
defaultmacrosymtablestack:=olddefaultmacrosymtablestack;
|
||||
aktdefproccall:=oldaktdefproccall;
|
||||
current_procinfo:=oldcurrent_procinfo;
|
||||
aktsourcecodepage:=oldsourcecodepage;
|
||||
aktlocalswitches:=oldaktlocalswitches;
|
||||
aktmoduleswitches:=oldaktmoduleswitches;
|
||||
aktalignment:=oldaktalignment;
|
||||
aktpackenum:=oldaktpackenum;
|
||||
aktpackrecords:=oldaktpackrecords;
|
||||
aktmaxfpuregisters:=oldaktmaxfpuregisters;
|
||||
aktoutputformat:=oldaktoutputformat;
|
||||
set_target_asm(aktoutputformat);
|
||||
aktoptprocessor:=oldaktoptprocessor;
|
||||
aktspecificoptprocessor:=oldaktspecificoptprocessor;
|
||||
aktfputype:=oldaktfputype;
|
||||
aktasmmode:=oldaktasmmode;
|
||||
aktinterfacetype:=oldaktinterfacetype;
|
||||
aktfilepos:=oldaktfilepos;
|
||||
aktmodeswitches:=oldaktmodeswitches;
|
||||
aktexceptblock:=0;
|
||||
exceptblockcounter:=0;
|
||||
{$ifdef GDB}
|
||||
dbx_counter:=store_dbx;
|
||||
{$endif GDB}
|
||||
tppumodule(current_module).ppufile.free;
|
||||
tppumodule(current_module).ppufile:=nil;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
parser_current_file:='';
|
||||
{ Shut down things when the last file is compiled }
|
||||
if (compile_level=1) then
|
||||
begin
|
||||
{ Close script }
|
||||
if (not AsmRes.Empty) then
|
||||
begin
|
||||
Message1(exec_i_closing_script,AsmRes.Fn);
|
||||
AsmRes.WriteToDisk;
|
||||
end;
|
||||
|
||||
{$ifdef USEEXCEPT}
|
||||
if not longjump_used then
|
||||
{$endif USEEXCEPT}
|
||||
{ free scanner }
|
||||
if assigned(current_module.scanner) then
|
||||
begin
|
||||
if current_scanner=tscannerfile(current_module.scanner) then
|
||||
current_scanner:=nil;
|
||||
tscannerfile(current_module.scanner).free;
|
||||
current_module.scanner:=nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
if (compile_level>1) then
|
||||
begin
|
||||
with olddata^ do
|
||||
begin
|
||||
{ do not create browsers on errors !! }
|
||||
if status.errorcount=0 then
|
||||
begin
|
||||
{ restore scanner }
|
||||
c:=oldc;
|
||||
pattern:=oldpattern;
|
||||
orgpattern:=oldorgpattern;
|
||||
token:=oldtoken;
|
||||
idtoken:=oldidtoken;
|
||||
akttokenpos:=oldtokenpos;
|
||||
block_type:=old_block_type;
|
||||
{ restore cg }
|
||||
parse_only:=oldparse_only;
|
||||
{ restore asmlists }
|
||||
exprasmlist:=oldexprasmlist;
|
||||
datasegment:=olddatasegment;
|
||||
bsssegment:=oldbsssegment;
|
||||
codesegment:=oldcodesegment;
|
||||
consts:=oldconsts;
|
||||
debuglist:=olddebuglist;
|
||||
withdebuglist:=oldwithdebuglist;
|
||||
importssection:=oldimports;
|
||||
exportssection:=oldexports;
|
||||
resourcesection:=oldresource;
|
||||
rttilist:=oldrttilist;
|
||||
picdata:=oldpicdata;
|
||||
resourcestringlist:=oldresourcestringlist;
|
||||
{ object data }
|
||||
ResourceStrings:=OldResourceStrings;
|
||||
objectlibrary:=oldobjectlibrary;
|
||||
{ restore previous scanner }
|
||||
if assigned(old_compiled_module) then
|
||||
current_scanner:=tscannerfile(old_compiled_module.scanner)
|
||||
else
|
||||
current_scanner:=nil;
|
||||
if assigned(current_scanner) then
|
||||
parser_current_file:=current_scanner.inputfile.name^;
|
||||
{ restore symtable state }
|
||||
refsymtable:=oldrefsymtable;
|
||||
symtablestack:=oldsymtablestack;
|
||||
macrosymtablestack:=oldmacrosymtablestack;
|
||||
defaultsymtablestack:=olddefaultsymtablestack;
|
||||
defaultmacrosymtablestack:=olddefaultmacrosymtablestack;
|
||||
aktdefproccall:=oldaktdefproccall;
|
||||
current_procinfo:=oldcurrent_procinfo;
|
||||
aktsourcecodepage:=oldsourcecodepage;
|
||||
aktlocalswitches:=oldaktlocalswitches;
|
||||
aktmoduleswitches:=oldaktmoduleswitches;
|
||||
aktalignment:=oldaktalignment;
|
||||
aktpackenum:=oldaktpackenum;
|
||||
aktpackrecords:=oldaktpackrecords;
|
||||
aktmaxfpuregisters:=oldaktmaxfpuregisters;
|
||||
aktoutputformat:=oldaktoutputformat;
|
||||
set_target_asm(aktoutputformat);
|
||||
aktoptprocessor:=oldaktoptprocessor;
|
||||
aktspecificoptprocessor:=oldaktspecificoptprocessor;
|
||||
aktfputype:=oldaktfputype;
|
||||
aktasmmode:=oldaktasmmode;
|
||||
aktinterfacetype:=oldaktinterfacetype;
|
||||
aktfilepos:=oldaktfilepos;
|
||||
aktmodeswitches:=oldaktmodeswitches;
|
||||
aktexceptblock:=0;
|
||||
exceptblockcounter:=0;
|
||||
{$ifdef GDB}
|
||||
dbx_counter:=store_dbx;
|
||||
{$endif GDB}
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ Shut down things when the last file is compiled succesfull }
|
||||
if (compile_level=1) and
|
||||
(status.errorcount=0) then
|
||||
begin
|
||||
parser_current_file:='';
|
||||
{ Close script }
|
||||
if (not AsmRes.Empty) then
|
||||
begin
|
||||
Message1(exec_i_closing_script,AsmRes.Fn);
|
||||
AsmRes.WriteToDisk;
|
||||
end;
|
||||
|
||||
{ do not create browsers on errors !! }
|
||||
if status.errorcount=0 then
|
||||
begin
|
||||
{$ifdef BrowserLog}
|
||||
{ Write Browser Log }
|
||||
if (cs_browser_log in aktglobalswitches) and
|
||||
(cs_browser in aktmoduleswitches) then
|
||||
begin
|
||||
if browserlog.elements_to_list.empty then
|
||||
begin
|
||||
Message1(parser_i_writing_browser_log,browserlog.Fname);
|
||||
WriteBrowserLog;
|
||||
end
|
||||
else
|
||||
browserlog.list_elements;
|
||||
end;
|
||||
{ Write Browser Log }
|
||||
if (cs_browser_log in aktglobalswitches) and
|
||||
(cs_browser in aktmoduleswitches) then
|
||||
begin
|
||||
if browserlog.elements_to_list.empty then
|
||||
begin
|
||||
Message1(parser_i_writing_browser_log,browserlog.Fname);
|
||||
WriteBrowserLog;
|
||||
end
|
||||
else
|
||||
browserlog.list_elements;
|
||||
end;
|
||||
{ Write Browser Collections }
|
||||
do_extractsymbolinfo{$ifdef FPC}(){$endif};
|
||||
{$endif BrowserLog}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ Write Browser Collections }
|
||||
do_extractsymbolinfo{$ifdef FPC}(){$endif};
|
||||
end;
|
||||
end;
|
||||
dec(compile_level);
|
||||
compiled_module:=olddata^.old_compiled_module;
|
||||
|
||||
{$ifdef dummy}
|
||||
if current_module.in_second_compile then
|
||||
begin
|
||||
current_module.in_second_compile:=false;
|
||||
current_module.in_compile:=true;
|
||||
end
|
||||
else
|
||||
current_module.in_compile:=false;
|
||||
{$endif dummy}
|
||||
end;
|
||||
end;
|
||||
|
||||
dec(compile_level);
|
||||
compiled_module:=olddata^.old_compiled_module;
|
||||
|
||||
dispose(olddata);
|
||||
|
||||
{$ifdef USEEXCEPT}
|
||||
if longjump_used then
|
||||
longjmp(recoverpospointer^,1);
|
||||
{$endif USEEXCEPT}
|
||||
end;
|
||||
dispose(olddata);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.70 2005-01-19 22:19:41 peter
|
||||
Revision 1.71 2005-01-26 16:23:28 peter
|
||||
* detect arithmetic overflows for constants at compile time
|
||||
* use try..except instead of setjmp
|
||||
|
||||
Revision 1.70 2005/01/19 22:19:41 peter
|
||||
* unit mapping rewrite
|
||||
* new derefmap added
|
||||
|
||||
|
||||
@ -1,271 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
Copyright (c) 1998-2002 by Florian Klaempfl
|
||||
|
||||
SetJmp and LongJmp implementation for recovery handling of the
|
||||
compiler
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
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. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
****************************************************************************}
|
||||
unit tpexcept;
|
||||
|
||||
{$i fpcdefs.inc}
|
||||
|
||||
interface
|
||||
|
||||
{$ifdef VER1_0}
|
||||
{$define HASNOLONGJMP}
|
||||
{$else}
|
||||
{$ifdef DELPHI}
|
||||
{$define HASNOLONGJMP}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
{$ifndef UNIX}
|
||||
{$S-}
|
||||
{$endif}
|
||||
|
||||
{$ifdef HASNOLONGJMP}
|
||||
|
||||
type
|
||||
jmp_buf = record
|
||||
{$ifdef Delphi} { must preserve: ebx, esi, edi, ebp, esp, eip only }
|
||||
_ebx,_esi,_edi,_ebp,_esp,_eip : longint;
|
||||
{$else}
|
||||
eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
|
||||
cs,ds,es,fs,gs,ss : word;
|
||||
{$endif Delphi}
|
||||
end;
|
||||
|
||||
pjmp_buf = ^jmp_buf;
|
||||
|
||||
function setjmp(var rec : jmp_buf) : longint;{$ifndef ver1_0}oldfpccall;{$endif}
|
||||
procedure longjmp(const rec : jmp_buf;return_value : longint);{$ifndef ver1_0}oldfpccall;{$endif}
|
||||
|
||||
{$endif HASNOLONGJMP}
|
||||
|
||||
const
|
||||
recoverpospointer : pjmp_buf = nil;
|
||||
longjump_used : boolean = false;
|
||||
|
||||
implementation
|
||||
|
||||
{$ifdef HASNOLONGJMP}
|
||||
|
||||
{*****************************************************************************
|
||||
Exception Helpers
|
||||
*****************************************************************************}
|
||||
|
||||
{$ifdef DELPHI}
|
||||
|
||||
{$STACKFRAMES ON}
|
||||
function setjmp(var rec : jmp_buf) : longint; assembler;
|
||||
{ [ebp+12]: [ebp+8]:@rec, [ebp+4]:eip', [ebp+0]:ebp' }
|
||||
asm // free: eax, ecx, edx
|
||||
{ push ebp; mov ebp,esp }
|
||||
mov edx,rec
|
||||
mov [edx].jmp_buf._ebx,ebx { ebx }
|
||||
mov [edx].jmp_buf._esi,esi { esi }
|
||||
mov [edx].jmp_buf._edi,edi { edi }
|
||||
mov eax,[ebp] { ebp (caller stack frame) }
|
||||
mov [edx].jmp_buf._ebp,eax
|
||||
lea eax,[ebp+12] { esp [12]: [8]:@rec, [4]:eip, [0]:ebp }
|
||||
mov [edx].jmp_buf._esp,eax
|
||||
mov eax,[ebp+4]
|
||||
mov [edx].jmp_buf._eip,eax
|
||||
xor eax,eax
|
||||
{ leave }
|
||||
{ ret 4 }
|
||||
end;
|
||||
|
||||
procedure longjmp(const rec : jmp_buf; return_value : longint);assembler;
|
||||
{ [ebp+12]: return_value [ebp+8]:@rec, [ebp+4]:eip', [ebp+0]:ebp' }
|
||||
asm
|
||||
{ push ebp, mov ebp,esp }
|
||||
mov edx,rec
|
||||
mov ecx,return_value
|
||||
mov ebx,[edx].jmp_buf._ebx { ebx }
|
||||
mov esi,[edx].jmp_buf._esi { esi }
|
||||
mov edi,[edx].jmp_buf._edi { edi }
|
||||
mov ebp,[edx].jmp_buf._ebp { ebp }
|
||||
mov esp,[edx].jmp_buf._esp { esp }
|
||||
mov eax,[edx].jmp_buf._eip { eip }
|
||||
push eax
|
||||
mov eax,ecx
|
||||
ret 0
|
||||
end;
|
||||
|
||||
{$else not DELPHI}
|
||||
|
||||
{$asmmode ATT}
|
||||
|
||||
function setjmp(var rec : jmp_buf) : longint; {$ifndef ver1_0}oldfpccall;{$endif}
|
||||
begin
|
||||
asm
|
||||
pushl %edi
|
||||
movl rec,%edi
|
||||
movl %eax,(%edi)
|
||||
movl %ebx,4(%edi)
|
||||
movl %ecx,8(%edi)
|
||||
movl %edx,12(%edi)
|
||||
movl %esi,16(%edi)
|
||||
|
||||
{ load edi }
|
||||
movl -4(%ebp),%eax
|
||||
|
||||
{ ... and store it }
|
||||
movl %eax,20(%edi)
|
||||
|
||||
{ ebp ... }
|
||||
movl (%ebp),%eax
|
||||
movl %eax,24(%edi)
|
||||
|
||||
{ esp ... }
|
||||
leal 12(%ebp),%eax
|
||||
movl %eax,28(%edi)
|
||||
|
||||
{ the return address }
|
||||
movl 4(%ebp),%eax
|
||||
movl %eax,32(%edi)
|
||||
|
||||
{ flags ... }
|
||||
pushfl
|
||||
popl 36(%edi)
|
||||
|
||||
{ !!!!! the segment registers, not yet needed }
|
||||
{ you need them if the exception comes from
|
||||
an interrupt or a seg_move }
|
||||
movw %cs,40(%edi)
|
||||
movw %ds,42(%edi)
|
||||
movw %es,44(%edi)
|
||||
movw %fs,46(%edi)
|
||||
movw %gs,48(%edi)
|
||||
movw %ss,50(%edi)
|
||||
|
||||
{ restore EDI }
|
||||
pop %edi
|
||||
|
||||
{ we come from the initial call }
|
||||
xorl %eax,%eax
|
||||
|
||||
leave
|
||||
ret $4
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure longjmp(const rec : jmp_buf;return_value : longint); {$ifndef ver1_0}oldfpccall;{$endif}
|
||||
begin
|
||||
asm
|
||||
{ restore compiler shit }
|
||||
popl %ebp
|
||||
{ this is the address of rec }
|
||||
movl 4(%esp),%edi
|
||||
|
||||
{ save return value }
|
||||
movl 8(%esp),%eax
|
||||
movl %eax,0(%edi)
|
||||
|
||||
{ !!!!! load segment registers }
|
||||
movw 46(%edi),%fs
|
||||
movw 48(%edi),%gs
|
||||
|
||||
{ ... and some other registers }
|
||||
movl 4(%edi),%ebx
|
||||
movl 8(%edi),%ecx
|
||||
movl 12(%edi),%edx
|
||||
movl 24(%edi),%ebp
|
||||
|
||||
{ !!!!! movw 50(%edi),%es }
|
||||
movl 28(%edi),%esi
|
||||
|
||||
{ create a stack frame for the return }
|
||||
subl $16,%esi
|
||||
|
||||
{
|
||||
movzwl 42(%edi),%eax
|
||||
!!!!! es
|
||||
movl %eax,(%esi)
|
||||
}
|
||||
|
||||
{ edi }
|
||||
movl 20(%edi),%eax
|
||||
{ !!!!! es }
|
||||
movl %eax,(%esi)
|
||||
|
||||
{ esi }
|
||||
movl 16(%edi),%eax
|
||||
{ !!!!! es }
|
||||
movl %eax,4(%esi)
|
||||
|
||||
{ eip }
|
||||
movl 32(%edi),%eax
|
||||
{ !!!!! es }
|
||||
movl %eax,12(%esi)
|
||||
|
||||
{ !!!!! cs
|
||||
movl 40(%edi),%eax
|
||||
es
|
||||
movl %eax,16(%esi)
|
||||
}
|
||||
|
||||
{ load and store flags }
|
||||
movl 36(%edi),%eax
|
||||
{ !!!!!
|
||||
es
|
||||
}
|
||||
movl %eax,8(%esi)
|
||||
|
||||
{ load return value }
|
||||
movl 0(%edi),%eax
|
||||
|
||||
{ load old ES
|
||||
!!!!! movw 44(%edi),%es
|
||||
}
|
||||
|
||||
{ load stack
|
||||
!!!!! movw 50(%edi),%ss }
|
||||
movl %esi,%esp
|
||||
|
||||
{ !!!!
|
||||
popl %ds
|
||||
}
|
||||
popl %edi
|
||||
popl %esi
|
||||
|
||||
popfl
|
||||
ret
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif DELPHI}
|
||||
|
||||
{$endif HASNOLONGJMP}
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.12 2004-10-15 09:14:17 mazen
|
||||
- remove $IFDEF DELPHI and related code
|
||||
- remove $IFDEF FPCPROCVAR and related code
|
||||
|
||||
Revision 1.11 2004/06/20 08:55:30 florian
|
||||
* logs truncated
|
||||
|
||||
Revision 1.10 2004/02/12 16:00:39 peter
|
||||
* don't use the local longjmp for 1.9.x
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user