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