home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Rmisc < prev    next >
Encoding:
Text File  |  1990-07-19  |  51.1 KB  |  2,060 lines
  1. /*
  2.  * File: rmisc.c
  3.  *  Contents: deref, eq, [gcvt], getvar, hash, outimage, [qsort],
  4.  *  qtos, trace, pushact, popact, topact, [dumpact], putpos, putsub, putint,
  5.  *  findline, findipc, findfile, [llqsort], doimage, prescan, getimage
  6.  *  printable.
  7.  *
  8.  *  Integer overflow checking.
  9.  */
  10.  
  11. #ifdef IconAlloc
  12. #define free mem_free
  13. #endif                    /* IconAlloc */
  14.  
  15. #include <math.h>
  16. #include "../h/config.h"
  17. #include "../h/rt.h"
  18. #include "rproto.h"
  19. #include <ctype.h>
  20.  
  21. /*
  22.  * Prototypes.
  23.  */
  24.  
  25. hidden novalue    listimage
  26.    Params((FILE *f,struct b_list *lp, int restrict));
  27. hidden novalue    printimage    Params((FILE *f,int c,int q));
  28.  
  29. #ifdef IconQsort
  30. hidden novalue    qswap        Params((char *a, char *b, int w));
  31. #endif                    /* IconQsort */
  32.  
  33. hidden novalue    showlevel    Params((int n));
  34. hidden novalue    showline    Params((char *f,int l));
  35.  
  36. /*
  37.  * deref - dereference a descriptor.
  38.  */
  39.  
  40. int deref(dp)
  41. dptr dp;
  42.    {
  43.    register uword hn;
  44.    register union block *bp;
  45.    struct descrip v, tref;
  46.    union block *tbl;
  47.  
  48.    if (!Tvar(*dp))
  49.        /*
  50.        * An ordinary variable is being dereferenced; just replace
  51.        *  *dp with the descriptor *dp is pointing to.
  52.        */
  53.       *dp = *(dptr)((word *)VarLoc(*dp) + Offset(*dp));
  54.    else switch (Type(*dp)) {
  55.  
  56.          case T_Tvsubs:
  57.             /*
  58.              * A substring trapped variable is being dereferenced.
  59.              *  Point bp to the trapped variable block and v to
  60.              *  the string.
  61.              */
  62.             bp = TvarLoc(*dp);
  63.             v = bp->tvsubs.ssvar;
  64.             if (DeRef(v) == Error)
  65.                return Error;
  66.             if (!Qual(v))
  67.                RetError(103, v);
  68.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
  69.                RetError(-205, nulldesc);
  70.             /*
  71.              * Make a descriptor for the substring by getting the
  72.              *  length and pointing into the string.
  73.              */
  74.             StrLen(*dp) = bp->tvsubs.sslen;
  75.             StrLoc(*dp) = StrLoc(v) + bp->tvsubs.sspos - 1;
  76.             break;
  77.  
  78.          case T_Tvtbl:
  79.             if (BlkLoc(*dp)->tvtbl.title == T_Telem) {
  80.                /*
  81.                 * The tvtbl has been converted to a telem and is
  82.                 *  in the table.  Replace the descriptor pointed to
  83.                 *  by dp with the value of the element.
  84.                 */
  85.                 *dp = BlkLoc(*dp)->telem.tval;
  86.                 break;
  87.                 }
  88.  
  89.             /*
  90.              *  Point tbl to the table header block, tref to the
  91.              *  subscripting value, and bp to the appropriate 
  92.              *  chain.  Point dp to a descriptor for the default
  93.              *  value in case the value referenced by the subscript
  94.              *  is not in the table.
  95.              */
  96.             tbl = BlkLoc(*dp)->tvtbl.clink;
  97.             tref = BlkLoc(*dp)->tvtbl.tref;
  98.             hn = BlkLoc(*dp)->tvtbl.hashnum;
  99.             *dp = tbl->table.defvalue;
  100.             bp = *(hchain((union block *)tbl, hn));
  101.  
  102.             /*
  103.              * Traverse the element chain looking for the subscript
  104.              *  value.  If found, replace the descriptor pointed to
  105.              *  by dp with the value of the element.
  106.              */
  107.             while (bp != NULL && bp->telem.hashnum <= hn) {
  108.                if ((bp->telem.hashnum == hn) &&
  109.                   (equiv(&bp->telem.tref, &tref))) {
  110.                      *dp = bp->telem.tval;
  111.                      break;
  112.                      }
  113.                bp = bp->telem.clink;
  114.                }
  115.             break;
  116.  
  117.          case T_Tvkywd:
  118.             bp = TvarLoc(*dp);
  119.             *dp = bp->tvkywd.kyval;
  120.             break;
  121.  
  122.          default:
  123.             syserr("deref: illegal trapped variable");
  124.          }
  125.  
  126. #ifdef DeBugIconx
  127.    if (Var(*dp))
  128.       syserr("deref: didn't get dereferenced");
  129. #endif                    /* DeBugIconx */
  130.  
  131.    return Success;
  132.    }
  133.  
  134. #ifdef IconGcvt
  135. /*
  136.  * gcvt - Convert number to a string in buf.  If possible, ndigit
  137.  *  significant digits are produced, otherwise a form with an exponent is used.
  138.  *
  139.  *  The name is actually #defined as "icon_gcvt" in config.h.
  140.  */
  141. char *gcvt(number, ndigit, buf)
  142. double number;
  143. int ndigit;
  144. char *buf;
  145.    {
  146.    int sign, decpt;
  147.    register char *p1, *p2;
  148.    register i;
  149.  
  150.    p1 = ecvt(number, ndigit, &decpt, &sign);
  151.    p2 = buf;
  152.    if (sign)
  153.       *p2++ = '-';
  154.    for (i=ndigit-1; i>0 && p1[i]=='0'; i--)
  155.       ndigit--;
  156.    if (decpt >= 0 && decpt-ndigit > 4
  157.       || decpt < 0 && decpt < -3) { /* use E-style */
  158.          decpt--;
  159.          *p2++ = *p1++;
  160.          *p2++ = '.';
  161.          for (i=1; i<ndigit; i++)
  162.             *p2++ = *p1++;
  163.          *p2++ = 'e';
  164.          if (decpt<0) {
  165.             decpt = -decpt;
  166.             *p2++ = '-';
  167.             }
  168.          else
  169.             *p2++ = '+';
  170.          if (decpt/100 > 0)
  171.             *p2++ = decpt/100 + '0';
  172.          if (decpt/10 > 0)
  173.             *p2++ = (decpt%100)/10 + '0';
  174.          *p2++ = decpt%10 + '0';
  175.       } else {
  176.          if (decpt<=0) {
  177.          /* if (*p1!='0') */
  178.          *p2++ = '0';
  179.          *p2++ = '.';
  180.          while (decpt<0) {
  181.             decpt++;
  182.             *p2++ = '0';
  183.             }
  184.          }
  185.          for (i=1; i<=ndigit; i++) {
  186.             *p2++ = *p1++;
  187.             if (i==decpt)
  188.                *p2++ = '.';
  189.             }
  190.       if (ndigit<decpt) {
  191.          while (ndigit++<decpt)
  192.             *p2++ = '0';
  193.          *p2++ = '.';
  194.          }
  195.    }
  196.    if (p2[-1]=='.')
  197.       *p2++ = '0';
  198.    *p2 = '\0';
  199.  
  200.    return(buf);
  201.    }
  202. #endif                    /* IconGcvt */
  203.  
  204. /*
  205.  * Get variable descriptor from name.
  206.  */
  207.  
  208. int getvar(s,vp)
  209.    char *s;
  210.    dptr vp;
  211.    {
  212.    register dptr dp;
  213.    register dptr np;
  214.    register int i;
  215.    struct b_proc *bp;
  216.    struct pf_marker *fp = pfp;
  217.  
  218. /*
  219.  * Is it a keyword that's a variable?
  220.  */
  221.    if (*s == '&') {
  222.  
  223.       if (strcmp(s,"&error") == 0) {    /* must put basic one first */
  224.          vp->dword = D_Tvkywd;
  225.          VarLoc(*vp) = (dptr)&tvky_err;
  226.          return Success;
  227.          }
  228.  
  229.  
  230.  
  231.  
  232.       else if (strcmp(s,"&pos") == 0) {
  233.          vp->dword = D_Tvkywd;
  234.          VarLoc(*vp) = (dptr)&tvky_pos;
  235.          return Success;
  236.          }
  237.       else if (strcmp(s,"&random") == 0) {
  238.          vp->dword = D_Tvkywd;
  239.          VarLoc(*vp) = (dptr)&tvky_ran;
  240.          return Success;
  241.          }
  242.       else if (strcmp(s,"&subject") == 0) {
  243.          vp->dword = D_Tvkywd;
  244.          VarLoc(*vp) = (dptr)&tvky_sub;
  245.          return Success;
  246.          }
  247.       else if (strcmp(s,"&trace") == 0) {
  248.          vp->dword = D_Tvkywd;
  249.          VarLoc(*vp) = (dptr)&tvky_trc;
  250.          return Success;
  251.          }
  252.       else return Failure;
  253.       }
  254.  
  255. /*
  256.  * Look for the variable with the name of the local identifiers,
  257.  *  parameters, and static names in each Icon procedure frame on the stack.
  258.  *  If not found among the locals, check the global variables.
  259.  *  If a variable with name is found, variable() returns a variable
  260.  *  descriptor that points to the corresponding value descriptor. 
  261.  *  If no such variable exits, it fails.
  262.  */
  263.       
  264.    /*
  265.     *  If no procedure has been called (as can happen with icon_call(),
  266.     *  dont' try to find local identifier.
  267.     */
  268.    if (pfp == NULL)
  269.       goto glbvars;
  270.    dp = argp;
  271.    bp = (struct b_proc *)BlkLoc(*dp);    /* get address of procedure block */
  272.    
  273.    np = bp->lnames;        /* Check the formal parameter names. */
  274.    for (i = abs((int)bp->nparam); i > 0; i--) {
  275.       dp++;
  276.       if (strcmp(s,StrLoc(*np)) == 0) {
  277.          vp->dword = D_Var;
  278.          VarLoc(*vp) = (dptr)dp;
  279.          return Success;
  280.          }
  281.       np++;
  282.       }
  283.  
  284.    dp = &fp->pf_locals[0];
  285.    for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */
  286.       if (strcmp(s,StrLoc(*np)) == 0) {
  287.          vp->dword = D_Var;
  288.          VarLoc(*vp) = (dptr)dp;
  289.          return Success;
  290.          }
  291.       np++;
  292.       dp++;
  293.       }
  294.  
  295.    dp = &statics[bp->fstatic]; /* Check the local static names. */
  296.    for (i = (int)bp->nstatic; i > 0; i--) {
  297.       if (strcmp(s,StrLoc(*np)) == 0) {
  298.          vp->dword = D_Var;
  299.          VarLoc(*vp) = (dptr)dp;
  300.          return Success;
  301.          }
  302.       np++;
  303.       dp++;
  304.       }
  305.  
  306. glbvars:
  307.    dp = globals;    /* Check the global variable names. */
  308.    np = gnames;
  309.    while (dp < eglobals) {
  310.       if (strcmp(s,StrLoc(*np)) == 0) {
  311.          vp->dword    =  D_Var;
  312.          VarLoc(*vp) =  (dptr)(dp);
  313.          return Success;
  314.          }
  315.       np++;
  316.       dp++;
  317.       }
  318.    return Failure;
  319. }
  320.  
  321. /*
  322.  * hash - compute hash value of arbitrary object for table and set accessing.
  323.  */
  324.  
  325. uword hash(dp)
  326. dptr dp;
  327.    {
  328.    register char *s;
  329.    register uword i;
  330.    register word j, n;
  331.    register int *bitarr;
  332.    double r;
  333.  
  334.    if (Qual(*dp)) {
  335.  
  336.       /*
  337.        * Compute the hash value for the string based on a scaled sum
  338.        *  of its first ten characters, plus its length.
  339.        */
  340.       i = 0;
  341.       s = StrLoc(*dp);
  342.       j = n = StrLen(*dp);
  343.       if (j > 10)        /* limit scan to first ten characters */
  344.          j = 10;
  345.       while (j-- > 0) {
  346.          i += *s++ & 0xFF;    /* add unsigned version of next char */
  347.          i *= 39;        /* scale total by a nice prime number */
  348.          }
  349.       i += n;            /* add the (untruncated) string length */
  350.       }
  351.  
  352.    else {
  353.  
  354.       switch (Type(*dp)) {
  355.          /*
  356.           * The hash value of an integer is itself times eight times the golden
  357.       *  ratio.  We do this calculation in fixed point.  We don't just use
  358.       *  the integer itself, for that would give bad results with sets
  359.       *  having entries that are multiples of a power of two.
  360.           */
  361.          case T_Integer:
  362.             i = (13255 * (uword)IntVal(*dp)) >> 10;
  363.             break;
  364.  
  365. #ifdef LargeInts
  366.          /*
  367.           * The hash value of a bignum is based on its length and its
  368.           *  most and least significant digits.
  369.           */
  370.      case T_Bignum:
  371.         {
  372.         struct b_bignum *b = &BlkLoc(*dp)->bignumblk;
  373.  
  374.         i = ((b->lsd - b->msd) << 16) ^ 
  375.         (b->digits[b->msd] << 8) ^ b->digits[b->lsd];
  376.         }
  377.         break;
  378. #endif                    /* LargeInts */
  379.  
  380.          /*
  381.           * The hash value of a real number is itself times a constant,
  382.           *  converted to an unsigned integer.  The intent is to scramble
  383.       *  the bits well, in the case of integral values, and to scale up
  384.       *  fractional values so they don't all land in the same bin.
  385.       *  The constant below is 32749 / 29, the quotient of two primes,
  386.       *  and was observed to work well in empirical testing.
  387.           */
  388.          case T_Real:
  389.             GetReal(dp,r);
  390.             i = r * 1129.27586206896558;
  391.             break;
  392.  
  393.          /*
  394.           * The hash value of a cset is based on a convoluted combination
  395.           *  of all its bits.
  396.           */
  397.          case T_Cset:
  398.             i = 0;
  399.             bitarr = BlkLoc(*dp)->cset.bits + CsetSize - 1;
  400.             for (j = 0; j < CsetSize; j++) {
  401.                i += *bitarr--;
  402.                i *= 37;            /* better distribution */
  403.                }
  404.             i %= 1048583;        /* scramble the bits */
  405.             break;
  406.  
  407.          /*
  408.           * The hash value of a list, set, table, or record is its id,
  409.           *   hashed like an integer.
  410.           */
  411.          case T_List:
  412.             i = (13255 * BlkLoc(*dp)->list.id) >> 10;
  413.             break;
  414.  
  415.          case T_Set:
  416.             i = (13255 * BlkLoc(*dp)->set.id) >> 10;
  417.             break;
  418.  
  419.          case T_Table:
  420.             i = (13255 * BlkLoc(*dp)->table.id) >> 10;
  421.             break;
  422.  
  423.          case T_Record:
  424.             i = (13255 * BlkLoc(*dp)->record.id) >> 10;
  425.             break;
  426.  
  427.          default:
  428.             /*
  429.              * For other types, use the type code as the hash
  430.              *  value.
  431.              */
  432.             i = Type(*dp);
  433.             break;
  434.          }
  435.       }
  436.  
  437.    return i;
  438.    }
  439.  
  440. #define StringLimit    16        /* limit on length of imaged string */
  441. #define ListLimit     6        /* limit on list items in image */
  442.  
  443. /*
  444.  * outimage - print image of *dp on file f.  If restrict is nonzero,
  445.  *  fields of records will not be imaged.
  446.  */
  447.  
  448. novalue outimage(f, dp, restrict)
  449. FILE *f;
  450. dptr dp;
  451. int restrict;
  452.    {
  453.    register word i, j;
  454.    register char *s;
  455.    register union block *bp, *vp;
  456.    char *type;
  457.    FILE *fd;
  458.    struct descrip q;
  459.    extern char *blkname[];
  460.    double rresult;
  461.  
  462. outimg:
  463.  
  464.    if (Qual(*dp)) {
  465.       /*
  466.        * *dp is a string qualifier.  Print StringLimit characters of it
  467.        *  using printimage and denote the presence of additional characters
  468.        *  by terminating the string with "...".
  469.        */
  470.       i = StrLen(*dp);
  471.       s = StrLoc(*dp);
  472.       j = Min(i, StringLimit);
  473.       putc('"', f);
  474.       while (j-- > 0)
  475.          printimage(f, *s++, '"');
  476.       if (i > StringLimit)
  477.          fprintf(f, "...");
  478.       putc('"', f);
  479.       return;
  480.       }
  481.  
  482.    if (Var(*dp) && !Tvar(*dp)) {
  483.       /*
  484.        * *d is a variable.  Print "variable =", dereference it, and 
  485.        *  call outimage to handle the value.
  486.        */
  487.       fprintf(f, "(variable = ");
  488.       dp = (dptr)((word *)VarLoc(*dp) + Offset(*dp));
  489.       outimage(f, dp, restrict);
  490.       putc(')', f);
  491.       return;
  492.       }
  493.  
  494.    switch (Type(*dp)) {
  495.  
  496.       case T_Null:
  497.          fprintf(f, "&null");
  498.          return;
  499.  
  500.       case T_Integer:
  501.          fprintf(f, "%ld", (long)IntVal(*dp));
  502.          return;
  503.  
  504. #ifdef LargeInts
  505.       case T_Bignum:
  506.      bigprint(f, dp);
  507.      return;
  508. #endif                    /* LargeInts */
  509.  
  510.       case T_Real:
  511.          {
  512.          char s[30];
  513.          struct descrip rd;
  514.  
  515.          GetReal(dp,rresult);
  516.          rtos(rresult, &rd, s);
  517.          fprintf(f, "%s", StrLoc(rd));
  518.          return;
  519.          }
  520.  
  521.       case T_Cset:
  522.          /*
  523.           * Check for distinguished csets by looking at the address of
  524.           *  of the object to image.  If one is found, print its name.
  525.           */
  526.          if ((char *)BlkLoc(*dp) == (char *)&k_ascii) {
  527.             fprintf(f, "&ascii");
  528.             return;
  529.             }
  530.          else if ((char *)BlkLoc(*dp) == (char *)&k_cset) {
  531.             fprintf(f, "&cset");
  532.             return;
  533.             }
  534.          else if ((char *)BlkLoc(*dp) == (char *)&k_digits) {
  535.             fprintf(f, "&digits");
  536.             return;
  537.             }
  538.          else if ((char *)BlkLoc(*dp) == (char *)&k_lcase) {
  539.             fprintf(f, "&lcase");
  540.             return;
  541.             }
  542.          else if ((char *)BlkLoc(*dp) == (char *)&k_letters) {
  543.             fprintf(f, "&letters");
  544.             return;
  545.             }
  546.          else if ((char *)BlkLoc(*dp) == (char *)&k_ucase) {
  547.             fprintf(f, "&ucase");
  548.             return;
  549.             }
  550.          /*
  551.           * Use printimage to print each character in the cset.  Follow
  552.           *  with "..." if the cset contains more than StringLimit
  553.           *  characters.
  554.           */
  555.          putc('\'', f);
  556.          j = StringLimit;
  557.          for (i = 0; i < 256; i++) {
  558.             if (Testb(i, BlkLoc(*dp)->cset.bits)) {
  559.                if (j-- <= 0) {
  560.                   fprintf(f, "...");
  561.                   break;
  562.                   }
  563.                printimage(f, (int)FromAscii(i), '\'');
  564.                }
  565.             }
  566.          putc('\'', f);
  567.          return;
  568.  
  569.       case T_File:
  570.          /*
  571.           * Check for distinguished files by looking at the address of
  572.           *  of the object to image.  If one is found, print its name.
  573.           */
  574.          if ((fd = BlkLoc(*dp)->file.fd) == stdin)
  575.             fprintf(f, "&input");
  576.          else if (fd == stdout)
  577.             fprintf(f, "&output");
  578.          else if (fd == stderr)
  579.             fprintf(f, "&errout");
  580.          else {
  581.             /*
  582.              * The file isn't a special one, just print "file(name)".
  583.              */
  584.             i = StrLen(BlkLoc(*dp)->file.fname);
  585.             s = StrLoc(BlkLoc(*dp)->file.fname);
  586.             fprintf(f, "file(");
  587.             while (i-- > 0)
  588.                printimage(f, *s++, '\0');
  589.             putc(')', f);
  590.             }
  591.          return;
  592.  
  593.       case T_Proc:
  594.          /*
  595.           * Produce one of:
  596.           *  "procedure name"
  597.           *  "function name"
  598.           *  "record constructor name"
  599.           *
  600.           * Note that the number of dynamic locals is used to determine
  601.           *  what type of "procedure" is at hand.
  602.           */
  603.          i = StrLen(BlkLoc(*dp)->proc.pname);
  604.          s = StrLoc(BlkLoc(*dp)->proc.pname);
  605.          switch ((int)BlkLoc(*dp)->proc.ndynam) {
  606.             default:  type = "procedure"; break;
  607.             case -1:  type = "function"; break;
  608.             case -2:  type = "record constructor"; break;
  609.             }
  610.          fprintf(f, "%s ", type);
  611.          while (i-- > 0)
  612.             printimage(f, *s++, '\0');
  613.          return;
  614.  
  615.       case T_List:
  616.          /*
  617.           * listimage does the work for lists.
  618.           */
  619.          listimage(f, (struct b_list *)BlkLoc(*dp), restrict);
  620.          return;
  621.  
  622.       case T_Table:
  623.          /*
  624.           * Print "table_m(n)" where n is the size of the table.
  625.           */
  626.          fprintf(f, "table_%ld(%ld)", (long)BlkLoc(*dp)->table.id,
  627.             (long)BlkLoc(*dp)->table.size);
  628.          return;
  629.  
  630.       case T_Set:
  631.     /*
  632.          * print "set_m(n)" where n is the cardinality of the set
  633.          */
  634.     fprintf(f,"set_%ld(%ld)",(long)BlkLoc(*dp)->set.id,
  635.            (long)BlkLoc(*dp)->set.size);
  636.     return;
  637.  
  638.       case T_Record:
  639.          /*
  640.           * If restrict is nonzero, print "record(n)" where n is the
  641.           *  number of fields in the record.  If restrict is zero, print
  642.           *  the image of each field instead of the number of fields.
  643.           */
  644.          bp = BlkLoc(*dp);
  645.          i = StrLen(bp->record.recdesc->proc.recname);
  646.          s = StrLoc(bp->record.recdesc->proc.recname);
  647.          fprintf(f, "record ");
  648.          while (i-- > 0)
  649.             printimage(f, *s++, '\0');
  650.         fprintf(f, "_%ld", bp->record.id);
  651.          j = bp->record.recdesc->proc.nfields;
  652.          if (j <= 0)
  653.             fprintf(f, "()");
  654.          else if (restrict > 0)
  655.             fprintf(f, "(%ld)", (long)j);
  656.          else {
  657.             putc('(', f);
  658.             i = 0;
  659.             for (;;) {
  660.                outimage(f, &bp->record.fields[i], restrict+1);
  661.                if (++i >= j)
  662.                   break;
  663.                putc(',', f);
  664.                }
  665.             putc(')', f);
  666.             }
  667.          return;
  668.  
  669.       case T_Tvsubs:
  670.          /*
  671.           * Produce "v[i+:j] = value" where v is the image of the variable
  672.           *  containing the substring, i is starting position of the substring
  673.           *  j is the length, and value is the string v[i+:j].    If the length
  674.           *  (j) is one, just produce "v[i] = value".
  675.           */
  676.          bp = BlkLoc(*dp);
  677.      dp = VarLoc(bp->tvsubs.ssvar);
  678.      if (!Tvar(bp->tvsubs.ssvar))
  679.             dp = (dptr)((word *)dp + Offset(bp->tvsubs.ssvar));
  680.          if (dp == (dptr)&tvky_sub)
  681.             fprintf(f, "&subject");
  682.          else outimage(f, dp, restrict);
  683.          if (bp->tvsubs.sslen == 1)
  684.             fprintf(f, "[%ld]", (long)bp->tvsubs.sspos);
  685.          else
  686.             fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos,
  687.                     (long)bp->tvsubs.sslen);
  688.          if (dp == (dptr)&tvky_sub) {
  689.             vp = BlkLoc(bp->tvsubs.ssvar);
  690.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 >
  691.                   StrLen(vp->tvkywd.kyval))
  692.                return;
  693.             StrLen(q) = bp->tvsubs.sslen;
  694.             StrLoc(q) = StrLoc(vp->tvkywd.kyval) + bp->tvsubs.sspos - 1;
  695.             fprintf(f, " = ");
  696.             dp = &q;
  697.             goto outimg;
  698.             }
  699.          else if (Qual(*dp)) {
  700.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(*dp))
  701.                return;
  702.             StrLen(q) = bp->tvsubs.sslen;
  703.             StrLoc(q) = StrLoc(*dp) + bp->tvsubs.sspos - 1;
  704.             fprintf(f, " = ");
  705.             dp = &q;
  706.             goto outimg;
  707.             }
  708.          return;
  709.  
  710.       case T_Tvtbl:
  711.          bp = BlkLoc(*dp);
  712.          /*
  713.           * It is possible that the descriptor that thinks it is pointing
  714.           *  to a tabel-element trapped variable may actually be pointing
  715.           *  at a table element block which had been converted from a
  716.           *  trapped variable. Check for this first and if it is a table
  717.           *  element block, produce the outimage of its value.
  718.           */
  719.          if (bp->tvtbl.title == T_Telem) {
  720.             outimage(f, &bp->tvtbl.tval, restrict);
  721.             return;
  722.             }
  723.          /*
  724.           * It really was a tvtbl - produce "t[s]" where t is the image of
  725.           *  the table containing the element and s is the image of the
  726.           *  subscript.
  727.           */
  728.          else {
  729.         dp->dword = D_Table;
  730.         BlkLoc(*dp) = bp->tvtbl.clink;
  731.             outimage(f, dp, restrict);
  732.             putc('[', f);
  733.             outimage(f, &bp->tvtbl.tref, restrict);
  734.             putc(']', f);
  735.             return;
  736.             }
  737.  
  738.       case T_Tvkywd:
  739.          bp = BlkLoc(*dp);
  740.          i = StrLen(bp->tvkywd.kyname);
  741.          s = StrLoc(bp->tvkywd.kyname);
  742.          while (i-- > 0)
  743.             putc(*s++, f);
  744.          fprintf(f, " = ");
  745.          outimage(f, &bp->tvkywd.kyval, restrict);
  746.          return;
  747.  
  748.       case T_Coexpr:
  749.          fprintf(f, "co-expression_%ld(%ld)",
  750.             (long)((struct b_coexpr *)BlkLoc(*dp))->id,
  751.             (long)((struct b_coexpr *)BlkLoc(*dp))->size);
  752.          return;
  753.  
  754.       case T_External:
  755.          fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize);
  756.          return;
  757.  
  758.       default:
  759.          if (Type(*dp) <= MaxType)
  760.             fprintf(f, "%s", blkname[Type(*dp)]);
  761.          else
  762.             syserr("outimage: unknown type");
  763.       }
  764.    }
  765.  
  766. /*
  767.  * printimage - print character c on file f using escape conventions
  768.  *  if c is unprintable, '\', or equal to q.
  769.  */
  770.  
  771. static novalue printimage(f, c, q)
  772. FILE *f;
  773. int c, q;
  774.    {
  775.    if (printable(c)) {
  776.       /*
  777.        * c is printable, but special case ", ', and \.
  778.        */
  779.       switch (c) {
  780.          case '"':
  781.             if (c != q) goto def;
  782.             fprintf(f, "\\\"");
  783.             return;
  784.          case '\'':
  785.             if (c != q) goto def;
  786.             fprintf(f, "\\'");
  787.             return;
  788.          case '\\':
  789.             fprintf(f, "\\\\");
  790.             return;
  791.          default:
  792.          def:
  793.             putc(c, f);
  794.             return;
  795.          }
  796.       }
  797.  
  798.    /*
  799.     * c is some sort of unprintable character.    If it one of the common
  800.     *  ones, produce a special representation for it, otherwise, produce
  801.     *  its hex value.
  802.     */
  803.    switch (c) {
  804.       case '\b':            /* backspace */
  805.          fprintf(f, "\\b");
  806.          return;
  807.  
  808. #if !EBCDIC
  809.       case '\177':            /* delete */
  810. #else                    /* !EBCDIC */
  811.       case '\x07':
  812. #endif                    /* !EBCDIC */
  813.  
  814.          fprintf(f, "\\d");
  815.          return;
  816. #if !EBCDIC
  817.       case '\33':            /* escape */
  818. #else                    /* !EBCDIC */
  819.       case '\x27':
  820. #endif                    /* !EBCDIC */
  821.          fprintf(f, "\\e");
  822.          return;
  823.       case '\f':            /* form feed */
  824.          fprintf(f, "\\f");
  825.          return;
  826.       case LineFeed:            /* new line */
  827.          fprintf(f, "\\n");
  828.          return;
  829.  
  830. #if EBCDIC == 1
  831.       case '\x25':                      /* EBCDIC line feed */
  832.          fprintf(f, "\\l");
  833.          return;
  834. #endif                    /* EBCDIC == 1 */
  835.  
  836.       case CarriageReturn:        /* carriage return */
  837.          fprintf(f, "\\r");
  838.          return;
  839.       case '\t':            /* horizontal tab */
  840.          fprintf(f, "\\t");
  841.          return;
  842.       case '\13':            /* vertical tab */
  843.          fprintf(f, "\\v");
  844.          return;
  845.       default:                /* hex escape sequence */
  846.          fprintf(f, "\\x%02x", ToAscii(c & 0xff));
  847.          return;
  848.       }
  849.    }
  850.  
  851. /*
  852.  * listimage - print an image of a list.
  853.  */
  854.  
  855. static novalue listimage(f, lp, restrict)
  856. FILE *f;
  857. struct b_list *lp;
  858. int restrict;
  859.    {
  860.    register word i, j;
  861.    register struct b_lelem *bp;
  862.    word size, count;
  863.  
  864.    bp = (struct b_lelem *) lp->listhead;
  865.    size = lp->size;
  866.  
  867.    if (restrict > 0 && size > 0) {
  868.       /*
  869.        * Just give indication of size if the list isn't empty.
  870.        */
  871.       fprintf(f, "list_%ld(%ld)", (long)lp->id, (long)size);
  872.       return;
  873.       }
  874.  
  875.    /*
  876.     * Print [e1,...,en] on f.  If more than ListLimit elements are in the
  877.     *  list, produce the first ListLimit/2 elements, an ellipsis, and the
  878.     *  last ListLimit elements.
  879.     */
  880.    fprintf(f, "list_%ld = [", (long)lp->id);
  881.    count = 1;
  882.    i = 0;
  883.    if (size > 0) {
  884.       for (;;) {
  885.          if (++i > bp->nused) {
  886.             i = 1;
  887.             bp = (struct b_lelem *) bp->listnext;
  888.             }
  889.          if (count <= ListLimit/2 || count > size - ListLimit/2) {
  890.             j = bp->first + i - 1;
  891.             if (j >= bp->nslots)
  892.                j -= bp->nslots;
  893.             outimage(f, &bp->lslots[j], restrict+1);
  894.             if (count >= size)
  895.                break;
  896.             putc(',', f);
  897.             }
  898.          else if (count == ListLimit/2 + 1)
  899.             fprintf(f, "...,");
  900.          count++;
  901.          }
  902.       }
  903.    putc(']', f);
  904.    }
  905.  
  906. #ifdef IconQsort
  907. /* qsort(base,nel,width,compar) - quicksort routine
  908.  *
  909.  * A Unix-compatible public domain quicksort.
  910.  * Based on Bentley, CACM 28,7 (July, 1985), p. 675.
  911.  */
  912.      
  913. novalue qsort(base, nel, w, compar)
  914. char *base;
  915. int nel, w;
  916. int (*compar)();
  917. {
  918.    int i, lastlow;
  919.     
  920.    if (nel < 2)
  921.       return;
  922.    qswap(base, base + w * (rand() % nel), w);
  923.    lastlow = 0;
  924.    for (i = 1; i < nel; i++)
  925.       if ((*compar) (base + w * i, base) < 0)
  926.          qswap(base + w * i, base + w * (++lastlow), w);
  927.    qswap(base, base + w * lastlow, w);
  928.    qsort(base, lastlow, w, compar);
  929.    qsort(base + w * (lastlow+1), nel-lastlow-1, w, compar);
  930. }
  931.     
  932. static novalue qswap(a, b, w)        /* swap *a and *b of width w for qsort*/
  933. char *a, *b;
  934. int w;
  935. {
  936.    register t;
  937.     
  938.    while (w--)  {
  939.       t = *a;
  940.       *a++ = *b;
  941.       *b++ = t;
  942.    }
  943. }
  944. #endif                    /* IconQsort */
  945.  
  946. /*
  947.  * qtos - convert a qualified string named by *dp to a C-style string.
  948.  *  Put the C-style string in sbuf if it will fit, otherwise put it
  949.  *  in the string region.
  950.  */
  951.  
  952. int qtos(dp, sbuf)
  953. dptr dp;
  954. char *sbuf;
  955.    {
  956.    register word slen;
  957.    register char *c;
  958.  
  959.    c = StrLoc(*dp);
  960.    slen = StrLen(*dp)++;
  961.    if (slen >= MaxCvtLen) {
  962.       if (strreq(slen + 1) == Error) 
  963.          return Error;
  964.       if (c + slen != strfree)
  965.          StrLoc(*dp) = alcstr(c, slen);
  966.       alcstr("",(word)1);
  967.       }
  968.    else {
  969.       StrLoc(*dp) = sbuf;
  970.       for ( ; slen > 0; slen--)
  971.          *sbuf++ = *c++;
  972.       *sbuf = '\0';
  973.       }
  974.    return Success;
  975.    }
  976.  
  977. /*
  978.  * ctrace - procedure named s is being called with nargs arguments, the first
  979.  *  of which is at arg; produce a trace message.
  980.  */
  981. novalue ctrace(dp, nargs, arg)
  982. dptr dp;
  983. int nargs;
  984. dptr arg;
  985.    {
  986.  
  987.    showline(findfile(ipc.opnd), findline(ipc.opnd));
  988.    showlevel(k_level);
  989.    putstr(stderr, dp);
  990.    putc('(', stderr);
  991.    while (nargs--) {
  992.       outimage(stderr, arg++, 0);
  993.       if (nargs)
  994.          putc(',', stderr);
  995.       }
  996.    putc(')', stderr);
  997.    putc('\n', stderr);
  998.    fflush(stderr);
  999.    }
  1000.  
  1001. /*
  1002.  * rtrace - procedure named s is returning *rval; produce a trace message.
  1003.  */
  1004.  
  1005. novalue rtrace(dp, rval)
  1006. dptr dp;
  1007. dptr rval;
  1008.    {
  1009.    inst t_ipc;
  1010.  
  1011.    /*
  1012.     * Compute the ipc of the return instruction.
  1013.     */
  1014.    t_ipc.op = ipc.op - 1;
  1015.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1016.    showlevel(k_level);
  1017.    putstr(stderr, dp);
  1018.    fprintf(stderr, " returned ");
  1019.    outimage(stderr, rval, 0);
  1020.    putc('\n', stderr);
  1021.    fflush(stderr);
  1022.    }
  1023.  
  1024. /*
  1025.  * failtrace - procedure named s is failing; produce a trace message.
  1026.  */
  1027.  
  1028. novalue failtrace(dp)
  1029. dptr dp;
  1030.    {
  1031.    inst t_ipc;
  1032.  
  1033.    /*
  1034.     * Compute the ipc of the fail instruction.
  1035.     */
  1036.    t_ipc.op = ipc.op - 1;
  1037.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1038.    showlevel(k_level);
  1039.    putstr(stderr, dp);
  1040.    fprintf(stderr, " failed");
  1041.    putc('\n', stderr);
  1042.    fflush(stderr);
  1043.    }
  1044.  
  1045. /*
  1046.  * strace - procedure named s is suspending *rval; produce a trace message.
  1047.  */
  1048.  
  1049. novalue strace(dp, rval)
  1050. dptr dp;
  1051. dptr rval;
  1052.    {
  1053.    inst t_ipc;
  1054.  
  1055.    /*
  1056.     * Compute the ipc of the suspend instruction.
  1057.     */
  1058.    t_ipc.op = ipc.op - 1;
  1059.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1060.    showlevel(k_level);
  1061.    putstr(stderr, dp);
  1062.    fprintf(stderr, " suspended ");
  1063.    outimage(stderr, rval, 0);
  1064.    putc('\n', stderr);
  1065.    fflush(stderr);
  1066.    }
  1067.  
  1068. /*
  1069.  * atrace - procedure named s is being resumed; produce a trace message.
  1070.  */
  1071.  
  1072. novalue atrace(dp)
  1073. dptr dp;
  1074.    {
  1075.    inst t_ipc;
  1076.  
  1077.    /*
  1078.     * Compute the ipc of the instruction causing resumption.
  1079.     */
  1080.    t_ipc.op = ipc.op - 1;
  1081.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1082.    showlevel(k_level);
  1083.    putstr(stderr, dp);
  1084.    fprintf(stderr, " resumed");
  1085.    putc('\n', stderr);
  1086.    fflush(stderr);
  1087.    }
  1088.  
  1089. #ifdef Coexpr
  1090. /*
  1091.  * coacttrace -- co-expression is being activated; produce a trace message.
  1092.  */
  1093. novalue coacttrace(ccp, ncp)
  1094. struct b_coexpr *ccp;
  1095. struct b_coexpr *ncp;
  1096.    {
  1097.    struct b_proc *bp;
  1098.    inst t_ipc;
  1099.  
  1100.    bp = (struct b_proc *)BlkLoc(*argp);
  1101.    /*
  1102.     * Compute the ipc of the activation instruction.
  1103.     */
  1104.    t_ipc.op = ipc.op - 1;
  1105.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1106.    showlevel(k_level);
  1107.    putstr(stderr, &(bp->pname));
  1108.    fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id);
  1109.    outimage(stderr, (dptr)(sp - 3), 0);
  1110.    fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id);
  1111.    fflush(stderr);
  1112.    }
  1113.  
  1114. /*
  1115.  * corettrace -- return from co-expression; produce a trace message.
  1116.  */
  1117. novalue corettrace(ccp, ncp)
  1118. struct b_coexpr *ccp;
  1119. struct b_coexpr *ncp;
  1120.    {
  1121.    struct b_proc *bp;
  1122.    inst t_ipc;
  1123.  
  1124.    bp = (struct b_proc *)BlkLoc(*argp);
  1125.    /*
  1126.     * Compute the ipc of the coret instruction.
  1127.     */
  1128.    t_ipc.op = ipc.op - 1;
  1129.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1130.    showlevel(k_level);
  1131.    putstr(stderr, &(bp->pname));
  1132.    fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id);
  1133.    outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0);
  1134.    fprintf(stderr," to co-expression_%ld\n", (long)ncp->id);
  1135.    fflush(stderr);
  1136.    }
  1137.  
  1138. /*
  1139.  * cofailtrace -- failure return from co-expression; produce a trace message.
  1140.  */
  1141. novalue cofailtrace(ccp, ncp)
  1142. struct b_coexpr *ccp;
  1143. struct b_coexpr *ncp;
  1144.    {
  1145.    struct b_proc *bp;
  1146.    inst t_ipc;
  1147.  
  1148.    bp = (struct b_proc *)BlkLoc(*argp);
  1149.    /*
  1150.     * Compute the ipc of the cofail instruction.
  1151.     */
  1152.    t_ipc.op = ipc.op - 1;
  1153.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1154.    showlevel(k_level);
  1155.    putstr(stderr, &(bp->pname));
  1156.    fprintf(stderr,"; co-epression_%ld failed to co-expression_%ld\n",
  1157.       (long)ccp->id, (long)ncp->id);
  1158.    fflush(stderr);
  1159.    }
  1160. #endif                    /* Coexpr */
  1161.  
  1162. /*
  1163.  * showline - print file and line number information.
  1164.  */
  1165. static novalue showline(f, l)
  1166. char *f;
  1167. int l;
  1168.    {
  1169.    int i;
  1170.  
  1171.    i = (int)strlen(f);
  1172.  
  1173. #if MVS
  1174.    while (i > 22) {
  1175. #else                    /* MVS */
  1176.    while (i > 13) {
  1177. #endif                    /* MVS */
  1178.       f++;
  1179.       i--;
  1180.       }
  1181.    if (l > 0)
  1182.  
  1183. #if MVS
  1184.       fprintf(stderr, "%-22s: %4d  ",f, l);
  1185.    else
  1186.       fprintf(stderr, "                      :      ");
  1187. #else                    /* MVS */
  1188.       fprintf(stderr, "%-13s: %4d  ",f, l);
  1189.    else
  1190.       fprintf(stderr, "             :      ");
  1191. #endif                    /* MVS */
  1192.  
  1193.    }
  1194.  
  1195. /*
  1196.  * showlevel - print "| " n times.
  1197.  */
  1198. static novalue showlevel(n)
  1199. register int n;
  1200.    {
  1201.    while (n-- > 0) {
  1202.       putc('|', stderr);
  1203.       putc(' ', stderr);
  1204.       }
  1205.    }
  1206.  
  1207. /*
  1208.  * putpos - assign value to &pos
  1209.  */
  1210.  
  1211. int putpos(dp,bp)
  1212. dptr dp;
  1213. struct b_tvkywd *bp;
  1214.    {
  1215.  
  1216. #if MACINTOSH && MPW
  1217. /* #pragma unused(bp) */
  1218. #endif                    /* MACINTOSH && MPW */
  1219.  
  1220.    register word l1;
  1221.    switch (cvint(dp)) {
  1222.  
  1223.       case T_Integer:
  1224.          l1 = cvpos(IntVal(*dp), StrLen(k_subject));
  1225.          if (l1 == CvtFail)
  1226.             return Failure;
  1227.          k_pos = l1;
  1228.          return Success;
  1229.  
  1230.       default:
  1231.          RetError(101, *dp);
  1232.       }
  1233.    }
  1234.  
  1235. /*
  1236.  * putsub - assign value to &subject
  1237.  */
  1238.  
  1239. int putsub(dp,bp)
  1240. dptr dp;
  1241. struct b_tvkywd *bp;
  1242.    {
  1243.  
  1244. #if MACINTOSH && MPW
  1245. /* #pragma unused(bp) */
  1246. #endif                    /* MACINTOSH && MPW */
  1247.  
  1248.    char sbuf[MaxCvtLen];
  1249.  
  1250.    switch (cvstr(dp, sbuf)) {
  1251.  
  1252.       case Cvt:
  1253.          if (strreq(StrLen(*dp)) == Error)
  1254.             return Error;
  1255.          StrLoc(*dp) = alcstr(StrLoc(*dp), StrLen(*dp));
  1256.          /* no break */
  1257.  
  1258.       case NoCvt:
  1259.          k_subject = *dp;
  1260.          k_pos = 1;
  1261.          return Success;
  1262.  
  1263.      default:
  1264.         RetError(103, *dp);
  1265.  
  1266.       }
  1267.    }
  1268.  
  1269. /*
  1270.  * putint - assign integer value to keyword
  1271.  */
  1272.  
  1273. int putint(dp,bp)
  1274. dptr dp;
  1275. struct b_tvkywd *bp;
  1276.    {
  1277.    switch (cvint(dp)) {
  1278.  
  1279.       case T_Integer:
  1280.          IntVal(bp->kyval) = IntVal(*dp);
  1281.          return Success;
  1282.  
  1283.       default:
  1284.          RetError(101, *dp);
  1285.       }
  1286.    }
  1287.  
  1288. #ifdef Coexpr
  1289. /*
  1290.  * pushact - push actvtr on the activator stack of ce
  1291.  */
  1292. int pushact(ce, actvtr)
  1293. struct b_coexpr *ce, *actvtr;
  1294. {
  1295.    struct astkblk *abp = ce->es_actstk, *nabp;
  1296.    struct actrec *arp;
  1297.  
  1298.    /*
  1299.     * If the last activator is the same as this one, just increment
  1300.     *  its count.
  1301.     */
  1302.    if (abp->nactivators > 0) {
  1303.       arp = &abp->arec[abp->nactivators - 1];
  1304.       if (arp->activator == actvtr) {
  1305.          arp->acount++;
  1306.          return Success;
  1307.          }
  1308.       }
  1309.    /*
  1310.     * This activator is different from the last one.  Push this activator
  1311.     *  on the stack, possibly adding another block.
  1312.     */
  1313.    if (abp->nactivators + 1 > ActStkBlkEnts) {
  1314.       nabp = alcactiv();
  1315.       if (nabp == NULL)
  1316.          return Error;
  1317.       nabp->astk_nxt = abp;
  1318.       abp = nabp;
  1319.       }
  1320.    abp->nactivators++;
  1321.    arp = &abp->arec[abp->nactivators - 1];
  1322.    arp->acount = 1;
  1323.    arp->activator = actvtr;
  1324.    ce->es_actstk = abp;
  1325.    return Success;
  1326. }
  1327.  
  1328. /*
  1329.  * popact - pop the most recent activator from the activator stack of ce
  1330.  *  and return it.
  1331.  */
  1332. struct b_coexpr *popact(ce)
  1333. struct b_coexpr *ce;
  1334. {
  1335.    struct astkblk *abp = ce->es_actstk, *oabp;
  1336.    struct actrec *arp;
  1337.    struct b_coexpr *actvtr;
  1338.  
  1339.    /*
  1340.     * If the current stack block is empty, pop it.
  1341.     */
  1342.    if (abp->nactivators == 0) {
  1343.       oabp = abp;
  1344.       abp = abp->astk_nxt;
  1345.       free((pointer)oabp);
  1346.       }
  1347.  
  1348.    if (abp == NULL || abp->nactivators == 0)
  1349.       syserr("empty activator stack\n");
  1350.  
  1351.    /*
  1352.     * Find the activation record for the most recent co-expression.
  1353.     *  Decrement the activation count and if it is zero, pop that
  1354.     *  activation record and decrement the count of activators.
  1355.     */
  1356.    arp = &abp->arec[abp->nactivators - 1];
  1357.    actvtr = arp->activator;
  1358.    if (--arp->acount == 0)
  1359.       abp->nactivators--;
  1360.  
  1361.    ce->es_actstk = abp;
  1362.    return actvtr;
  1363. }
  1364.  
  1365. /*
  1366.  * topact - return the most recent activator of ce.
  1367.  */
  1368. struct b_coexpr *topact(ce)
  1369. struct b_coexpr *ce;
  1370. {
  1371.    struct astkblk *abp = ce->es_actstk;
  1372.    
  1373.    if (abp->nactivators == 0)
  1374.       abp = abp->astk_nxt;
  1375.    return abp->arec[abp->nactivators-1].activator;
  1376. }
  1377.  
  1378. #ifdef DeBugIconx
  1379. /*
  1380.  * dumpact - dump an activator stack
  1381.  */
  1382. novalue dumpact(ce)
  1383. struct b_coexpr *ce;
  1384. {
  1385.    struct astkblk *abp = ce->es_actstk;
  1386.    struct actrec *arp;
  1387.    int i;
  1388.  
  1389.    if (abp)
  1390.       fprintf(stderr, "Ce %ld ", (long)ce->id);
  1391.    while (abp) {
  1392.       fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n",
  1393.          abp, abp->nactivators);
  1394.       for (i = abp->nactivators; i >= 1; i--) {
  1395.          arp = &abp->arec[i-1];
  1396.          /*for (j = 1; j <= arp->acount; j++)*/
  1397.          fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id),
  1398.             arp->acount);
  1399.          }
  1400.       abp = abp->astk_nxt;
  1401.       }
  1402. }
  1403. #endif                    /* DeBugIconx */
  1404. #endif                    /* Coexpr */
  1405.  
  1406. /*
  1407.  * findline - find the source line number associated with the ipc
  1408.  */
  1409. int findline(ipc)
  1410. word *ipc;
  1411. {
  1412.    uword ipc_offset;
  1413.    uword size;
  1414.    struct ipc_line *base;
  1415.    extern struct ipc_line *ilines, *elines;
  1416.    extern word *records;
  1417.    static two = 2;    /* some compilers generate bad code for division
  1418.                by a constant that is a power of two ... */
  1419.  
  1420.    if (!InRange(code,ipc,records))
  1421.       return 0;
  1422.    ipc_offset = DiffPtrs((char *)ipc,(char *)code);
  1423.    base = ilines;
  1424.    size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
  1425.    while (size > 1) {
  1426.       if (ipc_offset >= base[size / two].ipc) {
  1427.          base = &base[size / two];
  1428.          size -= size / two;
  1429.          }
  1430.       else
  1431.          size = size / two;
  1432.       }
  1433.    return (int)base->line;
  1434. }
  1435. /*
  1436.  * findipc - find the first ipc associated with a source-code line number.
  1437.  */
  1438. int findipc(line)
  1439. int line;
  1440. {
  1441.    uword size;
  1442.    struct ipc_line *base;
  1443.    extern struct ipc_line *ilines, *elines;
  1444.    static two = 2;    /* some compilers generate bad code for division
  1445.                by a constant that is a power of two ... */
  1446.  
  1447.    base = ilines;
  1448.    size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
  1449.    while (size > 1) {
  1450.       if (line >= base[size / two].line) {
  1451.          base = &base[size / two];
  1452.          size -= size / two;
  1453.          }
  1454.       else
  1455.          size = size / two;
  1456.       }
  1457.    return base->ipc;
  1458. }
  1459.  
  1460. /*
  1461.  * findfile - find source file name associated with the ipc
  1462.  */
  1463. char *findfile(ipc)
  1464. word *ipc;
  1465. {
  1466.    uword ipc_offset;
  1467.    struct ipc_fname *p;
  1468.    extern struct ipc_fname *filenms, *efilenms;
  1469.    extern word *records;
  1470.    extern char *strcons;
  1471.  
  1472.    if (!InRange(code,ipc,records))
  1473.       return "?";
  1474.    ipc_offset = DiffPtrs((char *)ipc,(char *)code);
  1475.    for (p = efilenms - 1; p >= filenms; p--)
  1476.       if (ipc_offset >= p->ipc)
  1477.          return strcons + p->fname;
  1478.    fprintf(stderr,"bad ipc/file name table");
  1479.    fflush(stderr);
  1480.    c_exit(ErrorExit);
  1481. }
  1482.  
  1483. #if IntBits == 16
  1484. /* Shell sort with some enhancements from Knuth.. */
  1485.  
  1486. novalue llqsort(base, nel, width, cmp )
  1487. char *base;
  1488. int nel;
  1489. int width;
  1490. int (*cmp)();
  1491. {
  1492.    register long i, j;
  1493.    long int gap;
  1494.    int k;
  1495.    char *p1, *p2, tmp;
  1496.  
  1497.    for( gap=1; gap <= nel; gap = 3*gap + 1 ) ;
  1498.  
  1499.    for( gap /= 3;  gap > 0  ; gap /= 3 )
  1500.        for( i = gap; i < nel; i++ )
  1501.        for( j = i-gap; j >= 0 ; j -= gap ) {
  1502.         p1 = base + ( j     * width);
  1503.         p2 = base + ((j+gap) * width);
  1504.  
  1505.         if( (*cmp)( p1, p2 ) <= 0 ) break;
  1506.  
  1507.         for( k = width; --k >= 0 ;) {
  1508.            tmp     = *p1;
  1509.            *p1++ = *p2;
  1510.            *p2++ = tmp;
  1511.         }
  1512.        }
  1513. }
  1514.  
  1515. #endif                    /* IntBits == 16 */
  1516. /*
  1517.  * doimage(c,q) - allocate character c in string space, with escape
  1518.  *  conventions if c is unprintable, '\', or equal to q.
  1519.  *  Returns number of characters allocated.
  1520.  */
  1521.  
  1522. doimage(c, q)
  1523. int c, q;
  1524.    {
  1525.    static char cbuf[5];
  1526.  
  1527.    if (printable(c)) {
  1528.  
  1529.       /*
  1530.        * c is printable, but special case ", ', and \.
  1531.        */
  1532.       switch (c) {
  1533.          case '"':
  1534.             if (c != q) goto def;
  1535.             alcstr("\\\"", (word)(2));
  1536.             return 2;
  1537.          case '\'':
  1538.             if (c != q) goto def;
  1539.             alcstr("\\'", (word)(2));
  1540.             return 2;
  1541.          case '\\':
  1542.             alcstr("\\\\", (word)(2));
  1543.             return 2;
  1544.          default:
  1545.          def:
  1546.             cbuf[0] = c;
  1547.             alcstr(cbuf, (word)(1));
  1548.             return 1;
  1549.          }
  1550.       }
  1551.  
  1552.    /*
  1553.     * c is some sort of unprintable character.    If it is one of the common
  1554.     *  ones, produce a special representation for it, otherwise, produce
  1555.     *  its hex value.
  1556.     */
  1557.    switch (c) {
  1558.       case '\b':            /*       backspace    */
  1559.          alcstr("\\b", (word)(2));
  1560.          return 2;
  1561.  
  1562. #if !EBCDIC
  1563.       case '\177':            /*      delete      */
  1564. #else                    /* !EBCDIC */
  1565.       case '\x07':            /*      delete    */
  1566. #endif                    /* !EBCDIC */
  1567.  
  1568.          alcstr("\\d", (word)(2));
  1569.          return 2;
  1570.  
  1571. #if !EBCDIC
  1572.       case '\33':            /*        escape     */
  1573. #else                    /* !EBCDIC */
  1574.       case '\x27':            /*          escape       */
  1575. #endif                    /* !EBCDIC */
  1576.  
  1577.          alcstr("\\e", (word)(2));
  1578.          return 2;
  1579.       case '\f':            /*       form feed    */
  1580.          alcstr("\\f", (word)(2));
  1581.          return 2;
  1582.  
  1583. #if EBCDIC == 1
  1584.       case '\x25':                      /* EBCDIC line feed */
  1585.          alcstr("\\l", (word)(2));
  1586.          return 2;
  1587. #endif                    /* EBCDIC */
  1588.  
  1589.       case LineFeed:            /*       new line    */
  1590.          alcstr("\\n", (word)(2));
  1591.          return 2;
  1592.       case CarriageReturn:        /*       return    */
  1593.          alcstr("\\r", (word)(2));
  1594.          return 2;
  1595.       case '\t':            /*       horizontal tab     */
  1596.          alcstr("\\t", (word)(2));
  1597.          return 2;
  1598.       case '\13':            /*        vertical tab     */
  1599.          alcstr("\\v", (word)(2));
  1600.          return 2;
  1601.       default:                /*      hex escape sequence  */
  1602.          sprintf(cbuf, "\\x%02x", ToAscii(c & 0xff));
  1603.          alcstr(cbuf, (word)(4));
  1604.          return 4;
  1605.       }
  1606.    }
  1607.  
  1608. /*
  1609.  * prescan(d) - return upper bound on length of expanded string.  Note
  1610.  *  that the only time that prescan is wrong is when the string contains
  1611.  *  one of the "special" unprintable characters, e.g. tab.
  1612.  */
  1613. word prescan(d)
  1614. dptr d;
  1615.    {
  1616.    register word slen, len;
  1617.    register char *s, c;
  1618.  
  1619.    s = StrLoc(*d);
  1620.    len = 0;
  1621.    for (slen = StrLen(*d); slen > 0; slen--)
  1622.  
  1623. #if EBCDIC
  1624. #if SASC
  1625.       if (!isascii(c = (*s++)) || iscntrl(c))
  1626. #else                    /* SASC */
  1627.       if (!isprint(c = (*s++)))
  1628. #endif                    /* SASC */
  1629. #else                    /* EBCDIC */
  1630.       if ((c = (*s++)) < ' ' || c >= 0177)
  1631. #endif                    /* EBCDIC */
  1632.  
  1633.          len += 4;
  1634.       else if (c == '"' || c == '\\' || c == '\'')
  1635.          len += 2;
  1636.       else
  1637.          len++;
  1638.  
  1639.    return len;
  1640.    }
  1641.  
  1642. /*
  1643.  * getimage(dp1,dp2) - return string image of object dp1 in dp2.
  1644.  */
  1645.  
  1646. int getimage(dp1,dp2)
  1647.    dptr dp1, dp2;
  1648.    {
  1649.    register word len, outlen, rnlen;
  1650.    register char *s;
  1651.    register union block *bp;
  1652.    char *type;
  1653.    char sbuf[MaxCvtLen];
  1654.    FILE *fd;
  1655.  
  1656.    if (Qual(*dp1)) {
  1657.       /*
  1658.        * Get some string space.  The magic 2 is for the double quote at each
  1659.        *  end of the resulting string.
  1660.        */
  1661.       if (strreq(prescan(dp1) + 2) == Error) 
  1662.          return Error;
  1663.       len = StrLen(*dp1);
  1664.       s = StrLoc(*dp1);
  1665.       outlen = 2;
  1666.  
  1667.       /*
  1668.        * Form the image by putting a quote in the string space, calling
  1669.        *  doimage with each character in the string, and then putting
  1670.        *  a quote at then end.    Note that doimage directly writes into the
  1671.        *  string space.  (Hence the indentation.)  This techinique is used
  1672.        *  several times in this routine.
  1673.        */
  1674.       StrLoc(*dp2) = alcstr("\"", (word)(1));
  1675.       while (len-- > 0)
  1676.          outlen += doimage(*s++, '"');
  1677.       alcstr("\"", (word)(1));
  1678.       StrLen(*dp2) = outlen;
  1679.       return Success;
  1680.       }
  1681.  
  1682.    switch (Type(*dp1)) {
  1683.  
  1684.       case T_Null:
  1685.          StrLoc(*dp2) = "&null";
  1686.          StrLen(*dp2) = 5;
  1687.          return Success;
  1688.  
  1689. #ifdef LargeInts
  1690.       case T_Bignum:
  1691.  
  1692.          {
  1693.          word slen;
  1694.          word dlen;
  1695.  
  1696.          slen = (BlkLoc(*dp1)->bignumblk.lsd - BlkLoc(*dp1)->bignumblk.msd + 1);
  1697.          dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  1698.          if (dlen > MaxDigits) {
  1699.             sprintf(sbuf,"integer(~%ld)",dlen - 2); /* center estimage */
  1700.             len = strlen(sbuf);
  1701.             if (strreq(len) == Error)
  1702.                return Error;
  1703.             StrLoc(*dp2) = alcstr(sbuf,strlen(sbuf));
  1704.             StrLen(*dp2) = len;
  1705.             return Success;
  1706.             }
  1707.          }
  1708. #endif                    /* LargeInts */
  1709.  
  1710.       case T_Integer:
  1711.  
  1712.       case T_Real:
  1713.          /*
  1714.           * Form a string representing the number and allocate it.
  1715.           */
  1716.          *dp2 = *dp1;            /* don't clobber dp1 */
  1717.          cvstr(dp2, sbuf);
  1718.          len = StrLen(*dp2);
  1719.          if (strreq(len) == Error) 
  1720.             return Error;
  1721.          StrLoc(*dp2) = alcstr(StrLoc(*dp2), len);
  1722.          StrLen(*dp2) = len;
  1723.          return Success;
  1724.  
  1725.       case T_Cset:
  1726.  
  1727.          /*
  1728.           * Check for distinguished csets by looking at the address of
  1729.           *  of the object to image.  If one is found, make a string
  1730.           *  naming it and return.
  1731.           */
  1732.          if (BlkLoc(*dp1) == ((union block *)&k_ascii)) {
  1733.             StrLoc(*dp2) = "&ascii";
  1734.             StrLen(*dp2) = 6;
  1735.             return Success;
  1736.             }
  1737.          else if (BlkLoc(*dp1) == ((union block *)&k_cset)) {
  1738.             StrLoc(*dp2) = "&cset";
  1739.             StrLen(*dp2) = 5;
  1740.             return Success;
  1741.             }
  1742.          else if (BlkLoc(*dp1) == ((union block *)&k_digits)) {
  1743.             StrLoc(*dp2) = "&digits";
  1744.             StrLen(*dp2) = 7;
  1745.             return Success;
  1746.             }
  1747.          else if (BlkLoc(*dp1) == ((union block *)&k_lcase)) {
  1748.             StrLoc(*dp2) = "&lcase";
  1749.             StrLen(*dp2) = 6;
  1750.             return Success;
  1751.             }
  1752.          else if (BlkLoc(*dp1) == ((union block *)&k_letters)) {
  1753.             StrLoc(*dp2) = "&letters";
  1754.             StrLen(*dp2) = 8;
  1755.             return Success;
  1756.             }
  1757.          else if (BlkLoc(*dp1) == ((union block *)&k_ucase)) {
  1758.             StrLoc(*dp2) = "&ucase";
  1759.             StrLen(*dp2) = 6;
  1760.             return Success;
  1761.             }
  1762.          /*
  1763.           * Convert the cset to a string and proceed as is done for
  1764.           *  string images but use a ' rather than " to bound the
  1765.           *  result string.
  1766.           */
  1767.          cvstr(dp1, sbuf);
  1768.          if (strreq(prescan(dp1) + 2) == Error) 
  1769.             return Error;
  1770.          len = StrLen(*dp1);
  1771.          s = StrLoc(*dp1);
  1772.          outlen = 2;
  1773.          StrLoc(*dp2) = alcstr("'", (word)(1));
  1774.          while (len-- > 0)
  1775.             outlen += doimage(*s++, '\'');
  1776.          alcstr("'", (word)(1));
  1777.          StrLen(*dp2) = outlen;
  1778.          return Success;
  1779.  
  1780.       case T_File:
  1781.          /*
  1782.           * Check for distinguished files by looking at the address of
  1783.           *  of the object to image.  If one is found, make a string
  1784.           *  naming it and return.
  1785.           */
  1786.          if ((fd = BlkLoc(*dp1)->file.fd) == stdin) {
  1787.             StrLen(*dp2) = 6;
  1788.             StrLoc(*dp2) = "&input";
  1789.             }
  1790.          else if (fd == stdout) {
  1791.             StrLen(*dp2) = 7;
  1792.             StrLoc(*dp2) = "&output";
  1793.             }
  1794.          else if (fd == stderr) {
  1795.             StrLen(*dp2) = 7;
  1796.             StrLoc(*dp2) = "&errout";
  1797.             }
  1798.          else {
  1799.             /*
  1800.              * The file is not a standard one; form a string of the form
  1801.              *    file(nm) where nm is the argument originally given to
  1802.              *    open.
  1803.              */
  1804.             if (strreq(prescan(&BlkLoc(*dp1)->file.fname)+6) == Error) 
  1805.                return Error;
  1806.             len = StrLen(BlkLoc(*dp1)->file.fname);
  1807.             s = StrLoc(BlkLoc(*dp1)->file.fname);
  1808.             outlen = 6;
  1809.             StrLoc(*dp2) = alcstr("file(", (word)(5));
  1810.             while (len-- > 0)
  1811.                outlen += doimage(*s++, '\0');
  1812.             alcstr(")", (word)(1));
  1813.             StrLen(*dp2) = outlen;
  1814.             }
  1815.          return Success;
  1816.  
  1817.       case T_Proc:
  1818.          /*
  1819.           * Produce one of:
  1820.           *  "procedure name"
  1821.           *  "function name"
  1822.           *  "record constructor name"
  1823.           *
  1824.           * Note that the number of dynamic locals is used to determine
  1825.           *  what type of "procedure" is at hand.
  1826.           */
  1827.          len = StrLen(BlkLoc(*dp1)->proc.pname);
  1828.          s = StrLoc(BlkLoc(*dp1)->proc.pname);
  1829.          switch ((int)BlkLoc(*dp1)->proc.ndynam) {
  1830.             default:  type = "procedure "; break;
  1831.             case -1:  type = "function "; break;
  1832.             case -2:  type = "record constructor "; break;
  1833.             }
  1834.          outlen = strlen(type);
  1835.          if (strreq(len + outlen) == Error) 
  1836.             return Error;
  1837.          StrLoc(*dp2) = alcstr(type, outlen);
  1838.          alcstr(s, len);
  1839.          StrLen(*dp2) = len + outlen;
  1840.          return Success;
  1841.  
  1842.       case T_List:
  1843.          /*
  1844.           * Produce:
  1845.           *  "list_m(n)"
  1846.           * where n is the current size of the list.
  1847.           */
  1848.          bp = BlkLoc(*dp1);
  1849.          sprintf(sbuf, "list_%ld(%ld)", (long)bp->list.id, (long)bp->list.size);
  1850.          len = strlen(sbuf);
  1851.          if (strreq(len) == Error) 
  1852.             return Error;
  1853.          StrLoc(*dp2) = alcstr(sbuf, len);
  1854.          StrLen(*dp2) = len;
  1855.          return Success;
  1856.  
  1857.       case T_Table:
  1858.          /*
  1859.           * Produce:
  1860.           *  "table_m(n)"
  1861.           * where n is the size of the table.
  1862.           */
  1863.          bp = BlkLoc(*dp1);
  1864.          sprintf(sbuf, "table_%ld(%ld)", (long)bp->table.id,
  1865.             (long)bp->table.size);
  1866.          len = strlen(sbuf);
  1867.          if (strreq(len) == Error) 
  1868.             return Error;
  1869.          StrLoc(*dp2) = alcstr(sbuf, len);
  1870.          StrLen(*dp2) = len;
  1871.          return Success;
  1872.  
  1873.       case T_Set:
  1874.          /*
  1875.           * Produce "set_m(n)" where n is size of the set.
  1876.           */
  1877.          bp = BlkLoc(*dp1);
  1878.          sprintf(sbuf, "set_%ld(%ld)", (long)bp->set.id, (long)bp->set.size);
  1879.          len = strlen(sbuf);
  1880.          if (strreq(len) == Error) 
  1881.             return Error;
  1882.          StrLoc(*dp2) = alcstr(sbuf,len);
  1883.          StrLen(*dp2) = len;
  1884.          return Success;
  1885.  
  1886.       case T_Record:
  1887.          /*
  1888.           * Produce:
  1889.           *  "record name_m(n)"    -- under construction
  1890.           * where n is the number of fields.
  1891.           */
  1892.          bp = BlkLoc(*dp1);
  1893.          rnlen = StrLen(bp->record.recdesc->proc.recname);
  1894.          if (strreq(15 + rnlen) == Error)    /* 15 = *"record " + *"(nnnnnn)"*/
  1895.             return Error;
  1896.          bp = BlkLoc(*dp1);
  1897.          sprintf(sbuf, "_%ld(%ld)", (long)bp->record.id,
  1898.             (long)bp->record.recdesc->proc.nfields);
  1899.          len = strlen(sbuf);
  1900.          StrLoc(*dp2) = alcstr("record ", (word)(7));
  1901.             alcstr(StrLoc(bp->record.recdesc->proc.recname),rnlen);
  1902.             alcstr(sbuf, len);
  1903.          StrLen(*dp2) = 7 + len + rnlen;
  1904.          return Success;
  1905.  
  1906.       case T_Coexpr:
  1907.          /*
  1908.           * Produce:
  1909.           *  "co-expression_m(n)"
  1910.           *  where m is the number of the co-expressions and n is the
  1911.           *  number of results that have been produced.
  1912.           */
  1913.  
  1914.          if (strreq((uword)30) == Error) 
  1915.             return Error;
  1916.          sprintf(sbuf, "_%ld(%ld)", (long)BlkLoc(*dp1)->coexpr.id,
  1917.             (long)BlkLoc(*dp1)->coexpr.size);
  1918.          len = strlen(sbuf);
  1919.          StrLoc(*dp2) = alcstr("co-expression", (word)(13));
  1920.          alcstr(sbuf, len);
  1921.          StrLen(*dp2) = 13 + len;
  1922.          return Success;
  1923.  
  1924.       case T_External:
  1925.          /*
  1926.           * For now, just produce "external(n)". 
  1927.           */
  1928.          sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize);
  1929.          len = strlen(sbuf);
  1930.          if (strreq(len) == Error) 
  1931.             return Error;
  1932.          StrLoc(*dp2) = alcstr(sbuf, len);
  1933.          StrLen(*dp2) = len;
  1934.          return Success;
  1935.  
  1936.       default:
  1937.          RetError(123,*dp1);
  1938.       }
  1939.    }
  1940.  
  1941. /*
  1942.  * printable(c) -- is c a "printable" character?
  1943.  */
  1944.  
  1945. int printable(c)
  1946. int c;
  1947.    {
  1948.  
  1949. /*
  1950.  * The following code is operating-system dependent [@rmisc.01].
  1951.  *  Determine if a character is "printable".
  1952.  */
  1953.  
  1954. #if PORT
  1955.    return isprint(c);
  1956. Deliberate Syntax Error
  1957. #endif                    /* PORT */
  1958.  
  1959. #if ARM
  1960.    return (c >= 0x00 && c <= 0x7F && isprint(c));
  1961. #endif                    /* ARM */
  1962.  
  1963. #if MACINTOSH
  1964.    return isprint(c);
  1965. #endif                    /* MACINTOSH */
  1966.  
  1967. #if MVS || VM
  1968. #if SASC
  1969.    return isascii(c) && !iscntrl(c);
  1970. #else                    /* SASC */
  1971.    return isprint(c);
  1972. #endif                    /* SASC */
  1973. #endif                                  /* MVS || VM */
  1974.  
  1975. #if AMIGA || ATARI_ST || HIGHC_386 || MSDOS || OS2 || UNIX || VMS
  1976.    return (isascii(c) && isprint(c));
  1977. #endif                    /* AMIGA || ATARI_ST ... */
  1978.  
  1979. /*
  1980.  * End of operating-system specific code.
  1981.  */
  1982.    }
  1983.  
  1984. #ifndef AsmOver
  1985. /*
  1986.  * add, sub, mul, neg with overflow check
  1987.  * all return 1 if ok, 0 if would overflow
  1988.  */
  1989.  
  1990. /*
  1991.  *  Note: on some systems an improvement in performance can be obtained by
  1992.  *  replacing the C functions that follow by checks written in assembly
  1993.  *  language.  To do so, add #define AsmOver to ../h/define.h.  If your
  1994.  *  C compiler supports the asm directive, but the new code at the end
  1995.  *  of this section under control of #else.  Otherwise put it a separate
  1996.  *  file.
  1997.  */
  1998.  
  1999. extern int over_flow;
  2000.  
  2001. word add(a, b)
  2002. word a, b;
  2003. {
  2004.    if ((a ^ b) >= 0 && (a >= 0 ? b > MaxLong - a : b < MinLong - a)) {
  2005.       over_flow = 1;
  2006.       return 0;
  2007.       }
  2008.    else {
  2009.      over_flow = 0;
  2010.      return a + b;
  2011.      }
  2012. }
  2013.  
  2014. word sub(a, b)
  2015. word a, b;
  2016. {
  2017.    if ((a ^ b) < 0 && (a >= 0 ? b < a - MaxLong : b > a - MinLong)) {
  2018.       over_flow = 1;
  2019.       return 0;
  2020.       }
  2021.    else {
  2022.       over_flow = 0;
  2023.       return a - b;
  2024.       }
  2025. }
  2026.  
  2027. word mul(a, b)
  2028. word a, b;
  2029. {
  2030.    if (b != 0) {
  2031.       if ((a ^ b) >= 0) {
  2032.      if (a >= 0 ? a > MaxLong / b : a < MaxLong / b) {
  2033.             over_flow = 1;
  2034.         return 0;
  2035.             }
  2036.      }
  2037.       else if (b != -1 && (a >= 0 ? a > MinLong / b : a < MinLong / b)) {
  2038.          over_flow = 1;
  2039.      return 0;
  2040.          }
  2041.       }
  2042.  
  2043.    over_flow = 0;
  2044.    return a * b;
  2045. }
  2046.  
  2047. /* MinLong / -1 overflows; need div3 too */
  2048.  
  2049. word neg(a)
  2050. word a;
  2051. {
  2052.    if (a == MinLong) {
  2053.       over_flow = 1;
  2054.       return 0;
  2055.       }
  2056.    over_flow = 0;
  2057.    return -a;
  2058. }
  2059. #endif                    /* AsmOver */
  2060.