paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 00:29:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed problem with default properties which are a class

Browse Source 
* case bug (from the mailing list with -O2) fixed, the
    distance of the case labels can be greater than the positive
    range of a longint => it is now a dword for fpc
This commit is contained in:
florian 1999-04-08 20:59:37 +00:00
parent 5e1b59ee73
commit 982e083f76
5 changed files with 100 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
compiler/cg386set.pas
View File

@ -659,6 +659,7 @@ implementation
var
lv,hv,min_label,max_label,labels : longint;
max_linear_list : longint;
dist : dword;
begin
getlabel(endlabel);
@ -732,14 +733,26 @@ implementation
min_label:=case_get_min(p^.nodes);
max_label:=case_get_max(p^.nodes);
labels:=case_count_labels(p^.nodes);
{ can we omit the range check of the jump table }
{ can we omit the range check of the jump table ? }
getrange(p^.left^.resulttype,lv,hv);
jumptable_no_range:=(lv=min_label) and (hv=max_label);
{ hack a little bit, because the range can be greater }
{ than the positive range of a longint }
if (min_label<0) and (max_label>0) then
begin
if min_label=$80000000 then
dist:=dword(max_label)+dword($80000000)
else
dist:=dword(max_label)+dword(-min_label)
end
else
dist:=max_label-min_label;
{ optimize for size ? }
if cs_littlesize in aktglobalswitches then
begin
if (labels<=2) or ((max_label-min_label)>3*labels) then
if (labels<=2) or (dist>3*labels) then
{ a linear list is always smaller than a jump tree }
genlinearlist(p^.nodes)
else
@ -764,7 +777,7 @@ implementation
genlinearlist(p^.nodes)
else
begin
if ((max_label-min_label)>4*labels) then
if (dist>4*labels) then
begin
if labels>16 then
gentreejmp(p^.nodes)
@ -805,7 +818,13 @@ implementation
end.
{
$Log$
Revision 1.24 1999-03-02 18:21:35 peter
Revision 1.25 1999-04-08 20:59:37 florian
* fixed problem with default properties which are a class
* case bug (from the mailing list with -O2) fixed, the
distance of the case labels can be greater than the positive
range of a longint => it is now a dword for fpc
Revision 1.24 1999/03/02 18:21:35 peter
+ flags support for add and case
Revision 1.23 1999/02/25 21:02:31 peter

15
compiler/cobjects.pas
View File

@ -47,6 +47,13 @@ unit cobjects;
type
pstring = ^string;
{$ifdef TP}
{ redeclare dword only in case of emergency, some small things
of the compiler won't work then correctly (FK)
}
dword = longint;
{$endif TP}
pfileposinfo = ^tfileposinfo;
tfileposinfo = record
line : longint;
@ -1612,7 +1619,13 @@ end;
end.
{
$Log$
Revision 1.22 1999-03-31 13:55:10 peter
Revision 1.23 1999-04-08 20:59:39 florian
* fixed problem with default properties which are a class
* case bug (from the mailing list with -O2) fixed, the
distance of the case labels can be greater than the positive
range of a longint => it is now a dword for fpc
Revision 1.22 1999/03/31 13:55:10 peter
* assembler inlining working for ag386bin
Revision 1.21 1999/03/19 16:35:29 pierre

13
compiler/pbase.pas
View File

@ -100,7 +100,10 @@ unit pbase;
procedure consume(i : ttoken);
begin
if (token<>i) and (idtoken<>i) then
Message2(scan_f_syn_expected,tokeninfo[i].str,tokeninfo[token].str)
if token=ID then
Message2(scan_f_syn_expected,tokeninfo[i].str,'identifier '+pattern)
else
Message2(scan_f_syn_expected,tokeninfo[i].str,tokeninfo[token].str)
else
begin
if token=_END then
@ -180,7 +183,13 @@ end.
{
$Log$
Revision 1.18 1998-12-11 00:03:29 peter
Revision 1.19 1999-04-08 20:59:42 florian
* fixed problem with default properties which are a class
* case bug (from the mailing list with -O2) fixed, the
distance of the case labels can be greater than the positive
range of a longint => it is now a dword for fpc
Revision 1.18 1998/12/11 00:03:29 peter
+ globtype,tokens,version unit splitted from globals
Revision 1.17 1998/09/26 17:45:31 peter

13
compiler/pexpr.pas
View File

@ -1231,10 +1231,7 @@ unit pexpr;
message(parser_e_no_default_property_available);
end
else
begin
p1:=nil;
handle_propertysym(propsym,propsym^.owner,p1,pd);
end;
handle_propertysym(propsym,propsym^.owner,p1,pd);
end
else
begin
@ -1976,7 +1973,13 @@ unit pexpr;
end.
{
$Log$
Revision 1.91 1999-04-06 11:21:56 peter
Revision 1.92 1999-04-08 20:59:43 florian
* fixed problem with default properties which are a class
* case bug (from the mailing list with -O2) fixed, the
distance of the case labels can be greater than the positive
range of a longint => it is now a dword for fpc
Revision 1.91 1999/04/06 11:21:56 peter
* more use of ttoken
Revision 1.90 1999/03/31 13:55:12 peter

50
compiler/temp_gen.pas
View File

@ -37,6 +37,15 @@ unit temp_gen;
{$endif m68k}
cobjects,globals,tree,hcodegen,verbose,files,aasm;
type
{ this saves some memory }
{$ifdef FPC}
{$minenumsize 1}
{$endif FPC}
ttemptype = (tt_normal,tt_ansistring,tt_widestring);
{$ifdef FPC}
{$minenumsize default}
{$endif FPC}
{ generates temporary variables }
procedure resettempgen;
procedure setfirsttemp(l : longint);
@ -49,9 +58,10 @@ unit temp_gen;
procedure ungettemp(pos : longint;size : longint);
procedure ungetpersistanttemp(pos : longint;size : longint);
procedure gettempofsizereference(l : longint;var ref : treference);
procedure gettempansistringreference(var ref : treference);
procedure gettempslotreference(slottype : ttemptype;var ref : treference);
function istemp(const ref : treference) : boolean;
procedure ungetiftemp(const ref : treference);
procedure gettempansistringreference(var ref : treference);
implementation
@ -74,14 +84,19 @@ unit temp_gen;
pos : longint;
size : longint;
persistant : boolean; { used for inlined procedures }
temptype : ttemptype;
{$ifdef EXTDEBUG}
posinfo,releaseposinfo : tfileposinfo;
{$endif}
end;
var
{ contains all free temps }
tmpfreelist : pfreerecord;
{ contains all used temps }
templist : pfreerecord;
{ contains the slots for ansi/wide string temps }
reftempslots : pfreerecord;
{$ifdef EXTDEBUG}
tempfreedlist : pfreerecord;
{$endif}
@ -252,6 +267,7 @@ unit temp_gen;
end;
procedure gettempansistringreference(var ref : treference);
begin
{ do a reset, because the reference isn't used }
reset_reference(ref);
@ -259,6 +275,15 @@ unit temp_gen;
ref.base:=procinfo.framepointer;
end;
procedure gettempslotreference(slottype : ttemptype;var ref : treference);
begin
{ do a reset, because the reference isn't used }
reset_reference(ref);
ref.offset:=gettempofsize(4);
ref.base:=procinfo.framepointer;
templist^.temptype:=slottype;
end;
function istemp(const ref : treference) : boolean;
@ -439,13 +464,13 @@ unit temp_gen;
while assigned(tl) do
begin
{ no release of persistant blocks this way!! }
if tl^.persistant then
if (tl^.persistant) or (tl^.temptype<>tt_normal) then
if (ref.offset>=tl^.pos) and
(ref.offset<tl^.pos+tl^.size) then
begin
{$ifdef EXTDEBUG}
Comment(V_Debug,'temp '+
' at pos '+tostr(ref.offset)+ ' not released because persistant !');
' at pos '+tostr(ref.offset)+ ' not released because persistant or slot!');
{$endif}
exit;
end;
@ -453,8 +478,8 @@ unit temp_gen;
begin
ungettemp(ref.offset,tl^.size);
{$ifdef TEMPDEBUG}
Comment(V_Debug,'temp managment : ungettemp()'+
' at pos '+tostr(tl^.pos)+ ' found !');
Comment(V_Debug,'temp managment : ungettemp()'+
' at pos '+tostr(tl^.pos)+ ' found !');
{$endif}
if assigned(prev) then
prev^.next:=tl^.next
@ -500,13 +525,26 @@ unit temp_gen;
end;
end;
procedure inittemps;
begin
{ hp:=temp }
end;
begin
tmpfreelist:=nil;
templist:=nil;
reftempslots:=nil;
end.
{
$Log$
Revision 1.10 1999-04-06 11:19:49 peter
Revision 1.11 1999-04-08 20:59:44 florian
* fixed problem with default properties which are a class
* case bug (from the mailing list with -O2) fixed, the
distance of the case labels can be greater than the positive
range of a longint => it is now a dword for fpc
Revision 1.10 1999/04/06 11:19:49 peter
* fixed temp reuse
Revision 1.9 1999/02/22 02:15:56 peter