/* 2155, Tue 16 May 00

   SRL.C:  First attempt at an SRL compiler

   Copyright (C) 1998-2002 by Nevil Brownlee,
   CAIDA | University of Auckland */

/*
 * $Log: srl.c,v $
 * Revision 1.1.1.2.2.11  2002/02/23 01:57:41  nevil
 * Moving srl examples to examples/ directory.  Modified examples/Makefile.in
 *
 * Revision 1.1.1.2.2.6  2000/08/08 19:44:59  nevil
 * 44b8 release
 *
 * Revision 1.1.1.2.2.4  2000/06/06 03:38:32  nevil
 * Combine NEW_ATR with TCP_ATR, various bug fixes
 *
 * Revision 1.1.1.2.2.1  2000/01/12 02:57:15  nevil
 * Implement 'packet pair matched' turnaroundtime distribution attributes.
 * Fix ASN-related bugs in NeTraMet, distribution-related bugs in fd_filter.
 *
 * Revision 1.1.1.2  1999/10/03 21:06:34  nevil
 * *** empty log message ***
 *
 * Revision 1.1.1.1.2.7  1999/09/22 05:34:09  nevil
 * Implement command-line defines
 * - Initialise scanner in init_symbol_table()
 * - Add get_command_define() to scanner.  This dummies up a define
 *      statement then calls push_include to invoke it
 * - Call get_command_define from main when we see a -D option
 *
 * Revision 1.1.1.1.2.6  1999/04/26 05:20:57  nevil
 * -Allow redeclaration of 'built-ins,' i.e. well-known ports, address
 *    families and transport types.  A warning is given telling the
 *    user what was redclared.
 * -Fix bug in checking of subroutine calls.  If a call appears before
 *    the subroutine declaration, it must have an integer label matching
 *    the highest one in the subroutine.  This is because the compiler
 *    doesn't emit dummy rules (to allow for returns) until after the
 *    declaration.
 * -Warn user that NeMaC doesn't handle return labels > 200.
 * -Warn user that NeMaC requires one SET and one FORMAT statement,
 *    and that every program should have at least one COUNT statement.
 *
 * Revision 1.1.1.1.2.5  1999/03/31 03:01:51  nevil
 * Added better error messages (and error recovery):
 *   Attempt to redefine reserved word, protocol, port, address family
 *   Char constants must have just one character
 * Corrected err_msg() to avoid msg buffer overflow when printing
 *   an error message from within the body of a define.
 * Improved error reovery for invald tokens in subroutine declarations
 *   and call statements.
 *
 * Revision 1.1.1.1.2.4  1999/01/28 03:12:09  nevil
 * Mis-spelt attribute names are now correctly reported as errors
 *
 * Revision 1.1.1.1.2.3  1999/01/27 04:26:17  nevil
 * Minor corrections to fix compiler warnings
 *
 * Revision 1.1.1.1.2.2  1999/01/08 01:38:41  nevil
 * Distribution file for 4.3b7
 *
 * Revision 1.1.1.1.2.1  1998/12/16 02:59:09  nevil
 * Make compiler distinguish between 'save attrib' and 'save attrib = 0'
 * These both used to produce a rule which saved the whole attrib value!
 *
 * Revision 1.1.1.1  1998/11/16 03:57:32  nevil
 * Import of NeTraMet 4.3b3
 *
 * Revision 1.1.1.1  1998/11/16 03:22:03  nevil
 * Import of release 4.3b3
 *
 * Revision 1.1.1.1  1998/10/28 20:31:33  nevil
 * Import of NeTraMet 4.3b1
 *
 * Revision 1.1.2.2  1998/10/27 04:39:19  nevil
 * 4.3b1 release
 *
 * Revision 1.2  1998/10/21 09:17:32  nguba
 * Now compiler only displays stats about errors and warnings when
 * either an error or a warning have occurred.  It now exits with the
 * right return value when un/successful (doesn't accept the emacs
 * compile.el anymore)
 *
 * Revision 1.1.2.1  1998/10/22 21:40:37  nevil
 * Moved srl from src/manager to its own subdirectory
 *
 * Revision 1.1.3.2  1998/10/18 23:44:13  nevil
 * Added Nicolai's patches, some 'tidying up' of the source
 *
 * Revision 1.1.3.1  1998/10/13 02:48:26  nevil
 * Import of Nicolai's 4.2.2
 *
 * Revision 1.1.1.1  1998/08/24 12:09:29  nguba
 * NetraMet 4.2 Original Distribution
 *
 * Revision 1.2  1998/07/21 00:43:57  rtfm
 * Change attrib numbers for 'New Attribs' I-D
 * First release version of SRL
 */

#if HAVE_CONFIG_H
#include <ntm_conf.h>
#endif

#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include <string.h>
#if HAVE_MALLOC_H
# include <malloc.h>
#endif
#include <sys/time.h>

#define SRLEXT
#include "rtfm_atr.h"
#include "srl.h"

char *ver = "SRL compiler, version " ver_str;

void q2(int x)  /* For debugging breakpoint */
{
   }

static int n_sets, n_formats, n_counts;

void check_mask(struct pt_node *a)
{
   int k;  unsigned char ac[50];
   for (k = 0; k != sizeof(a->d.operand.attrib); ++k) {
      if ((a->d.operand.value[k] & ~a->d.operand.mask[k]) != 0) {
         sprintvalmsk(ac, a);
         err_msg(ET_WARN, "%s value has bits not covered by mask", ac);
         /* Don't try to correct this by stripping bad bits here! */
         break;
         }
      }
   }

struct pt_node *operand(int attrib)
{
   struct pt_node *op;
   if (testing) printf(". . . operand(%d)\n", attrib);
   op = alloc_node();
   op->type = NT_OPERAND;
   op->d.operand.attrib = attrib;

   if (!get_value(op->d.operand.value, attrib)) {
      err_msg(ET_ERR, "Value expected");
      if (toktype != TOK_SPECIAL || toksubtype != ')')
         next();
      }
   else {
      next();
      if (toktype == TOK_SPECIAL &&
            (toksubtype == '&' || toksubtype == '/')) {
         if (toksubtype == '/') {
            next();
            if (toktype == TOK_NUMBER)
               mask_from_width(op->d.operand.mask, get_number());
            else err_msg(ET_ERR, "Width expected");
            }
         else if (toksubtype == '&') {
            next();
            if (!get_value(op->d.operand.mask, attrib))
               err_msg(ET_ERR, "Mask expected");
            }
         check_mask(op);
         next();
         }
      else get_default_mask(op->d.operand.mask, attrib);
      }
   if (testing > 1) printf(". . . operand() exit, token=%s\n", token);
   return op;
   }

