1: #include "../h/rt.h" 2: #include "../h/record.h" 3: 4: #define STRINGLIMIT 16 /* limit on length of imaged string */ 5: #define LISTLIMIT 6 /* limit on list items in image */ 6: 7: /* 8: * outimage - print image of d on file f. If restrict is non-zero, 9: * fields of records will not be imaged. 10: */ 11: 12: outimage(f, d, restrict) 13: FILE *f; 14: struct descrip *d; 15: int restrict; 16: { 17: register int i, j; 18: register char *s; 19: register union block *bp; 20: char *type; 21: FILE *fd; 22: struct descrip q; 23: extern char *blkname[]; 24: 25: outimg: 26: if (NULLDESC(*d)) { 27: if (restrict == 0) 28: fprintf(f, "&null"); 29: return; 30: } 31: 32: if (QUAL(*d)) { 33: /* 34: * *d is a string qualifier. Print STRINGLIMIT characters of it 35: * using printimage and denote the presence of additional characters 36: * by terminating the string with "...". 37: */ 38: i = STRLEN(*d); 39: s = STRLOC(*d); 40: j = MIN(i, STRINGLIMIT); 41: putc('"', f); 42: while (j-- > 0) 43: printimage(f, *s++, '"'); 44: if (i > STRINGLIMIT) 45: fprintf(f, "..."); 46: putc('"', f); 47: return; 48: } 49: 50: if (VAR(*d) && !TVAR(*d)) { 51: /* 52: * *d is a variable. Print "variable =", dereference it and loop 53: * back to the top to cause the value of the variable to be imaged. 54: */ 55: fprintf(f, "variable = "); 56: d = VARLOC(*d); 57: goto outimg; 58: } 59: 60: switch (TYPE(*d)) { 61: 62: case T_INTEGER: 63: fprintf(f, "%d", INTVAL(*d)); 64: return; 65: 66: #ifdef LONGS 67: case T_LONGINT: 68: fprintf(f, "%ld", BLKLOC(*d)->longint.intval); 69: return; 70: #endif LONGS 71: case T_REAL: 72: { 73: char s[30]; 74: struct descrip junk; 75: rtos(BLKLOC(*d)->realblk.realval, &junk, s); 76: fprintf(f, "%s", s); 77: return; 78: } 79: 80: case T_CSET: 81: /* 82: * Check for distinguished csets by looking at the address of 83: * of the object to image. If one is found, print its name. 84: */ 85: if (BLKLOC(*d) == (union block *) &k_ascii) { 86: fprintf(f, "&ascii"); 87: return; 88: } 89: else if (BLKLOC(*d) == (union block *) &k_cset) { 90: fprintf(f, "&cset"); 91: return; 92: } 93: else if (BLKLOC(*d) == (union block *) &k_lcase) { 94: fprintf(f, "&lcase"); 95: return; 96: } 97: else if (BLKLOC(*d) == (union block *) &k_ucase) { 98: fprintf(f, "&ucase"); 99: return; 100: } 101: /* 102: * Use printimage to print each character in the cset. Follow 103: * with "..." if the cset contains more than STRINGLIMIT 104: * characters. 105: */ 106: putc('\'', f); 107: j = STRINGLIMIT; 108: for (i = 0; i < 256; i++) { 109: if (tstb(i, BLKLOC(*d)->cset.bits)) { 110: if (j-- <= 0) { 111: fprintf(f, "..."); 112: break; 113: } 114: printimage(f, i, '\''); 115: } 116: } 117: putc('\'', f); 118: return; 119: 120: case T_FILE: 121: /* 122: * Check for distinguished files by looking at the address of 123: * of the object to image. If one is found, print its name. 124: */ 125: if ((fd = BLKLOC(*d)->file.fd) == stdin) 126: fprintf(f, "&input"); 127: else if (fd == stdout) 128: fprintf(f, "&output"); 129: else if (fd == stderr) 130: fprintf(f, "&output"); 131: else { 132: /* 133: * The file isn't a special one, just print "file(name)". 134: */ 135: i = STRLEN(BLKLOC(*d)->file.fname); 136: s = STRLOC(BLKLOC(*d)->file.fname); 137: fprintf(f, "file("); 138: while (i-- > 0) 139: printimage(f, *s++, '\0'); 140: putc(')', f); 141: } 142: return; 143: 144: case T_PROC: 145: /* 146: * Produce one of: 147: * "procedure name" 148: * "function name" 149: * "record constructor name" 150: * 151: * Note that the number of dynamic locals is used to determine 152: * what type of "procedure" is at hand. 153: */ 154: i = STRLEN(BLKLOC(*d)->proc.pname); 155: s = STRLOC(BLKLOC(*d)->proc.pname); 156: switch (BLKLOC(*d)->proc.ndynam) { 157: default: type = "procedure"; break; 158: case -1: type = "function"; break; 159: case -2: type = "record constructor"; break; 160: } 161: fprintf(f, "%s ", type); 162: while (i-- > 0) 163: printimage(f, *s++, '\0'); 164: return; 165: 166: case T_LIST: 167: /* 168: * listimage does the work for lists. 169: */ 170: listimage(f, BLKLOC(*d), restrict); 171: return; 172: 173: case T_TABLE: 174: /* 175: * Print "table(n)" where n is the size of the table. 176: */ 177: fprintf(f, "table(%d)", BLKLOC(*d)->table.cursize); 178: return; 179: #ifdef SETS 180: case T_SET: 181: /* 182: * print "set(n)" where n is the cardinality of the set 183: */ 184: fprintf(f,"set(%d)",BLKLOC(*d)->set.setsize); 185: return; 186: #endif SETS 187: 188: case T_RECORD: 189: /* 190: * If restrict is non-zero, print "record(n)" where n is the 191: * number of fields in the record. If restrict is zero, print 192: * the image of each field instead of the number of fields. 193: */ 194: bp = BLKLOC(*d); 195: i = STRLEN(bp->record.recptr->recname); 196: s = STRLOC(bp->record.recptr->recname); 197: fprintf(f, "record "); 198: while (i-- > 0) 199: printimage(f, *s++, '\0'); 200: j = bp->record.recptr->nfields; 201: if (j <= 0) 202: fprintf(f, "()"); 203: else if (restrict > 0) 204: fprintf(f, "(%d)", j); 205: else { 206: putc('(', f); 207: i = 0; 208: for (;;) { 209: outimage(f, &bp->record.fields[i], restrict+1); 210: if (++i >= j) 211: break; 212: putc(',', f); 213: } 214: putc(')', f); 215: } 216: return; 217: 218: case T_TVSUBS: 219: /* 220: * Produce "v[i+:j] = value" where v is the image of the variable 221: * containing the substring, i is starting position of the substring 222: * j is the length, and value is the string v[i+:j]. If the length 223: * (j) is one, just produce "v[i] = value". 224: */ 225: bp = BLKLOC(*d); 226: outimage(f, VARLOC(bp->tvsubs.ssvar), restrict); 227: if (bp->tvsubs.sslen == 1) 228: fprintf(f, "[%d]", bp->tvsubs.sspos); 229: else 230: fprintf(f, "[%d+:%d]", bp->tvsubs.sspos, bp->tvsubs.sslen); 231: if (QUAL(*VARLOC(bp->tvsubs.ssvar))) { 232: STRLEN(q) = bp->tvsubs.sslen; 233: STRLOC(q) = STRLOC(*VARLOC(bp->tvsubs.ssvar)) + bp->tvsubs.sspos-1; 234: fprintf(f, " = "); 235: d = &q; 236: goto outimg; 237: } 238: return; 239: 240: case T_TVTBL: 241: bp = BLKLOC(*d); 242: /* 243: * It is possible that descriptor d which thinks it is pointing 244: * at a TVTBL may actually be pointing at a TELEM which had 245: * been converted from a trapped variable. Check for this first 246: * and if it is a TELEM produce the outimage of its value. 247: */ 248: if (bp->tvtbl.type == T_TELEM) { 249: outimage(f,&bp->tvtbl.tvtval,restrict); 250: return; 251: } 252: /* 253: * It really was a TVTBL - Produce "t[s]" where t is the image of 254: * the table containing the element and s is the image of the 255: * subscript. 256: */ 257: else { 258: outimage(f, &bp->tvtbl.tvtable, restrict); 259: putc('[', f); 260: outimage(f, &bp->tvtbl.tvtref, restrict); 261: putc(']', f); 262: return; 263: } 264: 265: case T_TVPOS: 266: fprintf(f, "&pos = %d", k_pos); 267: return; 268: 269: case T_TVRAND: 270: fprintf(f, "&random = %ld", k_random); 271: return; 272: 273: case T_TVTRACE: 274: fprintf(f, "&trace = %d", k_trace); 275: return; 276: 277: case T_ESTACK: 278: fprintf(f, "co-expression"); 279: return; 280: 281: default: 282: if (TYPE(*d) <= MAXTYPE) 283: fprintf(f, "%s", blkname[TYPE(*d)]); 284: else 285: syserr("outimage: unknown type"); 286: } 287: } 288: 289: /* 290: * printimage - print character c on file f using escape conventions 291: * if c is unprintable, '\', or equal to q. 292: */ 293: 294: static printimage(f, c, q) 295: FILE *f; 296: int c, q; 297: { 298: if (c >= ' ' && c < '\177') { 299: /* 300: * c is printable, but special case ", ', and \. 301: */ 302: switch (c) { 303: case '"': 304: if (c != q) goto def; 305: fprintf(f, "\\\""); 306: return; 307: case '\'': 308: if (c != q) goto def; 309: fprintf(f, "\\'"); 310: return; 311: case '\\': 312: fprintf(f, "\\\\"); 313: return; 314: default: 315: def: 316: putc(c, f); 317: return; 318: } 319: } 320: 321: /* 322: * c is some sort of unprintable character. If it one of the common 323: * ones, produce a special representation for it, otherwise, produce 324: * its octal value. 325: */ 326: switch (c) { 327: case '\b': /* backspace */ 328: fprintf(f, "\\b"); 329: return; 330: case '\177': /* delete */ 331: fprintf(f, "\\d"); 332: return; 333: case '\33': /* escape */ 334: fprintf(f, "\\e"); 335: return; 336: case '\f': /* form feed */ 337: fprintf(f, "\\f"); 338: return; 339: case '\n': /* new line */ 340: fprintf(f, "\\n"); 341: return; 342: case '\r': /* return */ 343: fprintf(f, "\\r"); 344: return; 345: case '\t': /* horizontal tab */ 346: fprintf(f, "\\t"); 347: return; 348: case '\13': /* vertical tab */ 349: fprintf(f, "\\v"); 350: return; 351: default: /* octal constant */ 352: fprintf(f, "\\%03o", c&0377); 353: return; 354: } 355: } 356: 357: /* 358: * listimage - print an image of a list. 359: */ 360: 361: static listimage(f, lp, restrict) 362: FILE *f; 363: struct b_list *lp; 364: int restrict; 365: { 366: register int i, j; 367: register struct b_lelem *bp; 368: int size, count; 369: 370: bp = (struct b_lelem *) BLKLOC(lp->listhead); 371: size = lp->cursize; 372: 373: if (restrict > 0 && size > 0) { 374: /* 375: * Just give indication of size if the list isn't empty. 376: */ 377: fprintf(f, "list(%d)", size); 378: return; 379: } 380: 381: /* 382: * Print [e1,...,en] on f. If more than LISTLIMIT elements are in the 383: * list, produce the first LISTLIMIT/2 elements, an ellipsis, and the 384: * last LISTLIMIT elements. 385: */ 386: putc('[', f); 387: count = 1; 388: i = 0; 389: if (size > 0) { 390: for (;;) { 391: if (++i > bp->nused) { 392: i = 1; 393: bp = (struct b_lelem *) BLKLOC(bp->listnext); 394: } 395: if (count <= LISTLIMIT/2 || count > size - LISTLIMIT/2) { 396: j = bp->first + i - 1; 397: if (j >= bp->nelem) 398: j -= bp->nelem; 399: outimage(f, &bp->lslots[j], restrict+1); 400: if (count >= size) 401: break; 402: putc(',', f); 403: } 404: else if (count == LISTLIMIT/2 + 1) 405: fprintf(f, "...,"); 406: count++; 407: } 408: } 409: putc(']', f); 410: }