Return to al.c CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src

Annotation of 43BSD/contrib/apl/src/al.c, revision 1.1

1.1     ! root        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: }

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