struct pt_node *operand_list(int attrib)
{
   struct pt_node *op, *nop;
   if (testing) printf(". . . operand_list(%d)\n", attrib);
   if (toktype == TOK_SPECIAL && toksubtype == '(') {  /* Operand list */
      next();
      op = operand(attrib);
      while (toktype == TOK_SPECIAL && toksubtype == ',') {
         next();
         nop = alloc_node();
         nop->type = NT_BINOP;
         nop->d.binop.operator = SC_SAMEOR;
         nop->left = op;
         nop->right = operand(attrib);
         op = nop;
         }
      if (toktype != TOK_SPECIAL && toksubtype != ')')
         err_msg(ET_ERR, ") expected");
      next();
      }
   else op = operand(attrib);  /* Single operand */
   if (testing > 1) printf(". . . operand_list() exit, token=%s\n", token);
   return op;
   }

struct pt_node *expression(void);

struct pt_node *factor(void)
{
   struct pt_node *op;
   struct symbol *sp;
   int attrib;

   if (testing) printf(". . . factor()\n");
   attrib = 0;
   if (toktype == TOK_ATTRIB) {
      if (!if_OK(attrib = toksubtype))
         err_msg(ET_ERR, "This attribute can't be tested in an IF");
      }
   else if (toktype == TOK_SYMBOL) {
      sp = &st[st_ix];
      if (sp->symtype == ST_ADDRESS || sp->symtype == ST_VARIABLE) 
         attrib = param_attrib(sp);
      else err_msg(ET_ERR, "Attribute expected");
      }

   if (attrib != 0) {
      next();
      if (toktype != TOK_SPECIAL || toksubtype != SC_EQUAL)
         err_msg(ET_ERR, "== expected");
      if (toktype == TOK_SPECIAL &&
            (toksubtype == SC_EQUAL || toksubtype == '='))
         next();
      op = operand_list(attrib);
      }
   else {
      if (toktype == TOK_SPECIAL && toksubtype == '(') {
         next();
         op = expression();
         if (toktype == TOK_SPECIAL && toksubtype == ')')
            next();
         else err_msg(ET_ERR, ") expected");
         }
      else {
         err_msg(ET_ERR, "Factor expected");
         op = NULL;
         }
   }
   if (testing > 1) printf(". . . factor() exit, token=%s\n", token);
   return op;
   }

struct pt_node *term(void)
{
   struct pt_node *op, *nop;
   if (testing) printf(". . . term()\n");
   op = factor();
   while (toktype == TOK_SPECIAL && toksubtype == SC_LAND) {  /* && */
      if (testing) printf(". . . term() loop\n");
      next();
      nop = alloc_node();
      nop->type = NT_BINOP;
      nop->left = op;
      nop->d.binop.operator = SC_LAND;
      nop->right = factor();
      op = nop;
      }
   if (testing > 1) printf(". . . term() exit, token=%s\n", token);
   return op;
   }

struct pt_node *expression(void)
{
   struct pt_node *op, *nop;
   if (testing) printf(". . . expression()\n");
   op = term();
   while (toktype == TOK_SPECIAL && toksubtype == SC_LOR) {  /* || */
      if (testing) printf(". . . expression() loop\n");
      next();
      nop = alloc_node();
      nop->type = NT_BINOP;
      nop->left = op;
      nop->d.binop.operator = SC_LOR;
      nop->right = term();
      op = nop;
      }
   if (testing > 1) printf(". . . expression() exit, token=%s\n", token);
   return op;
   }


void find_arg_sep(void)
{
   if (testing) printf(". . . find_arg_sep()\n");
   for (;;) {
      if (toktype == TOK_EOF) return;
      if (toktype == TOK_SPECIAL && 
            (toksubtype == ',' || toksubtype == ')')) {
         return;
         }
      else if (toktype == TOK_NUMBER)
         get_number();  /* Move past the number */
      next();
      }
   }

void find_semi(void)
{
   if (testing) printf(". . . find_semi()\n");
   for (;;) {
      if (toktype == TOK_EOF) return;
      if (toktype == TOK_SPECIAL && 
            (toksubtype == ';' || toksubtype == '}')) {
         next();  /* Get next token after ; or } */
         return;
         }
      else if (toktype == TOK_NUMBER)
         get_number();  /* Move past the number */
      next();
      }
   }

int find_res_word(int word)
{
   if (testing) printf(". . . find_res_word(%d)\n", word);
   for (;;) {
      if (toktype == TOK_EOF) return 0;
      if (toktype == TOK_NUMBER)
         get_number();  /* Move past the number */
      else if (word == 0) {  /* Find something that could start a statement */
         if (toktype == TOK_SPECIAL && toksubtype == '{') return 1;
         if (toktype == TOK_RSVWD) return 1;
         }
      else if (toktype == TOK_RSVWD  /* Find specified reserved word */
            && toksubtype == word) {
         next();  /* Get next token after word */
         return 1;
         }
      next();
      }
   }

void check_semi(void)
{
   if (toktype != TOK_SPECIAL || toksubtype != ';')
      err_msg(ET_ERR, "; expected");
   find_semi();
   }


static int start_opt_lev;  /* Optimise level (from command line) */

void set_opt_level(void)  /* Let user give compiler some hints */
{
   next();
   if (toktype == TOK_SPECIAL && toksubtype == '*') {
      emit_opt_level(-1);  /* Mark break between optimised groups */
      next();
      }
   else if (toktype == TOK_SPECIAL && toksubtype == ';')
      emit_opt_level(optimise_level = start_opt_lev);
   else if (toktype == TOK_NUMBER) {
      emit_opt_level(optimise_level = get_number());
      next();
      }
   else err_msg(ET_WARN, "integer, * or ; expected");
   check_semi();
   }


static int
   a_ln = 0,  /* Start of an action */
   n_ln = 0,  /* Next IF clause */
   g_ln = 0,  /* End of an IF or CALL group */
   u_ln = 0;  /* Name for a user symbol */

