One long step towards control-structure interpretation.

diff --git a/cupl.h b/cupl.h
index 5b063628f49aa4659689f07f39c31d2ffa476023..dc9c8d267973d535e782a38dfb8b3feab250bb06 100644 (file)
--- a/cupl.h
+++ b/cupl.h
@@ -55,6 +55,8 @@ typedef struct edon
     /* back-pointer to the symbol list, set if the node is an identifier */
     struct lvar_t      *syminf;    
 
+    /* statement node only */
+    struct edon                *endnode;       /* end node address, if block label */
 #ifdef PARSEDEBUG
     int number;                /* statement number, if this is a STATEMENT node */
 #endif /* PARSEDEBUG */
@@ -79,7 +81,6 @@ typedef struct lvar_t
     node               *node;          /* variable's symbol info */
     value              value;          /* variable's value */
     node               *target;        /* target node, if label */
-    node               *endnode;       /* end node address, if block label */
 
     /* information used for consistency checks */
     int                blabeldef;

diff --git a/cupl.y b/cupl.y
index c8fb373b74ee21ed4a446bdd3e725040d8a41518..9aa551fe02441947e3eb01d3ec105ae86596bce8 100644 (file)
--- a/cupl.y
+++ b/cupl.y
@@ -79,8 +79,9 @@ static int statement_count;
 %token ITERATE
 %token FROM
 
-%type <node> prog command cond simple guard perform iter expr rel alloc subscr
-%type <node> datal ditem expl readl writel witem allocl varlist minl maxl
+%type <node> prog command cond simple guard perform gosub iter expr rel alloc
+%type <node> subscr datal ditem expl readl writel witem allocl varlist
+%type <node> minl maxl
 
 %%     /* beginning of rules section */
 
@@ -132,16 +133,17 @@ datal     :    ditem ',' datal            {$$ = cons(DATA, $1, $3);}
        |    ditem                      {$$ = cons(DATA, $1, NULLNODE);}
        ;
 
-perform        :    PERFORM IDENTIFIER
-               {$$ = cons(PERFORM, $2, NULLNODE);}
-       |    PERFORM IDENTIFIER expr TIMES
-               {$$ = cons(TIMES,   $2, $3);}
-       |    PERFORM IDENTIFIER WHILE guard
-               {$$ = cons(WHILE,   $2, $4);}
-       |    PERFORM IDENTIFIER FOR IDENTIFIER '=' expl
-               {$$ = cons(FOR,     $2, cons('=', $4, $6));}
-       |    PERFORM IDENTIFIER FOR IDENTIFIER '=' expr iter
-               {$$ = cons(FOR,     $2, cons(ITERATE, $4, cons(FROM, $6, $7)));}
+gosub  :   PERFORM IDENTIFIER          {$$ = cons(PERFORM, $2, NULLNODE);}
+       ;
+
+perform        :    gosub                      {$$ = $1;}
+       |    gosub expr TIMES           {$$ = cons(TIMES, $2, $1);}
+       |    gosub WHILE guard          {$$ = cons(WHILE, $3, $1);}
+
+       |    gosub FOR IDENTIFIER '=' expl
+               {$$ = cons(FOR,   cons('=', $3, $5),                     $1);}
+       |    gosub FOR IDENTIFIER '=' expr iter
+               {$$ = cons(FOR,   cons(ITERATE, $3, cons(FROM, $5, $6)), $1);}
        ;
 
 iter   :    TO expr BY expr            {$$ = cons(TO, $2, $4);}
@@ -161,7 +163,7 @@ expl        :    expr ',' expl              {$$ = cons(FORLIST, $1, $3);}
  */
 guard  :    rel                        {$$ = $1;}
        |    rel AND rel                {$$ = cons(AND, $1, $3);}
-       |    rel OR rel                 {$$ = cons(OR, $1, $3);}
+       |    rel OR rel                 {$$ = cons(OR,  $1, $3);}
        ;
 
 rel    :    expr '=' expr              {$$ = cons('=', $1, $3);}

diff --git a/execute.c b/execute.c
index d338512befdb7e7a6d87712467983ac3694f8801..f88d64a493e77a81af8838f19ba29c4973cc5017 100644 (file)
--- a/execute.c
+++ b/execute.c
@@ -23,9 +23,42 @@ support in monitor.c.
 #define EVAL_WRAP      /* empty */
 #define RETURN_WRAP(t, l, r, v)        display_return(t, l, r, v);
 
-static node *pc;       /* the statement node to evaluate next */
+static node *pc;       /* pointer to statement being evaluated */
+static node *next;     /* the statement node to evaluate next */
 static node *data;     /* pointer to *DATA item to be grabbed next */
-static jmp_buf jmpbuf; /* termination handling */
+static jmp_buf nextbuf;        /* end-of-statement handling */
+static jmp_buf endbuf; /* termination handling */
+
+/****************************************************************************
+ *
+ * Stack handling
+ *
+ ****************************************************************************/
+
+#define STACKSIZE      64
+static node *stack[STACKSIZE], **sp = stack;
+
+static node *popstack(void)
+/* pop the perform stack */
+{
+    if (sp <= stack)
+       die("too many END statements\n");
+    return(*sp--);
+}
+
+static void pushstack(node *st)
+/* push a return location onto the perform stack */
+{
+    if (sp >= stack + STACKSIZE)
+       die("too many PERFORM calls\n");
+    *sp++ = st;
+}
+
+/****************************************************************************
+ *
+ * I/O support
+ *
+ ****************************************************************************/
 
 static void cupl_read(node *tp)
 /* evaluate a READ item */
@@ -81,6 +114,12 @@ static void eval_write(node *tp)
        cupl_scalar_write(tp->u.string, tp->syminf->value.elements[0]);
 }
 
