path: root/support/ltx2x/l2xixstm.c

/* l2xixstm.c  LTX2X interpreter statement executor routines    */
/*  Written by: Peter Wilson, CUA  pwilson@cme.nist.gov                */
/*  This code is partly based on algorithms presented by Ronald Mak in */
/*  "Writing Compilers & Interpreters", John Wiley & Sons, 1991        */

#include <stdio.h>
#include "l2xicmon.h"
#include "l2xierr.h"
#include "l2xiscan.h"
#include "l2xisymt.h"
#include "l2xiprse.h"
#include "l2xiidbg.h"
#include "l2xiexec.h"

/* GLOBALS */

BOOLEAN executed_return;           /* TRUE iff return statement executed */

/* EXTERNALS */

extern int level;
extern int exec_line_number;;
extern long exec_stmt_count;
 
extern ICT *code_segmentp;           /* code segment ptr */
extern ICT *statement_startp;        /* ptr to start of statement */
extern TOKEN_CODE ctoken;            /* token from code segment */

extern STACK_ITEM *stack;                  /* runtime stack */
extern STACK_ITEM_PTR tos;                 /* ptr to top of runtime stack */
extern STACK_ITEM_PTR stack_frame_basep;   /* ptr to stack fame base */

extern BOOLEAN stack_flag;

extern BOOLEAN is_value_undef();
extern STRING get_stacked_string();

/* MACROS */

/* is_undef(tp1)  TRUE iff type tp1 is undef */
#define is_undef(tp1) (tp1 == any_typep)


/***************************************************************************/
/* exec_statement()  Execute a statement by calling appropriate routine    */
/*      returns the token code of the statement                            */

TOKEN_CODE exec_statement()
{
  TOKEN_CODE stmt_tok;
  entry_debug("exec_statement (l2xixstm.c)");

  if (ctoken == STATEMENT_MARKER) {
    exec_line_number = get_statement_cmarker();
    ++exec_stmt_count;

    statement_startp = code_segmentp;
    trace_statement_execution();
    get_ctoken();
  }
  stmt_tok = ctoken;

  switch (ctoken) {
    case IDENTIFIER: {
      SYMTAB_NODE_PTR idp = get_symtab_cptr();

      if (idp->defn.key == PROC_DEFN ||
          idp->defn.key == FUNC_DEFN) exec_routine_call(idp);
      else exec_assignment_statement(idp);
      break;
    }
    case BEGIN: {
      exec_compound_statement();
      break;
    }
    case CASE: {
      exec_case_statement();
      break;
    }
    case IF: {
      exec_if_statement();
      break;
    }
    case REPEAT: {
      exec_grepeat_statement();
      break;
    }
    case SEMICOLON:
    case END:
    case ELSE:
    case UNTIL: {
      break;
    }
       /* extensions for EXPRESS and ltx2x */
    case XSKIP : {
      break;
    }
    case XESCAPE : {
      break;
    }
    case XRETURN : {
      exec_return_statement();
      exit_debug("exec_statement at XRETURN");
      return(stmt_tok);
    }
    case END_OF_STATEMENTS: {
      exit_debug("exec_statement at END_OF_STATEMENTS");
      return(stmt_tok);
    }
    case ENDCODE: {
      exit_debug("exec_statement at ENDCODE");
      return(stmt_tok);
    }
/*    case ENDCODE: {          added for ltx2x to stop execution */
/*      exit_debug("exec_statement"); 
*       return; 
*      break; 
*    }
*/
    default: {
      runtime_error(UNIMPLEMENTED_RUNTIME_FEATURE);
      break;
    }
  } /* end switch */

  while (ctoken == SEMICOLON) get_ctoken();

  exit_debug("exec_statement");
  return(stmt_tok);
}                                                   /* end exec_statement  */
/***************************************************************************/



/***************************************************************************/
/* exec_return_statement()    Execute a return statement                   */
/*    at entry, ctoken = RETURN                                            */
/*    at exit, ctoken is token after RETURN                                */

