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