/*
 * File: rmisc.c
 *  Contents: deref, eq, [gcvt], getvar, hash, outimage, [qsort],
 *  qtos, trace, pushact, popact, topact, [dumpact], putpos, putsub, putint,
 *  findline, findipc, findfile, [llqsort], doimage, prescan, getimage
 *  printable.
 *
 *  Integer overflow checking.
 */

#ifdef IconAlloc
#define free mem_free
#endif					/* IconAlloc */

#include <math.h>
#include "..\h\config.h"
#include "..\h\rt.h"
#include "rproto.h"
#include <ctype.h>

/*
 * Prototypes.
 */

hidden novalue	listimage
   Params((FILE *f,struct b_list *lp, int restrict));
hidden novalue	printimage	Params((FILE *f,int c,int q));

#ifdef IconQsort
hidden novalue	qswap		Params((char *a, char *b, int w));
#endif					/* IconQsort */

hidden novalue	showlevel	Params((int n));
hidden novalue	showline	Params((char *f,int l));

/*
 * deref - dereference a descriptor.
 */

int deref(dp)
dptr dp;
   {
   register uword hn;
   register union block *bp;
   struct descrip v, tref;
   union block *tbl;

   if (!Tvar(*dp))
       /*
       * An ordinary variable is being dereferenced; just replace
       *  *dp with the descriptor *dp is pointing to.
       */
      *dp = *(dptr)((word *)VarLoc(*dp) + Offset(*dp));
   else switch (Type(*dp)) {

         case T_Tvsubs:
            /*
             * A substring trapped variable is being dereferenced.
             *  Point bp to the trapped variable block and v to
             *  the string.
             */
            bp = TvarLoc(*dp);
            v = bp->tvsubs.ssvar;
            if (DeRef(v) == Error)
               return Error;
            if (!Qual(v))
               RetError(103, v);
            if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
               RetError(-205, nulldesc);
            /*
             * Make a descriptor for the substring by getting the
             *  length and pointing into the string.
             */
            StrLen(*dp) = bp->tvsubs.sslen;
            StrLoc(*dp) = StrLoc(v) + bp->tvsubs.sspos - 1;
            break;

         case T_Tvtbl:
            if (BlkLoc(*dp)->tvtbl.title == T_Telem) {
               /*
                * The tvtbl has been converted to a telem and is
                *  in the table.  Replace the descriptor pointed to
                *  by dp with the value of the element.
                */
                *dp = BlkLoc(*dp)->telem.tval;
                break;
                }

            /*
             *  Point tbl to the table header block, tref to the
             *  subscripting value, and bp to the appropriate 
             *  chain.  Point dp to a descriptor for the default
             *  value in case the value referenced by the subscript
             *  is not in the table.
             */
            tbl = BlkLoc(*dp)->tvtbl.clink;
            tref = BlkLoc(*dp)->tvtbl.tref;
            hn = BlkLoc(*dp)->tvtbl.hashnum;
            *dp = tbl->table.defvalue;
            bp = *(hchain((union block *)tbl, hn));

            /*
             * Traverse the element chain looking for the subscript
             *  value.  If found, replace the descriptor pointed to
             *  by dp with the value of the element.
             */
            while (bp != NULL && bp->telem.hashnum <= hn) {
               if ((bp->telem.hashnum == hn) &&
                  (equiv(&bp->telem.tref, &tref))) {
                     *dp = bp->telem.tval;
                     break;
                     }
               bp = bp->telem.clink;
               }
            break;

         case T_Tvkywd:
            bp = TvarLoc(*dp);
            *dp = bp->tvkywd.kyval;
            break;

         default:
            syserr("deref: illegal trapped variable");
         }

#ifdef DeBugIconx
   if (Var(*dp))
      syserr("deref: didn't get dereferenced");
#endif					/* DeBugIconx */

   return Success;
   }

#ifdef IconGcvt
/*
 * gcvt - Convert number to a string in buf.  If possible, ndigit
 *  significant digits are produced, otherwise a form with an exponent is used.
 *
 *  The name is actually #defined as "icon_gcvt" in config.h.
 */
char *gcvt(number, ndigit, buf)
double number;
int ndigit;
char *buf;
   {
   int sign, decpt;
   register char *p1, *p2;
   register i;

   p1 = ecvt(number, ndigit, &decpt, &sign);
   p2 = buf;
   if (sign)
      *p2++ = '-';
   for (i=ndigit-1; i>0 && p1[i]=='0'; i--)
      ndigit--;
   if (decpt >= 0 && decpt-ndigit > 4
      || decpt < 0 && decpt < -3) { /* use E-style */
         decpt--;
         *p2++ = *p1++;
         *p2++ = '.';
         for (i=1; i<ndigit; i++)
            *p2++ = *p1++;
         *p2++ = 'e';
         if (decpt<0) {
            decpt = -decpt;
            *p2++ = '-';
            }
         else
            *p2++ = '+';
         if (decpt/100 > 0)
            *p2++ = decpt/100 + '0';
         if (decpt/10 > 0)
            *p2++ = (decpt%100)/10 + '0';
         *p2++ = decpt%10 + '0';
      } else {
         if (decpt<=0) {
         /* if (*p1!='0') */
         *p2++ = '0';
         *p2++ = '.';
         while (decpt<0) {
            decpt++;
            *p2++ = '0';
            }
         }
         for (i=1; i<=ndigit; i++) {
            *p2++ = *p1++;
            if (i==decpt)
               *p2++ = '.';
            }
      if (ndigit<decpt) {
         while (ndigit++<decpt)
            *p2++ = '0';
         *p2++ = '.';
         }
   }
   if (p2[-1]=='.')
      *p2++ = '0';
   *p2 = '\0';

   return(buf);
   }
#endif					/* IconGcvt */

/*
 * Get variable descriptor from name.
 */

