* cleaned up set conversion

* fixed conversion of var sets

git-svn-id: trunk@6644 -

compiler/defcmp.pas

@@ -64,13 +64,12 @@ interface
           tc_real_2_currency,
           tc_proc_2_procvar,
           tc_arrayconstructor_2_set,
-          tc_load_smallset,
+          tc_set_to_set,
           tc_cord_2_pointer,
           tc_intf_2_string,
           tc_intf_2_guid,
           tc_class_2_intf,
           tc_char_2_char,
-          tc_normal_2_smallset,
           tc_dynarray_2_openarray,
           tc_pwchar_2_string,
           tc_variant_2_dynarray,
@@ -1060,13 +1059,23 @@ implementation
                      if assigned(tsetdef(def_from).elementdef) and
                         assigned(tsetdef(def_to).elementdef) then
                       begin
-                        { sets with the same element base type are equal }
+                        { sets with the same element base type and the same range are equal }
-                        if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
+                        if equal_defs(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) and
-                         eq:=te_equal;
+                          (tsetdef(def_from).setbase=tsetdef(def_to).setbase) and
+                          (tsetdef(def_from).setmax=tsetdef(def_to).setmax) then
+                          eq:=te_equal
+                        else if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
+                          begin
+                            eq:=te_convert_l1;
+                            doconv:=tc_set_to_set;
+                          end;
                       end
                      else
+                      begin
                         { empty set is compatible with everything }
-                      eq:=te_equal;
+                        eq:=te_convert_l1;
+                        doconv:=tc_set_to_set;
+                      end;
                    end;
                  arraydef :
                    begin

compiler/nadd.pas

@@ -1083,7 +1083,7 @@ implementation
                if (rt=setelementn) then
                  begin
                    if not(equal_defs(tsetdef(ld).elementdef,rd)) then
-                   CGMessage(type_e_set_element_are_not_comp);
+                     inserttypeconv(right,tsetdef(ld).elementdef);
                  end
                else
                  CGMessage(type_e_mismatch)
@@ -1092,33 +1092,18 @@ implementation
              begin
                if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
                 CGMessage(type_e_set_operation_unknown);
-               { right def must be a also be set }
-               if (rd.typ<>setdef) or not(equal_defs(rd,ld)) then
-                CGMessage(type_e_set_element_are_not_comp);
-             end;
-
-            { ranges require normsets }
-            if (tsetdef(ld).settype=smallset) and
-               (rt=setelementn) and
-               assigned(tsetelementnode(right).right) then
-             begin
-               { generate a temporary normset def, it'll be destroyed
-                 when the symtable is unloaded }
-               inserttypeconv(left,tsetdef.create(tsetdef(ld).elementdef,255));
-             end;
-
                { if the right side is also a setdef then the settype must
                  be the same as the left setdef }
                if (rd.typ=setdef) and
-               (tsetdef(ld).settype<>tsetdef(rd).settype) then
+                  not(equal_defs(ld,rd)) then
                 begin
-               { when right is a normset we need to typecast both
+                  if is_varset(rd) then
-                 to normsets }
-               if (tsetdef(rd).settype=normset) then
                     inserttypeconv(left,right.resultdef)
                   else
                     inserttypeconv(right,left.resultdef);
                 end;
+             end;
+
           end
          { pointer comparision and subtraction }
          else if (
@@ -2286,6 +2271,8 @@ implementation
 {$endif addstringopt}
          lt,rt   : tnodetype;
          rd,ld   : tdef;
+         newstatement : tstatementnode;
+         temp    : ttempcreatenode;
       begin
          result:=nil;
 
@@ -2423,7 +2410,7 @@ implementation
            else array constructor can be seen as array of char (PFV) }
          else if (ld.typ=setdef) then
            begin
-             if tsetdef(ld).settype=smallset then
+             if not(is_varset(ld)) then
                begin
                  if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
                    expectloc:=LOC_FLAGS
@@ -2431,7 +2418,47 @@ implementation
                    expectloc:=LOC_REGISTER;
                  { are we adding set elements ? }
                  if right.nodetype=setelementn then
