/*
* Module:       CALLER_INFO
*
* Cobol Prototype :    Call  "GET_MODULE_INFO" using MODULE_NAME.
*
* Return Argument:
*
*   Name:       MODULE_NAME
*   Type:       PIC X(39)                 --->  NAME_BUFFER_LENGTH
*   Access:     Write Only
*   Mechanism:  By Reference
*
* Description:
*
*    This subroutine returns the name caller.
*
*    This example program shows how to call TBK$SHOW_TRACEBACK()
*    TBK$SHOW_TRACEBACK() handles several cases that are hard to handle
*    yourself.  Like VAX translated frames and exception frames.
*
*    To test: cc/def=__MAIN_TEST
*
*    Be sure to compile /NOOPT, or /OPT=NOINL to keep intermediate routines.
*/

#define NAME_BUFFER_LENGTH 39
#define __NEW_STARLET

#include <stdio.h>
#include <string.h>
#include <descrip.h>
#include <ssdef.h>
#include <stsdef.h>
#include <starlet.h>

// librtl headers for call stack walking


#include <lib$routines.h>
#include <libicb.h>

// trace headers for trace api


#include <tbkdef.h>
#include <tbk$routines.h>

static int line_counter;
static char *name_pointer;

# ifdef __ALPHA

static unsigned long (*tbk$show_traceback)() = 0;

static unsigned long find_image_symbol(const char *image,
        const char *name, void **addr);
static void stack_dump(unsigned __int64 fp, unsigned __int64 pc);

#endif

void GET_MODULE_INFO(char *name)    {

    name_pointer = name;
    line_counter = 0;
    name[0] =  0;

# ifdef __ALPHA


    /* Get my callers FP & PC */
    struct _invo_context_blk context;
    lib$get_curr_invo_context(&context);
    unsigned long status = lib$get_prev_invo_context(&context);
    if (!$VMS_STATUS_SUCCESS(status)) lib$signal(status);
    unsigned __int64 fp = context.libicb$q_ireg[29];
    unsigned __int64 pc = context.libicb$q_program_counter;
    stack_dump(fp,pc);

# else

/* IA64 - Itanium specific code.
 * This code is essentialy cloned from the OpenVMS documentation.
 *  http://h71000.www7.hp.com/doc/83final/4493/4493pro_070.html
 *  HP OpenVMS Utility Routines Manual
 *  Chapter 21 - Traceback Facility (TBK) Routines
**/

    int status, tbk_status=0, callstack_depth = 0;
    unsigned int depth;
    /* local pointer for the call stack walk invocation context block
     */
    INVO_CONTEXT_BLK *myICB;

    /* local storage for image, module, routine names, line number, and image
     * and module base addresses returned by the trace api
     */
    static char image [128], module [128], routine [128], inquire_continue [128];
    static struct dsc$descriptor_vs image_dsc = {125, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, &image[0]};
    static struct dsc$descriptor_vs module_dsc = {125, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, &module[0]};
    static struct dsc$descriptor_vs routine_dsc = {125, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, &routine[0]};
    unsigned int     list_line;
    unsigned __int64 image_base_addr;
    unsigned __int64 module_base_addr;

    /* Local storage and setup for the trace api parameter block
     */
    unsigned __int64 symbolize_flags={0};
    TBK_API_PARAM params = {
                TBK$K_LENGTH,   /* trace api parameter block length */
                0,              /* trace api parameter block type, MBZ */
                TBK$K_VERSION,  /* trace api parameter block length, MBZ */
                0,      /* reserved, MBZ */
                0,      /* pc, input */
                0,      /* fp, input, not used for I64 */
                0,      /* filename desc, output, not used here */
                0,      /* library module desc, output, not used here */
                0,      /* record number, output, not used here  */
                (struct _descriptor *)&image_dsc,       /* image descriptor, output */
                (struct _descriptor *)&module_dsc,      /* module descriptor, output */
                (struct _descriptor *)&routine_dsc,     /* routine_descriptor, output */
                &list_line,     /* compiler listing line number, output */
                0,      /* relative pc, output, not used here */
                &image_base_addr,       /* image base address, output */
                &module_base_addr,      /* module base address, output */
                0,      /* malloc routine, input */
                0,      /* free routine, input */
                &symbolize_flags,       /* symbolize flags, input */
                0,      /* reserved */
                0,      /* reserved */
                0};     /* reserved */


    /* Walk the call stack top to bottom, symbolize each frame's PC, and
     * print out the symbolizations.
     *
     * First, create the invocation context block and get my (subc_handler's)
     * current context.
     */
    myICB = (INVO_CONTEXT_BLK *) lib$i64_create_invo_context ();
    status = lib$i64_get_curr_invo_context (myICB);
    status = 1;   // call above returns 0 ??

# ifdef __MAIN_TEST
    printf ("test: image       module     routine          line           PC\n");
# endif

    while (!(myICB->libicb$v_bottom_of_stack) &&
           ((status & 1) != 0))
        {
        /* Use the PC from the call stack invocation context block.
         */
        params.tbk$q_faulting_pc = (unsigned __int64) myICB->libicb$ih_pc;

        /* Call trace to do the symbolizations.
         */
        tbk_status = tbk$i64_symbolize (&params);

        /* And print out results
         */
        image [*((short *) image) + 2] = 0;
        module [*((short *) module) + 2] = 0;
        routine [*((short *) routine) + 2] = 0;

    if (2 == line_counter++)
         {
            int i;

            // Retrieve module name
            strncpy  ( name_pointer, module + 2, NAME_BUFFER_LENGTH - 1 );

            //Add ":" character
            strcat   ( name_pointer, ":" );

            // Add routine name

            i = strlen ( name_pointer );
            strncpy ( name_pointer+i, routine + 2, NAME_BUFFER_LENGTH - i );

            // Replace any character < space with space
            for ( i=0; i<NAME_BUFFER_LENGTH; i++ )
               if ( name_pointer[i] < ' ' ) name_pointer[i] = ' ';
         }

# ifdef __MAIN_TEST
        /* Print out the tbk$i64_symbolize info (with formating
         * to align columns).
         */
        if (*((short *) module) > 8)
            {
            if (*((short *) routine) > 8)
                {
                printf ("test: %s   %s    %s    %ld       %16.16LX\n",
                        &image [2],
                        &module [2],
                        &routine [2],
                        list_line,
                        (unsigned __int64) myICB->libicb$ih_pc);
                }
            else
                {
                printf ("test: %s     %s      %s    %ld      %16.16LX\n",
                        &image [2],
                        &module [2],
                        &routine [2],
                        list_line,
                        (unsigned __int64) myICB->libicb$ih_pc);
                }
            }

        else
            {
            if (*((short *) routine) > 8)
                {
                printf ("test: %s       %s       %s      %ld      %16.16LX\n",
                        &image [2],
                        &module [2],
                        &routine [2],
                        list_line,
                        (unsigned __int64) myICB->libicb$ih_pc);
                }
            else
                {
                printf ("test: %s       %s         %s         %ld      %16.16LX\n",
                        &image [2],
                        &module [2],
                        &routine [2],
                        list_line,
                        (unsigned __int64) myICB->libicb$ih_pc);
                }
            }
# endif

        /* Get the previous call frame.
         */
        status = lib$i64_get_prev_invo_context (myICB);
        callstack_depth++;
        }

    /* Terminate the call stack walk and free up the memory that it used.
     */
    lib$i64_prev_invo_end (myICB);
    lib$i64_free_invo_context (myICB);

# endif
} // GET_MODULE_INFO