int getvar(s,vp)
   char *s;
   dptr vp;
   {
   register dptr dp;
   register dptr np;
   register int i;
   struct b_proc *bp;
   struct pf_marker *fp = pfp;

/*
 * Is it a keyword that's a variable?
 */
   if (*s == '&') {

      if (strcmp(s,"&error") == 0) {	/* must put basic one first */
         vp->dword = D_Tvkywd;
         VarLoc(*vp) = (dptr)&tvky_err;
         return Success;
         }




      else if (strcmp(s,"&pos") == 0) {
         vp->dword = D_Tvkywd;
         VarLoc(*vp) = (dptr)&tvky_pos;
         return Success;
         }
      else if (strcmp(s,"&random") == 0) {
         vp->dword = D_Tvkywd;
         VarLoc(*vp) = (dptr)&tvky_ran;
         return Success;
         }
      else if (strcmp(s,"&subject") == 0) {
         vp->dword = D_Tvkywd;
         VarLoc(*vp) = (dptr)&tvky_sub;
         return Success;
         }
      else if (strcmp(s,"&trace") == 0) {
         vp->dword = D_Tvkywd;
         VarLoc(*vp) = (dptr)&tvky_trc;
         return Success;
         }
      else return Failure;
      }

/*
 * Look for the variable with the name of the local identifiers,
 *  parameters, and static names in each Icon procedure frame on the stack.
 *  If not found among the locals, check the global variables.
 *  If a variable with name is found, variable() returns a variable
 *  descriptor that points to the corresponding value descriptor. 
 *  If no such variable exits, it fails.
 */
      
   /*
    *  If no procedure has been called (as can happen with icon_call(),
    *  dont' try to find local identifier.
    */
   if (pfp == NULL)
      goto glbvars;
   dp = argp;
   bp = (struct b_proc *)BlkLoc(*dp);	/* get address of procedure block */
   
   np = bp->lnames;		/* Check the formal parameter names. */
   for (i = abs((int)bp->nparam); i > 0; i--) {
      dp++;
      if (strcmp(s,StrLoc(*np)) == 0) {
         vp->dword = D_Var;
         VarLoc(*vp) = (dptr)dp;
         return Success;
         }
      np++;
      }

   dp = &fp->pf_locals[0];
   for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */
      if (strcmp(s,StrLoc(*np)) == 0) {
         vp->dword = D_Var;
         VarLoc(*vp) = (dptr)dp;
         return Success;
         }
      np++;
      dp++;
      }

   dp = &statics[bp->fstatic]; /* Check the local static names. */
   for (i = (int)bp->nstatic; i > 0; i--) {
      if (strcmp(s,StrLoc(*np)) == 0) {
         vp->dword = D_Var;
         VarLoc(*vp) = (dptr)dp;
         return Success;
         }
      np++;
      dp++;
      }

glbvars:
   dp = globals;	/* Check the global variable names. */
   np = gnames;
   while (dp < eglobals) {
      if (strcmp(s,StrLoc(*np)) == 0) {
         vp->dword    =  D_Var;
         VarLoc(*vp) =  (dptr)(dp);
         return Success;
         }
      np++;
      dp++;
      }
   return Failure;
}

/*
 * hash - compute hash value of arbitrary object for table and set accessing.
 */

uword hash(dp)
dptr dp;
   {
   register char *s;
   register uword i;
   register word j, n;
   register int *bitarr;
   double r;

   if (Qual(*dp)) {

      /*
       * Compute the hash value for the string based on a scaled sum
       *  of its first ten characters, plus its length.
       */
      i = 0;
      s = StrLoc(*dp);
      j = n = StrLen(*dp);
      if (j > 10)		/* limit scan to first ten characters */
         j = 10;
      while (j-- > 0) {
         i += *s++ & 0xFF;	/* add unsigned version of next char */
         i *= 39;		/* scale total by a nice prime number */
         }
      i += n;			/* add the (untruncated) string length */
      }

   else {

      switch (Type(*dp)) {
         /*
          * The hash value of an integer is itself times eight times the golden
	  *  ratio.  We do this calculation in fixed point.  We don't just use
	  *  the integer itself, for that would give bad results with sets
	  *  having entries that are multiples of a power of two.
          */
         case T_Integer:
            i = (13255 * (uword)IntVal(*dp)) >> 10;
            break;

#ifdef LargeInts
         /*
          * The hash value of a bignum is based on its length and its
          *  most and least significant digits.
          */
	 case T_Bignum:
	    {
	    struct b_bignum *b = &BlkLoc(*dp)->bignumblk;

	    i = ((b->lsd - b->msd) << 16) ^ 
		(b->digits[b->msd] << 8) ^ b->digits[b->lsd];
	    }
	    break;
#endif					/* LargeInts */

         /*
          * The hash value of a real number is itself times a constant,
          *  converted to an unsigned integer.  The intent is to scramble
	  *  the bits well, in the case of integral values, and to scale up
	  *  fractional values so they don't all land in the same bin.
	  *  The constant below is 32749 / 29, the quotient of two primes,
	  *  and was observed to work well in empirical testing.
          */
         case T_Real:
            GetReal(dp,r);
            i = r * 1129.27586206896558;
            break;

         /*
          * The hash value of a cset is based on a convoluted combination
          *  of all its bits.
          */
         case T_Cset:
            i = 0;
            bitarr = BlkLoc(*dp)->cset.bits + CsetSize - 1;
            for (j = 0; j < CsetSize; j++) {
               i += *bitarr--;
               i *= 37;			/* better distribution */
               }
            i %= 1048583;		/* scramble the bits */
            break;

         /*
          * The hash value of a list, set, table, or record is its id,
          *   hashed like an integer.
          */
         case T_List:
            i = (13255 * BlkLoc(*dp)->list.id) >> 10;
            break;

         case T_Set:
            i = (13255 * BlkLoc(*dp)->set.id) >> 10;
            break;

         case T_Table:
            i = (13255 * BlkLoc(*dp)->table.id) >> 10;
            break;

         case T_Record:
            i = (13255 * BlkLoc(*dp)->record.id) >> 10;
            break;
 
         default:
            /*
             * For other types, use the type code as the hash
             *  value.
             */
            i = Type(*dp);
            break;
         }
      }

   return i;
   }

#define StringLimit	16		/* limit on length of imaged string */
#define ListLimit	 6		/* limit on list items in image */

/*
 * outimage - print image of *dp on file f.  If restrict is nonzero,
 *  fields of records will not be imaged.
 */

