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