![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rmisc.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 rmisc.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
1.1 root 1: /*
2: * File: rmisc.c
3: * Contents: deref, hash, outimage, qtos, trace, tvkeys
4: */
5:
6: #include "../h/rt.h"
7: /*
8: * deref - dereference a descriptor.
9: */
10:
11: /* >deref1 */
12: deref(dp)
13: struct descrip *dp;
14: {
15: register word i, j;
16: register union block *bp;
17: struct descrip v, tbl, tref;
18: char sbuf[MaxCvtLen];
19: extern char *alcstr();
20:
21: if (!Qual(*dp) && Var(*dp)) {
22: /*
23: * dp points to a variable and must be dereferenced.
24: */
25: /* <deref1 */
26: /* >deref2 */
27: if (!Tvar(*dp))
28: /*
29: * An ordinary variable is being dereferenced, just replace
30: * *dp with the the descriptor *dp is pointing to.
31: */
32: *dp = *VarLoc(*dp);
33: /* <deref2 */
34: /* >deref3 */
35: else switch (Type(*dp)) {
36:
37: case T_Tvsubs:
38: Inc(ev_n_tsderef);
39: /*
40: * A substring trapped variable is being dereferenced.
41: * Point bp to the trapped variable block and v to
42: * the string.
43: */
44: bp = TvarLoc(*dp);
45: v = bp->tvsubs.ssvar;
46: DeRef(v);
47: if (!Qual(v))
48: runerr(103, &v);
49: if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
50: runerr(205, NULL);
51: /*
52: * Make a descriptor for the substring by getting the
53: * length and pointing into the string.
54: */
55: StrLen(*dp) = bp->tvsubs.sslen;
56: StrLoc(*dp) = StrLoc(v) + bp->tvsubs.sspos - 1;
57: break;
58: /* <deref3 */
59:
60: /* >deref4 */
61: case T_Tvtbl:
62: Inc(ev_n_ttderef);
63: if (BlkLoc(*dp)->tvtbl.title == T_Telem) {
64: /*
65: * The tvtbl has been converted to a telem and is in
66: * the table. Replace the descriptor pointed to by dp
67: * with the value of the element.
68: */
69: *dp = BlkLoc(*dp)->telem.tval;
70: break;
71: }
72:
73: /*
74: * Point tbl to the table header block, tref to the
75: * subscripting value, and bp to the appropriate element
76: * chain. Point dp to a descriptor for the default
77: * value in case the value referenced by the subscript
78: * is not in the table.
79: */
80: tbl = BlkLoc(*dp)->tvtbl.clink;
81: tref = BlkLoc(*dp)->tvtbl.tref;
82: i = BlkLoc(*dp)->tvtbl.hashnum;
83: *dp = BlkLoc(tbl)->table.defvalue;
84: bp = BlkLoc(BlkLoc(tbl)->table.buckets[SlotNum(i,TSlots)]);
85:
86: /*
87: * Traverse the element chain looking for the subscript value.
88: * If found, replace the descriptor pointed to by dp with
89: * the value of the element.
90: */
91: while (bp != NULL && bp->telem.hashnum <= i) {
92: if ((bp->telem.hashnum == i) &&
93: (equiv(&bp->telem.tref, &tref))) {
94: *dp = bp->telem.tval;
95: break;
96: }
97: bp = BlkLoc(bp->telem.clink);
98: }
99: break;
100: /* <deref4 */
101:
102: /* >deref5 */
103: case T_Tvkywd:
104: bp = TvarLoc(*dp);
105: *dp = bp->tvkywd.kyval;
106: break;
107: /* <deref5 */
108:
109: default:
110: syserr("deref: illegal trapped variable");
111: }
112: }
113: #ifdef Debug
114: if (!Qual(*d) && Var(*d))
115: syserr("deref: didn't get dereferenced");
116: #endif Debug
117: return 1;
118: }
119: /* <deref */
120:
121:
122: /*
123: * hash - compute hash value of arbitrary object for table and set accessing.
124: */
125:
126: /* >hash */
127: word hash(dp)
128: struct descrip *dp;
129: {
130: word i;
131: double r;
132: register word j;
133: register char *s;
134:
135: if (Qual(*dp)) {
136:
137: /*
138: * Compute the hash value for the string by summing the value
139: * of all the characters (up to a maximum of 10) plus the length.
140: */
141: i = 0;
142: s = StrLoc(*dp);
143: j = StrLen(*dp);
144: for (j = (j <= 10) ? j : 10 ; j > 0; j--)
145: i += *s++ & 0377;
146: i += StrLen(*dp) & 0377;
147: }
148: else {
149: switch (Type(*dp)) {
150: /*
151: * The hash value for numeric types is the bitstring
152: * representation of the value.
153: */
154:
155: case T_Integer:
156: i = IntVal(*dp);
157: break;
158:
159: case T_Longint:
160: i = BlkLoc(*dp)->longint.intval;
161: break;
162:
163: case T_Real:
164: GetReal(dp,r);
165: i = r;
166: break;
167:
168: case T_Cset:
169: /*
170: * Compute the hash value for a cset by exclusive or-ing
171: * the words in the bit array.
172: */
173: i = 0;
174: for (j = 0; j < CsetSize; j++)
175: i ^= BlkLoc(*dp)->cset.bits[j];
176: break;
177:
178: default:
179: /*
180: * For other types, use the type code as the hash
181: * value.
182: */
183: i = Type(*dp);
184: break;
185: }
186: }
187:
188: return i;
189: }
190: /* <hash */
191:
192:
193: #define StringLimit 16 /* limit on length of imaged string */
194: #define ListLimit 6 /* limit on list items in image */
195:
196: /*
197: * outimage - print image of d on file f. If restrict is non-zero,
198: * fields of records will not be imaged.
199: */
200:
201: outimage(f, d, restrict)
202: FILE *f;
203: struct descrip *d;
204: int restrict;
205: {
206: register word i, j;
207: register char *s;
208: register union block *bp, *vp;
209: char *type;
210: FILE *fd;
211: struct descrip q;
212: extern char *blkname[];
213: double rresult;
214:
215: outimg:
216:
217: if (Qual(*d)) {
218: /*
219: * *d is a string qualifier. Print StringLimit characters of it
220: * using printimage and denote the presence of additional characters
221: * by terminating the string with "...".
222: */
223: i = StrLen(*d);
224: s = StrLoc(*d);
225: j = Min(i, StringLimit);
226: putc('"', f);
227: while (j-- > 0)
228: printimage(f, *s++, '"');
229: if (i > StringLimit)
230: fprintf(f, "...");
231: putc('"', f);
232: return;
233: }
234:
235: if (Var(*d) && !Tvar(*d)) {
236: /*
237: * *d is a variable. Print "variable =", dereference it and loop
238: * back to the top to cause the value of the variable to be imaged.
239: */
240: fprintf(f, "variable = ");
241: d = VarLoc(*d);
242: goto outimg;
243: }
244:
245: switch (Type(*d)) {
246:
247: case T_Null:
248: if (restrict == 0)
249: fprintf(f, "&null");
250: return;
251:
252: case T_Integer:
253: fprintf(f, "%d", (int)IntVal(*d));
254: return;
255:
256: case T_Longint:
257: fprintf(f, "%ld", BlkLoc(*d)->longint.intval);
258: return;
259:
260: case T_Real:
261: {
262: char s[30];
263: struct descrip junk;
264: double rresult;
265:
266: GetReal(d,rresult);
267: rtos(rresult, &junk, s);
268: fprintf(f, "%s", s);
269: return;
270: }
271:
272: case T_Cset:
273: /*
274: * Check for distinguished csets by looking at the address of
275: * of the object to image. If one is found, print its name.
276: */
277: if (BlkLoc(*d) == (union block *) &k_ascii) {
278: fprintf(f, "&ascii");
279: return;
280: }
281: else if (BlkLoc(*d) == (union block *) &k_cset) {
282: fprintf(f, "&cset");
283: return;
284: }
285: else if (BlkLoc(*d) == (union block *) &k_lcase) {
286: fprintf(f, "&lcase");
287: return;
288: }
289: else if (BlkLoc(*d) == (union block *) &k_ucase) {
290: fprintf(f, "&ucase");
291: return;
292: }
293: /*
294: * Use printimage to print each character in the cset. Follow
295: * with "..." if the cset contains more than StringLimit
296: * characters.
297: */
298: putc('\'', f);
299: j = StringLimit;
300: for (i = 0; i < 256; i++) {
301: if (Testb(i, BlkLoc(*d)->cset.bits)) {
302: if (j-- <= 0) {
303: fprintf(f, "...");
304: break;
305: }
306: printimage(f, (int)i, '\'');
307: }
308: }
309: putc('\'', f);
310: return;
311:
312: case T_File:
313: /*
314: * Check for distinguished files by looking at the address of
315: * of the object to image. If one is found, print its name.
316: */
317: if ((fd = BlkLoc(*d)->file.fd) == stdin)
318: fprintf(f, "&input");
319: else if (fd == stdout)
320: fprintf(f, "&output");
321: else if (fd == stderr)
322: fprintf(f, "&output");
323: else {
324: /*
325: * The file isn't a special one, just print "file(name)".
326: */
327: i = StrLen(BlkLoc(*d)->file.fname);
328: s = StrLoc(BlkLoc(*d)->file.fname);
329: fprintf(f, "file(");
330: while (i-- > 0)
331: printimage(f, *s++, '\0');
332: putc(')', f);
333: }
334: return;
335:
336: case T_Proc:
337: /*
338: * Produce one of:
339: * "procedure name"
340: * "function name"
341: * "record constructor name"
342: *
343: * Note that the number of dynamic locals is used to determine
344: * what type of "procedure" is at hand.
345: */
346: i = StrLen(BlkLoc(*d)->proc.pname);
347: s = StrLoc(BlkLoc(*d)->proc.pname);
348: switch (BlkLoc(*d)->proc.ndynam) {
349: default: type = "procedure"; break;
350: case -1: type = "function"; break;
351: case -2: type = "record constructor"; break;
352: }
353: fprintf(f, "%s ", type);
354: while (i-- > 0)
355: printimage(f, *s++, '\0');
356: return;
357:
358: case T_List:
359: /*
360: * listimage does the work for lists.
361: */
362: listimage(f, (struct b_list *)BlkLoc(*d), restrict);
363: return;
364:
365: case T_Table:
366: /*
367: * Print "table(n)" where n is the size of the table.
368: */
369: fprintf(f, "table(%ld)", (long)BlkLoc(*d)->table.size);
370: return;
371: case T_Set:
372: /*
373: * print "set(n)" where n is the cardinality of the set
374: */
375: fprintf(f,"set(%ld)",(long)BlkLoc(*d)->set.size);
376: return;
377:
378: case T_Record:
379: /*
380: * If restrict is non-zero, print "record(n)" where n is the
381: * number of fields in the record. If restrict is zero, print
382: * the image of each field instead of the number of fields.
383: */
384: bp = BlkLoc(*d);
385: i = StrLen(BlkLoc(bp->record.recdesc)->proc.recname);
386: s = StrLoc(BlkLoc(bp->record.recdesc)->proc.recname);
387: fprintf(f, "record ");
388: while (i-- > 0)
389: printimage(f, *s++, '\0');
390: j = BlkLoc(bp->record.recdesc)->proc.nfields;
391: if (j <= 0)
392: fprintf(f, "()");
393: else if (restrict > 0)
394: fprintf(f, "(%ld)", (long)j);
395: else {
396: putc('(', f);
397: i = 0;
398: for (;;) {
399: outimage(f, &bp->record.fields[i], restrict+1);
400: if (++i >= j)
401: break;
402: putc(',', f);
403: }
404: putc(')', f);
405: }
406: return;
407:
408: case T_Tvsubs:
409: /*
410: * Produce "v[i+:j] = value" where v is the image of the variable
411: * containing the substring, i is starting position of the substring
412: * j is the length, and value is the string v[i+:j]. If the length
413: * (j) is one, just produce "v[i] = value".
414: */
415: bp = BlkLoc(*d);
416: d = VarLoc(bp->tvsubs.ssvar);
417: if ((word)d == (word)&tvky_sub)
418: fprintf(f, "&subject");
419: else outimage(f, d, restrict);
420: if (bp->tvsubs.sslen == 1)
421: fprintf(f, "[%ld]", (long)bp->tvsubs.sspos);
422: else
423: fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos, (long)bp->tvsubs.sslen);
424: if ((word)d == (word)&tvky_sub) {
425: fprintf(f, " = ");
426: vp = BlkLoc(bp->tvsubs.ssvar);
427: StrLen(q) = bp->tvsubs.sslen;
428: StrLoc(q) = StrLoc(vp->tvkywd.kyval) + bp->tvsubs.sspos-1;
429: d = &q;
430: goto outimg;
431: }
432: else if (Qual(*d)) {
433: StrLen(q) = bp->tvsubs.sslen;
434: StrLoc(q) = StrLoc(*VarLoc(bp->tvsubs.ssvar)) + bp->tvsubs.sspos-1;
435: fprintf(f, " = ");
436: d = &q;
437: goto outimg;
438: }
439: return;
440:
441: case T_Tvtbl:
442: bp = BlkLoc(*d);
443: /*
444: * It is possible that descriptor d which thinks it is pointing
445: * at a TVTBL may actually be pointing at a TELEM which had
446: * been converted from a trapped variable. Check for this first
447: * and if it is a TELEM produce the outimage of its value.
448: */
449: if (bp->tvtbl.title == T_Telem) {
450: outimage(f, &bp->tvtbl.tval, restrict);
451: return;
452: }
453: /*
454: * It really was a TVTBL - Produce "t[s]" where t is the image of
455: * the table containing the element and s is the image of the
456: * subscript.
457: */
458: else {
459: outimage(f, &bp->tvtbl.clink, restrict);
460: putc('[', f);
461: outimage(f, &bp->tvtbl.tref, restrict);
462: putc(']', f);
463: return;
464: }
465:
466: case T_Tvkywd:
467: bp = BlkLoc(*d);
468: i = StrLen(bp->tvkywd.kyname);
469: s = StrLoc(bp->tvkywd.kyname);
470: while (i-- > 0)
471: putc(*s++, f);
472: fprintf(f, " = ");
473: outimage(f, &bp->tvkywd.kyval, restrict);
474: return;
475:
476:
477: case T_Coexpr:
478: fprintf(f, "co-expression");
479: return;
480:
481: default:
482: if (Type(*d) <= MaxType)
483: fprintf(f, "%s", blkname[Type(*d)]);
484: else
485: syserr("outimage: unknown type");
486: }
487: }
488:
489: /*
490: * printimage - print character c on file f using escape conventions
491: * if c is unprintable, '\', or equal to q.
492: */
493:
494: static printimage(f, c, q)
495: FILE *f;
496: int c, q;
497: {
498: if (c >= ' ' && c < '\177') {
499: /*
500: * c is printable, but special case ", ', and \.
501: */
502: switch (c) {
503: case '"':
504: if (c != q) goto def;
505: fprintf(f, "\\\"");
506: return;
507: case '\'':
508: if (c != q) goto def;
509: fprintf(f, "\\'");
510: return;
511: case '\\':
512: fprintf(f, "\\\\");
513: return;
514: default:
515: def:
516: putc(c, f);
517: return;
518: }
519: }
520:
521: /*
522: * c is some sort of unprintable character. If it one of the common
523: * ones, produce a special representation for it, otherwise, produce
524: * its octal value.
525: */
526: switch (c) {
527: case '\b': /* backspace */
528: fprintf(f, "\\b");
529: return;
530: case '\177': /* delete */
531: fprintf(f, "\\d");
532: return;
533: case '\33': /* escape */
534: fprintf(f, "\\e");
535: return;
536: case '\f': /* form feed */
537: fprintf(f, "\\f");
538: return;
539: case '\n': /* new line */
540: fprintf(f, "\\n");
541: return;
542: case '\r': /* return */
543: fprintf(f, "\\r");
544: return;
545: case '\t': /* horizontal tab */
546: fprintf(f, "\\t");
547: return;
548: case '\13': /* vertical tab */
549: fprintf(f, "\\v");
550: return;
551: default: /* octal constant */
552: fprintf(f, "\\%03o", c&0377);
553: return;
554: }
555: }
556:
557: /*
558: * listimage - print an image of a list.
559: */
560:
561: static listimage(f, lp, restrict)
562: FILE *f;
563: struct b_list *lp;
564: int restrict;
565: {
566: register word i, j;
567: register struct b_lelem *bp;
568: word size, count;
569:
570: bp = (struct b_lelem *) BlkLoc(lp->listhead);
571: size = lp->size;
572:
573: if (restrict > 0 && size > 0) {
574: /*
575: * Just give indication of size if the list isn't empty.
576: */
577: fprintf(f, "list(%ld)", (long)size);
578: return;
579: }
580:
581: /*
582: * Print [e1,...,en] on f. If more than ListLimit elements are in the
583: * list, produce the first ListLimit/2 elements, an ellipsis, and the
584: * last ListLimit elements.
585: */
586: putc('[', f);
587: count = 1;
588: i = 0;
589: if (size > 0) {
590: for (;;) {
591: if (++i > bp->nused) {
592: i = 1;
593: bp = (struct b_lelem *) BlkLoc(bp->listnext);
594: }
595: if (count <= ListLimit/2 || count > size - ListLimit/2) {
596: j = bp->first + i - 1;
597: if (j >= bp->nelem)
598: j -= bp->nelem;
599: outimage(f, &bp->lslots[j], restrict+1);
600: if (count >= size)
601: break;
602: putc(',', f);
603: }
604: else if (count == ListLimit/2 + 1)
605: fprintf(f, "...,");
606: count++;
607: }
608: }
609: putc(']', f);
610: }
611:
612:
613: /*
614: * qtos - convert a qualified string named by *d to a C-style string in
615: * in str. At most MaxCvtLen characters are copied into str.
616: */
617:
618: qtos(d, str)
619: struct descrip *d;
620: char *str;
621: {
622: register word cnt, slen;
623: register char *c;
624:
625: c = StrLoc(*d);
626: slen = StrLen(*d);
627: for (cnt = Min(slen, MaxCvtLen - 1); cnt > 0; cnt--)
628: *str++ = *c++;
629: *str = '\0';
630: }
631:
632:
633: /*
634: * ctrace - procedure *bp is being called with nargs arguments, the first
635: * of which is at arg; produce a trace message.
636: */
637: ctrace(bp, nargs, arg)
638: struct b_proc *bp;
639: int nargs;
640: struct descrip *arg;
641: {
642: register int n;
643:
644: if (k_trace > 0)
645: k_trace--;
646: showline(bp->filename, line);
647: showlevel(k_level);
648: putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
649: putc('(', stderr);
650: while (nargs--) {
651: outimage(stderr, arg++, 0);
652: if (nargs)
653: putc(',', stderr);
654: }
655: putc(')', stderr);
656: putc('\n', stderr);
657: fflush(stderr);
658: }
659:
660: /*
661: * rtrace - procedure *bp is returning *rval; produce a trace message.
662: */
663:
664: rtrace(bp, rval)
665: register struct b_proc *bp;
666: struct descrip *rval;
667: {
668: register int n;
669:
670: if (k_trace > 0)
671: k_trace--;
672: showline(bp->filename, line);
673: showlevel(k_level);
674: putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
675: fprintf(stderr, " returned ");
676: outimage(stderr, rval, 0);
677: putc('\n', stderr);
678: fflush(stderr);
679: }
680:
681: /*
682: * ftrace - procedure *bp is failing; produce a trace message.
683: */
684:
685: ftrace(bp)
686: register struct b_proc *bp;
687: {
688: register int n;
689:
690: if (k_trace > 0)
691: k_trace--;
692: showline(bp->filename, line);
693: showlevel(k_level);
694: putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
695: fprintf(stderr, " failed");
696: putc('\n', stderr);
697: fflush(stderr);
698: }
699:
700: /*
701: * strace - procedure *bp is suspending *rval; produce a trace message.
702: */
703:
704: strace(bp, rval)
705: register struct b_proc *bp;
706: struct descrip *rval;
707: {
708: register int n;
709:
710: if (k_trace > 0)
711: k_trace--;
712: showline(bp->filename, line);
713: showlevel(k_level);
714: putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
715: fprintf(stderr, " suspended ");
716: outimage(stderr, rval, 0);
717: putc('\n', stderr);
718: fflush(stderr);
719: }
720:
721: /*
722: * atrace - procedure *bp is being resumed; produce a trace message.
723: */
724:
725: atrace(bp)
726: register struct b_proc *bp;
727: {
728: register int n;
729:
730: if (k_trace > 0)
731: k_trace--;
732: showline(bp->filename, line);
733: showlevel(k_level);
734: putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
735: fprintf(stderr, " resumed");
736: putc('\n', stderr);
737: fflush(stderr);
738: }
739:
740: /*
741: * showline - print file and line number information.
742: */
743: static showline(f, l)
744: char *f;
745: int l;
746: {
747: if (l > 0)
748: fprintf(stderr, "%.10s: %d\t", f, l);
749: else
750: fprintf(stderr, "\t\t");
751: }
752:
753: /*
754: * showlevel - print "| " n times.
755: */
756: static showlevel(n)
757: register int n;
758: {
759: while (n-- > 0) {
760: putc('|', stderr);
761: putc(' ', stderr);
762: }
763: }
764:
765:
766: /*
767: * putpos - assign value to &pos
768: */
769:
770: putpos(d1)
771: struct descrip *d1;
772: {
773: register word l1;
774: long l2;
775: switch (cvint(d1, &l2)) {
776:
777: case T_Integer:
778: break;
779:
780: case T_Longint:
781: return NULL;
782:
783: default: runerr(101, d1);
784: }
785:
786: l1 = cvpos(l2, StrLen(k_subject));
787: if (l1 == 0)
788: return NULL;
789: k_pos = l1;
790: return 1;
791: }
792:
793:
794: /*
795: * putran - assign value to &random
796: */
797:
798: putran(d1)
799: struct descrip *d1;
800: {
801: long l1;
802: switch (cvint(d1, &l1)) {
803:
804: case T_Integer:
805: case T_Longint:
806: break;
807:
808: default: runerr(101, d1);
809: }
810:
811: k_random = l1;
812: return 1;
813: }
814:
815:
816: /*
817: * putsub - assign value to &subject
818: */
819:
820: /* >putsub */
821: putsub(dp)
822: struct descrip *dp;
823: {
824: char sbuf[MaxCvtLen];
825: extern char *alcstr();
826:
827: switch (cvstr(dp, sbuf)) {
828:
829: case NULL:
830: runerr(103, dp);
831:
832: case Cvt:
833: strreq(StrLen(*dp));
834: StrLoc(*dp) = alcstr(StrLoc(*dp), StrLen(*dp));
835:
836: case NoCvt:
837: k_subject = *dp;
838: k_pos = 1;
839: }
840:
841: return 1;
842: }
843: /* <putsub */
844:
845:
846: /*
847: * puttrc - assign value to &trace
848: */
849:
850: puttrc(d1)
851: struct descrip *d1;
852: {
853: long l1;
854: switch (cvint(d1, &l1)) {
855:
856: case T_Integer:
857: k_trace = (int)l1;
858: break;
859:
860: case T_Longint:
861: k_trace = -1;
862: break;
863:
864: default: runerr(101, d1);
865: }
866:
867: return 1;
868: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.