tw11862.pp 1.4 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586
  1. program bug9;
  2. {$ifdef fpc}
  3. {$mode delphi}
  4. {$endif}
  5. type
  6. ttesttype = (testgetchild,testparent,testparentex);
  7. ITest = interface(IInterface)
  8. ['{FE6B16A6-A898-4B09-A46E-0AAC5E0A4E14}']
  9. function Parent: ITest;
  10. end;
  11. ITestEx = interface(ITest)
  12. ['{82449E91-76BE-4F4A-B873-1865042D5CAF}']
  13. function Parent: ITestEx;
  14. function GetChild: ITestEx;
  15. procedure RemoveChild;
  16. end;
  17. TTest = class(TInterfacedObject, ITestEx)
  18. function ITestEx.Parent = ParentEx;
  19. { ITest }
  20. function Parent: ITest;
  21. { ITestEx }
  22. function ParentEx: ITestEx;
  23. function GetChild: ITestEx;
  24. procedure RemoveChild;
  25. end;
  26. { ITest }
  27. var
  28. test: ttesttype;
  29. function TTest.Parent: ITest;
  30. begin;
  31. writeln('ttest.parent');
  32. Result := nil;
  33. if (test<>testparent) then
  34. halt(1);
  35. end;
  36. { ITestEx }
  37. function TTest.ParentEx: ITestEx;
  38. begin;
  39. writeln('ttest.parentex');
  40. Result := nil;
  41. if (test<>testparentex) then
  42. halt(1);
  43. end;
  44. function TTest.GetChild: ITestEx;
  45. begin;
  46. WriteLn('TTest.GetChild');
  47. Result := nil;
  48. if (test<>testgetchild) then
  49. halt(1);
  50. end;
  51. procedure TTest.RemoveChild;
  52. begin;
  53. WriteLn('TTest.RemoveChild');
  54. halt(1);
  55. end;
  56. var E: ITestEx;
  57. e2: itest;
  58. begin
  59. E := TTest.Create;
  60. WriteLn('Calling GetChild');
  61. test:=testgetchild;
  62. E.GetChild();
  63. test:=testparentex;
  64. e.parent;
  65. test:=testparent;
  66. e2:=e;
  67. e2.parent;
  68. WriteLn('Stop');
  69. end.