home *** CD-ROM | disk | FTP | other *** search
/ vsiftp.vmssoftware.com / VSIPUBLIC@vsiftp.vmssoftware.com.tar / FREEWARE / FREEWARE40.ZIP / callmon / src / example_collection.ada < prev    next >
Text File  |  1996-08-06  |  21KB  |  622 lines
  1. --  CALLMON Examples
  2. --
  3. --  File:     EXAMPLE_COLLECTION.ADA
  4. --  Author:   Thierry Lelegard
  5. --  Version:  1.0
  6. --  Date:     24-JUL-1996
  7. --
  8. --  Abstract: Example package which traces the usage of Ada collections.
  9. --
  10. --            All routines prefixed with ADA$ which are intercepted in
  11. --            this package come from module ADA$ACCESS, in the DEC Ada
  12. --            Run-Time Library for OpenVMS Alpha V6.2. The description
  13. --            of these routine are copied from file ADAACCESS.LIS in
  14. --            directory [V62.ADARTL.LIS] on the OpenVMS Alpha listing
  15. --            CD-ROMs.
  16. --
  17.  
  18.  
  19. with Callmon;
  20.  
  21. with Text_IO;
  22. with System;
  23. with Get_Task_Info;
  24. with Unchecked_Conversion;
  25. with Condition_Handling;
  26.  
  27. package body Example_Collection is
  28.  
  29.     -- Local renaming or external types and operators.
  30.  
  31.     function "=" (X, Y : in Callmon.Integer_64) return Boolean
  32.     renames System."=";
  33.  
  34.     function "<" (X, Y : in Callmon.Integer_32) return Boolean
  35.     renames System."<";
  36.  
  37.     --  This generic routine fetches an object at an address. The address
  38.     --  if given by an integer type. If the address is null, return a
  39.     --  default value.
  40.  
  41.     generic
  42.         type Address is range <>;
  43.         type Target is private;
  44.         Default_Value : in Target;
  45.     function Fetch_From_Address (
  46.         Location : in Address;
  47.         Default  : in Target := Default_Value)
  48.         return Target;
  49.  
  50.  
  51.     ----------------------------------------------------------------------------
  52.     --
  53.     --  This generic routine returns the "image" of an integer value,
  54.     --  in an hexadecimal string.
  55.     --
  56.     ----------------------------------------------------------------------------
  57.  
  58.     function Integer_Hexa_Image (
  59.         Item  : in Element;
  60.         Width : in Positive := Default_Width)
  61.         return String is
  62.  
  63.         Digit  : constant String := "0123456789ABCDEF";
  64.         Image  : String (1..Width);
  65.         Remain : Element := Item;
  66.  
  67.     begin
  68.  
  69.         for N in reverse Image'Range loop
  70.             Image (N) := Digit (Digit'First + Natural (Remain mod 16));
  71.             Remain := Remain / 16;
  72.         end loop;
  73.  
  74.         return Image;
  75.  
  76.     end Integer_Hexa_Image;
  77.  
  78.  
  79.     ----------------------------------------------------------------------------
  80.     --
  81.     --  Hexadecimal image of 32-bits and 64-bits integers.
  82.     --
  83.     ----------------------------------------------------------------------------
  84.  
  85.     function Hexa_Image is new Integer_Hexa_Image (
  86.         Element => Callmon.Integer_32,
  87.         Default_Width => 8);
  88.  
  89.     function Hexa_Image is new Integer_Hexa_Image (
  90.         Element => Callmon.Integer_64,
  91.         Default_Width => 8); -- P0 addresses are 32-bits only
  92.  
  93.  
  94.     ----------------------------------------------------------------------------
  95.     --
  96.     --  This generic routine returns the "image" of an access value,
  97.     --  in an hexadecimal string.
  98.     --
  99.     ----------------------------------------------------------------------------
  100.  
  101.     function Access_Hexa_Image (
  102.         Item  : in Access_Element;
  103.         Width : in Positive := Default_Width)
  104.         return String is
  105.  
  106.         function To_Integer_32 is
  107.         new Unchecked_Conversion (Access_Element, Callmon.Integer_32);
  108.  
  109.     begin
  110.  
  111.         return Hexa_Image (To_Integer_32 (Item), Width);
  112.  
  113.     end Access_Hexa_Image;
  114.  
  115.  
  116.     ----------------------------------------------------------------------------
  117.     --
  118.     --  This function returns a string which uniformely identifies
  119.     --  the current task in the application.
  120.     --
  121.     ----------------------------------------------------------------------------
  122.  
  123.     function Task_Name return String is
  124.  
  125.         package Integer_IO is new Text_IO.Integer_IO (Integer);
  126.  
  127.         Image : String (1..4);
  128.  
  129.     begin
  130.  
  131.         Integer_IO.Put (Image, Get_Task_Info.Get_Current_Task_Id);
  132.         return "Task" & Image;
  133.  
  134.     end Task_Name;
  135.  
  136.  
  137.     ----------------------------------------------------------------------------
  138.     --
  139.     --  This generic routine fetches an object at an address. The address
  140.     --  if given by an integer type. If the address is null, return a
  141.     --  default value.
  142.     --
  143.     ----------------------------------------------------------------------------
  144.  
  145.     function Fetch_From_Address (
  146.         Location : in Address;
  147.         Default  : in Target := Default_Value)
  148.         return Target is
  149.  
  150.         function Fetch is new System.Fetch_From_Address (Target);
  151.  
  152.     begin
  153.  
  154.         if Location = 0 then
  155.             return Default;
  156.         else
  157.             return Fetch (
  158.                 System.To_Address (System.Unsigned_Longword (Location)));
  159.         end if;
  160.  
  161.     end Fetch_From_Address;
  162.  
  163.  
  164.     ----------------------------------------------------------------------------
  165.     --
  166.     --  When a parameter is passed by reference, the Integer_64 in
  167.     --  the argument list is the address of the actual parameter.
  168.     --  This function fetches a 32-bits integer passed by reference.
  169.     --
  170.     ----------------------------------------------------------------------------
  171.  
  172.     function Fetch_Integer_32 is new Fetch_From_Address (
  173.         Address       => Callmon.Integer_64,
  174.         Target        => Callmon.Integer_32,
  175.         Default_Value => 0);
  176.  
  177.  
  178.     ----------------------------------------------------------------------------
  179.     --
  180.     --  Interception of ADA$CREATE_COLLECTION_2
  181.     --
  182.     ----------------------------------------------------------------------------
  183.     --
  184.     --
  185.     --  FUNCTIONAL DESCRIPTION:
  186.     -- 
  187.     --     Called by the Ada compiler when it wishes to create 
  188.     --     a collection corresponding to some access type, i.e.
  189.     --     when the access type definition is elaborated.
  190.     -- 
  191.     --     This routine is passed a list header upon which the
  192.     --     RTL chains collections created in the current frame 
  193.     --     so they can be released at normal exit or exception
  194.     --     propagation.
  195.     -- 
  196.     --     Bounds are passed for the size of objects in the collection.
  197.     --     These must be correct.  It is desireable that they also
  198.     --     be as tight as possible because they are used to choose the 
  199.     --     allocation algorithms.
  200.     -- 
  201.     --     There are two outputs.  One output is that information about
  202.     --     this new collection is inserted on the collection list of the
  203.     --     scope.  Another output is the collection descriptor
  204.     --     associated with the access type.   The collection descriptor is
  205.     --     used as a parameter when other operations related to this access
  206.     --     type are performed.
  207.     -- 
  208.     --     A limit on the size of the collection may be specified, and 
  209.     --     an alignment requirement can be specified.
  210.     -- 
  211.     --     Ada source:
  212.     -- 
  213.     --         type SOME_TYPE is access OTHER_TYPE; 
  214.     --         -- ADA$CREATE_COLLECTION
  215.     -- 
  216.     -- 
  217.     --  FORMAL PARAMETERS:
  218.     --
  219.     --     MIN_SIZE (in)              Minimum size of any object of the 
  220.     --                                type.  (0 to MAX_INT).
  221.     --  
  222.     --                                If negative, PROGRAM_ERROR is raised.
  223.     --
  224.     --     MAX_SIZE (in)              Maximum size of any object of the type
  225.     --                                (0 to MAX_INT).
  226.     -- 
  227.     --                                NOTE: later attempting to allocate an
  228.     --                                object whose size exceeds these limits
  229.     --                                is erroneous and will be assumed to
  230.     --                                indicate a corrupted program.
  231.     -- 
  232.     --                                If negative, PROGRAM_ERROR is raised.
  233.     --                                If MAX_SIZE < MIN_SIZE, PROGRAM_ERROR
  234.     --                                is raised.
  235.     --
  236.     --     COLLECTION_LIST (in out)   Address of the collection list header
  237.     --                                for this scope.
  238.     -- 
  239.     --                                The collection list header is a longword
  240.     --                                allocated in the context of the current
  241.     --                                scope.  It must be initially nulled by
  242.     --                                the compiler before ADA$HANDLER is 
  243.     --                                established.
  244.     --
  245.     --     COLLECTION_DESC (out)      Address of the collection descriptor for
  246.     --                                this collection. 
  247.     --  
  248.     --                                The collection descriptor is initialized
  249.     --                                by this routine.  Collection descriptors
  250.     --                                must never be copied and are always passed
  251.     --                                by reference. (Internally, it consists of
  252.     --                                a link to the next collection in the
  253.     --                                scope, a longword zone, and other
  254.     --                                information).
  255.     --
  256.     --  OPT_STORAGE_SIZE (in)         Address of a longword giving an optional 
  257.     --                                restriction on the size of the collection.
  258.     --                                The STORAGE_SIZE is given in bytes.
  259.     -- 
  260.     --                null address    => "no storage limit".
  261.     --                Value of <= 0   => "no storage allocated".
  262.     --
  263.     --  OPT_ALIGNMENT (in)            Address of a longword giving an optional
  264.     --                                byte alignment specification for objects
  265.     --                                of the collection. This number must be
  266.     --                                equal to 2**N for some N.  To illustrate,
  267.     --                                the value 8 implies quadword alignment.
  268.     -- 
  269.     --      null address              => longword alignment.
  270.     --      Value > 0 and Value < 4   => longword alignment.
  271.     --      Value < 0 or  Value > 512 => PROGRAM_ERROR is raised
  272.     --      Value not power-of-2      => PROGRAM_ERROR is raised
  273.     --
  274.     --
  275.     --  IMPLICIT INPUTS:
  276.     -- 
  277.     --      NONE
  278.     -- 
  279.     --  IMPLICIT OUTPUTS:
  280.     -- 
  281.     --      NONE
  282.     -- 
  283.     --  ROUTINE VALUE:
  284.     -- 
  285.     --      NONE
  286.     -- 
  287.     --  SIDE EFFECTS:
  288.     -- 
  289.     --      CONSTRAINT_ERROR is raised if the specified collection size will
  290.     --                       exceed MAX_INT when it is rounded up to the next
  291.     --                       block.
  292.     --      STORAGE_ERROR    is raised if a COLLECTION_SIZE was specified
  293.     --                       and insufficient virtual space exists.
  294.     --      PROGRAM_ERROR    is raised if parameters violate required limits.
  295.     --
  296.     --
  297.     ----------------------------------------------------------------------------
  298.     -- 
  299.     --  The following procedure is a post-processing routine for
  300.     --  ADA$CREATE_COLLECTION_2
  301.     -- 
  302.     ----------------------------------------------------------------------------
  303.  
  304.     procedure Post_Create_Collection_2 (
  305.         Arguments           : in out Callmon.Arguments_Type;
  306.         Caller              : in     Callmon.Invo_Handle_Type;
  307.         Routine_Name        : in     String;
  308.         Intercepted_Routine : in     Callmon.Address;
  309.         Jacket_Routine      : in     Callmon.Address) is
  310.  
  311.         function Storage_Limit return String is
  312.             Address : Callmon.Integer_64 := Arguments.Arg_List (5);
  313.             Value   : Callmon.Integer_32 := Fetch_Integer_32 (Address);
  314.         begin
  315.             if Address = 0 then
  316.                 return "no storage limit";
  317.             elsif Value < 0 then
  318.                 return "no storage";
  319.             else
  320.                 return "storage limit:" & 
  321.                    Callmon.Integer_32'Image (Value) & " bytes";
  322.             end if;
  323.         end Storage_Limit;
  324.  
  325.     begin
  326.  
  327.         Text_IO.Put_Line (Task_Name &
  328.             ": [trace] Created collection " &
  329.             Hexa_Image (Arguments.Arg_List (4)) &
  330.             ", min size:" &
  331.             Callmon.Integer_64'Image (Arguments.Arg_List (1)) &
  332.             ", max:" &
  333.             Callmon.Integer_64'Image (Arguments.Arg_List (2)) &
  334.             " bytes" & Ascii.CR & Ascii.LF & "          List: " &
  335.             Hexa_Image (Arguments.Arg_List (3)) &
  336.             ", " & Storage_Limit & ", alignment:" &
  337.             Callmon.Integer_32'Image (
  338.                 Fetch_Integer_32 (Arguments.Arg_List (6), Default => 4)) &
  339.             " bytes");
  340.  
  341.     end Post_Create_Collection_2;
  342.  
  343.     pragma Export_Procedure (
  344.         Internal  => Post_Create_Collection_2,
  345.         External  => "",
  346.         Mechanism => (Reference, Value, Descriptor (S), Value, Value));
  347.  
  348.  
  349.     ----------------------------------------------------------------------------
  350.     --
  351.     --  Interception of ADA$DELETE_COLLECTIONS
  352.     --
  353.     ----------------------------------------------------------------------------
  354.     -- 
  355.     --
  356.     --  FUNCTIONAL DESCRIPTION:
  357.     --
  358.     --     Called by the Ada compiler or Ada exception handler
  359.     --     when a scope containing any collections is being left.
  360.     --
  361.     --     This routine releases the storage for all collections
  362.     --     dependent on that scope.
  363.     --
  364.     --     Ada source:
  365.     --
  366.     --         end;
  367.     --         -- ADA$DELETE_COLLECTIONS
  368.     -- 
  369.     --
  370.     --  FORMAL PARAMETERS:
  371.     --
  372.     --     COLLECTION_LIST (in out)  Address of the list header describing all
  373.     --                               collections in the scope.
  374.     --
  375.     --                               This longword will be nulled by this
  376.     --                               routine. This indicates that the freeing
  377.     --                               has been already been done when a second
  378.     --                               cleanup is attempted on exception or
  379.     --                               unwind.
  380.     -- 
  381.     --
  382.     --  IMPLICIT INPUTS:
  383.     -- 
  384.     --     NONE
  385.     -- 
  386.     --  IMPLICIT OUTPUTS:
  387.     -- 
  388.     --     NONE
  389.     -- 
  390.     --  ROUTINE VALUE:
  391.     -- 
  392.     --     NONE
  393.     -- 
  394.     --  SIDE EFFECTS:
  395.     -- 
  396.     --     NONE
  397.     -- 
  398.     -- 
  399.     ----------------------------------------------------------------------------
  400.     -- 
  401.     --  The following procedure is a pre-processing routine for
  402.     --  ADA$DELETE_COLLECTIONS
  403.     -- 
  404.     ----------------------------------------------------------------------------
  405.  
  406.     procedure Pre_Delete_Collections (
  407.         Arguments           : in out Callmon.Arguments_Type;
  408.         Caller              : in     Callmon.Invo_Handle_Type;
  409.         Routine_Name        : in     String;
  410.         Intercepted_Routine : in     Callmon.Address;
  411.         Jacket_Routine      : in     Callmon.Address) is
  412.  
  413.     begin
  414.  
  415.         Text_IO.Put_Line (Task_Name &
  416.             ": [trace] Delete collection in list " &
  417.             Hexa_Image (Arguments.Arg_List (1)));
  418.  
  419.     end Pre_Delete_Collections;
  420.  
  421.     pragma Export_Procedure (
  422.         Internal  => Pre_Delete_Collections,
  423.         External  => "",
  424.         Mechanism => (Reference, Value, Descriptor (S), Value, Value));
  425.  
  426.  
  427.     ----------------------------------------------------------------------------
  428.     --
  429.     --  Interception of ADA$ALLOCATE
  430.     --
  431.     ----------------------------------------------------------------------------
  432.     --
  433.     --  Description of ADA$ALLOCATE, module ADA$ACCESS, V6.2
  434.     -- 
  435.     --
  436.     --  FUNCTIONAL DESCRIPTION:
  437.     --
  438.     --     Called by the Ada compiler when it wishes to allocate a 
  439.     --     dynamic object to be referenced by an object of an access type.
  440.     --
  441.     --     This routine allocates some number of requested bytes of 
  442.     --     storage for a dynamic object.  The address of the dynamic
  443.     --     object is stored in the access object (a longword).
  444.     --     The caller must pass in the address of the collection descriptor
  445.     --     that is associated with the access type definition.
  446.     --
  447.     --     Ada source:
  448.     --
  449.     --        X := new SOME_TYPE 
  450.     --        -- ADA$ALLOCATE    
  451.     --
  452.     --
  453.     --  FORMAL PARAMETERS:
  454.     --
  455.     --     SIZE (in)             Size of the object to be allocated (bytes).
  456.     --
  457.     --     COLLECTION_DESC (in)  The address of the collection descriptor for
  458.     --                           the collection which the object belongs to.
  459.     --
  460.     --
  461.     --  IMPLICIT INPUTS:
  462.     --
  463.     --     NONE
  464.     --
  465.     --  IMPLICIT OUTPUTS:
  466.     --
  467.     --     NONE
  468.     --
  469.     --  ROUTINE VALUE:
  470.     --
  471.     --     ACCESS_VALUE, the address of the dynamic object that was created.
  472.     --                   A null value may be returned if it is a collection
  473.     --                   of null objects.
  474.     --
  475.     --  SIDE EFFECTS:
  476.     --
  477.     --     PROGRAM_ERROR is raised if the object size is out of bounds
  478.     --                   of MIN_SIZE, MAX_SIZE for the collection.
  479.     --                   It is also raised if internal data structures fail a
  480.     --                   consistency check (out-of-bounds addressing by user
  481.     --                   is assumed).
  482.     --
  483.     --     STORAGE_ERROR is raised if the collection size had a 
  484.     --                   STORAGE_SIZE rep spec and the new object can't be 
  485.     --                   allocated, or, there was no bound, but there is no 
  486.     --                   virtual space available.
  487.     --
  488.     --
  489.     ----------------------------------------------------------------------------
  490.     -- 
  491.     --  The following procedure is a post-processing routine for ADA$ALLOCATE.
  492.     -- 
  493.     ----------------------------------------------------------------------------
  494.  
  495.     procedure Post_Allocate (
  496.         Arguments           : in out Callmon.Arguments_Type;
  497.         Caller              : in     Callmon.Invo_Handle_Type;
  498.         Routine_Name        : in     String;
  499.         Intercepted_Routine : in     Callmon.Address;
  500.         Jacket_Routine      : in     Callmon.Address) is
  501.  
  502.     begin
  503.  
  504.         Text_IO.Put_Line (Task_Name &
  505.             ": [trace] Allocated" & 
  506.             Callmon.Integer_64'Image (Arguments.Arg_List (1)) &
  507.             " bytes at " &
  508.             Hexa_Image (Arguments.Result_R0) &
  509.             " in collection " &
  510.             Hexa_Image (Arguments.Arg_List (2)));
  511.  
  512.     end Post_Allocate;
  513.  
  514.     pragma Export_Procedure (
  515.         Internal  => Post_Allocate,
  516.         External  => "",
  517.         Mechanism => (Reference, Value, Descriptor (S), Value, Value));
  518.  
  519.  
  520.     ----------------------------------------------------------------------------
  521.     --
  522.     --  Interception of ADA$DEALLOCATE
  523.     --
  524.     ----------------------------------------------------------------------------
  525.     --
  526.     --  Description of ADA$DEALLOCATE, module ADA$ACCESS, V6.2
  527.     -- 
  528.     --
  529.     --  FUNCTIONAL DESCRIPTION:
  530.     --
  531.     --     Called by the Ada compiler when it wishes to deallocate
  532.     --     an access object.
  533.     --
  534.     --     This routine releases the storage for the object to the
  535.     --     collection, and sets the access object to null.
  536.     --
  537.     --     Ada source:
  538.     --
  539.     --        UNCHECKED_DEALLOCATION_FOR_TYPE_OF_X (X);
  540.     --        -- ADA$DEALLOCATE
  541.     --
  542.     --  FORMAL PARAMETERS:
  543.     --
  544.     --     COLLECTION_DESC (in)    The address of the collection descriptor of
  545.     --                             the collection which the object belongs to.
  546.     --
  547.     --     ACCESS_OBJECT (in out)  The address of the access object pointing
  548.     --                             to the dynamic object.
  549.     --
  550.     --                             The access object is set to the null
  551.     --                             access value by this routine.
  552.     --
  553.     --
  554.     --  IMPLICIT INPUTS:
  555.     --
  556.     --     NONE
  557.     --
  558.     --  IMPLICIT OUTPUTS:
  559.     --
  560.     --     NONE
  561.     --
  562.     --  ROUTINE VALUE:
  563.     --
  564.     --     NONE
  565.     --
  566.     --  SIDE EFFECTS:
  567.     --
  568.     --     NONE
  569.     --
  570.     --
  571.     ----------------------------------------------------------------------------
  572.     -- 
  573.     --  The following procedure is a pre-processing routine for ADA$DEALLOCATE.
  574.     -- 
  575.     ----------------------------------------------------------------------------
  576.  
  577.     procedure Pre_Deallocate (
  578.         Arguments           : in out Callmon.Arguments_Type;
  579.         Caller              : in     Callmon.Invo_Handle_Type;
  580.         Routine_Name        : in     String;
  581.         Intercepted_Routine : in     Callmon.Address;
  582.         Jacket_Routine      : in     Callmon.Address) is
  583.  
  584.     begin
  585.  
  586.         Text_IO.Put_Line (Task_Name &
  587.             ": [trace] Deallocate " &
  588.             Hexa_Image (Fetch_Integer_32 (Arguments.Arg_List (2))) &
  589.             " from collection " &
  590.             Hexa_Image (Arguments.Arg_List (1)));
  591.  
  592.     end Pre_Deallocate;
  593.  
  594.     pragma Export_Procedure (
  595.         Internal  => Pre_Deallocate,
  596.         External  => "",
  597.         Mechanism => (Reference, Value, Descriptor (S), Value, Value));
  598.  
  599.  
  600. --------------------------------------------------------------------------------
  601. --
  602. --  Package elaboration.
  603. --  Should be executed before the creation of any task.
  604. --
  605. --------------------------------------------------------------------------------
  606.  
  607. begin
  608.  
  609.     Callmon.Intercept ("ADA$CREATE_COLLECTION_2",
  610.         Post_Routine => Post_Create_Collection_2'Address);
  611.  
  612.     Callmon.Intercept ("ADA$DELETE_COLLECTIONS",
  613.         Pre_Routine => Pre_Delete_Collections'Address);
  614.  
  615.     Callmon.Intercept ("ADA$ALLOCATE",
  616.         Post_Routine => Post_Allocate'Address);
  617.  
  618.     Callmon.Intercept ("ADA$DEALLOCATE",
  619.         Pre_Routine => Pre_Deallocate'Address);
  620.  
  621. end Example_Collection;
  622.