* bugfix 2109 (bad imho, but only way)

compiler/defbase.pas

@@ -214,6 +214,15 @@ interface
              var doconv : tconverttype;
              fromtreetype : tnodetype;
              explicit : boolean) : byte;
+             
+    { this routine is recusrive safe, and is used by the
+      checking of overloaded assignment operators ONLY!
+    }  
+    function overloaded_assignment_isconvertable(def_from,def_to : tdef;
+             var doconv : tconverttype;
+             fromtreetype : tnodetype;
+             explicit : boolean; var overload_procs : pprocdeflist) : byte;
+             
 
     { Same as is_equal, but with error message if failed }
     function CheckTypes(def1,def2 : tdef) : boolean;
@@ -387,6 +396,7 @@ implementation
       var
         def1,def2 : TParaItem;
         doconv : tconverttype;
+        p : pointer;
       begin
          def1:=TParaItem(paralist1.first);
          def2:=TParaItem(paralist2.first);
@@ -1266,40 +1276,71 @@ implementation
             end;
        end;
 *)
+    { this is an internal routine to take care of recursivity }
+    function internal_assignment_overloaded(from_def,to_def : tdef; 
+        var overload_procs : pprocdeflist) : tprocdef;
+     var
+       p :pprocdeflist;
+     begin
+          internal_assignment_overloaded:=nil;
+          p := nil;
+          if not assigned(overloaded_operators[_ASSIGNMENT]) then
+            exit;
 
-    function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
+          { look for an exact match first, from start of list }
+          internal_assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
+             search_procdef_byretdef_by1paradef(to_def,from_def,dm_exact,
+               p);
+          if assigned(internal_assignment_overloaded) then
+            exit;
 
-       begin
-          assignment_overloaded:=nil;
-          if not assigned(overloaded_operators[_ASSIGNMENT]) then
+          { .... then look for an equal match, from start of list }
+          internal_assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
+           search_procdef_byretdef_by1paradef(to_def,from_def,dm_equal,
+                p);
+          if assigned(internal_assignment_overloaded) then
             exit;
 
-          { look for an exact match first }
-      assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
-       search_procdef_byretdef_by1paradef(to_def,from_def,dm_exact);
-      if assigned(assignment_overloaded) then
-        exit;
+          {  .... then for convert level 1, continue from where we were at }
+          internal_assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
+           search_procdef_byretdef_by1paradef(to_def,from_def,dm_convertl1,
+                overload_procs);
+     end;
 
-          { .... then look for an equal match }
-      assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
-       search_procdef_byretdef_by1paradef(to_def,from_def,dm_equal);
-      if assigned(assignment_overloaded) then
-        exit;
 
-          {  .... then for convert level 1 }
-      assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
-       search_procdef_byretdef_by1paradef(to_def,from_def,dm_convertl1);
+    function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
+
+       var
+         p : pprocdeflist;
+       begin
+          p:=nil;
+          assignment_overloaded:=nil;
+          assignment_overloaded:=internal_assignment_overloaded(
+            from_def, to_def, p);
        end;
 
 
     { Returns:
        0 - Not convertable
        1 - Convertable
-       2 - Convertable, but not first choice }
+       2 - Convertable, but not first choice 
+    }   
     function isconvertable(def_from,def_to : tdef;
              var doconv : tconverttype;
              fromtreetype : tnodetype;
              explicit : boolean) : byte;