novalue outimage(f, dp, restrict)
FILE *f;
dptr dp;
int restrict;
   {
   register word i, j;
   register char *s;
   register union block *bp, *vp;
   char *type;
   FILE *fd;
   struct descrip q;
   extern char *blkname[];
   double rresult;

outimg:

   if (Qual(*dp)) {
      /*
       * *dp is a string qualifier.  Print StringLimit characters of it
       *  using printimage and denote the presence of additional characters
       *  by terminating the string with "...".
       */
      i = StrLen(*dp);
      s = StrLoc(*dp);
      j = Min(i, StringLimit);
      putc('"', f);
      while (j-- > 0)
         printimage(f, *s++, '"');
      if (i > StringLimit)
         fprintf(f, "...");
      putc('"', f);
      return;
      }

   if (Var(*dp) && !Tvar(*dp)) {
      /*
       * *d is a variable.  Print "variable =", dereference it, and 
       *  call outimage to handle the value.
       */
      fprintf(f, "(variable = ");
      dp = (dptr)((word *)VarLoc(*dp) + Offset(*dp));
      outimage(f, dp, restrict);
      putc(')', f);
      return;
      }

   switch (Type(*dp)) {

      case T_Null:
         fprintf(f, "&null");
         return;

      case T_Integer:
         fprintf(f, "%ld", (long)IntVal(*dp));
         return;

#ifdef LargeInts
      case T_Bignum:
	 bigprint(f, dp);
	 return;
#endif					/* LargeInts */

      case T_Real:
         {
         char s[30];
         struct descrip rd;

         GetReal(dp,rresult);
         rtos(rresult, &rd, s);
         fprintf(f, "%s", StrLoc(rd));
         return;
         }

      case T_Cset:
         /*
          * Check for distinguished csets by looking at the address of
          *  of the object to image.  If one is found, print its name.
          */
         if ((char *)BlkLoc(*dp) == (char *)&k_ascii) {
            fprintf(f, "&ascii");
            return;
            }
         else if ((char *)BlkLoc(*dp) == (char *)&k_cset) {
            fprintf(f, "&cset");
            return;
            }
         else if ((char *)BlkLoc(*dp) == (char *)&k_digits) {
            fprintf(f, "&digits");
            return;
            }
         else if ((char *)BlkLoc(*dp) == (char *)&k_lcase) {
            fprintf(f, "&lcase");
            return;
            }
         else if ((char *)BlkLoc(*dp) == (char *)&k_letters) {
            fprintf(f, "&letters");
            return;
            }
         else if ((char *)BlkLoc(*dp) == (char *)&k_ucase) {
            fprintf(f, "&ucase");
            return;
            }
         /*
          * Use printimage to print each character in the cset.  Follow
          *  with "..." if the cset contains more than StringLimit
          *  characters.
          */
         putc('\'', f);
         j = StringLimit;
         for (i = 0; i < 256; i++) {
            if (Testb(i, BlkLoc(*dp)->cset.bits)) {
               if (j-- <= 0) {
                  fprintf(f, "...");
                  break;
                  }
               printimage(f, (int)FromAscii(i), '\'');
               }
            }
         putc('\'', f);
         return;

      case T_File:
         /*
          * Check for distinguished files by looking at the address of
          *  of the object to image.  If one is found, print its name.
          */
         if ((fd = BlkLoc(*dp)->file.fd) == stdin)
            fprintf(f, "&input");
         else if (fd == stdout)
            fprintf(f, "&output");
         else if (fd == stderr)
            fprintf(f, "&errout");
         else {
            /*
             * The file isn't a special one, just print "file(name)".
             */
            i = StrLen(BlkLoc(*dp)->file.fname);
            s = StrLoc(BlkLoc(*dp)->file.fname);
            fprintf(f, "file(");
            while (i-- > 0)
               printimage(f, *s++, '\0');
            putc(')', f);
            }
         return;

      case T_Proc:
         /*
          * Produce one of:
          *  "procedure name"
          *  "function name"
          *  "record constructor name"
          *
          * Note that the number of dynamic locals is used to determine
          *  what type of "procedure" is at hand.
          */
         i = StrLen(BlkLoc(*dp)->proc.pname);
         s = StrLoc(BlkLoc(*dp)->proc.pname);
         switch ((int)BlkLoc(*dp)->proc.ndynam) {
            default:  type = "procedure"; break;
            case -1:  type = "function"; break;
            case -2:  type = "record constructor"; break;
            }
         fprintf(f, "%s ", type);
         while (i-- > 0)
            printimage(f, *s++, '\0');
         return;

      case T_List:
         /*
          * listimage does the work for lists.
          */
         listimage(f, (struct b_list *)BlkLoc(*dp), restrict);
         return;

      case T_Table:
         /*
          * Print "table_m(n)" where n is the size of the table.
          */
         fprintf(f, "table_%ld(%ld)", (long)BlkLoc(*dp)->table.id,
            (long)BlkLoc(*dp)->table.size);
         return;

      case T_Set:
	/*
         * print "set_m(n)" where n is the cardinality of the set
         */
	fprintf(f,"set_%ld(%ld)",(long)BlkLoc(*dp)->set.id,
           (long)BlkLoc(*dp)->set.size);
	return;

      case T_Record:
         /*
          * If restrict is nonzero, print "record(n)" where n is the
          *  number of fields in the record.  If restrict is zero, print
          *  the image of each field instead of the number of fields.
          */
         bp = BlkLoc(*dp);
         i = StrLen(bp->record.recdesc->proc.recname);
         s = StrLoc(bp->record.recdesc->proc.recname);
         fprintf(f, "record ");
         while (i-- > 0)
            printimage(f, *s++, '\0');
        fprintf(f, "_%ld", bp->record.id);
         j = bp->record.recdesc->proc.nfields;
         if (j <= 0)
            fprintf(f, "()");
         else if (restrict > 0)
            fprintf(f, "(%ld)", (long)j);
         else {
            putc('(', f);
            i = 0;
            for (;;) {
               outimage(f, &bp->record.fields[i], restrict+1);
               if (++i >= j)
                  break;
               putc(',', f);
               }
            putc(')', f);
            }
         return;

      case T_Tvsubs:
         /*
          * Produce "v[i+:j] = value" where v is the image of the variable
          *  containing the substring, i is starting position of the substring
          *  j is the length, and value is the string v[i+:j].	If the length
          *  (j) is one, just produce "v[i] = value".
          */
         bp = BlkLoc(*dp);
	 dp = VarLoc(bp->tvsubs.ssvar);
	 if (!Tvar(bp->tvsubs.ssvar))
            dp = (dptr)((word *)dp + Offset(bp->tvsubs.ssvar));
         if (dp == (dptr)&tvky_sub)
            fprintf(f, "&subject");
         else outimage(f, dp, restrict);
         if (bp->tvsubs.sslen == 1)
            fprintf(f, "[%ld]", (long)bp->tvsubs.sspos);
         else
            fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos,
                    (long)bp->tvsubs.sslen);
         if (dp == (dptr)&tvky_sub) {
            vp = BlkLoc(bp->tvsubs.ssvar);
            if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 >
                  StrLen(vp->tvkywd.kyval))
               return;
            StrLen(q) = bp->tvsubs.sslen;
            StrLoc(q) = StrLoc(vp->tvkywd.kyval) + bp->tvsubs.sspos - 1;
            fprintf(f, " = ");
            dp = &q;
            goto outimg;
            }
         else if (Qual(*dp)) {
            if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(*dp))
               return;
            StrLen(q) = bp->tvsubs.sslen;
            StrLoc(q) = StrLoc(*dp) + bp->tvsubs.sspos - 1;
            fprintf(f, " = ");
            dp = &q;
            goto outimg;
            }
         return;

      case T_Tvtbl:
         bp = BlkLoc(*dp);
         /*
          * It is possible that the descriptor that thinks it is pointing
          *  to a tabel-element trapped variable may actually be pointing
          *  at a table element block which had been converted from a
          *  trapped variable. Check for this first and if it is a table
          *  element block, produce the outimage of its value.
          */
         if (bp->tvtbl.title == T_Telem) {
            outimage(f, &bp->tvtbl.tval, restrict);
            return;
            }
         /*
          * It really was a tvtbl - produce "t[s]" where t is the image of
          *  the table containing the element and s is the image of the
          *  subscript.
          */
         else {
	    dp->dword = D_Table;
	    BlkLoc(*dp) = bp->tvtbl.clink;
            outimage(f, dp, restrict);
            putc('[', f);
            outimage(f, &bp->tvtbl.tref, restrict);
            putc(']', f);
            return;
            }

      case T_Tvkywd:
         bp = BlkLoc(*dp);
         i = StrLen(bp->tvkywd.kyname);
         s = StrLoc(bp->tvkywd.kyname);
         while (i-- > 0)
            putc(*s++, f);
         fprintf(f, " = ");
         outimage(f, &bp->tvkywd.kyval, restrict);
         return;

      case T_Coexpr:
         fprintf(f, "co-expression_%ld(%ld)",
            (long)((struct b_coexpr *)BlkLoc(*dp))->id,
            (long)((struct b_coexpr *)BlkLoc(*dp))->size);
         return;

      case T_External:
         fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize);
         return;

      default:
         if (Type(*dp) <= MaxType)
            fprintf(f, "%s", blkname[Type(*dp)]);
         else
            syserr("outimage: unknown type");
      }
   }

