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

##### Functions

    ex_crp            X
    ex_dfmt           X
    ex_list           X
    ex_menc           X
    ex_meps           X
    ex_mfmt           X
    ex_nc             X
    ex_nl             X
    ex_prws           X
    ex_run            X
    menc1             X
    run               X
    strlen            X

       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

ex_crp defined in line 114; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 30, 267

ex_dfmt defined in line 275; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 33, 268

ex_list defined in line 63; used 2 times

- in line 528
- in /usr/src/new/OLD/apl/src/ah.c line 224

ex_menc defined in line 51; used 3 times

- in line 382
- in /usr/src/new/OLD/apl/src/at.c line 77, 238

ex_meps defined in line 9; used 4 times

- in /usr/src/new/OLD/apl/src/Llx.c line 9
- in /usr/src/new/OLD/apl/src/ah.c line 261
- in /usr/src/new/OLD/apl/src/at.c line 78, 219

ex_mfmt defined in line 380; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 79, 269

ex_nc defined in line 385; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 89, 270

ex_nl defined in line 424; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 53, 278

ex_prws defined in line 497; used 2 times

- in /usr/src/new/OLD/apl/src/a0.c line 127
- in /usr/src/new/OLD/apl/src/ah.c line 228

ex_run defined in line 230; used 2 times

- in /usr/src/new/OLD/apl/src/at.c line 119, 248

menc1 defined in line 178; used 1 times

- in line 57

run defined in line 250; used 2 times

- in line 237, 244

strlen defined in line 488; used 1 times

- in line 465

#### Defined variables

Sccsid defined in line 1; never used

Last modified: 1986-10-21 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1230 |