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

git-svn-id: trunk@16636 -

compiler/defcmp.pas

@@ -29,7 +29,7 @@ interface
        cclasses,
        globtype,globals,
        node,
-       symconst,symtype,symdef;
+       symconst,symtype,symbase,symdef;
 
      type
        { if acp is cp_all the var const or nothing are considered equal }
@@ -1487,7 +1487,19 @@ implementation
             )
            ) then
           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
              eq:=te_convert_operator;
           end;

compiler/htypechk.pas

@@ -97,34 +97,35 @@ interface
 
   {$i compinnr.inc}
     const
-      tok2nodes=26;
+      tok2nodes=27;
       tok2node:array[1..tok2nodes] of ttok2noderec=(
-        (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:_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:_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:_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:_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:_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_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_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_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_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_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:_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_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 }
+        (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:_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:_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:_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:_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:_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_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_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_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_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_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:_ASSIGNMENT ;nod:assignn;inr:-1;op_overloading_supported:true),   { unary overloading supported }
+        (tok:_OP_EXPLICIT;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_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 }
@@ -419,7 +420,7 @@ implementation
           1 : begin
                 ld:=tparavarsym(pf.parast.SymList[0]).vardef;
                 { assignment is a special case }
-                if optoken=_ASSIGNMENT then
+                if optoken in [_ASSIGNMENT,_OP_EXPLICIT] then
                   begin
                     eq:=compare_defs_ext(ld,pf.returndef,nothingn,conv,pd,[cdo_explicit]);
                     result:=

compiler/pdecsub.pas

@@ -826,8 +826,8 @@ implementation
                   else
                   if (m_delphi in current_settings.modeswitches) then
                     case lastidtoken of
-//                         _IMPLICIT:optoken:=;
-//                         _EXPLICIT:optoken:=;
+                      _IMPLICIT:optoken:=_ASSIGNMENT;
+                      _EXPLICIT:optoken:=_OP_EXPLICIT;
                       _NEGATIVE:optoken:=_MINUS;
 //                         _POSITIVE:optoken:=_PLUS;
                       _INC:optoken:=_OP_INC;
@@ -1380,7 +1380,7 @@ implementation
                         ((pd.returndef.typ<>orddef) or
                          (torddef(pd.returndef).ordtype<>pasbool)) then
                         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
                        message(parser_e_no_such_assignment)
                      else if not isoperatoracceptable(pd,optoken) then

compiler/pexpr.pas

@@ -2786,7 +2786,7 @@ implementation
 ****************************************************************************}
    const
       { 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],
           [_PLUS,_MINUS,_OP_OR,_PIPE,_OP_XOR],
           [_CARET,_SYMDIF,_STARSTAR,_STAR,_SLASH,

compiler/symtable.pas

@@ -214,7 +214,7 @@ interface
     function  search_system_type(const s: TIDString): 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_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_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;
@@ -290,6 +290,7 @@ interface
     { _OP_SHR        }  'shr',
     { _OP_XOR        }  'xor',
     { _ASSIGNMENT    }  'assign',
+    { _OP_EXPLICIT   }  'explicit',
     { _OP_ENUMERATOR }  'enumerator',
     { _OP_INC        }  'inc',
     { _OP_DEC        }  'dec');
@@ -2234,7 +2235,9 @@ implementation
       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
         sym : Tprocsym;
         hashedid : THashedIDString;
@@ -2244,7 +2247,7 @@ implementation
         bestpd : tprocdef;
         stackitem : psymtablestackitem;
       begin
-        hashedid.id:='assign';
+        hashedid.id:=overloaded_names[op_token[explicit]];
         besteq:=te_incompatible;
         bestpd:=nil;
         stackitem:=symtablestack.stack;

compiler/tokens.pas

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

tests/test/terecs6.pp

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