void make_label(char *buf, int kind)
{
   int n;
   if (kind == 'a') n = ++a_ln;
   else if (kind == 'n') n = ++n_ln;
   else if (kind == 'g') n = ++g_ln;
   else if (kind == 'u') n = ++u_ln;
   sprintf(buf, "%c%d", kind, n);
   }

void set_st_name(struct symbol *sp, int dummy)
{
   if (sp->name[0] != '\0') return;  /* Already set */
   if (asmint && !dummy) strcpy(sp->name, id_table[sp->idx].id);
   else make_label(sp->name, 'u');
   }

struct symbol *block_check(int stx, int type)
{
   struct symbol *sp;

   sp = &st[stx];
   if (sp->symtype == ST_SYMBOL) {  /* New symbol */
      sp->symtype = type;
      set_st_name(sp, 0);
      }
   else {
      if (type == ST_LABEL) {
         if (subr_stx != 0 && stx > subr_stx)
            err_msg(ET_ERR, "Already declared inside SUBROUTINE");
         else if (subr_stx == 0)
            err_msg(ET_ERR, "Already declared");
         add_symbol(type);  /* Declare new label */
         sp = &st[stx = st_top-1];
         set_st_name(sp, 1);
         }
      else {  /* Subroutine parameter */
         if (stx < subr_stx) {  /* Declared in enclosing block */
            add_symbol(type);  /* Declare new symbol in this block */
            sp = &st[stx = st_top-1];
            }
         else err_msg(ET_ERR, "Already declared in SUBROUTINE");
         }
      }
   if (sp->symtype != type)
      err_msg(ET_ERR, "%s expected", sym_types[type]);
   return sp;
   }

void set_subr_n_returns(int r)
{
   int n = st[subr_stx].d.sub.n_returns;
   if (r > n) st[subr_stx].d.sub.n_returns = r;

   if (r > MXRETURNOFFSET) err_msg(ET_WARN, 
      "NeMaC doesn't allow return labels > %d", MXRETURNOFFSET);
   }

void check_subrs_declared(int blk_stx)
{
   int j;
   for (j = st_top-1; j >= blk_stx; --j) {
      if (st[j].symtype == ST_SUBROUTINE &&
            strcmp(st[j+1].name, "<<subr>>") != 0)
         err_msg(ET_ERR, "No SUBROUTINE declaration for %s",
            id_table[st[j].idx].id);
      }
   }

void Statement(void);

void IF_statement(char *outer_grp_lbl)
{
   struct pt_node *op;
   char nbuf[IDENT_LN+1], lbuf[IDENT_LN+1];
   char a_lbl[IDENT_LN+1], n_lbl[IDENT_LN+1];
   char g_lbl[IDENT_LN+1], *grp_lbl;
   struct symbol *sp;
   int which;  char *action, *next_if;
   unsigned long n;
   int save_reqd, done, single;

   if (testing) printf(". . . IF_statement()\n");
   if (outer_grp_lbl == NULL) {
      make_label(g_lbl, 'g');  /* Make this IF group's closing label */
      grp_lbl = g_lbl;
      }
   else grp_lbl = outer_grp_lbl;

   next();
   op = expression();   
   set_mxd_pt(op);  set_grpsz_pt(op);
   if (verbose) {
      printf("+++ expression tree:\n");
      print_pt(op, 0, "");
      printf("---\n");
      }
   if (op == NULL)  /* Invalid expression */
      find_res_word(0);  /* Resync on any reserved word */

   if (toktype == TOK_RSVWD && toksubtype == RW_SAVE) {
      nextnb();  /* 1-char lookahead */
      if (ic == ';') {  /* SAVE ; */
         next();  next();
         single = 1;  which = RW_SAVE;  action = grp_lbl;
         done = 1;
         }
      else if (ic == ',') {  /* SAVE , */
         next();  next();
         save_reqd = 1;  single = 0;
         done = 0;
         }
      else {  /* SAVE statement */
         save_reqd = 0;  single = 0;  
         done = 0;
         }
      }
   else if (toktype == TOK_SPECIAL && toksubtype == ';') {  /* Null stmt */
      next();
      single = 1;  which = RW_EXIT;  action = grp_lbl;
      done = 1;
      }
   else save_reqd = done = 0;

   if (!done) {  /* Action not yet determined */
      if (toktype == TOK_RSVWD) {
         switch(toksubtype) {
         case RW_EXIT:
            next();
            if (toktype == TOK_SYMBOL) {  /* Get the label */
               single = 1;
               which = save_reqd ? RW_SAVE : RW_EXIT;
               sp = &st[st_ix];
               if (sp->symtype != ST_LABEL) {
                  err_msg(ET_ERR, "Undeclared label");
                  sp = block_check(st_ix, ST_LABEL);  /* Declare it */
                  action = NULL;
                  }
               else strcpy(action = lbuf, sp->name);
               if (subr_stx != 0 && st_ix < subr_stx)
                  err_msg(ET_ERR, "Can't EXIT to label outside SUBROUTINE");
               next();  check_semi();
               }
            else err_msg(ET_ERR, "Exit label expected");
            break;
         case RW_IGNORE:
            single = 1;  which = RW_IGNORE;  action = NULL;
            next();  check_semi();
            break;
         case RW_NOMATCH:
            single = 1;  which = RW_NOMATCH;  action = NULL;
            next();  check_semi();
            break;
         case RW_RETURN:
            if (save_reqd) single = 0;
            else {
               if (subr_stx == 0)
                  err_msg(ET_ERR, "Return only allowed inside a subroutine");
               next();
               single = 1;  which = RW_RETURN;
               if (toktype == TOK_NUMBER) {
                  sprintf(nbuf, "%lu", n = get_number());
                  action = nbuf;
                  set_subr_n_returns(n);
                  next();
                  }
               else action = id_table[st[subr_stx].idx].id;
               check_semi();
               }
            break;
         default:
            single = 0;
            break;
            }
         }
      else single = 0;
      }		    

   make_label(n_lbl, 'n');  /* Make this IF action's closing label */
   if (single)
      emit_expression(op, which, action, n_lbl);
   else {
      make_label(a_lbl, 'a');  /* Make an action label */
      emit_expression(op, save_reqd ? RW_SAVE : RW_EXIT, a_lbl, n_lbl);
      emit_IF_level(+1);
         emit_label(a_lbl);
         Statement();
         emit_goto(grp_lbl);
      emit_IF_level(-1);
      }
   emit_label(n_lbl);

   free_pt(op);  /* Finished with expression parse tree */

   if (toktype == TOK_RSVWD && toksubtype == RW_OPTIMISE)
      set_opt_level();            

   if (toktype == TOK_RSVWD && toksubtype == RW_ELSE) {
      next();
      if (toktype == TOK_RSVWD && toksubtype == RW_OPTIMISE)
         set_opt_level();

      if (toktype == TOK_RSVWD && toksubtype == RW_IF) {
         IF_statement(grp_lbl);  /* Continue this IF group */
         }
      else Statement();
      }

   if (outer_grp_lbl == NULL)
      emit_label(grp_lbl);
   }