/*
 * printimage - print character c on file f using escape conventions
 *  if c is unprintable, '\', or equal to q.
 */

static novalue printimage(f, c, q)
FILE *f;
int c, q;
   {
   if (printable(c)) {
      /*
       * c is printable, but special case ", ', and \.
       */
      switch (c) {
         case '"':
            if (c != q) goto def;
            fprintf(f, "\\\"");
            return;
         case '\'':
            if (c != q) goto def;
            fprintf(f, "\\'");
            return;
         case '\\':
            fprintf(f, "\\\\");
            return;
         default:
         def:
            putc(c, f);
            return;
         }
      }

   /*
    * c is some sort of unprintable character.	If it one of the common
    *  ones, produce a special representation for it, otherwise, produce
    *  its hex value.
    */
   switch (c) {
      case '\b':			/* backspace */
         fprintf(f, "\\b");
         return;

#if !EBCDIC
      case '\177':			/* delete */
#else					/* !EBCDIC */
      case '\x07':
#endif					/* !EBCDIC */

         fprintf(f, "\\d");
         return;
#if !EBCDIC
      case '\33':			/* escape */
#else					/* !EBCDIC */
      case '\x27':
#endif					/* !EBCDIC */
         fprintf(f, "\\e");
         return;
      case '\f':			/* form feed */
         fprintf(f, "\\f");
         return;
      case LineFeed:			/* new line */
         fprintf(f, "\\n");
         return;

#if EBCDIC == 1
      case '\x25':                      /* EBCDIC line feed */
         fprintf(f, "\\l");
         return;
#endif					/* EBCDIC == 1 */

      case CarriageReturn:		/* carriage return */
         fprintf(f, "\\r");
         return;
      case '\t':			/* horizontal tab */
         fprintf(f, "\\t");
         return;
      case '\13':			/* vertical tab */
         fprintf(f, "\\v");
         return;
      default:				/* hex escape sequence */
         fprintf(f, "\\x%02x", ToAscii(c & 0xff));
         return;
      }
   }

/*
 * listimage - print an image of a list.
 */

static novalue listimage(f, lp, restrict)
FILE *f;
struct b_list *lp;
int restrict;
   {
   register word i, j;
   register struct b_lelem *bp;
   word size, count;

   bp = (struct b_lelem *) lp->listhead;
   size = lp->size;

   if (restrict > 0 && size > 0) {
      /*
       * Just give indication of size if the list isn't empty.
       */
      fprintf(f, "list_%ld(%ld)", (long)lp->id, (long)size);
      return;
      }

   /*
    * Print [e1,...,en] on f.  If more than ListLimit elements are in the
    *  list, produce the first ListLimit/2 elements, an ellipsis, and the
    *  last ListLimit elements.
    */
   fprintf(f, "list_%ld = [", (long)lp->id);
   count = 1;
   i = 0;
   if (size > 0) {
      for (;;) {
         if (++i > bp->nused) {
            i = 1;
            bp = (struct b_lelem *) bp->listnext;
            }
         if (count <= ListLimit/2 || count > size - ListLimit/2) {
            j = bp->first + i - 1;
            if (j >= bp->nslots)
               j -= bp->nslots;
            outimage(f, &bp->lslots[j], restrict+1);
            if (count >= size)
               break;
            putc(',', f);
            }
         else if (count == ListLimit/2 + 1)
            fprintf(f, "...,");
         count++;
         }
      }
   putc(']', f);
   }

#ifdef IconQsort
/* qsort(base,nel,width,compar) - quicksort routine
 *
 * A Unix-compatible public domain quicksort.
 * Based on Bentley, CACM 28,7 (July, 1985), p. 675.
 */
     
novalue qsort(base, nel, w, compar)
char *base;
int nel, w;
int (*compar)();
{
   int i, lastlow;
    
   if (nel < 2)
      return;
   qswap(base, base + w * (rand() % nel), w);
   lastlow = 0;
   for (i = 1; i < nel; i++)
      if ((*compar) (base + w * i, base) < 0)
         qswap(base + w * i, base + w * (++lastlow), w);
   qswap(base, base + w * lastlow, w);
   qsort(base, lastlow, w, compar);
   qsort(base + w * (lastlow+1), nel-lastlow-1, w, compar);
}
    
static novalue qswap(a, b, w)		/* swap *a and *b of width w for qsort*/
char *a, *b;
int w;
{
   register t;
    
   while (w--)  {
      t = *a;
      *a++ = *b;
      *b++ = t;
   }
}
#endif					/* IconQsort */

/*
 * qtos - convert a qualified string named by *dp to a C-style string.
 *  Put the C-style string in sbuf if it will fit, otherwise put it
 *  in the string region.
 */

int qtos(dp, sbuf)
dptr dp;
char *sbuf;
   {
   register word slen;
   register char *c;

   c = StrLoc(*dp);
   slen = StrLen(*dp)++;
   if (slen >= MaxCvtLen) {
      if (strreq(slen + 1) == Error) 
         return Error;
      if (c + slen != strfree)
         StrLoc(*dp) = alcstr(c, slen);
      alcstr("",(word)1);
      }
   else {
      StrLoc(*dp) = sbuf;
      for ( ; slen > 0; slen--)
         *sbuf++ = *c++;
      *sbuf = '\0';
      }
   return Success;
   }

/*
 * ctrace - procedure named s is being called with nargs arguments, the first
 *  of which is at arg; produce a trace message.
 */