+      var
+       p: pprocdeflist;
+      begin
+        p:=nil;
+        isconvertable:=overloaded_assignment_isconvertable(def_from,def_to,
+          doconv, fromtreetype, explicit,p);
+      end;
+      
+    function overloaded_assignment_isconvertable(def_from,def_to : tdef;
+             var doconv : tconverttype;
+             fromtreetype : tnodetype;
+             explicit : boolean; var overload_procs : pprocdeflist) : byte;
 
       { Tbasetype:
            uvoid,
@@ -1333,7 +1374,7 @@ implementation
        { safety check }
          if not(assigned(def_from) and assigned(def_to)) then
           begin
-            isconvertable:=0;
+            overloaded_assignment_isconvertable :=0;
             exit;
           end;
 
@@ -1859,22 +1900,22 @@ implementation
                else
                 begin
                   { assignment overwritten ?? }
-                  if assignment_overloaded(def_from,def_to)<>nil then
+                  if internal_assignment_overloaded(def_from,def_to,overload_procs)<>nil then
                     b:=2;
                 end;
              end;
-     formaldef:
-       {Just about everything can be converted to a formaldef...}
-       if not (def_from.deftype in [abstractdef,errordef]) then
-          b:=1;
-           else
-             begin
-               { assignment overwritten ?? }
-               if assignment_overloaded(def_from,def_to)<>nil then
-                 b:=2;
-             end;
+          formaldef:
+            {Just about everything can be converted to a formaldef...}
+            if not (def_from.deftype in [abstractdef,errordef]) then
+               b:=1;
+            else
+                begin
+                  { assignment overwritten ?? }
+                  if internal_assignment_overloaded(def_from,def_to,overload_procs)<>nil then
+                    b:=2;
+                end;
          end;
-        isconvertable:=b;
+        overloaded_assignment_isconvertable :=b;
       end;
 
     function CheckTypes(def1,def2 : tdef) : boolean;
@@ -1908,7 +1949,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.9  2002-09-07 15:25:02  peter
+  Revision 1.10  2002-09-08 11:10:17  carl
+    * bugfix 2109 (bad imho, but only way)
+
+  Revision 1.9  2002/09/07 15:25:02  peter
     * old logs removed and tabs fixed
 
   Revision 1.8  2002/09/07 09:16:55  carl

compiler/symsym.pas

@@ -143,7 +143,7 @@ interface
           function search_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
           function search_procdef_by1paradef(firstpara:Tdef):Tprocdef;
           function search_procdef_byretdef_by1paradef(retdef,firstpara:Tdef;
-                                                      matchtype:Tdefmatch):Tprocdef;
+             matchtype:Tdefmatch; var pd : pprocdeflist):Tprocdef;
           function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;override;
 {$ifdef GDB}
           function stabstring : pchar;override;
@@ -1100,17 +1100,20 @@ implementation
     end;
 
     function Tprocsym.search_procdef_byretdef_by1paradef(retdef,firstpara:Tdef;
-                                                         matchtype:Tdefmatch):Tprocdef;
+                                                         matchtype:Tdefmatch; var pd : pprocdeflist):Tprocdef;
 
-    var pd:Pprocdeflist;
-        convtyp:Tconverttype;
+    var 
+        convtyp:tconverttype;
         a,b:boolean;
+        oldpd : pprocdeflist;
 
     begin
         search_procdef_byretdef_by1paradef:=nil;
-        pd:=defs;
+        if not assigned(pd) then
+           pd:=defs;
         while assigned(pd) do
             begin