struct pt_node *Save_statement(int emit)
{
   int attrib, action;
   struct pt_node *op;
   struct symbol *sp;

   if (testing) printf(". . . Save_statement()\n");
   if (toktype == TOK_ATTRIB) {
      if (!save_OK(attrib = toksubtype))
         err_msg(ET_ERR, "This attribute may not be SAVEd");
      }
   else if (toktype == TOK_SYMBOL) {
      sp = &st[st_ix];
      if (sp->symtype == ST_ADDRESS || sp->symtype == ST_VARIABLE) {
         attrib = param_attrib(sp);
         if (sp->symtype == ST_VARIABLE)
            err_msg(ET_ERR, "Address expected");
         }
      else err_msg(ET_ERR, "Attribute expected");
      }
   else err_msg(ET_ERR, "Attribute expected");

   if (attrib != 0) {
      action = RW_SAVE;
      next();
      if (toktype == TOK_SPECIAL &&
            (toksubtype == '/' || toksubtype == '&' || toksubtype == '=')) {
         if (toksubtype == '/') {
            next();
            op = alloc_node();
            op->type = NT_OPERAND;
            op->d.operand.attrib = attrib;
            if (toktype == TOK_NUMBER) {
               mask_from_width(op->d.operand.mask, get_number());
               next();
               }
            else err_msg(ET_ERR, "Width expected");
            }
         else if (toksubtype == '&') {
            next();
            op = alloc_node();
            op->type = NT_OPERAND;
            op->d.operand.attrib = attrib;
            if (!get_value(op->d.operand.mask, attrib))
               err_msg(ET_ERR, "Mask expected");
            else next();
            }
         else {  /* = */
            action = RW_SAVE_V;
            next();
            op = operand(attrib);
            }
         }
      else {  /* No mask or width */
         op = alloc_node();
         op->type = NT_OPERAND;
         op->d.operand.attrib = attrib;
         get_default_mask(op->d.operand.mask, attrib);
         }
      if (emit) {
         emit_imperative(op, action, NULL);
         if (op != NULL) free_node(op);
         return NULL;
         }
      else return op;
      }
   else err_msg(ET_ERR, "Attribute expected");
   return NULL;
   }

struct pt_node *Store_statement(int emit)
{
   int attrib;
   struct pt_node *op;
   struct symbol *sp;

   if (testing) printf(". . . Store_statement()\n");
   attrib = 0;
   if (toktype == TOK_ATTRIB) {
      if (!store_OK(attrib = toksubtype))
         err_msg(ET_ERR, "Variable expected");
      }
   else if (toktype == TOK_SYMBOL) {
      sp = &st[st_ix];
      if (sp->symtype == ST_ADDRESS || sp->symtype == ST_VARIABLE) {
         attrib = param_attrib(sp);
         if (sp->symtype == ST_ADDRESS)
            err_msg(ET_ERR, "Variable expected");
         }
      else err_msg(ET_ERR, "Variable expected");
      }
   else err_msg(ET_ERR, "Variable expected");

   if (attrib != 0) {
      op = alloc_node();
      op->type = NT_OPERAND;
      op->d.operand.attrib = attrib;
      op->d.operand.mask[0] = 255;
      next();
      if (toktype == TOK_SPECIAL && toksubtype == SC_ASSIGN) {
         next();
         if (toktype == TOK_NUMBER) {
            op->d.operand.attrib = FTFLOWKIND;  /* Force get_value width */
            if (!get_value(op->d.operand.value, op->d.operand.attrib)) {
               err_msg(ET_ERR, "Value expected");
               }
            else next();
            op->d.operand.attrib = attrib;
            }
         else err_msg(ET_ERR, "Value expected");
         if (emit) emit_imperative(op, RW_STORE, NULL);
         }
      else err_msg(ET_ERR, ":= expected");
      if (emit) {
         free_node(op);
         return NULL;
         }
      else return op;
      }
   return NULL;
   }

void Imperative_statement(void)
{
   struct pt_node *op;
   struct symbol *sp;
   char nbuf[IDENT_LN];
   int which;
   unsigned long n;

   if (testing) printf(". . . Imperative_statement()\n");
   which = toksubtype;
   op = NULL;
   next();

   switch(which) {
   case RW_EXIT:
      if (toktype == TOK_SYMBOL) {  /* Get the label */
         sp = &st[st_ix];
         if (sp->symtype != ST_LABEL) {
            if (sp->symtype == ST_SYMBOL)  /* New symbol */
               err_msg(ET_ERR, "Undeclared label");
            sp = block_check(st_ix, ST_LABEL);  /* Declare it */
            }
         else if (subr_stx != 0 && st_ix < subr_stx)
            err_msg(ET_ERR, "Can't EXIT to label outside SUBROUTINE");
         emit_imperative(op, RW_EXIT, sp->name);
         next();
         }
      else err_msg(ET_ERR, "Label expected");
      break;
   case RW_SAVE:
      Save_statement(1);
      break;
   case RW_COUNT:
      ++n_counts;
      emit_imperative(op, RW_COUNT, NULL);
      break;
   case RW_IGNORE:
      emit_imperative(op, RW_IGNORE, NULL);
      break;
   case RW_NOMATCH:
      emit_imperative(op, RW_NOMATCH, NULL);
      break;
   case RW_STORE:
      Store_statement(1);
      break;
   case RW_RETURN:
      if (subr_stx == 0)
         err_msg(ET_ERR, "Return only allowed inside a subroutine");
      if (toktype == TOK_NUMBER) {
         sprintf(nbuf, "%lu", n = get_number());
         emit_imperative(op, RW_RETURN, nbuf);
         set_subr_n_returns(n);
         next();
         }
      else emit_imperative(op, RW_RETURN, st[subr_stx].name);
      break;
      }
   check_semi();
   }


