Browse Source

* force advanced records into memory when they are used as self, resolves #26075

git-svn-id: trunk@29139 -
florian 10 years ago
parent
commit
854fa1d4b9
4 changed files with 76 additions and 0 deletions
  1. 2 0
      .gitattributes
  2. 4 0
      compiler/ncgcal.pas
  3. 35 0
      tests/webtbs/tw26075.pp
  4. 35 0
      tests/webtbs/tw26075b.pp

+ 2 - 0
.gitattributes

@@ -14079,6 +14079,8 @@ tests/webtbs/tw25959.pp svneol=native#text/pascal
 tests/webtbs/tw2602.pp svneol=native#text/plain
 tests/webtbs/tw26069.pp svneol=native#text/plain
 tests/webtbs/tw2607.pp svneol=native#text/plain
+tests/webtbs/tw26075.pp svneol=native#text/pascal
+tests/webtbs/tw26075b.pp svneol=native#text/pascal
 tests/webtbs/tw26123.pp svneol=native#text/pascal
 tests/webtbs/tw26162.pp svneol=native#text/pascal
 tests/webtbs/tw26177.pp svneol=native#text/pascal

+ 4 - 0
compiler/ncgcal.pas

@@ -325,6 +325,10 @@ implementation
                      paramanager.push_addr_param(parasym.varspez,parasym.vardef,
                          aktcallnode.procdefinition.proccalloption));
 
+                 { objects or advanced records could be located in registers if they are the result of a type case, see e.g. webtbs\tw26075.pp }
+                 if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
+                   hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
+
                  if pushaddr then
                    push_addr_para
                  else

+ 35 - 0
tests/webtbs/tw26075.pp

@@ -0,0 +1,35 @@
+program fpc_advrec_bug;
+
+{$mode delphi}
+{$optimization off}
+
+Uses TypInfo;
+
+Type
+
+ PTypeInfoRec = Record
+  FValue : PTypeInfo;
+  Function QualifiedName : String;
+ End;
+
+Function PTypeInfoRec.QualifiedName : String;
+Begin
+ Result := '';
+End;
+
+function Test : Pointer;
+Begin
+ Result := nil;
+End;
+
+Var
+
+ p : PTypeInfo;
+
+begin
+
+ PTypeInfoRec(p).QualifiedName; // OK
+ PTypeInfoRec(Test).QualifiedName; // OK
+ PTypeInfoRec(TypeInfo(String)).QualifiedName; // Internal error 200304235
+
+end.

+ 35 - 0
tests/webtbs/tw26075b.pp

@@ -0,0 +1,35 @@
+program fpc_advrec_bug;
+
+{$mode delphi}
+{$optimization off}
+
+Uses TypInfo;
+
+Type
+
+ PTypeInfoRec = object
+  FValue : PTypeInfo;
+  Function QualifiedName : String;
+ End;
+
+Function PTypeInfoRec.QualifiedName : String;
+Begin
+ Result := '';
+End;
+
+function Test : Pointer;
+Begin
+ Result := nil;
+End;
+
+Var
+
+ p : PTypeInfo;
+
+begin
+
+ PTypeInfoRec(p).QualifiedName; // OK
+ PTypeInfoRec(Test).QualifiedName; // OK
+ PTypeInfoRec(TypeInfo(String)).QualifiedName; // Internal error 200304235
+
+end.