paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-01-06 04:10:36 +01:00
Code Issues Packages Projects Releases Wiki Activity

* internal error 10 together with array access fixed. I hope

Browse Source 
that's the final fix.
This commit is contained in:
florian 1998-07-24 22:16:52 +00:00
parent 4637fffd8b
commit 9b4225f26f
8 changed files with 250 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
compiler/cg386cal.pas
View File

@ -1796,9 +1796,38 @@ implementation
l : longint;
ispushed : boolean;
hregister : tregister;
otlabel,oflabel,filenamestring : plabel;
begin
case p^.inlinenumber of
in_assert_x:
begin
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
getlabel(filenamestring);
secondpass(p^.left);
if codegenerror then
exit;
if cs_do_assertion in aktswitches then
begin
maketojumpbool(p^.left);
emitl(A_LABEL,falselabel);
exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,
p^.fileinfo.line)));
{ generate string }
{ push string
exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,
p^.fileinfo.line)));
}
emitcall('FPC_DO_ASSERT',true);
emitl(A_LABEL,truelabel);
end;
truelabel:=otlabel;
falselabel:=oflabel;
end;
in_lo_word,
in_hi_word :
begin
@ -2261,7 +2290,11 @@ implementation
end.
{
$Log$
Revision 1.10 1998-07-18 22:54:23 florian
Revision 1.11 1998-07-24 22:16:52 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.10 1998/07/18 22:54:23 florian
* some ansi/wide/longstring support fixed:
o parameter passing
o returning as result from functions

10
compiler/cg386flw.pas
View File

@ -136,9 +136,9 @@ implementation
secondpass(p^.right);
end;
if assigned(p^.t1) then
begin
begin
if assigned(p^.right) then
begin
begin
getlabel(hl);
emitl(A_JMP,hl);
end;
@ -590,7 +590,11 @@ do_jmp:
end.
{
$Log$
Revision 1.3 1998-06-25 08:48:08 florian
Revision 1.4 1998-07-24 22:16:53 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.3 1998/06/25 08:48:08 florian
* first version of rtti support
Revision 1.2 1998/06/08 13:13:33 pierre

29
compiler/cg386ld.pas
View File

@ -184,17 +184,20 @@ implementation
simple_loadn:=false;
if hregister=R_NO then
hregister:=getregister32;
if (p^.location.reference.base=procinfo.framepointer) then
if is_open_array(pvarsym(p^.symtableentry)^.definition) then
begin
highframepointer:=p^.location.reference.base;
highoffset:=p^.location.reference.offset;
end
else
begin
highframepointer:=R_EDI;
highoffset:=p^.location.reference.offset;
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
p^.location.reference.base,R_EDI)));
if (p^.location.reference.base=procinfo.framepointer) then
begin
highframepointer:=p^.location.reference.base;
highoffset:=p^.location.reference.offset;
end
else
begin
highframepointer:=R_EDI;
highoffset:=p^.location.reference.offset;
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
p^.location.reference.base,R_EDI)));
end;
end;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),
hregister)));
@ -521,7 +524,11 @@ implementation
end.
{
$Log$
Revision 1.4 1998-06-11 13:58:45 peter
Revision 1.5 1998-07-24 22:16:54 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.4 1998/06/11 13:58:45 peter
* fixed too long line
Revision 1.3 1998/06/09 16:01:35 pierre

208
compiler/cg386mem.pas
View File

@ -384,14 +384,14 @@ implementation
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end
else if (p^.right^.treetype=subn) then
begin
if p^.right^.right^.treetype=ordconstn then
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
@ -402,7 +402,7 @@ implementation
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
@ -418,105 +418,105 @@ implementation
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
case p^.right^.location.loc of
LOC_REGISTER:
begin
ind:=p^.right^.location.register;
case p^.right^.resulttype^.size of
1:
begin
hr:=reg8toreg32(ind);
emit_reg_reg(A_MOVZX,S_BL,ind,hr);
ind:=hr;
end;
2:
begin
hr:=reg16toreg32(ind);
emit_reg_reg(A_MOVZX,S_WL,ind,hr);
ind:=hr;
end;
end;
end;
LOC_CREGISTER:
begin
ind:=getregister32;
case p^.right^.resulttype^.size of
1:
emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind);
2:
emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind);
4:
emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind);
end;
end;
LOC_FLAGS:
begin
ind:=getregister32;
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,reg32toreg8(ind))));
emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
end
else
begin
del_reference(p^.right^.location.reference);
ind:=getregister32;
{ Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct }
case p^.right^.resulttype^.size of
1:
tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
2:
tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
4:
tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
end;
exprasmlist^.concat(tai);
case p^.right^.location.loc of
LOC_REGISTER:
begin
ind:=p^.right^.location.register;
case p^.right^.resulttype^.size of
1:
begin
hr:=reg8toreg32(ind);
emit_reg_reg(A_MOVZX,S_BL,ind,hr);
ind:=hr;
end;
2:
begin
hr:=reg16toreg32(ind);
emit_reg_reg(A_MOVZX,S_WL,ind,hr);
ind:=hr;
end;
end;
end;
{ produce possible range check code: }
if cs_rangechecking in aktswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
hp:=new_reference(R_NO,0);
parraydef(p^.left^.resulttype)^.genrangecheck;
hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
end;
end;
if p^.location.reference.index=R_NO then
begin
p^.location.reference.index:=ind;
calc_emit_mul;
end
else
begin
if p^.location.reference.base=R_NO then
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
p^.location.reference.index)));
ungetregister32(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
stringdispose(p^.location.reference.symbol);
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end;
end;
end;
LOC_CREGISTER:
begin
ind:=getregister32;
case p^.right^.resulttype^.size of
1:
emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind);
2:
emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind);
4:
emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind);
end;
end;
LOC_FLAGS:
begin
ind:=getregister32;
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,reg32toreg8(ind))));
emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
end
else
begin
del_reference(p^.right^.location.reference);
ind:=getregister32;
{ Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct }
case p^.right^.resulttype^.size of
1:
tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
2:
tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
4:
tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
end;
exprasmlist^.concat(tai);
end;
end;
{ produce possible range check code: }
if cs_rangechecking in aktswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
hp:=new_reference(R_NO,0);
parraydef(p^.left^.resulttype)^.genrangecheck;
hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
end;
end;
if p^.location.reference.index=R_NO then
begin
p^.location.reference.index:=ind;
calc_emit_mul;
end
else
begin
if p^.location.reference.base=R_NO then
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
p^.location.reference.index)));
ungetregister32(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
stringdispose(p^.location.reference.symbol);
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end;
end;
if p^.memseg then
p^.location.reference.segment:=R_FS;
end;
@ -579,7 +579,11 @@ implementation
end.
{
$Log$
Revision 1.3 1998-06-25 08:48:09 florian
Revision 1.4 1998-07-24 22:16:55 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.3 1998/06/25 08:48:09 florian
* first version of rtti support
Revision 1.2 1998/06/08 13:13:35 pierre

7
compiler/innr.inc
View File

@ -55,10 +55,15 @@ const
in_exclude_x_y = 38;
in_break = 39;
in_continue = 40;
in_assert_x = 41;
{
$Log$
Revision 1.4 1998-05-01 16:38:44 florian
Revision 1.5 1998-07-24 22:16:57 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.4 1998/05/01 16:38:44 florian
* handling of private and protected fixed
+ change_keywords_to_tp implemented to remove
keywords which aren't supported by tp

86
compiler/pass_1.pas
View File

@ -1944,7 +1944,7 @@ unit pass_1;
if not((p^.left^.treetype=ordconstn) and
(p^.right^.treetype=ordconstn)) then
Message(cg_e_illegal_expression);
{ upper limit must be greater or equalt than lower limit }
{ upper limit must be greater or equal than lower limit }
{ not if u32bit }
if (p^.left^.value>p^.right^.value) and
(( p^.left^.value<0) or (p^.right^.value>=0)) then
@ -1956,6 +1956,19 @@ unit pass_1;
Message(sym_e_type_mismatch);
end;
{
begin
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
if p^.right^.treetype<>ordconstn then
begin
case p^.right^.location.loc of
LOC_MEM,LOC_REFERENCE,
LOC_CREGISTER,LOC_FLAGS:
inc(p^.registers32);
end;
end;
end;
}
procedure firstvecn(var p : ptree);
var
@ -1980,17 +1993,17 @@ unit pass_1;
Message(sym_e_type_mismatch);
end;
{ Never convert a boolean or a char !}
{ maybe type conversion }
if (p^.right^.resulttype^.deftype<>enumdef) and
not ((p^.right^.resulttype^.deftype=orddef) and
(Porddef(p^.right^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit,uchar])) then
begin
p^.right:=gentypeconvnode(p^.right,s32bitdef);
{ once more firstpass }
{?? It's better to only firstpass when the tree has
changed, isn't it ?}
firstpass(p^.right);
end;
{ maybe type conversion }
if (p^.right^.resulttype^.deftype<>enumdef) and
not ((p^.right^.resulttype^.deftype=orddef) and
(Porddef(p^.right^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit,uchar])) then
begin
p^.right:=gentypeconvnode(p^.right,s32bitdef);
{ once more firstpass }
{?? It's better to only firstpass when the tree has
changed, isn't it ?}
firstpass(p^.right);
end;
if codegenerror then
exit;
@ -2010,23 +2023,54 @@ unit pass_1;
exit;
p^.resulttype:=parraydef(harr)^.definition
end
else if p^.left^.resulttype^.deftype=stringdef then
begin
{ indexed access to strings }
case pstringdef(p^.left^.resulttype)^.string_typ of
{
st_widestring : p^.resulttype:=cwchardef;
}
st_ansistring : p^.resulttype:=cchardef;
st_longstring : p^.resulttype:=cchardef;
st_shortstring : p^.resulttype:=cchardef;
end;
end
else
{ indexed access to arrays }
p^.resulttype:=cchardef;
Message(sym_e_type_mismatch);
{ the register calculation is easy if a const index is used }
if p^.right^.treetype=ordconstn then
p^.registers32:=p^.left^.registers32
begin
p^.registers32:=p^.left^.registers32
{
if is_ansistring(p^.left^.
}
end
else
begin
{ this rules are suboptimal, but they should give }
{ good results }
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
{ need we an extra register when doing the restore ? }
if (p^.left^.registers32<=p^.right^.registers32) and
{ only if the node needs less than 3 registers }
{ two for the right node and one for the }
{ left address }
(p^.registers32<3) then
inc(p^.registers32);
{ not correct, but what works better ? }
{ need we an extra register for the index ? }
if (p^.right^.location.loc<>LOC_REGISTER)
{ only if the right node doesn't need a register }
and (p^.right^.registers32<1) then
inc(p^.registers32);
{ not correct, but what works better ?
if p^.left^.registers32>0 then
p^.registers32:=max(p^.registers32,2)
else
{ min. one register }
min. one register
p^.registers32:=max(p^.registers32,1);
}
end;
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
{$ifdef SUPPORT_MMX}
@ -5048,7 +5092,11 @@ unit pass_1;
end.
{
$Log$
Revision 1.43 1998-07-20 18:40:14 florian
Revision 1.44 1998-07-24 22:16:59 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.43 1998/07/20 18:40:14 florian
* handling of ansi string constants should now work
Revision 1.42 1998/07/20 10:23:01 florian

8
compiler/switches.pas
View File

@ -66,7 +66,7 @@ const
SwitchTable:array['A'..'Z'] of SwitchRec=(
{A} (typesw:unsupported; setsw:cs_none; proc:nil),
{B} (typesw:unsupported; setsw:cs_none; proc:nil),
{C} (typesw:illegal; setsw:cs_none; proc:nil),
{C} (typesw:local; setsw:cs_do_assertion; proc:nil),
{D} (typesw:unitglobal; setsw:cs_debuginfo; proc:nil),
{E} (typesw:programglobal; setsw:cs_fp_emulation; proc:nil),
{F} (typesw:unsupported; setsw:cs_none; proc:nil),
@ -161,7 +161,11 @@ end;
end.
{
$Log$
Revision 1.6 1998-07-18 17:11:13 florian
Revision 1.7 1998-07-24 22:17:00 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.6 1998/07/18 17:11:13 florian
+ ansi string constants fixed
+ switch $H partial implemented

8
compiler/tree.pas
View File

@ -195,7 +195,7 @@ unit tree;
fileinfo : tfileposinfo;
pragmas : Tcswitches;
{$ifdef extdebug}
firstpasscount : longint;
firstpasscount : longint;
{$endif extdebug}
case treetype : ttreetyp of
addn : (use_strconcat : boolean;string_typ : tstringtype);
@ -1596,7 +1596,11 @@ unit tree;
end.
{
$Log$
Revision 1.22 1998-07-20 10:23:05 florian
Revision 1.23 1998-07-24 22:17:01 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.22 1998/07/20 10:23:05 florian
* better ansi string assignement
Revision 1.21 1998/07/14 21:46:56 peter