+                   begin
+                     { add range?
+                       the smallset code can't handle set ranges }
+                     if assigned(tsetelementnode(right).right) then
+                       begin
+                         result:=internalstatements(newstatement);
+
+                         { create temp for result }
+                         temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
+                         addstatement(newstatement,temp);
+
+                         { add a range or a single element? }
+                         if assigned(tsetelementnode(right).right) then
+                           addstatement(newstatement,ccallnode.createintern('fpc_varset_set_range',
+                             ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
+                             ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).right,sinttype),
+                             ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).left,sinttype),
+                             ccallparanode.create(ctemprefnode.create(temp),
+                             ccallparanode.create(left,nil))))))
+                           )
+                         else
+                           addstatement(newstatement,ccallnode.createintern('fpc_varset_set',
+                             ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
+                             ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).left,sinttype),
+                             ccallparanode.create(ctemprefnode.create(temp),
+                             ccallparanode.create(left,nil)))))
+                           );
+                         { remove reused parts from original node }
+                         tsetelementnode(right).right:=nil;
+                         tsetelementnode(right).left:=nil;
+                         left:=nil;
+                         { the last statement should return the value as
+                           location and type, this is done be referencing the
+                           temp and converting it first from a persistent temp to
+                           normal temp }
+                         addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
+                         addstatement(newstatement,ctemprefnode.create(temp));
+                       end
+                     else
                        calcregisters(self,2,0,0)
+                   end
                  else
                    calcregisters(self,1,0,0);
                end

compiler/ncgcon.pas

@@ -524,9 +524,9 @@ implementation
         else
           indexadjust := 3;
         { small sets are loaded as constants }
-        if tsetdef(resultdef).settype=smallset then
+        if not(is_varset(resultdef)) then
          begin
-           location_reset(location,LOC_CONSTANT,OS_32);
+           location_reset(location,LOC_CONSTANT,int_cgsize(resultdef.size));
            location.value:=pLongint(value_set)^;
            exit;
          end;

compiler/ncnv.pas

@@ -70,6 +70,7 @@ interface
           function typecheck_cstring_to_int : tnode;
           function typecheck_char_to_char : tnode;
           function typecheck_arrayconstructor_to_set : tnode;
+          function typecheck_set_to_set : tnode;
           function typecheck_pchar_to_string : tnode;
           function typecheck_interface_to_guid : tnode;
           function typecheck_dynarray_to_openarray : tnode;
@@ -99,7 +100,7 @@ interface
           function first_int_to_bool : tnode;virtual;
           function first_bool_to_bool : tnode;virtual;
           function first_proc_to_procvar : tnode;virtual;
-          function first_load_smallset : tnode;virtual;
+          function first_set_to_set : tnode;virtual;
           function first_cord_to_pointer : tnode;virtual;
           function first_ansistring_to_pchar : tnode;virtual;
           function first_arrayconstructor_to_set : tnode;virtual;
@@ -125,12 +126,12 @@ interface
           function _first_int_to_bool : tnode;
           function _first_bool_to_bool : tnode;
           function _first_proc_to_procvar : tnode;
-          function _first_load_smallset : tnode;
           function _first_cord_to_pointer : tnode;
           function _first_ansistring_to_pchar : tnode;
           function _first_arrayconstructor_to_set : tnode;
           function _first_class_to_intf : tnode;
           function _first_char_to_char : tnode;
+          function _first_set_to_set : tnode;
 
           procedure _second_int_to_int;virtual;
           procedure _second_string_to_string;virtual;
@@ -148,7 +149,7 @@ interface
           procedure _second_bool_to_int;virtual;
           procedure _second_int_to_bool;virtual;
           procedure _second_bool_to_bool;virtual;
-          procedure _second_load_smallset;virtual;
+          procedure _second_set_to_set;virtual;
           procedure _second_ansistring_to_pchar;virtual;
           procedure _second_class_to_intf;virtual;
           procedure _second_char_to_char;virtual;
@@ -170,7 +171,7 @@ interface
           procedure second_bool_to_int;virtual;abstract;
           procedure second_int_to_bool;virtual;abstract;
           procedure second_bool_to_bool;virtual;abstract;
-          procedure second_load_smallset;virtual;abstract;
+          procedure second_set_to_set;virtual;abstract;
           procedure second_ansistring_to_pchar;virtual;abstract;
           procedure second_class_to_intf;virtual;abstract;
           procedure second_char_to_char;virtual;abstract;
