Return to a2.c CVS log

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

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

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

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