home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Fmisc < prev    next >
Encoding:
Text File  |  1990-07-19  |  31.9 KB  |  1,239 lines
  1. /*
  2.  * File: fmisc.c
  3.  *  Contents: args, [callout], char, collect, copy, display, errorclear, iand,
  4.  *  icom, image, ior, ishift, ixor, ord, name, runerr, seq, sort, type, variable
  5.  */
  6.  
  7. #include <math.h>
  8. #include "../h/config.h"
  9. #include "../h/rt.h"
  10. #include "rproto.h"
  11.  
  12. extern word coll_tot;
  13. extern word coll_stat;
  14. extern word coll_str;
  15. extern word coll_blk;
  16.  
  17. struct dpair {
  18.    struct descrip dr;
  19.    struct descrip dv;
  20.    };
  21.  
  22. /*
  23.  * Prototypes.
  24.  */
  25.  
  26. hidden    int    getname        Params((dptr dp1, dptr dp2));
  27. hidden    int    trefcmp        Params((dptr d1,dptr d2));
  28. hidden    int    tvalcmp        Params((dptr d1,dptr d2));
  29. hidden    int    trcmp3        Params((struct dpair *dp1,struct dpair *dp2));
  30. hidden    int    tvcmp4        Params((struct dpair *dp1,struct dpair *dp2));
  31.  
  32. /*
  33.  * args(x) - produce number of arguments for procedure x.
  34.  */
  35. FncDcl(args,1)
  36.    {
  37.  
  38.    if (Arg1.dword != D_Proc)
  39.       RunErr(106, &Arg1);
  40.    MakeInt(((struct b_proc *)BlkLoc(Arg1))->nparam,&Arg0);
  41.    Return;
  42.    }
  43.  
  44. #ifdef ExternalFunctions
  45. #ifdef IconCalling
  46. /*
  47.  * callout - call a C routine with an argument count and a list of descriptors.
  48.  */
  49. FncDclV(callout)
  50. {
  51.    dptr retval;
  52.    struct pf_marker *newpfp;
  53.    register word *newsp = sp;
  54.    int signal;
  55.  
  56. /*------------------------------------------------------------------------*/
  57.    /*
  58.     * Build a procedure frame.  This is not normal for "built-in" procedures,
  59.     *  but we're preparing to call Icon back, if necessary.  To get rid of
  60.     *  this frame, on the way out signal a Pret.  The code between the dashed 
  61.     *  lines is copied largely from invoke().
  62.     */
  63.    newpfp = (struct pf_marker *)(newsp + 1);
  64.    newpfp->pf_nargs = nargs;
  65.    newpfp->pf_argp = argp;
  66.    newpfp->pf_pfp = pfp;
  67.    newpfp->pf_ilevel = ilevel;
  68.    newpfp->pf_scan = NULL;
  69.  
  70.    newpfp->pf_ipc = ipc;
  71.    newpfp->pf_gfp = gfp;
  72.    newpfp->pf_efp = efp;
  73.  
  74.    argp = cargp;    /* cargp is newargp in invoke() */
  75.    pfp = newpfp;
  76.    newsp += Vwsizeof(*pfp);
  77.    
  78.    efp = 0;
  79.    gfp = 0;
  80.  
  81.    sp = newsp;
  82. /*------------------------------------------------------------------------*/
  83.  
  84.    /*
  85.     * Little cheat here.  Although this is a var-arg procedure, we need
  86.     *  at least one argument to get started: pretend there is a null on
  87.     *  the stack.  NOTE:  Actually, at present, varargs functions always
  88.     *  have at least one argument, so this doesn't plug the hole.
  89.     */
  90.    if (nargs < 1)
  91.       RunErr(103, &nulldesc);
  92.  
  93.    /*
  94.     * Call the 'C routine caller' with a pointer to an array of descriptors.
  95.     *  Note that these are being left on the stack. We are passing
  96.     *  the name of the routine as part of the convention of calling
  97.     *  routines with an argc/argv technique.
  98.     */
  99.    signal = -1;            /* presume successful completion */
  100.    retval = extcall(&Arg1, nargs, &signal);
  101.    if (signal >= 0) {
  102.       if (retval == NULL)
  103.          RunErr(-signal, NULL)
  104.       else
  105.          RunErr(signal, retval); 
  106.       }
  107.    if (retval != NULL) {
  108.       Arg0 = *retval;
  109.       return A_Pret_uw;
  110.       }
  111.    else 
  112.       return A_Pfail_uw;
  113.    }
  114.  
  115. #else                    /* IconCalling */
  116.  
  117. /*
  118.  * callout - call a C library routine (or any C routine which doesn't call Icon)
  119.  *   with an argument count and a list of descriptors.  This routine
  120.  *   doesn't build a procedure frame to prepare for calling Icon back.
  121.  */
  122. FncDclV(callout)
  123. {
  124.    dptr retval;
  125.    int signal;
  126.  
  127.    /*
  128.     * Little cheat here.  Although this is a var-arg procedure, we need
  129.     *  at least one argument to get started: pretend there is a null on
  130.     *  the stack.  NOTE:  Actually, at present, varargs functions always
  131.     *  have at least one argument, so this doesn't plug the hole.
  132.     */
  133.    if (nargs < 1)
  134.       RunErr(103, &nulldesc);
  135.  
  136.    /*
  137.     * Call the 'C routine caller' with a pointer to an array of descriptors.
  138.     *  Note that these are being left on the stack. We are passing
  139.     *  the name of the routine as part of the convention of calling
  140.     *  routines with an argc/argv technique.
  141.     */
  142.    signal = -1;            /* presume successful completiong */
  143.    retval = extcall(&Arg1, nargs, &signal);
  144.    if (signal >= 0) {
  145.       if (retval == NULL)
  146.          RunErr(-signal, NULL)
  147.       else
  148.          RunErr(signal, retval); 
  149.       }
  150.    if (retval != NULL) {
  151.       Arg0 = *retval;
  152.       Return;
  153.       }
  154.    else 
  155.       Fail;
  156.    }
  157.  
  158. #endif                    /* IconCalling */
  159. #endif                     /* ExternalFunctions */
  160.  
  161. /*
  162.  * char(i) - produce a string consisting of character i.
  163.  */
  164. FncDcl(char,1)
  165.    {
  166.    char c;
  167.  
  168.    if (cvint(&Arg1) == CvtFail)
  169.       RunErr(101, &Arg1);
  170.    if (IntVal(Arg1) < 0 || IntVal(Arg1) >= 256)
  171.       RunErr(205, &Arg1);
  172.    if (strreq((uword)1) == Error)
  173.       RunErr(0, NULL);
  174.    c = IntVal(Arg1);
  175.    StrLen(Arg0) = 1;
  176.    StrLoc(Arg0) = alcstr(&FromAscii(c), (word)1);
  177.    Return;
  178.    }
  179.  
  180. /*
  181.  * collect(r,n) - call garbage collector to ensure n bytes in region r.
  182.  */
  183.  
  184. FncDcl(collect,2)
  185.    {
  186.    long region, bytes;
  187.    word coll = coll_tot;
  188.  
  189.    if ((defint(&Arg1, ®ion, (word)0) == Error) ||
  190.        (defint(&Arg2, &bytes, (word)0) == Error)) 
  191.       RunErr(0, NULL);
  192.    if (bytes < 0)
  193.       RunErr(205, &Arg2);
  194.    switch ((int)region) {
  195.       case 0:
  196.          break;
  197.       case Static:
  198.          coll_stat++;
  199.          break;
  200.       case Strings:
  201.          coll_str++;
  202.          if (strreq((uword)bytes) == Error)
  203.             Fail;
  204.          break;
  205.       case Blocks:  
  206.          coll_blk++;
  207.          if (blkreq((uword)bytes) == Error)
  208.             Fail;
  209.          break;
  210.       default:
  211.          RunErr(205, &Arg1);
  212.       };
  213.    if (coll == coll_tot)
  214.       collect((int)region);
  215.    Arg0 = nulldesc;
  216.    Return;
  217.    }
  218.  
  219. /*
  220.  * copy(x) - make a copy of object x.
  221.  */
  222.  
  223. FncDcl(copy,1)
  224.    {
  225.    register int i;
  226.    word slotnum;
  227.    struct descrip *d1, *d2;
  228.    struct b_slots *seg;
  229.    register union block **tp, *ep, *bp, *op;
  230.  
  231.    if (Qual(Arg1))
  232.       /*
  233.        * Arg1 is a string; just copy its descriptor
  234.        *  into Arg0.
  235.        */
  236.       Arg0 = Arg1;
  237.    else {
  238.       switch (Type(Arg1)) {
  239.          case T_Null:
  240.          case T_Integer:
  241.  
  242. #ifdef LargeInts
  243.      case T_Bignum:
  244. #endif                    /* LargeInts */
  245.  
  246.          case T_Real:
  247.          case T_File:
  248.          case T_Cset:
  249.          case T_Proc:
  250.          case T_Coexpr:
  251.          case T_External:
  252.             /*
  253.              * Copy the null value, integers, long integers, reals, files,
  254.              *    csets, procedures, and such by copying the descriptor.
  255.              *    Note that for integers, this results in the assignment
  256.              *    of a value, for the other types, a pointer is directed to
  257.              *    a data block.
  258.              */
  259.             Arg0 = Arg1;
  260.             break;
  261.  
  262.          case T_List:
  263.             /*
  264.              * Pass the buck to cplist to copy a list.
  265.              */
  266.             if (cplist(&Arg1, &Arg0, (word)1, BlkLoc(Arg1)->list.size + 1) ==
  267.                  Error) 
  268.                RunErr(0, NULL);
  269.             break;
  270.  
  271.          case T_Table:
  272.             /*
  273.              * Copy a Table.  First, allocate and copy header and slot blocks.
  274.              */
  275.             op = BlkLoc(Arg1);
  276.             bp = hmake(T_Table, op->table.mask + 1, op->table.size);
  277.             if (bp == NULL)
  278.                RunErr(0, NULL);
  279.             op = BlkLoc(Arg1);            /* may have moved */
  280.             bp->table.size = op->table.size;
  281.             bp->table.mask = op->table.mask;
  282.             bp->table.defvalue = op->table.defvalue;
  283.             for (i = 0; i < HSegs && op->table.hdir[i] != NULL; i++)
  284.                memcopy((char *)bp->table.hdir[i], (char *)op->table.hdir[i],
  285.                   op->table.hdir[i]->blksize);
  286.             /*
  287.              * Work down the chain of element blocks in each bucket
  288.              *    and create identical chains in new table.
  289.              */
  290.             for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  291.                for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--)  {
  292.                   tp = &seg->hslots[slotnum];
  293.                   for (ep = *tp; ep != NULL; ep = *tp) {
  294.                      *tp = (union block *)alctelem();
  295.                      (*tp)->telem = ep->telem;
  296.                      tp = &(*tp)->telem.clink;
  297.                      }
  298.                   }
  299.  
  300.             Arg0.dword = D_Table;
  301.             BlkLoc(Arg0) = bp;
  302.             if (TooSparse(bp))
  303.                hshrink(&Arg0);
  304.             break;
  305.  
  306.          case T_Set:
  307.             /*
  308.              * Pass the buck to cpset to copy a set.
  309.              */
  310.             if (cpset(&Arg1, &Arg0, BlkLoc(Arg1)->set.size) == Error)
  311.                RunErr(0, NULL);
  312.             break;
  313.  
  314.          case T_Record:
  315.             /*
  316.              * Allocate space for the new record and copy the old
  317.              *    one into it.
  318.              */
  319.             if (blkreq(BlkLoc(Arg1)->record.blksize) == Error) 
  320.                RunErr(0, NULL);
  321.             i = (int)BlkLoc(Arg1)->record.recdesc->proc.nfields;
  322.             bp = (union block *)alcrecd(i,&BlkLoc(Arg1)->record.recdesc);
  323.             bp->record = BlkLoc(Arg1)->record;
  324.             bp->record.id = bp->record.recdesc->proc.recid++;    /* get new id */
  325.             d1 = bp->record.fields;
  326.             d2 = BlkLoc(Arg1)->record.fields;
  327.             while (i--)
  328.                *d1++ = *d2++;
  329.             /*
  330.              * Return the copied record
  331.              */
  332.             Arg0.dword = D_Record;
  333.             BlkLoc(Arg0) = bp;
  334.             break;
  335.  
  336.          default:
  337.             RunErr(123,&Arg1);
  338.          }
  339.       }
  340.    Return;
  341.    }
  342.  
  343. /*
  344.  * display(i,f) - display local variables of i most recent
  345.  * procedure activations, plus global variables.
  346.  * Output to file f (default &errout).
  347.  */
  348.  
  349. FncDcl(display,2)
  350.    {
  351.    long l;
  352.    int count;
  353.    FILE *f;
  354.  
  355.    /*
  356.     * Arg1 defaults to &level; Arg2 defaults to &errout.
  357.     */
  358.    if ((defint(&Arg1, &l, (word)k_level) == Error) ||
  359.        (deffile(&Arg2, &errout) == Error)) 
  360.       RunErr(0, NULL);
  361.  
  362.    /*
  363.     * Produce error if file cannot be written.
  364.     */
  365.    f = BlkLoc(Arg2)->file.fd;
  366.    if ((BlkLoc(Arg2)->file.status & Fs_Write) == 0) 
  367.       RunErr(213, &Arg2);
  368.  
  369.    /*
  370.     * Produce error if Arg1 is negative; constrain Arg1 to be >= &level.
  371.     */
  372.    if (l < 0)  {
  373.       RunErr(205, &Arg1);
  374.       }
  375.    else if (l > k_level)
  376.       count = k_level;
  377.    else
  378.       count = (int)l;
  379.  
  380.    fprintf(f,"co-expression_%ld(%ld)\n\n",BlkLoc(k_current)->coexpr.id,
  381.       BlkLoc(k_current)->coexpr.size);
  382.    fflush(f);
  383.    xdisp(pfp,argp,count,f);
  384.    Arg0 = nulldesc;        /* Return null value. */
  385.    Return;
  386.    }
  387.  
  388. /*
  389.  * errorclear() - clear error condition.
  390.  */
  391.  
  392. FncDcl(errorclear,0)
  393.    {
  394.    k_errornumber = 0;
  395.    k_errortext = "";
  396.    k_errorvalue = nulldesc;
  397.    Arg0 = nulldesc;
  398.    Return;
  399.    }
  400.  
  401. /*
  402.  * iand(i,j) - produce bitwise AND of i and j.
  403.  */
  404. FncDcl(iand,2)
  405.    {
  406. #ifdef LargeInts
  407.    int t1, t2;
  408.  
  409.    if ((t1 = cvnum(&Arg1)) == CvtFail)
  410.       RunErr(101, &Arg1);
  411.    if ((t2 = cvnum(&Arg2)) == CvtFail)
  412.       RunErr(101, &Arg2);
  413.    if (t1 == T_Real) {
  414.       if (realtobig(&Arg1, &Arg1) == Error)  /* alcbignum failed */
  415.      RunErr(0, NULL);
  416.       t1 = Type(Arg1);
  417.       }
  418.    if (t2 == T_Real) {
  419.       if (realtobig(&Arg2, &Arg2) == Error)  /* alcbignum failed */
  420.      RunErr(0, NULL);;
  421.       t2 = Type(Arg2);
  422.       }
  423.    if (t1 == T_Integer && t2 == T_Integer) {
  424.       MakeInt(IntVal(Arg1) & IntVal(Arg2), &Arg0);
  425.       }
  426.    else
  427.       if (bigand(&Arg1, &Arg2, &Arg0) == Error)  /* alcvignum failed */
  428.      RunErr(0, NULL);
  429. #else                    /* LargeInts */
  430.    if (cvint(&Arg1) == CvtFail)
  431.       RunErr(101, &Arg1);
  432.    if (cvint(&Arg2) == CvtFail)
  433.       RunErr(101, &Arg2);
  434.    MakeInt(IntVal(Arg1) & IntVal(Arg2), &Arg0);
  435. #endif                    /* LargeInts */
  436.  
  437.    Return;
  438.    }
  439.  
  440. /*
  441.  * icom(i) - produce bitwise complement (one's complement) of i.
  442.  */
  443. FncDcl(icom,1)
  444.    {
  445. #ifdef LargeInts
  446.    int t1;
  447.  
  448.    if ((t1 = cvnum(&Arg1)) == CvtFail)
  449.       RunErr(101, &Arg1);
  450.  
  451.    if (t1 == T_Real) {
  452.       if (realtobig(&Arg1, &Arg1) == Error)  /* alcbignum failed */
  453.      RunErr(0, NULL);
  454.       t1 = Type(Arg1);
  455.       }
  456.    if (t1 == T_Integer) {
  457.       MakeInt(~IntVal(Arg1), &Arg0);
  458.       }
  459.    else {
  460.       struct descrip td;
  461.  
  462.       td.dword = D_Integer;
  463.       IntVal(td) = -1;
  464.       if (bigsub(&td, &Arg1, &Arg0) == Error)  /* alcbignum failed */
  465.      RunErr(0, NULL);
  466.       }
  467. #else                    /* LargeInts */
  468.    if (cvint(&Arg1) == CvtFail)
  469.       RunErr(101, &Arg1);
  470.    MakeInt(~IntVal(Arg1), &Arg0);
  471. #endif                    /* LargeInts */
  472.  
  473.    Return;
  474.    }
  475.  
  476. /*
  477.  * image(x) - return string image of object x.    Nothing fancy here,
  478.  *  just plug and chug on a case-wise basis.
  479.  */
  480.  
  481. FncDcl(image,1)
  482.    {
  483.    if (getimage(&Arg1,&Arg0) == Error)
  484.       RunErr(0, NULL);
  485.    Return;
  486.    }
  487.  
  488. /*
  489.  * ior(i,j) - produce bitwise inclusive OR of i and j.
  490.  */
  491. FncDcl(ior,2)
  492.    {
  493. #ifdef LargeInts
  494.    int t1, t2;
  495.  
  496.    if ((t1 = cvnum(&Arg1)) == CvtFail)
  497.       RunErr(101, &Arg1);
  498.    if ((t2 = cvnum(&Arg2)) == CvtFail)
  499.       RunErr(101, &Arg2);
  500.    if (t1 == T_Real) {
  501.       if (realtobig(&Arg1, &Arg1) == Error)  /* alcbignum failed */
  502.      RunErr(0, NULL);
  503.       t1 = Type(Arg1);
  504.       }
  505.    if (t2 == T_Real) {
  506.       if (realtobig(&Arg2, &Arg2) == Error)  /* alcbignum failed */
  507.      RunErr(0, NULL);
  508.       t2 = Type(Arg2);
  509.       }
  510.    if (t1 == T_Integer && t2 == T_Integer) {
  511.       MakeInt(IntVal(Arg1) | IntVal(Arg2), &Arg0);
  512.       }
  513.    else
  514.       if (bigor(&Arg1, &Arg2, &Arg0) == Error)  /* alcbignum failed */
  515.      RunErr(0, NULL);
  516. #else                    /* LargeInts */
  517.    if (cvint(&Arg1) == CvtFail)
  518.       RunErr(101, &Arg1);
  519.    if (cvint(&Arg2) == CvtFail)
  520.       RunErr(101, &Arg2);
  521.    MakeInt(IntVal(Arg1) | IntVal(Arg2), &Arg0);
  522. #endif                    /* LargeInts */
  523.  
  524.    Return;
  525.    }
  526.  
  527. /*
  528.  * ishift(i,j) - produce i shifted j bit positions (left if j<0, right if j>0).
  529.  */
  530. FncDcl(ishift,2)
  531.    {
  532.    uword i;    /* unsigned to ensure zero fill on right shift */
  533.    word n;
  534.  
  535. #ifdef LargeInts
  536.    int t1;
  537.  
  538.    if ((t1 = cvnum(&Arg1)) == CvtFail)
  539.       RunErr(101, &Arg1);
  540.    if (cvint(&Arg2) == CvtFail)
  541.       RunErr(101, &Arg2);
  542.  
  543.    if (t1 == T_Real) {
  544.       if (realtobig(&Arg1, &Arg1) == Error)  /* alcbignum failed */
  545.      RunErr(0, NULL);
  546.       t1 = Type(Arg1);
  547.       }
  548.    if (t1 == T_Bignum || IntVal(Arg2) > 0) {
  549.       if (bigshift(&Arg1, &Arg2, &Arg0) == Error)  /* alcbignum failed */
  550.      RunErr(0, NULL);
  551.       Return;
  552.       }
  553. #else                    /* LargeInts */
  554.    if (cvint(&Arg1) == CvtFail)
  555.       RunErr(101, &Arg1);
  556.    if (cvint(&Arg2) == CvtFail)
  557.       RunErr(101, &Arg2);
  558. #endif                    /* LargeInts */
  559.  
  560.    i = (uword)IntVal(Arg1);
  561.    n = IntVal(Arg2);
  562.    /*
  563.     * Check for a shift of WordSize or greater; return an explicit 0 because
  564.     *  this is beyond C's defined behavior.  Otherwise shift as requested.
  565.     */
  566.    if (n <= -WordBits || n >= WordBits)
  567.       i = 0;
  568.    else if (n < 0)
  569.       i >>= -n;
  570.    else
  571.       i <<= n;
  572.    MakeInt(i, &Arg0);
  573.    Return;
  574.    }
  575.  
  576. /*
  577.  * ixor(i,j) - produce bitwise exclusive OR of i and j.
  578.  */
  579. FncDcl(ixor,2)
  580.    {
  581. #ifdef LargeInts
  582.    int t1, t2;
  583.  
  584.    if ((t1 = cvnum(&Arg1)) == CvtFail)
  585.       RunErr(101, &Arg1);
  586.    if ((t2 = cvnum(&Arg2)) == CvtFail)
  587.       RunErr(101, &Arg2);
  588.    if (t1 == T_Real) {
  589.       if (realtobig(&Arg1, &Arg1) == Error)  /* alcbignum failed */
  590.      RunErr(0, NULL);
  591.       t1 = Type(Arg1);
  592.       }
  593.    if (t2 == T_Real) {
  594.       if (realtobig(&Arg2, &Arg2) == Error)  /* alcbignum failed */
  595.      RunErr(0, NULL);
  596.       t2 = Type(Arg2);
  597.       }
  598.    if (t1 == T_Integer && t2 == T_Integer) {
  599.       MakeInt(IntVal(Arg1) ^ IntVal(Arg2), &Arg0);
  600.       }
  601.    else
  602.       if (bigxor(&Arg1, &Arg2, &Arg0) == Error)  /* alcbignum failed */
  603.      RunErr(0, NULL);
  604. #else                    /* LargeInts */
  605.    if (cvint(&Arg1) == CvtFail)
  606.       RunErr(101, &Arg1);
  607.    if (cvint(&Arg2) == CvtFail)
  608.       RunErr(101, &Arg2);
  609.    MakeInt(IntVal(Arg1) ^ IntVal(Arg2), &Arg0);
  610. #endif                    /* LargeInts */
  611.  
  612.    Return;
  613.    }
  614.  
  615. /*
  616.  * ord(s) - produce integer ordinal (value) of single chracter.
  617.  */
  618. FncDcl(ord,1)
  619.    {
  620.    char sbuf[MaxCvtLen];
  621.  
  622.    if (cvstr(&Arg1, sbuf) == CvtFail)
  623.       RunErr(103, &Arg1);
  624.    if (StrLen(Arg1) != 1)
  625.       RunErr(205, &Arg1);
  626.    MakeInt(ToAscii(*StrLoc(Arg1) & 0xFF), &Arg0);
  627.    Return;
  628.    }
  629.  
  630. FncNDcl(name,1)
  631.    {
  632.  
  633.    if (!Var(Arg1))
  634.       RunErr(111, &Arg1);
  635.  
  636.    if (getname(&Arg1, &Arg0) == Error)
  637.       RunErr(0,NULL);
  638.  
  639.    Return;
  640.    }
  641.  
  642. /*
  643.  * getname -- function to get print name of variable
  644.  */
  645.  
  646. static int getname(dp1,dp0)
  647.    dptr dp1, dp0;
  648.    {
  649.    dptr dp, varptr;
  650.    union block *blkptr;
  651.    char sbuf[100];            /* buffer; might be too small */
  652.    word i, j, k;
  653.    extern word *ftabp, *records;
  654.    word *rp;
  655.    extern dptr fnames;
  656.  
  657.    /*
  658.     * Is it a trapped variable?
  659.     */
  660.    if Tvar(*dp1) {
  661.       blkptr = BlkLoc(*dp1);
  662.       switch (Type(*dp1)) {
  663.          case T_Tvkywd:
  664.             *dp0 = BlkLoc(*dp1)->tvkywd.kyname;
  665.             return Success;
  666.          case T_Tvsubs:
  667.             getname(&(blkptr->tvsubs.ssvar),dp0);
  668.             sprintf(sbuf,"[%ld:%ld]",blkptr->tvsubs.sspos,
  669.                blkptr->tvsubs.sslen);
  670.             j = strlen(sbuf);
  671.             k = StrLen(*dp0);
  672.             if (strreq(j + k) == Error)
  673.                return Error;
  674.             StrLoc(*dp0) = alcstr(StrLoc(*dp0),k);
  675.             alcstr(sbuf,j);
  676.             StrLen(*dp0) = j + k;
  677.             return Success;
  678.          case T_Tvtbl:
  679.             return keyref(dp1,dp0);
  680.          default: {
  681.             syserr("name: invalid trapped variable");
  682.             }
  683.          }
  684.       }
  685.  
  686.    /*
  687.     * Not a trapped variable; is it an identifier?
  688.     */
  689.    dp = VarLoc(*dp1);        /* get address of variable */
  690.    if (globals <= dp && dp < eglobals) {
  691.       *dp0 = gnames[dp - globals];         /* global */
  692.       return Success;
  693.       }
  694.    else if (statics <= dp && dp < estatics) {
  695.       blkptr = BlkLoc(*argp);
  696.       i = dp - statics - blkptr->proc.fstatic;    /* static */
  697.       if (i < 0 || i >= blkptr->proc.nstatic)
  698.          syserr("name: unreferencable static variable");
  699.       i += abs(blkptr->proc.nparam) + abs(blkptr->proc.ndynam);
  700.       *dp0 = blkptr->proc.lnames[i];
  701.       return Success;
  702.       }
  703.    else if (stack < (word *)dp && (word *)dp <= sp) {
  704.       if ((struct pf_marker*)dp < pfp) {    /* argument */
  705.          *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[(dp - argp) - 1];
  706.          }
  707.       else {                    /* local */
  708.          *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[dp -
  709.             pfp->pf_locals + ((struct b_proc *)VarLoc(*argp))->nparam];
  710.          }
  711.       return Success;
  712.       }
  713.  
  714.    /*
  715.     * Must be an element of a structure.
  716.     */
  717.    blkptr = (union block *)VarLoc(*dp1);
  718.    varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1));
  719.    switch ((int)BlkType(blkptr)) {
  720.       case T_Lelem: {        /* list */
  721.          if ((i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1) < 1)
  722.             i += blkptr->lelem.nslots;
  723.          while (blkptr->lelem.listprev != NULL) {
  724.             blkptr = blkptr->lelem.listprev;
  725.             i += blkptr->lelem.nused;
  726.             }
  727.          sprintf(sbuf,"L[%ld]",i);
  728.          i = strlen(sbuf);
  729.          if (strreq(i) == Error)
  730.             return Error;
  731.          StrLoc(*dp0) = alcstr(sbuf,i);
  732.          StrLen(*dp0) = i;
  733.          return Success;
  734.          }
  735.       case T_Record: {        /* record */
  736.          i = varptr - blkptr->record.fields;
  737.          rp = records + 1;
  738.          j = blkptr->record.recdesc->proc.recnum - 1;
  739.          k = 0;
  740.          while (ftabp[j] != i) {
  741.             j += *records;
  742.             k++;
  743.             }
  744.          sprintf(sbuf,"%s.%s",StrLoc(blkptr->record.recdesc-> proc.recname),
  745.             StrLoc(fnames[k]));
  746.          i = strlen(sbuf);
  747.          if (strreq(i) == Error)
  748.             return Error;
  749.          StrLoc(*dp0) = alcstr(sbuf,i);
  750.          StrLen(*dp0) = i;
  751.          return Success;
  752.          }
  753.       case T_Telem: {        /* table */
  754.          return keyref(dp1,dp0);
  755.          }
  756.       default:        /* none of the above */
  757.          syserr("name: invalid structure reference");
  758.       }
  759.    }
  760.  
  761. /*
  762.  * keyref(bp,dp) -- print name of subscripted table
  763.  */
  764. int keyref(dp1, dp2)
  765.    dptr dp1, dp2;
  766.    {
  767.    char *s;
  768.  
  769.    dp1 = &(((union block *)BlkLoc(*dp1))->telem.tref);
  770.    if (getimage(dp1,dp2) == Error)
  771.       return Error;
  772.    if (strreq(StrLen(*dp2) + 3) == Error)
  773.      return Error;
  774.    s = alcstr("T[",(word)2);
  775.    alcstr(StrLoc(*dp2),StrLen(*dp2));
  776.    alcstr("]",(word)1);
  777.    StrLoc(*dp2) = s;
  778.    StrLen(*dp2) = StrLen(*dp2) + 3;
  779.    return Success;
  780.    }
  781.  
  782. /*
  783.  * runerr(i,x) - produce runtime error i with value x.
  784.  */
  785.  
  786. FncDclV(runerr)
  787.    {
  788.  
  789.    if (nargs < 1)
  790.       RunErr(-101, NULL);
  791.  
  792.    switch (cvint(&Arg1)) {
  793.        case T_Integer:
  794.            if (IntVal(Arg1) <= 0)
  795.               RunErr(205, &Arg1);
  796.        break;
  797.  
  798.        default:
  799.           RunErr(101, &Arg1);
  800.        }
  801.  
  802.    if (nargs == 1) {
  803.       RunErr((int)(-IntVal(Arg1)), NULL);
  804.       }
  805.    else {
  806.       RunErr((int)IntVal(Arg1), &Arg2);
  807.       }
  808.       
  809.    }
  810.  
  811. /*
  812.  * seq(e1,e2) - generate e1, e1+e2, e1+e2+e2, ... .
  813.  */
  814.  
  815. FncDcl(seq,2)
  816.    {
  817.    long from, by;
  818.  
  819.    /*
  820.     * Default Arg1 and Arg2 to 1.
  821.     */
  822.    if ((defint(&Arg1, &from, (word)1) == Error) ||
  823.        (defint(&Arg2, &by, (word)1) == Error)) 
  824.       RunErr(0, NULL);
  825.    
  826.    /*
  827.     * Produce error if Arg2 is 0, i.e., an infinite sequence of Arg2s.
  828.     */
  829.    if (by == 0) 
  830.       RunErr(211, &Arg2);
  831.  
  832.    /*
  833.     * Suspend sequence, stopping when largest or smallest integer
  834.     *  is reached.
  835.     */
  836.    while ((from <= MaxLong && by > 0) || (from >= MinLong && by < 0)) {
  837.       MakeInt(from, &Arg0);
  838.       Suspend;
  839.       from += by;
  840.       }
  841.    Fail;
  842.    }
  843.  
  844. /*
  845.  * sort(l) - sort list l.
  846.  * sort(S) - sort set S.
  847.  * sort(t,i) - sort table.
  848.  */
  849.  
  850. FncDcl(sort,2)
  851.    {
  852.    register dptr d1;
  853.    register word size, i, j;
  854.    register struct b_slots *seg;
  855.    word nslots;
  856.    struct b_list *lp, *tp;
  857.    union block *bp, *ep;
  858.  
  859.    if (Arg1.dword == D_List) {
  860.       /*
  861.        * Sort the list by copying it into a new list and then using
  862.        *  qsort to sort the descriptors.  (That was easy!)
  863.        */
  864.       size = BlkLoc(Arg1)->list.size;
  865.       if (cplist(&Arg1, &Arg0, (word)1, size + 1) == Error) 
  866.          RunErr(0, NULL);
  867.       qsort((char *)BlkLoc(Arg0)->list.listhead->lelem.lslots,
  868.          (int)size, sizeof(struct descrip), anycmp);
  869.       }
  870.    else if (Arg1.dword == D_Set) {
  871.       /*
  872.        * Create a list the size of the set, copy each element into the list, and
  873.        *  then sort the list using qsort as in list sorting and return the
  874.        *  sorted list.
  875.        */
  876.    nslots = size = BlkLoc(Arg1)->set.size;
  877.  
  878.    if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) +
  879.       nslots * sizeof(struct descrip)) == Error) 
  880.       RunErr(0, NULL);
  881.  
  882.    bp = BlkLoc(Arg1);
  883.    lp = alclist(size);
  884.    lp->listtail = (union block *)alclstb(nslots, (word)0, size);
  885.    lp->listhead = lp->listtail;
  886.    if (size > 0) {  /* only need to sort non-empty sets */
  887.       d1 = lp->listhead->lelem.lslots;
  888.       for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  889.          for (j = segsize[i] - 1; j >= 0; j--)
  890.             for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  891.                *d1++ = ep->selem.setmem;
  892.       qsort((char *)lp->listhead->lelem.lslots,(int)size,
  893.          sizeof(struct descrip),anycmp);
  894.       }
  895.    Arg0.dword = D_List;
  896.    BlkLoc(Arg0) = (union block *) lp;
  897.    }
  898.  
  899.    else if (Arg1.dword == D_Table) {
  900.       /*
  901.        * Default i (the type of sort) to 1.
  902.        */
  903.       if (defshort(&Arg2, 1) == Error) 
  904.          RunErr(0, NULL);
  905.       switch ((int)IntVal(Arg2)) {
  906.  
  907.       /*
  908.        * Cases 1 and 2 are as in standard Version 5.
  909.        */
  910.          case 1:
  911.          case 2:
  912.         {
  913.       /*
  914.        * The list resulting from the sort will have as many elements as
  915.        *  the table has, so get that value and also make a valid list
  916.        *  block size out of it.
  917.        */
  918.       nslots = size = BlkLoc(Arg1)->table.size;
  919.       /*
  920.        * Ensure space for: the list header block and a list element
  921.        *  block for the list which is to be returned,
  922.        *  a list header block and a list element block for each of the two
  923.        *  element lists the sorted list is to contain. Note that the
  924.        *  calculation might be better expressed as:
  925.        *    list_header_size + list_block_size + nslots * descriptor_size +
  926.        *     nslots * (list_header_size + list_block_size + 2*descriptor_size)
  927.        */
  928.       if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) +
  929.          nslots * (sizeof(struct b_list) + sizeof(struct b_lelem) +
  930.             3 * sizeof(struct descrip))) == Error) 
  931.          RunErr(0, NULL);
  932.       /*
  933.        * Point bp at the table header block of the table to be sorted
  934.        *  and point lp at a newly allocated list
  935.        *  that will hold the the result of sorting the table.
  936.        */
  937.       bp = BlkLoc(Arg1);
  938.       lp = alclist(size);
  939.       lp->listtail = (union block *)alclstb(nslots, (word)0, size);
  940.       lp->listhead = lp->listtail;
  941.       /*
  942.        * If the table is empty, there is no need to sort anything.
  943.        */
  944.       if (size <= 0)
  945.          break;
  946.          /*
  947.           * Point d1 at the start of the list elements in the new list
  948.           *  element block in preparation for use as an index into the list.
  949.           */
  950.          d1 = lp->listhead->lelem.lslots;
  951.          /*
  952.           * Traverse the element chain for each table bucket.  For each
  953.           *  element, allocate a two-element list and put the table
  954.           *  entry value in the first element and the assigned value in
  955.           *  the second element.  The two-element list is assigned to
  956.           *  the descriptor that d1 points at.    When this is done, the
  957.           *  list of two-element lists is complete, but unsorted.
  958.           */
  959.  
  960.          for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  961.             for (j = segsize[i] - 1; j >= 0; j--)
  962.                for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) {
  963.                   d1->dword = D_List;
  964.                   tp = alclist((word)2);
  965.                   BlkLoc(*d1) = (union block *)tp;
  966.                   tp->listtail = (union block *)alclstb((word)2, (word)0,
  967.                      (word)2);
  968.                   tp->listhead = tp->listtail;
  969.                   tp->listhead->lelem.lslots[0] = ep->telem.tref;
  970.                   tp->listhead->lelem.lslots[1] = ep->telem.tval;
  971.                   d1++;
  972.                   }
  973.          /*
  974.           * Sort the resulting two-element list using the sorting function
  975.           *  determined by i.
  976.           */
  977.          if (IntVal(Arg2) == 1)
  978.             qsort((char *)lp->listhead->lelem.lslots, (int)size,
  979.                   sizeof(struct descrip), trefcmp);
  980.          else
  981.             qsort((char *)lp->listhead->lelem.lslots, (int)size,
  982.                   sizeof(struct descrip), tvalcmp);
  983.          break;        /* from cases 1 and 2 */
  984.          }
  985.       /*
  986.        * Cases 3 and 4 were introduced in Version 5.10.
  987.        */
  988.          case 3 :
  989.          case 4 :
  990.                  {
  991.       /*
  992.        * The list resulting from the sort will have twice as many elements as
  993.        *  the table has, so get that value and also make a valid list
  994.        *  block size out of it.
  995.        */
  996.       nslots = size = BlkLoc(Arg1)->table.size * 2;
  997.       /*
  998.        * Ensure space for: the list header block and a list element
  999.        *  block for the list which is to be returned, and two descriptors for
  1000.        *  each table element.
  1001.        */
  1002.       if (blkreq(sizeof(struct b_list) + Vsizeof(struct b_lelem) +
  1003.             (nslots * sizeof(struct descrip))) == Error) 
  1004.          RunErr(0, NULL);
  1005.  
  1006.       /*
  1007.        * Point bp at the table header block of the table to be sorted
  1008.        *  and point lp at a newly allocated list
  1009.        *  that will hold the the result of sorting the table.
  1010.        */
  1011.       bp = BlkLoc(Arg1);
  1012.       lp = alclist(size);
  1013.       lp->listtail = (union block *)alclstb(nslots, (word)0, size);
  1014.       lp->listhead = lp->listtail;
  1015.       /*
  1016.        * If the table is empty there's no need to sort anything.
  1017.        */
  1018.       if (size <= 0)
  1019.          break;
  1020.  
  1021.          /*
  1022.           * Point d1 at the start of the list elements in the new list
  1023.           *  element block in preparation for use as an index into the list.
  1024.           */
  1025.          d1 = lp->listhead->lelem.lslots;
  1026.          /*
  1027.           * Traverse the element chain for each table bucket.  For each
  1028.           *  table element copy the the entry descriptor and the value
  1029.           *  descriptor into adjacent descriptors in the lslots array
  1030.           *  in the list element block.
  1031.           *  When this is done we now need to sort this list.
  1032.           */
  1033.  
  1034.          for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  1035.             for (j = segsize[i] - 1; j >= 0; j--)
  1036.                for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) {
  1037.                   *d1++ = ep->telem.tref;
  1038.                   *d1++ = ep->telem.tval;
  1039.                   }
  1040.          /*
  1041.           * Sort the resulting two-element list using the sorting function
  1042.           *  determined by i.
  1043.           */
  1044.          if (IntVal(Arg2) == 3)
  1045.             qsort((char *)lp->listhead->lelem.lslots, (int)size / 2,
  1046.                   (2 * sizeof(struct descrip)), trcmp3);
  1047.          else
  1048.             qsort((char *)lp->listhead->lelem.lslots, (int)size / 2,
  1049.                   (2 * sizeof(struct descrip)), tvcmp4);
  1050.             break; /* from case 3 or 4 */
  1051.             }
  1052.  
  1053.          default:
  1054.             RunErr(205, &Arg2);
  1055.  
  1056.          } /* end of switch statement */
  1057.  
  1058.       /*
  1059.        * Make Arg0 point at the sorted list.
  1060.        */
  1061.       Arg0.dword = D_List;
  1062.       BlkLoc(Arg0) = (union block *) lp;
  1063.       }
  1064.    else {  /* Tried to sort something that wasn't a list or a table. */
  1065.       RunErr(115, &Arg1);
  1066.       }
  1067.    Return;
  1068.    }
  1069.  
  1070. /*
  1071.  * trefcmp(d1,d2) - compare two-element lists on first field.
  1072.  */
  1073.  
  1074. static int trefcmp(d1, d2)
  1075. dptr d1, d2;
  1076.    {
  1077.  
  1078. #ifdef DeBugIconx
  1079.    if (d1->dword != D_List || d2->dword != D_List)
  1080.       syserr("trefcmp: internal consistency check fails.");
  1081. #endif                    /* DeBugIconx */
  1082.  
  1083.    return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]),
  1084.                   &(BlkLoc(*d2)->list.listhead->lelem.lslots[0])));
  1085.    }
  1086.  
  1087. /*
  1088.  * tvalcmp(d1,d2) - compare two-element lists on second field.
  1089.  */
  1090.  
  1091. static int tvalcmp(d1, d2)
  1092. dptr d1, d2;
  1093.    {
  1094.  
  1095. #ifdef DeBugIconx
  1096.    if (d1->dword != D_List || d2->dword != D_List)
  1097.       syserr("tvalcmp: internal consistency check fails.");
  1098. #endif                    /* DeBugIconx */
  1099.  
  1100.    return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]),
  1101.       &(BlkLoc(*d2)->list.listhead->lelem.lslots[1])));
  1102.    }
  1103.  
  1104. /*
  1105.  * The following two routines are used to compare descriptor pairs in the
  1106.  *  experimental table sort.
  1107.  *
  1108.  * trcmp3(dp1,dp2)
  1109.  */
  1110.  
  1111. static int trcmp3(dp1, dp2)
  1112. struct dpair *dp1,*dp2;
  1113. {
  1114.    return (anycmp(&((*dp1).dr),&((*dp2).dr)));
  1115. }
  1116. /*
  1117.  * tvcmp4(dp1,dp2)
  1118.  */
  1119.  
  1120. static int tvcmp4(dp1, dp2)
  1121. struct dpair *dp1,*dp2;
  1122.  
  1123.    {
  1124.    return (anycmp(&((*dp1).dv),&((*dp2).dv)));
  1125.    }
  1126.  
  1127. /*
  1128.  * type(x) - return type of x as a string.
  1129.  */
  1130.  
  1131. FncDcl(type,1)
  1132.    {
  1133.  
  1134.    if (Qual(Arg1)) {
  1135.       StrLen(Arg0) = 6;
  1136.       StrLoc(Arg0) = "string";
  1137.       }
  1138.  
  1139.    else {
  1140.       switch (Type(Arg1)) {
  1141.  
  1142.          case T_Null:
  1143.             StrLen(Arg0) = 4;
  1144.             StrLoc(Arg0) = "null";
  1145.             break;
  1146.  
  1147. #ifdef LargeInts
  1148.      case T_Bignum:
  1149. #endif                    /* LargeInts */
  1150.  
  1151.          case T_Integer:
  1152.             StrLen(Arg0) = 7;
  1153.             StrLoc(Arg0) = "integer";
  1154.             break;
  1155.  
  1156.          case T_Real:
  1157.             StrLen(Arg0) = 4;
  1158.             StrLoc(Arg0) = "real";
  1159.             break;
  1160.  
  1161.          case T_Cset:
  1162.             StrLen(Arg0) = 4;
  1163.             StrLoc(Arg0) = "cset";
  1164.             break;
  1165.  
  1166.          case T_File:
  1167.             StrLen(Arg0) = 4;
  1168.             StrLoc(Arg0) = "file";
  1169.             break;
  1170.  
  1171.          case T_Proc:
  1172.             StrLen(Arg0) = 9;
  1173.             StrLoc(Arg0) = "procedure";
  1174.             break;
  1175.  
  1176.          case T_List:
  1177.             StrLen(Arg0) = 4;
  1178.             StrLoc(Arg0) = "list";
  1179.             break;
  1180.  
  1181.          case T_Table:
  1182.             StrLen(Arg0) = 5;
  1183.             StrLoc(Arg0) = "table";
  1184.             break;
  1185.  
  1186.          case T_Set:
  1187.             StrLen(Arg0) = 3;
  1188.             StrLoc(Arg0) = "set";
  1189.             break;
  1190.  
  1191.          case T_Record:
  1192.             Arg0 = BlkLoc(Arg1)->record.recdesc->proc.recname;
  1193.             break;
  1194.  
  1195.          case T_Coexpr:
  1196.             StrLen(Arg0) = 13;
  1197.             StrLoc(Arg0) = "co-expression";
  1198.             break;
  1199.  
  1200.          case T_External:
  1201.             StrLen(Arg0) = 8;
  1202.             StrLoc(Arg0) = "external";
  1203.             break;
  1204.  
  1205.          default:
  1206.             RunErr(123,&Arg1);
  1207.          }
  1208.       }
  1209.    Return;
  1210.    }
  1211.  
  1212. /*
  1213.  * variable(s) - find the variable with name s and return a
  1214.  *   variable descriptor which points to its value.
  1215.  */
  1216.  
  1217. FncDcl(variable,1)
  1218.    {
  1219.    char sbuf[MaxCvtLen];
  1220.  
  1221.    switch (cvstr(&Arg1, sbuf)) {
  1222.  
  1223.       case Cvt:   /* Already converted to a C-style string */
  1224.          break;
  1225.  
  1226.       case NoCvt:
  1227.          qtos(&Arg1, sbuf);
  1228.          break;
  1229.  
  1230.       default:
  1231.          RunErr(103, &Arg1);
  1232.       }
  1233.  
  1234.    if (getvar(StrLoc(Arg1),&Arg0) == Success)
  1235.       Return;
  1236.    else
  1237.       Fail;
  1238.    }
  1239.