瀏覽代碼

* allow passing the address of a procedure to a formal parameter
in delphi mode

peter 23 年之前
父節點
當前提交
c7428a9e4a
共有 1 個文件被更改,包括 20 次插入1 次删除
  1. 20 1
      compiler/ncal.pas

+ 20 - 1
compiler/ncal.pas

@@ -279,6 +279,7 @@ implementation
 {$ifdef extdebug}
 {$ifdef extdebug}
         store_count_ref : boolean;
         store_count_ref : boolean;
 {$endif def extdebug}
 {$endif def extdebug}
+        p1 : tnode;
       begin
       begin
          inc(parsing_para_level);
          inc(parsing_para_level);
 
 
@@ -438,6 +439,20 @@ implementation
          { Handle formal parameters separate }
          { Handle formal parameters separate }
          if (defcoll.paratype.def.deftype=formaldef) then
          if (defcoll.paratype.def.deftype=formaldef) then
            begin
            begin
+             { load procvar if a procedure is passed }
+             if (m_tp_procvar in aktmodeswitches) and
+                (left.nodetype=calln) and
+                (is_void(left.resulttype.def)) then
+              begin
+                p1:=cloadnode.create_procvar(tcallnode(left).symtableprocentry,
+                   tprocdef(tcallnode(left).procdefinition),tcallnode(left).symtableproc);
+                if assigned(tcallnode(left).right) then
+                 tloadnode(p1).set_mp(tcallnode(left).right);
+                left.free;
+                left:=p1;
+                resulttypepass(left);
+              end;
+
              case defcoll.paratyp of
              case defcoll.paratyp of
                vs_var,
                vs_var,
                vs_out :
                vs_out :
@@ -1829,7 +1844,11 @@ begin
 end.
 end.
 {
 {
   $Log$
   $Log$
-  Revision 1.69  2002-04-15 19:44:19  peter
+  Revision 1.70  2002-04-16 16:09:08  peter
+    * allow passing the address of a procedure to a formal parameter
+      in delphi mode
+
+  Revision 1.69  2002/04/15 19:44:19  peter
     * fixed stackcheck that would be called recursively when a stack
     * fixed stackcheck that would be called recursively when a stack
       error was found
       error was found
     * generic changeregsize(reg,size) for i386 register resizing
     * generic changeregsize(reg,size) for i386 register resizing