![[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.