void Compound_statement(void)
{
   struct symbol *sp;
   int first_line = line_nbr;
   if (testing) printf(". . . Compound_statement()\n");

   sp = NULL;
   if (ic == ':') {
      if (toktype == TOK_SYMBOL) {
         sp = block_check(st_ix, ST_LABEL);
         next();  /* Move past the : */
         next();
         }
      else {
         err_msg(ET_ERR, "label expected");
         find_semi();
         }
      }

   if (toktype == TOK_SPECIAL && toksubtype == '{') {
      next();
      for (;;) {
         if (toktype == TOK_EOF) {
            err_msg(ET_ERR,
               "EOF in compound statement which began on line %d", first_line);
            return;
            }
         Statement();
         if (toktype == TOK_SPECIAL && toksubtype == '}') {
            next();
            if (sp != NULL)
               emit_label(sp->name);
            if (testing > 1 )
               printf(". . . leaving Compound_statement(s)\n");
            return;
            }
         }
      }
   else err_msg(ET_ERR, "{ expected");
   if (testing > 1) printf(". . . leaving Compound_statement(f)\n");
   }

int subr_match(int call_stx, int sub_stx, int params)
{  /* Returns 1 if st entries match */
   int k, cx,sx;
   if (params) {
      if ((k = st[call_stx].d.sub.n_params) != st[sub_stx].d.sub.n_params)
         return 0;
      for (cx = call_stx+2, sx = sub_stx+2; k != 0; ++cx, ++sx, --k) {
         if (st[cx].symtype != st[sx].symtype) return 0;
         }
      return 1;
      }
   else {  /* Compare nbr of returns */
      if (strcmp(st[call_stx+1].name, st[sub_stx+1].name) == 0)
         return 1;  /* Need a <<call>> and a <<subr>> */
      return st[call_stx].d.sub.n_returns >= st[sub_stx].d.sub.n_returns;
      }
   }

struct return_stmt_info {
   int ret_nbr;
   struct pt_node opnode;
   int which;  /* Action */
   char a_lbl[IDENT_LN+1];
   };

static int call_grp_cmp(const void *ap, const void *bp)
{
   struct return_stmt_info *a, *b;
   a = (struct return_stmt_info *)ap;
   b = (struct return_stmt_info *)bp;
   if (a->ret_nbr < b->ret_nbr) return -1;
   else if (a->ret_nbr > b->ret_nbr) return 1;
   else return 0;
   }

