Browse Source

* pass dyn. arrays in registers when i386 register calling conventions are used

git-svn-id: trunk@30870 -
florian 10 years ago
parent
commit
956883b0c7
4 changed files with 80 additions and 3 deletions
  1. 1 0
      .gitattributes
  2. 2 1
      compiler/i386/cpupara.pas
  3. 75 0
      tests/tbs/tb0610.pp
  4. 2 2
      tests/webtbs/tw20075.pp

+ 1 - 0
.gitattributes

@@ -10540,6 +10540,7 @@ tests/tbs/tb0606.pp svneol=native#text/pascal
 tests/tbs/tb0607.pp svneol=native#text/plain
 tests/tbs/tb0608.pp svneol=native#text/pascal
 tests/tbs/tb0609.pp svneol=native#text/plain
+tests/tbs/tb0610.pp svneol=native#text/pascal
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tbs0594.pp svneol=native#text/pascal

+ 2 - 1
compiler/i386/cpupara.pas

@@ -601,7 +601,8 @@ unit cpupara;
                     if (parareg<=high(parasupregs)) and
                        (paralen<=sizeof(aint)) and
                        (not(hp.vardef.typ in [floatdef,recorddef,arraydef]) or
-                        pushaddr) and
+                        pushaddr or
+                        is_dynamic_array(hp.vardef)) and
                        (not(vo_is_parentfp in hp.varoptions) or
                         not(po_delphi_nested_cc in p.procoptions)) then
                       begin

+ 75 - 0
tests/tbs/tb0610.pp

@@ -0,0 +1,75 @@
+program testarray;
+{$mode objfpc}
+{$h+}
+uses typinfo;
+
+Procedure SetPointerProp(Instance : TObject;PropInfo : PPropInfo;Value : Pointer);
+
+type
+  TObjectArray = Array of tobject;
+  TSetPointerProcIndex=procedure(index : longint;p:pointer) of object;
+  TSetPointerProc=procedure(P : Pointer) of object;
+
+var
+  DataSize: Integer;
+  AMethod : TMethod;
+begin
+  DataSize:=Length(TObjectArray(Value));
+  case (PropInfo^.PropProcs shr 2) and 3 of
+    ptfield:
+        PPointer(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
+    ptstatic,
+    ptvirtual :
+      begin
+        if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
+          AMethod.Code:=PropInfo^.SetProc
+        else
+          AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
+        AMethod.Data:=Instance;
+        if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
+          TSetPointerProcIndex(AMethod)(PropInfo^.Index,Value)
+        else
+          TSetPointerProc(AMethod)(Value);
+      end;
+  end;
+end;
+
+{$M+}
+Type
+  TMyArrayObject = Class(TObject);
+  TMyArrayObjectArray = Array of TMyArrayObject;
+
+  { TMyObject }
+
+  TMyObject = Class(TObject)
+  private
+    FMyArray : TMyArrayObjectArray;
+    procedure SetMyArray(AIndex: Integer; AValue: TMyArrayObjectArray);virtual;
+  Published
+    Property MyArray : TMyArrayObjectArray Index 8 Read FMyArray Write SetMyArray;
+  end;
+
+{ TMyObject }
+
+procedure TMyObject.SetMyArray(AIndex: Integer; AValue: TMyArrayObjectArray);
+Var
+  ALength : Integer;
+
+begin
+  ALength:=Length(AValue);
+  If FMyArray=AValue then exit;
+  FMyArray:=AValue;
+end;
+
+Var
+  O : TMyObject;
+  A : TMyArrayObjectArray;
+
+begin
+  SetLength(A,117);
+  O:=TMyObject.Create;
+  // SetObjProp(O,GetPropInfo(O,'MyArray'),TObject(A));
+  SetPointerProp(O,GetPropInfo(O,'MyArray'),Pointer(A));
+  If Length(O.MyArray)<>Length(A) then
+    Writeln('Wrong!!')
+end.

+ 2 - 2
tests/webtbs/tw20075.pp

@@ -19,13 +19,13 @@ type
 
 function TTest.GetCount(TheArray: TNodeArray; Count: Integer): Integer; assembler;
 asm
-  MOV     EAX, EDX
+  MOV     EAX, ECX
 end;
 
 {$IMPLICITEXCEPTIONS OFF}
 function TTest.GetCountNoExceptions(TheArray: TNodeArray; Count: Integer): Integer; assembler;
 asm
-  MOV     EAX, EDX
+  MOV     EAX, ECX
 end;
 {$IMPLICITEXCEPTIONS ON}