home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v92.tgz / v92.tar / v92 / src / runtime / rdebug.r < prev    next >
Text File  |  1996-03-22  |  26KB  |  1,067 lines
  1. /*
  2.  * rdebug.r - tracebk, get_name, xdisp, ctrace, rtrace, failtrace, strace,
  3.  *   atrace, cotrace
  4.  */
  5.  
  6. /*
  7.  * Prototypes.
  8.  */
  9. hidden int     glbcmp    Params((char *pi, char *pj));
  10. hidden int     keyref    Params((union block *bp, dptr dp));
  11. hidden novalue showline  Params((char *f, int l));
  12. hidden novalue showlevel Params((register int n));
  13. hidden novalue ttrace    Params((noargs));
  14. hidden novalue xtrace
  15.    Params((struct b_proc *bp, word nargs, dptr arg, int pline, char *pfile));
  16.  
  17. /*
  18.  * tracebk - print a trace of procedure calls.
  19.  */
  20. #ifdef PresentationManager
  21. /* have to add COMPILER support too */
  22. novalue tracebk(void *foo, dptr argp, HWND hwndMLE)
  23. #else                    /* PresentationManager */
  24. novalue tracebk(lcl_pfp, argp)
  25.  
  26. #if COMPILER
  27. struct p_frame *lcl_pfp;
  28. #else                    /* COMPILER */
  29. struct pf_marker *lcl_pfp;
  30. #endif                    /* COMPILER */
  31.  
  32. dptr argp;
  33. #endif                    /* PresentationManager */
  34.    {
  35.    struct b_proc *cproc;
  36.  
  37. #if COMPILER
  38.  
  39.    struct debug *debug;
  40.    word nparam;
  41.  
  42.    if (lcl_pfp == NULL)
  43.       return;
  44.    debug = PFDebug(*lcl_pfp);
  45.    tracebk(lcl_pfp->old_pfp, lcl_pfp->old_argp);
  46.    cproc = debug->proc;
  47.    xtrace(cproc, (word)abs((int)cproc->nparam), argp, debug->old_line,
  48.       debug->old_fname);
  49.  
  50. #else                    /* COMPILER */
  51.  
  52.    struct pf_marker *origpfp = pfp;
  53.    dptr arg;
  54.    inst cipc;
  55.  
  56.    /*
  57.     * Chain back through the procedure frame markers, looking for the
  58.     *  first one, while building a foward chain of pointers through
  59.     *  the expression frame pointers.
  60.     */
  61.  
  62.    for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) {
  63.       (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp;
  64.       }
  65.  
  66.    /* Now start from the base procedure frame marker, producing a listing
  67.     *  of the procedure calls up through the last one.
  68.     */
  69.  
  70.    while (pfp) {
  71. #ifdef PresentationManager
  72.       /* point at the beginning of the string */
  73.       ConsoleStringBufPtr = ConsoleStringBuf;
  74. #endif                    /* PresentationManager */
  75.       arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1];
  76.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  77.       /*
  78.        * The ipc in the procedure frame points after the "invoke n".
  79.        */
  80.       cipc = pfp->pf_ipc;
  81.       --cipc.opnd;
  82.       --cipc.op;
  83.  
  84.       xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd),
  85.          findfile(cipc.opnd));
  86. #ifdef PresentationManager
  87.       /* insert the text in the MLE */
  88.       WinSendMsg(hwndMLE, MLM_INSERT, MPFROMP(ConsoleStringBuf), (MPARAM)0);
  89. #endif                    /* PresentationManager */
  90.       /*
  91.        * On the last call, show both the call and the offending expression.
  92.        */
  93.       if (pfp == origpfp) {
  94. #ifdef PresentationManager
  95.          /* make sure we are at the beginning of the buffer */
  96.          ConsoleStringBufPtr = ConsoleStringBuf;
  97.          ttrace();
  98.          /* add it to the MLE */
  99.          WinSendMsg(hwndMLE, MLM_INSERT, MPFROMP(ConsoleStringBuf), (MPARAM)0);
  100. #else                    /* PresentationManager */
  101.          ttrace();
  102. #endif                    /* PresentationManager */
  103.          break;
  104.          }
  105.  
  106.       pfp = (struct pf_marker *)(pfp->pf_efp);
  107.       }
  108. #endif                    /* COMPILER */
  109.    }
  110.  
  111. /*
  112.  * xtrace - procedure *bp is being called with nargs arguments, the first
  113.  *  of which is at arg; produce a trace message.
  114.  */
  115. static novalue xtrace(bp, nargs, arg, pline, pfile)
  116. struct b_proc *bp;
  117. word nargs;
  118. dptr arg;
  119. int pline;
  120. char *pfile;
  121.    {
  122.  
  123. #ifndef PresentationManager 
  124.    fprintf(stderr, "   ");
  125. #endif                    /* PresentationManager */
  126.    if (bp == NULL)
  127.       fprintf(stderr, "????");
  128.    else {
  129.  
  130. #if COMPILER
  131.        putstr(stderr, &(bp->pname));
  132. #else                    /* COMPILER */
  133.        if (arg[0].dword == D_Proc)
  134.           putstr(stderr, &(bp->pname));
  135.        else
  136.           outimage(stderr, arg, 0);
  137.        arg++;
  138. #endif                    /* COMPILER */
  139.  
  140.        putc('(', stderr);
  141.        while (nargs--) {
  142.           outimage(stderr, arg++, 0);
  143.           if (nargs)
  144.              putc(',', stderr);
  145.           }
  146.        putc(')', stderr);
  147.        }
  148.      
  149.    if (pline != 0)
  150.       fprintf(stderr, " from line %d in %s", pline, pfile);
  151.    putc('\n', stderr);
  152.    fflush(stderr);
  153.    }
  154.  
  155. /*
  156.  * get_name -- function to get print name of variable.
  157.  */
  158. int get_name(dp1,dp0)
  159.    dptr dp1, dp0;
  160.    {
  161.    dptr dp, varptr;
  162.    tended union block *blkptr;
  163.    dptr arg1;                           /* 1st parameter */
  164.    dptr loc1;                           /* 1st local */
  165.    struct b_proc *proc;                 /* address of procedure block */
  166.    char sbuf[100];            /* buffer; might be too small */
  167.    char *s, *s2;
  168.    word i, j, k;
  169.    int t;
  170.  
  171. #if COMPILER
  172.    arg1 = argp;
  173.    loc1 = pfp->tend.d;
  174.    proc = PFDebug(*pfp)->proc;
  175. #else                    /* COMPILER */
  176.    arg1 = &argp[1];
  177.    loc1 = pfp->pf_locals;
  178.    proc = &BlkLoc(*argp)->proc;
  179. #endif                    /* COMPILER */
  180.  
  181.    type_case *dp1 of {
  182.       tvsubs: {
  183.          blkptr = BlkLoc(*dp1);
  184.          get_name(&(blkptr->tvsubs.ssvar),dp0);
  185.          sprintf(sbuf,"[%ld:%ld]",blkptr->tvsubs.sspos,
  186.             blkptr->tvsubs.sspos+blkptr->tvsubs.sslen);
  187.          k = StrLen(*dp0);
  188.          j = strlen(sbuf);
  189.  
  190.      /*
  191.       * allocate space for both the name and the subscript image,
  192.       *  and then copy both parts into the allocated space
  193.       */
  194.      Protect(s = alcstr(NULL, k + j), return Error);
  195.      s2 = StrLoc(*dp0);
  196.      StrLoc(*dp0) = s;
  197.          StrLen(*dp0) = j + k;
  198.      for (i = 0; i < k; i++)
  199.         *s++ = *s2++;
  200.      s2 = sbuf;
  201.      for (i = 0; i < j; i++)
  202.         *s++ = *s2++;
  203.          }
  204.  
  205.       tvtbl: {
  206.          t = keyref(BlkLoc(*dp1) ,dp0);
  207.          if (t == Error)
  208.             return Error;
  209.           }
  210.  
  211.       kywdint:
  212.          if (VarLoc(*dp1) == &kywd_ran) {
  213.             StrLen(*dp0) = 7;
  214.             StrLoc(*dp0) = "&random";
  215.             }
  216.          else if (VarLoc(*dp1) == &kywd_trc) {
  217.             StrLen(*dp0) = 6;
  218.             StrLoc(*dp0) = "&trace";
  219.             }
  220.  
  221. #ifdef FncTrace
  222.          else if (VarLoc(*dp1) == &kywd_ftrc) {
  223.             StrLen(*dp0) = 7;
  224.             StrLoc(*dp0) = "&ftrace";
  225.             }
  226. #endif                    /* FncTrace */
  227.  
  228.          else if (VarLoc(*dp1) == &kywd_dmp) {
  229.             StrLen(*dp0) = 5;
  230.             StrLoc(*dp0) = "&dump";
  231.             }
  232.          else if (VarLoc(*dp1) == &kywd_err) {
  233.             StrLen(*dp0) = 6;
  234.             StrLoc(*dp0) = "&error";
  235.             }
  236.          else
  237.             syserr("name: unknown integer keyword variable");
  238.             
  239.       kywdevent:
  240. #ifdef MultiThread
  241.          if (VarLoc(*dp1) == &curpstate->eventsource) {
  242.             StrLen(*dp0) = 12;
  243.             StrLoc(*dp0) = "&eventsource";
  244.             }
  245.          else if (VarLoc(*dp1) == &curpstate->eventval) {
  246.             StrLen(*dp0) = 11;
  247.             StrLoc(*dp0) = "&eventvalue";
  248.             }
  249.          else if (VarLoc(*dp1) == &curpstate->eventcode) {
  250.             StrLen(*dp0) = 10;
  251.             StrLoc(*dp0) = "&eventcode";
  252.             }
  253.          else
  254. #endif                    /* MultiThread */
  255.             syserr("name: unknown event keyword variable");
  256.             
  257.       kywdwin: {
  258.          StrLen(*dp0) = 7;
  259.          StrLoc(*dp0) = "&window";
  260.          }
  261.  
  262.       kywdstr: {
  263.          StrLen(*dp0) = 9;
  264.          StrLoc(*dp0) = "&progname";
  265.          }
  266.  
  267.       kywdpos: {
  268.          StrLen(*dp0) = 4;
  269.          StrLoc(*dp0) = "&pos";
  270.          }
  271.  
  272.       kywdsubj: {
  273.          StrLen(*dp0) = 8;
  274.          StrLoc(*dp0) = "&subject";
  275.          }
  276.  
  277.       default:
  278.          if (Offset(*dp1) == 0) {
  279.             /*
  280.              * Must be a named variable.
  281.              */
  282.             dp = VarLoc(*dp1);         /* get address of variable */
  283.             if (InRange(globals,dp,eglobals)) {
  284.                *dp0 = gnames[dp - globals];         /* global */
  285.            return GlobalName;
  286.            }
  287.             else if (InRange(statics,dp,estatics)) {
  288.                i = dp - statics - proc->fstatic;    /* static */
  289.                if (i < 0 || i >= proc->nstatic)
  290.                   syserr("name: unreferencable static variable");
  291.                i += abs((int)proc->nparam) + abs((int)proc->ndynam);
  292.                *dp0 = proc->lnames[i];
  293.            return StaticName;
  294.                }
  295.             else if (InRange(arg1, dp, &arg1[abs((int)proc->nparam)])) {
  296.                *dp0 = proc->lnames[dp - arg1];          /* argument */
  297.            return ParamName;
  298.            }
  299.             else if (InRange(loc1, dp, &loc1[proc->ndynam])) {
  300.                *dp0 = proc->lnames[dp - loc1 + abs((int)proc->nparam)];
  301.            return LocalName;
  302.                }
  303.             else
  304.                syserr("name: cannot determine variable name");
  305.             }
  306.          else {
  307.             /*
  308.              * Must be an element of a structure.
  309.              */
  310.             blkptr = (union block *)VarLoc(*dp1);
  311.             varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1));
  312.             switch ((int)BlkType(blkptr)) {
  313.                case T_Lelem:         /* list */
  314.                   i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1;
  315.                   if (i < 1)
  316.                      i += blkptr->lelem.nslots;
  317.                   while (blkptr->lelem.listprev != NULL) {
  318.                      blkptr = blkptr->lelem.listprev;
  319.                      i += blkptr->lelem.nused;
  320.                      }
  321.                   sprintf(sbuf,"L[%ld]",i);
  322.                   i = strlen(sbuf);
  323.                   Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error);
  324.                   StrLen(*dp0) = i;
  325.                   break;
  326.                case T_Record:         /* record */
  327.                   i = varptr - blkptr->record.fields;
  328.                   proc = &blkptr->record.recdesc->proc;
  329.  
  330.                   sprintf(sbuf,"%s.%s",StrLoc(proc->recname),
  331.                       StrLoc(proc->lnames[i]));
  332.  
  333.                   i = strlen(sbuf);
  334.                   Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error);
  335.                   StrLen(*dp0) = i;
  336.                   break;
  337.                case T_Telem:         /* table */
  338.                   t = keyref(blkptr,dp0);
  339.                   if (t == Error)
  340.                       return Error;
  341.                   break;
  342.                default:        /* none of the above */
  343. #ifdef EventMon
  344.                   *dp0 = emptystr;
  345. #else                                   /* EventMon */
  346.                   syserr("name: invalid structure reference");
  347. #endif                                  /* EventMon */
  348.  
  349.                }
  350.            }
  351.       }
  352.    return Succeeded;
  353.    }
  354.  
  355. #if COMPILER
  356. #begdef PTraceSetup()
  357.    struct b_proc *proc;
  358.  
  359.    --k_trace;
  360.    showline(file_name, line_num);
  361.    showlevel(k_level);
  362.    proc = PFDebug(*pfp)->proc; /* get address of procedure block */
  363.    putstr(stderr, &proc->pname);
  364. #enddef
  365.  
  366. /*
  367.  * ctrace - a procedure is being called; produce a trace message.
  368.  */
  369. novalue ctrace()
  370.    {
  371.    dptr arg;
  372.    int n;
  373.  
  374.    PTraceSetup();
  375.  
  376.    putc('(', stderr);
  377.    arg = argp;
  378.    n = abs((int)proc->nparam);
  379.    while (n--) {
  380.       outimage(stderr, arg++, 0);
  381.       if (n)
  382.          putc(',', stderr);
  383.       }
  384.    putc(')', stderr);
  385.    putc('\n', stderr);
  386.    fflush(stderr);
  387.    }
  388.  
  389. /*
  390.  * rtrace - a procedure is returning; produce a trace message.
  391.  */
  392.  
  393. novalue rtrace()
  394.    {
  395.    PTraceSetup();
  396.  
  397.    fprintf(stderr, " returned ");
  398.    outimage(stderr, pfp->rslt, 0);
  399.    putc('\n', stderr);
  400.    fflush(stderr);
  401.    }
  402.  
  403. /*
  404.  * failtrace - procedure named s is failing; produce a trace message.
  405.  */
  406.  
  407. novalue failtrace()
  408.    {
  409.    PTraceSetup();
  410.  
  411.    fprintf(stderr, " failed\n");
  412.    fflush(stderr);
  413.    }
  414.  
  415. /*
  416.  * strace - a procedure is suspending; produce a trace message.
  417.  */
  418.  
  419. novalue strace()
  420.    {
  421.    PTraceSetup();
  422.  
  423.    fprintf(stderr, " suspended ");
  424.    outimage(stderr, pfp->rslt, 0);
  425.    putc('\n', stderr);
  426.    fflush(stderr);
  427.    }
  428.  
  429. /*
  430.  * atrace - a procedure is being resumed; produce a trace message.
  431.  */
  432. novalue atrace()
  433.    {
  434.    PTraceSetup();
  435.  
  436.    fprintf(stderr, " resumed\n");
  437.    fflush(stderr);
  438.    }
  439. #endif                    /* COMPILER */
  440.  
  441. /*
  442.  * keyref(bp,dp) -- print name of subscripted table
  443.  */
  444. static int keyref(bp, dp)
  445.    union block *bp;
  446.    dptr dp;
  447.    {
  448.    char *s, *s2;
  449.    int i, len;
  450.  
  451.    if (getimage(&(bp->telem.tref),dp) == Error)
  452.       return Error;    
  453.  
  454.    /*
  455.     * Allocate space, and copy the image surrounded by "T[" and "]"
  456.     */
  457.    Protect(s = alcstr(NULL, StrLen(*dp) + 3), return Error);
  458.    s2 = StrLoc(*dp);
  459.    len = StrLen(*dp);
  460.    StrLoc(*dp) = s;
  461.    StrLen(*dp) = StrLen(*dp) + 3;
  462.    *s++ = 'T'; *s++ = '[';
  463.    for (i = 0; i < len; i++)
  464.       *s++ = *s2++;
  465.    *s++ = ']';
  466.    return Succeeded;
  467.    }
  468.  
  469. #ifdef Coexpr
  470. /*
  471.  * cotrace -- a co-expression context switch; produce a trace message.
  472.  */
  473. novalue cotrace(ccp, ncp, swtch_typ, valloc)
  474. struct b_coexpr *ccp;
  475. struct b_coexpr *ncp;
  476. int swtch_typ;
  477. dptr valloc;
  478.    {
  479.    struct b_proc *proc;
  480.  
  481. #if !COMPILER
  482.    inst t_ipc;
  483. #endif                    /* !COMPILER */
  484.  
  485.    --k_trace;
  486.  
  487. #if COMPILER
  488.    showline(ccp->file_name, ccp->line_num);
  489.    proc = PFDebug(*ccp->es_pfp)->proc;     /* get address of procedure block */
  490. #else                    /* COMPILER */
  491.  
  492.    /*
  493.     * Compute the ipc of the instruction causing the context switch.
  494.     */
  495.    t_ipc.op = ipc.op - 1;
  496.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  497.    proc = (struct b_proc *)BlkLoc(*argp);
  498. #endif                    /* COMPILER */
  499.  
  500.    showlevel(k_level);
  501.    putstr(stderr, &proc->pname);
  502.    fprintf(stderr,"; co-expression_%ld ", (long)ccp->id);
  503.    switch (swtch_typ) {
  504.       case A_Coact:
  505.          fprintf(stderr,": ");
  506.          outimage(stderr, valloc, 0);
  507.          fprintf(stderr," @ ");
  508.          break;
  509.       case A_Coret:
  510.          fprintf(stderr,"returned ");
  511.          outimage(stderr, valloc, 0);
  512.          fprintf(stderr," to ");
  513.          break;
  514.       case A_Cofail:
  515.          fprintf(stderr,"failed to ");
  516.          break;
  517.       }
  518.    fprintf(stderr,"co-expression_%ld\n", (long)ncp->id);
  519.    fflush(stderr);
  520.    }
  521. #endif                    /* Coexpr */
  522.  
  523. /*
  524.  * showline - print file and line number information.
  525.  */
  526. static novalue showline(f, l)
  527. char *f;
  528. int l;
  529.    {
  530.    int i;
  531.  
  532.    i = (int)strlen(f);
  533.  
  534. #if MVS
  535.    while (i > 22) {
  536. #else                    /* MVS */
  537.    while (i > 13) {
  538. #endif                    /* MVS */
  539.       f++;
  540.       i--;
  541.       }
  542.    if (l > 0)
  543.  
  544. #if MVS
  545.       fprintf(stderr, "%-22s: %4d  ",f, l);
  546.    else
  547.       fprintf(stderr, "                      :      ");
  548. #else                    /* MVS */
  549.       fprintf(stderr, "%-13s: %4d  ",f, l);
  550.    else
  551.       fprintf(stderr, "             :       ");
  552. #endif                    /* MVS */
  553.  
  554.    }
  555.  
  556. /*
  557.  * showlevel - print "| " n times.
  558.  */
  559. static novalue showlevel(n)
  560. register int n;
  561.    {
  562.    while (n-- > 0) {
  563.       putc('|', stderr);
  564.       putc(' ', stderr);
  565.       }
  566.    }
  567.  
  568. #if !COMPILER
  569.  
  570. #include "::h:opdefs.h"
  571.  
  572.  
  573. extern struct b_list value_tmp;        /* argument of Op_Apply */
  574. extern struct b_proc *opblks[];
  575.  
  576.  
  577. /*
  578.  * ttrace - show offending expression.
  579.  */
  580. hidden novalue ttrace()
  581.    {
  582.    struct b_proc *bp;
  583.    word nargs;
  584.  
  585. #ifndef PresentationManager
  586.    fprintf(stderr, "   ");
  587. #endif                    /* PresentationManager */
  588.  
  589.    switch ((int)lastop) {
  590.  
  591.       case Op_Keywd:
  592.          fprintf(stderr,"bad keyword reference");
  593.          break;
  594.  
  595.       case Op_Invoke:
  596.          bp = (struct b_proc *)BlkLoc(*xargp);
  597.          nargs = xnargs;
  598.          if (xargp[0].dword == D_Proc)
  599.             putstr(stderr, &(bp->pname));
  600.          else
  601.             outimage(stderr, xargp, 0);
  602.          putc('(', stderr);
  603.          while (nargs--) {
  604.             outimage(stderr, ++xargp, 0);
  605.             if (nargs)
  606.                putc(',', stderr);
  607.             }
  608.          putc(')', stderr);
  609.          break;
  610.  
  611.       case Op_Toby:
  612.          putc('{', stderr);
  613.          outimage(stderr, ++xargp, 0);
  614.          fprintf(stderr, " to ");
  615.          outimage(stderr, ++xargp, 0);
  616.          fprintf(stderr, " by ");
  617.          outimage(stderr, ++xargp, 0);
  618.          putc('}', stderr);
  619.          break;
  620.  
  621.       case Op_Subsc:
  622.          putc('{', stderr);
  623.          outimage(stderr, ++xargp, 0);
  624.  
  625. #if EBCDIC != 1
  626.          putc('[', stderr);
  627. #else                    /* EBCDIC != 1 */
  628.          putc('$', stderr);
  629.          putc('<', stderr);
  630. #endif                    /* EBCDIC != 1 */
  631.  
  632.          outimage(stderr, ++xargp, 0);
  633.  
  634. #if EBCDIC != 1
  635.          putc(']', stderr);
  636. #else                    /* EBCDIC != 1 */
  637.          putc('$', stderr);
  638.          putc('>', stderr);
  639. #endif                    /* EBCDIC != 1 */
  640.  
  641.          putc('}', stderr);
  642.          break;
  643.  
  644.       case Op_Sect:
  645.          putc('{', stderr);
  646.          outimage(stderr, ++xargp, 0);
  647.  
  648. #if EBCDIC != 1
  649.          putc('[', stderr);
  650. #else                    /* EBCDIC != 1 */
  651.          putc('$', stderr);
  652.          putc('<', stderr);
  653. #endif                    /* EBCDIC != 1 */
  654.  
  655.          outimage(stderr, ++xargp, 0);
  656.          putc(':', stderr);
  657.          outimage(stderr, ++xargp, 0);
  658.  
  659. #if EBCDIC != 1
  660.          putc(']', stderr);
  661. #else                    /* EBCDIC != 1 */
  662.          putc('$', stderr);
  663.          putc('>', stderr);
  664. #endif                    /* EBCDIC != 1 */
  665.  
  666.          putc('}', stderr);
  667.          break;
  668.  
  669.       case Op_Bscan:
  670.          putc('{', stderr);
  671.          outimage(stderr, xargp, 0);
  672.          fputs(" ? ..}", stderr);
  673.          break;
  674.  
  675.       case Op_Coact:
  676.          putc('{', stderr);
  677.          outimage(stderr, ++xargp, 0);
  678.          fprintf(stderr, " @ ");
  679.          outimage(stderr, ++xargp, 0);
  680.          putc('}', stderr);
  681.          break;
  682.  
  683.       case Op_Apply:
  684.          outimage(stderr, xargp++, 0);
  685.          fprintf(stderr," ! ");
  686.          outimage(stderr, (dptr)&value_tmp, 0);
  687.          break;
  688.  
  689.       case Op_Create:
  690.          fprintf(stderr,"{create ..}");
  691.          break;
  692.  
  693.       case Op_Field:
  694.          putc('{', stderr);
  695.          outimage(stderr, ++xargp, 0);
  696.          fprintf(stderr, " . ");
  697.      ++xargp;
  698.      if (IntVal(*xargp) == -1)
  699.             fprintf(stderr, "field");
  700.      else
  701.             fprintf(stderr, "%s", StrLoc(fnames[IntVal(*xargp)]));
  702.          putc('}', stderr);
  703.          break;
  704.  
  705.       case Op_Limit:
  706.          fprintf(stderr, "limit counter: ");
  707.          outimage(stderr, xargp, 0);
  708.          break;
  709.  
  710.       case Op_Llist:
  711.  
  712. #if EBCDIC != 1
  713.          fprintf(stderr,"[ ... ]");
  714. #else                    /* EBCDIC != 1 */
  715.          fputs("$< ... $>", stderr);
  716. #endif                    /* EBCDIC != 1 */
  717.          break;
  718.  
  719.    
  720.       default:
  721.  
  722.          bp = opblks[lastop];
  723.          nargs = abs((int)bp->nparam);
  724.          putc('{', stderr);
  725.          if (lastop == Op_Bang || lastop == Op_Random)
  726.             goto oneop;
  727.          if (abs((int)bp->nparam) >= 2) {
  728.             outimage(stderr, ++xargp, 0);
  729.             putc(' ', stderr);
  730.             putstr(stderr, &(bp->pname));
  731.             putc(' ', stderr);
  732.            }
  733.          else
  734. oneop:
  735.          putstr(stderr, &(bp->pname));
  736.          outimage(stderr, ++xargp, 0);
  737.          putc('}', stderr);
  738.       }
  739.      
  740.    if (ipc.opnd != NULL)
  741.       fprintf(stderr, " from line %d in %s", findline(ipc.opnd),
  742.          findfile(ipc.opnd));
  743. #ifndef PresentationManager
  744.    putc('\n', stderr);
  745. #endif                    /* PresentationManager */
  746.    fflush(stderr);
  747.    }
  748.  
  749.  
  750. /*
  751.  * ctrace - procedure named s is being called with nargs arguments, the first
  752.  *  of which is at arg; produce a trace message.
  753.  */
  754. novalue ctrace(dp, nargs, arg)
  755. dptr dp;
  756. int nargs;
  757. dptr arg;
  758.    {
  759.  
  760.    showline(findfile(ipc.opnd), findline(ipc.opnd));
  761.    showlevel(k_level);
  762.    putstr(stderr, dp);
  763.    putc('(', stderr);
  764.    while (nargs--) {
  765.       outimage(stderr, arg++, 0);
  766.       if (nargs)
  767.          putc(',', stderr);
  768.       }
  769.    putc(')', stderr);
  770.    putc('\n', stderr);
  771.    fflush(stderr);
  772.    }
  773.  
  774. /*
  775.  * rtrace - procedure named s is returning *rval; produce a trace message.
  776.  */
  777.  
  778. novalue rtrace(dp, rval)
  779. dptr dp;
  780. dptr rval;
  781.    {
  782.    inst t_ipc;
  783.  
  784.    /*
  785.     * Compute the ipc of the return instruction.
  786.     */
  787.    t_ipc.op = ipc.op - 1;
  788.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  789.    showlevel(k_level);
  790.    putstr(stderr, dp);
  791.    fprintf(stderr, " returned ");
  792.    outimage(stderr, rval, 0);
  793.    putc('\n', stderr);
  794.    fflush(stderr);
  795.    }
  796.  
  797. /*
  798.  * failtrace - procedure named s is failing; produce a trace message.
  799.  */
  800.  
  801. novalue failtrace(dp)
  802. dptr dp;
  803.    {
  804.    inst t_ipc;
  805.  
  806.    /*
  807.     * Compute the ipc of the fail instruction.
  808.     */
  809.    t_ipc.op = ipc.op - 1;
  810.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  811.    showlevel(k_level);
  812.    putstr(stderr, dp);
  813.    fprintf(stderr, " failed");
  814.    putc('\n', stderr);
  815.    fflush(stderr);
  816.    }
  817.  
  818. /*
  819.  * strace - procedure named s is suspending *rval; produce a trace message.
  820.  */
  821.  
  822. novalue strace(dp, rval)
  823. dptr dp;
  824. dptr rval;
  825.    {
  826.    inst t_ipc;
  827.  
  828.    /*
  829.     * Compute the ipc of the suspend instruction.
  830.     */
  831.    t_ipc.op = ipc.op - 1;
  832.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  833.    showlevel(k_level);
  834.    putstr(stderr, dp);
  835.    fprintf(stderr, " suspended ");
  836.    outimage(stderr, rval, 0);
  837.    putc('\n', stderr);
  838.    fflush(stderr);
  839.    }
  840.  
  841. /*
  842.  * atrace - procedure named s is being resumed; produce a trace message.
  843.  */
  844.  
  845. novalue atrace(dp)
  846. dptr dp;
  847.    {
  848.    inst t_ipc;
  849.  
  850.    /*
  851.     * Compute the ipc of the instruction causing resumption.
  852.     */
  853.    t_ipc.op = ipc.op - 1;
  854.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  855.    showlevel(k_level);
  856.    putstr(stderr, dp);
  857.    fprintf(stderr, " resumed");
  858.    putc('\n', stderr);
  859.    fflush(stderr);
  860.    }
  861.  
  862. #ifdef Coexpr
  863. /*
  864.  * coacttrace -- co-expression is being activated; produce a trace message.
  865.  */
  866. novalue coacttrace(ccp, ncp)
  867. struct b_coexpr *ccp;
  868. struct b_coexpr *ncp;
  869.    {
  870.    struct b_proc *bp;
  871.    inst t_ipc;
  872.  
  873.    bp = (struct b_proc *)BlkLoc(*argp);
  874.    /*
  875.     * Compute the ipc of the activation instruction.
  876.     */
  877.    t_ipc.op = ipc.op - 1;
  878.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  879.    showlevel(k_level);
  880.    putstr(stderr, &(bp->pname));
  881.    fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id);
  882.    outimage(stderr, (dptr)(sp - 3), 0);
  883.    fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id);
  884.    fflush(stderr);
  885.    }
  886.  
  887. /*
  888.  * corettrace -- return from co-expression; produce a trace message.
  889.  */
  890. novalue corettrace(ccp, ncp)
  891. struct b_coexpr *ccp;
  892. struct b_coexpr *ncp;
  893.    {
  894.    struct b_proc *bp;
  895.    inst t_ipc;
  896.  
  897.    bp = (struct b_proc *)BlkLoc(*argp);
  898.    /*
  899.     * Compute the ipc of the coret instruction.
  900.     */
  901.    t_ipc.op = ipc.op - 1;
  902.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  903.    showlevel(k_level);
  904.    putstr(stderr, &(bp->pname));
  905.    fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id);
  906.    outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0);
  907.    fprintf(stderr," to co-expression_%ld\n", (long)ncp->id);
  908.    fflush(stderr);
  909.    }
  910.  
  911. /*
  912.  * cofailtrace -- failure return from co-expression; produce a trace message.
  913.  */
  914. novalue cofailtrace(ccp, ncp)
  915. struct b_coexpr *ccp;
  916. struct b_coexpr *ncp;
  917.    {
  918.    struct b_proc *bp;
  919.    inst t_ipc;
  920.  
  921.    bp = (struct b_proc *)BlkLoc(*argp);
  922.    /*
  923.     * Compute the ipc of the cofail instruction.
  924.     */
  925.    t_ipc.op = ipc.op - 1;
  926.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  927.    showlevel(k_level);
  928.    putstr(stderr, &(bp->pname));
  929.    fprintf(stderr,"; co-expression_%ld failed to co-expression_%ld\n",
  930.       (long)ccp->id, (long)ncp->id);
  931.    fflush(stderr);
  932.    }
  933. #endif                    /* Coexpr */
  934. #endif                    /* !COMPILER */
  935.  
  936. /*
  937.  * Service routine to display variables in given number of
  938.  *  procedure calls to file f.
  939.  */
  940.  
  941. int xdisp(fp,dp,count,f)
  942. #if COMPILER
  943.    struct p_frame *fp;
  944. #else                    /* COMPILER */
  945.    struct pf_marker *fp;
  946. #endif                    /* COMPILER */
  947.    register dptr dp;
  948.    int count;
  949.    FILE *f;
  950.    {
  951.    register dptr np;
  952.    register int n;
  953.    struct b_proc *bp;
  954.    word nglobals, *indices;
  955.  
  956.    while (count--) {        /* go back through 'count' frames */
  957.       if (fp == NULL)
  958.          break;       /* needed because &level is wrong in co-expressions */
  959.  
  960. #if COMPILER
  961.       bp = PFDebug(*fp)->proc;    /* get address of procedure block */
  962. #else                    /* COMPILER */
  963.       bp = (struct b_proc *)BlkLoc(*dp++); /* get addr of procedure block */
  964.       /* #%#% was: no post-increment there, but *pre*increment dp below */
  965. #endif                    /* COMPILER */
  966.  
  967.       /*
  968.        * Print procedure name.
  969.        */
  970.       putstr(f, &(bp->pname));
  971.       fprintf(f, " local identifiers:\n");
  972.  
  973.       /*
  974.        * Print arguments.
  975.        */
  976.       np = bp->lnames;
  977.       for (n = abs((int)bp->nparam); n > 0; n--) {
  978.          fprintf(f, "   ");
  979.          putstr(f, np);
  980.          fprintf(f, " = ");
  981.          outimage(f, dp++, 0);
  982.          putc('\n', f);
  983.          np++;
  984.          }
  985.  
  986.       /*
  987.        * Print locals.
  988.        */
  989. #if COMPILER
  990.       dp = fp->tend.d;
  991. #else                    /* COMPILER */
  992.       dp = &fp->pf_locals[0];
  993. #endif                    /* COMPILER */
  994.       for (n = bp->ndynam; n > 0; n--) {
  995.          fprintf(f, "   ");
  996.          putstr(f, np);
  997.          fprintf(f, " = ");
  998.          outimage(f, dp++, 0);
  999.          putc('\n', f);
  1000.          np++;
  1001.          }
  1002.  
  1003.       /*
  1004.        * Print statics.
  1005.        */
  1006.       dp = &statics[bp->fstatic];
  1007.       for (n = bp->nstatic; n > 0; n--) {
  1008.          fprintf(f, "   ");
  1009.          putstr(f, np);
  1010.          fprintf(f, " = ");
  1011.          outimage(f, dp++, 0);
  1012.          putc('\n', f);
  1013.          np++;
  1014.          }
  1015.  
  1016. #if COMPILER
  1017.       dp = fp->old_argp;
  1018.       fp = fp->old_pfp;
  1019. #else                    /* COMPILER */
  1020.       dp = fp->pf_argp;
  1021.       fp = fp->pf_pfp;
  1022. #endif                    /* COMPILER */
  1023.       }
  1024.  
  1025.    /*
  1026.     * Print globals.  Sort names in lexical order using temporary index array.
  1027.     */
  1028.  
  1029. #if COMPILER
  1030.    nglobals = n_globals;
  1031. #else                    /* COMPILER */
  1032.    nglobals = eglobals - globals;
  1033. #endif                    /* COMPILER */
  1034.  
  1035.    indices = (word *)malloc((msize)nglobals * sizeof(word));
  1036.    if (indices == NULL)
  1037.       return Failed;
  1038.    else {
  1039.       for (n = 0; n < nglobals; n++)
  1040.          indices[n] = n;
  1041.       qsort ((char*)indices, (int)nglobals, sizeof(word), (int (*)())glbcmp);
  1042.       fprintf(f, "\nglobal identifiers:\n");
  1043.       for (n = 0; n < nglobals; n++) {
  1044.          fprintf(f, "   ");
  1045.          putstr(f, &gnames[indices[n]]);
  1046.          fprintf(f, " = ");
  1047.          outimage(f, &globals[indices[n]], 0);
  1048.          putc('\n', f);
  1049.          }
  1050.       fflush(f);
  1051.       free((pointer)indices);
  1052.       }
  1053.    return Succeeded;
  1054.    }
  1055.  
  1056. /*
  1057.  * glbcmp - compare the names of two globals using their temporary indices.
  1058.  */
  1059. static int glbcmp (pi, pj)
  1060. char *pi, *pj;
  1061.    {
  1062.    register word i = *(word *)pi;
  1063.    register word j = *(word *)pj;
  1064.    return lexcmp(&gnames[i], &gnames[j]);
  1065.    }
  1066.  
  1067.