2.11BSD#431 - /usr/src/new/PORT/apl/src/a2.c

   1: static char Sccsid[] = "a2.c @(#)a2.c	1.1	10/1/82 Berkeley ";
   2: #include "apl.h"
   3: #include "aplmap.h"
   4: 
   5: int chartab[];
   6: char *ecvt();
   7: 
   8: ex_print()
   9: {
  10: 
  11:     if(epr0())
  12:         putchar('\n');
  13: }
  14: 
  15: ex_hprint()
  16: {
  17: 
  18:     epr0();
  19:     pop();
  20: }
  21: 
  22: epr0()
  23: {
  24:     register struct item *p;
  25:     register data *dp;
  26:     register i;
  27:     int j;
  28:     int param[4];
  29: 
  30:     p = fetch1();
  31:     if(p->type == DU)
  32:         return(0);
  33:     if(p->size == 0)
  34:         return(1);
  35:     if(p->type == DA) {
  36: 
  37:         /* Use "epr1()" to figure out the maximum field width
  38: 		 * required by any of the values to be printed.
  39: 		 */
  40: 
  41:         for(i=0; i<4; i++)
  42:             param[i] = 0;
  43:         dp = p->datap;
  44:         for(i=0; i<p->size; i++)
  45:             epr1(*dp++, param);
  46:         i = param[1] + param[2]; /* size if fp */
  47:         if(i > thread.digits)
  48:             i += 100;               /* set "e" format flag */
  49:         if(param[2])
  50:             i++;
  51:         if(i > param[0]+5) {
  52:             i = param[0] + 5; /* size if ep */
  53:             param[1] = param[0];
  54:             param[2] = -1;
  55:         }
  56:         if(param[3])
  57:             i++;    /* sign */
  58:         i++;        /* leading space */
  59:         param[0] = i;
  60:         dp = p->datap;
  61:     }
  62:     bidx(p);
  63:     for(i=1; i<p->size; i++) {
  64:         if(intflg)
  65:             break;
  66:         if(p->type == CH) {
  67:             j = getdat(p);
  68:             putchar(j);
  69:         } else
  70:             epr2(*dp++, param);
  71:         for(j=p->rank-2; j>=0; j--)
  72:             if(i%idx.del[j] == 0)
  73:                 putchar('\n');  /* end of dimension reached */
  74:     }
  75:     if(p->type == CH) {
  76:         j = getdat(p);
  77:         putchar(j);
  78:     } else
  79:         epr2(*dp, param);
  80:     return(1);
  81: }
  82: 
  83: epr1(d, param)
  84: data d;
  85: int *param;
  86: {
  87:     double f;
  88:     register a;
  89:     register char *c;
  90:     int dp, sg;
  91: 
  92: 
  93:     /* This routine figures out the field with required by the value
  94: 	 * "d".  It adjusts the four elements of "param" so that they
  95: 	 * contain the maximum of their old values or the requirements for
  96: 	 * the current data item.
  97: 	 *
  98: 	 * param[0] = number of significant digits
  99: 	 * param[1] = number of digits to left of decimal point
 100: 	 * param[2] = number of digits to right of decimal point
 101: 	 * param[3] = 0 if positive, 1 if negative
 102: 	 */
 103: 
 104:     f = d;
 105:     c = ecvt(f, thread.digits, &dp, &sg);
 106:     if (f == zero)                  /* kludge due to change in ecvt */
 107:         dp = 1;
 108:     a = thread.digits;
 109:     while(c[a-1]=='0' && a>1)
 110:         a--;
 111:     if(a > param[0])        /* sig digits */
 112:         param[0] = a;
 113:     a -= dp;
 114:     if(a < 0)
 115:         a = 0;
 116:     if(a > param[2])        /* digits to right of dp */
 117:         param[2] = a;
 118:     if(dp > param[1])       /* digits to left of dp */
 119:         param[1] = dp;
 120:     param[3] |= sg;     /* and sign */
 121: }
 122: 
 123: epr2(d, param)
 124: int *param;
 125: data d;
 126: {
 127:     register i;
 128:     register char *c, *mc;
 129:     double f;
 130:     int dp, sg;
 131: 
 132:     if(param[0]+column > thread.width && !mencflg) {
 133:         putchar('\n');
 134:         putto(param[0]);
 135:     }
 136:     f = d;
 137:     c = ecvt(f, thread.digits, &dp, &sg);
 138:     if (f == zero)
 139:         dp = 1;                 /* kludge due to change in ecvt */
 140:     mc = c + thread.digits;
 141:     putchar(' ');
 142:     sg = sg? '-': ' ';  /* '-' used to be '"' */
 143:     if(param[2] < 0) {
 144:         if(param[3])
 145:             putchar(sg);
 146:         for(i=0; i<param[1]; i++) {
 147:             putchar(*c++);
 148:             if(i == 0)
 149:                 putchar('.');
 150:         }
 151:         putchar('e');
 152:         dp--;
 153:         if(dp < 0) {
 154:             putchar('-');   /* '=' used to be '"' */
 155:             dp = -dp;
 156:         } else
 157:             putchar('+'); /* apl style plus sign, used to be ':' */
 158:         putchar(dp/10 + '0');
 159:         putchar(dp%10 + '0');
 160:         return;
 161:     }
 162:     i = dp;
 163:     if(i < 0)
 164:         i = 0;
 165:     for(; i<param[1]; i++)
 166:         putchar(' ');
 167:     if(param[3])
 168:         putchar(sg);
 169:     for(i=0; i<dp; i++)
 170:         if(c >= mc)
 171:             putchar('0'); else
 172:             putchar(*c++);
 173:     for(i=0; i<param[2]; i++) {
 174:         if(i == 0)
 175:             putchar('.');
 176:         if(dp < 0) {
 177:             putchar('0');
 178:             dp++;
 179:         } else
 180:         if(c >= mc)
 181:             putchar('0'); else
 182:             putchar(*c++);
 183:     }
 184: }
 185: 
 186: error(s)
 187: char *s;
 188: {
 189:     register c;
 190:     register char *cp, *cs;
 191: 
 192:     intflg = 0;
 193:     if(ifile) {
 194:         CLOSEF(ifile);
 195:         ifile = 0;
 196:     }
 197:     cp = s;
 198:     while(c = *cp++) {
 199:         if(c >= 'A' && c <= 'Z') {
 200:             switch(c) {
 201: 
 202:             case 'I':
 203:                 cs = "\ninterrupt";
 204:                 break;
 205: 
 206:             case 'L':
 207:                 cs = "L";
 208:                 break;
 209: 
 210:             case 'C':
 211:                 cs = "conformability";
 212:                 break;
 213: 
 214:             case 'S':
 215:                 cs = "syntax";
 216:                 break;
 217: 
 218:             case 'R':
 219:                 cs = "rank";
 220:                 break;
 221: 
 222:             case 'X':
 223:                 cs = "index";
 224:                 break;
 225: 
 226:             case 'Y':
 227:                 cs = "character";
 228:                 break;
 229: 
 230:             case 'M':
 231:                 cs = "memory";
 232:                 break;
 233: 
 234:             case 'D':
 235:                 cs = "domain";
 236:                 break;
 237: 
 238:             case 'T':
 239:                 cs = "type";
 240:                 break;
 241: 
 242:             case 'E':
 243:                 cs = "error";
 244:                 break;
 245: 
 246:             case 'P':
 247:                 cs = "programmer";
 248:                 break;
 249: 
 250:             case 'B':
 251:                 cs = "botch";
 252:                 break;
 253: 
 254:             default:
 255:                 putchar(c);
 256:                 continue;
 257:             }
 258:             printf(cs);
 259:             continue;
 260:         }
 261:         putchar(c);
 262:     }
 263:     putchar('\n');
 264:     if (prwsflg) exit(0);       /* if "prws", just exit */
 265:     /*
 266: 	 * produce traceback and mark state indicator.
 267: 	 */
 268:     tback(0);
 269:     if(gsip)
 270:         gsip->suspended = 1;
 271:     else {
 272:         while(sp > stack)
 273:             pop();      /* zap garbage */
 274:         reset();
 275:     }
 276:     mainloop();         /* reenter mainloop */
 277: }
 278: 
 279: printf(f, a)
 280: char *f;
 281: {
 282:     register char *s, *cp;
 283:     register *p;
 284: 
 285:     s = f;
 286:     p = &a;
 287:     while(*s) {
 288:         if(s[0] == '%')
 289:             switch(s[1]){
 290:             case 'd':
 291:                 putn(*p++);
 292:                 s += 2;
 293:                 continue;
 294:             case 'o':
 295:                 puto(*p++);
 296:                 s += 2;
 297:                 continue;
 298:             case 's':
 299:                 cp = (char *)*p++;
 300:                 s += 2;
 301:                 while(*cp)
 302:                     putchar(*cp++);
 303:                 continue;
 304:             case 'f':
 305:                 putf(p);
 306:                 p += 4; /* 4 words per floating arg */
 307:                 s += 2;
 308:                 continue;
 309:             }
 310:         putchar(*s++);
 311:     }
 312: }
 313: 
 314: putn(n)
 315: {
 316:     register a;
 317: 
 318:     if(n < 0) {
 319:         n = -n;
 320:         if(n < 0) {
 321:             printf("32768");
 322:             return;
 323:         }
 324:         putchar('-');   /* apl minus sign, was '"' */
 325:     }
 326:     if(a=n/10)
 327:         putn(a);
 328:     putchar(n%10 + '0');
 329: }
 330: 
 331: putf(p)
 332: data *p;
 333: {
 334:     int param[4];
 335:     register int i;
 336: 
 337:     param[1] = param[2] = param[3] = param[0] = 0;
 338:     epr1(*p, param);
 339:     i = param[1] + param[2]; /* size if fp */
 340:     if(i > thread.digits)
 341:         i += 100;
 342:     if(param[2])
 343:         i++;
 344:     if(i > param[0]+5) {
 345:         i = param[0] + 5; /* size if ep */
 346:         param[1] = param[0];
 347:         param[2] = -1;
 348:     }
 349:     if(param[3])
 350:         i++;    /* sign */
 351:     i++;        /* leading space */
 352:     param[0] = i;
 353:     epr2(*p, param);
 354: /*
 355:  *	register i,j;
 356:  *
 357:  *	i = *p;
 358:  *	j = (*p * 1000.0) - (i * 1000.0);
 359:  *	putn(i);
 360:  *	putchar('.');
 361:  *	putchar('0' + j/100);
 362:  *	putchar('0' + (j/10)%10);
 363:  *	putchar('0' + j%10);
 364:  */
 365: }
 366: 
 367: puto(n)
 368: {
 369:     if(n&0177770)
 370:         puto( (n>>3) & 017777);
 371:     putchar( '0' + (n&07));
 372: }
 373: 
 374: getchar()
 375: {
 376:     int c;
 377: 
 378:     c = 0;
 379:     if(READF(ifile, &c, 1) == 1 && echoflg == 1 && !ifile)
 380:             WRITEF(1, &c, 1);
 381: 
 382:     /* The following code converts the input character
 383: 	 * to the ASCII equivalent (internal format) if
 384: 	 * terminal character mapping is in force.
 385: 	 */
 386: 
 387:     if (apl_term && c >= 041 && !ifile) c = map_ascii[(c&0177)-041];
 388:     if (c && protofile && ifile == 0) WRITEF(protofile, &c, 1);
 389: 
 390:     return(c);
 391: }
 392: 
 393: putchar(c)
 394: {
 395:     register i;
 396: 
 397: 
 398:     /* This is the basic character output routine.  If "mencflg"
 399: 	 * is zero, output is performed on file descriptor 1.  If
 400: 	 * "menclfg" is non-zero, output is placed into the buffer
 401: 	 * pointed to by "mencptr".
 402: 	 */
 403: 
 404:     if(mencflg) {                   /* Format operator */
 405:         if(c != '\n') {
 406:             mencflg = 1;
 407:             *mencptr++ = c;
 408:         }
 409:         else
 410:             if(mencflg > 1)
 411:                 mencptr += rowsz;
 412:             else
 413:                 mencflg = 2;
 414:         return;
 415:     }
 416: 
 417: 
 418:     switch(c){                      /* Normal output */
 419: 
 420:     case '\0':
 421:         return;
 422: 
 423:     case '\b':
 424:         if(column)
 425:             column--;
 426:         break;
 427: 
 428:     case '\t':
 429:         column = (column+8) & ~7;
 430:         break;
 431: 
 432:     case '\r':
 433:     case '\n':
 434:         column = 0;
 435:         break;
 436: 
 437:     default:
 438:         column++;
 439:     }
 440: 
 441:     if (column > thread.width) printf("\n    ");    /* adjust for width */
 442: 
 443:     if(intflg == 0) {
 444:         if(c & 0200) {
 445:             i = chartab[c & 0177];
 446:             putchar(i>>8);
 447:             c = i & 0177;
 448:             putchar('\b');
 449:         }
 450: 
 451:         if(protofile)
 452:             WRITEF(protofile, &c, 1);
 453: 
 454: 
 455:         /* The following code converts the internal value
 456: 		 * to the APL character for modified terminals
 457: 		 * if the APL conversion was requested.
 458: 		 */
 459: 
 460:         if (apl_term && c >= 041)
 461:             c = map_apl[c-041];
 462: #ifdef PURDUE_EE
 463:         if (apl_term && c == 010)
 464:             c = '^';
 465: #endif
 466: 
 467:         WRITEF(1, &c, 1);
 468: #ifdef NBUF
 469:         if (c == '\n' && !prwsflg)
 470:             newbuf(files[1].fd_buf, 1);
 471: #endif
 472:     }
 473: }
 474: 
 475: char *ty[] = {
 476: 0,"DA","CH","LV","QD","QQ","IN","EL","NF","MF","DF","QC","QV","DU","QX","LB"
 477: };
 478: 
 479: dstack()
 480: {
 481:     register struct item **p;
 482:     register i,n;
 483: 
 484:     p = sp;
 485:     n = 0;
 486:     while(--p > stack){
 487:         printf("\t%o:  sp[%d]:   type = ", p, --n);
 488:         if((i=(*p)->type) >= 0 && i <= LBL && ty[i])
 489:             printf(ty[i]);
 490:         else
 491:             printf("%d", (*p)->type);
 492:         switch(i){
 493:         default:
 494:             putchar('\n');
 495:             break;
 496:         case LV:
 497:             printf(",  n = %s\n", ((struct nlist *)*p)->namep);
 498:             break;
 499: 
 500:         case CH:
 501:             if((*p)->size == 0)
 502:                 goto nullone;
 503:             if((*p)->rank == 1){
 504:                 printf(",  \"");
 505:                 for(i=0; i<(*p)->size; i++)
 506:                     putchar(((struct chrstrct *)(*p)->datap)->c[i]);
 507:                 printf("\"\n");
 508:             } else
 509:                 goto rnk;
 510:             break;
 511: 
 512:         case DA:
 513:         case LBL:
 514:             if((*p)->size == 0)
 515:                 goto nullone;
 516:             if((*p)->rank == 0){
 517:                 printf(",  v = %f\n", (*p)->datap[0]);
 518:             }
 519:             break;
 520:         rnk:
 521:             printf(",  rank = %d\n", (*p)->rank);
 522:             break;
 523: 
 524:         nullone:
 525:             printf(",  <null>\n");
 526:             break;
 527:         }
 528:     }
 529:     putchar('\n');
 530: }

Defined functions

Defined variables