Return to omisc.c CVS log

Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx

Annotation of researchv10dc/cmd/icon/src/iconx/omisc.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * File: omisc.c
        !             3:  *  Contents: random, refresh, size, tabmat, toby
        !             4:  */
        !             5: 
        !             6: 
        !             7: #include "../h/rt.h"
        !             8: #define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&MaxLong))
        !             9: 
        !            10: /*
        !            11:  * ?x - produce a randomly selected element of x.
        !            12:  */
        !            13: 
        !            14: OpDclV(random,1,"?")
        !            15:    {
        !            16:    register word val, i, j;
        !            17:    register union block *bp;
        !            18:    long r1;
        !            19:    char sbuf[MaxCvtLen];
        !            20:    union block *ep;
        !            21:    struct descrip *dp;
        !            22:    double rval;
        !            23:    extern char *alcstr();
        !            24: 
        !            25:    Arg2 = Arg1;
        !            26:    DeRef(Arg1);
        !            27: 
        !            28:    if (Qual(Arg1)) {
        !            29:       /*
        !            30:        * x is a string, produce a random character in it as the result.
        !            31:        *  Note that a substring trapped variable is returned.
        !            32:        */
        !            33:       if ((val = StrLen(Arg1)) <= 0)
        !            34:          Fail;
        !            35:       blkreq((word)sizeof(struct b_tvsubs));
        !            36:       rval = RandVal;                  /* This form is used to get around */
        !            37:       rval *= val;                     /* a bug in a certain C compiler */
        !            38:       mksubs(&Arg2, &Arg1, (word)rval + 1, (word)1, &Arg0);
        !            39:       Return;
        !            40:       }
        !            41: 
        !            42:    switch (Type(Arg1)) {
        !            43:       case T_Cset:
        !            44:          /*
        !            45:           * x is a cset.  Convert it to a string, select a random character
        !            46:           *  of that string and return it.  Note that a substring trapped
        !            47:           *  variable is not needed.
        !            48:           */
        !            49:          cvstr(&Arg1, sbuf);
        !            50:          if ((val = StrLen(Arg1)) <= 0)
        !            51:             Fail;
        !            52:          strreq((word)1);
        !            53:          StrLen(Arg0) = 1;
        !            54:          rval = RandVal;
        !            55:          rval *= val;
        !            56:          StrLoc(Arg0) = alcstr(StrLoc(Arg1)+(word)rval, (word)1);
        !            57:          Return;
        !            58: 
        !            59: 
        !            60:       case T_List:
        !            61:          /*
        !            62:           * x is a list.  Set i to a random number in the range [1,*x],
        !            63:           *  failing if the list is empty.
        !            64:           */
        !            65:          bp = BlkLoc(Arg1);
        !            66:          val = bp->list.size;
        !            67:          if (val <= 0)
        !            68:             Fail;
        !            69:          rval = RandVal;
        !            70:          rval *= val;
        !            71:          i = (word)rval + 1;
        !            72:          j = 1;
        !            73:          /*
        !            74:           * Work down chain list of list blocks and find the block that
        !            75:           *  contains the selected element.
        !            76:           */
        !            77:          bp = BlkLoc(BlkLoc(Arg1)->list.listhead);
        !            78:          while (i >= j + bp->lelem.nused) {
        !            79:             j += bp->lelem.nused;
        !            80:             if ((bp->lelem.listnext).dword != D_Lelem)
        !            81:             syserr("list reference out of bounds in random");
        !            82:             bp = BlkLoc(bp->lelem.listnext);
        !            83:             }
        !            84:          /*
        !            85:           * Locate the appropriate element and return a variable
        !            86:           * that points to it.
        !            87:           */
        !            88:          i += bp->lelem.first - j;
        !            89:          if (i >= bp->lelem.nelem)
        !            90:             i -= bp->lelem.nelem;
        !            91:          dp = &bp->lelem.lslots[i];
        !            92:          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
        !            93:          VarLoc(Arg0) = dp;
        !            94:          Return;
        !            95: 
        !            96:       case T_Table:
        !            97:           /*
        !            98:            * x is a table.  Set i to a random number in the range [1,*x],
        !            99:            *  failing if the table is empty.
        !           100:            */
        !           101:          bp = BlkLoc(Arg1);
        !           102:          val = bp->table.size;
        !           103:          if (val <= 0)
        !           104:             Fail;
        !           105:          rval = RandVal;
        !           106:          rval *= val;
        !           107:          i = (word)rval + 1;
        !           108:          /*
        !           109:           * Work down the chain of elements in each bucket and return
        !           110:           *  a variable that points to the i'th element encountered.
        !           111:           */
        !           112:          for (j = 0; j < TSlots; j++) {
        !           113:             for (ep = BlkLoc(bp->table.buckets[j]); ep != NULL;
        !           114:                     ep = BlkLoc(ep->telem.clink)) {
        !           115:                if (--i <= 0) {
        !           116:                   dp = &ep->telem.tval;
        !           117:                   Arg0.dword = D_Var + ((word *)dp - (word *)bp);
        !           118:                   VarLoc(Arg0) = dp;
        !           119:                   Return;
        !           120:                   }
        !           121:                }
        !           122:              }
        !           123:       case T_Set:
        !           124:          /*
        !           125:           * x is a set.  Set i to a random number in the range [1,*x],
        !           126:           *  failing if the set is empty.
        !           127:           */
        !           128:          bp = BlkLoc(Arg1);
        !           129:          val = bp->set.size;
        !           130:          if (val <= 0)
        !           131:             Fail;
        !           132:          rval = RandVal;
        !           133:          rval *= val;
        !           134:          i = (word)rval + 1;
        !           135:          /*
        !           136:           * Work down the chain of elements in each bucket and return
        !           137:           *  the value of the ith element encountered.
        !           138:           */
        !           139:          for (j = 0; j < SSlots; j++) {
        !           140:             for (ep = BlkLoc(bp->set.sbucks[j]); ep != NULL;
        !           141:                ep = BlkLoc(ep->selem.clink)) {
        !           142:                  if (--i <= 0) {
        !           143:                     Arg0 = ep->selem.setmem;
        !           144:                     Return;
        !           145:                     }
        !           146:                 }
        !           147:              }
        !           148: 
        !           149:       case T_Record:
        !           150:          /*
        !           151:           * x is a record.  Set val to a random number in the range [1,*x]
        !           152:           *  (*x is the number of fields), failing if the record has no
        !           153:           *  fields.
        !           154:           */
        !           155:          bp = BlkLoc(Arg1);
        !           156:          val = BlkLoc(bp->record.recdesc)->proc.nfields;
        !           157:          if (val <= 0)
        !           158:             Fail;
        !           159:          /*
        !           160:           * Locate the selected element and return a variable
        !           161:           * that points to it
        !           162:           */
        !           163:             rval = RandVal;
        !           164:             rval *= val;
        !           165:             dp = &bp->record.fields[(word)rval];
        !           166:             Arg0.dword = D_Var + ((word *)dp - (word *)bp);
        !           167:             VarLoc(Arg0) = dp;
        !           168:             Return;
        !           169: 
        !           170:       default:
        !           171:          /*
        !           172:           * Try converting it to an integer
        !           173:           */
        !           174:       switch (cvint(&Arg1, &r1)) {
        !           175: 
        !           176:          case T_Longint:
        !           177:             runerr(205, &Arg1);
        !           178: 
        !           179:          case T_Integer:
        !           180:             /*
        !           181:              * x is an integer, be sure that it's non-negative.
        !           182:              */
        !           183:             val = (word)r1;
        !           184:             if (val < 0)
        !           185:                runerr(205, &Arg1);
        !           186:          getrand:
        !           187:             /*
        !           188:              * val contains the integer value of x.  If val is 0, return
        !           189:              * a real in the range [0,1), else return an integer in the
        !           190:              * range [1,val].
        !           191:              */
        !           192:             if (val == 0) {
        !           193:                rval = RandVal;
        !           194:                mkreal(rval, &Arg0);
        !           195:                }
        !           196:             else {
        !           197:                rval = RandVal;
        !           198:                rval *= val;
        !           199:                Mkint((long)rval + 1, &Arg0);
        !           200:                }
        !           201:             Return;
        !           202: 
        !           203:          default:
        !           204:             /*
        !           205:              * x is of a type for which random generation is not supported
        !           206:              */
        !           207:             runerr(113, &Arg1);
        !           208:             }
        !           209:          }
        !           210:    }
        !           211: 
        !           212: 
        !           213: /*
        !           214:  * ^x - return an entry block for co-expression x from the refresh block.
        !           215:  */
        !           216: 
        !           217: OpDcl(refresh,1,"^")
        !           218:    {
        !           219:    register struct b_coexpr *sblkp;
        !           220:    register struct b_refresh *rblkp;
        !           221:    register struct descrip *dp, *dsp;
        !           222:    register word *newsp;
        !           223:    int na, nl, i;
        !           224:    extern struct b_coexpr *alcstk();
        !           225:    extern struct b_refresh *alceblk();
        !           226: 
        !           227:    /*
        !           228:     * Be sure a co-expression is being refreshed.
        !           229:     */
        !           230:    if (Qual(Arg1) || Arg1.dword != D_Coexpr)
        !           231:       runerr(118, &Arg1);
        !           232: 
        !           233:    /*
        !           234:     * Get a new co-expression stack and initialize.
        !           235:     */
        !           236:    sblkp = alcstk();
        !           237:    sblkp->activator = nulldesc;
        !           238:    sblkp->size = 0;
        !           239:    sblkp->nextstk = stklist;
        !           240:    stklist = sblkp;
        !           241:    sblkp->freshblk = BlkLoc(Arg1)->coexpr.freshblk;
        !           242:    /*
        !           243:     * Icon stack starts at word after co-expression stack block.  C stack
        !           244:     *  starts at end of stack region on machines with down-growing C stacks
        !           245:     *  and somewhere in the middle of the region.
        !           246:     *
        !           247:     * The C stack is aligned on a doubleword boundary. For upgrowing
        !           248:     *  stacks, the C stack starts in the middle of the stack portion
        !           249:     *  of the static block.  For downgrowing stacks, the C stack starts
        !           250:     *  at the last word of the static block.
        !           251:     */
        !           252:    newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr));
        !           253: #ifdef UpStack
        !           254:    sblkp->cstate[0] =
        !           255:       ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2)
        !           256:        &~(WordSize*2-1));
        !           257: #else
        !           258:    sblkp->cstate[0] =
        !           259:        ((word)((char *)sblkp + stksize - WordSize)&~(WordSize*2-1));
        !           260: #endif UpStack
        !           261:    sblkp->es_argp = (struct descrip *)newsp;
        !           262:    /*
        !           263:     * Get pointer to refresh block and get number of arguments and locals.
        !           264:     */
        !           265:    rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk);
        !           266:    na = (rblkp->pfmkr).pf_nargs + 1;
        !           267:    nl = rblkp->numlocals;
        !           268: 
        !           269:    /*
        !           270:     * Copy arguments onto new stack.
        !           271:     */
        !           272:    dp = &rblkp->elems[0];
        !           273:    dsp = (struct descrip *)newsp;
        !           274:    for (i = 1; i <= na; i++)
        !           275:       *dsp++ = *dp++;
        !           276: 
        !           277:    /*
        !           278:     * Copy procedure frame to new stack and point dsp to word after frame.
        !           279:     */
        !           280:    *((struct pf_marker *)dsp) = rblkp->pfmkr;
        !           281:    sblkp->es_pfp = (struct pf_marker *)dsp;
        !           282:    dsp = (struct descrip *)((word *)dsp + Vwsizeof(*pfp));
        !           283:    sblkp->es_ipc = rblkp->ep;
        !           284:    sblkp->es_gfp = 0;
        !           285:    sblkp->es_efp = 0;
        !           286:    sblkp->tvalloc = NULL;
        !           287:    sblkp->es_ilevel = 0;
        !           288: 
        !           289:    /*
        !           290:     * Copy locals to new stack and refresh block.
        !           291:     */
        !           292:    for (i = 1; i <= nl; i++)
        !           293:       *dsp++ = *dp++;
        !           294: 
        !           295:    /*
        !           296:     * Push two null descriptors on the stack.
        !           297:     */
        !           298:    *dsp++ = nulldesc;
        !           299:    *dsp++ = nulldesc;
        !           300: 
        !           301:    sblkp->es_sp = (word *)dsp - 1;
        !           302: 
        !           303:    /*
        !           304:     * Establish line and file values and clear location for transmitted value.
        !           305:     */
        !           306:    sblkp->es_line = line;
        !           307: 
        !           308:    /*
        !           309:     * Return the new co-expression.
        !           310:     */
        !           311:    Arg0.dword = D_Coexpr;
        !           312:    BlkLoc(Arg0) = (union block *) sblkp;
        !           313:    Return;
        !           314:    }
        !           315: 
        !           316: 
        !           317: /*
        !           318:  * *x - return size of string or object x.
        !           319:  */
        !           320: 
        !           321: /* >size */
        !           322: OpDcl(size,1,"*")
        !           323:    {
        !           324:    char sbuf[MaxCvtLen];
        !           325: 
        !           326:    Arg0.dword = D_Integer;
        !           327:    if (Qual(Arg1)) {
        !           328:       /*
        !           329:        * If Arg1 is a string, return the length of the string.
        !           330:        */
        !           331:       IntVal(Arg0) = StrLen(Arg1);
        !           332:       }
        !           333:    else {
        !           334:       /*
        !           335:        * Arg1 is not a string.  For most types, the size is in the size
        !           336:        *  field of the block.  For records, it is in an auxiliary
        !           337:        *  structure.
        !           338:        */
        !           339:       switch (Type(Arg1)) {
        !           340:          case T_List:
        !           341:             IntVal(Arg0) = BlkLoc(Arg1)->list.size;
        !           342:             break;
        !           343: 
        !           344:          case T_Table:
        !           345:             IntVal(Arg0) = BlkLoc(Arg1)->table.size;
        !           346:             break;
        !           347: 
        !           348:          case T_Set:
        !           349:             IntVal(Arg0) = BlkLoc(Arg1)->set.size;
        !           350:             break;
        !           351: 
        !           352:          case T_Cset:
        !           353:             IntVal(Arg0) = BlkLoc(Arg1)->cset.size;
        !           354:             break;
        !           355: 
        !           356:          case T_Record:
        !           357:             IntVal(Arg0) = BlkLoc(BlkLoc(Arg1)->record.recdesc)->proc.nfields;
        !           358:             break;
        !           359: 
        !           360:          case T_Coexpr:
        !           361:             IntVal(Arg0) = BlkLoc(Arg1)->coexpr.size;
        !           362:             break;
        !           363: 
        !           364:          default:
        !           365:             /*
        !           366:              * Try to convert it to a string.
        !           367:              */
        !           368:             if (cvstr(&Arg1, sbuf) == NULL)
        !           369:                runerr(112, &Arg1);             /* no notion of size */
        !           370:             IntVal(Arg0) = StrLen(Arg1);
        !           371:          }
        !           372:       }
        !           373:    Return;
        !           374:    }
        !           375: /* <size */
        !           376: 
        !           377: /*
        !           378:  * =x - tab(match(x)).
        !           379:  * Reverses effects if resumed.
        !           380:  */
        !           381: 
        !           382: OpDcl(tabmat,1,"=")
        !           383:    {
        !           384:    register word l;
        !           385:    register char *s1, *s2;
        !           386:    word i, j;
        !           387:    char sbuf[MaxCvtLen];
        !           388: 
        !           389:    /*
        !           390:     * x must be a string.
        !           391:     */
        !           392:    if (cvstr(&Arg1,sbuf) == NULL)
        !           393:       runerr(103, &Arg1);
        !           394: 
        !           395:    /*
        !           396:     * Make a copy of &pos.
        !           397:     */
        !           398:    i = k_pos;
        !           399: 
        !           400:    /*
        !           401:     * Fail if &subject[&pos:0] is not of sufficient length to contain x.
        !           402:     */
        !           403:    j = StrLen(k_subject) - i + 1;
        !           404:    if (j < StrLen(Arg1))
        !           405:       Fail;
        !           406: 
        !           407:    /*
        !           408:     * Get pointers to x (s1) and &subject (s2).  Compare them on a bytewise
        !           409:     *  basis and fail if s1 doesn't match s2 for *s1 characters.
        !           410:     */
        !           411:    s1 = StrLoc(Arg1);
        !           412:    s2 = StrLoc(k_subject) + i - 1;
        !           413:    l = StrLen(Arg1);
        !           414:    while (l-- > 0) {
        !           415:       if (*s1++ != *s2++)
        !           416:          Fail;
        !           417:       }
        !           418: 
        !           419:    /*
        !           420:     * Increment &pos to tab over the matched string and suspend the
        !           421:     *  matched string.
        !           422:     */
        !           423:    l = StrLen(Arg1);
        !           424:    k_pos += l;
        !           425:    Arg0 = Arg1;
        !           426:    Suspend;
        !           427: 
        !           428:    /*
        !           429:     * tabmat has been resumed, restore &pos and fail.
        !           430:     */
        !           431:    k_pos = i;
        !           432:    if (k_pos > StrLen(k_subject) + 1)
        !           433:       runerr(205, &tvky_pos.kyval);
        !           434:    Fail;
        !           435:    }
        !           436: 
        !           437: 
        !           438: /*
        !           439:  * i to j by k - generate successive values.
        !           440:  */
        !           441: 
        !           442: /* >toby */
        !           443: OpDcl(toby,3,"toby")
        !           444:    {
        !           445:    long from, to, by;
        !           446: 
        !           447:    /*
        !           448:     * Arg1 (from), Arg2 (to), and Arg3 (by) must be integers.
        !           449:     *  Also, Arg3 must not be zero.
        !           450:     */
        !           451:    if (cvint(&Arg1, &from) == NULL)
        !           452:       runerr(101, &Arg1);
        !           453:    if (cvint(&Arg2, &to) == NULL)
        !           454:       runerr(101, &Arg2);
        !           455:    if (cvint(&Arg3, &by) == NULL)
        !           456:       runerr(101, &Arg3);
        !           457:    if (by == 0)
        !           458:       runerr(211, &Arg3);
        !           459: 
        !           460:    /*
        !           461:     * Count up or down (depending on relationship of from and to) and
        !           462:     *  suspend each value in sequence, failing when the limit has been
        !           463:     *  exceeded.
        !           464:     */
        !           465:    while ((from <= to && by > 0) || (from >= to && by < 0)) {
        !           466:       Mkint(from, &Arg0);
        !           467:       Suspend;
        !           468:       from += by;
        !           469:       }
        !           470:    Fail;
        !           471:    }
        !           472: /* <toby */

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.