exec_return_statement()
{
  entry_debug("exec_return_statement");

  get_ctoken();
/*  if (ctoken == LPAREN) exec_expression(); */
  executed_return = TRUE;

  exit_debug("exec_return_statement");
  return;
}                                             /* end EXEC_RETURN_STATEMENT */
/***************************************************************************/



/***************************************************************************/
/* exec_assignment_statement(idp)  Execute an assignment statement         */
/*                                                                         */

exec_assignment_statement(idp)
SYMTAB_NODE_PTR idp;                /* target variable id */
{
  STACK_ITEM_PTR targetp;           /* ptr to assignment target */
  TYPE_STRUCT_PTR target_tp, base_target_tp, expr_tp;
  BOOLEAN data_area;

  entry_debug("exec_assignment_statement");
  data_area = FALSE;

  /* Assignment to function id: target is first item of appropriate stack frame */
  if (idp->defn.key == FUNC_DEFN) {
    STACK_ITEM_PTR hp;
    int delta;                     /* difference in levels */

    hp = (STACK_ITEM_PTR) stack_frame_basep;
    delta = level - idp->level - 1;
    while (delta-- > 0) {
      hp = (STACK_ITEM_PTR) get_static_link((ADDRESS) hp);
    }
    targetp = (STACK_ITEM_PTR) hp;
    target_tp = idp->typep;
    get_ctoken();
  }

  /* Assignment to variable: Routine exec_variable leaves target address */
  /*                         on top of stack */
  else {
    if ((idp->typep->form == ARRAY_FORM) || (idp->typep->form == ENTITY_FORM)) {
      data_area = TRUE;
      debug_print("data_area is TRUE\n");
    }
    target_tp = exec_variable(idp, TARGET_USE);
    targetp = (STACK_ITEM_PTR) get_address(tos);

    pop();         /* pop off the target address */
  }

  base_target_tp = base_type(target_tp);

  /* Routine exec-expression leaves expression value on top of stack */
  get_ctoken();
  expr_tp = exec_expression();
  
  if (stack_flag) {
    log_print("Assignment LHS: ");
    expression_type_debug(target_tp);
    log_print("Assignment RHS: ");
    expression_type_debug(expr_tp);
  }
  

  /* do the assignment */

  exec_the_assign(targetp, target_tp, expr_tp);

  trace_data_store(idp, idp->typep, targetp, target_tp);

  exit_debug("exec_assignment_statement");
  return;
}                                         /* end exec_assignment_statement */
/***************************************************************************/



/***************************************************************************/
/* exec_the_assign(targetp, target_tp, expr_tp)  Do the actual assignment  */
/*             targetp, target_tp are the target and its type;             */
/*             expr_tp is the RHS type with its value on top of the stack. */
/*     The current token is unchanged                                      */

