1: #include "../h/rt.h" 2: #include "../h/record.h" 3: 4: /* 5: * image(x) - return string image of object x. Nothing fancy here, 6: * just plug and chug on a case-wise basis. 7: */ 8: 9: Ximage(nargs, arg1, arg0) 10: int nargs; 11: struct descrip arg1, arg0; 12: { 13: register int len, outlen, rnlen; 14: register char *s; 15: register union block *bp; 16: char *type; 17: extern char *alcstr(); 18: extern struct descrip *cstos(); 19: char sbuf[MAXSTRING]; 20: FILE *fd; 21: 22: DeRef(arg1) 23: 24: if (NULLDESC(arg1)) { /* &null */ 25: STRLOC(arg0) = "&null"; 26: STRLEN(arg0) = 5; 27: return; 28: } 29: 30: if (QUAL(arg1)) { 31: /* 32: * Get some string space. The magic 2 is for the double quote at each 33: * end of the resulting string. 34: */ 35: sneed(prescan(&arg1) + 2); 36: len = STRLEN(arg1); 37: s = STRLOC(arg1); 38: outlen = 2; 39: /* 40: * Form the image by putting a " in the string space, calling 41: * doimage with each character in the string, and then putting 42: * a " at then end. Note that doimage directly writes into the 43: * string space. (Hence the indentation.) This techinique is used 44: * several times in this routine. 45: */ 46: STRLOC(arg0) = alcstr("\"", 1); 47: while (len-- > 0) 48: outlen += doimage(*s++, '"'); 49: alcstr("\"", 1); 50: STRLEN(arg0) = outlen; 51: return; 52: } 53: 54: switch (TYPE(arg1)) { 55: case T_INTEGER: 56: #ifdef LONGS 57: case T_LONGINT: 58: #endif LONGS 59: case T_REAL: 60: /* 61: * Form a string representing the number and allocate it. 62: */ 63: cvstr(&arg1, sbuf); 64: len = STRLEN(arg1); 65: sneed(len); 66: STRLOC(arg0) = alcstr(STRLOC(arg1), len); 67: STRLEN(arg0) = len; 68: return; 69: 70: case T_CSET: 71: /* 72: * Check for distinguished csets by looking at the address of 73: * of the object to image. If one is found, make a string 74: * naming it and return. 75: */ 76: if (BLKLOC(arg1) == ((union block *) &k_ascii)) { 77: STRLOC(arg0) = "&ascii"; 78: STRLEN(arg0) = 6; 79: return; 80: } 81: else if (BLKLOC(arg1) == ((union block *) &k_cset)) { 82: STRLOC(arg0) = "&cset"; 83: STRLEN(arg0) = 5; 84: return; 85: } 86: else if (BLKLOC(arg1) == ((union block *) &k_lcase)) { 87: STRLOC(arg0) = "&lcase"; 88: STRLEN(arg0) = 6; 89: return; 90: } 91: else if (BLKLOC(arg1) == ((union block *) &k_ucase)) { 92: STRLOC(arg0) = "&ucase"; 93: STRLEN(arg0) = 6; 94: return; 95: } 96: /* 97: * Convert the cset to a string and proceed as is done for 98: * string images but use a ' rather than " to bound the 99: * result string. 100: */ 101: cvstr(&arg1, sbuf); 102: sneed(prescan(&arg1) + 2); 103: len = STRLEN(arg1); 104: s = STRLOC(arg1); 105: outlen = 2; 106: STRLOC(arg0) = alcstr("'", 1); 107: while (len-- > 0) 108: outlen += doimage(*s++, '\''); 109: alcstr("'", 1); 110: STRLEN(arg0) = outlen; 111: return; 112: 113: case T_FILE: 114: /* 115: * Check for distinguished files by looking at the address of 116: * of the object to image. If one is found, make a string 117: * naming it and return. 118: */ 119: if ((fd = BLKLOC(arg1)->file.fd) == stdin) { 120: STRLEN(arg0) = 6; 121: STRLOC(arg0) = "&input"; 122: } 123: else if (fd == stdout) { 124: STRLEN(arg0) = 7; 125: STRLOC(arg0) = "&output"; 126: } 127: else if (fd == stderr) { 128: STRLEN(arg0) = 7; 129: STRLOC(arg0) = "&errout"; 130: } 131: else { 132: /* 133: * The file is not a standard one, form a string of the form 134: * file(nm) where nm is the argument originally given to 135: * open. 136: */ 137: sneed(prescan(&BLKLOC(arg1)->file.fname)+6); 138: len = STRLEN(BLKLOC(arg1)->file.fname); 139: s = STRLOC(BLKLOC(arg1)->file.fname); 140: outlen = 6; 141: STRLOC(arg0) = alcstr("file(", 5); 142: while (len-- > 0) 143: outlen += doimage(*s++, '\0'); 144: alcstr(")", 1); 145: STRLEN(arg0) = outlen; 146: } 147: return; 148: 149: case T_PROC: 150: /* 151: * Produce one of: 152: * "procedure name" 153: * "function name" 154: * "record constructor name" 155: * 156: * Note that the number of dynamic locals is used to determine 157: * what type of "procedure" is at hand. 158: */ 159: len = STRLEN(BLKLOC(arg1)->proc.pname); 160: s = STRLOC(BLKLOC(arg1)->proc.pname); 161: switch (BLKLOC(arg1)->proc.ndynam) { 162: default: type = "procedure "; break; 163: case -1: type = "function "; break; 164: case -2: type = "record constructor "; break; 165: } 166: outlen = strlen(type); 167: sneed(len + outlen); 168: STRLOC(arg0) = alcstr(type, outlen); 169: alcstr(s, len); 170: STRLEN(arg0) = len + outlen; 171: return; 172: 173: case T_LIST: 174: /* 175: * Produce: 176: * "list(n)" 177: * where n is the current size of the list. 178: */ 179: bp = BLKLOC(arg1); 180: sprintf(sbuf, "list(%d)", bp->list.cursize); 181: len = strlen(sbuf); 182: sneed(len); 183: STRLOC(arg0) = alcstr(sbuf, len); 184: STRLEN(arg0) = len; 185: return; 186: 187: case T_LELEM: 188: STRLEN(arg0) = 18; 189: STRLOC(arg0) = "list element block"; 190: return; 191: 192: case T_TABLE: 193: /* 194: * Produce: 195: * "table(n)" 196: * where n is the size of the table. 197: */ 198: bp = BLKLOC(arg1); 199: sprintf(sbuf, "table(%d)", bp->table.cursize); 200: len = strlen(sbuf); 201: sneed(len); 202: STRLOC(arg0) = alcstr(sbuf, len); 203: STRLEN(arg0) = len; 204: return; 205: 206: case T_TELEM: 207: STRLEN(arg0) = 19; 208: STRLOC(arg0) = "table element block"; 209: return; 210: 211: #ifdef SETS 212: case T_SET: 213: /* 214: * Produce "set(n)" where n is size of the set. 215: */ 216: bp = BLKLOC(arg1); 217: sprintf(sbuf, "set(%d)", bp->set.setsize); 218: len = strlen(sbuf); 219: sneed(len); 220: STRLOC(arg0) = alcstr(sbuf,len); 221: STRLEN(arg0) = len; 222: return; 223: 224: case T_SELEM: 225: STRLEN(arg0) = 17; 226: STRLOC(arg0) = "set element block"; 227: return; 228: #endif SETS 229: 230: case T_RECORD: 231: /* 232: * Produce: 233: * "record name(n)" 234: * where n is the number of fields. 235: */ 236: bp = BLKLOC(arg1); 237: rnlen = STRLEN(bp->record.recptr->recname); 238: sneed(15 + rnlen); /* 15 = *"record " + *"(nnnnnn)" */ 239: bp = BLKLOC(arg1); 240: sprintf(sbuf, "(%d)", bp->record.recptr->nfields); 241: len = strlen(sbuf); 242: STRLOC(arg0) = alcstr("record ", 7); 243: alcstr(STRLOC(bp->record.recptr->recname), 244: rnlen); 245: alcstr(sbuf, len); 246: STRLEN(arg0) = 7 + len + rnlen; 247: return; 248: 249: case T_ESTACK: 250: /* 251: * Produce: 252: * "co-expression(n)" 253: * where n is the number of results that have been produced. 254: */ 255: sneed(22); 256: sprintf(sbuf, "(%d)", BLKLOC(arg1)->estack.nresults); 257: len = strlen(sbuf); 258: STRLOC(arg0) = alcstr("co-expression", 13); 259: alcstr(sbuf, len); 260: STRLEN(arg0) = 13 + len; 261: return; 262: 263: default: 264: syserr("image: unknown type."); 265: } 266: } 267: 268: Procblock(image,1) 269: 270: /* 271: * doimage(c,q) - allocate character c in string space, with escape 272: * conventions if c is unprintable, '\', or equal to q. 273: * Returns number of characters allocated. 274: */ 275: 276: doimage(c, q) 277: int c, q; 278: { 279: static char *cbuf = "\\\0\0\0"; 280: extern char *alcstr(); 281: 282: if (c >= ' ' && c < '\177') { 283: /* 284: * c is printable, but special case ", ', and \. 285: */ 286: switch (c) { 287: case '"': 288: if (c != q) goto def; 289: alcstr("\\\"", 2); 290: return (2); 291: case '\'': 292: if (c != q) goto def; 293: alcstr("\\'", 2); 294: return (2); 295: case '\\': 296: alcstr("\\\\", 2); 297: return (2); 298: default: 299: def: 300: cbuf[0] = c; 301: cbuf[1] = '\0'; 302: alcstr(cbuf,1); 303: return (1); 304: } 305: } 306: 307: /* 308: * c is some sort of unprintable character. If it is one of the common 309: * ones, produce a special representation for it, otherwise, produce 310: * its octal value. 311: */ 312: switch (c) { 313: case '\b': /* backspace */ 314: alcstr("\\b", 2); 315: return (2); 316: case '\177': /* delete */ 317: alcstr("\\d", 2); 318: return (2); 319: case '\33': /* escape */ 320: alcstr("\\e", 2); 321: return (2); 322: case '\f': /* form feed */ 323: alcstr("\\f", 2); 324: return (2); 325: case '\n': /* new line */ 326: alcstr("\\n", 2); 327: return (2); 328: case '\r': /* return */ 329: alcstr("\\r", 2); 330: return (2); 331: case '\t': /* horizontal tab */ 332: alcstr("\\t", 2); 333: return (2); 334: case '\13': /* vertical tab */ 335: alcstr("\\v", 2); 336: return (2); 337: default: /* octal constant */ 338: cbuf[0] = '\\'; 339: cbuf[1] = ((c&0300) >> 6) + '0'; 340: cbuf[2] = ((c&070) >> 3) + '0'; 341: cbuf[3] = (c&07) + '0'; 342: alcstr(cbuf, 4); 343: return (4); 344: } 345: } 346: 347: /* 348: * prescan(d) - return upper bound on length of expanded string. Note 349: * that the only time that prescan is wrong is when the string contains 350: * one of the "special" unprintable characters, e.g. tab. 351: */ 352: prescan(d) 353: struct descrip *d; 354: { 355: register int slen, len; 356: register char *s, c; 357: 358: s = STRLOC(*d); 359: len = 0; 360: for (slen = STRLEN(*d); slen > 0; slen--) 361: if ((c = (*s++)) < ' ' || c >= 0177) 362: len += 4; 363: else if (c == '"' || c == '\\' || c == '\'') 364: len += 2; 365: else 366: len++; 367: 368: return (len); 369: }
|
Last modified: 1984-11-18
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1584 |
|