@@ -703,13 +704,12 @@ implementation
           'tc_real_2_currency',
           'tc_proc_2_procvar',
           'tc_arrayconstructor_2_set',
-          'tc_load_smallset',
+          'tc_set_2_set',
           'tc_cord_2_pointer',
           'tc_intf_2_string',
           'tc_intf_2_guid',
           'tc_class_2_intf',
           'tc_char_2_char',
-          'tc_normal_2_smallset',
           'tc_dynarray_2_openarray',
           'tc_pwchar_2_string',
           'tc_variant_2_dynarray',
@@ -1135,10 +1135,8 @@ implementation
 
 
     function ttypeconvnode.typecheck_arrayconstructor_to_set : tnode;
-
       var
         hp : tnode;
-
       begin
         result:=nil;
         if left.nodetype<>arrayconstructorn then
@@ -1152,8 +1150,29 @@ implementation
       end;
 
 
-    function ttypeconvnode.typecheck_pchar_to_string : tnode;
+    function ttypeconvnode.typecheck_set_to_set : tnode;
+      begin
+        result:=nil;
+        { because is_equal only checks the basetype for sets we need to
+          check here if we are loading a smallset into a normalset }
+        if (resultdef.typ=setdef) and
+           (left.resultdef.typ=setdef) and
+           ((tsetdef(resultdef).setmax<>tsetdef(left.resultdef).setmax) or
+            (tsetdef(resultdef).setbase<>tsetdef(left.resultdef).setbase)) then
+          begin
+            { constant sets can be converted by changing the type only }
+            if (left.nodetype=setconstn) then
+             begin
+               left.resultdef:=resultdef;
+               result:=left;
+               left:=nil;
+               exit;
+             end;
+          end;
+      end;
 