exec_the_assign(targetp, target_tp, expr_tp)
STACK_ITEM_PTR targetp;                 /* ptr to LHS */
TYPE_STRUCT_PTR target_tp;              /* ptr to type of LHS */
TYPE_STRUCT_PTR expr_tp;                /* ptr to type of RHS */
{
  TYPE_STRUCT_PTR base_target_tp;      /* ptr to LHS base type */
  STACK_TYPE rhstype;                  /* type on top of the stack */
  int size;
  entry_debug("exec_the_assign");

  if (is_undef(expr_tp) || is_value_undef(tos)) {
    put_undef(targetp);
    pop();
    exit_debug("exec_the_assign at undef");
    return;
  }

  rhstype = get_stackval_type(tos);
  if (expr_tp->form == ARRAY_FORM) {    /* then RHS is an array (element?) */
    if (rhstype == STKADD) {
      copy_value(tos, get_address(tos));
    }
  }

  base_target_tp = base_type(target_tp);

  if ((target_tp == real_typep) && (base_type(expr_tp) == integer_typep)) {
    /* real := integer */
    put_real(targetp, (XPRSAREAL) get_integer(tos));
  }

  else if (target_tp == logical_typep) {
      /* logical := logical */
    put_logical(targetp, get_logical(tos));
  }

  else if (target_tp->form == STRING_FORM && expr_tp->form == STRING_FORM) {
       /* string := string */
     exec_string_assign((STACK_ITEM_PTR) targetp);
  }

  else if (target_tp->form == ARRAY_FORM) {
    if (base_type(expr_tp) == target_tp->info.array.elmt_typep) { /* array := el */
      copy_value(targetp, tos);
    }
    else {             /* assume array := array */
      ICT *ptr1 = (ICT *) targetp;
      ICT *ptr2 = get_address(tos);
      size = target_tp->size;
      while (size--) *ptr1++ = *ptr2++;
    }
  }

  else if (target_tp->form == ENTITY_FORM ) {
    /* entity := entity */
    ICT *ptr1 = (ICT *) targetp;
    ICT *ptr2 = get_address(tos);
    size = target_tp->size;
    while (size--) *ptr1++ = *ptr2++;
  }
  else if ((base_target_tp == integer_typep) ||
           (target_tp->form == ENUM_FORM)) {
    /* Range check assignment to integer or enumeration subrange */
    if ((target_tp->form == SUBRANGE_FORM) &&
        ((get_integer(tos) < target_tp->info.subrange.min) ||
         (get_integer(tos) > target_tp->info.subrange.max))) {
      runtime_error(VALUE_OUT_OF_RANGE);
    }

    /* integer := integer */
    /* enumeration := enumeration */
    put_integer(targetp, get_integer(tos));
  }

  else {
    /* real := real */
    put_real(targetp, get_real(tos));
  }

  pop();    /* pop expression value */

  exit_debug("exec_the_assign");
  return;
}                                                   /* end EXEC_THE_ASSIGN */
/***************************************************************************/



/***************************************************************************/
/* exec_string_assign    Execute string := string                          */
/*                                                                         */

exec_string_assign(targetp)
STACK_ITEM_PTR targetp;             /* the LHS */
{
  STRING rhs;                        /* the RHS */
  STRING lhs;
  int num;
  int maxchrs;
  entry_debug("exec_string_assign");

  rhs = get_stacked_string(tos);    /* top of stack points to the string */
  free(targetp->value.string);
  num = strlen(rhs);
  sprintf(dbuffer, "strlen(str) = %d, str = %s\n", num, rhs);
  debug_print(dbuffer);
  lhs = alloc_bytes(num+1);
  sprintf(dbuffer, "lhs = %d", lhs);
  debug_print(dbuffer);
  strcpy(lhs, rhs);
  sprintf(dbuffer, ", str = %s\n", lhs);
  debug_print(dbuffer);
  
  put_string(targetp, lhs);
/*  set_string(targetp, rhs); */

  exit_debug("exec_string_assign");
  return;
}                                                /* end EXEC_STRING_ASSIGN */
/***************************************************************************/



/***************************************************************************/
/* set_string(var_idp, str)    Attaches string str to variable             */

set_string(var_idp, str)
SYMTAB_NODE_PTR var_idp;           /* variable in the symbol table */
STRING str;                        /* the string */
{
  int num;
  int maxchrs = 527;
  TYPE_STRUCT_PTR strtyp;
  entry_debug("set_string (l2xixstm.c)");

  sprintf(dbuffer, "var_idp = %d\n", var_idp);
  debug_print(dbuffer);
  num = strlen(str);
  sprintf(dbuffer, "num = strlen(str) = %d\n", num);
  debug_print(dbuffer);
  debug_print(str);
  strtyp = var_idp->typep;
/*  maxchrs = var_idp->typep->info.string.max_length; */
/*  maxchrs = strtyp->info.string.max_length; */
  sprintf(dbuffer, "\nmaxchrs = %d\n", maxchrs);
  debug_print(dbuffer);
  if (num > maxchrs) {
    runtime_error(RUNTIME_STRING_TOO_LONG);
    free(var_idp->info);
    var_idp->info = alloc_bytes(maxchrs + 1);
    strncpy(var_idp->info, str, maxchrs);
    var_idp->info[maxchrs] = '\0';
    strtyp->info.string.length = maxchrs;
  }
  else {
/*    free(var_idp->info); */
    var_idp->info = alloc_bytes(num+1);
    strcpy(var_idp->info, str);
/*    strtyp->info.string.length = num; */
  }

  exit_debug("set_string");
}                                                        /* end SET_STRING */
/***************************************************************************/



