paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-18 16:55:56 +02:00
Code Issues Packages Projects Releases Wiki Activity

compiler: map delphi Implicit operator to := operator of FPC, add Explicit operator for delphi only (for now) which works when explicit type conversion happens + extend test

Browse Source 
git-svn-id: trunk@16636 -
This commit is contained in:
paul 2010-12-25 11:08:02 +00:00
parent 2ff5f7a000
commit 66b128efb3
7 changed files with 77 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/defcmp.pas
View File

@ -29,7 +29,7 @@ interface
cclasses, cclasses,
globtype,globals, globtype,globals,
node, node,
symconst,symtype,symdef; symconst,symtype,symbase,symdef;
type type
{ if acp is cp_all the var const or nothing are considered equal } { if acp is cp_all the var const or nothing are considered equal }
@ -1487,7 +1487,19 @@ implementation
) )
) then ) then
begin begin
operatorpd:=search_assignment_operator(def_from,def_to); { search record/object symtable first for a sutable operator }
if def_from.typ in [recorddef,objectdef] then
symtablestack.push(tabstractrecorddef(def_from).symtable);
{ if type conversion is explicit then search first for explicit
operator overload and if not found then use implicit operator }
if cdo_explicit in cdoptions then
operatorpd:=search_assignment_operator(def_from,def_to,true)
else
operatorpd:=nil;
if operatorpd=nil then
operatorpd:=search_assignment_operator(def_from,def_to,false);
if def_from.typ in [recorddef,objectdef] then
symtablestack.pop(tabstractrecorddef(def_from).symtable);
if assigned(operatorpd) then if assigned(operatorpd) then
eq:=te_convert_operator; eq:=te_convert_operator;
end; end;

57
compiler/htypechk.pas
View File

@ -97,34 +97,35 @@ interface
{$i compinnr.inc} {$i compinnr.inc}
const const
tok2nodes=26; tok2nodes=27;
tok2node:array[1..tok2nodes] of ttok2noderec=( tok2node:array[1..tok2nodes] of ttok2noderec=(
(tok:_PLUS ;nod:addn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_PLUS ;nod:addn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_MINUS ;nod:subn;inr:-1;op_overloading_supported:true), { binary and unary overloading supported } (tok:_MINUS ;nod:subn;inr:-1;op_overloading_supported:true), { binary and unary overloading supported }
(tok:_STAR ;nod:muln;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_STAR ;nod:muln;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_SLASH ;nod:slashn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_SLASH ;nod:slashn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_EQ ;nod:equaln;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_EQ ;nod:equaln;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_GT ;nod:gtn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_GT ;nod:gtn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_LT ;nod:ltn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_LT ;nod:ltn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_GTE ;nod:gten;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_GTE ;nod:gten;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_LTE ;nod:lten;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_LTE ;nod:lten;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_SYMDIF ;nod:symdifn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_SYMDIF ;nod:symdifn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_STARSTAR ;nod:starstarn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_STARSTAR ;nod:starstarn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_AS ;nod:asn;inr:-1;op_overloading_supported:false), { binary overloading NOT supported } (tok:_OP_AS ;nod:asn;inr:-1;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_OP_IN ;nod:inn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_IN ;nod:inn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_IS ;nod:isn;inr:-1;op_overloading_supported:false), { binary overloading NOT supported } (tok:_OP_IS ;nod:isn;inr:-1;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_OP_OR ;nod:orn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_OR ;nod:orn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_AND ;nod:andn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_AND ;nod:andn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_DIV ;nod:divn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_DIV ;nod:divn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_NOT ;nod:notn;inr:-1;op_overloading_supported:true), { unary overloading supported } (tok:_OP_NOT ;nod:notn;inr:-1;op_overloading_supported:true), { unary overloading supported }
(tok:_OP_MOD ;nod:modn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_MOD ;nod:modn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_SHL ;nod:shln;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_SHL ;nod:shln;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_SHR ;nod:shrn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_SHR ;nod:shrn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_XOR ;nod:xorn;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_XOR ;nod:xorn;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_ASSIGNMENT;nod:assignn;inr:-1;op_overloading_supported:true), { unary overloading supported } (tok:_ASSIGNMENT ;nod:assignn;inr:-1;op_overloading_supported:true), { unary overloading supported }
(tok:_NE ;nod:unequaln;inr:-1;op_overloading_supported:true), { binary overloading supported } (tok:_OP_EXPLICIT;nod:assignn;inr:-1;op_overloading_supported:true), { unary overloading supported }
(tok:_OP_INC ;nod:inlinen;inr:in_inc_x;op_overloading_supported:true),{ unary overloading supported } (tok:_NE ;nod:unequaln;inr:-1;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_DEC ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true) { unary overloading supported } (tok:_OP_INC ;nod:inlinen;inr:in_inc_x;op_overloading_supported:true),{ unary overloading supported }
(tok:_OP_DEC ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true) { unary overloading supported }
); );
{ true, if we are parsing stuff which allows array constructors } { true, if we are parsing stuff which allows array constructors }
@ -419,7 +420,7 @@ implementation
1 : begin 1 : begin
ld:=tparavarsym(pf.parast.SymList[0]).vardef; ld:=tparavarsym(pf.parast.SymList[0]).vardef;
{ assignment is a special case } { assignment is a special case }
if optoken=_ASSIGNMENT then if optoken in [_ASSIGNMENT,_OP_EXPLICIT] then
begin begin
eq:=compare_defs_ext(ld,pf.returndef,nothingn,conv,pd,[cdo_explicit]); eq:=compare_defs_ext(ld,pf.returndef,nothingn,conv,pd,[cdo_explicit]);
result:= result:=