void Call_statement(void)
{
   struct symbol *call_sp, *sub_sp, *sp;
   int first_line, call_stx, sub_stx, arg_reg,
      params, single, which, p_type,
      call_grp_sz,   /* Nbr of return labels */
      mx_ret_value,  /* Max return label */
      lbls_this_stmt, j,k;
   unsigned long n;
   struct pt_node *op;
   struct return_stmt_info *rip;
   char g_lbl[IDENT_LN+1], a_lbl[IDENT_LN+1], 
      s_lbl[IDENT_LN+1], *target;
   struct return_stmt_info ret_info[MXCALLGRP];

   first_line = line_nbr;
   next();
   if (toktype != TOK_SYMBOL)
      err_msg(ET_ERR, "Subroutine name expected");
   else {
      sub_sp = NULL;  arg_reg = subr_reg;
      call_sp = &st[call_stx = st_ix];  /* ST entry for the symbol */
      if (call_sp->symtype == ST_SYMBOL) {  /* New symbol */
         call_sp->symtype = ST_SUBROUTINE;
         set_st_name(call_sp, 0);
         }
      else {
         sub_sp = call_sp;  sub_stx = call_stx;
         arg_reg = sub_sp->d.sub.first_param - 1;
         add_symbol(ST_SUBROUTINE);  /* New copy of subroutine entry */
         call_sp = &st[call_stx = st_top-1];  /* ST entry for the symbol */
         strcpy(call_sp->name, sub_sp->name);
         }
      start_st_block("<<call>>");
      next();
      if (toktype != TOK_SPECIAL || toksubtype != '(')
         err_msg(ET_ERR, "( expected");
      else {
         next();
         call_sp->d.sub.first_param = arg_reg+1;
         params = 0;
         if (toktype == TOK_SPECIAL &&toksubtype == ')')
            next();  /* No parameters */
         else for (;;) {
            if (toktype == TOK_EOF) break;
            if (toktype == TOK_ATTRIB) {
               which = toksubtype;
               p_type = store_OK(which) ? ST_VARIABLE : ST_ADDRESS; 
               add_argument(p_type, ++arg_reg, which);
               ++params;
               call_sp->d.sub.n_params = params;
               next();
               }
            else {
               err_msg(ET_ERR, "Attribute or Variable expected");
               find_arg_sep();
               }
            if (toktype == TOK_SPECIAL) {
               if (toksubtype == ',') {
                  next();
                  continue;
                  }
               else if (toksubtype == ')') {
                  next();
                  break;
                  }
               else err_msg(ET_ERR, ", or ) expected");
               }
            }

         if (sub_sp != NULL) {  /* Previous subroutine, check parameters */
            if (!subr_match(call_stx, sub_stx, 1))
               err_msg(ET_ERR,
                  "Call parameters don't match subroutine or previous call");
            }
         else subr_reg = arg_reg;  /* Allocate arg registers */
         emit_subr_call(call_stx);

         make_label(g_lbl, 'g');  /* Make this CALL group's closing label */
         emit_IF_level(+1);
         call_grp_sz = mx_ret_value = 0;
         for (;;) {  /* Handle the return statement list */
            if (toktype == TOK_EOF) {
               err_msg(ET_ERR,
                  "EOF in call which began on line %d", first_line);
               break;
               }

            if (toktype == TOK_RSVWD && toksubtype == RW_ENDCALL) {
               break;
               }
            if (toktype == TOK_RSVWD && toksubtype == RW_ENDSUB) {
               err_msg(ET_WARN, "CALL statement should end with ENDCALL");
               break;
               }

            lbls_this_stmt = 0;
            if (toktype != TOK_NUMBER) {
               err_msg(ET_ERR, "Integer (return number) expected");
               break;
               }
            while (toktype == TOK_NUMBER) {  /* Build return list */
               n = get_number();
               if (n > mx_ret_value) mx_ret_value = n;
               ret_info[call_grp_sz++].ret_nbr = n;
               ++lbls_this_stmt;
               next();
               if (toktype == TOK_SPECIAL && toksubtype == ':')
                  next();
               else err_msg(ET_ERR, ": expected");
               }
            make_label(a_lbl, 'a');  /* Make an action label */
            emit_label(a_lbl);

            single = 0;  op = NULL;
            if (toktype == TOK_RSVWD) {
               switch(toksubtype) {
               case RW_IGNORE:
               case RW_NOMATCH:
               case RW_COUNT:
                  ++n_counts;
                  single = 1;  which = toksubtype;  target = NULL;
                  next();  check_semi();
                  break;
               case RW_EXIT:
                  next();
                  if (toktype == TOK_SYMBOL) {  /* Get the label */
                     single = 1;
                     which = RW_EXIT;
                     sp = &st[st_ix];
                     if (sp->symtype != ST_LABEL) {
                        err_msg(ET_ERR, "Undeclared label");
                        sp = block_check(st_ix, ST_LABEL);  /* Declare it */
                        target = NULL;
                        }
                     else strcpy(target = s_lbl, sp->name);
                     if (subr_stx != 0 && st_ix < subr_stx)
                        err_msg(ET_ERR,
                            "Can't EXIT to label outside SUBROUTINE");
                     next();  check_semi();
                     }
                  else err_msg(ET_ERR, "Exit label expected");
                  break;
               case RW_RETURN:
                  if (subr_stx == 0)
                     err_msg(ET_ERR,
                        "Return only allowed inside a subroutine");
                  next();
                  single = 1;  which = RW_RETURN;
                  if (toktype == TOK_NUMBER) {
                     sprintf(s_lbl, "%lu", n = get_number());  
                     target = s_lbl;
                     set_subr_n_returns(n);
                     next();
                     }
                  else target = id_table[st[subr_stx].idx].id;
                  check_semi();
                  break;
               case RW_SAVE:
                  next();
                  op = Save_statement(0);
                  check_semi();
                  single = 1;  which = RW_SAVE;  target = g_lbl;
                  break;
               case RW_STORE:
                  next();
                  op = Store_statement(0);
                  check_semi();
                  single = 1;  which = RW_STORE;  target = g_lbl;
                  break;
               default:
                  single = 0;
                  break;
                  }
               }
            if (!single) {  /* Emit statement code block */
               Statement();
               emit_goto(g_lbl);  
               which = RW_EXIT;  target = a_lbl;
               }

            for (j = 0; j != lbls_this_stmt; ++j) {
               rip = &ret_info[call_grp_sz-1-j];
               if (op != NULL) {
                  memcpy(&rip->opnode, op, sizeof(struct pt_node));
                  free_pt(op);  /* Finished with operand node */
                  }
               else memset(&rip->opnode, 0, sizeof(struct pt_node));
               rip->which = which;
               if (target == NULL) rip->a_lbl[0] = '\0';
               else strcpy(rip->a_lbl, target);
               }
            }

         if (sub_sp == NULL)  /* Call of undeclared subroutine */
            call_sp->d.sub.n_returns = mx_ret_value;
#if 0
	 else if strcmp(sub_sp->name, "<<call>>") == 0) {
	    /* nth call, still undeclared */
            if (mx_ret_value < call_sp->d.sub.n_returns)
               call_sp->d.sub.n_returns = mx_ret_value;
	    }
#endif
         emit_IF_level(-1);

#if 0  /* We'll dummy up returns to match declaration */
         if (sub_sp != NULL) {  /* Previous subroutine, check nbr of returns */
            if (!subr_match(call_stx, sub_stx, 0))
               err_msg(ET_WARN,
                  "Return range smaller in call than in subroutine");
            if (mx_ret_value > sub_sp->d.sub.n_returns)
               sub_sp->d.sub.n_returns = mx_ret_value;
            }
#endif

         qsort(ret_info, call_grp_sz,sizeof(struct return_stmt_info),
            call_grp_cmp);
         for (k = 1, j = 0; j != call_grp_sz; ++j, ++k) {
            rip = &ret_info[j];
            for ( ; k != rip->ret_nbr; ++k) {
               emit_return_code(NULL, RW_EXIT, g_lbl);
               }
            emit_return_code(&rip->opnode, rip->which, rip->a_lbl);
            }
         if (sub_sp != 0) {
            for (++k ; k <= sub_sp->d.sub.n_returns; ++k)
               emit_return_code(NULL, RW_EXIT, g_lbl);
            }
         emit_return_code(NULL, RW_EXIT, g_lbl);
             /* For un-numbered RETURNs */
         emit_label(g_lbl);
         }
      if (verbose) dump_symbol_table();
      clear_st_subroutine(call_stx);
      if (verbose > 1) dump_symbol_table();
      }
   if (!find_res_word(RW_ENDCALL)) err_msg(ET_ERR,
      "ENDCALL expected for call which began on line %d", first_line);
   check_semi();
   }


void Statement(void)
{
   struct symbol *sp;
   if (testing) printf(". . . Statement()\n");

   nextnb();  /* Enable 1-char lookahead! */
   if (toktype == TOK_SYMBOL && ic == ':')
      Compound_statement();
   else if (toktype == TOK_SPECIAL && toksubtype == '{') {
      Compound_statement();
      }

   else if (toktype == TOK_RSVWD) {
      switch(toksubtype) {
      case RW_OPTIMISE:
         set_opt_level();            
         break;

      case RW_IF:
         IF_statement(NULL);  /* Begin an IF group */
         break;
      case RW_EXIT:
      case RW_SAVE:
      case RW_COUNT:
      case RW_IGNORE:
      case RW_NOMATCH:
      case RW_RETURN:
      case RW_STORE:
         Imperative_statement();
         break;

      case RW_CALL:
         Call_statement();
         break;

      default:
         err_msg(ET_ERR, "Statement expected");
         find_semi();
         break;
         }
      }

   else if (toktype == TOK_SPECIAL && toksubtype == ';')
      next();  /* Null statement */
   else if (toktype == TOK_SPECIAL && toksubtype == '}') {
      err_msg(ET_ERR, "Unmatched }");
      next();
      }
   else {
      err_msg(ET_ERR, "Statement expected");
      find_semi();
      }

   if (testing > 1) printf(". . . leaving Statement()\n");
   }