+
+    function ttypeconvnode.typecheck_pchar_to_string : tnode;
       begin
         result := ccallnode.createinternres(
           'fpc_pchar_to_'+tstringdef(resultdef).stringtypname,
@@ -1163,7 +1182,6 @@ implementation
 
 
     function ttypeconvnode.typecheck_interface_to_guid : tnode;
-
       begin
         if assigned(tobjectdef(left.resultdef).iidguid) then
           result:=cguidconstnode.create(tobjectdef(left.resultdef).iidguid^);
@@ -1171,7 +1189,6 @@ implementation
 
 
     function ttypeconvnode.typecheck_dynarray_to_openarray : tnode;
-
       begin
         { a dynamic array is a pointer to an array, so to convert it to }
         { an open array, we have to dereference it (JM)                 }
@@ -1186,7 +1203,6 @@ implementation
 
 
     function ttypeconvnode.typecheck_pwchar_to_string : tnode;
-
       begin
         result := ccallnode.createinternres(
           'fpc_pwidechar_to_'+tstringdef(resultdef).stringtypname,
@@ -1196,7 +1212,6 @@ implementation
 
 
     function ttypeconvnode.typecheck_variant_to_dynarray : tnode;
-
       begin
         result := ccallnode.createinternres(
           'fpc_variant_to_dynarray',
@@ -1209,7 +1224,6 @@ implementation
 
 
     function ttypeconvnode.typecheck_dynarray_to_variant : tnode;
-
       begin
         result := ccallnode.createinternres(
           'fpc_dynarray_to_variant',
@@ -1411,13 +1425,12 @@ implementation
           { real_2_currency } @ttypeconvnode.typecheck_real_to_currency,
           { proc_2_procvar } @ttypeconvnode.typecheck_proc_to_procvar,
           { arrayconstructor_2_set } @ttypeconvnode.typecheck_arrayconstructor_to_set,
-          { load_smallset } nil,
+          { set_to_set } @ttypeconvnode.typecheck_set_to_set,
           { cord_2_pointer } @ttypeconvnode.typecheck_cord_to_pointer,
           { intf_2_string } nil,
           { intf_2_guid } @ttypeconvnode.typecheck_interface_to_guid,
           { class_2_intf } nil,
           { char_2_char } @ttypeconvnode.typecheck_char_to_char,
-          { normal_2_smallset} nil,
           { dynarray_2_openarray} @ttypeconvnode.typecheck_dynarray_to_openarray,
           { pwchar_2_string} @ttypeconvnode.typecheck_pwchar_to_string,
           { variant_2_dynarray} @ttypeconvnode.typecheck_variant_to_dynarray,
@@ -1508,30 +1521,6 @@ implementation
                   if assigned(result) then
                     exit;
 
-                  { because is_equal only checks the basetype for sets we need to
-                    check here if we are loading a smallset into a normalset }
-                  if (resultdef.typ=setdef) and
-                     (left.resultdef.typ=setdef) and
-                     ((tsetdef(resultdef).settype = smallset) xor
-                      (tsetdef(left.resultdef).settype = smallset)) then
-                    begin
-                      { constant sets can be converted by changing the type only }
-                      if (left.nodetype=setconstn) then
-                       begin
-                         left.resultdef:=resultdef;
-                         result:=left;
-                         left:=nil;
-                         exit;
-                       end;
-
-                      if (tsetdef(resultdef).settype <> smallset) then
-                       convtype:=tc_load_smallset
-                      else
-                       convtype := tc_normal_2_smallset;
-                      exit;
-                    end
-                  else
-                   begin
                   { Only leave when there is no conversion to do.
                     We can still need to call a conversion routine,
                     like the routine to convert a stringconstnode }
@@ -1545,7 +1534,6 @@ implementation
                      exit;
                    end;
                 end;
-                end;
 
               te_convert_l1,
               te_convert_l2,
@@ -1888,7 +1876,6 @@ implementation
 
 
     procedure Ttypeconvnode.mark_write;
-
       begin
         left.mark_write;
       end;
@@ -2245,21 +2232,26 @@ implementation
       end;
 
 
-    function ttypeconvnode.first_load_smallset : tnode;
+    function ttypeconvnode.first_set_to_set : tnode;
       var
         srsym: ttypesym;
         newstatement : tstatementnode;
         temp    : ttempcreatenode;
       begin
-        { old small set code }
+        { in theory, we should do range checking here,
-        if left.resultdef.size=4 then
+          but Delphi doesn't do it either (FK) }
+
+        if left.nodetype=setconstn then
           begin
-            srsym:=search_system_type('FPC_SMALL_SET');
+            left.resultdef:=resultdef;
-            result :=
+            result:=left;
-              ccallnode.createinternres('fpc_set_load_small',
-                ccallparanode.create(ctypeconvnode.create_internal(left,srsym.typedef),nil),resultdef);
           end
+        { equal sets for the code generator? }
+        else if (left.resultdef.size=resultdef.size) and
+          (tsetdef(left.resultdef).setbase=tsetdef(resultdef).setbase) then
+          result:=left
         else
+        // if is_varset(resultdef) then
           begin
             result:=internalstatements(newstatement);
 
@@ -2276,13 +2268,21 @@ implementation
             addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
             addstatement(newstatement,ctemprefnode.create(temp));
           end;
+        {
+        else
+          begin
+            srsym:=search_system_type('FPC_SMALL_SET');
+            result :=
+              ccallnode.createinternres('fpc_set_load_small',
+                ccallparanode.create(ctypeconvnode.create_internal(left,srsym.typedef),nil),resultdef);
+          end;
+        }
         { reused }
         left:=nil;
       end;
 
 
     function ttypeconvnode.first_ansistring_to_pchar : tnode;
-
       begin
          first_ansistring_to_pchar:=nil;
          expectloc:=LOC_REGISTER;
@@ -2297,8 +2297,8 @@ implementation
         internalerror(200104022);
       end;
 
-    function ttypeconvnode.first_class_to_intf : tnode;
 
+    function ttypeconvnode.first_class_to_intf : tnode;
       begin
          first_class_to_intf:=nil;
          expectloc:=LOC_REGISTER;
@@ -2381,9 +2381,9 @@ implementation
          result:=first_proc_to_procvar;
       end;
 
-    function ttypeconvnode._first_load_smallset : tnode;
+    function ttypeconvnode._first_set_to_set : tnode;
       begin
-         result:=first_load_smallset;
+         result:=first_set_to_set;
       end;
 
     function ttypeconvnode._first_cord_to_pointer : tnode;
@@ -2439,7 +2439,7 @@ implementation
            nil, { removed in typecheck_real_to_currency }
            @ttypeconvnode._first_proc_to_procvar,
            @ttypeconvnode._first_arrayconstructor_to_set,
-           @ttypeconvnode._first_load_smallset,
+           @ttypeconvnode._first_set_to_set,
            @ttypeconvnode._first_cord_to_pointer,
            @ttypeconvnode._first_nothing,
            @ttypeconvnode._first_nothing,
@@ -2453,18 +2453,15 @@ implementation
            nil,
            nil,
            nil,
-           nil,
            nil
          );
       type
          tprocedureofobject = function : tnode of object;
-
       var
          r : packed record
                 proc : pointer;
                 obj : pointer;
              end;
-
       begin
          { this is a little bit dirty but it works }
          { and should be quite portable too        }
@@ -2626,9 +2623,10 @@ implementation
         second_bool_to_bool;
       end;
 
-    procedure ttypeconvnode._second_load_smallset;
+
+    procedure ttypeconvnode._second_set_to_set;
       begin
-        second_load_smallset;
+        second_set_to_set;
       end;
 
 
@@ -2683,13 +2681,12 @@ implementation
            @ttypeconvnode._second_nothing, { real_to_currency, handled in resultdef pass }
            @ttypeconvnode._second_proc_to_procvar,
            @ttypeconvnode._second_nothing, { arrayconstructor_to_set }
-           @ttypeconvnode._second_nothing, { second_load_smallset, handled in first pass }
+           @ttypeconvnode._second_nothing, { second_set_to_set, handled in first pass }
            @ttypeconvnode._second_cord_to_pointer,
            @ttypeconvnode._second_nothing, { interface 2 string }
            @ttypeconvnode._second_nothing, { interface 2 guid   }
            @ttypeconvnode._second_class_to_intf,
            @ttypeconvnode._second_char_to_char,
-           @ttypeconvnode._second_nothing,  { normal_2_smallset }
            @ttypeconvnode._second_nothing,  { dynarray_2_openarray }
            @ttypeconvnode._second_nothing,  { pwchar_2_string }
            @ttypeconvnode._second_nothing,  { variant_2_dynarray }
@@ -2901,7 +2898,6 @@ implementation
 
 
     function tasnode.dogetcopy: tnode;
-
       begin
         result := inherited dogetcopy;
         if assigned(call) then
@@ -2912,7 +2908,6 @@ implementation
 
 
     function tasnode.pass_1 : tnode;
-
       var
         procname: string;
       begin

compiler/powerpc/nppccnv.pas

@@ -46,7 +46,7 @@ interface
          { procedure second_proc_to_procvar;override; }
          { procedure second_bool_to_int;override; }
          { procedure second_int_to_bool;override; }
-         { procedure second_load_smallset;override;  }
+         { procedure second_set_to_set;override;  }
          { procedure second_ansistring_to_pchar;override; }
          { procedure second_pchar_to_string;override; }
          { procedure second_class_to_intf;override; }

compiler/symdef.pas

@@ -2006,7 +2006,7 @@ implementation
       begin
          inherited create(setdef);
          elementdef:=def;
-         // setbase:=low;
+         setbase:=0;
          setmax:=high;
          if high<32 then
            begin

compiler/x86/nx86cnv.pas

@@ -47,7 +47,7 @@ interface
          { procedure second_proc_to_procvar;override; }
          { procedure second_bool_to_int;override; }
            procedure second_int_to_bool;override;
-         { procedure second_load_smallset;override;  }
+         { procedure second_set_to_set;override;  }
          { procedure second_ansistring_to_pchar;override; }
          { procedure second_pchar_to_string;override; }
          { procedure second_class_to_intf;override;  }

rtl/inc/genset.inc

@@ -211,10 +211,12 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
 
 {$ifndef FPC_SYSTEM_HAS_FPC_VARSET_LOAD_SMALL}
 {
-  load a normal set p from a smallset l
+  convert sets
 }
 procedure fpc_varset_load(const l;sourcesize : longint;var dest;size : ptrint); compilerproc;
   begin
+    if sourcesize>size then
+      sourcesize:=size;
     move(l,plongint(@dest)^,sourcesize);
     FillChar((@dest+sourcesize)^,size-sourcesize,0);
   end;