Return to rmisc.c CVS log

Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx

Annotation of researchv10dc/cmd/icon/src/iconx/rmisc.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * File: rmisc.c
        !             3:  *  Contents: deref, hash, outimage, qtos, trace, tvkeys
        !             4:  */
        !             5: 
        !             6: #include "../h/rt.h"
        !             7: /*
        !             8:  * deref - dereference a descriptor.
        !             9:  */
        !            10: 
        !            11: /* >deref1 */
        !            12: deref(dp)
        !            13: struct descrip *dp;
        !            14:    {
        !            15:    register word i, j;
        !            16:    register union block *bp;
        !            17:    struct descrip v, tbl, tref;
        !            18:    char sbuf[MaxCvtLen];
        !            19:    extern char *alcstr();
        !            20: 
        !            21:    if (!Qual(*dp) && Var(*dp)) {
        !            22:       /*
        !            23:        * dp points to a variable and must be dereferenced.
        !            24:        */
        !            25: /* <deref1 */
        !            26: /* >deref2 */
        !            27:       if (!Tvar(*dp))
        !            28:          /*
        !            29:           * An ordinary variable is being dereferenced, just replace
        !            30:           *  *dp with the the descriptor *dp is pointing to.
        !            31:           */
        !            32:          *dp = *VarLoc(*dp);
        !            33: /* <deref2 */
        !            34: /* >deref3 */
        !            35:       else switch (Type(*dp)) {
        !            36: 
        !            37:             case T_Tvsubs:
        !            38:                Inc(ev_n_tsderef);
        !            39:                /*
        !            40:                 * A substring trapped variable is being dereferenced.
        !            41:                 *  Point bp to the trapped variable block and v to
        !            42:                 *  the string.
        !            43:                 */
        !            44:                bp = TvarLoc(*dp);
        !            45:                v = bp->tvsubs.ssvar;
        !            46:                DeRef(v);
        !            47:                if (!Qual(v))
        !            48:                   runerr(103, &v);
        !            49:                if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
        !            50:                   runerr(205, NULL);
        !            51:                /*
        !            52:                 * Make a descriptor for the substring by getting the
        !            53:                 *  length and pointing into the string.
        !            54:                 */
        !            55:                StrLen(*dp) = bp->tvsubs.sslen;
        !            56:                StrLoc(*dp) = StrLoc(v) + bp->tvsubs.sspos - 1;
        !            57:                break;
        !            58: /* <deref3 */
        !            59: 
        !            60: /* >deref4 */
        !            61:             case T_Tvtbl:
        !            62:                Inc(ev_n_ttderef);
        !            63:                if (BlkLoc(*dp)->tvtbl.title == T_Telem) {
        !            64:                   /*
        !            65:                    * The tvtbl has been converted to a telem and is in
        !            66:                    *  the table.  Replace the descriptor pointed to by dp
        !            67:                    *  with the value of the element.
        !            68:                    */
        !            69:                    *dp = BlkLoc(*dp)->telem.tval;
        !            70:                    break;
        !            71:                    }
        !            72: 
        !            73:                /*
        !            74:                 *  Point tbl to the table header block, tref to the
        !            75:                 *  subscripting value, and bp to the appropriate element
        !            76:                 *  chain.  Point dp to a descriptor for the default
        !            77:                 *  value in case the value referenced by the subscript
        !            78:                 *  is not in the table.
        !            79:                 */
        !            80:                tbl = BlkLoc(*dp)->tvtbl.clink;
        !            81:                tref = BlkLoc(*dp)->tvtbl.tref;
        !            82:                i = BlkLoc(*dp)->tvtbl.hashnum;
        !            83:                *dp = BlkLoc(tbl)->table.defvalue;
        !            84:                bp = BlkLoc(BlkLoc(tbl)->table.buckets[SlotNum(i,TSlots)]);
        !            85: 
        !            86:                /*
        !            87:                 * Traverse the element chain looking for the subscript value.
        !            88:                 *  If found, replace the descriptor pointed to by dp with
        !            89:                 *  the value of the element.
        !            90:                 */
        !            91:                while (bp != NULL && bp->telem.hashnum <= i) {
        !            92:                   if ((bp->telem.hashnum == i) &&
        !            93:                      (equiv(&bp->telem.tref, &tref))) {
        !            94:                         *dp = bp->telem.tval;
        !            95:                         break;
        !            96:                         }
        !            97:                   bp = BlkLoc(bp->telem.clink);
        !            98:                   }
        !            99:                break;
        !           100: /* <deref4 */
        !           101: 
        !           102: /* >deref5 */
        !           103:             case T_Tvkywd:
        !           104:                bp = TvarLoc(*dp);
        !           105:                *dp = bp->tvkywd.kyval;
        !           106:                break;
        !           107: /* <deref5 */
        !           108: 
        !           109:             default:
        !           110:                syserr("deref: illegal trapped variable");
        !           111:             }
        !           112:       }
        !           113: #ifdef Debug
        !           114:    if (!Qual(*d) && Var(*d))
        !           115:       syserr("deref: didn't get dereferenced");
        !           116: #endif Debug
        !           117:    return 1;
        !           118:    }
        !           119: /* <deref */
        !           120: 
        !           121: 
        !           122: /*
        !           123:  * hash - compute hash value of arbitrary object for table and set accessing.
        !           124:  */
        !           125: 
        !           126: /* >hash */
        !           127: word hash(dp)
        !           128: struct descrip *dp;
        !           129:    {
        !           130:    word i;
        !           131:    double r;
        !           132:    register word j;
        !           133:    register char *s;
        !           134: 
        !           135:    if (Qual(*dp)) {
        !           136: 
        !           137:       /*
        !           138:        * Compute the hash value for the string by summing the value
        !           139:        *  of all the characters (up to a maximum of 10) plus the length.
        !           140:        */
        !           141:       i = 0;
        !           142:       s = StrLoc(*dp);
        !           143:       j = StrLen(*dp);
        !           144:       for (j = (j <= 10) ? j : 10 ; j > 0; j--)
        !           145:          i += *s++ & 0377;
        !           146:       i += StrLen(*dp) & 0377;
        !           147:       }
        !           148:    else {
        !           149:       switch (Type(*dp)) {
        !           150:          /*
        !           151:           * The hash value for numeric types is the bitstring
        !           152:           *  representation of the value.
        !           153:           */
        !           154: 
        !           155:          case T_Integer:
        !           156:             i = IntVal(*dp);
        !           157:             break;
        !           158: 
        !           159:          case T_Longint:
        !           160:             i = BlkLoc(*dp)->longint.intval;
        !           161:             break;
        !           162: 
        !           163:          case T_Real:
        !           164:             GetReal(dp,r);
        !           165:             i = r;
        !           166:             break;
        !           167: 
        !           168:          case T_Cset:
        !           169:             /*
        !           170:              * Compute the hash value for a cset by exclusive or-ing
        !           171:              *  the words in the bit array.
        !           172:              */
        !           173:             i = 0;
        !           174:             for (j = 0; j < CsetSize; j++)
        !           175:                i ^= BlkLoc(*dp)->cset.bits[j];
        !           176:             break;
        !           177: 
        !           178:          default:
        !           179:             /*
        !           180:              * For other types, use the type code as the hash
        !           181:              *  value.
        !           182:              */
        !           183:             i = Type(*dp);
        !           184:             break;
        !           185:          }
        !           186:       }
        !           187: 
        !           188:    return i;
        !           189:    }
        !           190: /* <hash */
        !           191: 
        !           192: 
        !           193: #define StringLimit    16              /* limit on length of imaged string */
        !           194: #define ListLimit       6              /* limit on list items in image */
        !           195: 
        !           196: /*
        !           197:  * outimage - print image of d on file f.  If restrict is non-zero,
        !           198:  *  fields of records will not be imaged.
        !           199:  */
        !           200: 
        !           201: outimage(f, d, restrict)
        !           202: FILE *f;
        !           203: struct descrip *d;
        !           204: int restrict;
        !           205:    {
        !           206:    register word i, j;
        !           207:    register char *s;
        !           208:    register union block *bp, *vp;
        !           209:    char *type;
        !           210:    FILE *fd;
        !           211:    struct descrip q;
        !           212:    extern char *blkname[];
        !           213:    double rresult;
        !           214: 
        !           215: outimg:
        !           216: 
        !           217:    if (Qual(*d)) {
        !           218:       /*
        !           219:        * *d is a string qualifier.  Print StringLimit characters of it
        !           220:        *  using printimage and denote the presence of additional characters
        !           221:        *  by terminating the string with "...".
        !           222:        */
        !           223:       i = StrLen(*d);
        !           224:       s = StrLoc(*d);
        !           225:       j = Min(i, StringLimit);
        !           226:       putc('"', f);
        !           227:       while (j-- > 0)
        !           228:          printimage(f, *s++, '"');
        !           229:       if (i > StringLimit)
        !           230:          fprintf(f, "...");
        !           231:       putc('"', f);
        !           232:       return;
        !           233:       }
        !           234: 
        !           235:    if (Var(*d) && !Tvar(*d)) {
        !           236:       /*
        !           237:        * *d is a variable.  Print "variable =", dereference it and loop
        !           238:        *  back to the top to cause the value of the variable to be imaged.
        !           239:        */
        !           240:       fprintf(f, "variable = ");
        !           241:       d = VarLoc(*d);
        !           242:       goto outimg;
        !           243:       }
        !           244: 
        !           245:    switch (Type(*d)) {
        !           246: 
        !           247:       case T_Null:
        !           248:          if (restrict == 0)
        !           249:             fprintf(f, "&null");
        !           250:          return;
        !           251: 
        !           252:       case T_Integer:
        !           253:          fprintf(f, "%d", (int)IntVal(*d));
        !           254:          return;
        !           255: 
        !           256:       case T_Longint:
        !           257:          fprintf(f, "%ld", BlkLoc(*d)->longint.intval);
        !           258:          return;
        !           259: 
        !           260:       case T_Real:
        !           261:          {
        !           262:          char s[30];
        !           263:          struct descrip junk;
        !           264:          double rresult;
        !           265: 
        !           266:          GetReal(d,rresult);
        !           267:          rtos(rresult, &junk, s);
        !           268:          fprintf(f, "%s", s);
        !           269:          return;
        !           270:          }
        !           271: 
        !           272:       case T_Cset:
        !           273:          /*
        !           274:           * Check for distinguished csets by looking at the address of
        !           275:           *  of the object to image.  If one is found, print its name.
        !           276:           */
        !           277:          if (BlkLoc(*d) == (union block *) &k_ascii) {
        !           278:             fprintf(f, "&ascii");
        !           279:             return;
        !           280:             }
        !           281:          else if (BlkLoc(*d) == (union block *) &k_cset) {
        !           282:             fprintf(f, "&cset");
        !           283:             return;
        !           284:             }
        !           285:          else if (BlkLoc(*d) == (union block *) &k_lcase) {
        !           286:             fprintf(f, "&lcase");
        !           287:             return;
        !           288:             }
        !           289:          else if (BlkLoc(*d) == (union block *) &k_ucase) {
        !           290:             fprintf(f, "&ucase");
        !           291:             return;
        !           292:             }
        !           293:          /*
        !           294:           * Use printimage to print each character in the cset.  Follow
        !           295:           *  with "..." if the cset contains more than StringLimit
        !           296:           *  characters.
        !           297:           */
        !           298:          putc('\'', f);
        !           299:          j = StringLimit;
        !           300:          for (i = 0; i < 256; i++) {
        !           301:             if (Testb(i, BlkLoc(*d)->cset.bits)) {
        !           302:                if (j-- <= 0) {
        !           303:                   fprintf(f, "...");
        !           304:                   break;
        !           305:                   }
        !           306:                printimage(f, (int)i, '\'');
        !           307:                }
        !           308:             }
        !           309:          putc('\'', f);
        !           310:          return;
        !           311: 
        !           312:       case T_File:
        !           313:          /*
        !           314:           * Check for distinguished files by looking at the address of
        !           315:           *  of the object to image.  If one is found, print its name.
        !           316:           */
        !           317:          if ((fd = BlkLoc(*d)->file.fd) == stdin)
        !           318:             fprintf(f, "&input");
        !           319:          else if (fd == stdout)
        !           320:             fprintf(f, "&output");
        !           321:          else if (fd == stderr)
        !           322:             fprintf(f, "&output");
        !           323:          else {
        !           324:             /*
        !           325:              * The file isn't a special one, just print "file(name)".
        !           326:              */
        !           327:             i = StrLen(BlkLoc(*d)->file.fname);
        !           328:             s = StrLoc(BlkLoc(*d)->file.fname);
        !           329:             fprintf(f, "file(");
        !           330:             while (i-- > 0)
        !           331:                printimage(f, *s++, '\0');
        !           332:             putc(')', f);
        !           333:             }
        !           334:          return;
        !           335: 
        !           336:       case T_Proc:
        !           337:          /*
        !           338:           * Produce one of:
        !           339:           *  "procedure name"
        !           340:           *  "function name"
        !           341:           *  "record constructor name"
        !           342:           *
        !           343:           * Note that the number of dynamic locals is used to determine
        !           344:           *  what type of "procedure" is at hand.
        !           345:           */
        !           346:          i = StrLen(BlkLoc(*d)->proc.pname);
        !           347:          s = StrLoc(BlkLoc(*d)->proc.pname);
        !           348:          switch (BlkLoc(*d)->proc.ndynam) {
        !           349:             default:  type = "procedure"; break;
        !           350:             case -1:  type = "function"; break;
        !           351:             case -2:  type = "record constructor"; break;
        !           352:             }
        !           353:          fprintf(f, "%s ", type);
        !           354:          while (i-- > 0)
        !           355:             printimage(f, *s++, '\0');
        !           356:          return;
        !           357: 
        !           358:       case T_List:
        !           359:          /*
        !           360:           * listimage does the work for lists.
        !           361:           */
        !           362:          listimage(f, (struct b_list *)BlkLoc(*d), restrict);
        !           363:          return;
        !           364: 
        !           365:       case T_Table:
        !           366:          /*
        !           367:           * Print "table(n)" where n is the size of the table.
        !           368:           */
        !           369:          fprintf(f, "table(%ld)", (long)BlkLoc(*d)->table.size);
        !           370:          return;
        !           371:       case T_Set:
        !           372:        /*
        !           373:          * print "set(n)" where n is the cardinality of the set
        !           374:          */
        !           375:        fprintf(f,"set(%ld)",(long)BlkLoc(*d)->set.size);
        !           376:        return;
        !           377: 
        !           378:       case T_Record:
        !           379:          /*
        !           380:           * If restrict is non-zero, print "record(n)" where n is the
        !           381:           *  number of fields in the record.  If restrict is zero, print
        !           382:           *  the image of each field instead of the number of fields.
        !           383:           */
        !           384:          bp = BlkLoc(*d);
        !           385:          i = StrLen(BlkLoc(bp->record.recdesc)->proc.recname);
        !           386:          s = StrLoc(BlkLoc(bp->record.recdesc)->proc.recname);
        !           387:          fprintf(f, "record ");
        !           388:          while (i-- > 0)
        !           389:             printimage(f, *s++, '\0');
        !           390:          j = BlkLoc(bp->record.recdesc)->proc.nfields;
        !           391:          if (j <= 0)
        !           392:             fprintf(f, "()");
        !           393:          else if (restrict > 0)
        !           394:             fprintf(f, "(%ld)", (long)j);
        !           395:          else {
        !           396:             putc('(', f);
        !           397:             i = 0;
        !           398:             for (;;) {
        !           399:                outimage(f, &bp->record.fields[i], restrict+1);
        !           400:                if (++i >= j)
        !           401:                   break;
        !           402:                putc(',', f);
        !           403:                }
        !           404:             putc(')', f);
        !           405:             }
        !           406:          return;
        !           407: 
        !           408:       case T_Tvsubs:
        !           409:          /*
        !           410:           * Produce "v[i+:j] = value" where v is the image of the variable
        !           411:           *  containing the substring, i is starting position of the substring
        !           412:           *  j is the length, and value is the string v[i+:j]. If the length
        !           413:           *  (j) is one, just produce "v[i] = value".
        !           414:           */
        !           415:          bp = BlkLoc(*d);
        !           416:          d = VarLoc(bp->tvsubs.ssvar);
        !           417:          if ((word)d == (word)&tvky_sub)
        !           418:             fprintf(f, "&subject");
        !           419:          else outimage(f, d, restrict);
        !           420:          if (bp->tvsubs.sslen == 1)
        !           421:             fprintf(f, "[%ld]", (long)bp->tvsubs.sspos);
        !           422:          else
        !           423:             fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos, (long)bp->tvsubs.sslen);
        !           424:          if ((word)d == (word)&tvky_sub) {
        !           425:             fprintf(f, " = ");
        !           426:             vp = BlkLoc(bp->tvsubs.ssvar);
        !           427:             StrLen(q) = bp->tvsubs.sslen;
        !           428:             StrLoc(q) = StrLoc(vp->tvkywd.kyval) + bp->tvsubs.sspos-1;
        !           429:             d = &q;
        !           430:             goto outimg;
        !           431:             }
        !           432:          else if (Qual(*d)) {
        !           433:             StrLen(q) = bp->tvsubs.sslen;
        !           434:             StrLoc(q) = StrLoc(*VarLoc(bp->tvsubs.ssvar)) + bp->tvsubs.sspos-1;
        !           435:             fprintf(f, " = ");
        !           436:             d = &q;
        !           437:             goto outimg;
        !           438:             }
        !           439:          return;
        !           440: 
        !           441:       case T_Tvtbl:
        !           442:          bp = BlkLoc(*d);
        !           443:          /*
        !           444:           * It is possible that descriptor d which thinks it is pointing
        !           445:           *  at a TVTBL may actually be pointing at a TELEM which had
        !           446:           *  been converted from a trapped variable. Check for this first
        !           447:           *  and if it is a TELEM produce the outimage of its value.
        !           448:           */
        !           449:          if (bp->tvtbl.title == T_Telem) {
        !           450:             outimage(f, &bp->tvtbl.tval, restrict);
        !           451:             return;
        !           452:             }
        !           453:          /*
        !           454:           * It really was a TVTBL - Produce "t[s]" where t is the image of
        !           455:           *  the table containing the element and s is the image of the
        !           456:           *  subscript.
        !           457:           */
        !           458:          else {
        !           459:             outimage(f, &bp->tvtbl.clink, restrict);
        !           460:             putc('[', f);
        !           461:             outimage(f, &bp->tvtbl.tref, restrict);
        !           462:             putc(']', f);
        !           463:             return;
        !           464:             }
        !           465: 
        !           466:       case T_Tvkywd:
        !           467:          bp = BlkLoc(*d);
        !           468:          i = StrLen(bp->tvkywd.kyname);
        !           469:          s = StrLoc(bp->tvkywd.kyname);
        !           470:          while (i-- > 0)
        !           471:             putc(*s++, f);
        !           472:          fprintf(f, " = ");
        !           473:          outimage(f, &bp->tvkywd.kyval, restrict);
        !           474:          return;
        !           475: 
        !           476: 
        !           477:       case T_Coexpr:
        !           478:          fprintf(f, "co-expression");
        !           479:          return;
        !           480: 
        !           481:       default:
        !           482:          if (Type(*d) <= MaxType)
        !           483:             fprintf(f, "%s", blkname[Type(*d)]);
        !           484:          else
        !           485:             syserr("outimage: unknown type");
        !           486:       }
        !           487:    }
        !           488: 
        !           489: /*
        !           490:  * printimage - print character c on file f using escape conventions
        !           491:  *  if c is unprintable, '\', or equal to q.
        !           492:  */
        !           493: 
        !           494: static printimage(f, c, q)
        !           495: FILE *f;
        !           496: int c, q;
        !           497:    {
        !           498:    if (c >= ' ' && c < '\177') {
        !           499:       /*
        !           500:        * c is printable, but special case ", ', and \.
        !           501:        */
        !           502:       switch (c) {
        !           503:          case '"':
        !           504:             if (c != q) goto def;
        !           505:             fprintf(f, "\\\"");
        !           506:             return;
        !           507:          case '\'':
        !           508:             if (c != q) goto def;
        !           509:             fprintf(f, "\\'");
        !           510:             return;
        !           511:          case '\\':
        !           512:             fprintf(f, "\\\\");
        !           513:             return;
        !           514:          default:
        !           515:          def:
        !           516:             putc(c, f);
        !           517:             return;
        !           518:          }
        !           519:       }
        !           520: 
        !           521:    /*
        !           522:     * c is some sort of unprintable character. If it one of the common
        !           523:     *  ones, produce a special representation for it, otherwise, produce
        !           524:     *  its octal value.
        !           525:     */
        !           526:    switch (c) {
        !           527:       case '\b':                        /* backspace */
        !           528:          fprintf(f, "\\b");
        !           529:          return;
        !           530:       case '\177':                        /* delete */
        !           531:          fprintf(f, "\\d");
        !           532:          return;
        !           533:       case '\33':                        /* escape */
        !           534:          fprintf(f, "\\e");
        !           535:          return;
        !           536:       case '\f':                        /* form feed */
        !           537:          fprintf(f, "\\f");
        !           538:          return;
        !           539:       case '\n':                        /* new line */
        !           540:          fprintf(f, "\\n");
        !           541:          return;
        !           542:       case '\r':                        /* return */
        !           543:          fprintf(f, "\\r");
        !           544:          return;
        !           545:       case '\t':                        /* horizontal tab */
        !           546:          fprintf(f, "\\t");
        !           547:          return;
        !           548:       case '\13':                        /* vertical tab */
        !           549:          fprintf(f, "\\v");
        !           550:          return;
        !           551:       default:                               /* octal constant */
        !           552:          fprintf(f, "\\%03o", c&0377);
        !           553:          return;
        !           554:       }
        !           555:    }
        !           556: 
        !           557: /*
        !           558:  * listimage - print an image of a list.
        !           559:  */
        !           560: 
        !           561: static listimage(f, lp, restrict)
        !           562: FILE *f;
        !           563: struct b_list *lp;
        !           564: int restrict;
        !           565:    {
        !           566:    register word i, j;
        !           567:    register struct b_lelem *bp;
        !           568:    word size, count;
        !           569: 
        !           570:    bp = (struct b_lelem *) BlkLoc(lp->listhead);
        !           571:    size = lp->size;
        !           572: 
        !           573:    if (restrict > 0 && size > 0) {
        !           574:       /*
        !           575:        * Just give indication of size if the list isn't empty.
        !           576:        */
        !           577:       fprintf(f, "list(%ld)", (long)size);
        !           578:       return;
        !           579:       }
        !           580: 
        !           581:    /*
        !           582:     * Print [e1,...,en] on f.  If more than ListLimit elements are in the
        !           583:     *  list, produce the first ListLimit/2 elements, an ellipsis, and the
        !           584:     *  last ListLimit elements.
        !           585:     */
        !           586:    putc('[', f);
        !           587:    count = 1;
        !           588:    i = 0;
        !           589:    if (size > 0) {
        !           590:       for (;;) {
        !           591:          if (++i > bp->nused) {
        !           592:             i = 1;
        !           593:             bp = (struct b_lelem *) BlkLoc(bp->listnext);
        !           594:             }
        !           595:          if (count <= ListLimit/2 || count > size - ListLimit/2) {
        !           596:             j = bp->first + i - 1;
        !           597:             if (j >= bp->nelem)
        !           598:                j -= bp->nelem;
        !           599:             outimage(f, &bp->lslots[j], restrict+1);
        !           600:             if (count >= size)
        !           601:                break;
        !           602:             putc(',', f);
        !           603:             }
        !           604:          else if (count == ListLimit/2 + 1)
        !           605:             fprintf(f, "...,");
        !           606:          count++;
        !           607:          }
        !           608:       }
        !           609:    putc(']', f);
        !           610:    }
        !           611: 
        !           612: 
        !           613: /*
        !           614:  * qtos - convert a qualified string named by *d to a C-style string in
        !           615:  *  in str.  At most MaxCvtLen characters are copied into str.
        !           616:  */
        !           617: 
        !           618: qtos(d, str)
        !           619: struct descrip *d;
        !           620: char *str;
        !           621:    {
        !           622:    register word cnt, slen;
        !           623:    register char *c;
        !           624: 
        !           625:    c = StrLoc(*d);
        !           626:    slen = StrLen(*d);
        !           627:    for (cnt = Min(slen, MaxCvtLen - 1); cnt > 0; cnt--)
        !           628:       *str++ = *c++;
        !           629:    *str = '\0';
        !           630:    }
        !           631: 
        !           632: 
        !           633: /*
        !           634:  * ctrace - procedure *bp is being called with nargs arguments, the first
        !           635:  *  of which is at arg; produce a trace message.
        !           636:  */
        !           637: ctrace(bp, nargs, arg)
        !           638: struct b_proc *bp;
        !           639: int nargs;
        !           640: struct descrip *arg;
        !           641:    {
        !           642:    register int n;
        !           643: 
        !           644:    if (k_trace > 0)
        !           645:       k_trace--;
        !           646:    showline(bp->filename, line);
        !           647:    showlevel(k_level);
        !           648:    putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
        !           649:    putc('(', stderr);
        !           650:    while (nargs--) {
        !           651:       outimage(stderr, arg++, 0);
        !           652:       if (nargs)
        !           653:          putc(',', stderr);
        !           654:       }
        !           655:    putc(')', stderr);
        !           656:    putc('\n', stderr);
        !           657:    fflush(stderr);
        !           658:    }
        !           659: 
        !           660: /*
        !           661:  * rtrace - procedure *bp is returning *rval; produce a trace message.
        !           662:  */
        !           663: 
        !           664: rtrace(bp, rval)
        !           665: register struct b_proc *bp;
        !           666: struct descrip *rval;
        !           667:    {
        !           668:    register int n;
        !           669: 
        !           670:    if (k_trace > 0)
        !           671:       k_trace--;
        !           672:    showline(bp->filename, line);
        !           673:    showlevel(k_level);
        !           674:    putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
        !           675:    fprintf(stderr, " returned ");
        !           676:    outimage(stderr, rval, 0);
        !           677:    putc('\n', stderr);
        !           678:    fflush(stderr);
        !           679:    }
        !           680: 
        !           681: /*
        !           682:  * ftrace - procedure *bp is failing; produce a trace message.
        !           683:  */
        !           684: 
        !           685: ftrace(bp)
        !           686: register struct b_proc *bp;
        !           687:    {
        !           688:    register int n;
        !           689: 
        !           690:    if (k_trace > 0)
        !           691:       k_trace--;
        !           692:    showline(bp->filename, line);
        !           693:    showlevel(k_level);
        !           694:    putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
        !           695:    fprintf(stderr, " failed");
        !           696:    putc('\n', stderr);
        !           697:    fflush(stderr);
        !           698:    }
        !           699: 
        !           700: /*
        !           701:  * strace - procedure *bp is suspending *rval; produce a trace message.
        !           702:  */
        !           703: 
        !           704: strace(bp, rval)
        !           705: register struct b_proc *bp;
        !           706: struct descrip *rval;
        !           707:    {
        !           708:    register int n;
        !           709: 
        !           710:    if (k_trace > 0)
        !           711:       k_trace--;
        !           712:    showline(bp->filename, line);
        !           713:    showlevel(k_level);
        !           714:    putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
        !           715:    fprintf(stderr, " suspended ");
        !           716:    outimage(stderr, rval, 0);
        !           717:    putc('\n', stderr);
        !           718:    fflush(stderr);
        !           719:    }
        !           720: 
        !           721: /*
        !           722:  * atrace - procedure *bp is being resumed; produce a trace message.
        !           723:  */
        !           724: 
        !           725: atrace(bp)
        !           726: register struct b_proc *bp;
        !           727:    {
        !           728:    register int n;
        !           729: 
        !           730:    if (k_trace > 0)
        !           731:       k_trace--;
        !           732:    showline(bp->filename, line);
        !           733:    showlevel(k_level);
        !           734:    putstr(stderr, StrLoc(bp->pname), StrLen(bp->pname));
        !           735:    fprintf(stderr, " resumed");
        !           736:    putc('\n', stderr);
        !           737:    fflush(stderr);
        !           738:    }
        !           739: 
        !           740: /*
        !           741:  * showline - print file and line number information.
        !           742:  */
        !           743: static showline(f, l)
        !           744: char *f;
        !           745: int l;
        !           746:    {
        !           747:    if (l > 0)
        !           748:       fprintf(stderr, "%.10s: %d\t", f, l);
        !           749:    else
        !           750:       fprintf(stderr, "\t\t");
        !           751:    }
        !           752: 
        !           753: /*
        !           754:  * showlevel - print "| " n times.
        !           755:  */
        !           756: static showlevel(n)
        !           757: register int n;
        !           758:    {
        !           759:    while (n-- > 0) {
        !           760:       putc('|', stderr);
        !           761:       putc(' ', stderr);
        !           762:       }
        !           763:    }
        !           764: 
        !           765: 
        !           766: /*
        !           767:  * putpos - assign value to &pos
        !           768:  */
        !           769: 
        !           770: putpos(d1)
        !           771: struct descrip *d1;
        !           772:    {
        !           773:    register word l1;
        !           774:    long l2;
        !           775:    switch (cvint(d1, &l2)) {
        !           776: 
        !           777:       case T_Integer:
        !           778:          break;
        !           779: 
        !           780:       case T_Longint:
        !           781:          return NULL;
        !           782: 
        !           783:       default: runerr(101, d1);
        !           784:       }
        !           785: 
        !           786:    l1 = cvpos(l2, StrLen(k_subject));
        !           787:    if (l1 == 0)
        !           788:       return NULL;
        !           789:    k_pos = l1;
        !           790:    return 1;
        !           791:    }
        !           792: 
        !           793: 
        !           794: /*
        !           795:  * putran - assign value to &random
        !           796:  */
        !           797: 
        !           798: putran(d1)
        !           799: struct descrip *d1;
        !           800:    {
        !           801:    long l1;
        !           802:    switch (cvint(d1, &l1)) {
        !           803: 
        !           804:       case T_Integer:
        !           805:       case T_Longint:
        !           806:          break;
        !           807: 
        !           808:       default: runerr(101, d1);
        !           809:       }
        !           810: 
        !           811:    k_random = l1;
        !           812:    return 1;
        !           813:    }
        !           814: 
        !           815: 
        !           816: /*
        !           817:  * putsub - assign value to &subject
        !           818:  */
        !           819: 
        !           820: /* >putsub */
        !           821: putsub(dp)
        !           822: struct descrip *dp;
        !           823:    {
        !           824:    char sbuf[MaxCvtLen];
        !           825:    extern char *alcstr();
        !           826: 
        !           827:    switch (cvstr(dp, sbuf)) {
        !           828: 
        !           829:       case NULL:
        !           830:          runerr(103, dp);
        !           831: 
        !           832:       case Cvt:
        !           833:          strreq(StrLen(*dp));
        !           834:          StrLoc(*dp) = alcstr(StrLoc(*dp), StrLen(*dp));
        !           835: 
        !           836:       case NoCvt:
        !           837:          k_subject = *dp;
        !           838:          k_pos = 1;
        !           839:       }
        !           840: 
        !           841:    return 1;
        !           842:    }
        !           843: /* <putsub */
        !           844: 
        !           845: 
        !           846: /*
        !           847:  * puttrc - assign value to &trace
        !           848:  */
        !           849: 
        !           850: puttrc(d1)
        !           851: struct descrip *d1;
        !           852:    {
        !           853:    long l1;
        !           854:    switch (cvint(d1, &l1)) {
        !           855: 
        !           856:       case T_Integer:
        !           857:          k_trace = (int)l1;
        !           858:          break;
        !           859: 
        !           860:       case T_Longint:
        !           861:          k_trace = -1;
        !           862:          break;
        !           863: 
        !           864:       default: runerr(101, d1);
        !           865:       }
        !           866: 
        !           867:    return 1;
        !           868:    }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.