* support for array constructors extended and more error checking

compiler/cg386ld.pas

@@ -829,16 +829,27 @@ implementation
         lt    : pdef;
         vaddr : boolean;
         vtype : longint;
+        dovariant : boolean;
+        elesize : longint;
       begin
+        dovariant:=parraydef(p^.resulttype)^.isvariant;
+        if dovariant then
+         elesize:=8
+        else
+         begin
+           elesize:=parraydef(p^.resulttype)^.elesize;
+           if elesize>4 then
+            internalerror(8765678);
+         end;
         if not p^.cargs then
          begin
            reset_reference(p^.location.reference);
            { Allocate always a temp, also if no elements are required, to
-             ensure that location is valid (PFV) }
+             be sure that location is valid (PFV) }
             if parraydef(p^.resulttype)^.highrange=-1 then
-              gettempofsizereference(8,p^.location.reference)
+              gettempofsizereference(elesize,p^.location.reference)
             else
-              gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference);
+              gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*elesize,p^.location.reference);
            href:=p^.location.reference;
          end;
         hp:=p;
@@ -849,83 +860,101 @@ implementation
               secondpass(hp^.left);
               if codegenerror then
                exit;
-              { find the correct vtype value }
-              vtype:=$ff;
-              vaddr:=false;
-              lt:=hp^.left^.resulttype;
-              case lt^.deftype of
-                enumdef,
-                orddef :
-                  begin
-                    if (lt^.deftype=enumdef) or
-                       is_integer(lt) then
-                      vtype:=vtInteger
-                    else
-                      if is_boolean(lt) then
-                        vtype:=vtBoolean
-                      else
-                        if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
-                          vtype:=vtChar;
-                  end;
-                floatdef :
-                  begin
-                    vtype:=vtExtended;
-                    vaddr:=true;
-                  end;
-                procvardef,
-                pointerdef :
+              if dovariant then
+               begin
+                 { find the correct vtype value }
+                 vtype:=$ff;
+                 vaddr:=false;
+                 lt:=hp^.left^.resulttype;
+                 case lt^.deftype of
+                   enumdef,
+                   orddef :
+                     begin
+                       if (lt^.deftype=enumdef) or
+                          is_integer(lt) then
+                         vtype:=vtInteger
+                       else
+                         if is_boolean(lt) then
+                           vtype:=vtBoolean
+                         else
+                           if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
+                             vtype:=vtChar;
+                     end;
+                   floatdef :
+                     begin
+                       vtype:=vtExtended;
+                       vaddr:=true;
+                     end;
+                   procvardef,
+                   pointerdef :
+                     begin
+                       if is_pchar(lt) then
+                         vtype:=vtPChar
+                       else
+                         vtype:=vtPointer;
+                     end;
+                   classrefdef :
+                     vtype:=vtClass;
+                   objectdef :
+                     begin
+                       vtype:=vtObject;
+                     end;
+                   stringdef :
+                     begin
+                       if is_shortstring(lt) then
+                        begin
+                          vtype:=vtString;
+                          vaddr:=true;
+                        end
+                       else
+                        if is_ansistring(lt) then
+                         vtype:=vtAnsiString;
+                     end;
+                 end;
+                 if vtype=$ff then
+                   internalerror(14357);
+                 { write C style pushes or an pascal array }
+                 if p^.cargs then
                   begin
-                    if is_pchar(lt) then
-                      vtype:=vtPChar
+                    if vaddr then
+                     begin
+                       emit_to_reference(hp^.left);
+                       emit_push_lea_loc(hp^.left^.location);
+                     end
                     else
-                      vtype:=vtPointer;
-                  end;
-                classrefdef :
-                  vtype:=vtClass;
-                objectdef :
-                  begin
-                    vtype:=vtObject;
-                  end;
-                stringdef :
+                     emit_push_loc(hp^.left^.location);
+                  end
+                 else
                   begin
-                    if is_shortstring(lt) then
+                    { update href to the vtype field and write it }
+                    exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
+                      vtype,newreference(href))));
+                    inc(href.offset,4);
+                    { write changing field update href to the next element }
+                    if vaddr then
                      begin
