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:    }

Defined functions

Procblock defined in line 268; never used
Ximage defined in line 9; never used
doimage defined in line 268; used 3 times
prescan defined in line 352; used 3 times
Last modified: 1984-11-18
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1473
Valid CSS Valid XHTML 1.0 Strict