+                oldpd := pd;
                 a:=is_equal(retdef,pd^.def.rettype.def);
                 {Alert alert alert alert alert alert alert!!!
 
@@ -1125,8 +1128,8 @@ implementation
                         dm_equal:
                             b:=is_equal(Tparaitem(pd^.def.para.first).paratype.def,firstpara);
                         dm_convertl1:
-                            b:=isconvertable(firstpara,Tparaitem(pd^.def.para.first).paratype.def,
-                                convtyp,ordconstn,false)=1;
+                            b:=overloaded_assignment_isconvertable(firstpara,Tparaitem(pd^.def.para.first).paratype.def,
+                                convtyp,ordconstn,false,oldpd)=1;
                     end;
                 if a and b then
                     begin
@@ -2497,7 +2500,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.63  2002-09-07 18:17:41  florian
+  Revision 1.64  2002-09-08 11:10:17  carl
+    * bugfix 2109 (bad imho, but only way)
+
+  Revision 1.63  2002/09/07 18:17:41  florian
     + tvarsym.paraitem added
 
   Revision 1.62  2002/09/07 15:25:10  peter

tests/webtbs/tw2109.pp

@@ -0,0 +1,185 @@
+{ Source provided for Free Pascal Bug Report 2109 }
+{ Submitted by "Layton Davis" on  2002-09-05 }
+{ e-mail: [email protected] }
+unit tw2109;
+
+interface
+
+{ warning!!! -- pascal re-generates every result in an operator statement }
+{   attributes of the results have to be carried forward from the old value }
+{   as a work arround we have to ask the user to assign the original destination variable to OldBCD }
+{   or OldZoned before doing any assignments or arithmetic }
+{ fixme!!! -- assignment statements are used automatically to provide data }
+{   type conversion.  I need to provide a safety net so that this doesn't create bad behavior }
+{   from this library }
+
+
+type
+  flint = record
+    data : longint;
+    dec  : byte;
+  end;
+
+  bcddata = array[1..18] of char;
+  bcd = record
+    data   : ^bcddata;
+    bcdlen : byte;
+    bcddec : byte;
+  end;
+
+  zoneddata = array[1..9] of char;
+  zoned = record
+    data    : ^zoneddata;
+    zonelen : byte;
+    zonedec : byte;
+  end;
+
+operator := (a:bcd)     b:Integer;
+
+operator := (a:bcd)     b:Longint;
+
+operator := (a:bcd)     b:FLInt;
+
+function initbcd(blen, bdec:byte; bcdptr:pointer):bcd;
+operator := (a:integer) b:bcd;
+operator := (a:longint) b:bcd;
+operator := (a:FLInt)   b:bcd;
+
+function initzoned(zlen, zdec:byte; zptr:pointer):zoned;
+
+var
+  OldBCD : bcd;
+
+implementation
+
+operator := (a:bcd)     b:Integer;
+var
+  knt : integer;
+begin
+  b := 0;
+  for knt := 1 to a.bcdlen - a.bcddec do
+  begin
+    b := b * 10;
+    b := b + ord(a.data^[knt]) - ord('0');
+  end;
+end;
+
+operator := (a:bcd)     b: LongInt;
+var
+  test : FLInt;
+  knt  : byte;
+begin
+  test := a;
+  b := test.data;
+  knt := test.dec;
+  while knt > 0 do
+  begin
+    b := b div 10;
+    knt := knt - 1;
+  end;
+end;
+
+operator := (a:bcd)     b:FLInt;
+var
+  knt : byte;
+begin
+  b.data := 0;
+  for knt := 1 to a.bcdlen do
+    b.data := (b.data * 10) + ord(a.data^[knt]) - ord('0');
+  b.dec := a.bcddec;
+end;
+
+operator := (a:FLInt)   b:bcd;
+var
+  tmp : FLInt;
+  knt : byte;
+  tmpl : longint;
+begin
+  b := oldbcd;
+  tmp := a;
+  while tmp.dec < b.bcddec do
+  begin
+    tmp.data := tmp.data * 10;
+    tmp.dec := tmp.dec + 1;
+  end;
+  while tmp.dec > b.bcddec do
+  begin
+    tmp.data := tmp.data div 10;
+    tmp.dec := tmp.dec - 1;
+  end;
+  for knt := 1 to b.bcdlen do
+    b.data^[knt] := '0';
+  knt := b.bcdlen;
+  while (knt > 0) and (tmp.data > 0) do
+  begin
+    tmpl := tmp.data div 10;
+    tmpl := tmp.data - (tmpl * 10);
+    b.data^[knt] := char(ord('0') + tmpl);
+    tmp.data := tmp.data div 10;
+    knt := knt - 1;
+  end;
+end;
+
+function initbcd(blen, bdec:byte; bcdptr:pointer):bcd;
+var
+  temp : bcd;
+  knt  : integer;
+begin
+  if bcdptr <> NIL then
+    temp.data := bcdptr
+  else
+    new(temp.data);
+  temp.bcdlen := blen;
+  temp.bcddec := bdec;
+  for knt := 1 to blen do   {only fill out the space allocated to us -- as we may be part of a data structure}
+    temp.data^[knt] := '0';
+  initbcd := temp;
+end;
+
+operator := (a:integer) b:bcd;
+var
+  knt : integer;
+  temp : integer;
+  temp2  : integer;
+begin
+  b := oldbcd;
+  for knt := 1 to b.bcdlen do
+    b.data^[knt] := '0';
+  knt := b.bcdlen-b.bcddec;
+  temp := a;
+  while (knt > 0 ) and (temp > 0) do
+  begin
+    temp2 := temp div 10;
+    temp2 := temp - (temp2 * 10);
+    temp := temp div 10;
+    b.data^[knt] := char(ord('0') + temp2);
+    knt := knt - 1;
+  end;
+end;
+
+operator := (a:longint) b:bcd;
+var
+  knt : integer;
+  temp : longint;
+  temp2  : longint;
+begin
+  b := oldbcd;
+  for knt := 1 to b.bcdlen do
+    b.data^[knt] := '0';
+  knt := b.bcdlen-b.bcddec;
+  temp := a;
+  while (knt > 0 ) and (temp > 0) do
+  begin
+    temp2 := temp div 10;
+    temp2 := temp - (temp2 * 10);
+    temp := temp div 10;
+    b.data^[knt] := char(ord('0') + temp2);
+    knt := knt - 1;
+  end;
+end;
+
+function initzoned(zlen, zdec:byte; zptr:pointer):zoned;
+begin
+end;
+
+end.