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