* first version, please keep it up-to-date

tests/testpvar.pp

@@ -0,0 +1,99 @@
+{
+  $Id$
+  This program tries to test any aspect of procedure variables and related
+  stuff in FPC mode
+}
+
+{$ifdef go32v2}
+uses
+   dpmiexcp;
+{$endif go32v2}
+
+procedure do_error(i : longint);
+
+  begin
+     writeln('Error near: ',i);
+     halt(1);
+  end;
+
+var
+   globalvar : longint;
+
+type
+   tpoo_rec = record
+      procpointer : pointer;
+      s : pointer;
+   end;
+
+procedure callmethodparam(s : pointer;addr : pointer;param : longint);
+
+  var
+     p : procedure(param : longint) of object;
+
+  begin
+     tpoo_rec(p).procpointer:=addr;
+     tpoo_rec(p).s:=s;
+     p(param);
+  end;
+
+type
+   to1 = object
+      procedure test1;
+      procedure test2(l : longint);
+   end;
+
+ procedure to1.test1;
+   var
+      p:pointer;
+   begin
+      // useless only a semantic test
+      p:[email protected];
+      // this do we use to do some testing
+      p:[email protected];
+      globalvar:=0;
+      callmethodparam(@self,p,1234);
+      if globalvar<>1234 then
+        do_error(1000);
+   end;
+
+ procedure to1.test2(l : longint);
+
+   begin
+      globalvar:=l;
+   end;
+
+const
+   constmethodaddr : pointer = @to1.test2;
+
+var
+   o1 : to1;
+   p : procedure(l : longint) of object;
+
+begin
+   {                                       }
+   {  Procedures of objects                }
+   {                                       }
+   writeln('Procedures of objects');
+   p:[email protected];
+   globalvar:=0;
+   p(12);
+   if globalvar<>12 then
+     do_error(1002);
+   writeln('Ok');
+   {                                       }
+   {  Pointers and addresses of procedures }
+   {                                       }
+   writeln('Getting an address of a method as pointer');
+   o1.test1;
+   globalvar:=0;
+   callmethodparam(@o1,constmethodaddr,34);
+   if globalvar<>34 then
+     do_error(1001);
+   writeln('Ok');
+end.
+{
+  $Log$
+  Revision 1.1  1999-09-11 19:45:33  florian
+    * first version, please keep it up-to-date
+
+}