void Subroutine_declaration(void)
{
   struct symbol *call_sp, *sub_sp, *sp;
   int first_line, params, p_type, call_stx, arg_reg;

   first_line = line_nbr;
   next();
   if (toktype != TOK_SYMBOL)
      err_msg(ET_ERR, "Subroutine name expected");
   else {
      call_sp = NULL;  arg_reg = subr_reg;
      sub_sp = &st[subr_stx = st_ix];
      if (sub_sp->symtype == ST_SYMBOL) {  /* New symbol */
         sub_sp->symtype = ST_SUBROUTINE;
         set_st_name(sub_sp, 0);
         }
      else {
         if (strcmp(st[subr_stx+1].name, "<<call>>") != 0)
            err_msg(ET_ERR, "Subroutine already declared");
         call_sp = sub_sp;  call_stx = subr_stx;
         arg_reg = call_sp->d.sub.first_param - 1;
         add_symbol(ST_SUBROUTINE);  /* New copy of subroutine entry */
         sub_sp = &st[subr_stx = st_top-1];  /* ST entry for the symbol */
         strcpy(sub_sp->name, call_sp->name);
         }
      start_st_block("<<subr>>");
      next();
      if (toktype != TOK_SPECIAL || toksubtype != '(')
         err_msg(ET_ERR, "( expected");
      else {
         next();
         sub_sp->d.sub.first_param = arg_reg + 1;
         params = 0;
         if (toktype == TOK_SPECIAL  && toksubtype == ')')
            next();  /* No parameters */
         else for (;;) {
            if (toktype == TOK_EOF) break;
            if (toktype == TOK_RSVWD && 
                  (toksubtype == RW_ADDRESS || toksubtype == RW_VARIABLE)) {
               p_type = toksubtype;
               next();
               if (toktype != TOK_SYMBOL)
                  err_msg(ET_ERR, "Parameter name expected");
               else {
                  sp = block_check(st_ix, 
                     p_type == RW_ADDRESS ? ST_ADDRESS : ST_VARIABLE);
                  sp->d.arg.reg = ++arg_reg;
                  ++params;
                  }
               sub_sp->d.sub.n_params = params;
               next();
               }
            else {
               err_msg(ET_ERR, "ADDRESS or VARIABLE expected");
               find_arg_sep();
               }
            if (toktype == TOK_SPECIAL) {
               if (toksubtype == ',') {
                  next();
                  continue;
                  }
               else if (toksubtype == ')') {
                  next();
                  break;
                  }
               else err_msg(ET_ERR, ", or ) expected");
               }
            }

         if (call_sp != 0) {  /* Previous call, check parameters */
            if (!subr_match(call_stx, subr_stx, 1))
               err_msg(ET_ERR,
                  "Subroutine parameters don't match earlier calls");
            }
         else subr_reg = arg_reg;  /* Allocate arg registers */

         emit_IF_level(+1);
         emit_label(sub_sp->name);
         for (;;) {
            if (toktype == TOK_EOF) {
               err_msg(ET_ERR,
                  "EOF in subroutine which began on line %d", first_line);
               break;
               }
            else {
               Statement();
               if (toktype == TOK_RSVWD && toksubtype == RW_ENDSUB) {
                  break;
                  }
               if (toktype == TOK_RSVWD && toksubtype == RW_ENDCALL) {
                  err_msg(ET_WARN,
                     "SOUBROUTINE declaration should end with ENDSUB");
                  break;
                  }
               }
            }
         emit_imperative(  /* RETURN ; after subroutine body */
            NULL, RW_RETURN, id_table[st[subr_stx].idx].id);
         emit_IF_level(-1);

         if (call_sp != 0) {  /* Previous call, check nbr of returns */
            if (!subr_match(call_stx, subr_stx, 0))
               err_msg(ET_ERR,
                  "Return range smaller in previous call than in subroutine");
            }

         }
      if (verbose) dump_symbol_table();
      if (call_sp != NULL) {  /* Clear the subroutine declaration */
         call_sp->d.sub.n_returns = sub_sp->d.sub.n_returns;
         strcpy(st[call_stx+1].name, "<<subr>>");
         }
      clear_st_subroutine(subr_stx);
      if (verbose > 1) dump_symbol_table();
      }
   if (!find_res_word(RW_ENDSUB)) err_msg(ET_ERR,
      "ENDSUB expected for subroutine which began on line %d", first_line);
   check_semi();
   }


void NeMaC_set(void)
{
   char nbuf[IDENT_LN];
   if (n_sets != 0)
      err_msg(ET_WARN, "Program should only have one SET statement");
   ++n_sets;
   next();
   if (toktype == TOK_NUMBER) {
      sprintf(nbuf, "%lu", get_number());
      }
   else if (toktype == TOK_SYMBOL) {
      strcpy(nbuf, token);
      st[st_ix].symtype = ST_NEMAC_CMD;
      }
   else err_msg(ET_ERR, "Set name (or number) expected");
   emit_NeMaC_command("set %s;\n", nbuf);
   next();
   check_semi();
   }

static char fbuf[81];
static unsigned char *fbp;
static int flen;

void build_format_line(char *tok)
{
   int toklen = strlen(tok);

   if (flen+toklen > sizeof(fbuf)-4) {
      strcpy(fbp, "\n");
      emit_NeMaC_command(fbuf);
      flen = 0;
      }
   if (flen == 0) {
      fbp = strmov((unsigned char *)fbuf,(unsigned char *)" ");
      flen = 1;
      }
   *fbp++ = ' ';
   fbp = strmov(fbp, (unsigned char *)tok);
   flen += toklen+1; 
   }

void NeMaC_format(void)
{
   if (n_formats != 0)
      err_msg(ET_WARN, "Program should only have one FORMAT statement");
   ++n_formats;
   emit_NeMaC_command("format\n");
   next();
   for (flen = 0; ; ) {
      if (toktype == TOK_EOF) break;
      else if (toktype == TOK_SPECIAL && toksubtype == ';')
         break;
      else if (toktype == TOK_ATTRIB || toktype == TOK_STRING) {
         if (toktype == TOK_ATTRIB && !format_OK(toksubtype))
            err_msg(ET_ERR, "Attribute not allowed in FORMAT");
         build_format_line(token);
         }
      else {
         err_msg(ET_ERR, "Attribute or separator string expected");
         break;
         }
      next();
      }
   strcpy(fbp, ";\n");
   emit_NeMaC_command(fbuf);
   check_semi();
   }

