![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fmisc.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 fmisc.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
1.1 root 1: /*
2: * File: fmisc.c
3: * Contents: collect, copy, display, image, seq, runstats, type
4: */
5:
6: #include "../h/rt.h"
7: #include "gc.h"
8: #ifdef RunStats
9: #ifndef VMS
10: #include <sys/types.h>
11: #include <sys/times.h>
12: #else VMS
13: #include <types.h>
14: struct tms {
15: time_t tms_utime; /* user time */
16: time_t tms_stime; /* system time */
17: time_t tms_cutime; /* user time, children */
18: time_t tms_cstime; /* system time, children */
19: };
20: #endif VMS
21: #endif RunStats
22:
23: #define Stralc(a,b) alcstr(a,(word)(b))
24: /*
25: * collect() - explicit call to garbage collector.
26: */
27:
28: FncDcl(collect,0)
29: {
30: collect();
31: Arg0 = nulldesc;
32: Return;
33: }
34:
35:
36: /*
37: * copy(x) - make a copy of object x.
38: */
39:
40: FncDcl(copy,1)
41: {
42: register int i;
43: struct descrip *d1, *d2;
44: union block *bp, *ep, **tp;
45: extern struct b_table *alctable();
46: extern struct b_telem *alctelem();
47: extern struct b_set *alcset();
48: extern struct b_selem *alcselem();
49: extern struct b_record *alcrecd();
50:
51: if (Qual(Arg1))
52: /*
53: * x is a string, just copy its descriptor
54: * into Arg0.
55: */
56: Arg0 = Arg1;
57: else {
58: switch (Type(Arg1)) {
59: case T_Null:
60: case T_Integer:
61: case T_Longint:
62: case T_Real:
63: case T_File:
64: case T_Cset:
65: case T_Proc:
66: case T_Coexpr:
67: /*
68: * Copy the null value, integers, long integers, reals, files,
69: * csets, procedures, and co-expressions by copying the descriptor.
70: * Note that for integers, this results in the assignment
71: * of a value, for the other types, a pointer is directed to
72: * a data block.
73: */
74: Arg0 = Arg1;
75: break;
76:
77: case T_List:
78: /*
79: * Pass the buck to cplist to copy a list.
80: */
81: cplist(&Arg1, &Arg0, (word)1, BlkLoc(Arg1)->list.size + 1);
82: break;
83:
84: case T_Table:
85: /*
86: * Allocate space for table and elements and copy old table
87: * block into new.
88: */
89: blkreq((sizeof(struct b_table)) +
90: (sizeof(struct b_telem)) * BlkLoc(Arg1)->table.size);
91: bp = (union block *) alctable(&nulldesc);
92: bp->table = BlkLoc(Arg1)->table;
93: /*
94: * Work down the chain of table element blocks in each bucket
95: * and create identical chains in new table.
96: */
97: for (i = 0; i < TSlots; i++) {
98: tp = &(BlkLoc(bp->table.buckets[i]));
99: for (ep = *tp; ep != NULL; ep = *tp) {
100: *tp = (union block *) alctelem();
101: (*tp)->telem = ep->telem;
102: tp = &(BlkLoc((*tp)->telem.clink));
103: }
104: }
105: /*
106: * Return the copied table.
107: */
108: Arg0.dword = D_Table;
109: BlkLoc(Arg0) = bp;
110: break;
111:
112: case T_Set:
113: /*
114: * Allocate space for set and elements and copy old set
115: * block into new.
116: */
117: blkreq((sizeof(struct b_set)) +
118: (sizeof(struct b_selem)) * BlkLoc(Arg1)->set.size);
119: bp = (union block *) alcset(&nulldesc);
120: bp->set = BlkLoc(Arg1)->set;
121: /*
122: * Work down the chain of set elements in each bucket
123: * and create identical chains in new set.
124: */
125: for (i = 0; i < SSlots; i++) {
126: tp = &(BlkLoc(bp->set.sbucks[i]));
127: for (ep = *tp; ep != NULL; ep = *tp) {
128: *tp = (union block *) alcselem(&nulldesc,(word)0);
129: (*tp)->selem = ep->selem;
130: tp = &(BlkLoc((*tp)->selem.clink));
131: }
132: }
133: /*
134: * Return the copied set.
135: */
136: Arg0.dword = D_Set;
137: BlkLoc(Arg0) = bp;
138: break;
139:
140: case T_Record:
141: /*
142: * Allocate space for the new record and copy the old
143: * one into it.
144: */
145: blkreq(BlkLoc(Arg1)->record.blksize);
146: i = BlkLoc(BlkLoc(Arg1)->record.recdesc)->proc.nfields;
147: bp = (union block *)alcrecd(i,&BlkLoc(Arg1)->record.recdesc);
148: bp->record = BlkLoc(Arg1)->record;
149: d1 = bp->record.fields;
150: d2 = BlkLoc(Arg1)->record.fields;
151: while (i--)
152: *d1++ = *d2++;
153: /*
154: * Return the copied record
155: */
156: Arg0.dword = D_Record;
157: BlkLoc(Arg0) = bp;
158: break;
159:
160: default:
161: syserr("copy: illegal datatype.");
162: }
163: }
164: Return;
165: }
166:
167:
168: /*
169: * display(i,f) - display local variables of i most recent
170: * procedure activations, plus global variables.
171: * Output to file f (default &errout).
172: */
173:
174: FncDcl(display,2)
175: {
176: struct pf_marker *fp;
177: register struct descrip *dp;
178: register struct descrip *np;
179: register int n;
180: long l;
181: int count;
182: FILE *f;
183: struct b_proc *bp;
184: extern struct descrip *globals, *eglobals;
185: extern struct descrip *gnames;
186: extern struct descrip *statics;
187:
188: /*
189: * i defaults to &level; f defaults to &errout.
190: */
191: defint(&Arg1, &l, (word)k_level);
192: deffile(&Arg2, &errout);
193: /*
194: * Produce error if file can't be written on.
195: */
196: f = BlkLoc(Arg2)->file.fd;
197: if ((BlkLoc(Arg2)->file.status & Fs_Write) == 0)
198: runerr(213, &Arg2);
199:
200: /*
201: * Produce error if i is negative; constrain i to be >= &level.
202: */
203: if (l < 0)
204: runerr(205, &Arg1);
205: else if (l > k_level)
206: count = k_level;
207: else
208: count = l;
209:
210: fp = pfp; /* start fp at most recent procedure frame */
211: dp = argp;
212: while (count--) { /* go back through 'count' frames */
213:
214: bp = (struct b_proc *) BlkLoc(*dp); /* get address of procedure block */
215:
216: /*
217: * Print procedure name.
218: */
219: putstr(f, StrLoc(bp->pname), StrLen(bp->pname));
220: fprintf(f, " local identifiers:\n");
221:
222: /*
223: * Print arguments.
224: */
225: np = bp->lnames;
226: for (n = bp->nparam; n > 0; n--) {
227: fprintf(f, " ");
228: putstr(f, StrLoc(*np), StrLen(*np));
229: fprintf(f, " = ");
230: outimage(f, ++dp, 0);
231: putc('\n', f);
232: np++;
233: }
234:
235: /*
236: * Print local dynamics.
237: */
238: dp = &fp->pf_locals[0];
239: for (n = bp->ndynam; n > 0; n--) {
240: fprintf(f, " ");
241: putstr(f, StrLoc(*np), StrLen(*np));
242: fprintf(f, " = ");
243: outimage(f, dp++, 0);
244: putc('\n', f);
245: np++;
246: }
247:
248: /*
249: * Print local statics.
250: */
251: dp = &statics[bp->fstatic];
252: for (n = bp->nstatic; n > 0; n--) {
253: fprintf(f, " ");
254: putstr(f, StrLoc(*np), StrLen(*np));
255: fprintf(f, " = ");
256: outimage(f, dp++, 0);
257: putc('\n', f);
258: np++;
259: }
260:
261: dp = fp->pf_argp;
262: fp = fp->pf_pfp;
263: }
264:
265: /*
266: * Print globals.
267: */
268: fprintf(f, "global identifiers:\n");
269: dp = globals;
270: np = gnames;
271: while (dp < eglobals) {
272: fprintf(f, " ");
273: putstr(f, StrLoc(*np), StrLen(*np));
274: fprintf(f, " = ");
275: outimage(f, dp++, 0);
276: putc('\n', f);
277: np++;
278: }
279: fflush(f);
280: Arg0 = nulldesc; /* Return null value. */
281: Return;
282: }
283:
284:
285: /*
286: * image(x) - return string image of object x. Nothing fancy here,
287: * just plug and chug on a case-wise basis.
288: */
289:
290: FncDcl(image,1)
291: {
292: register word len, outlen, rnlen;
293: register char *s;
294: register union block *bp;
295: char *type;
296: extern char *alcstr();
297: word prescan();
298: char sbuf[MaxCvtLen];
299: FILE *fd;
300:
301: if (Qual(Arg1)) {
302: /*
303: * Get some string space. The magic 2 is for the double quote at each
304: * end of the resulting string.
305: */
306: strreq(prescan(&Arg1) + 2);
307: len = StrLen(Arg1);
308: s = StrLoc(Arg1);
309: outlen = 2;
310:
311: /*
312: * Form the image by putting a " in the string space, calling
313: * doimage with each character in the string, and then putting
314: * a " at then end. Note that doimage directly writes into the
315: * string space. (Hence the indentation.) This techinique is used
316: * several times in this routine.
317: */
318: StrLoc(Arg0) = Stralc("\"", 1);
319: while (len-- > 0)
320: outlen += doimage(*s++, '"');
321: Stralc("\"", 1);
322: StrLen(Arg0) = outlen;
323: Return;
324: }
325:
326: switch (Type(Arg1)) {
327:
328: case T_Null:
329: StrLoc(Arg0) = "&null";
330: StrLen(Arg0) = 5;
331: Return;
332:
333: case T_Integer:
334: case T_Longint:
335: case T_Real:
336: /*
337: * Form a string representing the number and allocate it.
338: */
339: cvstr(&Arg1, sbuf);
340: len = StrLen(Arg1);
341: strreq(len);
342: StrLoc(Arg0) = alcstr(StrLoc(Arg1), len);
343: StrLen(Arg0) = len;
344: Return;
345:
346: case T_Cset:
347:
348: /*
349: * Check for distinguished csets by looking at the address of
350: * of the object to image. If one is found, make a string
351: * naming it and return.
352: */
353: if (BlkLoc(Arg1) == ((union block *) &k_ascii)) {
354: StrLoc(Arg0) = "&ascii";
355: StrLen(Arg0) = 6;
356: Return;
357: }
358: else if (BlkLoc(Arg1) == ((union block *) &k_cset)) {
359: StrLoc(Arg0) = "&cset";
360: StrLen(Arg0) = 5;
361: Return;
362: }
363: else if (BlkLoc(Arg1) == ((union block *) &k_lcase)) {
364: StrLoc(Arg0) = "&lcase";
365: StrLen(Arg0) = 6;
366: Return;
367: }
368: else if (BlkLoc(Arg1) == ((union block *) &k_ucase)) {
369: StrLoc(Arg0) = "&ucase";
370: StrLen(Arg0) = 6;
371: Return;
372: }
373: /*
374: * Convert the cset to a string and proceed as is done for
375: * string images but use a ' rather than " to bound the
376: * result string.
377: */
378: cvstr(&Arg1, sbuf);
379: strreq(prescan(&Arg1) + 2);
380: len = StrLen(Arg1);
381: s = StrLoc(Arg1);
382: outlen = 2;
383: StrLoc(Arg0) = Stralc("'", 1);
384: while (len-- > 0)
385: outlen += doimage(*s++, '\'');
386: Stralc("'", 1);
387: StrLen(Arg0) = outlen;
388: Return;
389:
390: case T_File:
391: /*
392: * Check for distinguished files by looking at the address of
393: * of the object to image. If one is found, make a string
394: * naming it and return.
395: */
396: if ((fd = BlkLoc(Arg1)->file.fd) == stdin) {
397: StrLen(Arg0) = 6;
398: StrLoc(Arg0) = "&input";
399: }
400: else if (fd == stdout) {
401: StrLen(Arg0) = 7;
402: StrLoc(Arg0) = "&output";
403: }
404: else if (fd == stderr) {
405: StrLen(Arg0) = 7;
406: StrLoc(Arg0) = "&errout";
407: }
408: else {
409: /*
410: * The file is not a standard one, form a string of the form
411: * file(nm) where nm is the argument originally given to
412: * open.
413: */
414: strreq(prescan(&BlkLoc(Arg1)->file.fname)+6);
415: len = StrLen(BlkLoc(Arg1)->file.fname);
416: s = StrLoc(BlkLoc(Arg1)->file.fname);
417: outlen = 6;
418: StrLoc(Arg0) = Stralc("file(", 5);
419: while (len-- > 0)
420: outlen += doimage(*s++, '\0');
421: Stralc(")", 1);
422: StrLen(Arg0) = outlen;
423: }
424: Return;
425:
426: case T_Proc:
427: /*
428: * Produce one of:
429: * "procedure name"
430: * "function name"
431: * "record constructor name"
432: *
433: * Note that the number of dynamic locals is used to determine
434: * what type of "procedure" is at hand.
435: */
436: len = StrLen(BlkLoc(Arg1)->proc.pname);
437: s = StrLoc(BlkLoc(Arg1)->proc.pname);
438: switch (BlkLoc(Arg1)->proc.ndynam) {
439: default: type = "procedure "; break;
440: case -1: type = "function "; break;
441: case -2: type = "record constructor "; break;
442: }
443: outlen = strlen(type);
444: strreq(len + outlen);
445: StrLoc(Arg0) = alcstr(type, outlen);
446: alcstr(s, len);
447: StrLen(Arg0) = len + outlen;
448: Return;
449:
450: case T_List:
451: /*
452: * Produce:
453: * "list(n)"
454: * where n is the current size of the list.
455: */
456: bp = BlkLoc(Arg1);
457: sprintf(sbuf, "list(%ld)", (long)bp->list.size);
458: len = strlen(sbuf);
459: strreq(len);
460: StrLoc(Arg0) = alcstr(sbuf, len);
461: StrLen(Arg0) = len;
462: Return;
463:
464: case T_Lelem:
465: StrLen(Arg0) = 18;
466: StrLoc(Arg0) = "list element block";
467: Return;
468:
469: case T_Table:
470: /*
471: * Produce:
472: * "table(n)"
473: * where n is the size of the table.
474: */
475: bp = BlkLoc(Arg1);
476: sprintf(sbuf, "table(%ld)", (long)bp->table.size);
477: len = strlen(sbuf);
478: strreq(len);
479: StrLoc(Arg0) = alcstr(sbuf, len);
480: StrLen(Arg0) = len;
481: Return;
482:
483: case T_Telem:
484: StrLen(Arg0) = 19;
485: StrLoc(Arg0) = "table element block";
486: Return;
487:
488: case T_Set:
489: /*
490: * Produce "set(n)" where n is size of the set.
491: */
492: bp = BlkLoc(Arg1);
493: sprintf(sbuf, "set(%ld)", (long)bp->set.size);
494: len = strlen(sbuf);
495: strreq(len);
496: StrLoc(Arg0) = alcstr(sbuf,len);
497: StrLen(Arg0) = len;
498: Return;
499:
500: case T_Selem:
501: StrLen(Arg0) = 17;
502: StrLoc(Arg0) = "set element block";
503: Return;
504:
505: case T_Record:
506: /*
507: * Produce:
508: * "record name(n)"
509: * where n is the number of fields.
510: */
511: bp = BlkLoc(Arg1);
512: rnlen = StrLen(BlkLoc(bp->record.recdesc)->proc.recname);
513: strreq(15 + rnlen); /* 15 = *"record " + *"(nnnnnn)" */
514: bp = BlkLoc(Arg1);
515: sprintf(sbuf, "(%ld)", (long)BlkLoc(bp->record.recdesc)->proc.nfields);
516: len = strlen(sbuf);
517: StrLoc(Arg0) = Stralc("record ", 7);
518: alcstr(StrLoc(BlkLoc(bp->record.recdesc)->proc.recname),rnlen);
519: alcstr(sbuf, len);
520: StrLen(Arg0) = 7 + len + rnlen;
521: Return;
522:
523: case T_Coexpr:
524: /*
525: * Produce:
526: * "co-expression(n)"
527: * where n is the number of results that have been produced.
528: */
529: strreq(22);
530: sprintf(sbuf, "(%ld)", (long)BlkLoc(Arg1)->coexpr.size);
531: len = strlen(sbuf);
532: StrLoc(Arg0) = Stralc("co-expression", 13);
533: alcstr(sbuf, len);
534: StrLen(Arg0) = 13 + len;
535: Return;
536:
537: default:
538: syserr("image: unknown type.");
539: }
540: Return;
541: }
542:
543: /*
544: * doimage(c,q) - allocate character c in string space, with escape
545: * conventions if c is unprintable, '\', or equal to q.
546: * Returns number of characters allocated.
547: */
548:
549: doimage(c, q)
550: int c, q;
551: {
552: static char *cbuf = "\\\0\0\0";
553: extern char *alcstr();
554:
555: if (c >= ' ' && c < '\177') {
556: /*
557: * c is printable, but special case ", ', and \.
558: */
559: switch (c) {
560: case '"':
561: if (c != q) goto def;
562: Stralc("\\\"", 2);
563: return 2;
564: case '\'':
565: if (c != q) goto def;
566: Stralc("\\'", 2);
567: return 2;
568: case '\\':
569: Stralc("\\\\", 2);
570: return 2;
571: default:
572: def:
573: cbuf[0] = c;
574: cbuf[1] = '\0';
575: Stralc(cbuf,1);
576: return 1;
577: }
578: }
579:
580: /*
581: * c is some sort of unprintable character. If it is one of the common
582: * ones, produce a special representation for it, otherwise, produce
583: * its octal value.
584: */
585: switch (c) {
586: case '\b': /* backspace */
587: Stralc("\\b", 2);
588: return 2;
589: case '\177': /* delete */
590: Stralc("\\d", 2);
591: return 2;
592: case '\33': /* escape */
593: Stralc("\\e", 2);
594: return 2;
595: case '\f': /* form feed */
596: Stralc("\\f", 2);
597: return 2;
598: case '\n': /* new line */
599: Stralc("\\n", 2);
600: return 2;
601: case '\r': /* return */
602: Stralc("\\r", 2);
603: return 2;
604: case '\t': /* horizontal tab */
605: Stralc("\\t", 2);
606: return 2;
607: case '\13': /* vertical tab */
608: Stralc("\\v", 2);
609: return 2;
610: default: /* octal constant */
611: cbuf[0] = '\\';
612: cbuf[1] = ((c&0300) >> 6) + '0';
613: cbuf[2] = ((c&070) >> 3) + '0';
614: cbuf[3] = (c&07) + '0';
615: Stralc(cbuf, 4);
616: return 4;
617: }
618: }
619:
620: /*
621: * prescan(d) - return upper bound on length of expanded string. Note
622: * that the only time that prescan is wrong is when the string contains
623: * one of the "special" unprintable characters, e.g. tab.
624: */
625: word prescan(d)
626: struct descrip *d;
627: {
628: register word slen, len;
629: register char *s, c;
630:
631: s = StrLoc(*d);
632: len = 0;
633: for (slen = StrLen(*d); slen > 0; slen--)
634: if ((c = (*s++)) < ' ' || c >= 0177)
635: len += 4;
636: else if (c == '"' || c == '\\' || c == '\'')
637: len += 2;
638: else
639: len++;
640:
641: return len;
642: }
643:
644:
645: /*
646: * seq(e1,e2) - generate e1, e1+e2, e1+e2+e2, ... .
647: */
648:
649: FncDcl(seq,2)
650: {
651: long from, by;
652:
653: /*
654: * Default e1 and e2 to 1.
655: */
656: defint(&Arg1, &from, (word)1);
657: defint(&Arg2, &by, (word)1);
658:
659: /*
660: * Produce error if e2 is 0, i.e., infinite sequence of e1's.
661: */
662: if (by == 0)
663: runerr(211, &Arg2);
664:
665: /*
666: * Suspend sequence, stopping when largest or smallest integer
667: * is reached.
668: */
669: while ((from <= MaxLong && by > 0) || (from >= MinLong && by < 0)) {
670: Mkint(from, &Arg0);
671: Suspend;
672: from += by;
673: }
674: Fail;
675: }
676:
677:
678: #ifdef RunStats
679: /*
680: * runstats - return all sorts of junk (and junk of all sorts)
681: */
682: FncDcl(runstats,0)
683: {
684: extern char *alcstr();
685: char fmt[500],*p,*q;
686: int i;
687: struct tms tp;
688: long time(), clock, runtim;
689: times(&tp);
690:
691: #ifndef MSDOS
692: runtim = 1000 * ((tp.tms_utime - starttime) / (double)Hz);
693: #else MSDOS
694: runtim = time() - starttime;
695: #endif MSDOS
696:
697: #define NValues1 47
698: for ((i = 1,p=fmt); i <= NValues1; i++) {
699: q = "%s\t%d\n";
700: while (*p++ = *q++);
701: --p;
702: }
703:
704: strreq(3000); /* just a guess */
705: sprintf(strfree,fmt,
706: "Lines executed/ex",ex_n_lines,
707: "Opcodes executed/ex",ex_n_opcodes,
708: "Total time/ex",runtim,
709: "Invocations/ex",ex_n_invoke,
710: "Icon procedure invocations/ex",ex_n_ipinvoke,
711: "Built-in procedure invocations/ex",ex_n_bpinvoke,
712: "Argument list adjustments/ex",ex_n_argadjust,
713: "Operator invocations/ex",ex_n_opinvoke,
714: "goal-directed invocations/ex",ex_n_mdge,
715: "String invocations/ex",ex_n_stinvoke,
716: "Keyword references/ex",ex_n_keywd,
717: "Local variable references/ex",ex_n_locref,
718: "Global variable references/ex",ex_n_globref,
719: "Static variable references/ex",ex_n_statref,
720:
721: "Expression suspensions/gde",gde_n_esusp,
722: "Esusp bytes copied/gde",gde_bc_esusp,
723: "Icon procedure suspensions/gde",gde_n_psusp,
724: "Psusp bytes copied/gde",gde_bc_psusp,
725: "Operator & built-in suspensions/gde",gde_n_susp,
726: "Susp bytes copied/gde",gde_bc_susp,
727:
728: "Expression failures/gde",gde_n_efail,
729: "Icon procedure failures/gde",gde_n_pfail,
730: "Operator & built-in failures/gde",gde_n_fail,
731: "Evaluation resumptions/gde",gde_n_resume,
732: "Expression returns/gde",gde_n_eret,
733: "Icon procedure returns/gde",gde_n_pret,
734:
735: "Block Region Size/gc",maxblk-blkbase,
736: "Block Region Usage/gc",blkfree-blkbase,
737: "String Size/gc",strend-strbase,
738: "String Usage/gc",strfree-strbase,
739:
740: "Garbage collections/gc",gc_n_total,
741: "String triggered collections/gc",gc_n_string,
742: "Block region triggered collections/gc",gc_n_blk,
743: "CE triggered collections/gc",gc_n_coexpr,
744:
745: "Total garbage collection time/gc",gc_t_total,
746: "Last garbage collection time/gc",gc_t_last,
747:
748: "Dereferences/ev",ev_n_deref,
749: "No-op dereferences/ev",ev_n_redunderef,
750: "Tv substring dereferences/ev",ev_n_tsderef,
751: "Tv table dereferences/ev",ev_n_ttderef,
752: "&pos dereferences/ev",ev_n_tpderef,
753:
754: "Cvint operations/cv",cv_n_int,
755: "No-op cvint operations/cv",cv_n_rint,
756: "Cvreal operations/cv",cv_n_real,
757: "No-op cvreal operations/cv",cv_n_rreal,
758: "Cvnum operations/cv",cv_n_num,
759: "No-op cvnum operations/cv",cv_n_rnum,
760: "Cvstr operations/cv",cv_n_str,
761: "No-op cvstr operations/cv",cv_n_rstr,
762: "Cvcset operations/cv",cv_n_cset,
763: "No-op cvcset operations/cv",cv_n_rcset,
764: 0,0,0,0);
765:
766: #define NValues2 15
767: for ((i = 1,p=fmt); i <= NValues2; i++) {
768: q = "%s\t%d\n";
769: while (*p++ = *q++);
770: --p;
771: }
772:
773: sprintf(strfree+strlen(strfree),fmt,
774: "Block region allocations/al",al_n_total,
775: "Total block space allocated/al",al_bc_btotal,
776: "String allocations/al",al_n_str,
777: "Total string space allocated/al",al_bc_stotal,
778: "Trapped substring allocations/al",al_n_subs,
779: "Cset allocations/al",al_n_cset,
780: "Real number allocations/al",al_n_real,
781: "List allocations/al",al_n_list,
782: "List block allocations/al",al_n_lstb,
783: "Table allocations/al",al_n_table,
784: "Table element allocations/al",al_n_telem,
785: "Table element tvars/al",al_n_tvtbl,
786: "File block allocations/al",al_n_file,
787: "Co-expression block allocations/al",al_n_eblk,
788: "Co-expression stack allocations/al",al_n_estk,
789:
790: 0,0,0,0 /* who can count? */
791: );
792: StrLoc(Arg0) = alcstr(strfree,(word)strlen(strfree));
793: StrLen(Arg0) = alcstr(StrLoc(Arg0));
794: Return;
795: }
796: #else RunStats
797: char junk; /* prevent empty object module */
798: #endif RunStats
799:
800:
801: /*
802: * type(x) - return type of x as a string.
803: */
804:
805: /* >type1 */
806: FncDcl(type,1)
807: {
808:
809: if (Qual(Arg1)) {
810: StrLen(Arg0) = 6;
811: StrLoc(Arg0) = "string";
812: }
813:
814: else {
815: switch (Type(Arg1)) {
816:
817: case T_Null:
818: StrLen(Arg0) = 4;
819: StrLoc(Arg0) = "null";
820: break;
821:
822: case T_Integer:
823: case T_Longint:
824: StrLen(Arg0) = 7;
825: StrLoc(Arg0) = "integer";
826: break;
827:
828: case T_Real:
829: StrLen(Arg0) = 4;
830: StrLoc(Arg0) = "real";
831: break;
832: /* <type1 */
833:
834: case T_Cset:
835: StrLen(Arg0) = 4;
836: StrLoc(Arg0) = "cset";
837: break;
838:
839: case T_File:
840: StrLen(Arg0) = 4;
841: StrLoc(Arg0) = "file";
842: break;
843:
844: case T_Proc:
845: StrLen(Arg0) = 9;
846: StrLoc(Arg0) = "procedure";
847: break;
848:
849: case T_List:
850: StrLen(Arg0) = 4;
851: StrLoc(Arg0) = "list";
852: break;
853:
854: case T_Table:
855: StrLen(Arg0) = 5;
856: StrLoc(Arg0) = "table";
857: break;
858:
859: case T_Set:
860: StrLen(Arg0) = 3;
861: StrLoc(Arg0) = "set";
862: break;
863:
864: case T_Record:
865: Arg0 = BlkLoc(BlkLoc(Arg1)->record.recdesc)->proc.recname;
866: break;
867:
868: case T_Coexpr:
869: StrLen(Arg0) = 13;
870: StrLoc(Arg0) = "co-expression";
871: break;
872:
873:
874: default:
875: syserr("type: unknown type.");
876: /* >type2 */
877: }
878: }
879: Return;
880: }
881: /* <type2 */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.