-                       vtype:=vtString;
-                       vaddr:=true;
+                       emit_to_reference(hp^.left);
+                       emit_lea_loc_ref(hp^.left^.location,href);
                      end
                     else
-                     if is_ansistring(lt) then
-                      vtype:=vtAnsiString;
+                     emit_mov_loc_ref(hp^.left^.location,href,S_L);
+                    inc(href.offset,4);
                   end;
-              end;
-              if vtype=$ff then
-                internalerror(14357);
-              { write C style pushes or an pascal array }
-              if p^.cargs then
-               begin
-                 if vaddr then
-                  begin
-                    emit_to_reference(hp^.left);
-                    emit_push_lea_loc(hp^.left^.location);
-                  end
-                 else
-                  emit_push_loc(hp^.left^.location);
                end
               else
+              { normal array constructor of the same type }
                begin
-                 { update href to the vtype field and write it }
-                 exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
-                   vtype,newreference(href))));
-                 inc(href.offset,4);
-                 { write changing field update href to the next element }
-                 if vaddr then
-                  begin
-                    emit_to_reference(hp^.left);
-                    emit_lea_loc_ref(hp^.left^.location,href);
-                  end
-                 else
-                  emit_mov_loc_ref(hp^.left^.location,href);
-                 inc(href.offset,4);
+                 case elesize of
+                   1 :
+                     emit_mov_loc_ref(hp^.left^.location,href,S_B);
+                   2 :
+                     emit_mov_loc_ref(hp^.left^.location,href,S_W);
+                   4 :
+                     emit_mov_loc_ref(hp^.left^.location,href,S_L);
+                   else
+                     internalerror(87656781);
+                 end;
+                 inc(href.offset,elesize);
                end;
             end;
            { load next entry }
@@ -937,7 +966,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.72  1999-08-09 22:19:50  peter
+  Revision 1.73  1999-08-13 21:33:09  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.72  1999/08/09 22:19:50  peter
     * classes vmt changed to only positive addresses
     * sharedlib creation is working
 

compiler/symdef.inc

@@ -1836,7 +1836,7 @@
       begin
         {Tarraydef.size may never be called for an open array!}
         if highrange<lowrange then
-            internalerror($99080501);
+            internalerror(99080501);
         If (highrange-lowrange = $7fffffff) or
            { () are needed around elesize-1 to avoid a possible
              integer overflow for elesize=1 !! PM }
@@ -1884,7 +1884,12 @@
 
       begin
          if isarrayofconst or isConstructor then
-           gettypename:='Array Of Const'
+           begin
+             if isvariant then
+               gettypename:='Array Of Const'
+             else
+               gettypename:='Array Of '+definition^.typename;
+           end
          else if is_open_array(@self) then
            gettypename:='Array Of '+definition^.typename
          else
