home *** CD-ROM | disk | FTP | other *** search
/ Magazyn Amiga 13 / MA_Cover_13.bin / source / c / apl / ai.c < prev    next >
Encoding:
C/C++ Source or Header  |  1999-11-27  |  11.8 KB  |  590 lines
  1. #include "apl.h"
  2. #include <stdlib.h>
  3. #include <signal.h>
  4.  
  5. char *bad_fn  = "apl.badfn";
  6. int prolgerr;        /* Flag -- set if bad fetch in prologue */
  7.  
  8. /*
  9.  * funedit -- edit a file and read it in.
  10.  *
  11.  * If the arg to funedit is non-zero, it is used as a 
  12.  * pointer to the file name to be used.  If it is zero,
  13.  * the namep of the function is used for the file name.
  14.  */
  15.  
  16. funedit(fname, editor)
  17. char *fname;
  18. {
  19.     struct item *p;
  20.     int f, (*a)();
  21.     char *c, cmd[128];
  22.     extern edmagic;
  23.  
  24.     p = sp[-1];
  25.     if(p->type != LV) error("fed B");
  26.     sichk(p);
  27.     if(fname == 0) fname = ((struct nlist *)p)->namep;
  28.     c = getenv("EDITOR");
  29.     if (c == 0) c = "vi";
  30.     strcpy(cmd, c);
  31.     strcat(cmd, " ");
  32.     strcat(cmd, fname);
  33.     system(cmd);
  34.  
  35.     /* Read function into workspace.  If "funread" (which calls
  36.      * "fundef") returns 0, an error occurred in processing the
  37.      * header (line 0).  If this happened with "editf" or "del",
  38.      * save the bad function in the file "bad_fn".
  39.      */
  40.  
  41.     if (funread(fname) == 0 && fname == scr_file){
  42.         unlink(bad_fn);
  43.         if (badfnsv(fname)) printf("function saved in %s\n", bad_fn);
  44.     }
  45. }
  46.  
  47.  
  48. funread(fname)
  49. char *fname;
  50. {
  51.     struct item *p;
  52.     int f, pid;
  53.  
  54.     p = sp[-1];
  55.     sp--;
  56.     if(p->type != LV) error("fnl B");
  57.     if(fname == 0) fname = ((struct nlist *)p)->namep;
  58.     f = opn(fname, 0);
  59.     return(fundef(f));
  60. }
  61.  
  62. funwrite(fname)
  63. char *fname;
  64. {
  65.     struct nlist *n;
  66.     int i, cnt, fd1, fd2;
  67.     char buf[512];
  68.  
  69.     n = (struct nlist *)sp[-1];
  70.     sp--;
  71.     if(n->type != LV) error("fnwrite B");
  72.     if(fname ==0) fname = n->namep;
  73.     fd1 = opn(fname, 0644);
  74.     switch(n->use){
  75.     default:
  76.         close(fd1);
  77.         error("fnwrite T");
  78.  
  79.                         /*    Undefined function -- print that and do nothing  */
  80.     case 0:
  81.         printf("\t[new fn]\n");
  82.         break;
  83.  
  84.                         /*    Function already defined  */
  85.     case NF:
  86.     case MF:
  87.     case DF:
  88.         fd2 = dup(wfile);
  89.         lseek(fd2, (long)n->label, 0);
  90.         do {
  91.             cnt = read(fd2, buf, 512);
  92.             if(cnt <= 0) error("fnwrite eof");
  93.             for(i=0; i<cnt; i++) if(buf[i] == 0) break;
  94.             write(fd1, buf, i);
  95.         } while(i == 512);
  96.         close(fd2);
  97.         break;
  98.     }
  99.     close(fd1);
  100. }
  101.  
  102. fundef(f)
  103. {
  104.     int a, c;
  105.     struct nlist *np;
  106.     char b[512];
  107.  
  108.     ifile = f;
  109.     a = rline(0);
  110.     if(a == 0) error("fnd eof");
  111.     c = compile(a, 2);
  112.     aplfree(a);
  113.     if(c == 0) goto out;
  114.     copy(IN, c+1, &np, 1);
  115.     sichk(np);
  116.     erase(np);
  117.     np->use = ((struct chrstrct *)c)->c[0];
  118.     np->label = lseek(wfile, 0L, 2);
  119.     lseek(ifile, 0L, 0);
  120.     while((a=read(ifile, b, 512)) > 0) write(wfile, b, a);
  121.     write(wfile, "", 1);
  122. out:
  123.     close(ifile);
  124.     ifile = 0;
  125.     return(c);
  126. }
  127.  
  128. extern data lnumb;
  129. extern char *labcpp,*labcpe;
  130.  
  131. funcomp(np)
  132. struct nlist *np;
  133. {
  134.     char *a, *c, labp[MAXLAB*20], labe[MAXLAB*4];
  135.     int  *p, i, err, size;
  136.  
  137.     ifile = dup(wfile);
  138.     lseek(ifile, (long)np->label, 0);
  139.     size = 0;
  140.     err = 0;
  141.     lineNumber = 0;
  142.  
  143.     labgen = 0;
  144. pass1:
  145.     a = rline(0);
  146.     lineNumber++;
  147.     if(a == 0) {
  148.         if(err) goto out;
  149.         p = (int *)alloc((size+2)*SINT);
  150.         p[0] = size;
  151.         size = 0;
  152.         lseek(ifile, (long)np->label, 0);
  153.         lineNumber = 0;
  154.         err++;
  155.         labcpp = labp;
  156.         labcpe = labe;
  157.         labgen = 1;
  158.         goto pass2;
  159.     }
  160.     c = compile(a, size==0? 3: 5);
  161.     size++;
  162.     aplfree(a);
  163.     if(c == 0) {
  164.         err++;
  165.         goto pass1;
  166.     }
  167.     aplfree(c);
  168.     goto pass1;
  169.  
  170. pass2:
  171.     a = rline(0);
  172.     lineNumber++;
  173.     if(a == 0) goto pass3;
  174.     lnumb = size;
  175.     c = compile(a, size==0? 3: 5);
  176.     size++;
  177.     aplfree(a);
  178.     if(c == 0) goto out;
  179.     p[size] = c;
  180.     goto pass2;
  181.  
  182. pass3:
  183.     labgen = 0;
  184.     lseek(ifile, (long)np->label, 0);
  185.     lineNumber = 0;
  186.     a = rline(0);
  187.     lineNumber++;
  188.     if(a == 0){
  189.         err++;
  190.         goto out;
  191.     }
  192.     c = compile(a, 4);
  193.     aplfree(a);
  194.     if(c == 0) goto out;
  195.     if(labcpp != labp){
  196.         reverse(labe);
  197.         p[size+1] = catcode(labe, c);
  198.         aplfree(c);
  199.  
  200.         /*        *** KLUDGE ***
  201.         /*
  202.         /* due to the "line-at-a-time" nature of the parser,
  203.         /* we have to screw around with the compiled strings.
  204.         /*
  205.         /* At this point, we have:
  206.         /*
  207.         /* fn-prologue (p[1]):        <AUTOs and ARGs>, ELID, EOF
  208.         /* label-prologue (labp):    <AUTOs and LABELs>, EOF
  209.         /* 
  210.         /* and we want to produce:
  211.         /* 
  212.         /* fn-prologue (p[1]):    <AUTOs and ARGs>,<AUTOs and LABELs>,  ELID, EOF.
  213.          */
  214.         a = csize(p[1]) - 1;
  215.         c = csize(labp) - 1;
  216.         /*
  217.          * if there is an ELID at the end of the fn-prologue,
  218.          * move it to  the end of the label-prologue.
  219.          */
  220.  
  221.         if (((struct chrstrct *)p[1])->c[(int)a-1] == ELID) {
  222.             ((struct chrstrct *)p[1])->c[(int)a-1] = EOF;
  223.             labp[(int)c] = ELID;
  224.             labp[(int)c+1] = EOF;
  225.         }
  226.         else error("elid B");
  227.         /* *** END KLUDGE *** */
  228.  
  229.         a = p[1];
  230.         p[1] = catcode(a,labp);
  231.         aplfree(a);
  232.     }
  233.     else p[size+1] = c;
  234.     if(debug) {
  235.         dump(p[1], 1);
  236.         dump(p[size+1], 1);
  237.     }
  238.     np->itemp = (struct item *)p;
  239.     err = 0;
  240.  
  241. out:
  242.     close(ifile);
  243.     ifile = 0;
  244.     if (err) {
  245.         if (np->namep) printf("in function %s\n", np->namep);
  246.         error("");
  247.     }
  248. }
  249.  
  250. ex_fun()
  251. {
  252.     struct nlist *np;
  253.     int *p, s;
  254.     struct si si;
  255.  
  256.     pcp += copy(IN, pcp, &np, 1);
  257.     if(np->itemp == 0) funcomp(np);
  258.     p = (int *)np->itemp;
  259.     si.sip = gsip;                /* setup new state indicator */
  260.     gsip = &si;
  261.     si.np = np;
  262.     si.oldsp = 0;                /* we can add a more complicated version, later */
  263.     si.oldpcp = pcp;
  264.     si.funlc = 0;
  265.     si.suspended = 0;
  266.     prolgerr = 0;                /* Reset error flag */
  267.     s = p[0];
  268.     checksp();
  269.     if(funtrace) printf("\ntrace: fn %s entered: ", np->namep);
  270.     if (setjmp(si.env)) goto reenter;
  271.     while(1){
  272.         si.funlc++;
  273.         if(funtrace) printf("\ntrace: fn %s[%d]: ", np->namep, si.funlc-1);
  274.         execute(p[si.funlc]);
  275.         if(si.funlc == 1){
  276.             si.oldsp = sp;
  277.             if (prolgerr) error("");
  278.         }
  279.         if(intflg) error("I");
  280.  
  281.     reenter:
  282.         if(si.funlc <= 0 || si.funlc >= s) {
  283.             si.funlc = 1;        /* for pretty traceback */
  284.             if(funtrace) printf("\ntrace: fn %s exits ", np->namep);
  285.             execute(p[s+1]);
  286.             gsip = si.sip;        /* restore state indicator to previous state */
  287.             pcp = si.oldpcp;
  288.             return;
  289.         }
  290.         pop();
  291.     }
  292. }
  293.  
  294. ex_arg1()
  295. {
  296.     struct item *p;
  297.     struct nlist *np;
  298.  
  299.     pcp += copy(IN, pcp, &np, 1);
  300.     p = fetch1();
  301.     sp[-1] = np->itemp;
  302.     np->itemp = p;
  303.     np->use = DA;
  304. }
  305.  
  306. ex_arg2()
  307. {
  308.     struct item *p1, *p2;
  309.     struct nlist *np1, *np2;
  310.  
  311.     pcp += copy(IN, pcp, &np2, 1);    /* get first argument's name */
  312.     pcp++;                            /* skip over ARG1 */
  313.     pcp += copy(IN, pcp, &np1, 1);    /* get second arg's name */
  314.     p1 = fetch1();                    /* get first expr to be bound to arg */
  315.     p2 = fetch(sp[-2]);                /* get second one */
  316.     sp[-1] = np1->itemp;            /* save old value of name on stack */
  317.     sp[-2] = np2->itemp;            /* save second */
  318.     np1->itemp = p1;                /* new arg1 binding */
  319.     np2->itemp = p2;                /* ditto arg2 */
  320.     np1->use = DA;                    /* release safety catch */
  321.     np2->use = DA;
  322. }
  323.  
  324. ex_auto()
  325. {
  326.     struct nlist *np;
  327.  
  328.     pcp += copy(IN, pcp, &np, 1);
  329.     checksp();
  330.     *sp++ = np->itemp;
  331.     np->itemp = 0;
  332.     np->use = 0;
  333. }
  334.  
  335. ex_rest()
  336. {
  337.     struct item *p;
  338.     struct nlist *np;
  339.  
  340.     p = sp[-1];
  341.     /*
  342.      * the following is commented out because
  343.      * of an obscure bug in the parser, which is
  344.      * too difficult to correct right now.
  345.      * the bug is related to the way the
  346.      * "fn epilog" is compiled.  To accomodate labels,
  347.      * it was kludged up to have the label restoration
  348.      * code added after the entire fn was parsed.  A problem
  349.      * is that the generated code is like:
  350.      *
  351.      * "rest-lab1 rest-lab2 eol rval-result rest-arg1 ..."
  352.      *
  353.      * the "eol rval-result" pops off the previous result, and
  354.      * puts a "fetched" version of the returned value (result)
  355.      * onto the stack.  The bug is that the "eol rval." should
  356.      * be output at the beginning of the fn epilog.
  357.      * The following two lines used to be a simple
  358.      * "p = fetch(p)", which is used to disallow
  359.      * a fn to return a LV, (by fetching it, it gets
  360.      * converted to a RVAL.)  Since we later added
  361.      * code which returned stuff which could not be
  362.      * fetched (the DU, dummy datum, for example),
  363.      * this thing had to be eliminated.  An earlier
  364.      * version only fetched LV's, but that was eliminated
  365.      * by adding the "RVAL" operator.  The test below
  366.      * was made a botch, because no LV's should ever be
  367.      * passed back.  However, for this to be true, the
  368.      * "eol" should be executed first, so that any possible
  369.      * LV's left around by the last line executed are
  370.      * discarded.  Since we have some "rest"s in the epilog
  371.      * before the eol, the following test fails.
  372.      * I can't think of why it won't work properly as it
  373.      * is, but if I had the time, I'd fix it properly.
  374.      *    --jjb
  375.     if(p->type == LV) error("rest B");
  376.      */
  377.     pcp += copy(IN, pcp, &np, 1);
  378.     erase(np);
  379.     np->itemp = sp[-2];
  380.     np->use = 0;
  381.     if(np->itemp) np->use = DA;
  382.     sp--;
  383.     sp[-1] = p;
  384. }
  385.  
  386. ex_br0()
  387. {
  388.     gsip->funlc = 0;
  389.     ex_elid();
  390. }
  391.  
  392. ex_br()
  393. {
  394.     struct item *p;
  395.  
  396.     p = fetch1();
  397.     if(p->size == 0) return;
  398.     gsip->funlc = fix(getdat(p));
  399. }
  400.  
  401. /*
  402.  * immediate niladic branch -- reset SI
  403.  */
  404.  
  405. ex_ibr0()
  406. {
  407.     struct si *s;
  408.     int *p;
  409.  
  410.     if(gsip == 0) error("no suspended fn");
  411.     if(gsip->suspended == 0) error("imm } B1");
  412.     gsip->suspended = 0;
  413.     while((s = gsip) && s->suspended == 0){
  414.         if(s->oldsp == 0 || sp < s->oldsp) error("imm } B2");
  415.         while(sp > s->oldsp) pop();
  416.         pop();                            /* pop off possibly bad previous result */
  417.         ex_nilret();                    /* and stick on some dummy datum */
  418.         p = (int *)s->np->itemp;
  419.         execute(p[*p + 1]);
  420.         gsip = s->sip;
  421.     }
  422.     if(gsip == 0) {
  423.         while(sp > stack) pop();
  424.         longjmp(reset_env, 0);
  425.     }
  426. }
  427.  
  428. /*
  429.  * monadic immediate branch -- resume fn at specific line
  430.  */
  431.  
  432. ex_ibr()
  433. {
  434.     struct si *s;
  435.     if((s = gsip) == 0) error("no suspended fn");
  436.     ex_br();
  437.     if(s->oldsp == 0 || sp < s->oldsp) error("imm }n B");
  438.     while(sp > s->oldsp) pop();
  439.     pop();                        /* pop off possibly bad previous result */
  440.     ex_nilret();                /* and stick on some dummy datum */
  441.     longjmp(s->env, 0);            /* warp out */
  442. }
  443.  
  444. ex_fdef()
  445. {
  446.     struct item *p;
  447.     char *p1, *p2;
  448.     struct nlist *np;
  449.     char b[512];
  450.     int i, dim0, dim1;
  451.  
  452.     p = fetch1();
  453.     if((p->rank != 2 && p->rank != 1) || p->type != CH) error("Lfx D");
  454.  
  455.     /* The following code has been commented out as a
  456.      * test of slight modifications to the compiler.
  457.      * Before this change, it was impossible to use "Lfx"
  458.      * from inside an APL function, for it might damage
  459.      * an existing function by the same name.  The compiler
  460.      * now checks when processing function headers to see
  461.      * if the function is suspended by calling "sichk", which
  462.      * will generate an error if so.  Hopefully this will now
  463.      * allow "Lfx" to be used freely without disastrous side-
  464.      * effects.
  465.      *
  466.     if(gsip) error("si damage -- type ')reset'");
  467.      */
  468.  
  469.     dim0 = p->dim[0];
  470.     dim1 = p->dim[1];
  471.     if(p->rank == 1) dim1 = dim0;
  472.     copy(CH, p->datap, b, dim1);
  473.     b[dim1] = '\n';
  474.  
  475.     p2 = compile(b, 2);
  476.     if(p2 != 0){
  477.         copy(IN, p2+1, &np, 1);
  478.         erase(np);
  479.         np->use = *p2;
  480.         aplfree(p2);
  481.     
  482.         np->label = lseek(wfile, 0L, 2);
  483.         fappend(wfile, p);
  484.         write(wfile,"",1);
  485.     }
  486.     pop();
  487.     *sp++ = newdat(DA, 1, 0);
  488. }
  489.  
  490. ex_nilret()
  491. {
  492.     checksp();
  493.     *sp++ = newdat(DU,0,0);        /* put looser onto stack (should be discarded) */
  494. }
  495.  
  496. reverse(s)
  497. char *s;
  498. {
  499.     char *p, *q, c;
  500.     int j;
  501.  
  502.     p = q = s;
  503.     while(*p != EOF) p++;
  504.     p -= 1+sizeof(char *);
  505.     while(q < p){
  506.         for(j=0; j<1+sizeof (char *); j++) {
  507.             c = p[j];
  508.             p[j] = q[j];
  509.             q[j] = c;
  510.         }
  511.         q += j;
  512.         p -= j;
  513.     }
  514. }
  515.  
  516. /*
  517.  * produce trace back info
  518.  */
  519.  
  520. char *atfrom[] = {"at\t", "from\t", "", ""};
  521.  
  522. tback(flag)
  523. {
  524.     struct si *p;
  525.     int i;
  526.  
  527.     p = gsip;
  528.     i = 0;
  529.     if(flag) i = 2;
  530.     while(p){
  531.         if(flag==0 && p->suspended) return;
  532.         if (p->funlc != 1 || i){    /* skip if at line 0 */
  533.             printf("%s%s[%d]%s\n",
  534.                 atfrom[i],
  535.                 p->np->namep,
  536.                 p->funlc - 1,
  537.                 (p->suspended ? "   *" : "")
  538.             );
  539.             i |= 1;
  540.         }
  541.         p = p->sip;
  542.     }
  543. }
  544.  
  545. sichk(n)
  546. struct nlist *n;
  547. {
  548.     struct si *p;
  549.  
  550.     p = gsip;
  551.     while(p){
  552.         if(n == p->np) error("si damage -- type ')reset'");
  553.         p = p->sip;
  554.     }
  555. }
  556.  
  557. ex_shell(){
  558.  
  559.     /* If the environment variable SHELL is defined, attempt to
  560.      * execute that shell.  If not, or if that exec fails, attempt
  561.      * to execute the standard shell, /bin/sh
  562.      */
  563.  
  564.     char *getenv(), *sh, cmd[128];
  565.  
  566.     sh = getenv("SHELL");
  567.     if (sh == 0) sh = "/bin/sh";
  568.     system(sh);
  569. }
  570.  
  571. badfnsv(fname)
  572. char *fname;
  573. {
  574.     /* This routine saves the contents of "fname" in the file
  575.      * named in "bad_fn".  It is called by "funedit" if the
  576.      * header of a function just read in is messed up (thus,
  577.      * the entire file is not lost).  Returns 1 if successful,
  578.      * 0 if not.
  579.      */
  580.  
  581.     int fd1, fd2, len;
  582.     char buf[512];
  583.  
  584.     if ((fd1=open(fname, 0)) < 0 || (fd2=creat(bad_fn, 0644)) < 0) return(0);
  585.     while((len=read(fd1, buf, 512)) > 0) write(fd2, buf, len);
  586.     close(fd1);
  587.     close(fd2);
  588.     return(1);
  589. }
  590.