void NeMaC_statistics(void)
{
   next();
   if (toktype != TOK_SPECIAL || toksubtype != ';')
      err_msg(ET_ERR, "; expected");
   emit_NeMaC_command("statistics;\n");
   check_semi();
   }

void scan_file(char *sfname)
{
   next();  /* Get started */
   for (;;) {
      if (testing) printf(". . . scan_file()\n");
      if (toktype == TOK_EOF) break;

      nextnb();  /* Enable 1-char lookahead! */
      if (ic == ':')
         Compound_statement();
      else if (toktype == TOK_SPECIAL && toksubtype == '{') {
         Compound_statement();
         }

      else if (toktype == TOK_RSVWD) {
         switch(toksubtype) {
         case RW_IF:
         case RW_EXIT:
         case RW_SAVE:
         case RW_COUNT:
         case RW_IGNORE:
         case RW_NOMATCH:
         case RW_RETURN:
         case RW_STORE:
         case RW_CALL:
            Statement();
            break;

         case RW_SUBROUTINE:
            Subroutine_declaration();
            break;

         case RW_OPTIMISE:
            set_opt_level();            
            break;

         case RW_SET:
            NeMaC_set();            
            break;
         case RW_FORMAT:
            NeMaC_format();            
            break;
         case RW_STATS:
            NeMaC_statistics();            
            break;

         default:
            err_msg(ET_ERR, "Statement or Declaration expected");
            find_semi();
            break;
            }
         }

      else if (toktype == TOK_SPECIAL && toksubtype == ';')
         next();  /* Null statement */

      else if (toktype == TOK_SPECIAL && toksubtype == '}') {
         err_msg(ET_ERR, "Unmatched }");
         next();  /* Unmatched ('floating') } */
         }
      else {
         err_msg(ET_ERR, "Statement or Declaration expected");
         find_semi();
         }
      }

   fclose(sfp);
   if (n_counts == 0)
      err_msg(ET_WARN, "Program should have at least one COUNT statement");
   if (n_sets == 0)
      err_msg(ET_WARN, "NeMaC requires one SET statement");
   if (n_formats == 0)
      err_msg(ET_WARN, "NeMaC requires one FORMAT statement");
   }

int main(int argc, char *argv[])
{
   char *ap, sfname[FNAME_LN+1], sfprefix[FNAME_LN+1], *sfp;
   char codefn[FNAME_LN+1];
   int a, syntax;
   time_t t;  char *ts;

#if 0
   printf("N_OLD_ATRS=%d, N_METER_ATRS=%d, N_VBLS=%d\n",
      N_OLD_ATRS, N_METER_ATRS, N_VBLS);
   printf("N_DIST_ATRS=%d, N_NF_ATRS=%d, N_TC_ATRS=%d\n",
      N_DIST_ATRS, N_NF_ATRS, N_TCP_ATRS);
   exit(0);
#endif

   if (argc < 2) {
      fprintf(stderr, "%s [options] program.srl\n\n", argv[0]);
      exit(0);
      }

   syntax = list_source = verbose = testing = 0;
   asmint = optimise_level = 1;
   sfname[0] = codefn[0] = '\0';
   init_symbol_table();

   for (a = 1; a < argc; ++a) {
      if (argv[a][0] == '-') {
         ap = argv[a]+2;
	 switch (argv[a][1]) {
	 case 'O':
            if (isdigit(*ap)) optimise_level = *ap-'0';
	    else optimise_level = 1;
	    break;
	 case 'a':
            if (isdigit(*ap)) asmint = *ap-'0';
	    else ++asmint;
	    break;
	 case 'l':
	    ++list_source;
	    break;
	 case 'o':
            if (*ap == '\0') ap = argv[++a];
	    strncpy(codefn, ap, FNAME_LN);  /* Code file name */
	    codefn[FNAME_LN-1] = '\0';
	    break;
	 case 's':
	    ++syntax;
	    break;
	 case 't':
            if (isdigit(*ap)) testing = *ap-'0';
	    else ++testing;
	    break;
	 case 'v':
            if (isdigit(*ap)) verbose = *ap-'0';
	    else ++verbose;
	    break;
	 case 'D':
            if (*ap == '\0') ap = argv[++a];
            get_cmd_define(ap);
	    break;
	 default:
	    fprintf(stderr, "Invalid option: -%c\n", argv[a][1]);
	    break;
	    }
	 continue;
	 }
      if (sfname[0] == '\0') {
         strncpy(sfname,argv[a],sizeof(sfname)-1);
         sfname[sizeof(sfname)-1] = '\0';
         }
      }

   printf("Nevil's %s\n", ver);
   if (sfname[0] == '\0') {
      printf(">>> No srl file specified <<<\n");
      exit(11);
      }
   if (!parse_open((unsigned char *)sfname)) {
      printf(">>> Couldn't open srl file %s <<<\n", sfname);
      exit(12);
      }
   time(&t);  ts = fmt_time(&t);
   printf("%s: Compiling %s\n", ts, sfname);

   strcpy(sfprefix, sfname);
   for (sfp = sfprefix; *sfp != '\0'; ++sfp) {  /* Delete .srl suffix */
      if (strcmp(sfp,".srl") == 0) break;
      }
   *sfp = '\0';

   if (!intermediate_open(sfprefix)) {
      printf(">>> Couldn't open intermediate file <<<\n");
      exit(13);
      }
   emit_comment("#Source file: %s\n", sfname);
   emit_comment("#Compiled by: %s\n", ver);
   emit_comment("#Time:        %s\n", ts);
   emit_opt_level(start_opt_lev = optimise_level);

   n_sets = n_formats = n_counts = 0;
   subr_stx = subr_reg = 0;
   scan_file(sfname);  /* Pass 1 */
   intermediate_close();
   if (subr_reg > 5)
      err_msg(ET_ERR, "Too many subroutine parameters in program !!!");
   check_subrs_declared(0);

   if (sferrors == 0 && !syntax)
      emit_pass2(codefn);  /* Pass 2 */

   if (verbose) dump_symbol_table();

   if (list_source) printf("\n");

   if (sferrors || sfwarnings)
      printf("\n%s compiled: %d errors and %d warnings\n",
         sfname, sferrors, sfwarnings);

   exit(sferrors != 0 ? EXIT_FAILURE : EXIT_SUCCESS);
   }
