mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-11 22:48:00 +02:00
5cdd60cac8
* corrected operator overloading * corrected nasm output + started inline procedures + added starstarn : use ** for exponentiation (^ gave problems) + started UseTokenInfo cond to get accurate positions
1123 lines
41 KiB
ObjectPascal
1123 lines
41 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (C) 1993-98 by Florian Klaempfl
|
|
|
|
This unit provides some help routines for type handling
|
|
|
|
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 types;
|
|
|
|
interface
|
|
|
|
uses
|
|
cobjects,globals,symtable,tree,aasm;
|
|
|
|
type
|
|
tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
|
|
mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
|
|
|
|
{ returns true, if def defines an ordinal type }
|
|
function is_ordinal(def : pdef) : boolean;
|
|
|
|
{ true if p points to an open array def }
|
|
function is_open_array(p : pdef) : boolean;
|
|
|
|
{ true if o is an ansi string def }
|
|
function is_ansistring(p : pdef) : boolean;
|
|
|
|
{ returns true, if def defines a signed data type (only for ordinal types) }
|
|
function is_signed(def : pdef) : boolean;
|
|
|
|
{ returns true, if def uses FPU }
|
|
function is_fpu(def : pdef) : boolean;
|
|
|
|
{ true if the return value is in EAX }
|
|
function ret_in_acc(def : pdef) : boolean;
|
|
|
|
{ true if uses a parameter as return value }
|
|
function ret_in_param(def : pdef) : boolean;
|
|
|
|
{ true if a const parameter is too large to copy }
|
|
function dont_copy_const_param(def : pdef) : boolean;
|
|
{ true if we must never copy this parameter }
|
|
const
|
|
never_copy_const_param : boolean = false;
|
|
|
|
{ true, if def1 and def2 are semantical the same }
|
|
function is_equal(def1,def2 : pdef) : boolean;
|
|
|
|
{ checks for type compatibility (subgroups of type) }
|
|
{ used for case statements... probably missing stuff }
|
|
{ to use on other types }
|
|
function is_subequal(def1, def2: pdef): boolean;
|
|
|
|
{ true, if two parameter lists are equal }
|
|
{ if value_equal_const is true, call by value }
|
|
{ and call by const parameter are assumed as }
|
|
{ equal }
|
|
function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;
|
|
|
|
{ gibt den ordinalen Werten der Node zurueck oder falls sie }
|
|
{ keinen ordinalen Wert hat, wird ein Fehler erzeugt }
|
|
function get_ordinal_value(p : ptree) : longint;
|
|
|
|
{ if l isn't in the range of def a range check error is generated }
|
|
procedure testrange(def : pdef;l : longint);
|
|
|
|
{ returns the range of def }
|
|
procedure getrange(def : pdef;var l : longint;var h : longint);
|
|
|
|
{ generates a VMT for _class }
|
|
procedure genvmt(_class : pobjectdef);
|
|
|
|
{ true, if p is a pointer to a const int value }
|
|
function is_constintnode(p : ptree) : boolean;
|
|
|
|
{ like is_constintnode }
|
|
function is_constboolnode(p : ptree) : boolean;
|
|
function is_constrealnode(p : ptree) : boolean;
|
|
function is_constcharnode(p : ptree) : boolean;
|
|
|
|
{ some type helper routines for MMX support }
|
|
function is_mmx_able_array(p : pdef) : boolean;
|
|
|
|
{ returns the mmx type }
|
|
function mmx_type(p : pdef) : tmmxtype;
|
|
|
|
implementation
|
|
|
|
uses verbose;
|
|
|
|
function is_constintnode(p : ptree) : boolean;
|
|
|
|
begin
|
|
{DM: According to me, an orddef with anysize, is
|
|
a correct constintnode. Anyway I commented changed s32bit check,
|
|
because it caused problems with statements like a:=high(word).}
|
|
is_constintnode:=((p^.treetype=ordconstn) and
|
|
(p^.resulttype^.deftype=orddef) and
|
|
(porddef(p^.resulttype)^.typ in [u8bit,s8bit,u16bit,s16bit,
|
|
u32bit,s32bit,uauto]));
|
|
end;
|
|
|
|
function is_constcharnode(p : ptree) : boolean;
|
|
|
|
begin
|
|
is_constcharnode:=((p^.treetype=ordconstn) and
|
|
(p^.resulttype^.deftype=orddef) and
|
|
(porddef(p^.resulttype)^.typ=uchar));
|
|
end;
|
|
|
|
function is_constrealnode(p : ptree) : boolean;
|
|
|
|
begin
|
|
is_constrealnode:=(p^.treetype=realconstn);
|
|
end;
|
|
|
|
function is_constboolnode(p : ptree) : boolean;
|
|
|
|
begin
|
|
is_constboolnode:=((p^.treetype=ordconstn) and
|
|
(p^.resulttype^.deftype=orddef) and
|
|
(porddef(p^.resulttype)^.typ=bool8bit));
|
|
end;
|
|
|
|
function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;
|
|
|
|
begin
|
|
while (assigned(def1)) and (assigned(def2)) do
|
|
begin
|
|
if value_equal_const then
|
|
begin
|
|
if not(is_equal(def1^.data,def2^.data)) or
|
|
((def1^.paratyp<>def2^.paratyp) and
|
|
((def1^.paratyp=vs_var) or
|
|
(def1^.paratyp=vs_var)
|
|
)
|
|
) then
|
|
begin
|
|
equal_paras:=false;
|
|
exit;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if not(is_equal(def1^.data,def2^.data)) or
|
|
(def1^.paratyp<>def2^.paratyp) then
|
|
begin
|
|
equal_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
def1:=def1^.next;
|
|
def2:=def2^.next;
|
|
end;
|
|
if (def1=nil) and (def2=nil) then
|
|
equal_paras:=true
|
|
else
|
|
equal_paras:=false;
|
|
end;
|
|
|
|
{ returns true, if def uses FPU }
|
|
function is_fpu(def : pdef) : boolean;
|
|
begin
|
|
is_fpu:=(def^.deftype=floatdef) and (pfloatdef(def)^.typ<>f32bit);
|
|
end;
|
|
|
|
function is_ordinal(def : pdef) : boolean;
|
|
|
|
var
|
|
dt : tbasetype;
|
|
|
|
begin
|
|
case def^.deftype of
|
|
orddef : begin
|
|
dt:=porddef(def)^.typ;
|
|
is_ordinal:=(dt=s32bit) or (dt=u32bit) or (dt=uchar) or (dt=u8bit) or
|
|
(dt=s8bit) or (dt=s16bit) or (dt=bool8bit) or (dt=u16bit);
|
|
end;
|
|
enumdef : is_ordinal:=true;
|
|
else is_ordinal:=false;
|
|
end;
|
|
end;
|
|
|
|
function is_signed(def : pdef) : boolean;
|
|
|
|
var
|
|
dt : tbasetype;
|
|
|
|
begin
|
|
case def^.deftype of
|
|
orddef : begin
|
|
dt:=porddef(def)^.typ;
|
|
is_signed:=(dt=s32bit) or (dt=s8bit) or (dt=s16bit);
|
|
end;
|
|
enumdef : is_signed:=false;
|
|
else internalerror(1001);
|
|
end;
|
|
end;
|
|
|
|
{ true, if p points to an open array def }
|
|
function is_open_array(p : pdef) : boolean;
|
|
|
|
begin
|
|
is_open_array:=(p^.deftype=arraydef) and
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=-1);
|
|
end;
|
|
|
|
{ true if o is an ansi string def }
|
|
function is_ansistring(p : pdef) : boolean;
|
|
begin
|
|
is_ansistring:=(p^.deftype=stringdef) and
|
|
(pstringdef(p)^.string_typ=ansistring);
|
|
end;
|
|
|
|
{ true if the return value is in accumulator (EAX for i386), D0 for 68k }
|
|
function ret_in_acc(def : pdef) : boolean;
|
|
|
|
begin
|
|
ret_in_acc:=(def^.deftype=orddef) or
|
|
(def^.deftype=pointerdef) or
|
|
(def^.deftype=enumdef) or
|
|
((def^.deftype=procvardef) and
|
|
((pprocvardef(def)^.options and pomethodpointer)=0)) or
|
|
(def^.deftype=classrefdef) or
|
|
((def^.deftype=objectdef) and
|
|
pobjectdef(def)^.isclass
|
|
) or
|
|
((def^.deftype=setdef) and
|
|
(psetdef(def)^.settype=smallset)) or
|
|
((def^.deftype=floatdef) and
|
|
(pfloatdef(def)^.typ=f32bit));
|
|
end;
|
|
|
|
{ true if uses a parameter as return value }
|
|
function ret_in_param(def : pdef) : boolean;
|
|
|
|
begin
|
|
ret_in_param:=(def^.deftype=arraydef) or
|
|
(def^.deftype=stringdef) or
|
|
((def^.deftype=procvardef) and
|
|
((pprocvardef(def)^.options and pomethodpointer)<>0)) or
|
|
((def^.deftype=objectdef) and
|
|
((pobjectdef(def)^.options and oois_class)=0)
|
|
) or
|
|
(def^.deftype=recorddef) or
|
|
((def^.deftype=setdef) and
|
|
(psetdef(def)^.settype<>smallset));
|
|
end;
|
|
|
|
{ true if a const parameter is too large to copy }
|
|
function dont_copy_const_param(def : pdef) : boolean;
|
|
|
|
begin
|
|
dont_copy_const_param:=(def^.deftype=arraydef) or
|
|
(def^.deftype=stringdef) or
|
|
(def^.deftype=objectdef) or
|
|
(def^.deftype=formaldef) or
|
|
(def^.deftype=recorddef) or
|
|
((def^.deftype=procvardef) and
|
|
((pprocvardef(def)^.options and pomethodpointer)<>0)) or
|
|
((def^.deftype=setdef) and
|
|
(psetdef(def)^.settype<>smallset));
|
|
end;
|
|
|
|
procedure testrange(def : pdef;l : longint);
|
|
|
|
var
|
|
lv,hv: longint;
|
|
|
|
begin
|
|
getrange(def,lv,hv);
|
|
if (def^.deftype=orddef) and
|
|
(porddef(def)^.typ=u32bit) then
|
|
begin
|
|
if lv<=hv then
|
|
begin
|
|
if (l<lv) or (l>hv) then
|
|
Message(parser_e_range_check_error);
|
|
end
|
|
else
|
|
{ this happens with the wrap around problem }
|
|
{ if lv is positive and hv is over $7ffffff }
|
|
{ so it seems negative }
|
|
begin
|
|
if ((l>=0) and (l<lv)) or
|
|
((l<0) and (l>hv)) then
|
|
Message(parser_e_range_check_error);
|
|
end;
|
|
end
|
|
else if (l<lv) or (l>hv) then
|
|
Message(parser_e_range_check_error);
|
|
end;
|
|
|
|
procedure getrange(def : pdef;var l : longint;var h : longint);
|
|
|
|
begin
|
|
if def^.deftype=orddef then
|
|
case porddef(def)^.typ of
|
|
s32bit,s16bit,u16bit,s8bit,u8bit :
|
|
begin
|
|
l:=porddef(def)^.von;
|
|
h:=porddef(def)^.bis;
|
|
end;
|
|
bool8bit : begin
|
|
l:=0;
|
|
h:=1;
|
|
end;
|
|
uchar : begin
|
|
l:=0;
|
|
h:=255;
|
|
end;
|
|
u32bit : begin
|
|
{ this should work now }
|
|
l:=porddef(def)^.von;
|
|
h:=porddef(def)^.bis;
|
|
end;
|
|
end
|
|
else
|
|
if def^.deftype=enumdef then
|
|
begin
|
|
l:=0;
|
|
h:=penumdef(def)^.max;
|
|
end;
|
|
end;
|
|
|
|
function get_ordinal_value(p : ptree) : longint;
|
|
|
|
begin
|
|
if p^.treetype=ordconstn then
|
|
get_ordinal_value:=p^.value
|
|
else
|
|
Message(parser_e_ordinal_expected);
|
|
end;
|
|
|
|
function mmx_type(p : pdef) : tmmxtype;
|
|
|
|
begin
|
|
mmx_type:=mmxno;
|
|
if is_mmx_able_array(p) then
|
|
begin
|
|
if parraydef(p)^.definition^.deftype=floatdef then
|
|
case pfloatdef(parraydef(p)^.definition)^.typ of
|
|
s32real:
|
|
mmx_type:=mmxsingle;
|
|
f16bit:
|
|
mmx_type:=mmxfixed16
|
|
end
|
|
else
|
|
case porddef(parraydef(p)^.definition)^.typ of
|
|
u8bit:
|
|
mmx_type:=mmxu8bit;
|
|
s8bit:
|
|
mmx_type:=mmxs8bit;
|
|
u16bit:
|
|
mmx_type:=mmxu16bit;
|
|
s16bit:
|
|
mmx_type:=mmxs16bit;
|
|
u32bit:
|
|
mmx_type:=mmxu32bit;
|
|
s32bit:
|
|
mmx_type:=mmxs32bit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function is_mmx_able_array(p : pdef) : boolean;
|
|
|
|
begin
|
|
{$ifdef SUPPORT_MMX}
|
|
if (cs_mmx_saturation in aktswitches) then
|
|
begin
|
|
is_mmx_able_array:=(p^.deftype=arraydef) and
|
|
(
|
|
((parraydef(p)^.definition^.deftype=orddef) and
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
|
|
) or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
|
|
)
|
|
)
|
|
) or
|
|
(
|
|
((parraydef(p)^.definition^.deftype=floatdef) and
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(pfloatdef(parraydef(p)^.definition)^.typ=f16bit)
|
|
) or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(pfloatdef(parraydef(p)^.definition)^.typ=s32real)
|
|
)
|
|
)
|
|
);
|
|
end
|
|
else
|
|
begin
|
|
is_mmx_able_array:=(p^.deftype=arraydef) and
|
|
(
|
|
((parraydef(p)^.definition^.deftype=orddef) and
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
|
|
) or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
|
|
) or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=7) and
|
|
(porddef(parraydef(p)^.definition)^.typ in [u8bit,s8bit])
|
|
)
|
|
)
|
|
) or
|
|
(
|
|
((parraydef(p)^.definition^.deftype=floatdef) and
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(pfloatdef(parraydef(p)^.definition)^.typ=f32bit)
|
|
)
|
|
or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(pfloatdef(parraydef(p)^.definition)^.typ=s32real)
|
|
)
|
|
)
|
|
);
|
|
end;
|
|
{$else SUPPORT_MMX}
|
|
is_mmx_able_array:=false;
|
|
{$endif SUPPORT_MMX}
|
|
end;
|
|
|
|
function is_equal(def1,def2 : pdef) : boolean;
|
|
|
|
var
|
|
b : boolean;
|
|
hd : pdef;
|
|
hp1,hp2 : pdefcoll;
|
|
|
|
begin
|
|
{ both types must exists }
|
|
if not (assigned(def1) and assigned(def2)) then
|
|
begin
|
|
is_equal:=false;
|
|
exit;
|
|
end;
|
|
|
|
{ be sure, that if there is a stringdef, that this is def1 }
|
|
if def2^.deftype=stringdef then
|
|
begin
|
|
hd:=def1;
|
|
def1:=def2;
|
|
def2:=hd;
|
|
end;
|
|
b:=false;
|
|
|
|
{ wenn beide auf die gleiche Definition zeigen sind sie wohl gleich...}
|
|
if def1=def2 then
|
|
b:=true
|
|
else
|
|
{ pointer with an equal definition are equal }
|
|
if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then
|
|
{ here a problem detected in tabsolutesym }
|
|
{ the types can be forward type !! }
|
|
begin
|
|
if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
|
|
b:=(def1^.sym=def2^.sym)
|
|
else
|
|
b:=is_equal(ppointerdef(def1)^.definition,ppointerdef(def2)^.definition);
|
|
end
|
|
else
|
|
{ Grundtypen sind gleich, wenn sie den selben Grundtyp haben, }
|
|
{ und wenn noetig den selben Unterbereich haben }
|
|
if (def1^.deftype=orddef) and (def2^.deftype=orddef) then
|
|
begin
|
|
case porddef(def1)^.typ of
|
|
u32bit,u8bit,s32bit,s8bit,u16bit,s16bit : begin
|
|
if porddef(def1)^.typ=porddef(def2)^.typ then
|
|
if (porddef(def1)^.von=porddef(def2)^.von) and
|
|
(porddef(def1)^.bis=porddef(def2)^.bis) then
|
|
b:=true;
|
|
end;
|
|
uvoid,bool8bit,uchar :
|
|
b:=porddef(def1)^.typ=porddef(def2)^.typ;
|
|
end;
|
|
end
|
|
else
|
|
if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
|
|
b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
|
|
else
|
|
{ strings with the same length are equal }
|
|
if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
|
|
(pstringdef(def1)^.len=pstringdef(def2)^.len) then
|
|
b:=true
|
|
{ STRING[N] ist equivalent zu ARRAY[0..N] OF CHAR (N<256) }
|
|
{
|
|
else if ((def1^.deftype=stringdef) and (def2^.deftype=arraydef)) and
|
|
(parraydef(def2)^.definition^.deftype=orddef) and
|
|
(porddef(parraydef(def1)^.definition)^.typ=uchar) and
|
|
(parraydef(def2)^.lowrange=0) and
|
|
(parraydef(def2)^.highrange=pstringdef(def1)^.len) then
|
|
b:=true }
|
|
else
|
|
if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
|
|
b:=true
|
|
{ file types with the same file element type are equal }
|
|
{ this is a problem for assign !! }
|
|
{ changed to allow if one is untyped }
|
|
{ all typed files are equal to the special }
|
|
{ typed file that has voiddef as elemnt type }
|
|
{ but must NOT match for text file !!! }
|
|
else
|
|
if (def1^.deftype=filedef) and (def2^.deftype=filedef) then
|
|
b:=(pfiledef(def1)^.filetype=pfiledef(def2)^.filetype) and
|
|
((
|
|
((pfiledef(def1)^.typed_as=nil) and
|
|
(pfiledef(def2)^.typed_as=nil)) or
|
|
(
|
|
(pfiledef(def1)^.typed_as<>nil) and
|
|
(pfiledef(def2)^.typed_as<>nil) and
|
|
is_equal(pfiledef(def1)^.typed_as,pfiledef(def2)^.typed_as)
|
|
) or
|
|
( (pfiledef(def1)^.typed_as=pdef(voiddef)) or
|
|
(pfiledef(def2)^.typed_as=pdef(voiddef))
|
|
)))
|
|
{ sets with the same element type are equal }
|
|
else
|
|
if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
|
|
begin
|
|
if assigned(psetdef(def1)^.setof) and
|
|
assigned(psetdef(def2)^.setof) then
|
|
b:=is_equal(psetdef(def1)^.setof,psetdef(def2)^.setof)
|
|
else b:=true;
|
|
end
|
|
else
|
|
if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
|
|
begin
|
|
{ poassembler isn't important for compatibility }
|
|
b:=((pprocvardef(def1)^.options and not(poassembler))=
|
|
(pprocvardef(def2)^.options and not(poassembler))
|
|
) and
|
|
is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
|
|
{ now evalute the parameters }
|
|
if b then
|
|
begin
|
|
hp1:=pprocvardef(def1)^.para1;
|
|
hp2:=pprocvardef(def1)^.para1;
|
|
while assigned(hp1) and assigned(hp2) do
|
|
begin
|
|
if not(is_equal(hp1^.data,hp2^.data)) or
|
|
not(hp1^.paratyp=hp2^.paratyp) then
|
|
begin
|
|
b:=false;
|
|
break;
|
|
end;
|
|
hp1:=hp1^.next;
|
|
hp2:=hp2^.next;
|
|
end;
|
|
b:=(hp1=nil) and (hp2=nil);
|
|
end;
|
|
end
|
|
else
|
|
if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
|
|
(is_open_array(def1) or is_open_array(def2)) then
|
|
begin
|
|
b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
|
|
end
|
|
else
|
|
if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
|
|
begin
|
|
{ similar to pointerdef: }
|
|
if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
|
|
b:=(def1^.sym=def2^.sym)
|
|
else
|
|
b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
|
|
end;
|
|
is_equal:=b;
|
|
end;
|
|
|
|
|
|
function is_subequal(def1, def2: pdef): boolean;
|
|
Begin
|
|
if assigned(def1) and assigned(def2) then
|
|
Begin
|
|
is_subequal := FALSE;
|
|
if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
|
|
Begin
|
|
{ see p.47 of Turbo Pascal 7.01 manual for the separation of types }
|
|
{ range checking for case statements is done with testrange }
|
|
case porddef(def1)^.typ of
|
|
s32bit,u32bit,u8bit,s8bit,s16bit,u16bit:
|
|
Begin
|
|
{ PROBABLE CODE GENERATION BUG HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }
|
|
{ if porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit] then
|
|
is_subequal := TRUE; }
|
|
if (porddef(def2)^.typ = s32bit) or
|
|
(porddef(def2)^.typ = u32bit) or
|
|
(porddef(def2)^.typ = u8bit) or
|
|
(porddef(def2)^.typ = s8bit) or
|
|
(porddef(def2)^.typ = s16bit) or
|
|
(porddef(def2)^.typ = u16bit) then
|
|
Begin
|
|
is_subequal:=TRUE;
|
|
end;
|
|
end;
|
|
bool8bit: if porddef(def2)^.typ = bool8bit then is_subequal := TRUE;
|
|
uchar: if porddef(def2)^.typ = uchar then is_subequal := TRUE;
|
|
end;
|
|
end
|
|
else
|
|
Begin
|
|
{ I assume that both enumerations are equal when the first }
|
|
{ pointers are equal. }
|
|
if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
|
|
Begin
|
|
if penumdef(def1)^.first = penumdef(def2)^.first then
|
|
is_subequal := TRUE;
|
|
end;
|
|
end;
|
|
end; { endif assigned ... }
|
|
end;
|
|
|
|
type
|
|
pprocdefcoll = ^tprocdefcoll;
|
|
|
|
tprocdefcoll = record
|
|
next : pprocdefcoll;
|
|
data : pprocdef;
|
|
end;
|
|
|
|
psymcoll = ^tsymcoll;
|
|
|
|
tsymcoll = record
|
|
next : psymcoll;
|
|
name : pstring;
|
|
data : pprocdefcoll;
|
|
end;
|
|
|
|
var
|
|
wurzel : psymcoll;
|
|
nextvirtnumber : longint;
|
|
_c : pobjectdef;
|
|
has_constructor,has_virtual_method : boolean;
|
|
|
|
procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif}
|
|
|
|
var
|
|
procdefcoll : pprocdefcoll;
|
|
hp : pprocdef;
|
|
symcoll : psymcoll;
|
|
_name : string;
|
|
stored : boolean;
|
|
|
|
{ creates a new entry in the procsym list }
|
|
procedure newentry;
|
|
|
|
begin
|
|
{ if not, generate a new symbol item }
|
|
new(symcoll);
|
|
symcoll^.name:=stringdup(sym^.name);
|
|
symcoll^.next:=wurzel;
|
|
symcoll^.data:=nil;
|
|
wurzel:=symcoll;
|
|
hp:=pprocsym(sym)^.definition;
|
|
|
|
{ inserts all definitions }
|
|
while assigned(hp) do
|
|
begin
|
|
new(procdefcoll);
|
|
procdefcoll^.data:=hp;
|
|
procdefcoll^.next:=symcoll^.data;
|
|
symcoll^.data:=procdefcoll;
|
|
|
|
{ if it's a virtual method }
|
|
if (hp^.options and povirtualmethod)<>0 then
|
|
begin
|
|
{ then it gets a number ... }
|
|
hp^.extnumber:=nextvirtnumber;
|
|
{ and we inc the number }
|
|
inc(nextvirtnumber);
|
|
has_virtual_method:=true;
|
|
end;
|
|
|
|
if (hp^.options and poconstructor)<>0 then
|
|
has_constructor:=true;
|
|
|
|
{ check, if a method should be overridden }
|
|
if (hp^.options and pooverridingmethod)<>0 then
|
|
Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
|
|
{ next overloaded method }
|
|
hp:=hp^.nextoverloaded;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
{ put only sub routines into the VMT }
|
|
if sym^.typ=procsym then
|
|
begin
|
|
_name:=sym^.name;
|
|
symcoll:=wurzel;
|
|
while assigned(symcoll) do
|
|
begin
|
|
{ does the symbol already exist in the list ? }
|
|
if _name=symcoll^.name^ then
|
|
begin
|
|
{ walk through all defs of the symbol }
|
|
hp:=pprocsym(sym)^.definition;
|
|
while assigned(hp) do
|
|
begin
|
|
{ compare with all stored definitions }
|
|
procdefcoll:=symcoll^.data;
|
|
stored:=false;
|
|
while assigned(procdefcoll) do
|
|
begin
|
|
{ compare parameters }
|
|
if equal_paras(procdefcoll^.data^.para1,hp^.para1,false) and
|
|
(
|
|
((procdefcoll^.data^.options and povirtualmethod)<>0) or
|
|
((hp^.options and povirtualmethod)<>0)
|
|
) then
|
|
begin
|
|
{ wenn sie gleich sind }
|
|
{ und eine davon virtual deklariert ist }
|
|
{ Fehler falls nur eine VIRTUAL }
|
|
if (procdefcoll^.data^.options and povirtualmethod)<>
|
|
(hp^.options and povirtualmethod) then
|
|
begin
|
|
{ in classes, we hide the old method }
|
|
if _c^.isclass then
|
|
begin
|
|
{ warn only if it is the first time,
|
|
we hide the method }
|
|
if _c=hp^._class then
|
|
Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
|
|
newentry;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
Message1(parser_e_overloaded_are_not_both_virtual,_c^.name^+'.'+_name);
|
|
end;
|
|
end;
|
|
|
|
{ check, if the overridden directive is set }
|
|
{ (povirtualmethod is set! }
|
|
|
|
{ class ? }
|
|
if _c^.isclass and
|
|
((hp^.options and pooverridingmethod)=0) then
|
|
begin
|
|
{ warn only if it is the first time,
|
|
we hide the method }
|
|
if _c=hp^._class then
|
|
Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
|
|
newentry;
|
|
exit;
|
|
end;
|
|
|
|
{ error, if the return types aren't equal }
|
|
if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) then
|
|
Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);
|
|
|
|
|
|
{ the flags have to match }
|
|
{ except abstract and override }
|
|
if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
|
|
(hp^.options and not(poabstractmethod or pooverridingmethod)) then
|
|
Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);
|
|
|
|
{ now set the number }
|
|
hp^.extnumber:=procdefcoll^.data^.extnumber;
|
|
{ and exchange }
|
|
procdefcoll^.data:=hp;
|
|
stored:=true;
|
|
end;
|
|
procdefcoll:=procdefcoll^.next;
|
|
end;
|
|
{ if it isn't saved in the list }
|
|
{ we create a new entry }
|
|
if not(stored) then
|
|
begin
|
|
new(procdefcoll);
|
|
procdefcoll^.data:=hp;
|
|
procdefcoll^.next:=symcoll^.data;
|
|
symcoll^.data:=procdefcoll;
|
|
{ if the method is virtual ... }
|
|
if (hp^.options and povirtualmethod)<>0 then
|
|
begin
|
|
{ ... it will get a number }
|
|
hp^.extnumber:=nextvirtnumber;
|
|
inc(nextvirtnumber);
|
|
end;
|
|
{ check, if a method should be overridden }
|
|
if (hp^.options and pooverridingmethod)<>0 then
|
|
Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
|
|
end;
|
|
hp:=hp^.nextoverloaded;
|
|
end;
|
|
exit;
|
|
end;
|
|
symcoll:=symcoll^.next;
|
|
end;
|
|
newentry;
|
|
end;
|
|
end;
|
|
|
|
procedure genvmt(_class : pobjectdef);
|
|
|
|
procedure do_genvmt(p : pobjectdef);
|
|
|
|
begin
|
|
{ start with the base class }
|
|
if assigned(p^.childof) then
|
|
do_genvmt(p^.childof);
|
|
|
|
{ walk through all public syms }
|
|
_c:=_class;
|
|
{$ifdef tp}
|
|
p^.publicsyms^.foreach(eachsym);
|
|
{$else}
|
|
p^.publicsyms^.foreach(@eachsym);
|
|
{$endif}
|
|
end;
|
|
|
|
var
|
|
symcoll : psymcoll;
|
|
procdefcoll : pprocdefcoll;
|
|
i : longint;
|
|
|
|
begin
|
|
wurzel:=nil;
|
|
nextvirtnumber:=0;
|
|
|
|
has_constructor:=false;
|
|
has_virtual_method:=false;
|
|
|
|
{ generates a tree of all used methods }
|
|
do_genvmt(_class);
|
|
|
|
if has_virtual_method and not(has_constructor) then
|
|
begin
|
|
exterror:=strpnew(_class^.name^);
|
|
Message(parser_w_virtual_without_constructor);
|
|
end;
|
|
{ generates the VMT }
|
|
|
|
{ walk trough all numbers for virtual methods and search }
|
|
{ the method }
|
|
for i:=0 to nextvirtnumber-1 do
|
|
begin
|
|
symcoll:=wurzel;
|
|
|
|
{ walk trough all symbols }
|
|
while assigned(symcoll) do
|
|
begin
|
|
|
|
{ walk trough all methods }
|
|
procdefcoll:=symcoll^.data;
|
|
while assigned(procdefcoll) do
|
|
begin
|
|
{ writes the addresses to the VMT }
|
|
{ but only this which are declared as virtual }
|
|
if procdefcoll^.data^.extnumber=i then
|
|
begin
|
|
if (procdefcoll^.data^.options and povirtualmethod)<>0 then
|
|
begin
|
|
{ if a method is abstract, then is also the }
|
|
{ class abstract and it's not allow to }
|
|
{ generates an instance }
|
|
if (procdefcoll^.data^.options and poabstractmethod)<>0 then
|
|
begin
|
|
_class^.options:=_class^.options or oois_abstract;
|
|
datasegment^.concat(new(pai_const,init_symbol('ABSTRACTERROR')));
|
|
end
|
|
else
|
|
begin
|
|
datasegment^.concat(new(pai_const,init_symbol(
|
|
strpnew(procdefcoll^.data^.mangledname))));
|
|
maybe_concat_external(procdefcoll^.data^.owner,
|
|
procdefcoll^.data^.mangledname);
|
|
end;
|
|
end;
|
|
end;
|
|
procdefcoll:=procdefcoll^.next;
|
|
end;
|
|
symcoll:=symcoll^.next;
|
|
end;
|
|
end;
|
|
{ disposes the above generated tree }
|
|
symcoll:=wurzel;
|
|
while assigned(symcoll) do
|
|
begin
|
|
wurzel:=symcoll^.next;
|
|
stringdispose(symcoll^.name);
|
|
procdefcoll:=symcoll^.data;
|
|
while assigned(procdefcoll) do
|
|
begin
|
|
symcoll^.data:=procdefcoll^.next;
|
|
dispose(procdefcoll);
|
|
procdefcoll:=symcoll^.data;
|
|
end;
|
|
dispose(symcoll);
|
|
symcoll:=wurzel;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.10 1998-04-29 10:34:08 pierre
|
|
+ added some code for ansistring (not complete nor working yet)
|
|
* corrected operator overloading
|
|
* corrected nasm output
|
|
+ started inline procedures
|
|
+ added starstarn : use ** for exponentiation (^ gave problems)
|
|
+ started UseTokenInfo cond to get accurate positions
|
|
|
|
Revision 1.9 1998/04/21 10:16:49 peter
|
|
* patches from strasbourg
|
|
* objects is not used anymore in the fpc compiled version
|
|
|
|
Revision 1.8 1998/04/12 22:39:44 florian
|
|
* problem with read access to properties solved
|
|
* correct handling of hidding methods via virtual (COM)
|
|
* correct result type of constructor calls (COM), the resulttype
|
|
depends now on the type of the class reference
|
|
|
|
Revision 1.7 1998/04/10 21:36:56 florian
|
|
+ some stuff to support method pointers (procedure of object) added
|
|
(declaration, parameter handling)
|
|
|
|
Revision 1.6 1998/04/10 15:39:49 florian
|
|
* more fixes to get classes.pas compiled
|
|
|
|
Revision 1.5 1998/04/09 23:02:16 florian
|
|
* small problems solved to get remake3 work
|
|
|
|
Revision 1.4 1998/04/08 16:58:09 pierre
|
|
* several bugfixes
|
|
ADD ADC and AND are also sign extended
|
|
nasm output OK (program still crashes at end
|
|
and creates wrong assembler files !!)
|
|
procsym types sym in tdef removed !!
|
|
|
|
Revision 1.3 1998/04/08 11:34:22 peter
|
|
* nasm works (linux only tested)
|
|
|
|
Revision 1.2 1998/03/28 23:09:57 florian
|
|
* secondin bugfix (m68k and i386)
|
|
* overflow checking bugfix (m68k and i386) -- pretty useless in
|
|
secondadd, since everything is done using 32-bit
|
|
* loading pointer to routines hopefully fixed (m68k)
|
|
* flags problem with calls to RTL internal routines fixed (still strcmp
|
|
to fix) (m68k)
|
|
* #ELSE was still incorrect (didn't take care of the previous level)
|
|
* problem with filenames in the command line solved
|
|
* problem with mangledname solved
|
|
* linking name problem solved (was case insensitive)
|
|
* double id problem and potential crash solved
|
|
* stop after first error
|
|
* and=>test problem removed
|
|
* correct read for all float types
|
|
* 2 sigsegv fixes and a cosmetic fix for Internal Error
|
|
* push/pop is now correct optimized (=> mov (%esp),reg)
|
|
|
|
Revision 1.1.1.1 1998/03/25 11:18:15 root
|
|
* Restored version
|
|
|
|
Revision 1.24 1998/03/21 23:59:40 florian
|
|
* indexed properties fixed
|
|
* ppu i/o of properties fixed
|
|
* field can be also used for write access
|
|
* overriding of properties
|
|
|
|
Revision 1.23 1998/03/20 23:31:35 florian
|
|
* bug0113 fixed
|
|
* problem with interdepened units fixed ("options.pas problem")
|
|
* two small extensions for future AMD 3D support
|
|
|
|
Revision 1.22 1998/03/10 01:17:30 peter
|
|
* all files have the same header
|
|
* messages are fully implemented, EXTDEBUG uses Comment()
|
|
+ AG... files for the Assembler generation
|
|
|
|
Revision 1.21 1998/03/06 01:09:01 peter
|
|
* removed the conflicts that had occured
|
|
|
|
Revision 1.20 1998/03/06 00:53:01 peter
|
|
* replaced all old messages from errore.msg, only ExtDebug and some
|
|
Comment() calls are left
|
|
* fixed options.pas
|
|
|
|
Revision 1.19 1998/03/05 22:40:56 florian
|
|
+ warning about missing constructor added
|
|
|
|
Revision 1.18 1998/03/04 17:34:14 michael
|
|
+ Changed ifdef FPK to ifdef FPC
|
|
|
|
Revision 1.17 1998/03/02 01:49:38 peter
|
|
* renamed target_DOS to target_GO32V1
|
|
+ new verbose system, merged old errors and verbose units into one new
|
|
verbose.pas, so errors.pas is obsolete
|
|
|
|
Revision 1.16 1998/02/13 10:35:55 daniel
|
|
* Made Motorola version compilable.
|
|
* Fixed optimizer
|
|
|
|
Revision 1.15 1998/02/12 17:19:33 florian
|
|
* fixed to get remake3 work, but needs additional fixes (output, I don't like
|
|
also that aktswitches isn't a pointer)
|
|
|
|
Revision 1.14 1998/02/12 11:50:52 daniel
|
|
Yes! Finally! After three retries, my patch!
|
|
|
|
Changes:
|
|
|
|
Complete rewrite of psub.pas.
|
|
Added support for DLL's.
|
|
Compiler requires less memory.
|
|
Platform units for each platform.
|
|
|
|
Revision 1.13 1998/02/11 21:56:41 florian
|
|
* bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
|
|
|
|
Revision 1.12 1998/02/07 23:05:08 florian
|
|
* once more MMX
|
|
|
|
Revision 1.11 1998/02/06 10:34:35 florian
|
|
* bug0082 and bug0084 fixed
|
|
|
|
Revision 1.10 1998/02/05 22:27:07 florian
|
|
* small problems fixed: remake3 should now work
|
|
|
|
Revision 1.9 1998/02/05 21:54:36 florian
|
|
+ more MMX
|
|
|
|
Revision 1.8 1998/01/31 00:43:37 carl
|
|
- removed in in is_subequal, because the code generator is buggy!
|
|
(instead uses if...)
|
|
|
|
Revision 1.7 1998/01/16 18:03:21 florian
|
|
* small bug fixes, some stuff of delphi styled constructores added
|
|
|
|
Revision 1.6 1998/01/11 19:24:35 carl
|
|
+ type checking routine (is_subequal) for case statements
|
|
|
|
Revision 1.5 1998/01/09 23:08:38 florian
|
|
+ C++/Delphi styled //-comments
|
|
* some bugs in Delphi object model fixed
|
|
+ override directive
|
|
|
|
Revision 1.4 1998/01/09 16:08:24 florian
|
|
* abstract methods call now abstracterrorproc if they are called
|
|
a class with an abstract method can be create with a class reference else
|
|
the compiler forbides this
|
|
|
|
Revision 1.3 1998/01/07 00:17:12 michael
|
|
Restored released version (plus fixes) as current
|
|
|
|
Revision 1.2 1997/11/28 18:14:51 pierre
|
|
working version with several bug fixes
|
|
|
|
Revision 1.1.1.1 1997/11/27 08:33:03 michael
|
|
FPC Compiler CVS start
|
|
|
|
|
|
Pre-CVS log:
|
|
|
|
CEC Carl-Eric Codere
|
|
FK Florian Klaempfl
|
|
PM Pierre Muller
|
|
+ feature added
|
|
- removed
|
|
* bug fixed or changed
|
|
|
|
History:
|
|
22th september 1997
|
|
+ function dont_copy_const_param added (FK)
|
|
25th september 1997
|
|
+ is_open_array added (FK)
|
|
+ is_equal handles now also open arrays (FK)
|
|
2nd october 1997
|
|
+ added then boolean never_copy_const_param for use in typed write
|
|
where we must push the reference anyway (PM)
|
|
3rd october 1997:
|
|
+ renamed ret_in_eax to ret_in_acc (for accumulator for port.) (CEC)
|
|
- removed reference to i386 unit (CEC)
|
|
25th october 1997:
|
|
* poassembler isn't important for compatiblity of proc vars (FK)
|
|
3rd november 1997:
|
|
+ added formaldef type to types where we dont_copy_const_param (PM)
|
|
20rd november 1997:
|
|
+ added is_fpu function (PM)
|
|
}
|