home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v92.tgz / v92.tar / v92 / src / runtime / fmisc.r < prev    next >
Text File  |  1996-03-22  |  55KB  |  2,056 lines
  1. /*
  2.  * File: fmisc.r
  3.  * Contents:
  4.  *  args, char, collect, copy, display, function, iand, icom, image, ior,
  5.  *  ishift, ixor, [keyword], [load], ord, name, runerr, seq, sort, sortf,
  6.  *  type, variable
  7.  */
  8.  
  9. "args(p) - produce number of arguments for procedure p."
  10.  
  11. function{1} args(x)
  12.  
  13.    if !is:proc(x) then
  14.       runerr(106, x)
  15.  
  16.    abstract {
  17.       return integer
  18.       }
  19.    inline {
  20.       return C_integer ((struct b_proc *)BlkLoc(x))->nparam;
  21.       }
  22. end
  23.  
  24. #if !COMPILER
  25. #ifdef ExternalFunctions
  26.  
  27. /*
  28.  * callout - call a C library routine (or any C routine that doesn't call Icon)
  29.  *   with an argument count and a list of descriptors.  This routine
  30.  *   doesn't build a procedure frame to prepare for calling Icon back.
  31.  */
  32. function{1} callout(x[nargs])
  33.    body {
  34.       dptr retval;
  35.       int signal;
  36.  
  37.       /*
  38.        * Little cheat here.  Although this is a var-arg procedure, we need
  39.        *  at least one argument to get started: pretend there is a null on
  40.        *  the stack.  NOTE:  Actually, at present, varargs functions always
  41.        *  have at least one argument, so this doesn't plug the hole.
  42.        */
  43.       if (nargs < 1)
  44.          runerr(103, nulldesc);
  45.  
  46.       /*
  47.        * Call the 'C routine caller' with a pointer to an array of descriptors.
  48.        *  Note that these are being left on the stack. We are passing
  49.        *  the name of the routine as part of the convention of calling
  50.        *  routines with an argc/argv technique.
  51.        */
  52.       signal = -1;            /* presume successful completiong */
  53.       retval = extcall(x, nargs, &signal);
  54.       if (signal >= 0) {
  55.          if (retval == NULL)
  56.             runerr(signal);
  57.          else
  58.             runerr(signal, *retval); 
  59.          }
  60.       if (retval != NULL) {
  61.          return *retval;
  62.          }
  63.       else 
  64.          fail;
  65.       }
  66. end
  67.  
  68. #endif                     /* ExternalFunctions */
  69. #endif                    /* !COMPILER */
  70.  
  71.  
  72. "char(i) - produce a string consisting of character i."
  73.  
  74. function{1} char(i)
  75.  
  76.    if !cnv:C_integer(i) then
  77.       runerr(101,i)
  78.    abstract {
  79.       return string
  80.       }
  81.    body {
  82.       if (i < 0 || i > 255) {
  83.          irunerr(205, i);
  84.          errorfail;
  85.          }
  86.       return string(1, (char *)&allchars[FromAscii(i) & 0xFF]);
  87.       }
  88. end
  89.  
  90.  
  91. "collect(i1,i2) - call garbage collector to ensure i2 bytes in region i1."
  92. " no longer works."
  93.  
  94. function{1} collect(region, bytes)
  95.  
  96.    if !def:C_integer(region, (C_integer)0) then
  97.       runerr(101, region) 
  98.    if !def:C_integer(bytes, (C_integer)0) then
  99.       runerr(101, bytes)
  100.  
  101.    abstract {
  102.       return null
  103.       }
  104.    body {
  105.       if (bytes < 0) {
  106.          irunerr(205, bytes);
  107.          errorfail;
  108.          }
  109.       switch (region) {
  110.      case 0:
  111.         collect(0);
  112.         break;
  113.      case Static:
  114.         collect(Static);             /* i2 ignored if i1==Static */
  115.         break;
  116.      case Strings:
  117.         if (DiffPtrs(strend,strfree) >= bytes)
  118.            collect(Strings);        /* force unneded collection */
  119.         else if (!reserve(Strings, bytes))    /* collect & reserve bytes */
  120.                fail;
  121.         break;
  122.      case Blocks:
  123.         if (DiffPtrs(blkend,blkfree) >= bytes)
  124.            collect(Blocks);            /* force unneded collection */
  125.         else if (!reserve(Blocks, bytes))    /* collect & reserve bytes */
  126.                fail;
  127.         break;
  128.      default:
  129.             irunerr(205, region);
  130.             errorfail;
  131.          }
  132.       return nulldesc;
  133.       }
  134. end
  135.  
  136.  
  137. "copy(x) - make a copy of object x."
  138.  
  139. function{1} copy(x)
  140.    abstract {
  141.       return type(x)
  142.       }
  143.    type_case x of {
  144.       null:
  145.       string:
  146.       cset:
  147.       integer:
  148.       real:
  149.       file:
  150.       proc:
  151.       coexpr:
  152.          inline {
  153.             /*
  154.              * Copy the null value, integers, long integers, reals, files,
  155.              *    csets, procedures, and such by copying the descriptor.
  156.              *    Note that for integers, this results in the assignment
  157.              *    of a value, for the other types, a pointer is directed to
  158.              *    a data block.
  159.              */
  160.             return x;
  161.             }
  162.  
  163.       list:
  164.          inline {
  165.             /*
  166.              * Pass the buck to cplist to copy a list.
  167.              */
  168.             if (cplist(&x, &result, (word)1, BlkLoc(x)->list.size + 1) ==Error)
  169.            runerr(0);
  170.             return result;
  171.             }
  172.       table: {
  173.          body {
  174.             register int i;
  175.             register word slotnum;
  176.             tended union block *src;
  177.             tended union block *dst;
  178.         tended struct b_slots *seg;
  179.         tended struct b_telem *ep, *prev;
  180.         struct b_telem *te;
  181.             /*
  182.              * Copy a Table.  First, allocate and copy header and slot blocks.
  183.              */
  184.             src = BlkLoc(x);
  185.             dst = hmake(T_Table, src->table.mask + 1, src->table.size);
  186.             if (dst == NULL)
  187.                runerr(0);
  188.             dst->table.size = src->table.size;
  189.             dst->table.mask = src->table.mask;
  190.             dst->table.defvalue = src->table.defvalue;
  191.             for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++)
  192.                memcopy((char *)dst->table.hdir[i], (char *)src->table.hdir[i],
  193.                   src->table.hdir[i]->blksize);
  194.             /*
  195.              * Work down the chain of element blocks in each bucket
  196.              *    and create identical chains in new table.
  197.              */
  198.             for (i = 0; i < HSegs && (seg = dst->table.hdir[i]) != NULL; i++)
  199.                for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--)  {
  200.           prev = NULL;
  201.                   for (ep = (struct b_telem *)seg->hslots[slotnum];
  202.             ep != NULL; ep = (struct b_telem *)ep->clink) {
  203.              Protect(te = alctelem(), runerr(0));
  204.              *te = *ep;                /* copy table entry */
  205.              if (prev == NULL)
  206.             seg->hslots[slotnum] = (union block *)te;
  207.              else
  208.             prev->clink = (union block *)te;
  209.              te->clink = ep->clink;
  210.              prev = te;
  211.                      }
  212.                   }
  213.  
  214.             if (TooSparse(dst))
  215.                hshrink(dst);
  216.         return table(dst);
  217.             }
  218.          }
  219.  
  220.       set: {
  221.          body {
  222.             /*
  223.              * Pass the buck to cpset to copy a set.
  224.              */
  225.             if (cpset(&x, &result, BlkLoc(x)->set.size) == Error)
  226.                runerr(0);
  227.         return result;
  228.             }
  229.          }
  230.  
  231.       record: {
  232.          body {
  233.             /*
  234.              * Note, these pointers don't need to be tended, because they are
  235.              *  not used until after allocation is complete.
  236.              */
  237.             struct b_record *new_rec;
  238.             tended struct b_record *old_rec;
  239.             dptr d1, d2;
  240.             int i;
  241.  
  242.             /*
  243.              * Allocate space for the new record and copy the old
  244.              *    one into it.
  245.              */
  246.             old_rec = (struct b_record *)BlkLoc(x);
  247.             i = old_rec->recdesc->proc.nfields;
  248.  
  249.             /* #%#% param changed ? */
  250.             Protect(new_rec = alcrecd(i,old_rec->recdesc), runerr(0));
  251.             d1 = new_rec->fields;
  252.             d2 = old_rec->fields;
  253.             while (i--)
  254.                *d1++ = *d2++;
  255.             return record(new_rec);
  256.             }
  257.          }
  258.  
  259.       default: body {
  260. #if Never
  261.          if (Type(x) == T_External) {
  262.             word n;
  263.             tended union block *op, *bp;
  264.  
  265.             /*
  266.              * Duplicate the block.  Recover number of data words in block,
  267.              * then allocate new block and copy the data.
  268.              */
  269.             op = BlkLoc(x);
  270.             n = (op->externl.blksize - (sizeof(struct b_external) - 
  271.                  sizeof(word))) / sizeof(word);
  272.             Protect(bp = (union block *)alcextrnl(n), runerr(0));
  273.             while (n--)
  274.                bp->externl.exdata[n] = op->externl.exdata[n];
  275.             result.dword = D_External;
  276.             BlkLoc(result) = bp;
  277.         return result;
  278.             }
  279.          else
  280. #endif                    /* Never */
  281.             runerr(123,x);
  282.          }
  283.          }
  284. end
  285.  
  286.  
  287. "display(i,f) - display local variables of i most recent"
  288. " procedure activations, plus global variables."
  289. " Output to file f (default &errout)."
  290.  
  291. #ifdef MultiThread
  292. function{1} display(i,f,c)
  293.    declare {
  294.       struct b_coexpr *ce = NULL;
  295.       struct progstate *prog, *savedprog;
  296.       }
  297. #else                    /* MultiThread */
  298. function{1} display(i,f)
  299. #endif                    /* MultiThread */
  300.  
  301.    if !def:C_integer(i,(C_integer)k_level) then
  302.       runerr(101, i)
  303.  
  304.    if is:null(f) then
  305.        inline {
  306.       f.dword = D_File;
  307.       BlkLoc(f) = (union block *)&k_errout;
  308.           }
  309.    else if !is:file(f) then
  310.       runerr(105, f)
  311.  
  312. #ifdef MultiThread
  313.    if !is:null(c) then inline {
  314.       if (!is:coexpr(c)) runerr(118,c);
  315.       else if (BlkLoc(c) != BlkLoc(k_current))
  316.          ce = (struct b_coexpr *)BlkLoc(c);
  317.       savedprog = curpstate;
  318.       }
  319. #endif                        /* MultiThread */
  320.  
  321.    abstract {
  322.       return null
  323.       }
  324.  
  325.    body {
  326.       FILE *std_f;
  327.       int r;
  328.  
  329.       if (!debug_info)
  330.          runerr(402);
  331.  
  332.       /*
  333.        * Produce error if file cannot be written.
  334.        */
  335.       std_f = BlkLoc(f)->file.fd;
  336.       if ((BlkLoc(f)->file.status & Fs_Write) == 0) 
  337.          runerr(213, f);
  338.  
  339.       /*
  340.        * Produce error if i is negative; constrain i to be <= &level.
  341.        */
  342.       if (i < 0) {
  343.          irunerr(205, i);
  344.          errorfail;
  345.          }
  346.       else if (i > k_level)
  347.          i = k_level;
  348.  
  349.       fprintf(std_f,"co-expression_%ld(%ld)\n\n",BlkLoc(k_current)->coexpr.id,
  350.          BlkLoc(k_current)->coexpr.size);
  351.       fflush(std_f);
  352. #ifdef MultiThread
  353.       if (ce) {
  354.      if ((ce->es_pfp == NULL) || (ce->es_argp == NULL)) fail;
  355.      ENTERPSTATE(ce->program);
  356.          r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f);
  357.      ENTERPSTATE(savedprog);
  358.        }
  359.       else
  360. #endif                        /* MultiThread */
  361.          r = xdisp(pfp, argp, (int)i, std_f);
  362.       if (r == Failed)
  363.          runerr(305);
  364.       return nulldesc;
  365.       }
  366. end
  367.  
  368.  
  369. "errorclear() - clear error condition."
  370.  
  371. function{1} errorclear()
  372.    abstract {
  373.       return null
  374.       }
  375.    body {
  376.       k_errornumber = 0;
  377.       k_errortext = "";
  378.       k_errorvalue = nulldesc;
  379.       have_errval = 0;
  380.       return nulldesc;
  381.       }
  382. end
  383.  
  384. #if !COMPILER
  385.  
  386. "function() - generate the names of the functions."
  387.  
  388. function{*} function()
  389.    abstract {
  390.       return string
  391.       }
  392.    body {
  393.       register int i;
  394.  
  395.       for (i = 0; i<pnsize; i++) {
  396.      suspend string(strlen(pntab[i].pstrep), pntab[i].pstrep);
  397.          }
  398.       fail;
  399.       }
  400. end
  401. #endif                    /* !COMPILER */
  402.  
  403.  
  404. /*
  405.  * the bitwise operators are identical enough to be expansions
  406.  *  of a macro.
  407.  */
  408.  
  409. #begdef  bitop(func_name, c_op, operation)
  410. #func_name "(i,j) - produce bitwise " operation " of i and j."
  411. function{1} func_name(i,j)
  412.    /*
  413.     * i and j must be integers
  414.     */
  415.    if !cnv:integer(i) then
  416.       runerr(101,i)
  417.    if !cnv:integer(j) then
  418.       runerr(101,j)
  419.  
  420.    abstract {
  421.       return integer
  422.       }
  423.    inline {
  424. #ifdef LargeInts
  425.       if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) {
  426.          big_ ## c_op(i,j);
  427.          }
  428.       else
  429. #endif                    /* LargeInts */
  430.       return C_integer IntVal(i) c_op IntVal(j);
  431.       }
  432. end
  433. #enddef
  434.  
  435. #define bitand &
  436. #define bitor  |
  437. #define bitxor ^
  438. #begdef big_bitand(x,y)
  439. {
  440.    if (bigand(&x, &y, &result) == Error)  /* alcbignum failed */
  441.       runerr(0);
  442.    return result;
  443. }
  444. #enddef
  445. #begdef big_bitor(x,y)
  446. {
  447.    if (bigor(&x, &y, &result) == Error)  /* alcbignum failed */
  448.       runerr(0);
  449.    return result;
  450. }
  451. #enddef
  452. #begdef big_bitxor(x,y)
  453. {
  454.    if (bigxor(&x, &y, &result) == Error)  /* alcbignum failed */
  455.       runerr(0);
  456.    return result;
  457. }
  458. #enddef
  459.  
  460. bitop(iand, bitand, "AND")          /* iand(i,j) bitwise "and" of i and j */
  461. bitop(ior,  bitor, "inclusive OR")  /* ior(i,j) bitwise "or" of i and j */
  462. bitop(ixor, bitxor, "exclusive OR") /* ixor(i,j) bitwise "xor" of i and j */
  463.  
  464.  
  465. "icom(i) - produce bitwise complement (one's complement) of i."
  466.  
  467. function{1} icom(i)
  468.    /*
  469.     * i must be an integer
  470.     */
  471.    if !cnv:integer(i) then
  472.       runerr(101, i)
  473.  
  474.    abstract {
  475.       return integer
  476.       }
  477.    inline {
  478. #ifdef LargeInts
  479.       if (Type(i) == T_Lrgint) {
  480.          struct descrip td;
  481.  
  482.          td.dword = D_Integer;
  483.          IntVal(td) = -1;
  484.          if (bigsub(&td, &i, &result) == Error)  /* alcbignum failed */
  485.             runerr(0);
  486.          return result;
  487.          }
  488.       else
  489. #endif                    /* LargeInts */
  490.       return C_integer ~IntVal(i);
  491.       }
  492. end
  493.  
  494.  
  495. "image(x) - return string image of object x."
  496. /*
  497.  *  All the interesting work happens in getimage()
  498.  */
  499. function{1} image(x)
  500.    abstract {
  501.       return string
  502.       }
  503.    inline {
  504.       register int i;
  505.       if (getimage(&x,&result) == Error)
  506.           runerr(0);
  507.       return result;
  508.       }
  509. end
  510.  
  511.  
  512. "ishift(i,j) - produce i shifted j bit positions (left if j<0, right if j>0)."
  513.  
  514. function{1} ishift(i,j)
  515.  
  516.    if !cnv:integer(i) then
  517.       runerr(101, i)
  518.    if !cnv:integer(j) then
  519.       runerr(101, j)
  520.  
  521.    abstract {
  522.       return integer
  523.       }
  524.    body {
  525.       uword ci;             /* shift in 0s, even if negative */
  526.       C_integer cj;
  527. #ifdef LargeInts
  528.       if (Type(j) == T_Lrgint)
  529.          runerr(101,j);
  530.       cj = IntVal(j);
  531.       if (Type(i) == T_Lrgint || cj >= WordBits
  532.       || ((ci=(uword)IntVal(i))!=0 && cj>0 && (ci >= (1<<(WordBits-cj-1))))) {
  533.          if (bigshift(&i, &j, &result) == Error)  /* alcbignum failed */
  534.             runerr(0);
  535.          return result;
  536.          }
  537. #else                    /* LargeInts */
  538.       ci = (uword)IntVal(i);
  539.       cj = IntVal(j);
  540. #endif                    /* LargeInts */
  541.       /*
  542.        * Check for a shift of WordSize or greater; handle specially because
  543.        *  this is beyond C's defined behavior.  Otherwise shift as requested.
  544.        */
  545.       if (cj >= WordBits)
  546.          return C_integer 0;
  547.       if (cj <= -WordBits)
  548.          return C_integer ((IntVal(i) >= 0) ? 0 : -1);
  549.       if (cj >= 0)
  550.          return C_integer ci << cj;
  551.       if (IntVal(i) >= 0)
  552.          return C_integer ci >> -cj;
  553.       /*else*/
  554.          return C_integer ~(~ci >> -cj);    /* sign extending shift */
  555.       }
  556. end
  557.  
  558.  
  559. "ord(s) - produce integer ordinal (value) of single character."
  560.  
  561. function{1} ord(s)
  562.    if !cnv:tmp_string(s) then
  563.       runerr(103, s)
  564.    abstract {
  565.       return integer
  566.       }
  567.    body {
  568.       if (StrLen(s) != 1)
  569.          runerr(205, s);
  570.       return C_integer ToAscii(*StrLoc(s) & 0xFF);
  571.       }
  572. end
  573.  
  574.  
  575. "name(v) - return the name of a variable."
  576.  
  577. #ifdef MultiThread
  578. function{1} name(underef v, c)
  579.    declare {
  580.       struct progstate *prog, *savedprog;
  581.       }
  582. #else                        /* MultiThread */
  583. function{1} name(underef v)
  584. #endif                        /* MultiThread */
  585.    /*
  586.     * v must be a variable
  587.     */
  588.    if !is:variable(v) then
  589.       runerr(111, v);
  590.  
  591.    abstract {
  592.       return string
  593.       }
  594.  
  595.    body {
  596.       C_integer i;
  597.       if (!debug_info)
  598.          runerr(402);
  599.  
  600. #ifdef MultiThread
  601.       savedprog = curpstate;
  602.       if (is:null(c)) {
  603.          prog = curpstate;
  604.          }
  605.       else if (is:coexpr(c)) {
  606.          prog = BlkLoc(c)->coexpr.program;
  607.          }
  608.       else {
  609.          runerr(118,c);
  610.          }
  611.  
  612.       ENTERPSTATE(prog);
  613. #endif                        /* MultiThread */
  614.       i = get_name(&v, &result);        /* return val ? #%#% */
  615.  
  616. #ifdef MultiThread
  617.       ENTERPSTATE(savedprog);
  618. #endif                        /* MultiThread */
  619.  
  620.       if (i == Error)
  621.          runerr(0);
  622.       return result;
  623.       }
  624. end
  625.  
  626.  
  627. "runerr(i,x) - produce runtime error i with value x."
  628.  
  629. function{} runerr(i,x[n])
  630.  
  631.    if !cnv:C_integer(i) then
  632.       runerr(101,i)
  633.    body {
  634.       if (i <= 0) {
  635.          irunerr(205,i);
  636.          errorfail;
  637.          }
  638.       if (n == 0) 
  639.          runerr((int)i);
  640.       else
  641.          runerr((int)i, x[0]);
  642.       }
  643. end
  644.  
  645. "seq(i, j) - generate i, i+j, i+2*j, ... ."
  646.  
  647. function{1,*} seq(from, by)
  648.  
  649.    if !def:C_integer(from, 1) then
  650.       runerr(101, from)
  651.    if !def:C_integer(by, 1) then
  652.       runerr(101, by)
  653.    abstract {
  654.       return integer
  655.       }
  656.    body {
  657.       word seq_lb, seq_ub;
  658.  
  659.       /*
  660.        * Produce error if by is 0, i.e., an infinite sequence of from's.
  661.        */
  662.       if (by > 0) {
  663.          seq_lb = MinLong + by;
  664.          seq_ub = MaxLong;
  665.          }
  666.       else if (by < 0) {
  667.          seq_lb = MinLong;
  668.          seq_ub = MaxLong + by;
  669.          }
  670.       else if (by == 0) {
  671.          irunerr(211, by);
  672.          errorfail;
  673.  
  674.          }
  675.  
  676.       /*
  677.        * Suspend sequence, stopping when largest or smallest integer
  678.        *  is reached.
  679.        */
  680.       do {
  681.          suspend C_integer from;
  682.          from += by;
  683.          }
  684.       while (from >= seq_lb && from <= seq_ub);
  685.  
  686. #if !COMPILER
  687.       {
  688.       /*
  689.        * Suspending wipes out some things needed by the trace back code to
  690.        *  render the offending expression. Restore them.
  691.        */
  692.  
  693. #include "::h:opdefs.h"
  694.  
  695.       lastop = Op_Invoke;
  696.       xnargs = 2;
  697.       xargp = r_args;
  698.       r_args[0].dword = D_Proc;
  699.       r_args[0].vword.bptr = (union block *)&Bseq;
  700.       }
  701. #endif                    /* COMPILER */
  702.  
  703.       runerr(203);
  704.       }
  705. end
  706.  
  707. "sort(x,i) - sort structure x by method i (for tables)"
  708.  
  709. function{1} sort(t, i)
  710.    type_case t of {
  711.       list: {
  712.          abstract {
  713.             return type(t)
  714.             }
  715.          body {
  716.             register word size;
  717.  
  718.             /*
  719.              * Sort the list by copying it into a new list and then using
  720.              *  qsort to sort the descriptors.  (That was easy!)
  721.              */
  722.             size = BlkLoc(t)->list.size;
  723.             if (cplist(&t, &result, (word)1, size + 1) == Error)
  724.            runerr(0);
  725.             qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots,
  726.                (int)size, sizeof(struct descrip), (int (*)()) anycmp);
  727.  
  728.             Desc_EVValD(BlkLoc(result), E_Lcreate, D_List);
  729.             return result;
  730.             }
  731.          }
  732.  
  733.       record: {
  734.          abstract {
  735.             return new list(store[type(t).all_fields])
  736.             }
  737.          body {
  738.             register dptr d1;
  739.             register word size;
  740.             tended struct b_list *lp;
  741.             union block *ep, *bp;
  742.             register int i;
  743.             /*
  744.              * Create a list the size of the record, copy each element into
  745.              * the list, and then sort the list using qsort as in list
  746.              * sorting and return the sorted list.
  747.              */
  748.             size = BlkLoc(t)->record.recdesc->proc.nfields;
  749.  
  750.             Protect(lp = alclist(size), runerr(0));
  751.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  752.             lp->listhead = lp->listtail = ep;
  753.             bp = BlkLoc(t);  /* need not be tended if not set until now */
  754.  
  755.             if (size > 0) {  /* only need to sort non-empty records */
  756.                d1 = lp->listhead->lelem.lslots;
  757.                for (i = 0; i < size; i++)
  758.                   *d1++ = bp->record.fields[i];
  759.                qsort((char *)lp->listhead->lelem.lslots,(int)size,
  760.                      sizeof(struct descrip), (int (*)())anycmp);
  761.                }
  762.  
  763.             Desc_EVValD(lp, E_Lcreate, D_List);
  764.             return list(lp);
  765.             }
  766.          }
  767.  
  768.       set: {
  769.          abstract {
  770.             return new list(store[type(t).set_elem])
  771.             }
  772.          body {
  773.             register dptr d1;
  774.             register word size;
  775.             register int j, k;
  776.             tended struct b_list *lp;
  777.             union block *ep, *bp;
  778.             register struct b_slots *seg;
  779.             /*
  780.              * Create a list the size of the set, copy each element into
  781.              * the list, and then sort the list using qsort as in list
  782.              * sorting and return the sorted list.
  783.              */
  784.             size = BlkLoc(t)->set.size;
  785.  
  786.             Protect(lp = alclist(size), runerr(0));
  787.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  788.             lp->listhead = lp->listtail = ep;
  789.             bp = BlkLoc(t);  /* need not be tended if not set until now */
  790.  
  791.             if (size > 0) {  /* only need to sort non-empty sets */
  792.                d1 = lp->listhead->lelem.lslots;
  793.                for (j = 0; j < HSegs && (seg = bp->table.hdir[j]) != NULL; j++)
  794.                   for (k = segsize[j] - 1; k >= 0; k--)
  795.                      for (ep = seg->hslots[k]; ep != NULL; ep= ep->telem.clink)
  796.                         *d1++ = ep->selem.setmem;
  797.                qsort((char *)lp->listhead->lelem.lslots,(int)size,
  798.                      sizeof(struct descrip), (int (*)())anycmp);
  799.                }
  800.  
  801.             Desc_EVValD(lp, E_Lcreate, D_List);
  802.             return list(lp);
  803.             }
  804.          }
  805.  
  806.       table: {
  807.          abstract {
  808.             return new list(new list(store[type(t).tbl_key ++
  809.                type(t).tbl_val]) ++ store[type(t).tbl_key ++ type(t).tbl_val])
  810.             }
  811.          if !def:C_integer(i, 1) then
  812.             runerr(101, i)
  813.          body {
  814.             register dptr d1;
  815.             register word size;
  816.             register int j, k, n;
  817.         tended struct b_table *bp;
  818.             tended struct b_list *lp, *tp;
  819.             tended union block *ep, *ev;
  820.         tended struct b_slots *seg;
  821.  
  822.             switch ((int)i) {
  823.  
  824.             /*
  825.              * Cases 1 and 2 are as in early versions of Icon
  826.              */
  827.                case 1:
  828.                case 2:
  829.               {
  830.                /*
  831.                 * The list resulting from the sort will have as many elements
  832.                 *  as the table has, so get that value and also make a valid
  833.                 *  list block size out of it.
  834.                 */
  835.                size = BlkLoc(t)->table.size;
  836.  
  837.            /*
  838.         * Make sure, now, that there's enough room for all the
  839.         *  allocations we're going to need.
  840.         */
  841.            if (!reserve(Blocks, (word)(sizeof(struct b_list)
  842.           + sizeof(struct b_lelem) + (size - 1) * sizeof(struct descrip)
  843.           + size * sizeof(struct b_list)
  844.           + size * (sizeof(struct b_lelem) + sizeof(struct descrip)))))
  845.           runerr(0);
  846.                /*
  847.                 * Point bp at the table header block of the table to be sorted
  848.                 *  and point lp at a newly allocated list
  849.                 *  that will hold the the result of sorting the table.
  850.                 */
  851.                bp = (struct b_table *)BlkLoc(t);
  852.                Protect(lp = alclist(size), runerr(0));
  853.                Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0));
  854.                lp->listtail = lp->listhead = ep;
  855.                /*
  856.                 * If the table is empty, there is no need to sort anything.
  857.                 */
  858.                if (size <= 0)
  859.                   break;
  860.                /*
  861.                 * Traverse the element chain for each table bucket.  For each
  862.                 *  element, allocate a two-element list and put the table
  863.                 *  entry value in the first element and the assigned value in
  864.                 *  the second element.  The two-element list is assigned to
  865.                 *  the descriptor that d1 points at.  When this is done, the
  866.                 *  list of two-element lists is complete, but unsorted.
  867.                 */
  868.  
  869.                n = 0;                /* list index */
  870.                for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++)
  871.                   for (k = segsize[j] - 1; k >= 0; k--)
  872.                      for (ep= seg->hslots[k]; ep != NULL; ep= ep->telem.clink){
  873.                         Protect(tp = alclist((word)2), runerr(0));
  874.                         Protect(ev = (union block *)alclstb((word)2,
  875.                            (word)0, (word)2), runerr(0));
  876.                         tp->listhead = tp->listtail = ev;
  877.                         tp->listhead->lelem.lslots[0] = ep->telem.tref;
  878.                         tp->listhead->lelem.lslots[1] = ep->telem.tval;
  879.                         d1 = &lp->listhead->lelem.lslots[n++];
  880.                         d1->dword = D_List;
  881.                         BlkLoc(*d1) = (union block *)tp;
  882.                         }
  883.                /*
  884.                 * Sort the resulting two-element list using the sorting
  885.                 *  function determined by i.
  886.                 */
  887.                if (i == 1)
  888.                   qsort((char *)lp->listhead->lelem.lslots, (int)size,
  889.                         sizeof(struct descrip), (int (*)())trefcmp);
  890.                else
  891.                   qsort((char *)lp->listhead->lelem.lslots, (int)size,
  892.                         sizeof(struct descrip), (int (*)())tvalcmp);
  893.                break;        /* from cases 1 and 2 */
  894.                }
  895.             /*
  896.              * Cases 3 and 4 were introduced in Version 5.10.
  897.              */
  898.                case 3 :
  899.                case 4 :
  900.                        {
  901.             /*
  902.              * The list resulting from the sort will have twice as many
  903.              *  elements as the table has, so get that value and also make
  904.              *  a valid list block size out of it.
  905.              */
  906.             size = BlkLoc(t)->table.size * 2;
  907.  
  908.             /*
  909.              * Point bp at the table header block of the table to be sorted
  910.              *  and point lp at a newly allocated list
  911.              *  that will hold the the result of sorting the table.
  912.              */
  913.             bp = (struct b_table *)BlkLoc(t);
  914.             Protect(lp = alclist(size), runerr(0));
  915.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  916.             lp->listhead = lp->listtail = ep;
  917.             /*
  918.              * If the table is empty there's no need to sort anything.
  919.              */
  920.             if (size <= 0)
  921.                break;
  922.  
  923.             /*
  924.              * Point d1 at the start of the list elements in the new list
  925.              *  element block in preparation for use as an index into the list.
  926.              */
  927.             d1 = lp->listhead->lelem.lslots;
  928.             /*
  929.              * Traverse the element chain for each table bucket.  For each
  930.              *  table element copy the the entry descriptor and the value
  931.              *  descriptor into adjacent descriptors in the lslots array
  932.              *  in the list element block.
  933.              *  When this is done we now need to sort this list.
  934.              */
  935.  
  936.             for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++)
  937.                for (k = segsize[j] - 1; k >= 0; k--)
  938.                   for (ep = seg->hslots[k]; ep != NULL; ep = ep->telem.clink) {
  939.                      *d1++ = ep->telem.tref;
  940.                      *d1++ = ep->telem.tval;
  941.                      }
  942.             /*
  943.              * Sort the resulting two-element list using the
  944.              *  sorting function determined by i.
  945.              */
  946.             if (i == 3)
  947.                qsort((char *)lp->listhead->lelem.lslots, (int)size / 2,
  948.                      (2 * sizeof(struct descrip)), (int (*)())trcmp3);
  949.             else
  950.                qsort((char *)lp->listhead->lelem.lslots, (int)size / 2,
  951.                      (2 * sizeof(struct descrip)), (int (*)())tvcmp4);
  952.             break; /* from case 3 or 4 */
  953.                }
  954.  
  955.             default: {
  956.                irunerr(205, i);
  957.                errorfail;
  958.                }
  959.  
  960.             } /* end of switch statement */
  961.  
  962.             /*
  963.              * Make result point at the sorted list.
  964.              */
  965.  
  966.             Desc_EVValD(lp, E_Lcreate, D_List);
  967.             return list(lp);
  968.             }
  969.          }
  970.  
  971.       default:
  972.          runerr(115, t);        /* structure expected */
  973.       }
  974. end
  975.  
  976. /*
  977.  * trefcmp(d1,d2) - compare two-element lists on first field.
  978.  */
  979.  
  980. int trefcmp(d1,d2)
  981. dptr d1, d2;
  982.    {
  983.  
  984. #ifdef DeBug
  985.    if (d1->dword != D_List || d2->dword != D_List)
  986.       syserr("trefcmp: internal consistency check fails.");
  987. #endif                    /* DeBug */
  988.  
  989.    return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]),
  990.                   &(BlkLoc(*d2)->list.listhead->lelem.lslots[0])));
  991.    }
  992.  
  993. /*
  994.  * tvalcmp(d1,d2) - compare two-element lists on second field.
  995.  */
  996.  
  997. int tvalcmp(d1,d2)
  998. dptr d1, d2;
  999.    {
  1000.  
  1001. #ifdef DeBug
  1002.    if (d1->dword != D_List || d2->dword != D_List)
  1003.       syserr("tvalcmp: internal consistency check fails.");
  1004. #endif                    /* DeBug */
  1005.  
  1006.    return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]),
  1007.       &(BlkLoc(*d2)->list.listhead->lelem.lslots[1])));
  1008.    }
  1009.  
  1010. /*
  1011.  * The following two routines are used to compare descriptor pairs in the
  1012.  *  experimental table sort.
  1013.  *
  1014.  * trcmp3(dp1,dp2)
  1015.  */
  1016.  
  1017. int trcmp3(dp1,dp2)
  1018. struct dpair *dp1,*dp2;
  1019. {
  1020.    return (anycmp(&((*dp1).dr),&((*dp2).dr)));
  1021. }
  1022. /*
  1023.  * tvcmp4(dp1,dp2)
  1024.  */
  1025.  
  1026. int tvcmp4(dp1,dp2)
  1027. struct dpair *dp1,*dp2;
  1028.  
  1029.    {
  1030.    return (anycmp(&((*dp1).dv),&((*dp2).dv)));
  1031.    }
  1032.  
  1033.  
  1034. "sortf(x,i) - sort list or set x on field i of each member"
  1035.  
  1036. function{1} sortf(t, i)
  1037.    type_case t of {
  1038.       list: {
  1039.          abstract {
  1040.             return type(t)
  1041.             }
  1042.          if !def:C_integer(i, 1) then
  1043.             runerr (101, i)
  1044.          body {
  1045.             register word size;
  1046.             extern word sort_field;
  1047.  
  1048.             if (i == 0) {
  1049.                irunerr(205, i);
  1050.                errorfail;
  1051.                }
  1052.             /*
  1053.              * Sort the list by copying it into a new list and then using
  1054.              *  qsort to sort the descriptors.  (That was easy!)
  1055.              */
  1056.             size = BlkLoc(t)->list.size;
  1057.             if (cplist(&t, &result, (word)1, size + 1) == Error)
  1058.                runerr(0);
  1059.             sort_field = i;
  1060.             qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots,
  1061.                (int)size, sizeof(struct descrip), (int (*)()) nthcmp);
  1062.  
  1063.             Desc_EVValD(BlkLoc(result), E_Lcreate, D_List);
  1064.             return result;
  1065.             }
  1066.          }
  1067.  
  1068.       record: {
  1069.          abstract {
  1070.             return new list(any_value)
  1071.             }
  1072.          if !def:C_integer(i, 1) then
  1073.             runerr(101, i)
  1074.          body {
  1075.             register dptr d1;
  1076.             register word size;
  1077.             tended struct b_list *lp;
  1078.             union block *ep, *bp;
  1079.             register int j;
  1080.             extern word sort_field;
  1081.  
  1082.             if (i == 0) {
  1083.                irunerr(205, i);
  1084.                errorfail;
  1085.                }
  1086.             /*
  1087.              * Create a list the size of the record, copy each element into
  1088.              * the list, and then sort the list using qsort as in list
  1089.              * sorting and return the sorted list.
  1090.              */
  1091.             size = BlkLoc(t)->record.recdesc->proc.nfields;
  1092.  
  1093.             Protect(lp = alclist(size), runerr(0));
  1094.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  1095.             lp->listhead = lp->listtail = ep;
  1096.             bp = BlkLoc(t);  /* need not be tended if not set until now */
  1097.  
  1098.             if (size > 0) {  /* only need to sort non-empty records */
  1099.                d1 = lp->listhead->lelem.lslots;
  1100.                for (j = 0; j < size; j++)
  1101.                   *d1++ = bp->record.fields[j];
  1102.                sort_field = i;
  1103.                qsort((char *)lp->listhead->lelem.lslots,(int)size,
  1104.                   sizeof(struct descrip), (int (*)())nthcmp);
  1105.                }
  1106.  
  1107.             Desc_EVValD(lp, E_Lcreate, D_List);
  1108.             return list(lp);
  1109.             }
  1110.          }
  1111.  
  1112.       set: {
  1113.          abstract {
  1114.             return new list(store[type(t).set_elem])
  1115.             }
  1116.          if !def:C_integer(i, 1) then
  1117.             runerr (101, i)
  1118.          body {
  1119.             register dptr d1;
  1120.             register word size;
  1121.             register int j, k;
  1122.             tended struct b_list *lp;
  1123.             union block *ep, *bp;
  1124.             register struct b_slots *seg;
  1125.             extern word sort_field;
  1126.  
  1127.             if (i == 0) {
  1128.                irunerr(205, i);
  1129.                errorfail;
  1130.                }
  1131.             /*
  1132.              * Create a list the size of the set, copy each element into
  1133.              * the list, and then sort the list using qsort as in list
  1134.              * sorting and return the sorted list.
  1135.              */
  1136.             size = BlkLoc(t)->set.size;
  1137.  
  1138.             Protect(lp = alclist(size), runerr(0));
  1139.             Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
  1140.             lp->listhead = lp->listtail = ep;
  1141.             bp = BlkLoc(t);  /* need not be tended if not set until now */
  1142.  
  1143.             if (size > 0) {  /* only need to sort non-empty sets */
  1144.                d1 = lp->listhead->lelem.lslots;
  1145.                for (j = 0; j < HSegs && (seg = bp->table.hdir[j]) != NULL; j++)
  1146.                   for (k = segsize[j] - 1; k >= 0; k--)
  1147.                      for (ep = seg->hslots[k]; ep != NULL; ep= ep->telem.clink)
  1148.                         *d1++ = ep->selem.setmem;
  1149.                sort_field = i;
  1150.                qsort((char *)lp->listhead->lelem.lslots,(int)size,
  1151.                      sizeof(struct descrip), (int (*)())nthcmp);
  1152.                }
  1153.  
  1154.             Desc_EVValD(lp, E_Lcreate, D_List);
  1155.             return list(lp);
  1156.             }
  1157.          }
  1158.  
  1159.       default:
  1160.          runerr(125, t);    /* list, record, or set expected */
  1161.       }
  1162. end
  1163.  
  1164. /*
  1165.  * nthcmp(d1,d2) - compare two descriptors on their nth fields.
  1166.  */
  1167. word sort_field;        /* field number, set by sort function */
  1168. static dptr nth Params((dptr d));
  1169.  
  1170. int nthcmp(d1,d2)
  1171. dptr d1, d2;
  1172.    {
  1173.    int t1, t2, rv;
  1174.    dptr e1, e2;
  1175.  
  1176.    t1 = Type(*d1);
  1177.    t2 = Type(*d2);
  1178.    if (t1 == t2 && (t1 == T_Record || t1 == T_List)) {
  1179.       e1 = nth(d1);        /* get nth field, or NULL if none such */
  1180.       e2 = nth(d2);
  1181.       if (e1 == NULL) {
  1182.          if (e2 != NULL)
  1183.             return -1;        /* no-nth-field is < any nth field */
  1184.          }
  1185.       else if (e2 == NULL)
  1186.      return 1;        /* any nth field is > no-nth-field */
  1187.       else {
  1188.      /*
  1189.       *  Both had an nth field.  If they're unequal, that decides.
  1190.       */
  1191.          rv = anycmp(nth(d1), nth(d2));
  1192.          if (rv != 0)
  1193.             return rv;
  1194.          }
  1195.       }
  1196.    /*
  1197.     * Comparison of nth fields was either impossible or indecisive.
  1198.     *  Settle it by comparing the descriptors directly.
  1199.     */
  1200.    return anycmp(d1, d2);
  1201.    }
  1202.  
  1203. /*
  1204.  * nth(d) - return the nth field of d, if any.  (sort_field is "n".)
  1205.  */
  1206. static dptr nth(d)
  1207. dptr d;
  1208.    {
  1209.    union block *bp;
  1210.    struct b_list *lp;
  1211.    word i, j;
  1212.    dptr rv;
  1213.  
  1214.    rv = NULL;
  1215.    if (d->dword == D_Record) {
  1216.       /*
  1217.        * Find the nth field of a record.
  1218.        */
  1219.       bp = BlkLoc(*d);
  1220.       i = cvpos((long)sort_field, (long)(bp->record.recdesc->proc.nfields));
  1221.       if (i != CvtFail && i <= bp->record.recdesc->proc.nfields)
  1222.          rv = &bp->record.fields[i-1];
  1223.       }
  1224.    else if (d->dword == D_List) {
  1225.       /*
  1226.        * Find the nth element of a list.
  1227.        */
  1228.       lp = (struct b_list *)BlkLoc(*d);
  1229.       i = cvpos ((long)sort_field, (long)lp->size);
  1230.       if (i != CvtFail && i <= lp->size) {
  1231.          /*
  1232.           * Locate the correct list-element block.
  1233.           */
  1234.          bp = lp->listhead;
  1235.          j = 1;
  1236.          while (i >= j + bp->lelem.nused) {
  1237.             j += bp->lelem.nused;
  1238.             bp = bp->lelem.listnext;
  1239.             }
  1240.          /*
  1241.           * Locate the desired element.
  1242.           */
  1243.          i += bp->lelem.first - j;
  1244.          if (i >= bp->lelem.nslots)
  1245.             i -= bp->lelem.nslots;
  1246.          rv = &bp->lelem.lslots[i];
  1247.          }
  1248.       }
  1249.    return rv;
  1250.    }
  1251.  
  1252.  
  1253. "type(x) - return type of x as a string."
  1254.  
  1255. function{1} type(x)
  1256.    abstract {
  1257.       return string
  1258.       }
  1259.    type_case x of {
  1260.       string:   inline { return C_string "string";    }
  1261.       null:     inline { return C_string "null";      }
  1262.       integer:  inline { return C_string "integer";   }
  1263.       real:     inline { return C_string "real";      }
  1264.       cset:     inline { return C_string "cset";      }
  1265.       file:
  1266.      inline {
  1267. #ifdef Graphics
  1268.         if (BlkLoc(x)->file.status & Fs_Window)
  1269.            return C_string "window";
  1270. #endif                    /* Graphics */
  1271.         return C_string "file";
  1272.         }
  1273.       proc:     inline { return C_string "procedure"; }
  1274.       list:     inline { return C_string "list";      }
  1275.       table:    inline { return C_string "table";     }
  1276.       set:      inline { return C_string "set";       }
  1277.       record:   inline { return BlkLoc(x)->record.recdesc->proc.recname; }
  1278.       coexpr:   inline { return C_string "co-expression"; }
  1279.       default:
  1280.          inline {
  1281. #if !COMPILER
  1282.             if (!Qual(x) && (Type(x)==T_External)) {
  1283.                return C_string "external";
  1284.                }
  1285.             else
  1286. #endif                    /* !COMPILER */
  1287.                runerr(123,x);
  1288.         }
  1289.       }
  1290. end
  1291.  
  1292.  
  1293. "variable(s) - find the variable with name s and return a"
  1294. " variable descriptor which points to its value."
  1295.  
  1296. #ifdef MultiThread
  1297. function{0,1} variable(s,c,i)
  1298. #else                    /* MultiThread */
  1299. function{0,1} variable(s)
  1300. #endif                    /* MultiThread */
  1301.  
  1302.    if !cnv:C_string(s) then
  1303.       runerr(103, s)
  1304.  
  1305. #ifdef MultiThread
  1306.    if !def:C_integer(i,0) then
  1307.       runerr(101,i)
  1308. #endif                    /* MultiThread */
  1309.  
  1310.    abstract {
  1311.       return variable
  1312.       }
  1313.  
  1314.    body {
  1315.       register dptr dp;
  1316.       register dptr np;
  1317.       register int rv;
  1318.  
  1319. #ifdef MultiThread
  1320.       struct progstate *prog, *savedprog;
  1321.       struct pf_marker *tmp_pfp = pfp;
  1322.       dptr tmp_argp = argp;
  1323.  
  1324.       savedprog = curpstate;
  1325.       if (!is:null(c)) {
  1326.      if (is:coexpr(c)) {
  1327.         prog = BlkLoc(c)->coexpr.program;
  1328.         pfp = BlkLoc(c)->coexpr.es_pfp;
  1329.         argp = BlkLoc(c)->coexpr.es_argp;
  1330.         ENTERPSTATE(prog);
  1331.         }
  1332.      else {
  1333.         runerr(118, c);
  1334.         }
  1335.      }
  1336.  
  1337.       /*
  1338.        * Produce error if i is negative
  1339.        */
  1340.       if (i < 0) {
  1341.          irunerr(205, i);
  1342.          errorfail;
  1343.          }
  1344.  
  1345.       while (i--) {
  1346.      if (pfp == NULL) fail;
  1347.      argp = pfp->pf_argp;
  1348.      pfp = pfp->pf_pfp;
  1349.          }
  1350. #endif                        /* MultiThread */
  1351.  
  1352.       rv = getvar(s, &result);
  1353.    
  1354. #ifdef MultiThread
  1355.       if (is:coexpr(c)) {
  1356.      ENTERPSTATE(savedprog);
  1357.      pfp = tmp_pfp;
  1358.      argp = tmp_argp;
  1359.  
  1360.      if ((rv == LocalName) || (rv == StaticName)) {
  1361.         Deref(result);
  1362.         }
  1363.      }
  1364. #endif                        /* MultiThread */
  1365.  
  1366.       if (rv != Failed)
  1367.          return result;
  1368.       else
  1369.          fail;
  1370.       }
  1371. end
  1372.  
  1373. #ifdef MultiThread
  1374. #include "::h:opdefs.h"
  1375. "cofail(CE) - transmit a co-expression failure to CE"
  1376.  
  1377. function{1} cofail(CE)
  1378.    if is:null(CE) then
  1379.       body {
  1380.      struct b_coexpr *ce = topact((struct b_coexpr *)BlkLoc(k_current));
  1381.      if (ce != NULL) {
  1382.         CE.dword = D_Coexpr;
  1383.         BlkLoc(CE) = (union block *)ce;
  1384.         }
  1385.      else runerr(118,CE);
  1386.      }
  1387.    else if !is:coexpr(CE) then
  1388.       runerr(118,CE)
  1389.    body {
  1390.       struct b_coexpr *ncp = (struct b_coexpr *)BlkLoc(CE);
  1391.       if (co_chng(ncp, NULL, &result, A_Cofail, 1) == A_Cofail) fail;
  1392.       return result;
  1393.       }
  1394. end
  1395.  
  1396. "load(s,arglist,input,output,error,blocksize,stringsize,stacksize) - load"
  1397. " an icode file corresponding to string s as a co-expression."
  1398.  
  1399. function{1} load(s,arglist,infile,outfile,errfile,
  1400.          blocksize, stringsize, stacksize)
  1401.    declare {
  1402.       tended char *loadstring;
  1403.       C_integer _bs_, _ss_, _stk_;
  1404.       }
  1405.    if !cnv:C_string(s,loadstring) then
  1406.       runerr(103,s)
  1407.    if !def:C_integer(blocksize,abrsize,_bs_) then
  1408.       runerr(101,blocksize)
  1409.    if !def:C_integer(stringsize,ssize,_ss_) then
  1410.       runerr(101,stringsize)
  1411.    if !def:C_integer(stacksize,mstksize,_stk_) then
  1412.       runerr(101,stacksize)
  1413.    abstract {
  1414.       return coexpr
  1415.       }
  1416.    body {
  1417.       word *stack;
  1418.       struct progstate *pstate;
  1419.       char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen];
  1420.       register struct b_coexpr *sblkp;
  1421.       register struct b_refresh *rblkp;
  1422.       struct ef_marker *newefp;
  1423.       register dptr dp, ndp, dsp;
  1424.       register word *newsp, *savedsp;
  1425.       int na, nl, i, j, num_fileargs = 0;
  1426.       struct b_file *theInput = NULL, *theOutput = NULL, *theError = NULL;
  1427.       struct b_proc *cproc;
  1428.       extern char *prog_name;
  1429.  
  1430.       /*
  1431.        * Fragments of pseudo-icode to get loaded programs started,
  1432.        * and to handle termination.
  1433.        */
  1434.       static word *lterm;
  1435.       static word pstart[7];
  1436.  
  1437.       inst tipc;
  1438.  
  1439.       tipc.opnd = pstart;
  1440.       *tipc.op++ = Op_Invoke;
  1441.       *tipc.opnd++ = 1;
  1442.       *tipc.op++ = Op_Coret;
  1443.       *tipc.op++ = Op_Efail;
  1444.  
  1445.       lterm = (word *)(tipc.op);
  1446.  
  1447.       *tipc.op++ = Op_Cofail;
  1448.       *tipc.op++ = Op_Agoto;
  1449.       *tipc.opnd = (word)lterm;
  1450.  
  1451.       prog_name = loadstring;            /* set up for &progname */
  1452.  
  1453.       /*
  1454.        * arglist must be a list
  1455.        */
  1456.       if (!is:null(arglist) && !is:list(arglist))
  1457.          runerr(108,arglist);
  1458.  
  1459.       /*
  1460.        * input, output, and error must be files
  1461.        */
  1462.       if (is:null(infile))
  1463.      theInput = &(curpstate->K_input);
  1464.       else {
  1465.      if (!is:file(infile))
  1466.         runerr(105,infile);
  1467.      else theInput = &(BlkLoc(infile)->file);
  1468.          }
  1469.       if (is:null(outfile))
  1470.      theOutput = &(curpstate->K_output);
  1471.       else {
  1472.      if (!is:file(outfile))
  1473.         runerr(105,outfile);
  1474.      else theOutput = &(BlkLoc(outfile)->file);
  1475.          }
  1476.       if (is:null(errfile))
  1477.      theError = &(curpstate->K_errout);
  1478.       else {
  1479.      if (!is:file(errfile))
  1480.         runerr(105,errfile);
  1481.      else theError = &(BlkLoc(errfile)->file);
  1482.          }
  1483.  
  1484.       stack =
  1485.     (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError,
  1486.                    _bs_,_ss_,_stk_));
  1487.       if(!stack) {
  1488.      fail;
  1489.          }
  1490.       pstate = sblkp->program;
  1491.       pstate->parent = curpstate;
  1492.       pstate->parentdesc = k_main;
  1493.  
  1494.       savedsp = sp;
  1495.       sp = stack + Wsizeof(struct b_coexpr)
  1496.         + Wsizeof(struct progstate) + pstate->hsize/WordSize;
  1497.       if (pstate->hsize % WordSize) sp++;
  1498.  
  1499. #ifdef UpStack
  1500.       sblkp->cstate[0] =
  1501.          ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2)
  1502.             &~((word)WordSize*StackAlign-1));
  1503. #else                    /* UpStack */
  1504.       sblkp->cstate[0] =
  1505.     ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize)
  1506.            &~((word)WordSize*StackAlign-1));
  1507. #endif                    /* UpStack */
  1508.  
  1509. #ifdef CoProcesses
  1510.       sblkp->cstate[1] = 0;
  1511. #endif                    /* CoProcesses */
  1512.  
  1513.       sblkp->es_argp = NULL;
  1514.       sblkp->es_gfp = NULL;
  1515.       pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */
  1516.                     /*  This really is a bug. */
  1517.  
  1518.       /*
  1519.        * Set up expression frame marker to contain execution of the
  1520.        *  main procedure.  If failure occurs in this context, control
  1521.        *  is transferred to lterm, the address of an ...
  1522.        */
  1523.       newefp = (struct ef_marker *)(sp+1);
  1524.       newefp->ef_failure.opnd = lterm;
  1525.  
  1526.       newefp->ef_gfp = 0;
  1527.       newefp->ef_efp = 0;
  1528.       newefp->ef_ilevel = ilevel/*1*/;
  1529.       sp += Wsizeof(*newefp) - 1;
  1530.       sblkp->es_efp = newefp;
  1531.  
  1532.       /*
  1533.        * The first global variable holds the value of "main".  If it
  1534.        *  is not of type procedure, this is noted as run-time error 117.
  1535.        *  Otherwise, this value is pushed on the stack.
  1536.        */
  1537.       if (pstate->Globals[0].dword != D_Proc)
  1538.          fatalerr(117, NULL);
  1539.  
  1540.       PushDesc(pstate->Globals[0]);
  1541.  
  1542.       /*
  1543.        * Create a list from arguments using Ollist and push a descriptor
  1544.        * onto new stack.  Then create procedure frame on new stack.  Push
  1545.        * two new null descriptors, and set sblkp->es_sp when all finished.
  1546.        */
  1547.       if (!is:null(arglist)) {
  1548.          PushDesc(arglist);
  1549.          }
  1550.       else {
  1551.          PushNull;
  1552.          {
  1553.          dptr tmpargp = (dptr) (sp - 1);
  1554.          Ollist(0, tmpargp);
  1555.          sp = (word *)tmpargp + 1;
  1556.          }
  1557.          }
  1558.       sblkp->es_sp = (word *)sp;
  1559.       sblkp->es_ipc.opnd = pstart;
  1560.  
  1561.       result.dword = D_Coexpr;
  1562.       BlkLoc(result) = (union block *)sblkp;
  1563.       sp = savedsp;
  1564.       return result;
  1565.       }
  1566. end
  1567.  
  1568.  
  1569. "parent(ce) - given a ce, return &main for that ce's parent"
  1570.  
  1571. function{1} parent(ce)
  1572.    if is:null(ce) then inline { ce = k_current; }
  1573.    else if !is:coexpr(ce) then runerr(118,ce)
  1574.    abstract {
  1575.       return coexpr
  1576.       }
  1577.    body {
  1578.       if (BlkLoc(ce)->coexpr.program->parent == NULL) fail;
  1579.  
  1580.       result.dword = D_Coexpr;
  1581.       BlkLoc(result) =
  1582.     (union block *)(BlkLoc(ce)->coexpr.program->parent->Mainhead);
  1583.       return result;
  1584.       }
  1585. end
  1586.  
  1587.  
  1588. "eventmask(ce,cs) - given a ce, get or set that program's event mask"
  1589.  
  1590. function{1} eventmask(ce,cs)
  1591.    if !is:coexpr(ce) then runerr(118,ce)
  1592.  
  1593.    if is:null(cs) then {
  1594.       abstract {
  1595.          return cset++null
  1596.          }
  1597.       body {
  1598.          result = BlkLoc(ce)->coexpr.program->eventmask;
  1599.          return result;
  1600.          }
  1601.       }
  1602.    else if !cnv:cset(cs) then runerr(104,cs)
  1603.    else {
  1604.       abstract {
  1605.          return cset
  1606.          }
  1607.       body {
  1608.          ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs;
  1609.          return cs;
  1610.          }
  1611.       }
  1612. end
  1613.  
  1614.  
  1615. "fieldnames(r) - generate the fieldnames of record r"
  1616.  
  1617. function{*} fieldnames(r)
  1618.    if !is:record(r) then runerr(107,r)
  1619.    body {
  1620.       int i;
  1621.       for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) {
  1622.      suspend BlkLoc(r)->record.recdesc->proc.lnames[i];
  1623.          }
  1624.       fail;
  1625.       }
  1626. end
  1627.  
  1628.  
  1629.  
  1630. "globalnames(ce) - produce the names of identifiers global to ce"
  1631.  
  1632. function{*} globalnames(ce)
  1633.    declare {
  1634.       struct progstate *ps;
  1635.       }
  1636.    abstract {
  1637.       return string
  1638.       }
  1639.    if is:null(ce) then inline { ps = curpstate; }
  1640.    else if is:coexpr(ce) then
  1641.       inline { ps = BlkLoc(ce)->coexpr.program; }
  1642.    else runerr(118,ce)
  1643.    body {
  1644.       struct descrip *dp;
  1645.       for (dp = ps->Gnames; dp != ps->Egnames; dp++) {
  1646.          suspend *dp;
  1647.          }
  1648.       fail;
  1649.       }
  1650. end
  1651.  
  1652. "keyword(kname,ce) - produce a keyword in ce's thread"
  1653. function{*} keyword(keyname,ce)
  1654.    declare {
  1655.       tended struct descrip d;
  1656.       tended char *kyname;
  1657.       }
  1658.    abstract {
  1659.       return any_value
  1660.       }
  1661.    if !cnv:C_string(keyname,kyname) then runerr(103,keyname)
  1662.    if is:null(ce) then inline {
  1663.       d = k_current;
  1664.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1665.       BlkLoc(k_current)->coexpr.es_ipc.opnd = ipc.opnd;
  1666.       }
  1667.    else if is:coexpr(ce) then
  1668.       inline { d = ce; }
  1669.    else runerr(118, ce)
  1670.    body {
  1671.       struct progstate *p = BlkLoc(d)->coexpr.program;
  1672.       char *kname = kyname;
  1673.       if (kname[0] == '&') kname++;
  1674.       if (strcmp(kname,"allocated") == 0) {
  1675.      suspend C_integer stattotal + p->stringtotal + p->blocktotal;
  1676.      suspend C_integer stattotal;
  1677.      suspend C_integer p->stringtotal;
  1678.      return  C_integer p->blocktotal;
  1679.      }
  1680.       else if (strcmp(kname,"collections") == 0) {
  1681.      suspend C_integer p->colltot;
  1682.      suspend C_integer p->collstat;
  1683.      suspend C_integer p->collstr;
  1684.      return  C_integer p->collblk;
  1685.      }
  1686.       else if (strcmp(kname,"column") == 0) {
  1687.      struct progstate *savedp = curpstate;
  1688.      int i;
  1689.      ENTERPSTATE(p);
  1690.      i = findcol(BlkLoc(d)->coexpr.es_ipc.opnd);
  1691.      ENTERPSTATE(savedp);
  1692.      return C_integer i;
  1693.      }
  1694.       else if (strcmp(kname,"error") == 0) {
  1695.      return kywdint(&(p->Kywd_err));
  1696.      }
  1697.       else if (strcmp(kname,"errornumber") == 0) {
  1698.      return C_integer p->K_errornumber;
  1699.      }
  1700.       else if (strcmp(kname,"errortext") == 0) {
  1701.      return C_string p->K_errortext;
  1702.      }
  1703.       else if (strcmp(kname,"errorvalue") == 0) {
  1704.      return p->K_errorvalue;
  1705.      }
  1706.       else if (strcmp(kname,"errout") == 0) {
  1707.      return file(&(p->K_errout));
  1708.      }
  1709.       else if (strcmp(kname,"eventcode") == 0) {
  1710.      return kywdevent(&(p->eventcode));
  1711.      }
  1712.       else if (strcmp(kname,"eventsource") == 0) {
  1713.      return kywdevent(&(p->eventsource));
  1714.      }
  1715.       else if (strcmp(kname,"eventvalue") == 0) {
  1716.      return kywdevent(&(p->eventval));
  1717.      }
  1718.       else if (strcmp(kname,"file") == 0) {
  1719.      struct progstate *savedp = curpstate;
  1720.      struct descrip s;
  1721.      ENTERPSTATE(p);
  1722.      StrLoc(s) = findfile(BlkLoc(d)->coexpr.es_ipc.opnd);
  1723.      StrLen(s) = strlen(StrLoc(s));
  1724.      ENTERPSTATE(savedp);
  1725.      if (!strcmp(StrLoc(s),"?")) fail;
  1726.      return s;
  1727.      }
  1728.       else if (strcmp(kname,"input") == 0) {
  1729.      return file(&(p->K_input));
  1730.      }
  1731.       else if (strcmp(kname,"level") == 0) {
  1732.      /*
  1733.       * Bug; levels aren't maintained per program yet.
  1734.       * But shouldn't they be per co-expression, not per program?
  1735.       */
  1736.      }
  1737.       else if (strcmp(kname,"line") == 0) {
  1738.      struct progstate *savedp = curpstate;
  1739.      int i;
  1740.      ENTERPSTATE(p);
  1741.      i = findline(BlkLoc(d)->coexpr.es_ipc.opnd);
  1742.      ENTERPSTATE(savedp);
  1743.      return C_integer i;
  1744.      }
  1745.       else if (strcmp(kname,"main") == 0) {
  1746.      return p->K_main;
  1747.      }
  1748.       else if (strcmp(kname,"output") == 0) {
  1749.      return file(&(p->K_output));
  1750.      }
  1751.       else if (strcmp(kname,"pos") == 0) {
  1752.      return kywdpos(&(p->Kywd_pos));
  1753.      }
  1754.       else if (strcmp(kname,"progname") == 0) {
  1755.      return kywdstr(&(p->Kywd_prog));
  1756.      }
  1757.       else if (strcmp(kname,"random") == 0) {
  1758.      return kywdint(&(p->Kywd_ran));
  1759.      }
  1760.       else if (strcmp(kname,"regions") == 0) {
  1761.          word allRegions = 0;
  1762.          struct region *rp;
  1763.  
  1764.          suspend C_integer 0;
  1765.      for (rp = p->stringregion; rp; rp = rp->next)
  1766.         allRegions += DiffPtrs(rp->end,rp->base);
  1767.      for (rp = p->stringregion->prev; rp; rp = rp->prev)
  1768.         allRegions += DiffPtrs(rp->end,rp->base);
  1769.      suspend C_integer allRegions;
  1770.  
  1771.      allRegions = 0;
  1772.      for (rp = p->blockregion; rp; rp = rp->next)
  1773.         allRegions += DiffPtrs(rp->end,rp->base);
  1774.      for (rp = p->blockregion->prev; rp; rp = rp->prev)
  1775.         allRegions += DiffPtrs(rp->end,rp->base);
  1776.      return C_integer allRegions;
  1777.      }
  1778.       else if (strcmp(kname,"source") == 0) {
  1779.      if (BlkLoc(d)->coexpr.es_actstk)
  1780.         return coexpr(topact((struct b_coexpr *)BlkLoc(d)));
  1781.      else return BlkLoc(d)->coexpr.program->parent->K_main;
  1782.      }
  1783.       else if (strcmp(kname,"storage") == 0) {
  1784.      word allRegions = 0;
  1785.      struct region *rp;
  1786.      suspend C_integer 0;
  1787.      for (rp = p->stringregion; rp; rp = rp->next)
  1788.         allRegions += DiffPtrs(rp->free,rp->base);
  1789.      for (rp = p->stringregion->prev; rp; rp = rp->prev)
  1790.         allRegions += DiffPtrs(rp->free,rp->base);
  1791.      suspend C_integer allRegions;
  1792.  
  1793.      allRegions = 0;
  1794.      for (rp = p->blockregion; rp; rp = rp->next)
  1795.         allRegions += DiffPtrs(rp->free,rp->base);
  1796.      for (rp = p->blockregion->prev; rp; rp = rp->prev)
  1797.         allRegions += DiffPtrs(rp->free,rp->base);
  1798.      return C_integer allRegions;
  1799.      }
  1800.       else if (strcmp(kname,"subject") == 0) {
  1801.      return kywdsubj(&(p->ksub));
  1802.      }
  1803.       else if (strcmp(kname,"trace") == 0) {
  1804.      return kywdint(&(p->Kywd_trc));
  1805.      }
  1806. #ifdef Graphics
  1807.       else if (strcmp(kname,"window") == 0) {
  1808.      return kywdwin(&(p->Kywd_xwin[XKey_Window]));
  1809.      }
  1810.       else if (strcmp(kname,"col") == 0) {
  1811.      return kywdint(&(p->AmperCol));
  1812.      }
  1813.       else if (strcmp(kname,"row") == 0) {
  1814.      return kywdint(&(p->AmperRow));
  1815.      }
  1816.       else if (strcmp(kname,"x") == 0) {
  1817.      return kywdint(&(p->AmperX));
  1818.      }
  1819.       else if (strcmp(kname,"y") == 0) {
  1820.      return kywdint(&(p->AmperY));
  1821.      }
  1822.       else if (strcmp(kname,"interval") == 0) {
  1823.      return kywdint(&(p->AmperInterval));
  1824.      }
  1825.       else if (strcmp(kname,"control") == 0) {
  1826.      if (p->Xmod_Control)
  1827.         return nulldesc;
  1828.      else
  1829.          fail;
  1830.      }
  1831.       else if (strcmp(kname,"shift") == 0) {
  1832.      if (p->Xmod_Shift)
  1833.         return nulldesc;
  1834.      else
  1835.          fail;
  1836.      }
  1837.       else if (strcmp(kname,"meta") == 0) {
  1838.      if (p->Xmod_Meta)
  1839.         return nulldesc;
  1840.      else
  1841.          fail;
  1842.      }
  1843. #endif                    /* Graphics */
  1844.       runerr(205, keyname);
  1845.       }
  1846. end
  1847.  
  1848. "localnames(ce,i) - produce the names of local variables"
  1849. " in the procedure activation i levels up in ce"
  1850. function{*} localnames(ce,i)
  1851.    declare {
  1852.       tended struct descrip d;
  1853.       }
  1854.    abstract {
  1855.       return string
  1856.       }
  1857.    if is:null(ce) then inline {
  1858.       d = k_current;
  1859.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1860.       }
  1861.    else if is:proc(ce) then inline {
  1862.       int j;
  1863.       struct b_proc *cproc = (struct b_proc *)BlkLoc(ce);
  1864.       for(j = 0; j < cproc->ndynam; j++) {
  1865.      result = cproc->lnames[j + cproc->nparam];
  1866.      suspend result;
  1867.          }
  1868.       fail;
  1869.       }
  1870.    else if is:coexpr(ce) then inline {
  1871.       d = ce;
  1872.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1873.       }
  1874.    else runerr(118, ce)
  1875.    if !def:C_integer(i,0) then
  1876.       runerr(101,i)
  1877.    body {
  1878.       int j;
  1879.       dptr arg;
  1880.       struct b_proc *cproc;
  1881.       struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
  1882.  
  1883.       if (thePfp == NULL) fail;
  1884.       
  1885.       /*
  1886.        * Produce error if i is negative
  1887.        */
  1888.       if (i < 0) {
  1889.          irunerr(205, i);
  1890.          errorfail;
  1891.          }
  1892.  
  1893.       while (i--) {
  1894.      thePfp = thePfp->pf_pfp;
  1895.      if (thePfp == NULL) fail;
  1896.          }
  1897.  
  1898.       arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
  1899.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1900.       for(j = 0; j < cproc->ndynam; j++) {
  1901.      result = cproc->lnames[j + cproc->nparam];
  1902.      suspend result;
  1903.          }
  1904.       fail;
  1905.       }
  1906. end
  1907.  
  1908.  
  1909. "opmask(ce,cs) - get or set ce's program's opcode mask"
  1910.  
  1911. function{1} opmask(ce,cs)
  1912.    if !is:coexpr(ce) then runerr(118,ce)
  1913.  
  1914.    if is:null(cs) then {
  1915.       abstract {
  1916.          return cset++null
  1917.          }
  1918.       body {
  1919.          result = BlkLoc(ce)->coexpr.program->opcodemask;
  1920.          return result;
  1921.          }
  1922.       }
  1923.    else if !cnv:cset(cs) then runerr(104,cs)
  1924.    else {
  1925.       abstract {
  1926.          return cset
  1927.          }
  1928.       body {
  1929.          ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs;
  1930.          return cs;
  1931.          }
  1932.       }
  1933. end
  1934.  
  1935. "staticnames(ce,i) - produce the names of static variables"
  1936. " in the current procedure activation in ce"
  1937.  
  1938. function{*} staticnames(ce,i)
  1939.    declare {
  1940.       tended struct descrip d;
  1941.       }
  1942.    abstract {
  1943.       return string
  1944.       }
  1945.    if is:null(ce) then inline {
  1946.       d = k_current;
  1947.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1948.       }
  1949.    else if is:proc(ce) then inline {
  1950.       int j;
  1951.       struct b_proc *cproc = (struct b_proc *)BlkLoc(ce);
  1952.       for(j = 0; j < cproc->nstatic; j++) {
  1953.      result = cproc->lnames[j + cproc->nparam + cproc->ndynam];
  1954.      suspend result;
  1955.          }
  1956.       fail;
  1957.       }
  1958.    else if is:coexpr(ce) then inline {
  1959.       d = ce;
  1960.       BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
  1961.       }
  1962.    else runerr(118,ce)
  1963.    if !def:C_integer(i,0) then
  1964.       runerr(101,i)
  1965.    body {
  1966.       int j;
  1967.       dptr arg;
  1968.       struct b_proc *cproc;
  1969.       struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
  1970.       if (thePfp == NULL) fail;
  1971.  
  1972.       /*
  1973.        * Produce error if i is negative
  1974.        */
  1975.       if (i < 0) {
  1976.          irunerr(205, i);
  1977.          errorfail;
  1978.          }
  1979.  
  1980.       while (i--) {
  1981.      thePfp = thePfp->pf_pfp;
  1982.      if (thePfp == NULL) fail;
  1983.          }
  1984.  
  1985.       arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
  1986.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1987.       for(j=0; j < cproc->nstatic; j++) {
  1988.      result = cproc->lnames[j + cproc->nparam + cproc->ndynam];
  1989.      suspend result;
  1990.          }
  1991.       fail;
  1992.       }
  1993. end
  1994.  
  1995. "paramnames(ce,i) - produce the names of the parameters"
  1996. " in the current procedure activation in ce"
  1997.  
  1998. function{1,*} paramnames(ce,i)
  1999.    declare {
  2000.       tended struct descrip d;
  2001.       }
  2002.    abstract {
  2003.       return string
  2004.       }
  2005.    if is:null(ce) then inline {
  2006.       d = k_main;
  2007.       BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */
  2008.       }
  2009.    else if is:proc(ce) then inline {
  2010.       int j;
  2011.       struct b_proc *cproc = (struct b_proc *)BlkLoc(ce);
  2012.       for(j = 0; j < cproc->nparam; j++) {
  2013.      result = cproc->lnames[j];
  2014.      suspend result;
  2015.          }
  2016.       fail;
  2017.       }
  2018.    else if is:coexpr(ce) then inline {
  2019.       d = ce;
  2020.       BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */
  2021.       }
  2022.    else runerr(118,ce)
  2023.    if !def:C_integer(i,0) then
  2024.       runerr(101,i)
  2025.    body {
  2026.       int j;
  2027.       dptr arg;
  2028.       struct b_proc *cproc;
  2029.       struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
  2030.  
  2031.       if (thePfp == NULL) fail;
  2032.  
  2033.       /*
  2034.        * Produce error if i is negative
  2035.        */
  2036.       if (i < 0) {
  2037.          irunerr(205, i);
  2038.          errorfail;
  2039.          }
  2040.  
  2041.       while (i--) {
  2042.      thePfp = thePfp->pf_pfp;
  2043.      if (thePfp == NULL) fail;
  2044.          }
  2045.  
  2046.       arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
  2047.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  2048.       for(j = 0; j < cproc->nparam; j++) {
  2049.      result = cproc->lnames[j];
  2050.      suspend result;
  2051.          }
  2052.       fail;
  2053.       }
  2054. end
  2055. #endif                    /* MultiThread */
  2056.