6
compiler/pdecsub.pas
View File

@ -826,8 +826,8 @@ implementation
else else
if (m_delphi in current_settings.modeswitches) then if (m_delphi in current_settings.modeswitches) then
case lastidtoken of case lastidtoken of
// _IMPLICIT:optoken:=; _IMPLICIT:optoken:=_ASSIGNMENT;
// _EXPLICIT:optoken:=; _EXPLICIT:optoken:=_OP_EXPLICIT;
_NEGATIVE:optoken:=_MINUS; _NEGATIVE:optoken:=_MINUS;
// _POSITIVE:optoken:=_PLUS; // _POSITIVE:optoken:=_PLUS;
_INC:optoken:=_OP_INC; _INC:optoken:=_OP_INC;
@ -1380,7 +1380,7 @@ implementation
((pd.returndef.typ<>orddef) or ((pd.returndef.typ<>orddef) or
(torddef(pd.returndef).ordtype<>pasbool)) then (torddef(pd.returndef).ordtype<>pasbool)) then
Message(parser_e_comparative_operator_return_boolean); Message(parser_e_comparative_operator_return_boolean);
if (optoken=_ASSIGNMENT) and if (optoken in [_ASSIGNMENT,_OP_EXPLICIT]) and
equal_defs(pd.returndef,tparavarsym(pd.parast.SymList[0]).vardef) then equal_defs(pd.returndef,tparavarsym(pd.parast.SymList[0]).vardef) then
message(parser_e_no_such_assignment) message(parser_e_no_such_assignment)
else if not isoperatoracceptable(pd,optoken) then else if not isoperatoracceptable(pd,optoken) then

2
compiler/pexpr.pas
View File