novalue ctrace(dp, nargs, arg)
dptr dp;
int nargs;
dptr arg;
   {

   showline(findfile(ipc.opnd), findline(ipc.opnd));
   showlevel(k_level);
   putstr(stderr, dp);
   putc('(', stderr);
   while (nargs--) {
      outimage(stderr, arg++, 0);
      if (nargs)
         putc(',', stderr);
      }
   putc(')', stderr);
   putc('\n', stderr);
   fflush(stderr);
   }

/*
 * rtrace - procedure named s is returning *rval; produce a trace message.
 */

novalue rtrace(dp, rval)
dptr dp;
dptr rval;
   {
   inst t_ipc;

   /*
    * Compute the ipc of the return instruction.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, dp);
   fprintf(stderr, " returned ");
   outimage(stderr, rval, 0);
   putc('\n', stderr);
   fflush(stderr);
   }

/*
 * failtrace - procedure named s is failing; produce a trace message.
 */

novalue failtrace(dp)
dptr dp;
   {
   inst t_ipc;

   /*
    * Compute the ipc of the fail instruction.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, dp);
   fprintf(stderr, " failed");
   putc('\n', stderr);
   fflush(stderr);
   }

/*
 * strace - procedure named s is suspending *rval; produce a trace message.
 */

novalue strace(dp, rval)
dptr dp;
dptr rval;
   {
   inst t_ipc;

   /*
    * Compute the ipc of the suspend instruction.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, dp);
   fprintf(stderr, " suspended ");
   outimage(stderr, rval, 0);
   putc('\n', stderr);
   fflush(stderr);
   }

/*
 * atrace - procedure named s is being resumed; produce a trace message.
 */

novalue atrace(dp)
dptr dp;
   {
   inst t_ipc;

   /*
    * Compute the ipc of the instruction causing resumption.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, dp);
   fprintf(stderr, " resumed");
   putc('\n', stderr);
   fflush(stderr);
   }

#ifdef Coexpr
/*
 * coacttrace -- co-expression is being activated; produce a trace message.
 */
novalue coacttrace(ccp, ncp)
struct b_coexpr *ccp;
struct b_coexpr *ncp;
   {
   struct b_proc *bp;
   inst t_ipc;

   bp = (struct b_proc *)BlkLoc(*argp);
   /*
    * Compute the ipc of the activation instruction.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, &(bp->pname));
   fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id);
   outimage(stderr, (dptr)(sp - 3), 0);
   fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id);
   fflush(stderr);
   }

/*
 * corettrace -- return from co-expression; produce a trace message.
 */
novalue corettrace(ccp, ncp)
struct b_coexpr *ccp;
struct b_coexpr *ncp;
   {
   struct b_proc *bp;
   inst t_ipc;

   bp = (struct b_proc *)BlkLoc(*argp);
   /*
    * Compute the ipc of the coret instruction.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, &(bp->pname));
   fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id);
   outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0);
   fprintf(stderr," to co-expression_%ld\n", (long)ncp->id);
   fflush(stderr);
   }

/*
 * cofailtrace -- failure return from co-expression; produce a trace message.
 */
novalue cofailtrace(ccp, ncp)
struct b_coexpr *ccp;
struct b_coexpr *ncp;
   {
   struct b_proc *bp;
   inst t_ipc;

   bp = (struct b_proc *)BlkLoc(*argp);
   /*
    * Compute the ipc of the cofail instruction.
    */
   t_ipc.op = ipc.op - 1;
   showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
   showlevel(k_level);
   putstr(stderr, &(bp->pname));
   fprintf(stderr,"; co-epression_%ld failed to co-expression_%ld\n",
      (long)ccp->id, (long)ncp->id);
   fflush(stderr);
   }
#endif					/* Coexpr */

/*
 * showline - print file and line number information.
 */
static novalue showline(f, l)
char *f;
int l;
   {
   int i;

   i = (int)strlen(f);

#if MVS
   while (i > 22) {
#else					/* MVS */
   while (i > 13) {
#endif					/* MVS */
      f++;
      i--;
      }
   if (l > 0)

#if MVS
      fprintf(stderr, "%-22s: %4d  ",f, l);
   else
      fprintf(stderr, "                      :      ");
#else					/* MVS */
      fprintf(stderr, "%-13s: %4d  ",f, l);
   else
      fprintf(stderr, "             :      ");
#endif					/* MVS */

   }

/*
 * showlevel - print "| " n times.
 */
static novalue showlevel(n)
register int n;
   {
   while (n-- > 0) {
      putc('|', stderr);
      putc(' ', stderr);
      }
   }

/*
 * putpos - assign value to &pos
 */

int putpos(dp,bp)
dptr dp;
struct b_tvkywd *bp;
   {

#if MACINTOSH && MPW
/* #pragma unused(bp) */
#endif					/* MACINTOSH && MPW */

   register word l1;
   switch (cvint(dp)) {

      case T_Integer:
         l1 = cvpos(IntVal(*dp), StrLen(k_subject));
         if (l1 == CvtFail)
            return Failure;
         k_pos = l1;
         return Success;

      default:
         RetError(101, *dp);
      }
   }

/*
 * putsub - assign value to &subject
 */

int putsub(dp,bp)
dptr dp;
struct b_tvkywd *bp;
   {

#if MACINTOSH && MPW
/* #pragma unused(bp) */
#endif					/* MACINTOSH && MPW */

   char sbuf[MaxCvtLen];

   switch (cvstr(dp, sbuf)) {

      case Cvt:
         if (strreq(StrLen(*dp)) == Error)
            return Error;
         StrLoc(*dp) = alcstr(StrLoc(*dp), StrLen(*dp));
         /* no break */

      case NoCvt:
         k_subject = *dp;
         k_pos = 1;
         return Success;

     default:
        RetError(103, *dp);

      }
   }

/*
 * putint - assign integer value to keyword
 */

int putint(dp,bp)
dptr dp;
struct b_tvkywd *bp;
   {
   switch (cvint(dp)) {

      case T_Integer:
         IntVal(bp->kyval) = IntVal(*dp);
         return Success;

      default:
         RetError(101, *dp);
      }
   }

#ifdef Coexpr
/*
 * pushact - push actvtr on the activator stack of ce
 */
int pushact(ce, actvtr)
struct b_coexpr *ce, *actvtr;
{
   struct astkblk *abp = ce->es_actstk, *nabp;
   struct actrec *arp;

   /*
    * If the last activator is the same as this one, just increment
    *  its count.
    */
   if (abp->nactivators > 0) {
      arp = &abp->arec[abp->nactivators - 1];
      if (arp->activator == actvtr) {
         arp->acount++;
         return Success;
         }
      }
   /*
    * This activator is different from the last one.  Push this activator
    *  on the stack, possibly adding another block.
    */
   if (abp->nactivators + 1 > ActStkBlkEnts) {
      nabp = alcactiv();
      if (nabp == NULL)
         return Error;
      nabp->astk_nxt = abp;
      abp = nabp;
      }
   abp->nactivators++;
   arp = &abp->arec[abp->nactivators - 1];
   arp->acount = 1;
   arp->activator = actvtr;
   ce->es_actstk = abp;
   return Success;
}

/*
 * popact - pop the most recent activator from the activator stack of ce
 *  and return it.
 */
struct b_coexpr *popact(ce)
struct b_coexpr *ce;
{
   struct astkblk *abp = ce->es_actstk, *oabp;
   struct actrec *arp;
   struct b_coexpr *actvtr;

   /*
    * If the current stack block is empty, pop it.
    */
   if (abp->nactivators == 0) {
      oabp = abp;
      abp = abp->astk_nxt;
      free((pointer)oabp);
      }

   if (abp == NULL || abp->nactivators == 0)
      syserr("empty activator stack\n");

   /*
    * Find the activation record for the most recent co-expression.
    *  Decrement the activation count and if it is zero, pop that
    *  activation record and decrement the count of activators.
    */
   arp = &abp->arec[abp->nactivators - 1];
   actvtr = arp->activator;
   if (--arp->acount == 0)
      abp->nactivators--;

   ce->es_actstk = abp;
   return actvtr;
}

/*
 * topact - return the most recent activator of ce.
 */
struct b_coexpr *topact(ce)
struct b_coexpr *ce;
{
   struct astkblk *abp = ce->es_actstk;
   
   if (abp->nactivators == 0)
      abp = abp->astk_nxt;
   return abp->arec[abp->nactivators-1].activator;
}

#ifdef DeBugIconx
/*
 * dumpact - dump an activator stack
 */
novalue dumpact(ce)
struct b_coexpr *ce;
{
   struct astkblk *abp = ce->es_actstk;
   struct actrec *arp;
   int i;

   if (abp)
      fprintf(stderr, "Ce %ld ", (long)ce->id);
   while (abp) {
      fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n",
         abp, abp->nactivators);
      for (i = abp->nactivators; i >= 1; i--) {
         arp = &abp->arec[i-1];
         /*for (j = 1; j <= arp->acount; j++)*/
         fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id),
            arp->acount);
         }
      abp = abp->astk_nxt;
      }
}
#endif					/* DeBugIconx */
#endif					/* Coexpr */

/*
 * findline - find the source line number associated with the ipc
 */
int findline(ipc)
word *ipc;
{
   uword ipc_offset;
   uword size;
   struct ipc_line *base;
   extern struct ipc_line *ilines, *elines;
   extern word *records;
   static two = 2;	/* some compilers generate bad code for division
			   by a constant that is a power of two ... */

   if (!InRange(code,ipc,records))
      return 0;
   ipc_offset = DiffPtrs((char *)ipc,(char *)code);
   base = ilines;
   size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
   while (size > 1) {
      if (ipc_offset >= base[size / two].ipc) {
         base = &base[size / two];
         size -= size / two;
         }
      else
         size = size / two;
      }
   return (int)base->line;
}
/*
 * findipc - find the first ipc associated with a source-code line number.
 */
int findipc(line)
int line;
{
   uword size;
   struct ipc_line *base;
   extern struct ipc_line *ilines, *elines;
   static two = 2;	/* some compilers generate bad code for division
			   by a constant that is a power of two ... */

   base = ilines;
   size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
   while (size > 1) {
      if (line >= base[size / two].line) {
         base = &base[size / two];
         size -= size / two;
         }
      else
         size = size / two;
      }
   return base->ipc;
}

/*
 * findfile - find source file name associated with the ipc
 */
char *findfile(ipc)
word *ipc;
{
   uword ipc_offset;
   struct ipc_fname *p;
   extern struct ipc_fname *filenms, *efilenms;
   extern word *records;
   extern char *strcons;

   if (!InRange(code,ipc,records))
      return "?";
   ipc_offset = DiffPtrs((char *)ipc,(char *)code);
   for (p = efilenms - 1; p >= filenms; p--)
      if (ipc_offset >= p->ipc)
         return strcons + p->fname;
   fprintf(stderr,"bad ipc/file name table");
   fflush(stderr);
   c_exit(ErrorExit);
}

#if IntBits == 16
/* Shell sort with some enhancements from Knuth.. */

novalue llqsort(base, nel, width, cmp )
char *base;
int nel;
int width;
int (*cmp)();
{
   register long i, j;
   long int gap;
   int k;
   char *p1, *p2, tmp;

   for( gap=1; gap <= nel; gap = 3*gap + 1 ) ;

   for( gap /= 3;  gap > 0  ; gap /= 3 )
       for( i = gap; i < nel; i++ )
	   for( j = i-gap; j >= 0 ; j -= gap ) {
		p1 = base + ( j     * width);
		p2 = base + ((j+gap) * width);

		if( (*cmp)( p1, p2 ) <= 0 ) break;

		for( k = width; --k >= 0 ;) {
		   tmp	 = *p1;
		   *p1++ = *p2;
		   *p2++ = tmp;
		}
	   }
}

#endif					/* IntBits == 16 */
/*
 * doimage(c,q) - allocate character c in string space, with escape
 *  conventions if c is unprintable, '\', or equal to q.
 *  Returns number of characters allocated.
 */

doimage(c, q)
int c, q;
   {
   static char cbuf[5];

   if (printable(c)) {

      /*
       * c is printable, but special case ", ', and \.
       */
      switch (c) {
         case '"':
            if (c != q) goto def;
            alcstr("\\\"", (word)(2));
            return 2;
         case '\'':
            if (c != q) goto def;
            alcstr("\\'", (word)(2));
            return 2;
         case '\\':
            alcstr("\\\\", (word)(2));
            return 2;
         default:
         def:
            cbuf[0] = c;
            alcstr(cbuf, (word)(1));
            return 1;
         }
      }

   /*
    * c is some sort of unprintable character.	If it is one of the common
    *  ones, produce a special representation for it, otherwise, produce
    *  its hex value.
    */
   switch (c) {
      case '\b':			/*	   backspace	*/
         alcstr("\\b", (word)(2));
         return 2;

#if !EBCDIC
      case '\177':			/*      delete	  */
#else					/* !EBCDIC */
      case '\x07':			/*      delete    */
#endif					/* !EBCDIC */

         alcstr("\\d", (word)(2));
         return 2;

#if !EBCDIC
      case '\33':			/*	    escape	 */
#else					/* !EBCDIC */
      case '\x27':			/*          escape       */
#endif					/* !EBCDIC */

         alcstr("\\e", (word)(2));
         return 2;
      case '\f':			/*	   form feed	*/
         alcstr("\\f", (word)(2));
         return 2;

#if EBCDIC == 1
      case '\x25':                      /* EBCDIC line feed */
         alcstr("\\l", (word)(2));
         return 2;
#endif					/* EBCDIC */

      case LineFeed:			/*	   new line	*/
         alcstr("\\n", (word)(2));
         return 2;
      case CarriageReturn:		/*	   return	*/
         alcstr("\\r", (word)(2));
         return 2;
      case '\t':			/*	   horizontal tab     */
         alcstr("\\t", (word)(2));
         return 2;
      case '\13':			/*	    vertical tab     */
         alcstr("\\v", (word)(2));
         return 2;
      default:				/*	  hex escape sequence  */
         sprintf(cbuf, "\\x%02x", ToAscii(c & 0xff));
         alcstr(cbuf, (word)(4));
         return 4;
      }
   }

/*
 * prescan(d) - return upper bound on length of expanded string.  Note
 *  that the only time that prescan is wrong is when the string contains
 *  one of the "special" unprintable characters, e.g. tab.
 */
word prescan(d)
dptr d;
   {
   register word slen, len;
   register char *s, c;

   s = StrLoc(*d);
   len = 0;
   for (slen = StrLen(*d); slen > 0; slen--)

#if EBCDIC
#if SASC
      if (!isascii(c = (*s++)) || iscntrl(c))
#else					/* SASC */
      if (!isprint(c = (*s++)))
#endif					/* SASC */
#else					/* EBCDIC */
      if ((c = (*s++)) < ' ' || c >= 0177)
#endif					/* EBCDIC */

         len += 4;
      else if (c == '"' || c == '\\' || c == '\'')
         len += 2;
      else
         len++;

   return len;
   }

/*
 * getimage(dp1,dp2) - return string image of object dp1 in dp2.
 */

int getimage(dp1,dp2)
   dptr dp1, dp2;
   {
   register word len, outlen, rnlen;
   register char *s;
   register union block *bp;
   char *type;
   char sbuf[MaxCvtLen];
   FILE *fd;

   if (Qual(*dp1)) {
      /*
       * Get some string space.  The magic 2 is for the double quote at each
       *  end of the resulting string.
       */
      if (strreq(prescan(dp1) + 2) == Error) 
         return Error;
      len = StrLen(*dp1);
      s = StrLoc(*dp1);
      outlen = 2;

      /*
       * Form the image by putting a quote in the string space, calling
       *  doimage with each character in the string, and then putting
       *  a quote at then end.	Note that doimage directly writes into the
       *  string space.  (Hence the indentation.)  This techinique is used
       *  several times in this routine.
       */
      StrLoc(*dp2) = alcstr("\"", (word)(1));
      while (len-- > 0)
         outlen += doimage(*s++, '"');
      alcstr("\"", (word)(1));
      StrLen(*dp2) = outlen;
      return Success;
      }

   switch (Type(*dp1)) {

      case T_Null:
         StrLoc(*dp2) = "&null";
         StrLen(*dp2) = 5;
         return Success;

#ifdef LargeInts
      case T_Bignum:

         {
         word slen;
         word dlen;

         slen = (BlkLoc(*dp1)->bignumblk.lsd - BlkLoc(*dp1)->bignumblk.msd + 1);
         dlen = slen * NB * 0.3010299956639812;	/* 1 / log2(10) */
         if (dlen > MaxDigits) {
            sprintf(sbuf,"integer(~%ld)",dlen - 2); /* center estimage */
            len = strlen(sbuf);
            if (strreq(len) == Error)
               return Error;
            StrLoc(*dp2) = alcstr(sbuf,strlen(sbuf));
            StrLen(*dp2) = len;
            return Success;
            }
         }
#endif					/* LargeInts */

      case T_Integer:

      case T_Real:
         /*
          * Form a string representing the number and allocate it.
          */
         *dp2 = *dp1;			/* don't clobber dp1 */
         cvstr(dp2, sbuf);
         len = StrLen(*dp2);
         if (strreq(len) == Error) 
            return Error;
         StrLoc(*dp2) = alcstr(StrLoc(*dp2), len);
         StrLen(*dp2) = len;
         return Success;

      case T_Cset:

         /*
          * Check for distinguished csets by looking at the address of
          *  of the object to image.  If one is found, make a string
          *  naming it and return.
          */
         if (BlkLoc(*dp1) == ((union block *)&k_ascii)) {
            StrLoc(*dp2) = "&ascii";
            StrLen(*dp2) = 6;
            return Success;
            }
         else if (BlkLoc(*dp1) == ((union block *)&k_cset)) {
            StrLoc(*dp2) = "&cset";
            StrLen(*dp2) = 5;
            return Success;
            }
         else if (BlkLoc(*dp1) == ((union block *)&k_digits)) {
            StrLoc(*dp2) = "&digits";
            StrLen(*dp2) = 7;
            return Success;
            }
         else if (BlkLoc(*dp1) == ((union block *)&k_lcase)) {
            StrLoc(*dp2) = "&lcase";
            StrLen(*dp2) = 6;
            return Success;
            }
         else if (BlkLoc(*dp1) == ((union block *)&k_letters)) {
            StrLoc(*dp2) = "&letters";
            StrLen(*dp2) = 8;
            return Success;
            }
         else if (BlkLoc(*dp1) == ((union block *)&k_ucase)) {
            StrLoc(*dp2) = "&ucase";
            StrLen(*dp2) = 6;
            return Success;
            }
         /*
          * Convert the cset to a string and proceed as is done for
          *  string images but use a ' rather than " to bound the
          *  result string.
          */
         cvstr(dp1, sbuf);
         if (strreq(prescan(dp1) + 2) == Error) 
            return Error;
         len = StrLen(*dp1);
         s = StrLoc(*dp1);
         outlen = 2;
         StrLoc(*dp2) = alcstr("'", (word)(1));
         while (len-- > 0)
            outlen += doimage(*s++, '\'');
         alcstr("'", (word)(1));
         StrLen(*dp2) = outlen;
         return Success;

      case T_File:
         /*
          * Check for distinguished files by looking at the address of
          *  of the object to image.  If one is found, make a string
          *  naming it and return.
          */
         if ((fd = BlkLoc(*dp1)->file.fd) == stdin) {
            StrLen(*dp2) = 6;
            StrLoc(*dp2) = "&input";
            }
         else if (fd == stdout) {
            StrLen(*dp2) = 7;
            StrLoc(*dp2) = "&output";
            }
         else if (fd == stderr) {
            StrLen(*dp2) = 7;
            StrLoc(*dp2) = "&errout";
            }
         else {
            /*
             * The file is not a standard one; form a string of the form
             *	file(nm) where nm is the argument originally given to
             *	open.
             */
            if (strreq(prescan(&BlkLoc(*dp1)->file.fname)+6) == Error) 
               return Error;
            len = StrLen(BlkLoc(*dp1)->file.fname);
            s = StrLoc(BlkLoc(*dp1)->file.fname);
            outlen = 6;
            StrLoc(*dp2) = alcstr("file(", (word)(5));
            while (len-- > 0)
               outlen += doimage(*s++, '\0');
            alcstr(")", (word)(1));
            StrLen(*dp2) = outlen;
            }
         return Success;

      case T_Proc:
         /*
          * Produce one of:
          *  "procedure name"
          *  "function name"
          *  "record constructor name"
          *
          * Note that the number of dynamic locals is used to determine
          *  what type of "procedure" is at hand.
          */
         len = StrLen(BlkLoc(*dp1)->proc.pname);
         s = StrLoc(BlkLoc(*dp1)->proc.pname);
         switch ((int)BlkLoc(*dp1)->proc.ndynam) {
            default:  type = "procedure "; break;
            case -1:  type = "function "; break;
            case -2:  type = "record constructor "; break;
            }
         outlen = strlen(type);
         if (strreq(len + outlen) == Error) 
            return Error;
         StrLoc(*dp2) = alcstr(type, outlen);
         alcstr(s, len);
         StrLen(*dp2) = len + outlen;
         return Success;

      case T_List:
         /*
          * Produce:
          *  "list_m(n)"
          * where n is the current size of the list.
          */
         bp = BlkLoc(*dp1);
         sprintf(sbuf, "list_%ld(%ld)", (long)bp->list.id, (long)bp->list.size);
         len = strlen(sbuf);
         if (strreq(len) == Error) 
            return Error;
         StrLoc(*dp2) = alcstr(sbuf, len);
         StrLen(*dp2) = len;
         return Success;

      case T_Table:
         /*
          * Produce:
          *  "table_m(n)"
          * where n is the size of the table.
          */
         bp = BlkLoc(*dp1);
         sprintf(sbuf, "table_%ld(%ld)", (long)bp->table.id,
            (long)bp->table.size);
         len = strlen(sbuf);
         if (strreq(len) == Error) 
            return Error;
         StrLoc(*dp2) = alcstr(sbuf, len);
         StrLen(*dp2) = len;
         return Success;

      case T_Set:
         /*
          * Produce "set_m(n)" where n is size of the set.
          */
         bp = BlkLoc(*dp1);
         sprintf(sbuf, "set_%ld(%ld)", (long)bp->set.id, (long)bp->set.size);
         len = strlen(sbuf);
         if (strreq(len) == Error) 
            return Error;
         StrLoc(*dp2) = alcstr(sbuf,len);
         StrLen(*dp2) = len;
         return Success;

      case T_Record:
         /*
          * Produce:
          *  "record name_m(n)"	-- under construction
          * where n is the number of fields.
          */
         bp = BlkLoc(*dp1);
         rnlen = StrLen(bp->record.recdesc->proc.recname);
         if (strreq(15 + rnlen) == Error)    /* 15 = *"record " + *"(nnnnnn)"*/
            return Error;
         bp = BlkLoc(*dp1);
         sprintf(sbuf, "_%ld(%ld)", (long)bp->record.id,
            (long)bp->record.recdesc->proc.nfields);
         len = strlen(sbuf);
         StrLoc(*dp2) = alcstr("record ", (word)(7));
            alcstr(StrLoc(bp->record.recdesc->proc.recname),rnlen);
            alcstr(sbuf, len);
         StrLen(*dp2) = 7 + len + rnlen;
         return Success;

      case T_Coexpr:
         /*
          * Produce:
          *  "co-expression_m(n)"
          *  where m is the number of the co-expressions and n is the
          *  number of results that have been produced.
          */

         if (strreq((uword)30) == Error) 
            return Error;
         sprintf(sbuf, "_%ld(%ld)", (long)BlkLoc(*dp1)->coexpr.id,
            (long)BlkLoc(*dp1)->coexpr.size);
         len = strlen(sbuf);
         StrLoc(*dp2) = alcstr("co-expression", (word)(13));
         alcstr(sbuf, len);
         StrLen(*dp2) = 13 + len;
         return Success;

      case T_External:
         /*
          * For now, just produce "external(n)". 
          */
         sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize);
         len = strlen(sbuf);
         if (strreq(len) == Error) 
            return Error;
         StrLoc(*dp2) = alcstr(sbuf, len);
         StrLen(*dp2) = len;
         return Success;

      default:
         RetError(123,*dp1);
      }
   }

/*
 * printable(c) -- is c a "printable" character?
 */

int printable(c)
int c;
   {

/*
 * The following code is operating-system dependent [@rmisc.01].
 *  Determine if a character is "printable".
 */

#if PORT
   return isprint(c);
Deliberate Syntax Error
#endif					/* PORT */

#if MACINTOSH
   return isprint(c);
#endif					/* MACINTOSH */

#if MVS || VM
#if SASC
   return isascii(c) && !iscntrl(c);
#else					/* SASC */
   return isprint(c);
#endif					/* SASC */
#endif                                  /* MVS || VM */

#if AMIGA || ATARI_ST || HIGHC_386 || MSDOS || OS2 || UNIX || VMS
   return (isascii(c) && isprint(c));
#endif					/* AMIGA || ATARI_ST ... */

/*
 * End of operating-system specific code.
 */
   }

#ifndef AsmOver
/*
 * add, sub, mul, neg with overflow check
 * all return 1 if ok, 0 if would overflow
 */

/*
 *  Note: on some systems an improvement in performance can be obtained by
 *  replacing the C functions that follow by checks written in assembly
 *  language.  To do so, add #define AsmOver to ../h/define.h.  If your
 *  C compiler supports the asm directive, but the new code at the end
 *  of this section under control of #else.  Otherwise put it a separate
 *  file.
 */

extern int over_flow;

word add(a, b)
word a, b;
{
   if ((a ^ b) >= 0 && (a >= 0 ? b > MaxLong - a : b < MinLong - a)) {
      over_flow = 1;
      return 0;
      }
   else {
     over_flow = 0;
     return a + b;
     }
}

word sub(a, b)
word a, b;
{
   if ((a ^ b) < 0 && (a >= 0 ? b < a - MaxLong : b > a - MinLong)) {
      over_flow = 1;
      return 0;
      }
   else {
      over_flow = 0;
      return a - b;
      }
}

word mul(a, b)
word a, b;
{
   if (b != 0) {
      if ((a ^ b) >= 0) {
	 if (a >= 0 ? a > MaxLong / b : a < MaxLong / b) {
            over_flow = 1;
	    return 0;
            }
	 }
      else if (b != -1 && (a >= 0 ? a > MinLong / b : a < MinLong / b)) {
         over_flow = 1;
	 return 0;
         }
      }

   over_flow = 0;
   return a * b;
}

/* MinLong / -1 overflows; need div3 too */

word neg(a)
word a;
{
   if (a == MinLong) {
      over_flow = 1;
      return 0;
      }
   over_flow = 0;
   return -a;
}
#endif					/* AsmOver */