/***************************************************************************/
/* exec_routine_call(rtn_idp)  Execute procedure or function call.         */
/* return pointer to the type structure                                    */

TYPE_STRUCT_PTR exec_routine_call(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                     /* routine id */
{
  TYPE_STRUCT_PTR exec_declared_routine_call();
  TYPE_STRUCT_PTR exec_standard_routine_call();
  entry_debug("exec_routine_call");

  if (rtn_idp->defn.info.routine.key == DECLARED) {
    exit_debug("exec_routine_call");
    return(exec_declared_routine_call(rtn_idp));
  }
  else {
    exit_debug("exec_routine_call");
    return(exec_standard_routine_call(rtn_idp));
  }

}                                                /* end exec_routine_call  */
/***************************************************************************/



/***************************************************************************/
/* exec_declared_routine_call(rtn_idp)  Execute a call to a declared       */
/*                                      function or procedure              */
/* return pointer to the type structure                                    */

TYPE_STRUCT_PTR exec_declared_routine_call(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;                     /* routine id */
{
  int old_level = level;                        /* level of caller */
  int new_level = rtn_idp->level + 1;           /* level of callee */
  STACK_ITEM_PTR new_stack_frame_basep;
  STACK_ITEM_PTR hp;                   /* ptr to frame header */
  entry_debug("exec_declared_routine_call");

  /* set up stack frame of callee */
  new_stack_frame_basep = tos + 1;
  push_stack_frame_header(old_level, new_level);

  /* push parameter values onto the stack */
  get_ctoken();
  if (ctoken == LPAREN) {
    exec_actual_parms(rtn_idp);
    get_ctoken();   /* the token after the RPAREN */
  }

  /* set the return address in the new stack frame, and execute callee */
  level = new_level;
  stack_frame_basep = new_stack_frame_basep;
  hp = stack_frame_basep;
/*  put_address(hp->return_address, (code_segmentp - 1)); */
  put_return_address(hp, (code_segmentp - 1));
/*  execute(rtn_idp);      changed this call for EXPRESS */
  exec_algorithm(rtn_idp);

  /* return from callee */
  level = old_level;
  get_ctoken();    /* first token after return */

  exit_debug("exec_declared_routine_call");
  return(rtn_idp->defn.key == PROC_DEFN ? NULL : rtn_idp->typep);

}                                       /* end exec_declared_routine_call  */
/***************************************************************************/



/***************************************************************************/
/* exec_actual_parms(rtn_idp)  Push the values of the actual parameters    */
/*                             onto the stack                              */

exec_actual_parms(rtn_idp)
SYMTAB_NODE_PTR rtn_idp;           /* id of callee routine */
{
  SYMTAB_NODE_PTR formal_idp;           /* formal param id */
  TYPE_STRUCT_PTR formal_tp, actual_tp;
  entry_debug("exec_actual_parms");
  
  /* loop to execute actual params */
  for (formal_idp = rtn_idp->defn.info.routine.parms;
       formal_idp != NULL;
       formal_idp = formal_idp->next) {
    formal_tp = formal_idp->typep;
    get_ctoken();

    /* value parameter */
    if (formal_idp->defn.key == VALPARM_DEFN) {
      actual_tp = exec_expression();

      /* Range check for a subrange formal param */
      if (formal_tp->form == SUBRANGE_FORM) {
        TYPE_STRUCT_PTR base_formal_tp = base_type(formal_tp);
        XPRSAINT value;

        value = get_integer(tos);
        if ((value < formal_tp->info.subrange.min) ||
            (value > formal_tp->info.subrange.max)) {
          runtime_error(VALUE_OUT_OF_RANGE);
        }
      }
     
      else if ((formal_tp == real_typep) &&
               (base_type(actual_tp) == integer_typep)) {
        /* real formal := integer actual */
        put_real(tos, (XPRSAREAL) get_integer(tos));
      }
      
     if ((formal_tp->form == ARRAY_FORM) ||
         (formal_tp->form == ENTITY_FORM)) {
       /* formal param is array or entity. Make a copy */
        int size = formal_tp->size;
        ICT *ptr1 = alloc_array(ICT, size);
        ICT *ptr2 = get_address(tos);      /* ??????????????????? */
        ICT *save_ptr = ptr1;

        while (size--) *ptr1++ = *ptr2++;
        put_address(tos, save_ptr);
      }
    } /* end value param */

    /* a VAR parameter */
    else {
      SYMTAB_NODE_PTR idp = get_symtab_cptr();
      exec_variable(idp, VARPARM_USE);
    }

  } /* end for loop */

  exit_debug("exec_actual_parms");
}                                                /* end exec_actual_parms  */
/***************************************************************************/



/***************************************************************************/
/* exec_compound_statement()  Execute a compound statement                 */
/*                                                                         */

exec_compound_statement()
{
  entry_debug("exec_compound_statement");

  get_ctoken();
  while (ctoken != END) exec_statement();
  get_ctoken();

  exit_debug("exec_compound_statement");
  return;
}                                          /* end exec_compound_statement  */
/***************************************************************************/



/***************************************************************************/
/* exec_case_statement()  Execute a CASE statement                         */
/*                        CASE <expr> OF                                   */
/*                           <case-branch>                                 */
/*                        END                                              */

exec_case_statement()
{
  XPRSAINT case_expr_value;                 /* CASE expr value */
  XPRSAINT case_label_count;                /* CASE label count */
  XPRSAINT case_label_value;                /* CASE label value */
  ADDRESS branch_table_location;       /* branch table address */
  ADDRESS case_branch_location;        /* CASE branch address */
  TYPE_STRUCT_PTR case_expr_tp;        /* CASE expr type */
  BOOLEAN done = FALSE;
  BOOLEAN found_otherwise = FALSE;
  ADDRESS otherwise_location;
  entry_debug("exec_case_statement");

  get_ctoken();               /* token after CASE */
  branch_table_location = get_address_cmarker();

  /* evaluate the CASE expr */
  get_ctoken();
  case_expr_tp = exec_expression();
  case_expr_value = get_integer(tos);
  pop();         /* expression value */

  /* search the branch table for the expr value */
  code_segmentp = branch_table_location;
  get_ctoken();
  case_label_count = get_cinteger();
  while (!done && case_label_count--) {
    case_label_value = get_cinteger();
    case_branch_location = get_caddress();
    done = case_label_value == case_expr_value;
    if (case_label_value == XOTHERWISE) {
      found_otherwise = TRUE;
      otherwise_location = case_branch_location;
    }
  }

  /* if found, goto the appropriate CASE branch */
  if (case_label_count >= 0) {
    code_segmentp = case_branch_location;
    get_ctoken();
    exec_statement(); 
    

    code_segmentp = get_address_cmarker();
    get_ctoken();
  }
  else if (found_otherwise) {
    code_segmentp = otherwise_location;
    get_ctoken();
    exec_statement();

    code_segmentp = get_address_cmarker();
    get_ctoken();
  }
  else {
    runtime_error(INVALID_CASE_VALUE);
  }

  exit_debug("exec_case_statement");
  return;
}                                               /* end exec_case_statement */
/***************************************************************************/





/***************************************************************************/
/* exec_if_statement()  Execute an IF statement                            */
/*                      IF <expr> THEN <stmt> END_IF                       */
/*               or                                                        */
/*                      IF <expr> THEN <stmt> ELSE <stmt> END_IF           */

exec_if_statement()
{
  ADDRESS false_location;               /* address of false branch */
  BOOLEAN test;
  entry_debug("exec_if_statement");

  get_ctoken();               /* token after if */
  false_location = get_address_cmarker();

  /* evaluate the boolean expression */
  get_ctoken();
  exec_expression();
  test = get_logical(tos) == TRUE_REP;
  pop();                     /* boolean value */

  if (test) {    /* do the TRUE branch */
    get_ctoken();        /* token after THEN */
    while (ctoken != ELSE && ctoken != XEND_IF) exec_statement();
      if (ctoken == ELSE) {
        get_ctoken();
        code_segmentp = get_address_cmarker();
        get_ctoken();       /* token after false stmt */
    }
  }
  else {           /* do the ELSE branch if there is one */
    code_segmentp = false_location;
    get_ctoken();

    if (ctoken == ELSE ) {
      get_ctoken();
      get_address_cmarker();      /* skip the address marker */

      get_ctoken();
      while(ctoken != XEND_IF) exec_statement();
    }
  }
  get_ctoken(); /* after the END_IF */


  exit_debug("exec_if_statement");
  return;
}                                                 /* end exec_if_statement */
/***************************************************************************/



/***************************************************************************/
/* exec_grepeat_statement()  Execute an EXPRESS REPEAT statement           */
/*    REPEAT [ <inc_control> ] <while_control> <until_control>             */
/*           <stmt-list> END_REPEAT;                                       */
/*  at entry: ctoken is REPEAT                                             */
/*  at exit:  ctoken is after END_REPEAT;                                  */

exec_grepeat_statement()
{
  SYMTAB_NODE_PTR control_idp;            /* control var id */
  TYPE_STRUCT_PTR control_tp;             /* control var type */
  STACK_ITEM_PTR targetp;                 /* ptr to control target */
  ADDRESS loop_start_location;            /* address of start of loop */
  ADDRESS loop_end_location;              /* address of end of loop */
  ADDRESS until_start_location;
  ADDRESS to_start_location;
  ADDRESS while_start_location;
  ADDRESS statements_start_location;
  BOOLEAN loop_done = FALSE;
  BOOLEAN is_increment_control = FALSE;   /* TRUE iff there is an inc. control */
  int control_value;                      /* value of control var */
  int initial_value, final_value, delta_value;
  TOKEN_CODE stmt_tok;
  entry_debug("exec_grepeat_statement (l2xixstm.c)");

  /* the first time through */
  get_ctoken();                   /* code (address marker) token after REPEAT */
  loop_end_location = get_address_cmarker();
    sprintf(dbuffer, "loop_end_location = %d\n", loop_end_location);
    debug_print(dbuffer);
  get_ctoken();                   /* source token after REPEAT */

  if (ctoken == FOR) {            /* increment control */
    is_increment_control = TRUE;
    get_ctoken();                 /* IDENTIFIER for the variable */
     /* get address of control var's stack item */
    control_idp = get_symtab_cptr();
    control_tp = exec_variable(control_idp, TARGET_USE);
    targetp = (STACK_ITEM_PTR) get_address(tos);
    pop();                             /* pop control var's address */

    /* evaluate the initial expression */
    get_ctoken();
    exec_expression();
    initial_value = get_integer(tos);
    pop();                /* initial value */
    put_integer(targetp, initial_value);
    control_value = initial_value;

    /* evaluate the final expression */
    get_ctoken();                        
    to_start_location = code_segmentp -1;
      sprintf(dbuffer, "to_start_location = %d\n", to_start_location);
      debug_print(dbuffer);
    exec_expression();
    final_value = get_integer(tos);
    pop();                /* final value */

    /* get the increment */
    get_ctoken();
    exec_expression();
    delta_value = get_integer(tos);
    pop();                /* delta value */
      /* check the bound */
      if ((delta_value >= 0 && control_value > final_value) ||
          (delta_value < 0  && control_value < final_value)) {
        code_segmentp = loop_end_location;
        get_ctoken();
        loop_done = TRUE;
      }
      if (loop_done) {
        exit_debug("exec_grepeat_statement");
        return;
      }
  }
  
  /* check the WHILE condition */
  get_ctoken();                
  while_start_location = code_segmentp -1;   
      sprintf(dbuffer, "while_start_location = %d\n", while_start_location);
      debug_print(dbuffer);
  exec_expression();
  if (get_logical(tos) == FALSE_REP) {    /* finished */
    code_segmentp = loop_end_location;
    get_ctoken();
    loop_done = TRUE;
  }
  pop();                             /* the WHILE value */
  if (loop_done) {
    exit_debug("exec_grepeat_statement");
    return;
  }

  /* skip the UNTIL condition */
  get_ctoken();
  until_start_location = code_segmentp -1;
      sprintf(dbuffer, "until_start_location = %d\n", until_start_location);
      debug_print(dbuffer);
  while (ctoken != STATEMENT_MARKER) get_ctoken();
  statements_start_location = code_segmentp -1;
      sprintf(dbuffer, "statements_start_location = %d\n", statements_start_location);
      debug_print(dbuffer);

  /* do the statements */
  do {
    stmt_tok = exec_statement();
    if (stmt_tok == XSKIP) {
      code_segmentp = until_start_location;
      break;
    }
    else if (stmt_tok == XESCAPE) {
      code_segmentp = loop_end_location;
      get_ctoken();
      loop_done = TRUE;
      pop();
      exit_debug("exec_grepeat_statement");
      return;
    }
  }  while (ctoken != XEND_REPEAT);

  /* This finishes the first pass, do subsequent passes */
  do {
    /* check the UNTIL expression */
    code_segmentp = until_start_location;
    get_ctoken();
    exec_expression();
    if (get_logical(tos) == TRUE_REP) {    /* finished */
      code_segmentp = loop_end_location;
      get_ctoken();
      loop_done = TRUE;
    }
    pop();                                 /* the UNTIL value */
    if (loop_done) {
      exit_debug("exec_grepeat_statement");
      return;
    }

    /* increment control now */
    if (is_increment_control) {
      /* perform the increment */
      control_value = get_integer(targetp) + delta_value;
      put_integer(targetp, control_value);
      /* do the check */
      code_segmentp = to_start_location;
      get_ctoken();
      exec_expression();
      get_integer(tos);
      if ((delta_value >= 0 && control_value > final_value) ||
          (delta_value < 0  && control_value < final_value)) {
        code_segmentp = loop_end_location;
        get_ctoken();
        loop_done = TRUE;
      }
      pop();                     /* the to value */
      if (loop_done) {
        exit_debug("exec_grepeat_statement");
        return;
      }
    }
     
      /* check the WHILE */
    code_segmentp = while_start_location;
    get_ctoken();
    exec_expression();
    if (get_logical(tos) == FALSE_REP) {
      code_segmentp = loop_end_location;
      get_ctoken();
      loop_done = TRUE;
    }
    pop();                                 /* the WHILE value */
    if (loop_done) {
      exit_debug("exec_grepeat_statement");
      return;
    }

    /* and now back to executing the statements */
    code_segmentp = statements_start_location;
    get_ctoken(); 
    do {
      exec_statement();
    } while (ctoken != XEND_REPEAT);
    /* start again checking the UNTIL condition */
    code_segmentp = until_start_location;
  }   while(TRUE);


  exit_debug("exec_grepeat_statement");
  return;

}                                            /* end EXEC_GREPEAT_STATEMENT */
/***************************************************************************/