2.11BSD#431 - /usr/src/new/OLD/apl/src/al.c

   1: static char Sccsid[] = "al.c @(#)al.c	1.1	10/1/82 Berkeley ";
   2: #
   3: /*
   4:  *	monadic epsilon and encode /rww
   5:  */
   6: #include "apl.h"
   7: #include <signal.h>
   8: 
   9: ex_meps()
  10: {
  11:         struct item *p;
  12:         register i,j;
  13:         char *a,*b,*c;
  14:         int dim0,dim1;
  15:     char *xpcp;
  16: 
  17:     p = fetch1();
  18:     if ( p->rank > 2 || p->type != CH )
  19:         error("execute C");
  20:     /*get out if nothing to do, apr 2-23-77 */
  21:     if (p->size == 0){
  22:         return;
  23:     }
  24:     b = (char *)p->datap;
  25:     dim0 = p->rank < 2 ? 1       : p->dim[0];
  26:     dim1 = p->rank < 2 ? p->size : p->dim[1];
  27:     a = alloc ( dim1+1 );
  28:     xpcp = pcp;
  29:     for ( i=0; i<dim0 ; i++) {
  30:         copy(CH, b, a, dim1);
  31:         a[dim1] = '\n';
  32:         c = compile(a,1);
  33:         if(c != 0){
  34:             execute(c);
  35:             free(c);
  36:         } else {
  37:             free(a);
  38:             error("");
  39:         }
  40:         b += dim1;
  41:         if(i < dim0-1)
  42:             pop();
  43:     }
  44:     free(a);
  45:     pcp = xpcp;
  46:     p = *--sp;
  47:     pop();
  48:     *sp++ = p;
  49: }
  50: 
  51: ex_menc()
  52: {
  53:     struct item *p;
  54: 
  55:     p = fetch1();
  56:     if ( p->type == DA )
  57:         menc1();    /*
  58: 	else
  59: 		return (char argument unchanged);	*/
  60: }
  61: 
  62: 
  63: ex_list()   /* List a function on the terminal */
  64: {
  65:     register char lastc;
  66:     register struct nlist *n;
  67:     register line;
  68:     char c;
  69: 
  70: 
  71:     /* Check for valid function */
  72: 
  73:     n = (struct nlist *)*--sp;
  74:     if (n->type != LV)
  75:         error("fnlist B");
  76: 
  77: 
  78:     /* If a function, locate it in workspace file and
  79: 	 * print on the terminal in formatted form.
  80: 	 */
  81: 
  82:     switch(((struct nlist *)n)->use){
  83:     default:
  84:         error("fnlist T");
  85: 
  86:     case NF:
  87:     case MF:
  88:     case DF:
  89:         SEEKF(wfile, (long)n->label, 0);
  90:         line = 0;
  91:         lastc = 0;
  92:         putchar('\n');
  93: 
  94:         while(READF(wfile, &c, 1) > 0){
  95: 
  96:             if (!c){
  97:                 putchar('\n');
  98:                 return;
  99:             }
 100: 
 101:             switch(lastc){
 102:             case '\n':
 103:                 printf("[%d]", ++line);
 104:             case 0:
 105:                 putchar('\t');
 106:             }
 107:             putchar(lastc=c);
 108:         }
 109:         error("workspace eof");
 110:     }
 111: }
 112: 
 113: 
 114: ex_crp()         /* dredge up a function and put it into an array*/
 115: {
 116:     char name[NAMS];
 117:     char *c, *c2;
 118:     struct nlist *np;
 119:     struct item *p;
 120:     int len, dim0, dim1;
 121:     register i;
 122:     register char *dp;
 123: 
 124:     p = fetch1();
 125:     if ( p->size == 0 || p->rank >1 || p->size >= NAMS )
 126:         error("Lcr C");
 127:             /* set up the name in search format     */
 128:     copy(CH, p->datap, name, p->size);
 129:     name[p->size] = '\0';
 130:     np = nlook(name);
 131:             /* if not found then domain error       */
 132:     if ( !np->namep )
 133:         error("Lcr D");
 134:     switch(np->use){
 135:     default:
 136:         error("Lcr D");
 137:     case MF:
 138:     case DF:
 139:     case NF:    /* only allow functions */
 140:         ;
 141:     }
 142:             /* set up new array                     */
 143:     dim0 = 0;
 144:     dim1 = 0;
 145:     ifile = DUPF(wfile);
 146:     SEEKF( ifile, (long)np->label, 0);    /* look up function     */
 147:             /* compute max width and height         */
 148:     while ( c2 = c = rline(0) ){
 149:            while ( *c2++ != '\n' ){}
 150:         dim0++;
 151:         len = c2 - c - 1;
 152:         dim1 = dim1 < len ? len : dim1;
 153:         free(c);
 154:     }
 155:     pop();                /* release old variable         */
 156:             /* create new array and put function in */
 157:     p = newdat ( CH, 2, dim0*dim1 );
 158:     p->rank = 2;
 159:     p->dim[0] = dim0;
 160:     p->dim[1] = dim1;
 161:     dp = (char *)(p->datap);
 162:     SEEKF( ifile, (long)np->label, 0);
 163:     while ( c2 = c = rline(0) ){
 164:            for ( i=0; i<dim1; i++)
 165:             if ( *c != '\n' )
 166:                 *dp++ = *c++;
 167:             else
 168:                 *dp++ = ' ';    /* fill w/blanks*/
 169:         free(c2);
 170:     }
 171:             /* put the new array on the stack       */
 172:     *sp++ = p;
 173:                 /* reset the current file               */
 174:     CLOSEF(ifile);
 175:     ifile = 0;
 176: }
 177: 
 178: menc1()                 /* change numbers into characters       */
 179: {
 180:     struct item *p, *q;
 181:     register i,j,numsz;
 182:     data *dp;
 183:     int total,param[4];
 184: 
 185:             /* zeroize size information vector      */
 186:     for ( i=0; i<4; i++ )
 187:         param[i] = 0;
 188:             /* pick up the argument                 */
 189:     p = fetch1();
 190:     if(p->rank > 2)
 191:         error("format R");
 192:     dp = p->datap;
 193:             /* find the maximum # of chars in any # */
 194:     for(i=0; i<p->size; i++)
 195:         epr1(*dp++, param);
 196:     numsz = param[1] + param[2] + !!param[2] + param[3] + 1;
 197:             /* rowsize is max # size x last dim     */
 198:     rowsz = p->rank ? p->dim[p->rank-1] : 1;
 199:     rowsz *= numsz;
 200:             /* row size x # of rows (incl blank)    */
 201:     total = p->size * numsz;
 202:     for( j=i=0; i<p->rank; i++ )
 203:         if ( p->dim[i] != 1)
 204:             if ( j++ > 1 )
 205:                 total += rowsz;
 206:             /* make new data and fill with blanks   */
 207:     if(p->rank == 2){
 208:         q = newdat(CH, 2, total);
 209:         q->dim[0] = total/rowsz;
 210:         q->dim[1] = rowsz;
 211:     } else {
 212:         /* rank = 0 or 1 */
 213:         q = newdat( CH, 1, total);
 214:         q->dim[0] = rowsz;
 215:     }
 216:     mencptr = (char *)(q->datap);
 217:     for ( i=0; i<total; i++)
 218:         *mencptr++ = ' ';
 219:     mencptr = (char *)(q->datap);
 220:             /* use putchar() to fill up the array   */
 221:     mencflg = 2;
 222:     ex_hprint();
 223:     mencflg = 0;
 224:             /* put it on the stack                  */
 225: /*	pop();		/* done by ex_hprint() */
 226:     *sp++ = q;
 227: }
 228: 
 229: 
 230: ex_run()
 231: {
 232:     register struct item *p;
 233:     register data *dp;
 234:     register int *p2;
 235:     char ebuf[100];
 236:     int i;
 237:     int *run();
 238: 
 239:     p = fetch1();
 240:     if(p->type != CH || p->rank != 1)
 241:         error("Lrun D");
 242:     copy(CH, p->datap, ebuf, p->size);
 243:     ebuf[p->size] = 0;
 244:     p2 = run(ebuf);
 245:     p = newdat(DA, 1, 0);
 246:     pop();
 247:     *sp++ = p;
 248: }
 249: 
 250: int *run(s)
 251: char *s;
 252: {
 253:     register p;
 254:     static int a[3];
 255:     int (*oldint)(), (*oldquit)();
 256: 
 257:     oldint = signal(SIGINT, SIG_IGN);
 258:     oldquit = signal(SIGQUIT, 1);
 259:     if(a[0]=FORKF(1)){
 260:         while((p = wait(a+1)) != -1)
 261:             if(p == a[0])
 262:                 break;
 263:     } else {
 264:         execl("/bin/sh", "-", "-c", s, 0);
 265:         WRITEF(1, "can't find shell\n", 17);
 266:         exit(1);
 267:     }
 268:     a[2] = (a[1]>>8)&0377;
 269:     a[1] &= 0377;
 270:     signal(SIGINT, oldint);
 271:     signal(SIGQUIT, oldquit);
 272:     return(a);
 273: }
 274: 
 275: ex_dfmt()
 276: {
 277:     register char *cp, *ecp;
 278:     register data *fp;
 279:     register j;
 280:     struct item *lp, *rp, *ip;
 281:     data *dp;
 282:     unsigned nrow, ncol, rowlen, inc, wid;
 283:     int i, sign, decpt;
 284: 
 285:     /* Dyadic format.  This routine is a little crude and should
 286: 	 * probably be rewritten to take advantage of other conversion
 287: 	 * routines.  Nonetheless, it does do dyadic formatting for
 288: 	 * scalars, vectors, and 2-dimensional arrays when the left
 289: 	 * argument is a 2-element or appropriate-length vector
 290: 	 * specifying non-exponential ("F format") conversion.
 291: 	 */
 292: 
 293:     lp = fetch2();
 294:     rp = sp[-2];
 295:     nrow = (rp->rank < 2) ? 1 : rp->dim[0];
 296:     ncol = rp->rank ? rp->dim[rp->rank-1] : 1;
 297:     inc = (lp->size != 2) * 2;
 298: 
 299: 
 300:     /* Check validity of arguments. */
 301: 
 302:     if (lp->rank > 1 || lp->size <= 1 || rp->rank > 2
 303:         || lp->type != DA || rp->type != DA
 304:         || (lp->size != 2 && lp->size != 2*ncol))
 305:         error("dfmt D");
 306: 
 307:     for(fp=lp->datap,i=0; i < lp->size; i += 2,fp += 2){
 308:         if (fp[0] <= 0.0 || fp[1] < 0.0)
 309:             error("dfmt D");
 310:         fp[0] = (data)((int)(0.5+fp[0]));
 311:         fp[1] = (data)((int)(0.5+fp[1]));
 312:     }
 313: 
 314: 
 315:     /* Allocate result array */
 316: 
 317:     for(i=rowlen=0,fp=lp->datap; i < ncol; i++, fp += inc)
 318:         rowlen += (int)*fp;
 319: 
 320:     ip = newdat(CH, rp->rank ? rp->rank : 1, rowlen*nrow);
 321: 
 322:     if (rp->rank < 2)
 323:         ip->dim[0] = rowlen;
 324:     else {
 325:         ip->dim[0] = nrow;
 326:         ip->dim[1] = rowlen;
 327:     }
 328: 
 329: 
 330:     /* Fill it up. The special case "fabs(*dp) < 1.0 && !fp[1]"
 331: 	 * insures that a zero is printed when 0 fractional digits are
 332: 	 * specified and the number being converted is less than one.
 333: 	 */
 334: 
 335:     cp = (char *)ip->datap;
 336:     dp = rp->datap;
 337:     while(nrow--)
 338:         for(i=0,fp=lp->datap; i < ncol; i++, dp++, fp += inc){
 339:             if (fp[1] == 0.0 && fabs(*dp) < 1.0)
 340:                 *dp = 0.0;
 341:             ecp = ecvt(*dp, (int)(0.5+fp[0]), &decpt, &sign);
 342:             decpt += (*dp == 0.0 && fp[1] == 0.0);
 343:             j = fp[0];
 344:             wid = !!sign + fp[1] + !!fp[1] + ((decpt>0)?decpt:0);
 345:             if (j < wid)
 346:                 while(j--)
 347:                     *cp++ = '*';    /* not wide enough */
 348:             else {
 349:                 while(j > wid){     /* leading spaces */
 350:                     *cp++ = ' ';
 351:                     j--;
 352:                 }
 353:                 if (sign){      /* possible - sign */
 354:                     *cp++ = '-';
 355:                     j--;
 356:                 }
 357:                 while(decpt > 0){   /* whole number part */
 358:                     *cp++ = *ecp++;
 359:                     j--;
 360:                     decpt--;
 361:                 }
 362:                 if (j--){       /* fraction, if any */
 363:                     *cp++ = '.';
 364:                     while(decpt++ < 0 && j){
 365:                         j--;
 366:                         *cp++ = '0';
 367:                     }
 368:                     while(j--)
 369:                         *cp++ = *ecp++;
 370:                 }
 371:             }
 372:         }
 373: 
 374:     pop();
 375:     pop();
 376:     *sp++ = ip;
 377: 
 378: }
 379: 
 380: ex_mfmt()
 381: {
 382:     ex_menc();
 383: }
 384: 
 385: ex_nc()
 386: {
 387:     register struct nlist *np;
 388:     register struct item *p;
 389:     register char *q;
 390:     int i;
 391:     char buf[40];
 392: 
 393:     p = fetch1();
 394:     if(p->type != CH)
 395:         error("Lnc T");
 396:     if(p->size >= 40 || p->rank > 1)
 397:         error("Lnc D");
 398:     copy(CH, p->datap, buf, p->size);
 399:     buf[p->size] = 0;
 400:     np = nlook(buf);
 401:     i = 0;
 402:     if(np != 0)
 403:     switch(np->use){
 404:     case 0:
 405:         i = 0; break;
 406:     case MF:
 407:     case NF:
 408:     case DF:
 409:         i = 3; break;
 410:     case DA:
 411:     case CH:
 412:     case LV:
 413:         i = 2; break;
 414:     default:
 415:         printf("unknown Lnc type = %d\n", np->use);
 416:         i = 4;
 417:     }
 418:     p = newdat(DA, 0, 1);
 419:     p->datap[0] = i;
 420:     pop();
 421:     *sp++ = p;
 422: }
 423: 
 424: ex_nl()
 425: {
 426: 
 427:     struct item *ip;
 428:     struct nlist *np;
 429:     data *dp;
 430:     register char *cp, *cp2;
 431:     register i;
 432:     int count, maxlen;
 433:     char tlist[NTYPES];
 434: 
 435: 
 436:     /* Namelist quad function.  This is monadic (dyadic not
 437: 	 * implemented).  The argument is a list of types:
 438: 	 *  1:	labels
 439: 	 *  2:	variables
 440: 	 *  3:	functions
 441: 	 * whose names are desired.  The result is a character array
 442: 	 * containing all defined names (in no particular order) of
 443: 	 * the specified type(s).  The number of rows in the matrix
 444: 	 * is the number of names; the number of columns is the
 445: 	 * same as the longest name (other names are space-filled).
 446: 	 */
 447: 
 448:     ip = fetch1();
 449:     if (ip->rank > 1 || ip->type != DA)
 450:         error("Lnl D");
 451: 
 452:     for(i=0; i < NTYPES; i++) tlist[i] = 0;
 453:     for(dp=ip->datap; dp < ip->datap+ip->size; dp++)
 454:         switch((int)*dp){
 455:         case 1: tlist[LBL] = 1; break;
 456:         case 2: tlist[CH] = tlist[DA] = 1; break;
 457:         case 3: tlist[NF] = tlist[MF] = tlist[DF] = 1; break;
 458:         default:error("Lnl D"); break;
 459:         }
 460: 
 461:     count = maxlen = 0;
 462:     for(np=nlist; np < &nlist[NLS]; np++){
 463:         if (np->use < NTYPES && tlist[np->use]){
 464:             count++;
 465:             if ((i=strlen(np->namep)) > maxlen)
 466:                 maxlen = i;
 467:         }
 468:     }
 469: 
 470: 
 471:     ip = newdat(CH, 2, count*maxlen);
 472:     ip->dim[0] = count;
 473:     ip->dim[1] = maxlen;
 474:     cp = ip->datap;
 475: 
 476:     for(np=nlist; np < &nlist[NLS]; np++)
 477:         if (np->use < NTYPES && tlist[np->use])
 478:             for(cp2 = &np->namep[i=0]; i < maxlen; i++)
 479:                 if (*cp2)
 480:                     *cp++ = *cp2++;
 481:                 else
 482:                     *cp++ = ' ';
 483: 
 484:     pop();
 485:     *sp++ = ip;
 486: }
 487: 
 488: strlen(p)
 489: register char *p;
 490: {
 491:     register i;
 492: 
 493:     for(i=0; *p; i++,p++);
 494:     return(i);
 495: }
 496: 
 497: ex_prws(){
 498: 
 499:     register struct nlist *np;
 500:     register struct item *ip;
 501:     register i;
 502: 
 503:     /* Print workspace in ASCII format */
 504: 
 505:     printf("origin = %d\nwidth = %d\ndigits = %d\n\n\n",
 506:         thread.iorg, thread.width, thread.digits);
 507:     for(np=nlist; np < &nlist[NLS]; np++)
 508:         switch(np->use){
 509:         case CH:
 510:         case DA:
 511:             printf("%s { ", np->namep);
 512:             ip = np->itemp;
 513:             if (ip->rank){
 514:                 for(i=0; i < ip->rank; i++)
 515:                     printf("%d ", ip->dim[i]);
 516:                 printf("R\n");
 517:             }
 518:             *sp++ = np;
 519:             ex_print();
 520:             pop();
 521:             putchar('\n');
 522:             break;
 523: 
 524:         case NF:
 525:         case MF:
 526:         case DF:
 527:             *sp++ = np;
 528:             ex_list();
 529:             /* pop(); in ex_list() */
 530:             putchar('\n');
 531:             break;
 532:         }
 533: }

Defined functions

Defined variables