# ifdef __ALPHA
/*
** stack_dump() - this prints out the stack-dump
**      If first dynamically activates TRACE.EXE
**      and finds the address of TBK$SHOW_TRACEBACK.
**      Note: TBK$SHOW_TRACEBACK says it needs the SP but by
**      looking at the 7.1 source listings it's not used.
*/

static void my_action_routine (struct dsc$descriptor *line)
    {
# ifdef __MAIN_TEST
    line->dsc$a_pointer[line->dsc$w_length]= 0;
    printf ("size: %2d, addr: %08x, text: %s\n",
         line->dsc$w_length, line->dsc$a_pointer, line->dsc$a_pointer);
# endif

    if (2 == line_counter++)
        {
           int i, len;

           // Find first non-blank character
           for ( i=0; i<line->dsc$w_length && line->dsc$a_pointer[i] < NAME_BUFFER_LENGTH; i++ )
              ;

           // skip image name
           strtok(&line->dsc$a_pointer[i], " \t");

           // Retrieve module name
           strncpy  ( name_pointer,   strtok(NULL, " \t"), NAME_BUFFER_LENGTH - 1);

           //Add ":" character
           strcat   ( name_pointer, ":" );

           // Add routine name

           i = strlen ( name_pointer );
           strncpy ( name_pointer+i, strtok(NULL, " \t"), NAME_BUFFER_LENGTH - i );

           // Replace any character < space with space
           for ( i=0; i<NAME_BUFFER_LENGTH; i++ )
              if ( name_pointer[i] < ' ' ) name_pointer[i] = ' ';
        }
    }
static void stack_dump(unsigned __int64 fp, unsigned __int64 pc)
    {
    unsigned long status;
    if (!tbk$show_traceback)
        {
        status = find_image_symbol("TRACE","TBK$SHOW_TRACEBACK",
                (void **)&tbk$show_traceback);
        if (!$VMS_STATUS_SUCCESS(status)) lib$signal(status);
        }
    if (tbk$show_traceback)
        {
/*        printf("%%MYTRACE-F-TRACEBACK, symbolic stack dump follows\n");
*/
        status = tbk$show_traceback(fp, /* FAULT FP */
                0,                      /* FAULT SP - NOT USED!!!! */
                pc,                     /* PC */
                0,                      /* detail flag */
                &my_action_routine,     /* User action routine */
                0);
        if (!$VMS_STATUS_SUCCESS(status)) lib$signal(status);
/*        printf("%%MYTRACE-I-END, end of MYTRACE stack dump\n\n\n");
*/
        }
    }


static unsigned long find_image_symbol(const char *image,
        const char *name, void **addr)
    {
    struct dsc$descriptor image_dsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S


};


    image_dsc.dsc$w_length = strlen(image);
    image_dsc.dsc$a_pointer = (char *)image;
    struct dsc$descriptor name_dsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S

};


    name_dsc.dsc$w_length = strlen(name);
    name_dsc.dsc$a_pointer = (char *)name;
    return lib$find_image_symbol(&image_dsc, &name_dsc, (void *)addr);
    }

# endif


# ifdef __MAIN_TEST
static void c() {
  char my_name[NAME_BUFFER_LENGTH + 1];
  GET_MODULE_INFO(my_name);
  printf ("my name is %s\n", my_name);
  }
static void b() { c(); }
static void a() { b(); }



int main()
    {
    a();
    }
# endif