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