home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Omisc < prev    next >
Encoding:
Text File  |  1990-07-19  |  6.7 KB  |  305 lines
  1. /*
  2.  * File: omisc.c
  3.  *  Contents: refresh, size, tabmat, toby
  4.  */
  5.  
  6. #include "../h/config.h"
  7. #include "../h/rt.h"
  8. #include "rproto.h"
  9.  
  10.  
  11. /*
  12.  * ^x - return an entry block for co-expression x from the refresh block.
  13.  */
  14.  
  15. OpDcl(refresh,1,"^")
  16.    {
  17.  
  18. #ifdef Coexpr
  19.    register struct b_coexpr *sblkp;
  20.    register struct b_refresh *rblkp;
  21.    register dptr dp, dsp;
  22.    register word *newsp;
  23.    int na, nl, i;
  24.  
  25.    /*
  26.     * Be sure a co-expression is being refreshed.
  27.     */
  28.    if (Qual(Arg1) || Arg1.dword != D_Coexpr) 
  29.       RunErr(118, &Arg1);
  30.  
  31.    /*
  32.     * Get a new co-expression stack and initialize.
  33.     */
  34.    if ((sblkp = alccoexp()) == NULL) 
  35.       RunErr(0, NULL);
  36.    sblkp->freshblk = BlkLoc(Arg1)->coexpr.freshblk;
  37.    if (ChkNull(sblkp->freshblk))    /* &main cannot be refreshed */
  38.       RunErr(215, &Arg1);
  39.  
  40.    /*
  41.     * The interpreter stack starts at word after co-expression stack block.
  42.     *  C stack starts at end of stack region on machines with down-growing C
  43.     *  stacks and somewhere in the middle of the region.
  44.     *
  45.     * The C stack is aligned on a doubleword boundary.    For upgrowing
  46.     *  stacks, the C stack starts in the middle of the stack portion
  47.     *  of the static block.  For downgrowing stacks, the C stack starts
  48.     *  at the last word of the static block.
  49.     */
  50.    newsp = (word *)((word)(char *)sblkp + sizeof(struct b_coexpr));
  51.  
  52. #ifdef UpStack
  53.    sblkp->cstate[0] =
  54.       ((word)((word)(char *)sblkp + (stksize - sizeof(*sblkp))/2)
  55.        &~(WordSize*StackAlign-1));
  56. #else                    /* UpStack */
  57.    sblkp->cstate[0] =
  58.     ((word)((word)(char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));
  59. #endif                    /* UpStack */
  60.  
  61. #ifdef CoProcesses
  62.    sblkp->cstate[1] = 0;
  63. #endif
  64.  
  65.  
  66.    sblkp->es_argp = (dptr)newsp;
  67.  
  68.    /*
  69.     * Get pointer to refresh block and get number of arguments and locals.
  70.     */
  71.  
  72.    rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk);
  73.    na = (rblkp->pfmkr).pf_nargs + 1;
  74.    nl = (int)rblkp->numlocals;
  75.  
  76.    /*
  77.     * Copy arguments onto new stack.
  78.     */
  79.    dp = &rblkp->elems[0];
  80.    dsp = (dptr)newsp;
  81.    for (i = 1; i <= na; i++)
  82.       *dsp++ = *dp++;
  83.  
  84.    /*
  85.     * Copy procedure frame to new stack and point dsp to word after frame.
  86.     */
  87.    *((struct pf_marker *)dsp) = rblkp->pfmkr;
  88.    sblkp->es_pfp = (struct pf_marker *)dsp;
  89. /*   dsp = (dptr)((word *)dsp + Vwsizeof(*pfp)); */
  90.    dsp = (dptr)((word)dsp + sizeof(word) * Vwsizeof(*pfp));
  91.    sblkp->es_ipc.opnd = rblkp->ep;
  92.    sblkp->es_gfp = 0;
  93.    sblkp->es_efp = 0;
  94.    sblkp->tvalloc = NULL;
  95.    sblkp->es_ilevel = 0;
  96.  
  97.    /*
  98.     * Copy locals to new stack and refresh block.
  99.     */
  100.    for (i = 1; i <= nl; i++)
  101.       *dsp++ = *dp++;
  102.  
  103.    /*
  104.     * Push two null descriptors on the stack.
  105.     */
  106.    *dsp++ = nulldesc;
  107.    *dsp++ = nulldesc;
  108.  
  109.    sblkp->es_sp = (word *)dsp - 1;
  110.  
  111.    /*
  112.     * Return the new co-expression.
  113.     */
  114.    Arg0.dword = D_Coexpr;
  115.    BlkLoc(Arg0) = (union block *) sblkp;
  116.    Return;
  117.  
  118. #else                    /* Coexpr */
  119.    RunErr(-401, NULL);
  120. #endif                    /* Coexpr */
  121.  
  122.    }
  123.  
  124. /*
  125.  * *x - return size of string or object x.
  126.  */
  127.  
  128. OpDcl(size,1,"*")
  129.    {
  130.    char sbuf[MaxCvtLen];
  131.    word i;
  132.    int j;
  133.    union block *bp;
  134.  
  135.    if (Qual(Arg1)) {
  136.       /*
  137.        * If Arg1 is a string, return the length of the string.
  138.        */
  139.       i = StrLen(Arg1);
  140.       }
  141.  
  142.    else {
  143.       /*
  144.        * Arg1 is not a string.  For most types, the size is in the size
  145.        *  field of the block.
  146.        *  structure.
  147.        */
  148.       switch (Type(Arg1)) {
  149.          case T_List:
  150.             i = BlkLoc(Arg1)->list.size;
  151.             break;
  152.  
  153.          case T_Table:
  154.             i = BlkLoc(Arg1)->table.size;
  155.             break;
  156.  
  157.          case T_Set:
  158.             i = BlkLoc(Arg1)->set.size;
  159.             break;
  160.  
  161.          case T_Cset: {
  162.         register unsigned int w;
  163.  
  164.             i = BlkLoc(Arg1)->cset.size;
  165.             if (i >= 0)
  166.                break;
  167.             bp = (union block *)BlkLoc(Arg1);
  168.             i = 0;
  169.             for (j = 0; j < CsetSize; j++)
  170.            for (w=bp->cset.bits[j]; w; w >>= 1)
  171.           if (w & 01)
  172.              i++;
  173.             bp->cset.size = i;
  174.             break;
  175.         }
  176.  
  177.          case T_Record:
  178.             i = BlkLoc(Arg1)->record.recdesc->proc.nfields;
  179.             break;
  180.  
  181.          case T_Coexpr:
  182.  
  183.             i = BlkLoc(Arg1)->coexpr.size;
  184.             break;
  185.  
  186.          default:
  187.             /*
  188.              * Try to convert it to a string.
  189.              */
  190.             if (cvstr(&Arg1, sbuf) == CvtFail) 
  191.                RunErr(112, &Arg1);    /* no notion of size */
  192.             i = StrLen(Arg1);
  193.          }
  194.       }
  195.    MakeInt(i, &Arg0);
  196.    Return;
  197.    }
  198.  
  199. /*
  200.  * =x - tab(match(x)).  Reverses effects if resumed.
  201.  */
  202.  
  203. OpDcl(tabmat,1,"=")
  204.    {
  205.    register word l;
  206.    register char *s1, *s2;
  207.    word i, j;
  208.    char sbuf[MaxCvtLen];
  209.    int type;
  210.  
  211.    /*
  212.     * Arg1 must be a string.
  213.     */
  214.    if ((type = cvstr(&Arg1,sbuf)) == CvtFail) 
  215.       RunErr(103, &Arg1);
  216.  
  217.    /*
  218.     * Make a copy of &pos.
  219.     */
  220.    i = k_pos;
  221.  
  222.    /*
  223.     * Fail if &subject[&pos:0] is not of sufficient length to contain Arg1.
  224.     */
  225.    j = StrLen(k_subject) - i + 1;
  226.    if (j < StrLen(Arg1))
  227.       Fail;
  228.  
  229.    /*
  230.     * Get pointers to Arg1 (s1) and &subject (s2).  Compare them on a bytewise
  231.     *  basis and fail if s1 doesn't match s2 for *s1 characters.
  232.     */
  233.    s1 = StrLoc(Arg1);
  234.    s2 = StrLoc(k_subject) + i - 1;
  235.    l = StrLen(Arg1);
  236.    while (l-- > 0) {
  237.       if (*s1++ != *s2++)
  238.          Fail;
  239.       }
  240.  
  241.    /*
  242.     * Increment &pos to tab over the matched string and suspend the
  243.     *  matched string.
  244.     */
  245.    l = StrLen(Arg1);
  246.    k_pos += l;
  247.    Arg0 = Arg1;
  248.    if (type == Cvt) {        /* string is in buffer, copy */
  249.       if (strreq(StrLen(Arg0)) == Error) 
  250.          RunErr(0, NULL);
  251.       StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0));
  252.       }
  253.    Suspend;
  254.  
  255.    /*
  256.     * tabmat has been resumed, restore &pos and fail.
  257.     */
  258.    if (i > StrLen(k_subject) + 1) {
  259.       RunErr(205, &tvky_pos.kyval);
  260.       }
  261.    else
  262.       k_pos = i;
  263.    Fail;
  264.    }
  265.  
  266. /*
  267.  * i to j by k - generate successive values.
  268.  */
  269.  
  270. OpDcl(toby,3,"...")
  271.    {
  272.    long from;
  273.  
  274.    /*
  275.     * Arg1 (from), Arg2 (to), and Arg3 (by) must be integers.
  276.     *  Also, Arg3 must not be zero.
  277.     */
  278.    if (cvint(&Arg1) == CvtFail) 
  279.       RunErr(101, &Arg1);
  280.    if (cvint(&Arg2) == CvtFail) 
  281.       RunErr(101, &Arg2);
  282.    if (cvint(&Arg3) == CvtFail) 
  283.       RunErr(101, &Arg3);
  284.    if (IntVal(Arg3) == 0) 
  285.       RunErr(211, &Arg3);
  286.  
  287.    /*
  288.     * Count up or down (depending on relationship of from and to) and
  289.     *  suspend each value in sequence, failing when the limit has been
  290.     *  exceeded.
  291.     */
  292.    from = IntVal(Arg1);
  293.    if (IntVal(Arg3) > 0)
  294.       for ( ; from <= IntVal(Arg2); from += IntVal(Arg3)) {
  295.      MakeInt(from, &Arg0);
  296.          Suspend;
  297.          }
  298.    else
  299.       for ( ; from >= IntVal(Arg2); from += IntVal(Arg3)) {
  300.      MakeInt(from, &Arg0);
  301.          Suspend;
  302.          }
  303.    Fail;
  304.    }
  305.