@@ -3710,7 +3715,10 @@ Const local_symtable_index : longint = $8001;
 
 {
   $Log$
-  Revision 1.152  1999-08-13 14:24:18  pierre
+  Revision 1.153  1999-08-13 21:33:11  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.152  1999/08/13 14:24:18  pierre
     + stabs for classes and classref working,
       a class still needs an ^ to get that content of it,
       but the class fields inside a class don't result into an

compiler/symppu.inc

@@ -233,8 +233,6 @@
        { create unit flags }
          with Current_Module^ do
           begin
-            if cs_smartlink in aktmoduleswitches then
-             flags:=flags or uf_smart_linked;
 {$ifdef GDB}
             if cs_gdb_dbx in aktglobalswitches then
              flags:=flags or uf_has_dbx;
@@ -606,7 +604,10 @@
 
 {
   $Log$
-  Revision 1.45  1999-08-03 22:03:17  peter
+  Revision 1.46  1999-08-13 21:33:12  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.45  1999/08/03 22:03:17  peter
     * moved bitmask constants to sets
     * some other type/const renamings
 

compiler/symtable.pas

@@ -2175,6 +2175,7 @@ implementation
         search_default_property:=_defaultprop;
      end;
 
+
 {****************************************************************************
                                Macro's
 ****************************************************************************}
@@ -2347,7 +2348,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.41  1999-08-13 14:24:22  pierre
+  Revision 1.42  1999-08-13 21:33:13  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.41  1999/08/13 14:24:22  pierre
     + stabs for classes and classref working,
       a class still needs an ^ to get that content of it,
       but the class fields inside a class don't result into an

compiler/tccal.pas

@@ -242,12 +242,17 @@ implementation
                           CGMessage(parser_e_call_by_ref_without_typeconv);
                        end;
                    { process cargs arrayconstructor }
-                   if is_array_constructor(p^.left^.resulttype) and
-                      assigned(aktcallprocsym) and
-                      (pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and
-                      (po_external in aktcallprocsym^.definition^.procoptions) then
+                   if is_array_constructor(p^.left^.resulttype) then
                     begin
-                      p^.left^.cargs:=true;
+                      if is_array_of_const(defcoll^.data) then
+                       begin
+                         if assigned(aktcallprocsym) and
+                            (pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and
+                            (po_external in aktcallprocsym^.definition^.procoptions) then
+                           p^.left^.cargs:=true;
+                       end
+                      else
+                       p^.left^.novariaallowed:=true;
                       old_array_constructor:=allow_array_constructor;
                       allow_array_constructor:=true;
                       firstpass(p^.left);
@@ -1198,7 +1203,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.58  1999-08-12 14:34:28  peter
+  Revision 1.59  1999-08-13 21:33:16  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.58  1999/08/12 14:34:28  peter
     * tp_procvar mode call->loadn fixed
 
   Revision 1.57  1999/08/05 16:53:19  peter

compiler/tcld.pas

@@ -389,7 +389,7 @@ implementation
            while assigned(hp) do
             begin
               firstpass(hp^.left);
-              if not get_para_resulttype then
+              if (not get_para_resulttype) and (not p^.novariaallowed) then
                begin
                  case hp^.left^.resulttype^.deftype of
                    enumdef :
@@ -426,8 +426,15 @@ implementation
               if (pd=nil) then
                pd:=hp^.left^.resulttype
               else
-               if (not varia) and (not is_equal(pd,hp^.left^.resulttype)) then
-                varia:=true;
+               begin
+                 if ((p^.novariaallowed) or (not varia)) and
+                    (not is_equal(pd,hp^.left^.resulttype)) then
+                  begin
+                    if p^.novariaallowed then
+                     CGMessage2(type_e_incompatible_types,hp^.left^.resulttype^.typename,pd^.typename);
+                    varia:=true;
+                  end;
+               end;
               inc(len);
               hp:=hp^.right;
             end;
@@ -480,7 +487,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.39  1999-08-05 16:53:24  peter
+  Revision 1.40  1999-08-13 21:33:17  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.39  1999/08/05 16:53:24  peter
     * V_Fatal=1, all other V_ are also increased
     * Check for local procedure when assigning procvar
     * fixed comment parsing because directives

compiler/tree.pas

@@ -231,7 +231,7 @@ unit tree;
              labeln,goton : (labelnr : pasmlabel);
              withn : (withsymtable : pwithsymtable;tablecount : longint;withreference:preference;islocal:boolean);
              onn : (exceptsymtable : psymtable;excepttype : pobjectdef);
-             arrayconstructn : (cargs,cargswap: boolean);
+             arrayconstructn : (cargs,cargswap,novariaallowed: boolean);
            end;
 
     function gennode(t : ttreetyp;l,r : ptree) : ptree;
@@ -1739,7 +1739,10 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.87  1999-08-09 22:14:46  peter
+  Revision 1.88  1999-08-13 21:33:18  peter
+    * support for array constructors extended and more error checking
+
+  Revision 1.87  1999/08/09 22:14:46  peter
     * fixed disposing of tree node
 
   Revision 1.86  1999/08/04 00:23:49  florian