+ a lot of vararray stuff

rtl/inc/compproc.inc

@@ -210,11 +210,14 @@ Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); comp
 {$endif HASWIDECHAR}
 
 {$ifdef HASVARIANT}
+procedure fpc_variant_copy(d,s : pointer);compilerproc;
 procedure fpc_write_text_variant(Len : Longint;var f : Text;const v : variant); compilerproc;
 function fpc_variant_to_dynarray(const v : variant;typeinfo : pointer) : pointer;compilerproc;
 function fpc_dynarray_to_variant(dynarr : pointer;typeinfo : pointer) : variant;compilerproc;
 function fpc_variant_to_interface(const v : variant) : iinterface;compilerproc;
 function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc;
+procedure fpc_vararray_get(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
+procedure fpc_vararray_put(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
 {$endif HASVARIANT}
 
 Procedure fpc_Read_End(var f:Text); compilerproc;
@@ -363,7 +366,10 @@ function fpc_qword_to_double(q: qword): double; compilerproc;
 
 {
   $Log$
-  Revision 1.66  2005-03-05 16:37:28  florian
+  Revision 1.67  2005-03-28 13:38:05  florian
+    + a lot of vararray stuff
+
+  Revision 1.66  2005/03/05 16:37:28  florian
     * fixed copy(dyn. array,...);
 
   Revision 1.65  2005/02/14 17:13:22  peter

rtl/inc/variant.inc

@@ -60,24 +60,43 @@ procedure variant_addref(var v : tvardata);[Public,Alias:'FPC_VARIANT_ADDREF'];
     if assigned(VarAddRefProc) then
       VarAddRefProc(v);
   end;
+  
+{ using pointers as argument here makes life for the compiler easier }  
+procedure fpc_variant_copy(d,s : pointer);compilerproc;
+  begin
+    if assigned(VarCopyProc) then
+      VarCopyProc(tvardata(d^),tvardata(s^));
+  end;
 
 
 Procedure fpc_write_text_variant(Len : Longint;var f : Text;const v : variant); iocheck; [Public,Alias:'FPC_WRITE_TEXT_VARIANT']; compilerproc;
-Begin
-  If (InOutRes<>0) then
-   exit;
-  case TextRec(f).mode of
-    { fmAppend gets changed to fmOutPut in do_open (JM) }
-    fmOutput:
-      if len=-1 then
-        variantmanager.write0variant(f,v)
-      else
-        variantmanager.writevariant(f,v,len);
-    fmInput:
-      InOutRes:=105
-    else InOutRes:=103;
+  begin
+    if (InOutRes<>0) then
+     exit;
+    case TextRec(f).mode of
+      { fmAppend gets changed to fmOutPut in do_open (JM) }
+      fmOutput:
+        if len=-1 then
+          variantmanager.write0variant(f,v)
+        else
+          variantmanager.writevariant(f,v,len);
+      fmInput:
+        InOutRes:=105
+      else InOutRes:=103;
+    end;
+  end;
+
+
+procedure fpc_vararray_get(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
+  begin
+    d:=variantmanager.vararrayget(s,len,indices);
+  end;
+  
+  
+procedure fpc_vararray_put(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
+  begin
+    variantmanager.vararrayput(d,s,len,indices);
   end;
-End;
 
 
 function fpc_variant_to_dynarray(const v : variant;typeinfo : pointer) : pointer;compilerproc;
@@ -594,7 +613,10 @@ procedure initvariantmanager;
 
 {
   $Log$
-  Revision 1.26  2005-03-25 19:02:59  florian
+  Revision 1.27  2005-03-28 13:38:05  florian
+    + a lot of vararray stuff
+
+  Revision 1.26  2005/03/25 19:02:59  florian
     + more vararray stuff
 
   Revision 1.25  2005/02/24 22:36:36  florian

rtl/inc/varianth.inc

@@ -174,9 +174,9 @@ type
         calldesc : pcalldesc;params : pointer);cdecl;
 
       vararrayredim : procedure(var a : variant;highbound : SizeInt);
-      vararrayget : function(var a : variant;indexcount : SizeInt;indices : SizeInt) : variant;cdecl;
+      vararrayget : function(const a : variant;indexcount : SizeInt;indices : PSizeInt) : variant;cdecl;
       vararrayput: procedure(var a : variant; const value : variant;
-        indexcount : SizeInt;indices : SizeInt);cdecl;
+        indexcount : SizeInt;indices : PSizeInt);cdecl;
       writevariant : function(var t : text;const v : variant;width : longint) : Pointer;
       write0Variant : function(var t : text;const v : Variant) : Pointer;
    end;
@@ -318,7 +318,10 @@ operator <=(const op1,op2 : variant) dest : boolean;
 
 {
   $Log$
-  Revision 1.20  2005-03-25 19:02:59  florian
+  Revision 1.21  2005-03-28 13:38:05  florian
+    + a lot of vararray stuff
+
+  Revision 1.20  2005/03/25 19:02:59  florian
     + more vararray stuff
 
   Revision 1.19  2005/03/25 18:03:50  florian

rtl/objpas/sysconst.pp

@@ -90,6 +90,7 @@ resourcestring
   SVarArrayLocked        = 'Variant array locked';
   SVarBadType            = 'Invalid variant type';
   SVarInvalid            = 'Invalid argument';
+  SVarInvalid1           = 'Invalid argument: %s';
   SVarNotArray           = 'Variant doesn''t contain an array';
   SVarNotImplemented     = 'Operation not supported';
   SVarOutOfMemory        = 'Variant operation ran out memory';
@@ -222,7 +223,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.16  2005-03-17 16:29:04  peter
+  Revision 1.17  2005-03-28 13:38:05  florian
+    + a lot of vararray stuff
+
+  Revision 1.16  2005/03/17 16:29:04  peter
     * fixed str() call
 
   Revision 1.15  2005/02/14 17:13:31  peter

rtl/objpas/varutils.inc

@@ -278,16 +278,16 @@ begin
 end;
 
 type
-  TVariantArrayType = (vatNormal, varInterface, varWideString);
+  TVariantArrayType = (vatNormal, vatInterface, vatWideString);
 
 Function VariantArrayType(psa: PVarArray): TVariantArrayType;
 
 begin
   if ((psa^.Flags and ARR_DISPATCH) <> 0) or
      ((psa^.Flags and ARR_UNKNOWN) <> 0) then
-    Result:=varInterface
+    Result:=vatInterface
   else if (psa^.Flags AND ARR_OLESTR) <> 0 then
-    Result:=varWideString
+    Result:=vatWideString
   else
     Result:=vatNormal;
 end;
@@ -304,8 +304,8 @@ begin
       vatNormal     : FillChar(psa^.Data^,
                          SafeArrayElementTotal(psa)*psa^.ElementSize,
                          0);
-      varInterface  : NoInterfaces;
-      varWideString : NoWidestrings;
+      vatInterface  : NoInterfaces;
+      vatWideString : NoWidestrings;
     end;
     Result:=VAR_OK;
   except
@@ -325,8 +325,8 @@ begin
       vatNormal: Move(psa^.Data^,
                       psaOut^.Data^,
                       SafeArrayElementTotal(psa)*psa^.ElementSize);
-      varInterface : NoInterfaces; // Copy element per element...
-      varWideString: NoWideStrings; // here also...
+      vatInterface : NoInterfaces; // Copy element per element...
+      vatWideString: NoWideStrings; // here also...
     end;
     Result:=VAR_OK;
   except
@@ -651,6 +651,7 @@ begin
     end;
 end;
 
+
 Function SafeArrayGetElement(psa: PVarArray; Indices: PVarArrayCoorArray;
   Data: Pointer): HRESULT;stdcall;
 var
@@ -675,6 +676,7 @@ begin
   SetUnlockResult(psa,Result);
 end;
 
+
 Function SafeArrayPutElement(psa: PVarArray; Indices: PVarArrayCoorArray;
   const Data: Pointer): HRESULT;stdcall;
 var
@@ -685,8 +687,9 @@ begin
     exit;
   try
     case VariantArrayType(psa) of
-      vatNormal: Move(Data^,P^,psa^.ElementSize);
-      varInterface: NoInterfaces;
+      vatNormal: 
+        Move(Data^,P^,psa^.ElementSize);
+      varInterface: 
       varWideString: NoWideStrings;
     end;
   except
@@ -696,12 +699,14 @@ begin
   SetUnlockResult(psa,Result);
 end;
 
+
 Function SafeArrayPtrOfIndex(psa: PVarArray; Indices: PVarArrayCoorArray;
   var Address: Pointer): HRESULT;stdcall;
 begin
   Result:=CheckVarArrayAndCalculateAddress(psa,Indices,Address,False);
 end;
 
+
 Function SafeArrayGetElemSize(psa: PVarArray): LongWord;stdcall;
 begin
   if CheckVarArray(psa)<>VAR_OK then
@@ -713,7 +718,10 @@ end;
 {$endif HASVARIANT}
 {
   $Log$
-  Revision 1.21  2005-02-25 14:39:31  peter
+  Revision 1.22  2005-03-28 13:38:05  florian
+    + a lot of vararray stuff
+
+  Revision 1.21  2005/02/25 14:39:31  peter
     * 64bit fixes
 
   Revision 1.20  2005/02/24 22:36:36  florian