+/****************************************************************************
+ *
+ * Interpretation
+ *
+ ****************************************************************************/
+
 static void display_return(node *tree, node *left, node *right, value v)
 /* display the returned value of a node (for tracing purposes) */
 {
@@ -275,6 +314,14 @@ static value cupl_eval(node *tree)
         * Matrix functions
         */
 
+    case IDN:
+       /* FIXME: IDN special properties are not implemented */
+       die("special properties of IDN are not omplemented\n");
+
+    case SUBSCRIPT:
+       /* FIXME: SUBSCRIPT special properties are not implemented */
+       die("special properties of subscript are not omplemented\n");
+
     case DET:
        rightside = EVAL_WRAP(cupl_eval(tree->cdr));
        result = cupl_det(rightside);
@@ -413,40 +460,75 @@ static value cupl_eval(node *tree)
         * Control structures.
         */
 
-    case WHILE:
-       do {
-           (void) cupl_eval(tree->car);
+    case LABEL:
+       (void) cupl_eval(tree->cdr);
+       result.rank = FAIL;
+       return(result);
 
-           cond = cupl_eval(tree->cdr);
-       } while
-           (cond.rank);        /* conditional values use an odd convention */
+    case WHILE:
+       /* FIXME: implement WHILE */
+       die("WHILE is not implemented\n");
        result.rank = FAIL;
-       break;
+       return(result);
 
     case FOR:
        /* FIXME: implement FOR */
        die("FOR is not implemented\n");
+       result.rank = FAIL;
+       return(result);
 
     case TIMES:
        /* FIXME: implement TIMES */
        die("TIMES is not implemented\n");
+       result.rank = FAIL;
+       return(result);
+
+    case PERFORM:
+       next = tree->car;
+       pushstack(pc->cdr);
+       longjmp(nextbuf, 1);
 
     case BLOCK:
-       /* FIXME: implement BLOCK */
-       die("BLOCK skip is not implemented\n");
+       next = pc->endnode->cdr;
+       longjmp(nextbuf, 1);
 
     case GO:
-       /* FIXME: implement GO TO */
-       die("GO TO is not implemented\n");
+       next = tree->car;
+       longjmp(nextbuf, 1);
+
+    case END:
+    case OG:
+       next = popstack();
+       longjmp(nextbuf, 1);
 
     case IF:
-       /* FIXME: implement IF */
-       die("GO TO is not implemented\n");
+       leftside = EVAL_WRAP(cupl_eval(tree->car));
+       if (leftside.rank)
+           cupl_eval(tree->cdr);
+       result.rank == FAIL;
+       return(result);
+
+    case IFELSE:
+       leftside = EVAL_WRAP(cupl_eval(tree->car));
+       if (leftside.rank)
+           cupl_eval(tree->cdr->car);
+       else
+           cupl_eval(tree->cdr->cdr);
+       result.rank == FAIL;
+       return(result);
 
     case STOP:
-       longjmp(jmpbuf, 1);
+       longjmp(endbuf, 1);
        /* no fall through */
 
+       /*
+        * Tracing.
+        */
+
+    case WATCH:
+       /* FIXME: implement WATCH */
+       die("WATCH is not implemented\n");
+
     default:
        die("unknown node type %d (%s), cannot execute\n",
            tree->type,
@@ -458,7 +540,7 @@ static value cupl_eval(node *tree)
 void execute(node *tree)
 /* execute a CUPL program described by a parse tree */
 {
-    node       *np, *next, *last;
+    node       *np, *last;
     lvar       *lp;
 
     /* initially, all variables are scalars with zero values */
@@ -484,14 +566,15 @@ void execute(node *tree)
        last->cdr = (node *)NULL;
 
     /* first, setjmp so we can use STOP to exit */
-    if (setjmp(jmpbuf) != 0)
+    if (setjmp(endbuf) != 0)
        return;
     else
        /* now execute the program */
        for (pc = tree; pc; pc = next)
        {
            next = pc->cdr;
-           (void) cupl_eval(pc->car);
+           if (setjmp(nextbuf) == 0)
+               (void) cupl_eval(pc->car);
        }
 
     warn("program terminated without explicit STOP\n");

diff --git a/interpret.c b/interpret.c
index cf37fe9a1fd140a402702eabdd241fc49af2cc88..f377be6230731e0bc978ac7d1712f1c50e9b8b0b 100644 (file)
--- a/interpret.c
+++ b/interpret.c
@@ -299,24 +299,31 @@ static void rewrite(node *tree)
        if (np->car->type == LABEL)
            np->car->car->syminf->target = np;
 
-    /* pull blocks out of the main line */
+    /* figure end addresses */
     for_cdr(np, tree)
     {
        node *sp = np->car;
 
        if (sp && sp->type == LABEL && sp->cdr->type == BLOCK)
        {
-           node        *endnode;
+           node        *ep;
            bool        found = FALSE;
 
-           for (endnode = np->cdr; endnode; endnode = endnode->cdr)
-               if (endnode->car->type == LABEL
-                       && endnode->car->cdr->type == END
+           for (ep = np->cdr; ep; ep = ep->cdr)
+               if (ep->car->type == LABEL
+                       && ep->car->cdr->type == END
                        && strcmp(sp->car->u.string,
-                                 endnode->car->car->u.string) == 0)
+                                 ep->car->car->u.string) == 0)
                {
+                   /*
+                    * Associate the end node not with the BLOCK node
+                    * itself but with the enclosing statement node.
+                    * that way, we can find the first statement after
+                    * the END by pc->endnode->cdr, where pc is the
+                    * current statement.
+                    */
+                   np->endnode = ep;
                    found = TRUE;
-                   sp->car->syminf->endnode = endnode;
                    break;
                }
            if (!found)