@ -2786,7 +2786,7 @@ implementation
****************************************************************************} ****************************************************************************}
const const
{ Warning these stay be ordered !! } { Warning these stay be ordered !! }
operator_levels:array[Toperator_precedence] of set of Ttoken= operator_levels:array[Toperator_precedence] of set of NOTOKEN..last_operator=
([_LT,_LTE,_GT,_GTE,_EQ,_NE,_OP_IN], ([_LT,_LTE,_GT,_GTE,_EQ,_NE,_OP_IN],
[_PLUS,_MINUS,_OP_OR,_PIPE,_OP_XOR], [_PLUS,_MINUS,_OP_OR,_PIPE,_OP_XOR],
[_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH, [_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH,

9
compiler/symtable.pas
View File

@ -214,7 +214,7 @@ interface
function search_system_type(const s: TIDString): ttypesym; function search_system_type(const s: TIDString): ttypesym;
function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym; function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
function search_struct_member(pd : tabstractrecorddef;const s : string):tsym; function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
function search_assignment_operator(from_def,to_def:Tdef):Tprocdef; function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef; function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef;
function search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; function search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
@ -290,6 +290,7 @@ interface
{ _OP_SHR } 'shr', { _OP_SHR } 'shr',
{ _OP_XOR } 'xor', { _OP_XOR } 'xor',
{ _ASSIGNMENT } 'assign', { _ASSIGNMENT } 'assign',
{ _OP_EXPLICIT } 'explicit',
{ _OP_ENUMERATOR } 'enumerator', { _OP_ENUMERATOR } 'enumerator',
{ _OP_INC } 'inc', { _OP_INC } 'inc',
{ _OP_DEC } 'dec'); { _OP_DEC } 'dec');
@ -2234,7 +2235,9 @@ implementation
end; end;
function search_assignment_operator(from_def,to_def:Tdef):Tprocdef; function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
const
op_token:array[boolean] of ttoken=(_ASSIGNMENT,_OP_EXPLICIT);
var var
sym : Tprocsym; sym : Tprocsym;
hashedid : THashedIDString; hashedid : THashedIDString;
@ -2244,7 +2247,7 @@ implementation
bestpd : tprocdef; bestpd : tprocdef;
stackitem : psymtablestackitem; stackitem : psymtablestackitem;
begin begin
hashedid.id:='assign'; hashedid.id:=overloaded_names[op_token[explicit]];
besteq:=te_incompatible; besteq:=te_incompatible;
bestpd:=nil; bestpd:=nil;
stackitem:=symtablestack.stack; stackitem:=symtablestack.stack;

7
compiler/tokens.pas
View File

@ -54,6 +54,7 @@ type
_OP_SHR, _OP_SHR,
_OP_XOR, _OP_XOR,
_ASSIGNMENT, _ASSIGNMENT,
_OP_EXPLICIT,
_OP_ENUMERATOR, _OP_ENUMERATOR,
_OP_INC, _OP_INC,
_OP_DEC, _OP_DEC,
@ -299,6 +300,7 @@ const
be declared directly after NOTOKEN } be declared directly after NOTOKEN }
first_overloaded = succ(NOTOKEN); first_overloaded = succ(NOTOKEN);
last_overloaded = _OP_DEC; last_overloaded = _OP_DEC;
last_operator = _GENERICSPECIALTOKEN;
type type
tokenrec=record tokenrec=record
@ -346,9 +348,10 @@ const
(str:'shr' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'shr' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'xor' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'xor' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:':=' ;special:true ;keyword:m_none;op:NOTOKEN), (str:':=' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'explicit' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'enumerator' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'enumerator' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'++' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'inc' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'--' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'dec' ;special:true ;keyword:m_none;op:NOTOKEN),
{ Special chars } { Special chars }
(str:'^' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'^' ;special:true ;keyword:m_none;op:NOTOKEN),
(str:'[' ;special:true ;keyword:m_none;op:NOTOKEN), (str:'[' ;special:true ;keyword:m_none;op:NOTOKEN),

19
tests/test/terecs6.pp
View File

@ -8,6 +8,8 @@ uses
type type
TFoo = record TFoo = record
F: Integer; F: Integer;
class operator Explicit(a: TFoo): Integer;
class operator Implicit(a: TFoo): Integer;
class operator Equal(a, b: TFoo): Boolean; class operator Equal(a, b: TFoo): Boolean;
class operator NotEqual(a, b: TFoo): Boolean; class operator NotEqual(a, b: TFoo): Boolean;
class operator In(a, b: TFoo): Boolean; class operator In(a, b: TFoo): Boolean;
@ -34,6 +36,17 @@ type
class operator Dec(a: TFoo): TFoo; class operator Dec(a: TFoo): TFoo;
end; end;
class operator TFoo.Explicit(a: TFoo): Integer;
begin
// to check the difference with implicit
Result := a.F + 1;
end;
class operator TFoo.Implicit(a: TFoo): Integer;
begin
Result := a.F;
end;
class operator TFoo.Equal(a, b: TFoo): Boolean; class operator TFoo.Equal(a, b: TFoo): Boolean;
begin begin
Result := a.F = b.F; Result := a.F = b.F;
@ -156,6 +169,7 @@ end;
var var
a, b: TFoo; a, b: TFoo;
i: integer;
begin begin
a.F := 1; a.F := 1;
b.F := 2; b.F := 2;
@ -213,5 +227,10 @@ begin
dec(b); dec(b);
if b.F <> 1 then if b.F <> 1 then
halt(25); halt(25);
i := b;
if i <> 1 then
halt(26);
if Integer(b) <> 2 then
halt(27);
WriteLn('ok'); WriteLn('ok');
end. end.