![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to omisc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx|
Return to omisc.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
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.