From mboxrd@z Thu Jan  1 00:00:00 1970
X-Spam-Checker-Version: SpamAssassin 3.4.5-pre1 (2020-06-20) on
	ip-172-31-74-118.ec2.internal
X-Spam-Level: 
X-Spam-Status: No, score=-1.9 required=3.0 tests=BAYES_00 autolearn=ham
	autolearn_force=no version=3.4.5-pre1
Date: 10 May 93 22:56:19 GMT
From: aio!aio.jsc.nasa.gov!dean@tmc.edu  (Jack Dean)
Subject: Re: Passing procedures as parameters to procedures.
Message-ID: <DEAN.93May10155619@wind.sweetpea.jsc.nasa.gov>
List-Id: <comp.lang.ada>

>>>>> andrewd@winnie.cs.adelaide.edu.au (Andrew Dunstan,,2285592,) writes:
 Andrew> NNTP-Posting-Host: winnie.cs.adelaide.edu.au

 Andrew> As I pointed out in this group about a year ago, there are some things
 Andrew> that you want to be able to do that you just can't with generics. If
 Andrew> anybody can provide me with a good, clean, Ada equivalent of the
 Andrew> following Pascal code, I'll send him/her (first winner only!) a good
 Andrew> bottle of Australian red wine (damn this Beaujolais business!).

 Andrew> procedure a(b : procedure(c : procedure));

 Andrew>   procedure d;	
 Andrew>   begin;
 Andrew>   end;

 Andrew>  begin
 Andrew>    b(d);
 Andrew>  end;


 Andrew> procedure x(y : procedure);
 Andrew> begin
 Andrew>   y;
 Andrew> end;

 Andrew> .
 Andrew> .
 Andrew> .
 Andrew> a(x);
 Andrew> .
 Andrew> .


OK, here is my entry.  The following is legal, portable Ada 83, and it
implement the functional equivalent of procedure pointers.

I'll start off with the Ada equivalent of the Pascal fragment you
provided:

WITH Text_Io;
WITH Procedure_Parameter_Profile;

PROCEDURE Test_Pointer IS

    SUBTYPE Dummy IS Integer;

    PACKAGE D_Proc IS NEW Procedure_Parameter_Profile (Args => Dummy);
    PACKAGE B_Proc IS NEW Procedure_Parameter_Profile (Args => D_Proc.Pointer);

    D_Pointer : D_Proc.Pointer;
    X_Pointer : B_Proc.Pointer;

    PROCEDURE A (B : B_Proc.Pointer) IS
        PROCEDURE D (Ignore : Dummy) IS
        BEGIN
            Text_Io.Put_Line ("In procedure A.D");
        END D;

        PACKAGE D_Designate IS NEW D_Proc.Designate (The_Pointer => D_Pointer,
                                                     Designated_Procedure => D)
;
    BEGIN
        B_Proc.Invoke (The_Procedure => B, With_Args => D_Pointer);
        D_Designate.Leave_Scope;
    END A;

    PROCEDURE X (Y : D_Proc.Pointer) IS
    BEGIN  
        Text_Io.Put_Line ("In Procedure X");
        D_Proc.Invoke (The_Procedure => Y, With_Args => 0);
    END X;

    PACKAGE X_Designate IS NEW B_Proc.Designate (The_Pointer => X_Pointer,
                                                 Designated_Procedure => X);

BEGIN
    A (X_Pointer);

    X_Designate.Leave_Scope;
    Text_Io.Put_Line ("That's all, folks!");
END Test_Pointer;




And now for the magic that makes it work:


GENERIC
    TYPE Args IS PRIVATE;
PACKAGE Procedure_Parameter_Profile IS

    TYPE Id      IS LIMITED PRIVATE;
    TYPE Pointer IS ACCESS Id;


    GENERIC  
        The_Pointer : IN OUT Pointer;
        WITH PROCEDURE Designated_Procedure (The_Args : IN Args);
    PACKAGE Designate IS
        PROCEDURE Leave_Scope;
    END Designate;

    PROCEDURE Invoke (The_Procedure : IN Pointer; --
                      With_Args     : IN Args);

PRIVATE

    Max_Number_Of_Procedure_Pointers : CONSTANT := 20;
    TYPE Id IS RANGE 0 .. Max_Number_Of_Procedure_Pointers;

END Procedure_Parameter_Profile;


and its implementation:


PACKAGE BODY Procedure_Parameter_Profile IS


    Last_Id : Id := 0;


    FUNCTION New_Id RETURN Id IS
    BEGIN  
        Last_Id := Last_Id + 1;
        RETURN Last_Id;
    END New_Id;



    TASK Dispatcher IS  
        ENTRY Invoke (The_Procedure_Pointer : IN Id; With_Args : IN Args);
        ENTRY Wait_For_Start (Id) (The_Args : OUT Args);
        ENTRY Wait_For_Finish (Id);
        ENTRY Signal_Finished (The_Procedure_Pointer : IN Id);
        ENTRY Shutdown;
    END Dispatcher;



    TASK BODY Dispatcher IS
        The_Args : Args;
    BEGIN
        LOOP
            SELECT
                ACCEPT Invoke (The_Procedure_Pointer : IN Id;
                               With_Args             : IN Args) DO
                    ACCEPT Wait_For_Start (The_Procedure_Pointer)
                              (The_Args : OUT Args) DO
                        The_Args := With_Args;
                    END Wait_For_Start;  
                END Invoke;
            OR
                ACCEPT Signal_Finished (The_Procedure_Pointer : IN Id) DO  
                    ACCEPT Wait_For_Finish (The_Procedure_Pointer);
                END Signal_Finished;
            OR
                TERMINATE;
            END SELECT;
        END LOOP;
    END Dispatcher;



    PACKAGE BODY Designate IS

        My_Id : Id;

        TASK Hidden IS
            ENTRY Start;
        END Hidden;

        TASK BODY Hidden IS
            The_Args : Args;
            Continue : Boolean;
        BEGIN  
            ACCEPT Start;
            LOOP
                Dispatcher.Wait_For_Start (My_Id) (The_Args);
                Designated_Procedure (The_Args);
                Dispatcher.Signal_Finished (My_Id);
            END LOOP;
        END Hidden;

        PROCEDURE Leave_Scope IS
        BEGIN
            ABORT Hidden;
            The_pointer := NULL;
        END Leave_Scope;

    BEGIN

        IF The_Pointer = NULL THEN
            The_Pointer     := NEW Id;
            The_Pointer.ALL := New_Id;
        END IF;
        My_Id := The_Pointer.ALL;
        Hidden.Start;
    END Designate;




    PROCEDURE Invoke (The_Procedure : IN Pointer; --
                      With_Args     : IN Args) IS
    BEGIN
        Dispatcher.Invoke (The_Procedure.ALL, With_Args);
        Dispatcher.Wait_For_Finish (The_Procedure.ALL);  
    END Invoke;


END Procedure_Parameter_Profile;



Try it. It works.  I'm ready for my bottle of wine.





--
Jack Dean                         dean@sweetpea.jsc.nasa.gov