/* Output from P2C, the Pascal-to-C translator */
/* From input file "../rpcc.p" */


#include <p2c/p2c.h>


/** Global declaration **/
/********************************************************************

                Top-down RPC compiler - Declaration part

History:
        28 May 86       Written, Antonio Pastore, technical Student, DD/OC
        11 Jul 86       Last update by Antonio
         2 Nov 86       Options concurrent, sm6809, cm6809 added
        10 Aug 87       genericC options added; structural changes - Nici.
        17 Aug 87       byvalue option added - Nici.
        26 Aug 87       Options timeout and version added - Nici.
         1 Sep 87       Options types and <s,c>pcturbo added - Nici.
        26 Aug 88       Options <s,c>macturbo added. Roberto Bagnara, DD/OC
         1 Nov 88       Options <s,c>pils added. TBL, LT.
        30 Mar 89       CAST option added - TBL
*/

#define rpc_name_length  40   /* Must tally with RPC$CONST! */

#define MAXSTRING       255
#define expression_length  80
    /* expression for compenent of composite type*/
#define template_length  10   /* Length of expression templates */
#define error_length    48   /* Length of code generator error string */
#define MAXIDLEN        25
#define NUMKEYWORD      27   /* Must = number of keywords in INIT  */
#define NUMOMODES       11   /*  "     "     "    "   "  output_mode */
#define MAXDIM          9

#define rpc_default_timeout  (-1)   /* Must agree with include files */

/* The following constant should be set to take parameters from the
 command line.
*/

#define COMMANDLINE     true



typedef Char longstring[MAXSTRING];
typedef Char char_name[MAXIDLEN];
typedef Char char3[3];
typedef Char opt_name[10];
typedef Char template_type[template_length];
typedef Char error_string[error_length];

typedef struct astring {
  Char str[MAXSTRING];
  long len;
} astring;

typedef struct pilstring {
  Char str[MAXSTRING];
  long start, len;
} pilstring;

typedef struct id_name {
  char_name str;
  long len;
} id_name;

typedef struct expression {
  Char str[expression_length];
  long len;
} expression;

/** Types related to lexical analizer and tokens **/
/******
* WARNING!!!
* Be careful when changing the order of the following declaration!!
*******/
/* First token, simple type, courier type */
/* Last simple type */
/* RECORD            added 23 Oct TBL */
/* POINTER            .    .   .      */
/* Last courier type */
/* First attr_type */
/* Last attr_type */
/* add new tokens here */
typedef enum {
  chartok, bytetok, shortok, integertok, real32tok, real48tok, real64tok,
  real128tok, longtok, arraytok, recordtok, accesstok, sequence, stringtok,
  substring, package, semicolon, istok, typetok, endtok, colon, comma,
  opnround, clsround, oftok, intok, outok, inoutok, dot, ident, number,
  proctok, functok, return_, pragmatok, nultok
} type_token;   /* Last type */

typedef struct token_descriptor {
  type_token kind;
  union {
    id_name name;
    long value;
  } UU;
} token_descriptor;





/*   Describes:  an abstract data type */

/*defined_type*/

typedef struct defined_type {
  struct named_type *typ_name;   /* The name if any */
  long typ_min_size;   /* the minimum size in bytes */
  long typ_max_size;   /* The maximum size in bytes */
  long typ_nesting;   /* Number of indeces needed */
  struct defined_type *typ_subtype;   /* Subtype for complex types */
  boolean typ_external;   /* External marshalling */
  /* The type represented by this */
  type_token typ_basic_type;
  union {
    struct {

      /* low is always 1 */
      /* low is always 1 */
      /* low is always 1 */
      /* low and high can vary */
      long typ_low, typ_high;   /* array bounds */
    } U12;
    struct named_type *typ_fields;   /* List of subtypes */
  } UU;
} defined_type;

/*   Descibes:   a Named type
*/

typedef struct named_type {
  struct named_type *nty_next;
  id_name nty_name;
  defined_type *nty_type;
} named_type;

/*   Describes:   one parameter of a procedure/function
*/

typedef struct id_list {
  struct id_list *next;
  id_name name;
  type_token attr;
  defined_type *id_type;
} id_list;

/*   Describes:  one procedure or function
*/

typedef struct block_table {
  struct block_table *next;
  id_name name;
  type_token b_type;
  type_token return_;
  id_list *list;
  boolean in_only;   /* no data returned */
  long blk_nesting;   /* Number of indeces */
  long blk_min_in, blk_max_in;   /* Tot Parameter size */
  long blk_min_out, blk_max_out;   /* Tot Parameter size */
  long blk_timeout;   /* Overall timeout */
  id_list *blk_status_param;   /* Status parameter */
  boolean blk_concurrent;   /* Concurrent execution*/
  boolean blk_cast;   /* CAST(one way message)*/
} block_table;

/*   Error Codes:
*/
/** WARNING!
* Do not change the first and the last element of the following list!
**/
typedef enum {
  ill_basic_type, number_req, oftok_miss, simtype_req, blocks_req, ident_req,
  twice_declared, semicol_miss, var_attr_req, colon_miss, id_not_declared,
  clsround_miss, opnround_miss, package_miss, endtok_miss, char_ignored,
  params_miss, input_miss, comma_miss, semic_round_miss, toomany_dim,
  toomany_dig, proc_exp, cant_opn_input, cant_opn_client, cant_opn_server,
  cant_cls_client, cant_cls_server, dot_miss, positive_req, cant_cls_input,
  ident_reserved, istok_miss, record_miss, invalid_range, bad_proc_decl,
  bad_name, type_miss, return_miss, cant_opn_ext, internal_error,
  bad_input_name, cant_cls_ext, unexp_eof
} err_type;


typedef enum {
  rewriting, resetting
} open_mode;

/* *** WARNING:  IF YOU MODIFY THIS DECLARATION:-

1.  Check that NUMOMODES in the constant section matches the number of entries
2.  Check that order of the the server and client options below matches - Nici
*/

/* ** SEE Note: */
typedef enum {
  cerncross, m6809, monolith, vaxvms, vaxpas, unixbsd, pcturbo, macturbo,
  pils, vaxfor, genericc
} output_mode;

/******
* WARNING!!!
* Think carefully before changing the order of the following declaration!!! (AP)
*******/
/* See output_mode */
/*       add new options here */
typedef enum {
  ccerncross, cm6809, cmonolith, cvaxvms, cvaxpas, cunixbsd, cpcturbo,
  cmacturbo, cpils, cvaxfor, cgenericc, scerncross, sm6809, smonolith,
  svaxvms, svaxpas, sunixbsd, spcturbo, smacturbo, spils, svaxfor, sgenericc,
  dlex, dlexhot, dtree, shortint, stdescr, concurrent, noautoinit, byvalue,
  timeout, version, types, invalid
} options;


/** deb_lex      For lexical analizer                    **/
/** deb_lex_hot  Prints each character read from input   **/
/** deb_tree     To print trees created by parse **/

/*
        cerncross       Cern Cross Software enviroment
        m6809           Omegasoft Pascal for the m6809
        monolith        Any monolithic Pascal compiler
        vaxvms          Vax/Vms pascal fortran-like
        vaxpas          Vax/Vms pascal
        unixbsd         Unix BSD enviroment
        pcturbo         IBM PC Turbo Pascal
        macturbo        Macintosh Turbo Pascal
        pils            Any standard PILS environonment
        vaxfor          VAX/FORTRAN under VMS (might be portable)
        genericc        Any generic C compiler
        shortint        forces short (16 bit) rpc_integer
        stdescr         pass strings by descriptor (not implemented yet)
        concurrent      return before processing if all parameters IN
        noautoinit      supress automatic initialisation of stubs (VMS)
        byvalue         pass all simple type parameters by value - Nici.
        timeout         specify value of timeout parameter - Nici.
        version         control stub version number handling - Nici.
        types           include user types in ".ext" file - Nici.
*/


typedef struct _REC_keyword {
  char_name name;
  type_token symbol;

} _REC_keyword;

typedef struct _REC_runoptions {
  opt_name name;
  boolean value;
} _REC_runoptions;


/** This variable is the HEAD pointer to the TYPE's list table **/
Static named_type *typeptr;

/** This variable is the HEAD pointer to the BLOCK's list table **/
Static block_table *blockptr;

Static id_name unitname;   /** Name of the unit under analysis **/

/** Vars related to lexical analizer and tokens **/
Static long checksum;   /** used for stub version number **/
Static boolean is_blank;   /** for skipping multiple blanks **/
Static Char ch_there;   /** for read-ahead in getchar(); **/
Static Char lastcar;   /** Last char read **/
Static Char oldchar;   /** Char ready for next request **/
Static boolean char_ready;   /** Is a char ready to be returned? **/
Static boolean incomment;   /** We are checking for comment **/
Static long lastindex;   /** Index to the last token read **/
Static token_descriptor token, lastoken;
Static boolean tok_present;
    /** If a token already present in lex-analizer **/
Static long lineread;   /** Number of line read **/
Static long maxkeyword;
/** Number of keyword,
                        should be the same as NUMKEYWORD **/
Static _REC_keyword keyword[NUMKEYWORD];

Static Char upkpck[2][3];   /*'upk','pck'*/

Static defined_type *simple_descriptor[(long)longtok - (long)chartok + 1];
/* Reference definitions of simple types */


/* Variables set by parser:
*/
Static boolean external_marshalling;   /* has been invoked */

Static long number_of_invented_types;   /* Used by ensure_named_type */

/** General flag for errors **/
Static long errorfound;

/** File variables **/
Static FILE *inp_file;   /** Input file **/
Static astring inp_name;   /** Input file name **/
Static pilstring inp_line;   /** Last line read **/

Static FILE *op_file;   /** Output file for stub &c **/

Static astring cli_name;   /** Client file name **/
Static astring ser_name;   /** Server file name **/
Static astring ext_name;   /** External declaration file **/

/** General options **/

Static boolean deref, dr_tmp;   /** dereferencing flag for C params **/
Static boolean cli_spec, ser_spec;   /** forbid multiple stub generation **/
Static output_mode omode, ser_mode, cli_mode;
Static boolean client;   /** We are making a client stub now **/
Static long Cmode;   /** must contain all C output modes **/
Static long timeout_val;   /** value of timeout, if specified  **/
Static long version_num;   /** stub version number, if given   **/

/** Debugging variables **/
Static _REC_runoptions runoptions[(long)invalid - (long)ccerncross + 1];



/** Error management **/
/********************************************************************
*               Top-down RPC compiler - Error management
*
*       Author:
*               Antonio Pastore, Tec. Student 1986, DD/OC, CERN

    28 May 1986     Written, AP
    23 Nov 1988     'expected' written, find_tok made less verbose. TBL

***********************************************************************/

Static Void getoken PV( );

Static Void backtoken PV( );


Static Void error(which)
err_type which;
{
  printf("ERROR: ");
  errorfound++;
  if ((unsigned long)which > (int)unexp_eof) {
    printf(
      "RPCC: Panic: compiler internal error, notify the compiler's Administrator.\n");
    return;
  }
  switch (which) {

  case ill_basic_type:
    printf("Illegal basic type.\n");
    break;

  case invalid_range:
    printf("Upper bound must be greater then lower.\n");
    break;

  case number_req:
    printf("Number requested.\n");
    break;

  case oftok_miss:
    printf("Keyword \"of\" missing.\n");
    break;

  case simtype_req:
    printf("Simple type requested.\n");
    break;

  case positive_req:
    printf("Index must be positive.\n");
    break;

  case ident_req:
    printf("Identifier requested.\n");
    break;

  case blocks_req:
    printf("At least a procedure/function declaration requested.\n");
    break;

  case bad_proc_decl:
    printf("Parameter must be simple or already declared in type section.\n");
    break;

  case twice_declared:
    printf("Identifier already declared.\n");
    break;

  case semicol_miss:
    printf("Semicolon \";\" missing.\n");
    break;

  case semic_round_miss:
    printf("Semicolon \";\" or round bracket \")\" missing.\n");
    break;

  case comma_miss:
    printf("Comma \",\" missing.\n");
    break;

  case var_attr_req:
    printf("\"in\",\"out\" or \"in out\" required.\n");
    break;

  case colon_miss:
    printf("Colon \":\" missing.\n");
    break;

  case dot_miss:
    printf("Dot \".\" missing.\n");
    break;

  case id_not_declared:
    printf("Identifier not declared.\n");
    break;

  case clsround_miss:
    printf("Round bracket \")\" missing.\n");
    break;

  case opnround_miss:
    printf("Round bracket \"(\" missing.\n");
    break;

  case package_miss:
    printf("Keyword \"package\" missing.\n");
    break;

  case record_miss:
    printf("Keyword \"record\" missing.\n");
    break;

  case return_miss:
    printf("Keyword \"return\" missing.\n");
    break;

  case istok_miss:
    printf("Keyword \"is\" missing.\n");
    break;

  case endtok_miss:
    printf("Keyword \"end\" missing.\n");
    break;

  case type_miss:
    printf("Keyword \"type\", \"procedure\" or \"function\" missing.\n");
    break;

  case char_ignored:
    printf("Illegal character:\"%c\", ignored.\n", lastcar);
    break;

  case toomany_dig:
    printf("Too many digits in this number.\n");
    break;

  case toomany_dim:
    printf("Too many dimensions in this array.\n");
    break;

  case ident_reserved:
    printf("Identifier reserved for compiler use.\n");
    break;

  case bad_name:
    printf("Identifier does not match already declared package name.\n");
    break;

  case proc_exp:
    printf("Keyword \"procedure\" or \"function\" expected.\n");
    break;

  case params_miss:
    printf("Parameters missing.\n");
    break;

  case input_miss:
    printf("Input file missing, can't go on.\n");
    break;

  case bad_input_name:
    printf("Bad input file name: \".ext\" extension reserved.\n");
    break;

  case cant_opn_input:
    printf("Can't open input file.\n");
    break;

  case cant_opn_ext:
    printf("Can't open \".ext\" file.\n");
    break;

  case cant_opn_client:
    printf("Can't open client file.\n");
    break;

  case cant_opn_server:
    printf("Can't open server file.\n");
    break;

  case cant_cls_input:
    printf("Can't close input file.\n");
    break;

  case cant_cls_client:
    printf("Can't close client file.\n");
    break;

  case cant_cls_server:
    printf("Can't close server file.\n");
    break;

  case cant_cls_ext:
    printf("Can't close \".ext\" file.\n");
    break;

  case internal_error:
    printf("Sorry - Unexpected internal condition in compiler.\n");
    break;

  case unexp_eof:
    printf("Unexpected end of input file.\n");
    break;
  }/*End_CASE*/
}  /*ERROR*/


/*       Write a token name
         ------------------
 */
Static Void write_token(what)
type_token what;
{
  if ((unsigned long)what > (int)nultok) {
    printf("(Unknown token!)");
    return;
  }
  switch (what) {

  case chartok:
    printf("RPC_CHAR");
    break;

  case bytetok:
    printf("RPC_BYTE");
    break;

  case shortok:
    printf("RPC_SHORT");
    break;

  case integertok:
    printf("RPC_INTEGER");
    break;

  case real32tok:
    printf("RPC_REAL32");
    break;

  case real48tok:
    printf("RPC_REAL48");
    break;

  case real64tok:
    printf("RPC_REAL64");
    break;

  case real128tok:
    printf("RPC_REAL128");
    break;

  case longtok:
    printf("RPC_LONG");
    break;

  case arraytok:
    printf("ARRAY");
    break;

  case sequence:
    printf("SEQUENCE");
    break;

  case stringtok:
    printf("STRING");
    break;

  case substring:
    printf("SUBSTRING");
    break;

  case package:
    printf("PACKAGE");
    break;

  case semicolon:
    printf("SEMICOLON");
    break;

  case typetok:
    printf("TYPE");
    break;

  case endtok:
    printf("END");
    break;

  case colon:
    printf("colon \":\"");
    break;

  case comma:
    printf("comma \",\"");
    break;

  case opnround:
    printf("\"(\"");
    break;

  case clsround:
    printf("\")\"");
    break;

  case oftok:
    printf("OF");
    break;

  case intok:
    printf("IN");
    break;

  case outok:
    printf("OUT");
    break;

  case inoutok:
    printf("INOUT");
    break;

  case istok:
    printf("IS");
    break;

  case return_:
    printf("RETURN");
    break;

  case dot:
    printf("\".\"");
    break;

  case ident:
    printf("identifier");
    break;

  case number:
    printf("number");
    break;

  case proctok:
    printf("PROCEDURE");
    break;

  case functok:
    printf("FUNCTION ");
    break;

  case nultok:
    printf("(Null Token!)");
    break;
  }
}  /*write_token*/


/*       Print last line read from declaration file
         ------------------------------------------
 On entry:
     'lastindex' is the index of the last token read.
 */
Static Void print_last_line()
{
  long a, FORLIM;

  printf("INPUT:");
  FORLIM = inp_line.len;
  for (a = 0; a < FORLIM; a++)
    putchar(inp_line.str[a]);
  putchar('\n');
  FORLIM = lastindex + 4;
  for (a = 1; a <= FORLIM; a++)
    putchar('-');
  printf("^\n");
}


Static Void linerror(which)
err_type which;
{
  printf("RPCC: Error found on line %3ld:\n", lineread);
  print_last_line();
  error(which);
  putchar('\n');
}


Static Void find_tok(kind)
long *kind;
{
  /**    writeln('RPCC: Skipping ...');        **/
  while (!P_inset(token.kind, kind))
    getoken();
  /**
      print_last_line;
      writeln('RPCC: Restarting analysis here.');
      writeln;
  **/
}


Static Void errfind(which, kind)
err_type which;
long *kind;
{
  linerror(which);
  find_tok(kind);
}


Static Void abort_pgm(which)
err_type which;
{
  error(which);
  printf("Fatal error, program aborted.\n");
  _Escape(0);
}


/** Debugging module **/
/********************************************************************
*               Top-down RPC compiler - Debugging module
*
*       Author:
*               Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
*       History:
*               28 May 1986     first written (AP)
*               27 Jun 1986     last update by AP
*               26 Aug 1987     bug fix in print_tab_types - Nici.
*
***********************************************************************/

Static Void debug_print_name(where, name)
FILE **where;
id_name name;
{
  long i;

  for (i = 0; i < name.len; i++)
    putc(name.str[i], *where);
}


Static Void printok(what)
type_token what;
{
  if ((unsigned long)what > (int)nultok) {
    printf("?????? (bad type token) ???");
    return;
  }
  switch (what) {

  case chartok:
    printf("RPC_CHAR");
    break;

  case bytetok:
    printf("RPC_BYTE");
    break;

  case shortok:
    printf("RPC_SHORT");
    break;

  case integertok:
    printf("RPC_INTEGER");
    break;

  case real32tok:
    printf("RPC_REAL32");
    break;

  case real48tok:
    printf("RPC_REAL48");
    break;

  case real64tok:
    printf("RPC_REAL64");
    break;

  case real128tok:
    printf("RPC_REAL128");
    break;

  case longtok:
    printf("RPC_LONG");
    break;

  case arraytok:
    printf("ARRAY");
    break;

  case sequence:
    printf("SEQUENCE");
    break;

  case stringtok:
    printf("STRING");
    break;

  case substring:
    printf("SUBSTRING");
    break;

  case package:
    printf("PACKAGE");
    break;

  case semicolon:
    printf("SEMICOLON");
    break;

  case typetok:
    printf("TYPE");
    break;

  case endtok:
    printf("END");
    break;

  case colon:
    printf("COLON");
    break;

  case comma:
    printf("COMMA");
    break;

  case opnround:
    printf("OPNROUND");
    break;

  case clsround:
    printf("CLSROUND");
    break;

  case oftok:
    printf("OF");
    break;

  case intok:
    printf("IN     ");
    break;

  case outok:
    printf("OUT    ");
    break;

  case inoutok:
    printf("IN OUT ");
    break;

  case istok:
    printf("IS");
    break;

  case return_:
    printf("RETURN");
    break;

  case dot:
    printf("DOT");
    break;

  case ident:
    printf("IDENT");
    break;

  case number:
    printf("NUMBER");
    break;

  case proctok:
    printf("PROCEDURE");
    break;

  case functok:
    printf("FUNCTION ");
    break;

  case nultok:
    printf("NULTOKEN");
    break;
  }
}  /*PRINT*/


/*_____________________________________________________________________________

                Print out a type definition

Prints out whole lines.
*/
/*   indenting function */

Static long indent(level)
long level;
{
  return (level * 4 + 16);
}


Static Void print_def_type(ptr, level)
defined_type *ptr;
long level;
{
  named_type *scan;
  FILE *TEMP;
  named_type *WITH1;

  if (ptr == NULL) {
    printf("???? NIL pointer ????");
    return;
  }
  if (((1L << ((long)ptr->typ_basic_type)) &
       ((1 << ((long)substring + 1)) - (1 << ((long)chartok)))) == 0) {
    printf("???? Bad basic type ????");
    return;
  } else {
    if ((level > 1 || ((1L << ((long)ptr->typ_basic_type)) &
	     ((1 << ((long)longtok + 1)) - (1 << ((long)chartok)))) != 0) &&
	ptr->typ_name != NULL) {
/* p2c: ../rpcc.p, line 695: Note: Line breaker spent 6.6+0.72 seconds, 2563 tries on line 948 */
      printf("%*c", (int)indent(level), ' ');
	  /* Use predefined name if possible */
      TEMP = stdout;
/* p2c: ../rpcc.p, line 644:
 * Note: Taking address of stdout; consider setting VarFiles = 0 */
      debug_print_name(&TEMP, ptr->typ_name->nty_name);
      printf(";\n");
      return;
    }
    switch (ptr->typ_basic_type) {

    case chartok:
    case bytetok:
    case shortok:
    case integertok:
    case real32tok:
    case real48tok:
    case real64tok:
    case real128tok:
    case longtok:
      printf("%*c", (int)indent(level), ' ');
      printok(ptr->typ_basic_type);
      printf("; -- ??? unnamed basic type ???\n");
      break;

    case stringtok:
      printf("%*cSTRING (%ld);\n",
	     (int)indent(level), ' ', ptr->UU.U12.typ_high);
      break;

    case arraytok:
      printf("%*cARRAY (%ld..%ld) OF\n",
	     (int)indent(level), ' ', ptr->UU.U12.typ_low,
	     ptr->UU.U12.typ_high);
      print_def_type(ptr->typ_subtype, level + 1);
      break;

    case accesstok:
      printf("%*cACCESS\n", (int)indent(level), ' ');
      print_def_type(ptr->typ_subtype, level + 1);
      break;

    case recordtok:
      printf("%*cRECORD\n", (int)indent(level), ' ');
      scan = ptr->UU.typ_fields;
      while (scan != NULL) {
	WITH1 = scan;
	printf("%*c", (int)indent(level + 1), ' ');
	TEMP = stdout;
/* p2c: ../rpcc.p, line 678:
 * Note: Taking address of stdout; consider setting VarFiles = 0 */
	debug_print_name(&TEMP, WITH1->nty_name);
	printf(": \n");
	print_def_type(WITH1->nty_type, level + 2);
	scan = scan->nty_next;   /*while*/
      }
      printf("%*cEND RECORD;\n", (int)indent(level), ' ');
      break;

    case sequence:
      printf("%*cSEQUENCE (%ld) OF \n",
	     (int)indent(level), ' ', ptr->UU.U12.typ_high);
      print_def_type(ptr->typ_subtype, level + 1);
      break;

    case substring:
      printf("%*cSUBSTRING (%ld);\n",
	     (int)indent(level), ' ', ptr->UU.U12.typ_high);
      break;

    }/*end_case*/
  }
}  /*PRINT_DEF_TYPE*/


Static Void print_tab_types()
{
  /****
  * This procedure prints on standard output the tree of the type's declaration.
  ****/
  named_type *scan;
  options a;
  FILE *TEMP;
  defined_type *WITH;

  printf("\n--     Compiler options requested:\n\n");
  for (a = ccerncross; (long)a <= (long)invalid; a = (options)((long)a + 1)) {
    if (runoptions[(long)a - (long)ccerncross].value)
      printf("-- Option %.10s is set.\n",
	     runoptions[(long)a - (long)ccerncross].name);
  }
  printf("\n\n--     Tree of types (alphabetical order)\n\n");

  scan = typeptr;
  while (scan != NULL) {
    printf("TYPE ");
    TEMP = stdout;
/* p2c: ../rpcc.p, line 720:
 * Note: Taking address of stdout; consider setting VarFiles = 0 */
    debug_print_name(&TEMP, scan->nty_name);
    printf(" IS \n");
    print_def_type(scan->nty_type, 1L);
    WITH = scan->nty_type;
    if (WITH->typ_max_size == WITH->typ_min_size)
      printf(" -- Representation: %ld bytes.\n", WITH->typ_max_size);
    else
      printf(" -- Representation: %ld bytes minimum, %ld bytes maximum.\n",
	     WITH->typ_min_size, WITH->typ_max_size);
    putchar('\n');
    scan = scan->nty_next;
  }  /*end_while*/
}  /*PRINT_TAB_TYPES*/


Local Void print_list(ptr)
id_list *ptr;
{
  printf("with parameters:\n");
  do {
    printf("    %.*s : ", MAXIDLEN, ptr->name.str);
    printok(ptr->attr);
    if (ptr->id_type->typ_name != NULL)
      printf("%.*s", MAXIDLEN, ptr->id_type->typ_name->nty_name.str);
    else
      print_def_type(ptr->id_type, 1L);
    putchar('\n');
    ptr = ptr->next;
  } while (ptr != NULL);
  printf("(end of parameters)");
}


Static Void print_tab_blocks()
{
  /****
  * This procedure prints on standard output the tree of the block's declaration.
  ****/
  block_table *scan;

  printf("\n################## TREE OF BLOCKS #######################\n\n");
  printf("PACKAGE %.*s IS\n", MAXIDLEN, unitname.str);
  scan = blockptr;
  while (scan != NULL) {
    putchar('\n');
    printok(scan->b_type);
    printf(" %.*s", MAXIDLEN, scan->name.str);
    if (scan->list != NULL)
      print_list(scan->list);
    if ((long)scan->b_type == (long)functok) {
      printf(" RETURN ");
      printok(scan->return_);
    }
    printf("\n--  Minimum %ld bytes in, %ld out.\n",
	   scan->blk_min_in, scan->blk_min_out);
    printf("--  Maximum %ld bytes in, %ld out.\n",
	   scan->blk_max_in, scan->blk_max_out);
    printf("-- _______________________________________________________\n");
    scan = scan->next;
  }  /*end_while*/
  printf("END %.*s;\n\n", MAXIDLEN, unitname.str);
}


Static Void print_token()
{
  printf("     Token read: ");
  if ((long)token.kind == (long)ident)
    printf("IDENT:\"%.*s\"", MAXIDLEN, token.UU.name.str);
  else {
    if ((long)token.kind == (long)number)
      printf("NUMBER: %12ld", token.UU.value);
    else
      printok(token.kind);
  }
  putchar('\n');
}  /*PRINT_TOKEN*/


Local Void put_keyword(name, tok)
Char *name;
type_token tok;
{
  maxkeyword++;
  memcpy(keyword[maxkeyword - 1].name, name, sizeof(char_name));
  keyword[maxkeyword - 1].symbol = tok;
}


/** Global initialization **/
/********************************************************************
*               Top-down RPC compiler - Initialization code
*
*       Author:
*               Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*

History:
        28 May 86       Written, Antonio Pastore, Technical student, DD/OC
        11 Jul 86       Last update by antonio
         2 Nov 86       Extra options added (TBL)
        10 Aug 87       genericC options added; structural changes - Nici.
        17 Aug 87       byvalue option added - Nici.
        26 Aug 87       Options timeout and version added - Nici.
         1 Sep 87       Options types and <s,c>pcturbo added - Nici.
        26 Aug 88       Options <s,c>macturbo added. Roberto Bagnara, DD/OC
        23 Oct 88       RECORD and ACCESS added - Tim BL
         1 Nov 88       PILS output options added (Louis Tremblet)

***********************************************************************/

Static Void getoken_init()
{
  /** Vars in getoken **/
  inp_line.len = 0;
  inp_line.start = 0;
  lastindex = 1;
  lineread = 0;
  tok_present = false;
  lastcar = ' ';
  char_ready = false;
  incomment = false;

  /** The following MUST be in alphabetical order !!! **/

  maxkeyword = 0;
  put_keyword("access                   ", accesstok);
  put_keyword("array                    ", arraytok);
  put_keyword("end                      ", endtok);
  put_keyword("function                 ", functok);
  put_keyword("in                       ", intok);
  put_keyword("inout                    ", inoutok);
  put_keyword("is                       ", istok);
  put_keyword("of                       ", oftok);
  put_keyword("out                      ", outok);
  put_keyword("package                  ", package);
  put_keyword("pragma                   ", pragmatok);
  put_keyword("procedure                ", proctok);
  put_keyword("record                   ", recordtok);
  put_keyword("return                   ", return_);
  put_keyword("rpc_byte                 ", bytetok);
  put_keyword("rpc_char                 ", chartok);
  put_keyword("rpc_integer              ", integertok);
  put_keyword("rpc_long                 ", longtok);
  put_keyword("rpc_real128              ", real128tok);
  put_keyword("rpc_real32               ", real32tok);
  put_keyword("rpc_real48               ", real48tok);
  put_keyword("rpc_real64               ", real64tok);
  put_keyword("rpc_short                ", shortok);
  put_keyword("sequence                 ", sequence);
  put_keyword("string                   ", stringtok);
  put_keyword("substring                ", substring);
  put_keyword("type                     ", typetok);

  memcpy(upkpck[false], "upk", 3L);   /* Part of output of code generator */
  memcpy(upkpck[true], "pck", 3L);
}


Static Void inp_options()
{
  options opt;

  for (opt = ccerncross; (long)opt <= (long)invalid; opt = (options)((long)opt + 1))
    runoptions[(long)opt - (long)ccerncross].value = false;

  memcpy(runoptions[(long)cmonolith - (long)ccerncross].name, "cmonolith ",
	 sizeof(opt_name));
  memcpy(runoptions[0].name, "ccerncross", sizeof(opt_name));
  memcpy(runoptions[(long)cm6809 - (long)ccerncross].name, "cm6809    ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cvaxvms - (long)ccerncross].name, "cvaxvms   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cvaxpas - (long)ccerncross].name, "cvaxpascal",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cunixbsd - (long)ccerncross].name, "cunixbsd  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cpcturbo - (long)ccerncross].name, "cpcturbo  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cmacturbo - (long)ccerncross].name, "cmacturbo ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cpils - (long)ccerncross].name, "cpils     ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cvaxfor - (long)ccerncross].name, "cfortran  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)cgenericc - (long)ccerncross].name, "cgenericc ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)smonolith - (long)ccerncross].name, "smonolith ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)scerncross - (long)ccerncross].name, "scerncross",
	 sizeof(opt_name));
  memcpy(runoptions[(long)sm6809 - (long)ccerncross].name, "sm6809    ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)svaxvms - (long)ccerncross].name, "svaxvms   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)svaxpas - (long)ccerncross].name, "svaxpascal",
	 sizeof(opt_name));
  memcpy(runoptions[(long)sunixbsd - (long)ccerncross].name, "sunixbsd  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)spcturbo - (long)ccerncross].name, "spcturbo  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)smacturbo - (long)ccerncross].name, "smacturbo ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)spils - (long)ccerncross].name, "spils     ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)svaxfor - (long)ccerncross].name, "sfortran  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)sgenericc - (long)ccerncross].name, "sgenericc ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)dlex - (long)ccerncross].name, "dlex      ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)dlexhot - (long)ccerncross].name, "dlexhot   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)dtree - (long)ccerncross].name, "dtree     ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)shortint - (long)ccerncross].name, "shortint  ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)stdescr - (long)ccerncross].name, "stdescr   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)concurrent - (long)ccerncross].name, "concurrent",
	 sizeof(opt_name));
  memcpy(runoptions[(long)noautoinit - (long)ccerncross].name, "noautoinit",
	 sizeof(opt_name));
  memcpy(runoptions[(long)byvalue - (long)ccerncross].name, "byvalue   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)timeout - (long)ccerncross].name, "timeout   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)version - (long)ccerncross].name, "version   ",
	 sizeof(opt_name));
  memcpy(runoptions[(long)types - (long)ccerncross].name, "types     ",
	 sizeof(opt_name));

  Cmode = 1 << ((long)genericc);
  ser_name.len = 0;
  ser_mode = cerncross;
  ser_spec = false;
  cli_name.len = 0;
  cli_mode = cerncross;
  cli_spec = false;

  checksum = 0;
  ch_there = ' ';
  is_blank = true;
}


Static Void pointers_init()
{
  typeptr = NULL;
  blockptr = NULL;
}


Static Void init_global()
{
  getoken_init();
  inp_options();
  pointers_init();
  errorfound = 0;
}


/** Input parameters management **/
/********************************************************************
*               Top-down RPC compiler - Parameters management
*
*       Author:
*               Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
        28 May 1986     Written (Antonio)
        27 Jun 1986     Last update by Antonio
        12 Feb 87       No longer overwrites existing files: makes new version
        10 Aug 87       get_argv (UNIXBSD): string length bug fixed;
                        options "[s,c]<mode>=<filename>" implemented;
                        bug fix: disallow problematic MAGIC characters;
                        catch multiple server/client specifications - Nici.
        26 Aug 87       Options timeout and version added - Nici.
        20 Mar 88       For loop vaiable was used after loop in Unix file open
                        Subsctring function now used in VMS file open.
        15 Dec 88       Bug fix: filename with 10 char long option was ignored

***********************************************************************/



/*       M A C H I N E           D E P E N D A N T       R O U T I N E S
         =============           =================       ===============

 These are:

         get_argc(count)                 Return number of arguments
         get_argv(index, str, len)       Return one argument as a string
         file_open(file, name, mode)     Open a file
         file-close(file)                Close a file
 */


Static Void get_argc(count)
long *count;
{
  *count = argc - 1;   /** Predefined identifier **/
/* p2c: ../rpcc.p, line 981: Warning: Symbol 'ARGC' is not defined */
}


Static Void get_argv(what, towhere, len)
long what;
Char *towhere;
long *len;
{
  boolean loop;

/* p2c: ../rpcc.p, line 988: Warning: Symbol 'ARGV' is not defined */
  argv(what, towhere);
  /**
  * Remember:
  * command line parameters are truncated or padded with blanks!!
  **/
  *len = 0;
  loop = true;
  while (loop && *len <= MAXSTRING) {
    if (towhere[*len] != ' ')
      (*len)++;
    else
      loop = false;
  }
}


Static boolean file_open(file_des, name, mode)
FILE **file_des;
astring *name;
open_mode mode;
{
  /***
  * Try to open a file with 'name' name, returns true if succesful,
  * false otherwise.
  ***/
  long a;
  longstring str;
  long FORLIM;

  FORLIM = name->len;
  for (a = 0; a < FORLIM; a++)
    str[a] = name->str[a];

  a = name->len;   /* 80320 */
  if (a < MAXSTRING)
    a++;
  str[a - 1] = '\0';

  if ((long)mode == (long)rewriting)
    rewind(*file_des);
  else
    rewind(*file_des);
/* p2c: ../rpcc.p, line 1022: Note: REWRITE does not specify a name */
  return true;
}


Static boolean file_close(file_des)
FILE **file_des;
{
  fflush(*file_des);
  P_ioresult = 0;
  return true;
}


#define MAGIC1          "-"
    /* ugly! This disallows magic charcter '-' for */

#define MAGIC2          "-"



/*       E N D           O F     M A C H I N E   D E P E N D A N T       B I T
******************************************************************************
*/

/*       Analize an option:
         -----------------

 If interactive skip MAGIC and don't set input file name.
 The spelling of the name of this procedure is historical.

 */
Static Void analize(arg, len, interactive)
Char *arg;
long len;
boolean interactive;
{
  opt_name loc_arg;
  long a, i;
  boolean found;
  options scan;
  boolean present;   /* Parameter present */
  Char STR1[256], STR2[256];
  long FORLIM;


  sprintf(STR1, "%c", arg[0]);
  sprintf(STR2, "%c", arg[0]);
  /* Options are at most 10 characters long, but may be followed by an '='
     sign which must be scanned and may be in position 11.
  */
  if (((strcmp(STR1, MAGIC1) == 0) | (strcmp(STR2, MAGIC2) == 0)) || interactive)
      /** Options **/
      {  /** Option **/
    memcpy(loc_arg, "          ", sizeof(opt_name));
    a = 1;
    present = false;
    while (a <= 11 && a < len && !present) {
      if (arg[a] == '=')
	present = true;
      else if (a <= 10) {
	if (isupper(arg[a]))
	  loc_arg[a - 1] = (Char)(arg[a] + 32L);
	else
	  loc_arg[a - 1] = arg[a];
      }
      a++;
    }

    /** Find options **/
    scan = ccerncross;
    found = false;
    /** if present then a := a + 1;   skip over "="    out 90926 **/
    do {
      if (!memcmp(loc_arg, runoptions[(long)scan - (long)ccerncross].name,
		  sizeof(opt_name))) {
	found = true;
	if ((int)scan < NUMOMODES) {  /*client specification*/
	  if (cli_spec) {
	    printf("RPCC: ");
	    for (a = 0; a < len; a++)
	      putchar(arg[a]);
	    printf(": client already specified - option ignored.\n");
	  } else {
	    cli_spec = true;
	    for (i = 1; i <= (int)scan; i++)
	      cli_mode = (output_mode)((long)cli_mode + 1);
	    if (present) {
	      cli_name.len = len - a;
	      FORLIM = len - a;
	      for (i = 0; i < FORLIM; i++)
		cli_name.str[i] = arg[a + i];
	    }
	  }
	} else if ((int)scan < NUMOMODES * 2) {
	  if (ser_spec) {
	    printf("RPCC: ");
	    for (a = 0; a < len; a++)
	      putchar(arg[a]);
	    printf(": server already specified - option ignored.\n");
	  } else {
	    ser_spec = true;
	    for (i = 1; i <= (int)scan - NUMOMODES; i++)
	      ser_mode = (output_mode)((long)ser_mode + 1);
	    if (present) {
	      ser_name.len = len - a;
	      FORLIM = len - a;
	      for (i = 0; i < FORLIM; i++)
		ser_name.str[i] = arg[a + i];
	    }
	  }
	} else {
	  runoptions[(long)scan - (long)ccerncross].value = true;
	  if ((long)scan == (long)timeout) {
	    if (a >= len) {
	      printf("RPCC: timeout value missing, default will be used.\n");
	      runoptions[(long)timeout - (long)ccerncross].value = false;
	    } else {
	      timeout_val = 0;
	      FORLIM = len - a;
	      for (i = 0; i < FORLIM; i++) {
		if (isdigit(arg[a + i]))
		  timeout_val = timeout_val * 10 + arg[a + i] - '0';
		else {
		  printf("RPCC timeout option: ");
		  abort_pgm(number_req);
		}
	      }
	      if (timeout_val == 0)
		printf("RPCC: timeout is zero, hope that's okay.\n");
	    }
	  } else if ((long)scan == (long)version) {
	    if (a >= len) {
	      printf("RPCC: supplying missing version number.\n");
	      runoptions[(long)version - (long)ccerncross].value = false;
	    } else {
	      version_num = 0;
	      FORLIM = len - a;
	      for (i = 0; i < FORLIM; i++) {
		if (isdigit(arg[a + i]))
		  version_num = version_num * 10 + arg[a + i] - '0';
		else {
		  printf("RPCC version option: ");
		  abort_pgm(number_req);
		}
	      }
	      if (version_num == 0)
		printf("RPCC: stub version check disabled.\n");
	    }
	  }
	}
      } else
	scan = (options)((long)scan + 1);
    } while (!(found || (long)scan == (long)invalid));

    if ((long)scan != (long)invalid)
      return;

    printf("RPCC: ");
    for (a = 0; a < len; a++)
      putchar(arg[a]);
    printf(": unrecognized option, ignored.\n");
    return;
  }

  inp_name.len = len;
  for (a = 0; a < len; a++)
    inp_name.str[a] = arg[a];

  /*server specification*/
  /*a REAL option*/
  /** File name **/

}  /*ANALIZE*/

#undef MAGIC1
#undef MAGIC2


/*   Make a filename out of the input file name and a prefix
     -------------------------------------------------------

     The prefix is put on the front of the name part of the filename.
 This is taken to be the last bit which contains only alphanumerics and
 dots and underscores. Other characters are assumed to be directory
 information, which must be left intact.

 */
Static Void make_filename(filename, prefix)
astring *filename;
Char *prefix;
{
  long i, rdp;   /* read pointer */
  long FORLIM;

  rdp = inp_name.len;   /* point to last char */
  while (rdp >= 1 && (inp_name.str[rdp - 1] == '_' ||
	   inp_name.str[rdp - 1] == '.' || isalnum(inp_name.str[rdp - 1])))
	/*then*/
	  rdp--;
  /* Find start of name */

  /* rdp is the number of characters of directory etc preceding the filename*/

  filename->len = 0;
  for (i = 0; i < rdp; i++) {
    filename->len++;
    filename->str[filename->len - 1] = inp_name.str[i];
  }

  for (i = 0; i <= 2; i++) {
    filename->len++;
    filename->str[filename->len - 1] = prefix[i];
  }

  FORLIM = inp_name.len;
  for (i = rdp; i < FORLIM; i++) {
    filename->len++;
    filename->str[filename->len - 1] = inp_name.str[i];
  }

}


Static Void get_parameters()
{
  /*****
  * On entry: parameters on the command line
  * On exit:
  * 'inp_name' filled with input file name;
  * 'inp_file' opened using 'inp_name' name;
  * 'cli_name' filled with client file name; ('cli'+inp_name)
  * 'ser_name' filled with server file name; ('ser'+inp_name)
  * 'ext_name' filled with the external file name; (inp_name.'ext')
  *******/
  long a, b, count, p_argc, p_len;
  longstring p_argv;
  Char ext[3];   /* TBL 14-8-86 */

  inp_name.len = 0;

  if (COMMANDLINE) {
    count = 1;
    get_argc(&p_argc);
    while (count <= p_argc) {
      get_argv(count, p_argv, &p_len);
      count++;
      /** Analize option **/
      analize(p_argv, p_len, false);
    }  /*end_while*/
  } else {
    printf("Input file name: ");
    inp_name.len = 0;
    while (!P_eoln(stdin) && inp_name.len <= MAXSTRING) {
      inp_name.len++;
      inp_name.str[inp_name.len - 1] = getchar();
      if (inp_name.str[inp_name.len - 1] == '\n')
	inp_name.str[inp_name.len - 1] = ' ';
    }
    /** Skip end of line **/
    scanf("%*[^\n]");
    getchar();
    /** Get options **/
    do {
      printf("Debugging options: ");
      count = 1;
      while (!P_eoln(stdin) && count < MAXSTRING) {
	count++;
	p_argv[count - 1] = getchar();
	if (p_argv[count - 1] == '\n')
	  p_argv[count - 1] = ' ';
      }
      scanf("%*[^\n]");
      getchar();
      /** Analize option **/
      if (count > 1)
	analize(p_argv, count, true);
    } while (count != 1);
  }

  if (inp_name.len == 0) {
    printf("RPCC: usage: source_file [options]\n");
    abort_pgm(input_miss);
  }

  /** Try to open input file **/
  if (!file_open(&inp_file, &inp_name, resetting))
    abort_pgm(cant_opn_input);

  /** Build client, server and external default file names **/

  if (cli_name.len == 0)
    make_filename(&cli_name, "cli");

  if (ser_name.len == 0)
    make_filename(&ser_name, "ser");

  /*   Make the external declaration file name:

       Th extension is changed to '.ext'
   */
  b = inp_name.len;
  while (b >= 1 && isalpha(inp_name.str[b - 1]))   /*then*/
    b--;
  if (b == 0)   /* No '.' found */
    b = inp_name.len;
  if (inp_name.str[b - 1] != '.')   /* Found directory */
    b = inp_name.len;

  for (a = 0; a < b; a++) {
    if (a + 1 <= MAXSTRING - 3)
      ext_name.str[a] = inp_name.str[a];
  }

  if (b <= inp_name.len - 3) {  /* extension was specified */
    ext[0] = inp_name.str[b];
    ext[1] = inp_name.str[b + 1];
    ext[2] = inp_name.str[b + 2];
    if (!memcmp(ext, "ext", 3) || !memcmp(ext, "EXT", 3))
      abort_pgm(bad_input_name);
  } else {   /*if*/
    b++;   /* Add a '.' if it wasn't */
    ext_name.str[b - 1] = '.';
  }

  ext_name.str[b] = 'e';
  ext_name.str[b + 1] = 'x';
  ext_name.str[b + 2] = 't';
  ext_name.len = b + 3;

  /** Get file name **/
}  /*GET_PARAMETERS*/


#define TAB             9   /** ASCII TAB character **/


/***
* Note: 'lastcar' is declared global to be printed in error messages.
***/

Local Char AP_getchar()
{
  /** renamed - Nici, 26 Aug 87 **/
  Char Result;
  long a;
  Char localcar;
  long FORLIM;

  if (char_ready) {
    Result = oldchar;
    char_ready = false;
    return Result;
  }

  while (inp_line.start > inp_line.len || inp_line.len == 0) {
    inp_line.len = 0;
    inp_line.start = 1;
    lastindex = 1;
    if (P_eof(inp_file)) {
      abort_pgm(unexp_eof);
      continue;
    }
    while (!P_eoln(inp_file)) {
      inp_line.len++;
      inp_line.str[inp_line.len - 1] = getc(inp_file);
      if (inp_line.str[inp_line.len - 1] == '\n')
	inp_line.str[inp_line.len - 1] = ' ';
      if (inp_line.str[inp_line.len - 1] == TAB)
	inp_line.str[inp_line.len - 1] = ' ';   /** Convert TAB to space **/
      else {
	if (inp_line.str[inp_line.len - 1] < 32)
	  inp_line.len--;
      }
    }
    inp_line.len++;
    inp_line.str[inp_line.len - 1] = ' ';
    fscanf(inp_file, "%*[^\n]");   /** Skip END_OF_LINE **/
    getc(inp_file);
    lineread++;   /** Line counter **/
    if (runoptions[(long)dlex - (long)ccerncross].value) {
      printf("LINE READ: ");
      FORLIM = inp_line.len;
      for (a = 0; a < FORLIM; a++)
	putchar(inp_line.str[a]);
      putchar('\n');
    }
  }

  localcar = inp_line.str[inp_line.start - 1];
  inp_line.start++;   /*END_WITH*/


  /** Make it lower **/
  if (isupper(localcar))
    localcar = (Char)(localcar + 32L);
  Result = localcar;

  /** Skip comment if any **/
  if (localcar != '-' || incomment)
    return Result;
  incomment = true;
  oldchar = AP_getchar();
  incomment = false;
  if (oldchar == '-') {
    inp_line.len = 0;   /** Force the reading of a new line **/
    return ' ';   /** Return space **/
  }
  Result = localcar;
  char_ready = true;
  return Result;


  /*END_ELSE char_ready*/
}  /*AP_GETCHAR*/

#undef TAB


Local Char getchar_()
{
  /** written - Nici, 26 Aug 87 **/

  /**  This rather complex interface ensures that blanks are skipped  **/
  /**  whenever they are not syntactically relevant, in order to make **/
  /**  the checksum of syntactically identical RPCL files invariant.  **/
  Char ch;

  if (ch_there != ' ') {
    ch = ch_there;
    ch_there = ' ';
  } else {
    ch = AP_getchar();
    if (ch == ' ') {
      if (!P_eof(inp_file)) {
	do {
	  ch = AP_getchar();
	} while (ch == ' ');
      }
      if (!(ch == ';' || ch == ',' || ch == ')' || ch == '(' || ch == ':' ||
	    is_blank)) {
	ch_there = ch;
	ch = ' ';
      }
    }
  }
  is_blank = (ch == ';' || ch == ',' || ch == ')' || ch == '(' || ch == ':' ||
	      ch == ' ');
  checksum = (checksum * 3 + ch - ' ') % 8999;
  if (!runoptions[(long)dlexhot - (long)ccerncross].value)
    return ch;
  if (ch == ' ')
    printf("%c\n", ch);
  else
    putchar(ch);
  return ch;
}


/** Getoken, lexical analizer **/
/********************************************************************
*               Top-down RPC compiler - Lexical analizer
*
*       Author:
*               Antonio Pastore, Tec. Student 1986, DD/OC, CERN
*
*       History:
*               28 May 1986     first written (AP)
*               27 Jun 1986     last update by AP
*               26 Aug 1987     checksum (for version) included - Nici.
*               16 Nov 1988     Bug fix: crashed with 26 char identifier (TBL)
*
***********************************************************************/

/*GETOKEN returns in TOKEN (globally declared) the last token read*/

Static Void getoken()
{
  long i, j, k, sign;

  /*
  _____________________________________________________________________________
  */
  if (tok_present) {
    token = lastoken;
    tok_present = false;
  } else {
    do {   /** Find a valid token **/

      if (lastcar == ' ')   /** Skip blank **/
	lastcar = getchar_();
      lastindex = inp_line.start;   /** To print error messages **/

      /** Check if identifier or keyword **/
      if (lastcar == '_' || islower(lastcar)) {
	/** Suppose to be an identifier or keyword **/
	token.kind = ident;
	token.UU.name.len = 0;
	do {
	  if (token.UU.name.len < MAXIDLEN) {  /* was <= 81116 TBL */
	    token.UU.name.len++;
	    token.UU.name.str[token.UU.name.len - 1] = lastcar;
	  }
	  lastcar = getchar_();
	} while (lastcar == '_' || islower(lastcar) || isdigit(lastcar));
	/** Fill with blanks **/
	for (i = token.UU.name.len; i < MAXIDLEN; i++)
	  token.UU.name.str[i] = ' ';

	/** Try to see if keyword **/
	/** The following is the famous binary search!!! **/
	i = 1;
	j = maxkeyword;
	do {
	  k = (i + j) / 2;
	  if (memcmp(token.UU.name.str, keyword[k - 1].name,
		     sizeof(char_name)) <= 0)
	    j = k - 1;
	  if (memcmp(token.UU.name.str, keyword[k - 1].name,
		     sizeof(char_name)) >= 0)
	    i = k + 1;
	} while (i <= j);

	if (i - 1 > j)
	  token.kind = keyword[k - 1].symbol;
	else {
	  /** Check if illegal identifier, reserved for compiler use **/
	  if ((token.UU.name.str[0] == 'r' && token.UU.name.str[1] == 'p' &&
	       token.UU.name.str[2] == 'c' && token.UU.name.str[3] == '_') ||
	      !memcmp(token.UU.name.str, "b                        ",
		      sizeof(char_name)) || !memcmp(token.UU.name.str,
		"header                   ",
		sizeof(char_name)) || !memcmp(token.UU.name.str,
		"ret                      ", sizeof(char_name)))
/* p2c: ../rpcc.p, line 1565: Note: Line breaker spent 12.7+1.64 seconds, 3877 tries on line 1937 */
	    linerror(ident_reserved);
	  token.kind = ident;
	}
      }  /*identifier or keyword*/
      else {
	/** Check if number **/
	if (lastcar == '-' || isdigit(lastcar)) {   /*if number*/
	  token.kind = number;
	  token.UU.value = 0;
	  if (lastcar == '-') {
	    sign = -1;
	    lastcar = getchar_();
	  } else
	    sign = 1;
	  do {
	    if (token.UU.value < LONG_MAX / 10 - lastcar + '0')
	      token.UU.value = token.UU.value * 10 + lastcar - '0';
	    else {
	      error(toomany_dig);
	      token.UU.value = LONG_MAX;
	    }
	    lastcar = getchar_();
	  } while (isdigit(lastcar));
	  token.UU.value *= sign;
	} else {   /*if*/
	  /** Then should be one of these symbols! **/
	  if (lastcar != '.' && lastcar != ')' && lastcar != '(' &&
	      lastcar != ',' && lastcar != '=' && lastcar != ';' &&
	      lastcar != ':') {
	    token.kind = nultok;
	    error(char_ignored);   /** Ignore this character **/
	  } else {
	    switch (lastcar) {

	    case ':':
	      token.kind = colon;
	      break;

	    case ';':
	      token.kind = semicolon;
	      break;

	    case ',':
	      token.kind = comma;
	      break;

	    case '(':
	      token.kind = opnround;
	      break;

	    case ')':
	      token.kind = clsround;
	      break;

	    case '.':
	      token.kind = dot;
	      break;
	    }/*end case*/
	  }  /*if*/
	  lastcar = getchar_();   /** Read next char **/
	}
      }


    } while ((long)token.kind == (long)nultok);

    /*END_WITH*/
  }  /*end_token already present*/

  if (runoptions[(long)dlex - (long)ccerncross].value)
    print_token();



}  /*getoken*/


/*
_____________________________________________________________________________
*/

Static Void backtoken()
{
  /****
  * This procedure save the value of 'tok' and uses it when next 'getoken' is
  * called.
  *****/
  lastoken = token;
  tok_present = true;
}


/** Parser **/
/****************************************************************************
*               Top-down RPC compiler - PARSER, types and blocks declaration
*

History:
        28 May 86       Written, Antonio Pastore, Tec. Student '86, DD/OC, CERN
        30 Jun 86       Last change by Antonio
        18 Aug 86       Bug fix in block_declare (TBL) (block.list not initzd).
        31 Oct 86       Direction defaults to IN (TBL)
        20 Oct 88       Nested complex types (TBL)
        23 Nov 88       PRAGMAs timeout, external_marshalling introduced (TBL)
        30 Mar 89       PRAGMA CAST introducted (TBL)
NOTE:
 1. 'ERT' means Error Recovery Tactics.  -AP

***************************************************************************/

/*************************************************************************
*
*               General useful routines
*
*************************************************************************
*/

/*   Check for a given token, otherwise skip
     ---------------------------------------
 */

Static boolean expected(what, skip_until)
type_token what;
long *skip_until;
{
  boolean Result;

  getoken();
  if ((long)token.kind == (long)what)
    return true;
  Result = false;
  printf("RPCC: Error: Found ");
  write_token(token.kind);
  printf(" where ");
  write_token(what);
  printf(" was expected on line %ld:\n", lineread);
  print_last_line();
  putchar('\n');
  find_tok(skip_until);
  return Result;

  /*if*/
}


/*_____________________________________________________________________________

                Expression handling
                ===================

   An expression is a variable length string generated by the compiler.
   The following routines add bits on to an existing expression to
   make it more complicated:

        Append one character to an expression:
        -------------------------------------
*/
Static Void append_1(expr, ch)
expression *expr;
Char ch;
{
  expr->len++;
  expr->str[expr->len - 1] = ch;
}


/*       Format an expression according to a template
         --------------------------------------------

     The template is a 10-character character array which contains a
     dollar sign wherever the original value of the expression is to be
     put.
 */
Static Void format(final, template)
expression *final;
Char *template;
{
  /*
  On entry,
      template must not be blank.
  On exit,
      expression copied from template with original expression inserted
          in place of "$" signs.
  */
  expression initial;
  long e;   /* effective end of template string*/
  long i, j;   /* loop index */

  /*format*/
  initial = *final;
  final->len = 0;
  e = template_length;
  while (template[e - 1] == ' ')   /* strip spaces */
    e--;
  for (i = 0; i < e; i++) {   /*for*/
    if (template[i] == '$') {
      for (j = 0; j < initial.len; j++)
	append_1(final, initial.str[j]);
    } else
      append_1(final, template[i]);
  }
}


/*       Put one character on the front of an expression
         -----------------------------------------------
 */
Static Void prepend_1(expr, ch)
expression *expr;
Char ch;
{
  long a;

  for (a = expr->len; a >= 1; a--)
    expr->str[a] = expr->str[a - 1];
  expr->str[0] = ch;
  expr->len++;
}


/*       Append an identifier to an expression
         -------------------------------------
 */
Static Void append_name(expr, name)
expression *expr;
id_name name;
{
  long a;

  for (a = 0; a < name.len; a++)
    append_1(expr, name.str[a]);
}


/*       Append an index to an array expression
         --------------------------------------

     The `level' parameter determines the name of the index to be used.

     1 -> rpc_a, 2 -> rpc_b etc.
 */
Static Void append_index(expr, level)
expression *expr;
long level;
{
  format(expr, "$[rpc_    ");
  append_1(expr, (Char)(level - 1 + 'a'));
  append_1(expr, ']');

}


/*       Append a decimal number to an expression
         ----------------------------------------
 */
Static Void append_decimal(expr, x)
expression *expr;
long x;
{
  long t, weight;

  if (x < 0) {
    append_1(expr, '-');
    t = -x;
  } else
    t = x;

  weight = 1;   /* these are array bounds */
  while (weight * 10 <= t)
    weight *= 10;
  /* weight is largest power of 10 not greater than t */
  while (weight > 0) {   /*while*/
    append_1(expr, (Char)(t / weight + '0'));
    t %= weight;
    weight /= 10;
  }
}


/*_____________________________________________________________________________

        Find Type in List
        =================

The TYPE table used to be in alphabetical order, to halve search time. However,
now it is kept in the order or original declaration, as we allow types to be
defined in terms of other types. When the type table is repoduced in C or
Pascal, we don't want any forward references.

This routine not only searches for existing types, but also is used to find
the previous element ("father"), when inserting into a list.

On entry
    head        is the head pointer of the list to be searched, in which
                the elements are in order.
    name        is the name to be searched for.

On exit,
    father      is set to the father of this element if any, otherwise
                will point to the last element in the list.
    son         is a pointer to that element if found, NIL otherwise.
    returns true if element found else false.

 Parameter 'name' is 'var' to speed up the processing.

*/
Static boolean find_type(head, name, father, son)
named_type *head;
id_name *name;
named_type **father, **son;
{
  /* head of list*/
  boolean found;

  found = false;
  *son = head;   /** Head of the list **/
  *father = *son;
  while (*son != NULL && !found) {
    if (!memcmp((*son)->nty_name.str, name->str, sizeof(char_name)))
      found = true;
    else {
      *father = *son;
      *son = (*son)->nty_next;
    }
  }
  return found;
}


/*_____________________________________________________________________________

            Insert Type Identifier into list
            --------------------------------

On entry,
    ptr     points to a description of the named type.
    head    is the pointer to a list of named types.
On exit,
    The element pointed to has been put into the list.
*/
Static Void insert_named_type(ptr, head)
named_type *ptr, **head;
{
  named_type *son, *father;

  /*insert_named_type*/
  if (find_type(*head, &ptr->nty_name, &father, &son)) {
    linerror(twice_declared);   /** Identifier already declared **/
    return;
  }

  if (*head == NULL) {  /** List empty **/
    *head = ptr;
    ptr->nty_next = NULL;
    return;
  }
  if (*head == son) {  /** Insert ahead **/
    *head = ptr;
    ptr->nty_next = son;
  } else {
    father->nty_next = ptr;
    ptr->nty_next = son;
  }
}


/**********************************************************************
*                       FIND_BLOCK
**********************************************************************
* This functions looks for 'name' in the table of blocks, then returns
* a pointer to that element if found, NIL otherwise.
* 'Father' will be setted to the father of this element if any, otherwise
* will point to the last element in the list. Anyway should be good enough
* to insert elements in queue.
* Input is 'var' to speed up the processing.
***********************************************************************/

Static boolean find_block(name, father, son)
id_name *name;
block_table **father, **son;
{
  boolean found;

  found = false;
  *son = blockptr;   /** Head of the list **/
  *father = *son;
  while (*son != NULL && !found) {   /*while*/
    if (!memcmp((*son)->name.str, name->str, sizeof(char_name)))
      found = true;
    else {
      *father = *son;
      *son = (*son)->next;
    }
  }
  return found;
}


/*_____________________________________________________________________________

        Find parameter
        --------------
On exit,
    son             pointer to param if found, else NIL
    return value    TRUE if found else FALSE
*/
Static boolean find_param(name, head, son)
id_name *name;
id_list *head, **son;
{
  boolean found;

  *son = head;
  found = false;
  while (*son != NULL && !found) {   /*while*/
    if (!memcmp((*son)->name.str, name->str, sizeof(char_name)))
      found = true;
    else
      *son = (*son)->next;
  }
  return found;
}


/******************************************************************************
*
*               TYPE DECLARATION ANALIZER
*
******************************************************************************

 The following routines analize the TYPE declaration and create
 the proper structure to handle them later.

_______________________________________________________________________________

                Ensure Type Named
                -----------------

      If the given type is not named, then this procedure will
      invent an arbitrary name for it, of the form

        rpc_stype_nnn

      where nnn is an incrementing decimal number.
*/
Static Void ensure_type_named(pt)
defined_type *pt;
{
  long i;   /* String index */
  expression expr;   /* for building up the variable name */
  named_type *pnt;   /* Pointer to the new named type if any */

  if (pt == NULL)
    return;
  if (pt->typ_name != NULL)   /*if with if*/
    return;
  pnt = (named_type *)Malloc(sizeof(named_type));

  format(&expr, "rpc_stype_");
  append_decimal(&expr, number_of_invented_types);
  number_of_invented_types++;

  for (i = 0; i < expr.len; i++)
    pnt->nty_name.str[i] = expr.str[i];
  pnt->nty_name.len = expr.len;
  pnt->nty_type = pt;   /* Link name to type */
  pt->typ_name = pnt;   /* Link type to name */
  insert_named_type(pnt, &typeptr);   /* Put into the type list */

  /*with*/
}


Static defined_type *parse_type PV( );

/*______________________________________________________________________________
*/
Local Void get_size(pt)
defined_type *pt;
{
  /** ERT:
  * If error found we suppose token forgotten so we 'backtoken'.

          Parses:     (  <positive_number>  )
  */
  long SET[3];

  getoken();
  if ((long)token.kind != (long)opnround)
    linerror(opnround_miss);
  else
    getoken();
  pt->UU.U12.typ_low = 1;   /* implied lower bound */
  if ((long)token.kind != (long)number) {
    linerror(number_req);   /** Assume zero **/
    pt->UU.U12.typ_high = 0;
  } else {
    pt->UU.U12.typ_high = token.UU.value;
    getoken();
  }
  if ((long)token.kind != (long)clsround) {
    errfind(clsround_miss,
	    P_expset(SET, (1L << ((long)oftok)) | (1 << ((long)semicolon))));
    backtoken();
  }

  if (pt->UU.U12.typ_high < 0)   /*with*/
    linerror(positive_req);
}  /*GET_SIZE*/

/*____________________________________________________________________________

        Parse Sub-array
        ===============

                subarray    ::  <number> .. <number> ] of <type>
                            |   <number> .. <number> , <subarray>

 Sub-array is not really a good word for this - it's the back end of an
 array definition, which can recursively call itself. These sort of things
 come out of pure BNF definitions, and avoid loops, even if they contain
 unnested brackets!

 On entry,
    First number token not read.
 On exit,
    token read/not read as after parse_type.
    value points to type descriptor filled in (except possibly for name)

Note that a subarray is the only thing which can have an unnamed subtype.
*/
Local defined_type *parse_subarray()
{
  defined_type *pt;
  long SET[3];

  pt = (defined_type *)Malloc(sizeof(defined_type));
  pt->typ_name = NULL;
  pt->typ_external = false;
  pt->typ_subtype = NULL;   /* Until filled in with good value */
  pt->typ_basic_type = arraytok;   /* The type is "array" */
  getoken();

  if ((long)token.kind != (long)number) {
    linerror(number_req);   /** Assume zero **/
    pt->UU.U12.typ_low = 0;
  } else {
    pt->UU.U12.typ_low = token.UU.value;
    getoken();
  }
  /** Skip double point **/
  if ((long)token.kind == (long)dot) {
    getoken();
    if ((long)token.kind != (long)dot)
      linerror(dot_miss);
    else
      getoken();
  } else
    linerror(dot_miss);

  if ((long)token.kind != (long)number) {
    linerror(number_req);   /** Assume low + 1 **/
    pt->UU.U12.typ_high = pt->UU.U12.typ_low + 1;
  } else {
    pt->UU.U12.typ_high = token.UU.value;
    getoken();
  }
  if (pt->UU.U12.typ_high <= pt->UU.U12.typ_low)
    linerror(invalid_range);


  if ((long)token.kind == (long)comma)
    pt->typ_subtype = parse_subarray();   /* , <subarray> */
  else if ((long)token.kind == (long)clsround) {
    getoken();
    if ((long)token.kind == (long)oftok) {
      getoken();
      pt->typ_subtype = parse_type();   /* ) of <type> */
      /*** ensure_type_named(typ_subtype); *NO* **/
    } else {   /*if*/
      errfind(clsround_miss, P_expset(SET, 1L << ((long)semicolon)));
	  /* ) garbage */
      backtoken();
    }
  } else {
    errfind(clsround_miss,
	    P_expset(SET, (1L << ((long)oftok)) | (1 << ((long)semicolon))));
    backtoken();
  }

  if (pt->typ_subtype == NULL) {   /*with*/
    Free(pt);   /* Not essential -could waste it */
    return NULL;
  } else {   /*if*/
    pt->typ_min_size = (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) *
		       pt->typ_subtype->typ_min_size;
    pt->typ_max_size = (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) *
		       pt->typ_subtype->typ_max_size;
    pt->typ_nesting = pt->typ_subtype->typ_nesting + 1;
    return pt;
  }

  /*if*/
}  /*parse_subarray*/


/*_____________________________________________________________________________

                Parse Type
                ==========
*/

Static defined_type *parse_type()
{
  /**********
  * In this function we analize a TYPE definition and return a pointer to
  * a type descriptor tree.
  *
  * Returns:
      Returns a pointer to a new created element otherwise nil if error
  * ERT:
  * If error found we exit with the offending token in 'backtoken'.
  ***********/
  defined_type *Result, *pt;
  named_type *pnt;
  boolean loc_err;
  named_type *father, *son;
  long SET[3];

  /*_____________________________________________________________________________

          Parse Type definition
          =====================

                  <type>  ::      <simple type>
                          |       SEQUENCE ( <n> ) OF <type>
                          |       ARRAY ( <n> .. <n> ) OF <type>
                          |       STRING ( <n> )
                          |       SUBSTRING ( <n> )
                          |       RECORD [ <id> : <type> ; ]*    END RECORD
                          |       <id>
   On entry,
      TOKEN ALREADY READ
   On exit,
      Next token (semicolon) not read
      Return value points to filled-in type descriptor, or NIL if error
  */
  if ((long)token.kind == (long)ident) {  /* <id> */
    if (find_type(typeptr, &token.UU.name, &father, &son))
      return (son->nty_type);

    linerror(id_not_declared);
    return Result;
  } else if ((unsigned long)token.kind < 32 &&
	     ((1L << ((long)token.kind)) &
	      ((1 << ((long)longtok + 1)) - (1 << ((long)chartok)))) != 0) {
/* p2c: ../rpcc.p, line 2218: Note: Line breaker spent 2.6+1.12 seconds, 775 tries on line 2594 */
    return (simple_descriptor[(long)token.kind - (long)chartok]);

  } else if ((long)token.kind == (long)arraytok) {
    getoken();
    if ((long)token.kind != (long)opnround) {
      linerror(opnround_miss);
      backtoken();
      return NULL;
    } else
      return (parse_subarray());

  } else if ((long)token.kind == (long)accesstok) {
    pt = (defined_type *)Malloc(sizeof(defined_type));
    pt->typ_basic_type = token.kind;
    pt->typ_external = false;
    getoken();
    pt->typ_subtype = parse_type();
    ensure_type_named(pt->typ_subtype);
    if (pt->typ_subtype == NULL)   /*if*/
      return pt;
    pt->typ_nesting = pt->typ_subtype->typ_nesting;   /* No extra index */
    pt->typ_min_size = 4;   /* <tbd> */
    pt->typ_max_size = pt->typ_subtype->typ_max_size + 4;   /* <tbd> */
    return pt;

  } else if ((long)token.kind == (long)recordtok) {
    pt = (defined_type *)Malloc(sizeof(defined_type));
    Result = pt;
    pt->typ_basic_type = token.kind;
    pt->typ_external = false;
    pt->typ_subtype = NULL;   /* subtype is meaningless */
    pt->UU.typ_fields = NULL;   /* List of fields currently empty */
    pt->typ_nesting = 0;   /* Unless we find nesting in a subtype */
    pt->typ_min_size = 0;   /* Initialise total */
    pt->typ_max_size = 0;   /* Initialise total */

    getoken();
    while ((long)token.kind == (long)ident) {   /*while token.kind=ident*/
      pnt = (named_type *)Malloc(sizeof(named_type));
	  /** It's ok, create an element **/
      pnt->nty_name = token.UU.name;
      getoken();

      if ((long)token.kind != (long)colon)   /* : (or ignore)*/
	linerror(colon_miss);
      else
	getoken();

      pnt->nty_type = parse_type();   /* Analyse a type declaration*/

      if (pnt->nty_type != NULL)   /*if ok*/
      {  /* Unless serious error, */
	if (pnt->nty_type->typ_nesting > pt->typ_nesting)
	      /* Find max. nesting */
		pt->typ_nesting = pnt->nty_type->typ_nesting;
	pt->typ_min_size += pnt->nty_type->typ_min_size;
	pt->typ_max_size += pnt->nty_type->typ_max_size;
	insert_named_type(pnt, &pt->UU.typ_fields);
	ensure_type_named(pnt->nty_type);   /* Needed for FORTRAN? */
      }

      getoken();   /* Read next token: ";" */

      if ((long)token.kind != (long)semicolon) {
	/** ERT: Skip tokens until a good token is found **/
	errfind(semicol_miss,
		P_expset(SET,
			 (1L << ((long)semicolon)) | (1 << ((long)endtok))));
	if ((long)token.kind == (long)semicolon)   /** Skip it **/
	  getoken();
      } else  /** Semicolon found **/
	getoken();

    }

    /*with*/

    if ((long)token.kind != (long)endtok)
      errfind(endtok_miss, P_expset(SET, 1L << ((long)endtok)));
    getoken();   /* skip the END */

    if ((long)token.kind == (long)recordtok)
      return Result;

    linerror(record_miss);
    if ((long)token.kind == (long)semicolon)   /* Assume he forgot RECORD */
      backtoken();
    return Result;
  } else if ((long)token.kind == (long)sequence) {
    pt = (defined_type *)Malloc(sizeof(defined_type));
    pt->typ_basic_type = token.kind;
    Result = pt;
    get_size(pt);

    getoken();
    if ((long)token.kind != (long)oftok) {   /** But ignore it **/
      linerror(oftok_miss);
      return Result;
    }

    getoken();
    pt->typ_external = false;
    pt->typ_subtype = parse_type();
    /** ensure_type_named(typ_subtype); *NO* not needed **/
    pt->typ_nesting = pt->typ_subtype->typ_nesting + 1;
    pt->typ_min_size = 2;
    pt->typ_max_size = pt->typ_subtype->typ_max_size *
		       (pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1) + 2;
	/*if*/
    return Result;
  } else if ((unsigned long)token.kind < 32 &&
	     ((1L << ((long)token.kind)) &
	      ((1L << ((long)stringtok)) | (1 << ((long)substring)))) != 0) {
/* p2c: ../rpcc.p, line 2218: Note: Line breaker spent 0.6+2.07 seconds, 654 tries on line 2708 */
    pt = (defined_type *)Malloc(sizeof(defined_type));
    Result = pt;
    pt->typ_basic_type = token.kind;
    get_size(pt);
    pt->typ_subtype = simple_descriptor[0];
    pt->typ_external = false;
    if ((long)pt->typ_basic_type == (long)stringtok) {   /*with*/
      pt->typ_nesting = 2;   /* Can be 2 or 1 needed actually. */
      pt->typ_max_size = pt->UU.U12.typ_high + 2;
      pt->typ_min_size = 2;
      return Result;
    }

    pt->typ_nesting = 1;
    pt->typ_max_size = pt->UU.U12.typ_high + 4;
    pt->typ_min_size = 4;
    return Result;
  } else {
    linerror(ill_basic_type);
    loc_err = true;
    backtoken();
    return NULL;

  }

  return Result;

  /* Simple types */
  /* ARRAY ( <subarray> */
  /* ACCESS <type> */
  /* R E C O R D */

  /* SEQUENCE (...) OF <type>*/
  /* Substring */
  /*if*/
}  /*parse_type*/


/*==============================================================================

                        Handle PRAGMA clause

Parses:

    <pragma clause> ::  PRAGMA TIMEOUT ( <block_id>, <time value> ) ;
                    |   PRAGMA EXTERNAL_MARSHALLING ( <type_id> ) ;
                    |   PRAGMA <name> ( <id> <anything> ) ;
    <name>          ::  <id>

On entry,
    The keyword PRAGMA has been read, and is the current token.
On exit,
    The token AFTER the final semicolon has been read and is the current token.
*/
Static Void parse_pragma()
{
  id_name pragma_name;   /* Name of pragma being invoked */
  block_table *blk;   /* Pointer to block refered to */
  block_table *block_father;   /* dummy */
  named_type *nty;   /* Pointer to named type referred to */
  named_type *type_father;   /* dummy */
  long i;   /* Loop index */
  defined_type *typ;   /* New type if needed for external */
  id_list *param;   /* Pointer to relevant parameter */
  long SET[3], SET1[3], SET2[3], SET3[3], SET4[3], SET5[3], SET6[3];

  /*parse_pragma*/
  if (expected(ident, P_expset(SET, 1L << ((long)semicolon))))
  {   /*if got pragma name*/
    pragma_name = token.UU.name;
    if (expected(opnround, P_expset(SET1, 1L << ((long)semicolon)))) {
      if (expected(ident, P_expset(SET2, 1L << ((long)semicolon)))) {
	/*   The TIMEOUT pragma allows one to define the maximum time allowed
	     for a procedure or function. It is represented by the blk_timeout parameter
	     for that procedure.
	 */
	if (!memcmp(pragma_name.str, "timeout                  ",
		    sizeof(char_name))) {
	  if (find_block(&token.UU.name, &block_father, &blk)) {
	    if (expected(comma, P_expset(SET3, 1L << ((long)semicolon)))) {
	      if (expected(number, P_expset(SET4, 1L << ((long)semicolon)))) {
		blk->blk_timeout = token.UU.value;
		if (expected(clsround,
			     P_expset(SET5, 1L << ((long)semicolon))))
		  expected(semicolon, P_expset(SET6, 1L << ((long)semicolon)));
		      /*fine - no more to do. */
	      }
	    }
	  }

	  /*   The CONCURRENT pragma allows one to specify that the execution of a
	       procedure must continue in parallel with the client.
	       It is represented by the blk_concurrent parameter for that procedure.

	       The CAST pragma allows one to specify that no reply message is used
	       for a procedure.
	   */
	} else if (!memcmp(pragma_name.str, "concurrent               ",
			   sizeof(char_name)) || !memcmp(pragma_name.str,
		     "cast                     ", sizeof(char_name))) {
/* p2c: ../rpcc.p, line 2367: Note: Line breaker spent 0.2+2.08 seconds, 143 tries on line 2809 */
	  while ((long)token.kind == (long)ident) {
	    if (!find_block(&token.UU.name, &block_father, &blk))
		  /*while if*/
		    continue;
	    if (pragma_name.str[1] == 'o')
	      blk->blk_concurrent = true;
	    else
	      blk->blk_cast = true;
	    getoken();
	    if ((long)token.kind == (long)comma)
	      expected(ident, P_expset(SET3,
			 (1L << ((long)clsround)) | (1 << ((long)semicolon))));
		  /*loop*/
	  }
	  if ((long)token.kind == (long)clsround)
	    expected(semicolon, P_expset(SET3, 1L << ((long)semicolon)));
		/*fine - no more to do. */
	  else {
	    linerror(clsround_miss);
	    if ((long)token.kind != (long)semicolon)
	      expected(semicolon, P_expset(SET3, 1L << ((long)semicolon)));
		  /*dummy*/
	  }

	  /*   If a type is external, it's name will be used in the name of the
	       marshalling routines. Therefore, we must ensure that the name of
	       the type is the name specified, and not another type (such as
	       a simple type) to which it was declared equivalent.
	   */
	} else if (!memcmp(pragma_name.str, "external_marshalling     ",
			   sizeof(char_name))) {
	  if (find_type(typeptr, &token.UU.name, &type_father, &nty)) {
	    if (nty->nty_type->typ_name != nty)
	    {   /* If type name is different */
	      typ = (defined_type *)Malloc(sizeof(defined_type));
		  /* Make a new type */
	      *typ = *nty->nty_type;   /* like the last one */
	      typ->typ_name = nty;   /* except named after us */
	      nty->nty_type = typ;   /* and use that instead. */
	    }
	    /*if*/
	    nty->nty_type->typ_external = true;
	    nty->nty_type->typ_nesting = 0;
	    external_marshalling = true;
	  } else {
	    printf(
	      "RPCC: PRAGMA EXTERNAL_MARSHALLING must refer to previously defined type\n");
	    linerror(id_not_declared);
	  }
	  if (expected(clsround, P_expset(SET3, 1L << ((long)semicolon)))) {
	    expected(semicolon, P_expset(SET4, 1L << ((long)semicolon)));
		/*fine - no more to do. */

	    /*   The CALL_STATUS pragma allows one parameter of a procedure or function
	         to be declared as a status parameter. In this case, if an error occurs
	         on the call, that parameter will be set to the status value, and the
	         other parameters will be undefined (unchanged in fact).
	         The parser sets up a pointer, blk_status_param, from the procedure
	         to the parameter to indicate this.
	     */
	  }
	} else if (!memcmp(pragma_name.str, "call_status              ",
			   sizeof(char_name))) {
	  if (!find_block(&token.UU.name, &block_father, &blk)) {
	    printf(
	      "RPCC: PRAGMA CALL_STATUS: First arg (proc/func name) not (yet) declared\n");
	    linerror(id_not_declared);
	  } else if (expected(comma, P_expset(SET3, 1L << ((long)semicolon)))) {
	    if (expected(ident, P_expset(SET4, 1L << ((long)semicolon)))) {
	      if (!find_param(&token.UU.name, blk->list, &param)) {
		printf(" RPCC: PRAGMA CALL_STATUS:\n");
		printf(" Second argument must be formal param. of proc/func\n");
		linerror(id_not_declared);
	      } else {   /*if*/
		if (blk->blk_status_param != NULL) {
		  printf("RPCC: Proc/func already has a CALL_STATUS parameter\n");
		  linerror(twice_declared);
		} else
		  blk->blk_status_param = param;
	      }
	    }
	  }
	  if (expected(clsround, P_expset(SET3, 1L << ((long)semicolon)))) {
	    expected(semicolon, P_expset(SET4, 1L << ((long)semicolon)));
		/*fine - no more to do. */

	    /*   Unknown PRAGMAs could be ADA ones or goodness knows what. We don't
	         even set warning status, we ignore them.
	     */
	  }
	} else {
	  printf("RPCC: Ignoring unknown pragma \"");
	  for (i = 0; i < pragma_name.len; i++)
	    putchar(pragma_name.str[i]);
	  printf("\"\n");   /* Ignore unknown pragma */
	  find_tok(P_expset(SET3, 1L << ((long)semicolon)));
	}
      }

    }
  }
  getoken();   /* skip semicolon */

  /*if good PRAGMA <name> ( <id>  etc */
}


/**********************************************************************
                        TYPE_DECLARE
**********************************************************************

        Parses the complete TYPE declaration section

        <typedecl>      ::      <id> IS <type> ;   <typedecl>
                        |       <void>

On entry,
    The token (TYPE) has been read
On exit,
    The next token (PROCEDURE, etc) has been read.
*/

Static Void type_declare()
{
  named_type *pnt;
  long SET[(long)functok / 32 + 2];
  long SET1[(long)functok / 32 + 2];
  long SET2[(long)functok / 32 + 2];

  while ((long)token.kind != (int)functok && (long)token.kind != (int)proctok) {
    if ((long)token.kind == (long)pragmatok) {
      parse_pragma();
      continue;
    }

    if ((long)token.kind != (long)typetok) {
      /** ERT: Skip all token until a good token is found **/
      errfind(type_miss,
	      P_addset(P_addset(P_addset(P_expset(SET, 0L), (int)proctok),
				(int)functok), (int)typetok));
/* p2c: ../rpcc.p, line 2437: Note: Line breaker spent 2.0 seconds, 165 tries on line 2950 */
    } else {
      /** We are sure that we found a TYPE declaration **/
      getoken();
      if ((long)token.kind != (long)ident) {
	/** ERT: Skip all token until a good token is found **/
	errfind(ident_req,
		P_addset(P_addset(P_addset(P_expset(SET1, 0L), (int)proctok),
				  (int)functok), (int)typetok));
/* p2c: ../rpcc.p, line 2437: Note: Line breaker spent 0.2+0.94 seconds, 169 tries on line 2959 */
	continue;
      }

      pnt = (named_type *)Malloc(sizeof(named_type));
      pnt->nty_name = token.UU.name;   /* <id> */
      getoken();

      if ((long)token.kind != (long)istok)   /* IS */
	linerror(istok_miss);
      else
	getoken();

      pnt->nty_type = parse_type();   /* <type> */

      if (pnt->nty_type != NULL) {
	insert_named_type(pnt, &typeptr);   /* Put into the type list */

	if (pnt->nty_type->typ_name == NULL)   /* Link type back to name */
	  pnt->nty_type->typ_name = pnt;
      }



      getoken();   /* Read next token */
      /*    ; */

      if ((long)token.kind != (long)semicolon) {
	/** ERT: Skip tokens until a good token is found **/
	errfind(semicol_miss,
	  P_addset(P_addset(P_addset(P_expset(SET2, 0L), (int)semicolon),
			    (int)proctok), (int)functok));
/* p2c: ../rpcc.p, line 2437: Note: Line breaker spent 0.5+0.60 seconds, 270 tries on line 2991 */
	if ((long)token.kind == (long)semicolon)   /** Skip it **/
	  getoken();
      } else  /** Semicolon found **/
	getoken();
    }  /*else_if, token <> typetok */
  }  /*end_while token = typetok*/




  /*else_if, token <> ident */
}  /*TYPE_DECLARE*/


/* Local variables for parse_parameter_list: */
struct LOC_parse_parameter_list {
  id_list *headlist;
} ;

/*____________________________________________________________________________

                        FND_IDLIST
*/
Local id_list *fnd_idlist(name, last, head, LINK)
id_name *name;
id_list **last, *head;
struct LOC_parse_parameter_list *LINK;
{
  /****
  * This function check whether 'name' is already in the list pointed by 'head'
  * Returns in 'last' last element of the list or the previous element if found.
  * Returns pointer to 'name' if succesful, nil otherwise
  *****/
  id_list *scan;
  boolean found;

  scan = head;   /** head pointer to the list to check **/
  *last = head;
  found = false;
  while (scan != NULL && !found) {
    if (!memcmp(scan->name.str, name->str, sizeof(char_name)))
      found = true;
    else {
      *last = scan;
      scan = scan->next;
    }
  }

  return scan;   /** Returns element or nil **/
}  /*FND_IDLIST*/

/*_____________________________________________________________________________

                        GET_IDLIST
*/
Local id_list *get_idlist(LINK)
struct LOC_parse_parameter_list *LINK;
{
  /****
  * This function builds a list of identifier and returns a pointer
  * to the header. Returns NIL in case of error (No tokens are skipped!!)
  *****/
  id_list *localist, *last, *scan;
  named_type *junk1, *junk2;
  long SET[3];

  localist = NULL;
  do {
    getoken();
    /** Get a parameter definition **/
    if ((long)token.kind != (long)ident)
      errfind(ident_req, P_expset(SET,
	  (1L << ((long)comma)) | (1 << ((long)ident)) | (1 << ((long)colon))));
    if ((long)token.kind == (long)ident) {
      /****************************
      * Check if this identifier was already declared.
      * There are 3 lists in which we check:
      1) list of global types.
      2) list of all variables declared in this block,
               pointed by headlist.
      3) list of variables read in this functions,
               pointed by localist.
      *******************************/
      if (find_type(typeptr, &token.UU.name, &junk1, &junk2) |
	  (fnd_idlist(&token.UU.name, &scan, LINK->headlist, LINK) != NULL) |
	  (fnd_idlist(&token.UU.name, &last, localist, LINK) != NULL))
/* p2c: ../rpcc.p, line 2702: Note: Line breaker spent 0.1+1.66 seconds, 122 tries on line 3078 */
	    /** But ignore it!!! **/
	      linerror(twice_declared);
      else {
	scan = (id_list *)Malloc(sizeof(id_list));
	scan->name = token.UU.name;
	scan->next = NULL;
	if (last == NULL)   /** Empty list **/
	  localist = scan;
	else
	  last->next = scan;
      }
      getoken();
    }  /** kind = ident **/
  } while ((long)token.kind == (long)comma);

  return localist;

  /** Add 'name' to the list, this is done
  * adding in QUEUE, do not change this! **/
}  /*GET_IDLIST*/


/******************************************************************************
*
*               BLOCK DECLARATION ANALIZER
*
*******************************************************************************/

/*                       Parse a list of parameters
                         ==========================

                 <paramlist> ::  <idlist> : <direction> <type>

                 <idlist>    ::  <id>
                             |   <id> , <idlist>

                 <direction> ::  <void>  |  IN | OUT | IN OUT
 */
Static Void parse_parameter_list(block)
block_table *block;
{
  /*
    This function builds a list of identifiers with their types associated.

   On entry,
       'block' describes a new procedure or function.
       no fields need be filled in in 'block'.

   On exit,
       block.list          Points to a list of paramaters;
       block.nesting       gives the number of indeces needed for (un)packing
       block.blk_min_in    gives the minimum size of the input parameters
       block.blk_max_in    gives the maximum size of the input parameters
       block.blk_min_out   gives the minimum size of the output parameters
       block.blk_max_out   gives the maximum size of the output parameters

   * Small explanation:
   * 1) get a list of identifier separate by commas. (id1, id2, id3, ....).
        This list is pointed by 'identlist'.
   * 2) get the type definition: according to PASCAL rules, token should be:
           1) identifier, then we look in the TYPE list;
           2) RPCL simple type;

           We do NOT allow to declare RPCL structured type as procedure parameter
           because PASCAL compilers do not allow the declaration of a structured
           type as parameter. Example: suppose user declares:
           PROCEDURE PLUTO(PIPPO IN : SEQUENCE[100] OF SHORT);
           We can not expand in PASCAL statement:
           PROCEDURE PLUTO(L_PIPPO : INTEGER; A_PIPPO: ARRAY[1..100] OF RPC_SHORT);
           because the PASCAL compiler would complain.
           Instead we manage this unpleasant situation in such a way:
           a) User must declare a RPCL structured type in TYPE section declaration.
           b) RPCC creates a TYPE declaration for that identifier and type ONLY
              for the structured type embedded in such RPCL type
           c) RPCC expand procedure parameter using such a definition.
           Example: (RPCL User program)

             TYPE
                   PAPERO = SEQUENCE(2000) OF SHORT;
             PROCEDURE PLUTO(PIPPO IN : PAPERO);

           will be expanded as: (RPCC output in PASCAL)

             TYPE
                   PAPERO = ARRAY [1..2000] OF RPC_SHORT;
             PROCEDURE PLUTO(L_PIPPO : INTEGER; A_PIPPO : PAPERO);

           (Note: The length parameter now FOLLOWS the array - TBL)

   * 3) If no error found fills the list of identifiers with their attributes:
        direction and type AND

   * 4) add to the global list pointed by 'headlist'.

   * 5) 'Loop' until ')'.

   * WARNING:
   * The list of the identifiers build on point 1 is split. So in the 'code'
   * generation we will produce the parameter's list in the same order as
   * declared but not in 'comma' format. (Without commas, I mean). So:
   *               procedure bb( a,b,c : short);
   * will be output as:
   *               procedure bb( a: short; b: short; c: short);
   *
   *****/
  struct LOC_parse_parameter_list V;
  id_list *identlist, *tailist, *last;
  defined_type *ptr2type;
  type_token direction;
  boolean got_error;
  long SET[(long)functok / 32 + 2];

  /*_____________________________________________________________________________

         main block of parse_parameter_list;
  */
  got_error = false;
  V.headlist = NULL;   /** Pointer to the head of the list to bulid **/
  do {

    /** Get the list of identifiers (id1, id2, id3, ...) **/
    identlist = get_idlist(&V);
    /** Now 'identlist points to the header of this list **/
    /** Get_idlist already reads next token **/

    if ((long)token.kind != (long)colon)   /** But ignore **/
      linerror(colon_miss);
    else
      getoken();

    /* Get direction attribute */

    if ((unsigned long)token.kind >= 32 || ((1L << ((long)token.kind)) &
	    ((1L << ((long)intok)) | (1 << ((long)outok)))) == 0)
/* p2c: ../rpcc.p, line 2702: Note: Line breaker spent 4.8+0.66 seconds, 743 tries on line 3213 */
      direction = intok;   /** Assume inout, perhaps forgotten **/
    else {
      direction = token.kind;
      getoken();
      if ((long)direction == (long)intok && (long)token.kind == (long)outok) {
	direction = inoutok;
	getoken();
      }
    }

    /* Get type definition       : <type>

        Originally, the type had to be a named type, but now we can generate
        an arbitrary name for an unnamed type. The name is needed for Pascal.
    */

    ptr2type = parse_type();   /* Parse it */
    ensure_type_named(ptr2type);   /* Invent a name if necessary */

    /*   Fill in this information for each parameter name:
    */
    if (identlist != NULL && ptr2type != NULL)
    {   /** Else ignore this wrong definition **/
      /* Find maximum nesting: */
      if (ptr2type->typ_nesting > block->blk_nesting)
	block->blk_nesting = ptr2type->typ_nesting;

      /** Add direction and type attributes **/
      if (V.headlist == NULL)   /** Empty list **/
	V.headlist = identlist;
      else
	tailist->next = identlist;
      tailist = identlist;
      do {
	tailist->attr = direction;
	tailist->id_type = ptr2type;
	last = tailist;
	tailist = tailist->next;
	/* Accumulate total parameter size: */
	if (((1L << ((long)direction)) &
	     ((1L << ((long)intok)) | (1 << ((long)inoutok)))) != 0) {
	  block->blk_max_in += ptr2type->typ_max_size;
	  block->blk_min_in += ptr2type->typ_min_size;
	}
	if (((1L << ((long)direction)) &
	     ((1L << ((long)outok)) | (1 << ((long)inoutok)))) != 0) {
	  block->blk_max_out += ptr2type->typ_max_size;
	  block->blk_min_out += ptr2type->typ_min_size;
	}

      } while (tailist != NULL);
      tailist = last;
    }

    getoken();
    if ((unsigned long)token.kind >= 32 || ((1L << ((long)token.kind)) &
	    ((1L << ((long)semicolon)) | (1 << ((long)clsround)))) == 0) {
/* p2c: ../rpcc.p, line 2702: Note: Line breaker spent 1.5+0.24 seconds, 763 tries on line 3271 */
      /** Semicolon or clsround missed.
      * ERT: Skip this parameter's definition and
      * find a semicolon or a closed round bracket or
      * a proctok/functok declaration
      **/
      errfind(semic_round_miss,
	      P_addset(P_addset(P_addset(P_addset(P_addset(P_expset(SET, 0L),
							   (int)semicolon),
					   (int)clsround), (int)functok),
				(int)proctok), (int)ident));
/* p2c: ../rpcc.p, line 2702: Note: Line breaker spent 10.8+0.74 seconds, 5000 tries on line 3282 */
      switch (token.kind) {

      case semicolon:
      case clsround:
	/* blank case */
	break;

      case ident:   /** Continue analisys **/
	backtoken();
	break;

      case colon:
      case functok:
      case proctok:
	got_error = true;
	backtoken();
	break;
      }
    }
  } while (!((long)token.kind == (long)clsround || got_error));

  block->list = V.headlist;
}  /*parse_parameter_list*/


/**********************************************************************
                BLOCK_DECLARE
***********************************************************************/

Static Void block_declare()
{
  block_table block;
  named_type *junk1, *scan;
  block_table *blk, *junk2, *lastblock;
  boolean localerr;
  id_list *ascan;
  long SET[(long)pragmatok / 32 + 2];
  long SET1[(long)functok / 32 + 2];

  do {
    localerr = false;

    block.blk_nesting = 0;   /* Initialise indeces required */
    block.blk_min_in = 0;   /* Initialize parameter size counts */
    block.blk_min_out = 0;
    block.blk_max_in = 0;
    block.blk_max_out = 0;

    if ((long)token.kind != (int)endtok && (long)token.kind != (int)pragmatok &&
	(long)token.kind != (int)functok && (long)token.kind != (int)proctok)
      errfind(proc_exp,
	P_addset(P_addset(P_addset(P_addset(P_expset(SET, 0L), (int)proctok),
				   (int)functok), (int)endtok),
		 (int)pragmatok));
/* p2c: ../rpcc.p, line 2836: Note: Line breaker spent 1.7+1.40 seconds, 1244 tries on line 3337 */

    if ((long)token.kind == (long)pragmatok)
      parse_pragma();
    else if ((long)token.kind != (long)endtok) {
      /** Save block type **/
      block.b_type = token.kind;
      block.in_only = ((long)token.kind == (long)proctok);
	  /* could be in_only */

      getoken();   /* <ident> */
      if ((long)token.kind != (long)ident) {
	/** ERT: ignore, but do not build any block later **/
	linerror(ident_req);
	localerr = true;
      } else {
	block.name = token.UU.name;
	if (find_type(typeptr, &token.UU.name, &junk1, &scan) |
	    find_block(&token.UU.name, &lastblock, &junk2)) {
	  /** ERT: ignore, but do not build any block later **/
	  linerror(twice_declared);
	  localerr = true;
	}
      }

      getoken();   /*  (    */
      if ((long)token.kind == (long)opnround) {   /* TBL 18.8.86 */
	parse_parameter_list(&block);   /* ... ) */
	getoken();
      } else {
	if ((unsigned long)token.kind < 32 &&
	    ((1L << ((long)token.kind)) & ((1L << ((long)inoutok)) |
	       (1 << ((long)intok)) | (1 << ((long)outok)))) != 0) {
/* p2c: ../rpcc.p, line 2836: Note: Line breaker spent 1.7+0.62 seconds, 1309 tries on line 3370 */
	  linerror(opnround_miss);
	  backtoken();
	  parse_parameter_list(&block);   /* ... ) */
	  getoken();
	} else
	  block.list = NULL;
      }



      if ((long)block.b_type == (long)functok) {   /*functok*/
	if ((long)token.kind != (long)return_)   /** But ignore **/
	  linerror(return_miss);
	else
	  getoken();
	if ((long)token.kind == (long)ident) {
	  /** Scan the types' list **/
	  if (find_type(typeptr, &token.UU.name, &junk1, &scan))
	    block.return_ = scan->nty_type->typ_basic_type;
	  else {
	    linerror(id_not_declared);
	    localerr = true;
	  }
	} else
	  block.return_ = token.kind;

	if (((1L << ((long)block.return_)) &
	     ((1 << ((long)longtok + 1)) - (1 << ((long)chartok)))) != 0) {
	  getoken();
	  block.blk_max_out +=
	    simple_descriptor[(long)block.return_ - (long)chartok]->typ_max_size;
	  block.blk_min_out +=
	    simple_descriptor[(long)block.return_ - (long)chartok]->typ_min_size;
	} else {
	  localerr = true;
	  linerror(simtype_req);
	}

      } else {   /*proctok*/
	/* Check for OUT or INOUT parameters to a procedure */

	ascan = block.list;
	while (ascan != NULL) {
	  if ((long)ascan->attr != (long)intok)
	    block.in_only = false;
	  ascan = ascan->next;
	}  /*while*/

      }  /*procok*/

      if ((long)token.kind != (long)semicolon) {
	errfind(semicol_miss,
	  P_addset(P_addset(P_addset(P_addset(P_expset(SET1, 0L),
					      (int)semicolon), (int)proctok),
			    (int)functok), (int)endtok));
/* p2c: ../rpcc.p, line 2836: Note: Line breaker spent 5.1+1.09 seconds, 2854 tries on line 3426 */
	if ((long)token.kind == (long)semicolon)
	  getoken();
      } else
	getoken();

      if (!localerr) {
	blk = (block_table *)Malloc(sizeof(block_table));
	*blk = block;
	blk->next = NULL;
	blk->blk_status_param = NULL;
	blk->blk_cast = false;
	blk->blk_concurrent = false;
	if (runoptions[(long)timeout - (long)ccerncross].value)
	  blk->blk_timeout = timeout_val;   /* default timout */
	else
	  blk->blk_timeout = rpc_default_timeout;

	if (lastblock == NULL) {
	  /** List empty, update blockptr **/
	  blockptr = blk;
	} else
	  lastblock->next = blk;
      }
      /** Create a new element and save the name **/
    }

  } while ((long)token.kind != (long)endtok);



  /*if kind <> endtok*/
}  /*BLOCDECLARE*/


/*************************************************************************

        Parser Initialisation

On exit,
    The simple type descriptors are prepared for the more complex
    types and parameters to be linked to.
*/
Static Void initialise_parser()
{
  type_token t;
  defined_type *WITH;
  named_type *WITH1;
  id_name *WITH2;

  /*initialise_parser*/
  for (t = chartok; (long)t <= (long)longtok; t = (type_token)((long)t + 1))
  {   /*for*/
    simple_descriptor[(long)t - (long)chartok] =
      (defined_type *)Malloc(sizeof(defined_type));
    WITH = simple_descriptor[(long)t - (long)chartok];
    WITH->typ_basic_type = t;
    WITH->typ_nesting = 0;   /* No indeces are necessary for this type */
    WITH->typ_subtype = NULL;
    WITH->typ_name = (named_type *)Malloc(sizeof(named_type));
    WITH1 = WITH->typ_name;

    WITH1->nty_name.len = MAXIDLEN;
    WITH1->nty_type = simple_descriptor[(long)t - (long)chartok];
    WITH1->nty_next = NULL;
    switch (t) {

    case chartok:
    case bytetok:
      WITH->typ_max_size = 1;
      break;

    case shortok:
    case integertok:
      WITH->typ_max_size = 2;
      break;

    case real32tok:
    case longtok:
      WITH->typ_max_size = 4;
      break;

    case real48tok:
    case real64tok:
      WITH->typ_max_size = 8;
      break;

    case real128tok:
      WITH->typ_max_size = 16;
      break;
    }/*end_case*/
    WITH->typ_min_size = WITH->typ_max_size;   /*with*/
  }

  memcpy(simple_descriptor[0]->typ_name->nty_name.str,
	 "rpc_char                 ", sizeof(char_name));
  memcpy(simple_descriptor[(long)bytetok - (long)chartok]->typ_name->nty_name.str,
	 "rpc_byte                 ", sizeof(char_name));
  memcpy(simple_descriptor[(long)shortok - (long)chartok]->typ_name->nty_name.str,
	 "rpc_short                ", sizeof(char_name));
  memcpy(simple_descriptor[(long)integertok - (long)chartok]->typ_name->
	 nty_name.str, "rpc_integer              ", sizeof(char_name));
  memcpy(simple_descriptor[(long)real32tok - (long)chartok]->typ_name->nty_name.str,
	 "rpc_real32               ", sizeof(char_name));
/* p2c: ../rpcc.p, line 2904: Note: Line breaker spent 0.1+1.04 seconds, 55 tries on line 3530 */
  memcpy(simple_descriptor[(long)longtok - (long)chartok]->typ_name->nty_name.str,
	 "rpc_long                 ", sizeof(char_name));
  memcpy(simple_descriptor[(long)real48tok - (long)chartok]->typ_name->nty_name.str,
	 "rpc_real48               ", sizeof(char_name));
  memcpy(simple_descriptor[(long)real64tok - (long)chartok]->typ_name->nty_name.str,
	 "rpc_real64               ", sizeof(char_name));
  memcpy(simple_descriptor[(long)real128tok - (long)chartok]->typ_name->
	 nty_name.str, "rpc_real128              ", sizeof(char_name));

  for (t = chartok; (long)t <= (long)longtok; t = (type_token)((long)t + 1))
  {   /* strip trailing spaces */
    WITH = simple_descriptor[(long)t - (long)chartok];
    WITH1 = WITH->typ_name;
    WITH2 = &WITH1->nty_name;
    while (WITH2->str[WITH2->len - 1] == ' ')
      WITH2->len--;
  }

  number_of_invented_types = 0;
  external_marshalling = false;   /* Not invoked yet */

}


/*****************************************************************
*
*               PARSER, MAIN LOOP
*
******************************************************************/

Static Void parser()
{
  initialise_parser();
  /** Look for 'PACKAGE' **/
  getoken();
  if ((long)token.kind != (long)package)   /** Ignored if missed **/
    linerror(package_miss);
  else
    getoken();
  /** Look for 'unit - name' **/
  if ((long)token.kind != (long)ident)   /*Ignore*/
    linerror(ident_req);
  else {   /*if*/
    unitname = token.UU.name;
    getoken();
  }

  /** Look for 'is' **/
  if ((long)token.kind != (long)istok)   /*Ignore*/
    linerror(istok_miss);
  else
    getoken();

  /** Look for 'type' **/
  type_declare();
  /** Returns with the next token already read **/

  if ((long)token.kind == (long)endtok) {
    linerror(blocks_req);
    return;
  }
  block_declare();
  if ((long)token.kind != (long)endtok)
    linerror(endtok_miss);
  else
    getoken();
  if ((long)token.kind != (long)ident)
    linerror(ident_req);
  else {
    if (memcmp(token.UU.name.str, unitname.str, sizeof(char_name)))
      linerror(bad_name);
  }
  getoken();
  if ((long)token.kind != (long)semicolon)
    linerror(semicol_miss);


  /*if*/
}  /*PARSER*/


/* Code generation (PILS, FORTRAN generation in separate files)
*/
/*                                                                       CODEFOR

        Top-down RPC compiler:          Code generator for FORTRAN
        ======================          ==========================


History:
       Nov 88   Composite types and pointers; arrays of named types.
                FORTRAN version made from Pascal/C versions! (TBL)
                (Talk about backward steps!?!)

     8 May 1988 detach_xxx and close_xxx and S_xxxx common block introduced.
    22 Jun 1989 REQUEST is now declared INTEGER*2 as it is UPK_SHORT()-ed

Requirements of the run-time system:

    1.  RPC_BEGIN_CALL_FOR must
            o   Set up the 'procedure number' and 'version' fields;
            o   Leave the m_index pointer to call_header_length;
    2.  RPC_END_CALL_FOR must dispose of the message
    3.  RPC_CALL must leave m_index set to return_header_length
    4.  On entry into the server stub, m_index must be = call_header_length-4
    5.  The routine RPC_INIT_RETURN_FOR must set it to return_header_length
    6.  PCK/UPK_STRING_FOR must pack and unpack strings, and post-align.
    7.  PCK/UPK_SUBSTRING_FOR must pack and unpack substrings, and post-align.
    8.  RPC_SET_ERROR must set the m_status field of the message as given.
    9.  RPC_ATTACH_STUB_FOR is a fortran callable rpc_attach_stub
   10.  RPC_DETACH_STUB_FOR is a fortran callable rpc_detach_stub
   11.  RPC_OPEN_FOR        is a fortran callable rpc_open
   12.  RPC_CLOSE_FOR       is a fortran callable rpc_close
   13.  PCK/UPK_xxxx_FOR are the packing/unpacking routines Fortran callable.
   14.  RPC_NO_RETURN must set the message status to "Normal" to inhibit reply.

VAX/FORTRAN-isms in code produced by this module:

    o   The long names and embedded underscore characters in identifiers;
    o   The STRUCTURE/RECORD types (if used);
    o   The length specification on INTEGER for rpc_short & rpc_long (if used);
    o   The BYTE data type for rpc_byte (if used).

Restrictions:

    1.  The data types are restricted to VAX/FORTRAN data types: No pointers
        but record types are allowed.

Note:
    1.  The PARAMETER statements generated to define the two RPC error
        codes produced by a server stub should match RPC$CONST always.
*/
/*___________________________________________________________________________

        Convert character to Upper case
*/
Static Char upper_case(ch)
Char ch;
{
  if (islower(ch))
    return ((Char)(ch - 32L));
  else
    return ch;
}


/*___________________________________________________________________________

        Write out one identifier (in uppercase if FORTRAN)
*/
Static Void write_name(where, name)
FILE **where;
id_name *name;
{
  long a, FORLIM;

  FORLIM = name->len;
  for (a = 0; a < FORLIM; a++) {
    if ((long)omode == (long)vaxfor)
      fputc(upper_case(name->str[a]), *where);
    else
      putc(name->str[a], *where);
  }
}


/*___________________________________________________________________________

        Write out component expression  (in uppercase if FORTRAN)
        ------------------------------
*/
Static Void write_exp(where, expr)
FILE **where;
expression *expr;
{
  long a, FORLIM;

  FORLIM = expr->len;
  for (a = 0; a < FORLIM; a++) {
    if ((long)omode == (long)vaxfor)
      fputc(upper_case(expr->str[a]), *where);
    else
      putc(expr->str[a], *where);
  }
}


/*___________________________________________________________________________

        Write a quoted string padded to 40 characters
*/
Static Void write_name_padded(op_file, name, ch)
FILE **op_file;
id_name name;
Char ch;
{
  /*write_name_padded*/
  putc(ch, *op_file);
  write_name(op_file, &name);
  fprintf(*op_file, "%*c", (int)(rpc_name_length - name.len + 1), ch);
}


/*=============================================================================

                        FORTRAN-sepcific procedures
*/
/*____________________________________________________________________________

        Code generator error
        --------------------

    Code generator errors are internal errors or target-dependent error.
*/
Static Void codefor_error(why)
Char *why;
{
  printf(" RPCC: **** Error: %.*s\n", error_length, why);
  printf("       (Error detected at FORTRAN code generator stage.)\n");
  _Escape(0);
}


/*___________________________________________________________________________

        Indenting algorithm
*/
Static long IndFor(level)
long level;
{
  return (level * 3 + 3);
}


/*___________________________________________________________________________

        Start a Continuation Line
*/
Static Void continuation()
{
  fprintf(op_file, "\n     +");
}


/*___________________________________________________________________________

        Append a FORTRAN index to an array expression

    Level = 1       =>      RPC_A   used,
    Level = 2       =>      RPC_B   used etc...
*/
Static Void append_index_for(expr, level)
expression *expr;
long level;
{
  format(expr, "$(RPC_    ");
  append_1(expr, (Char)(level - 1 + 'A'));
  append_1(expr, ')');

}


/*___________________________________________________________________________

      Generate procedure name to (un)pack a simple type or descriptor
      ---------------------------------------------------------------

    Used for the function return result.

|       generates:      upk/pck_ttt(rpc_p_buf,
*/
Static Void pack_simple_for(where, what, topack)
FILE **where;
type_token what;
boolean topack;
{
  fprintf(*where, "      CALL ");
  if (topack)
    fprintf(*where, "PCK_");
  else
    fprintf(*where, "UPK_");
  switch (what) {

  case chartok:
    fprintf(*where, "CHAR");
    break;

  case bytetok:
    fprintf(*where, "BYTE");
    break;

  case shortok:
    fprintf(*where, "SHORT");
    break;

  case integertok:
    fprintf(*where, "INTEGER");
    break;

  case real32tok:
    fprintf(*where, "REAL32");
    break;

  case real48tok:
    fprintf(*where, "REAL48");
    break;

  case real64tok:
    fprintf(*where, "REAL64");
    break;

  case real128tok:
    fprintf(*where, "REAL128");
    break;

  case longtok:
    fprintf(*where, "LONG");
    break;
  }
  fprintf(*where, "_FOR(RPC_P_BUF,");
}


/*___________________________________________________________________________

        Generate code to:       Align on a 2**power byte boundary

    Currently, only aligns on word boundaires, because that is all
    we need.
*/
Static Void gen_align_for(power, level)
long power, level;
{
  /*gen_align_for*/
  fprintf(op_file, "%*cCALL RPC_ALIGN(RPC_P_BUF,%ld)\n",
	  (int)IndFor(level), ' ', power);
  /* Extra runtime support needed here */
}


/*___________________________________________________________________________

        Generate code to:       (un)Pack a parameter of given type
        ----------------        ----------------------------------

    This recursive procedure uses the 'level' parameter to control the
    amount of indentation at each stage, and which rpc_<level> parameters
    may be accessed by any given stage.

    If the type is declared as 'EXTERNAL_MARSHALLING, then an external
    procedure PCK_<typename> or UPCK_<typename> is called to do the
    marshalling.

On entry,
    Output cursor at left margin.
On exit,
    Output cursor at left margin.
*/
Static Void gen_pack_type_for(where, expr, typ, level, topack)
FILE **where;
expression expr;
defined_type *typ;
long level;
boolean topack;
{
  /* output file */
  /* Expression for variable */
  /* type descriptor */
  /* indentation & rpc_<level> */
  /* pack or unpack? */
  Char ch;
  named_type *scan;
  defined_type *element;   /* Array element type */
  long depth;   /* Depth of nesting of array element */
  expression exp2, l_expr;   /* Expression for the length of a string, etc */
  expression s_expr;   /* Expression for the start of a substring */
  long i;   /* Loop index */
  id_name *WITH1;
  long FORLIM;
  defined_type *WITH2;
  named_type *WITH3;

  /*_____________________________________________________________________________
                      Main block of gen_pack_type_for
  */

  /*gen_pack_type_for*/
  /*    Generate a few useful expressions: */

  ch = (Char)(level - 1 + 'A');   /*for RPC_A etc */
  l_expr = expr;   /*   x */
  prepend_1(&l_expr, '_');   /*  _x */
  s_expr = l_expr;   /*  _x */
  prepend_1(&l_expr, 'L');   /* L_x */
  prepend_1(&s_expr, 'S');   /* S_x */

  if (typ->typ_external) {
    fprintf(*where, "%*cCALL ", (int)IndFor(level), ' ');
    if (topack)
      fprintf(*where, "PCK_");
    else
      fprintf(*where, "UPK_");
    write_name(&op_file, &typ->typ_name->nty_name);
    fprintf(*where, "(RPC_P_BUF,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");

    return;
  }
  switch (typ->typ_basic_type) {   /*case*/

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          S I M P L E

  Here we assume that the names of the pck/upk routines are consistent
  with the names rpc_xxx of the basic types. The exception is the code
  for unpacking a character, which is going to be a bit weierd, because
  of the descriptor.

  */
  case chartok:   /*simple type */
    fprintf(*where, "%*cCALL ", (int)IndFor(level), ' ');
    if (topack)
      fprintf(*where, "PCK");
    else
      fprintf(*where, "UPK");
    fprintf(*where, "_CHAR_FOR(RPC_P_BUF,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");
    break;

  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /*simple type */
    fprintf(*where, "%*cCALL ", (int)IndFor(level), ' ');
    if (topack)
      fprintf(*where, "PCK");
    else
      fprintf(*where, "UPK");
    WITH1 = &typ->typ_name->nty_name;   /* eg "_INTEGER" */
    FORLIM = WITH1->len;
    for (i = 3; i < FORLIM; i++)
      fputc(upper_case(WITH1->str[i]), *where);
    fprintf(*where, "_FOR(RPC_P_BUF,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

                                                          A R R A Y
  Example:    DO RPC_A=1,12
                  DO RPC_B=1,10
                          ...MYVAR(RPC_A,RPC_B)...
                  END DO
              END DO

  */
  case arraytok:   /*arraytok*/
    exp2 = expr;
    depth = level;
    ch = (Char)(depth + 'A' - 1);
    element = typ->typ_subtype;
    format(&exp2, "$(RPC_    ");
    append_1(&exp2, ch);
    fprintf(*where, "%*c", (int)IndFor(depth), ' ');
    fprintf(*where, "DO RPC_%c=1,%ld\n",
	    ch, typ->UU.U12.typ_high - typ->UU.U12.typ_low + 1);
    while ((long)element->typ_basic_type == (long)arraytok) {
      WITH2 = element;
      depth++;
      ch = (Char)(depth + 'A' - 1);
      fprintf(*where, "%*c", (int)IndFor(depth), ' ');
      fprintf(*where, "DO RPC_%c=1,%ld\n",
	      ch, WITH2->UU.U12.typ_high - WITH2->UU.U12.typ_low + 1);
      format(&exp2, "$,RPC_    ");
      append_1(&exp2, ch);
      element = element->typ_subtype;   /*while*/
    }
    append_1(&exp2, ')');

    gen_pack_type_for(where, exp2, element, depth + 1, topack);

    while (depth >= level) {   /*while*/
      fprintf(*where, "%*cEND DO\n", (int)IndFor(depth), ' ');
      depth--;   /* Come back out of nesting */
    }
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case recordtok:   /*recordtok*/
    /* R E C O R D */
    scan = typ->UU.typ_fields;
    while (scan != NULL) {
      WITH3 = scan;
      exp2 = expr;
      append_1(&exp2, '.');
      append_name(&exp2, WITH3->nty_name);
      gen_pack_type_for(where, exp2, WITH3->nty_type, level, topack);
      scan = WITH3->nty_next;   /*while*/
    }
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          A C C E S S

  */
  case accesstok:   /*accesstok*/
    codefor_error("No ACCESS (POINTER) type exists in FORTRAN!     ");
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case sequence:   /*sequence*/
    /* S E Q U E N C E */
    if (level > 1)
      codefor_error("SEQUENCE type not allowed within composite type.");

    gen_pack_type_for(where, l_expr,
		      simple_descriptor[(long)integertok - (long)chartok],
		      level, topack);

    exp2 = expr;
    format(&exp2, "A_$       ");   /* Make an expression for the array*/
    append_index_for(&exp2, level);   /* Make expression for an element */

    fprintf(*where, "%*c", (int)IndFor(level), ' ');
    fprintf(*where, "DO RPC_%c=1, L_", ch);
    write_exp(where, &expr);
    putc('\n', *where);

    gen_pack_type_for(where, exp2, typ->typ_subtype, level + 1, topack);
    fprintf(*where, "%*cEND DO\n", (int)IndFor(level), ' ');
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  In the server, strings are unpacked and the lengths fudged in the descriptor
  by the routine UPK_VSTRING_FOR(buffer, string, length).
  */
  case stringtok:   /*stringtok*/
    /* S T R I N G */
    fprintf(*where, "%*c", (int)IndFor(level), ' ');
    if (topack)
      fprintf(*where, "CALL PCK_STRING_FOR");
    else if (client)
      fprintf(*where, "CALL UPK_STRING_FOR");
    else
      fprintf(*where, "CALL UPK_VSTRING_FOR");
    fprintf(*where, "(RPC_P_BUF,");
    write_exp(where, &expr);
    if (!topack && !client)
      fprintf(*where, ",%ld", typ->UU.U12.typ_high);
    fprintf(*where, ")\n");

    break;


  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                            S U B S T R I N G

  */
  case substring:   /*substring*/
    fprintf(*where, "%*c", (int)IndFor(level), ' ');
    if (topack)
      fprintf(*where, "CALL PCK_SUBSTRING_FOR");
    else
      fprintf(*where, "CALL UPK_SUBSTRING_FOR");
    fprintf(*where, "(RPC_P_BUF,A_");
    write_exp(where, &expr);
    putc(',', *where);
    continuation();   /* Keep it in 72 characters */
    fprintf(*where, "S_");
    write_exp(where, &expr);
    fprintf(*where, ",L_");
    write_exp(where, &expr);
    fprintf(*where, ")\n");

    break;


  }
}


/*___________________________________________________________________________

        Generate code to:       (un)Pack all parameters necessary
        -----------------       ---------------------------------

The dirn parameter is INtok or OUTok, to specify which parameters to unpack.

A string descriptor needs to be initialised, including the creation of the
string, at the server side, and the string has to be disposed of afterwards.

*/
Static Void Gen_Pack_For(where, head, dirn, topack)
FILE **where;
id_list *head;
type_token dirn;
boolean topack;
{
  /* Output file */
  /* Parameter list */
  /* Parameter filter */
  /* Pack, rather than unpack? */
  expression expr;
  defined_type *WITH1;

  do {
    WITH1 = head->id_type;


    /* generate an expression for the variable: */

    expr.len = 0;   /* Expression for the variable */
    append_name(&expr, head->name);   /* expr is the param. name */


    /*       Pack or unpack
             --------------
     */
    if ((long)head->attr == (long)inoutok || (long)head->attr == (long)dirn)
    {   /*if*/
      deref = (client && !(runoptions[(long)byvalue - (long)ccerncross].value &&
			   (long)head->attr == (long)intok));
	  /** not value param **/
      /* and in-only param */

      /*level*/
      gen_pack_type_for(where, expr, head->id_type, 1L, topack);

    }

    /*with*/
    head = head->next;
  } while (head != NULL);
}  /*Gen_Pack_For*/


/*               (end of packing/unpacking)
*****************************************************************************

            Generate:       A type declaration in FORTRAN

    This recursive procedure generates a definition of a type, given
    a name and a type descriptor. It is impossible to generate a type
    itself, as the name is buried within it in FORTRAN.

    Examples
            CHARACTER*80    MYSTR(10,2)
                for
                    mystr:  ARRAY[1..10, 1..2] OF STRING(80);

            RECORD /MYSTRUCTURE/ MYVARIABLE(4)
                for
                    myvariable: ARRAY[1..4] OF MYSTRUCTURE;
    Note: In a client routine, a string has an undefined length
    (character * ( * ) ).  In the server, a length must be defined for it
    as well.

On entry,
    Cursor is assumed to be at left margin.
On exit,
    Cursor is again at the left margin.
*/

Static Void gen_type_decl_for(expr, pt, level)
expression expr;
defined_type *pt;
long level;
{
  /* for the varaiable */
  /* type structure */
  /* indentation */
  defined_type *scan;
  expression exp2;

  /*gen_type_decl_for*/
  switch (pt->typ_basic_type) {   /*with, case*/

  case chartok:
  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /* First token, simple type, courier type */
    fprintf(op_file, "%*c", (int)IndFor(level), ' ');
    switch (pt->typ_basic_type) {   /*case*/

    case chartok:
      fprintf(op_file, "CHARACTER*1");
      break;

    case bytetok:   /* @@ VAX ONLY */
      fprintf(op_file, "BYTE");
      break;

    case integertok:
      fprintf(op_file, "INTEGER");
      break;

    case real32tok:
      fprintf(op_file, "REAL");
      break;

    case real48tok:
      fprintf(op_file, "DOUBLE");
      break;

    case real64tok:
      fprintf(op_file, "DOUBLE");
      break;

    case real128tok:
      fprintf(op_file, "DOUBLE");
      break;

    case shortok:   /* @@ VAX ONLY */
      fprintf(op_file, "INTEGER*2");
      break;

    case longtok:   /* @@ VAX ONLY */
      fprintf(op_file, "INTEGER*4");
      break;
    }
    putc(' ', op_file);
    write_exp(&op_file, &expr);   /* Example: rpc_char x */
    putc('\n', op_file);
    break;
    /*simple type*/

  case substring:
  case stringtok:   /*stringtok*/
    /* Example: rpc_char x[81] */
    fprintf(op_file, "%*c", (int)IndFor(level), ' ');
    if (client)
      fprintf(op_file, "CHARACTER*(*) ");
    else
      fprintf(op_file, "CHARACTER*%ld ", pt->UU.U12.typ_high);
    write_exp(&op_file, &expr);
    putc('\n', op_file);
    break;

  case sequence:
  case arraytok:   /*arraytok*/
    /* example  INTEGER MYARR(10,20) */
    exp2 = expr;
    append_1(&exp2, '(');
    append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
    scan = pt->typ_subtype;
    while ((long)scan->typ_basic_type == (long)arraytok) {   /*while*/
      append_1(&exp2, ',');
      append_decimal(&exp2, scan->UU.U12.typ_high - scan->UU.U12.typ_low + 1);
      scan = scan->typ_subtype;
    }
    append_1(&exp2, ')');
    gen_type_decl_for(exp2, scan, level);   /*non-array type*/
    break;

  case accesstok:
    codefor_error("Package has pointers: Can't make FORTRAN stubs. ");
    break;

  case recordtok:  /* VAX/FORTRAN ONLY! */
    fprintf(op_file, "%*cRECORD ", (int)IndFor(level), ' ');
    if (pt->typ_name == NULL)
      codefor_error("Every structure must be named for VAX/FORTRAN.  ");
    else {   /*if*/
      putc('/', op_file);
      write_name(&op_file, &pt->typ_name->nty_name);
      fprintf(op_file, "/ ");
    }
    write_exp(&op_file, &expr);
    putc('\n', op_file);
    break;

  }
}


/*_____________________________________________________________________________

                Generate Common Block for this client

*/
Static Void gen_client_common()
{
  /*gen_client_common*/
  fprintf(op_file, "      COMMON /C_");
  write_name(&op_file, &unitname);

  fprintf(op_file, "/ H_");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\n      INTEGER H_");

  write_name(&op_file, &unitname);
  putc('\n', op_file);

}


/*_____________________________________________________________________________

                Generate Common Block for this server

*/
Static Void gen_server_common()
{
  /*gen_server_common*/
  fprintf(op_file, "      COMMON /S_");
  write_name(&op_file, &unitname);

  fprintf(op_file, "/ P_");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\n      INTEGER P_");

  write_name(&op_file, &unitname);
  putc('\n', op_file);
}


/* Local variables for gen_dummies: */
struct LOC_gen_dummies {
  long a;
} ;

Local Void comma_cont(LINK)
struct LOC_gen_dummies *LINK;
{
  putc(',', op_file);   /* Separate two parameters */
  LINK->a++;   /* Count them */
  if (LINK->a >= 3) {   /* Break them up */
    LINK->a = 0;
    continuation();
  }
}


/*____________________________________________________________________________

            Generate Parameter list
*/
Static Void gen_dummies(head)
id_list *head;
{

  /* Generates the formal parameter list enclosed in brackets  (a,b,c,d)  */
  struct LOC_gen_dummies V;
  id_list *scan;



  if (head == NULL)   /*if list not NIL*/
    return;

  V.a = 0;
  scan = head;
  putc('(', op_file);
  while (scan != NULL) {   /*while*/
    if (((1L << ((long)scan->id_type->typ_basic_type)) &
	 ((1L << ((long)sequence)) | (1 << ((long)substring)))) != 0)
      fprintf(op_file, "A_");
    write_name(&op_file, &scan->name);
    if ((long)scan->id_type->typ_basic_type == (long)substring) {
      comma_cont(&V);
      fprintf(op_file, "S_");
      write_name(&op_file, &scan->name);
    }
    if (((1L << ((long)scan->id_type->typ_basic_type)) &
	 ((1L << ((long)sequence)) | (1 << ((long)substring)))) != 0) {
      comma_cont(&V);
      fprintf(op_file, "L_");
      write_name(&op_file, &scan->name);
    }

    scan = scan->next;
    if (scan != NULL)
      comma_cont(&V);
  }
  putc(')', op_file);
}  /*gen_dummies*/


/*_____________________________________________________________________________

        Generate local variables (server) / parameter (client)
        ------------------------------------------------------

This subroutine will generate

    -  The parameters to the client subroutine,
    -  or the local variables in the server.

*/

Static Void gen_params_for(head)
id_list *head;
{
  expression a_expr, l_expr, s_expr, expr;
  id_list *scan;
  boolean simple_ref;   /* Should simple variables be dereferenced? */
  boolean composite_ref;   /* what about composite variables? */
  defined_type *WITH;


  scan = head;
  while (scan != NULL) {   /*while*/
    WITH = scan->id_type;   /*with*/

    /** Write the type's name if any otherwise the full declaration **/
    /** Sequences and substrings MUST be expanded a little **/


    expr.len = 0;
    append_name(&expr, scan->name);
    l_expr = expr;   /*   x */
    prepend_1(&l_expr, '_');   /*  _x */
    s_expr = l_expr;   /*  _x */
    a_expr = l_expr;   /*  _x */
    prepend_1(&l_expr, 'L');   /* L_x */
    prepend_1(&s_expr, 'S');   /* S_x */
    prepend_1(&a_expr, 'A');   /* A_x */

    switch (WITH->typ_basic_type) {   /*case*/

    case chartok:
    case bytetok:
    case shortok:
    case integertok:
    case real32tok:
    case real48tok:
    case real64tok:
    case real128tok:
    case longtok:
    case stringtok:
    case recordtok:
    case arraytok:
      gen_type_decl_for(expr, scan->id_type, 1L);
      break;

    case sequence:  /* a_xxx: tttt; */
      gen_type_decl_for(a_expr, scan->id_type, 1L);
      /* l_xxx: rpc_integer */
      gen_type_decl_for(l_expr,
			simple_descriptor[(long)integertok - (long)chartok],
			1L);
      break;

    case substring:  /* a_xxx: tttt; */
      gen_type_decl_for(a_expr, scan->id_type, 1L);

      gen_type_decl_for(s_expr,
			simple_descriptor[(long)integertok - (long)chartok],
			1L);

      gen_type_decl_for(l_expr,
			simple_descriptor[(long)integertok - (long)chartok],
			1L);
      break;
    }

    scan = scan->next;
  }

}  /*GEN_PARAMS_for*/


/*_________________________________________________________________________

            Generate:   A structure declaration in FORTRAN
            ==============================================

Example:    STRUCTURE /structurename/
                CHARACTER*80    fieldname
                INTEGER         fieldname2
            END STRUCTURE
*/
Static Void gen_struct_for(pt, level)
defined_type *pt;
long level;
{
  /* type structure */
  /* indentation */
  named_type *scan;
  expression exp2;

  /*gen_struct_for*/
  if ((long)pt->typ_basic_type != (long)recordtok)   /*with..if*/
    return;
  /* VAX/FORTRAN ONLY! */
  fprintf(op_file, "%*cSTRUCTURE ", (int)IndFor(level), ' ');
  if (pt->typ_name == NULL)
    codefor_error("Every structure must be named for VAX/FORTRAN.  ");
  else {   /*if*/
    putc('/', op_file);
    write_name(&op_file, &pt->typ_name->nty_name);
    fprintf(op_file, "/ ");
  }
  putc('\n', op_file);

  scan = pt->UU.typ_fields;
  while (scan != NULL) {   /*while*/
    exp2.len = 0;
    append_name(&exp2, scan->nty_name);
    gen_type_decl_for(exp2, scan->nty_type, level + 1);
    scan = scan->nty_next;
  }

  fprintf(op_file, "%*cEND STRUCTURE\n", (int)IndFor(level), ' ');

}


/*___________________________________________________________________________

        Generate type definitions for whole package
        ===========================================

Example:
            INTEGER         P1
            INTEGER*4       P2(3,3)
            CHARACATER*80   P3(10)
*/

Static Void generate_types_for()
{  /*generate types*/
  named_type *scan, *WITH;
  defined_type *WITH1;

  scan = typeptr;
  while (scan != NULL) {   /*while*/
    WITH = scan;
    WITH1 = WITH->nty_type;
    if ((long)WITH1->typ_basic_type == (long)recordtok) {   /*if*/
      /*   Now make the main type definition:
      */
      gen_struct_for(WITH->nty_type, 1L);
      putc('\n', op_file);   /* Blank line */
    }


    scan = WITH->nty_next;
  }
}


/* Local variables for client_gen_for: */
struct LOC_client_gen_for {
  long proc_number;
} ;

Local Void gen_client_block(ptr, LINK)
block_table *ptr;
struct LOC_client_gen_for *LINK;
{

  /****
  * On each block, the client allocates 'RPC_integer' variables to pack or
  * unpack parameters.
  *****/
  long a;
  expression expr;   /* Expression for return value */
  long FORLIM;

  /*   Generate Header:
  */
  fprintf(op_file, "%*c", (int)IndFor(1L), ' ');
  if ((long)ptr->b_type == (long)functok) {
    switch (ptr->return_) {   /*case*/

    case chartok:
      fprintf(op_file, "CHARACTER*1");
      break;

    case bytetok:
    case shortok:
    case longtok:
    case integertok:
      fprintf(op_file, "INTEGER");
      break;

    case real32tok:
      fprintf(op_file, "REAL");
      break;

    case real48tok:
    case real64tok:
    case real128tok:
      fprintf(op_file, "DOUBLE");
      break;
    }
    fprintf(op_file, " FUNCTION ");
    write_name(&op_file, &ptr->name);
    switch (ptr->return_) {   /*case*/

    case chartok:
      /* blank case */
      break;

    case bytetok:   /* @@ VAX ONLY */
      fprintf(op_file, "*1");
      break;

    case integertok:
    case real32tok:
    case real48tok:
    case real64tok:
    case real128tok:   /* ok as it is*/
      break;

    case shortok:   /* @@ VAX ONLY */
      fprintf(op_file, "*2");
      break;

    case longtok:   /* @@ VAX ONLY */
      fprintf(op_file, "*4");
      break;
    }
  } else {   /*if*/
    fprintf(op_file, "SUBROUTINE ");
    write_name(&op_file, &ptr->name);
  }

  gen_dummies(ptr->list);   /* Generate formal parameter list */
  putc('\n', op_file);
  gen_client_common();

  generate_types_for();   /* generate local types   */

  gen_params_for(ptr->list);

  /*   Local variables:
  */
  fprintf(op_file, "      INTEGER RPC_P_BUF");
  FORLIM = ptr->blk_nesting;
  for (a = 0; a < FORLIM; a++)
    fprintf(op_file, ",RPC_%c", (Char)(a + 0 + 65L));
  putc('\n', op_file);

  if ((long)ptr->b_type == (long)functok)   /*if*/
  {  /* Variable for return value */
    format(&expr, "RPC_RET   ");
    gen_type_decl_for(expr,
		      simple_descriptor[(long)ptr->return_ - (long)chartok],
		      1L);
  }

  /*   Code of routine starts here:
  */
  fprintf(op_file, "      CALL RPC_BEGIN_CALL_FOR(RPC_P_BUF, H_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ",%ld,%ld,%ld,%ld)\n",
	  ptr->blk_max_in, ptr->blk_max_out, version_num, LINK->proc_number);

  /** generate packing statements for IN & INOUT params **/
  if (ptr->list != NULL)
    Gen_Pack_For(&op_file, ptr->list, intok, true);

  /** generate rpc_call and bookeeping **/
  if (ptr->blk_status_param != NULL) {
    fprintf(op_file, "      ");
    write_name(&op_file, &ptr->blk_status_param->name);
    fprintf(op_file, "=RPC_CALL_STATUS(H_");
  } else if (ptr->blk_cast)
    fprintf(op_file, "      CALL RPC_CAST(H_");
  else
    fprintf(op_file, "      CALL RPC_CALL(H_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ",RPC_P_BUF");
  if (!ptr->blk_cast)
    fprintf(op_file, ",%ld", ptr->blk_timeout);
  fprintf(op_file, ")\n");

  if (ptr->blk_status_param != NULL) {
    fprintf(op_file, "      IF (MOD(");
    write_name(&op_file, &ptr->blk_status_param->name);
    fprintf(op_file, ",2).NE.0) THEN\n");
  }

  /** if function: unpack return value **/
  if ((long)ptr->b_type == (long)functok) {   /*if*/
    pack_simple_for(&op_file, ptr->return_, false);
    fprintf(op_file, "RPC_RET)\n");
  }

  /** generate UNpacking statements for OUT and INOUT params **/
  if (ptr->list != NULL)
    Gen_Pack_For(&op_file, ptr->list, outok, false);

  if (ptr->blk_status_param != NULL)
    fprintf(op_file, "      END IF\n");

  /** clear up everything and exit **/

  fprintf(op_file, "      CALL RPC_END_CALL_FOR(RPC_P_BUF)\n");

  if ((long)ptr->b_type == (long)functok) {   /*if*/
    fprintf(op_file, "      ");
    write_name(&op_file, &ptr->name);
    fprintf(op_file, "=RPC_RET\n");   /* Define function value */
  }
  fprintf(op_file, "      RETURN\n");
  fprintf(op_file, "      END\n\n");
  /*with*/

  /*if*/
}  /*gen_client_block*/

Local Void gen_open(LINK)
struct LOC_client_gen_for *LINK;
{
  if (!runoptions[(long)noautoinit - (long)ccerncross].value)
    fprintf(op_file, "C     Call this procedure at initialisation time ***\n");
  fprintf(op_file, "      SUBROUTINE OPEN_");
  write_name(&op_file, &unitname);
  putc('\n', op_file);

  gen_client_common();

  fprintf(op_file, "      INTEGER STATUS\n");

  fprintf(op_file, "      CALL RPC_OPEN_FOR(STATUS,H_");
  write_name(&op_file, &unitname);
  putc(',', op_file);
  continuation();
  write_name_padded(&op_file, unitname, '\'');
  fprintf(op_file, ")\n");

  fprintf(op_file, "      CALL RPC_REPORT_ERROR(STATUS)\n");
  fprintf(op_file, "      END\n\n");
}  /*GEN_OPEN*/

Local Void gen_close(LINK)
struct LOC_client_gen_for *LINK;
{
  fprintf(op_file, "      SUBROUTINE CLOSE_");
  write_name(&op_file, &unitname);
  putc('\n', op_file);

  gen_client_common();

  fprintf(op_file, "      INTEGER STATUS\n");

  fprintf(op_file, "      CALL RPC_CLOSE_FOR(STATUS,H_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ")\n");

  fprintf(op_file, "      CALL RPC_REPORT_ERROR(STATUS)\n");
  fprintf(op_file, "      END\n\n");
}  /*GEN_close*/


/*******************************************************************************

                Client code generator
                =====================

Generates one procedure or function for the client.
*/

Static Void client_gen_for()
{
  struct LOC_client_gen_for V;
  block_table *scan;



  fprintf(op_file, "C     CLIENT STUB routines for package ");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\nC     ====================\n");
  fprintf(op_file, "C\n");
  fprintf(op_file, "C     Generated automatically by the RPC Compiler\n");
  fprintf(op_file, "C     \n");

  /**      Generate procedures **/

  V.proc_number = 1;
  scan = blockptr;
  while (scan != NULL) {
    gen_client_block(scan, &V);
    V.proc_number++;
    scan = scan->next;
  }

  gen_open(&V);
  gen_close(&V);

}  /*CLIENT_GEN_for*/


/* Local variables for server_gen_for: */
struct LOC_server_gen_for {
  block_table *scan;
} ;


/*_____________________________________________________________________________

        Generate server stub for one procedure
*/
Local Void gen_r_routine(LINK)
struct LOC_server_gen_for *LINK;
{
  long a;   /* Loop variable */
  long FORLIM;

  /*gen_r_routine*/
  fprintf(op_file, "      SUBROUTINE R_");
  write_name(&op_file, &LINK->scan->name);
  fprintf(op_file, "(RPC_P_BUF)\n");

  fprintf(op_file, "      INTEGER RPC_P_BUF");
  FORLIM = LINK->scan->blk_nesting;
  for (a = 0; a < FORLIM; a++)
    fprintf(op_file, ",RPC_%c", (Char)(a + 65L - 1 + 1));
  putc('\n', op_file);

  generate_types_for();   /* Declare structure types   */

  gen_params_for(LINK->scan->list);   /* Declare types of parameters */

  /*   Generate UNpacking statements for IN and INOUT params:
  */
  if (LINK->scan->list != NULL)
    Gen_Pack_For(&op_file, LINK->scan->list, intok, false);

  /** generate call and bookeeping **/
  fprintf(op_file, "      CALL RPC_INIT_RETURN_FOR(RPC_P_BUF)\n");

  if ((long)LINK->scan->b_type == (long)proctok && LINK->scan->in_only) {
    if (runoptions[(long)concurrent - (long)ccerncross].value ||
	LINK->scan->blk_concurrent)
      fprintf(op_file, "      CALL RPC_EARLY_RETURN(RPC_P_BUF)\n");
    else if (LINK->scan->blk_cast)
      fprintf(op_file, "      CALL RPC_NO_RETURN(RPC_P_BUF)\n");
  }

  fprintf(op_file, "      ");

  /** if function: generate return variable, else just call subroutine.**/
  if ((long)LINK->scan->b_type == (long)functok)
    pack_simple_for(&op_file, LINK->scan->return_, true);
  else
    fprintf(op_file, "CALL ");
  write_name(&op_file, &LINK->scan->name);
  gen_dummies(LINK->scan->list);
  if ((long)LINK->scan->b_type == (long)functok)
    putc(')', op_file);
  putc('\n', op_file);

  /** generate packing statements for OUT and INOUT params**/
  if (LINK->scan->list != NULL)
    Gen_Pack_For(&op_file, LINK->scan->list, outok, true);

  fprintf(op_file, "      END\n\n");
  /* Blank line after each one */
}



/******************************************************************************

        S E R V E R     C O D E         G E N E R A T O R
        *************************************************

*/
Static Void server_gen_for()
{
  struct LOC_server_gen_for V;
  long i;   /* Label counter for computed goto */
  long proc_num;

  /*_____________________________________________________________________________*/

  /*       Generate Main Server Procedure
           ------------------------------
   */


  fprintf(op_file, "C     SERVER STUB routines for package ");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\nC     ====================\n");
  fprintf(op_file, "C\n");
  fprintf(op_file, "C     Generated automatically by the RPC Compiler\n");
  fprintf(op_file, "C     \n");

  /*       Generate individual routines for each procedure:
           -----------------------------------------------
   */
  V.scan = blockptr;
  proc_num = 0;
  while (V.scan != NULL) {   /*while*/
    proc_num++;   /* Count the procedures */
    gen_r_routine(&V);   /* Generate the individual stub subroutines */
    V.scan = V.scan->next;
  }

  /*       Generate the main server stub subroutine:
           ----------------------------------------
   */
  fprintf(op_file, "C\n");
  fprintf(op_file, "C                         Main stub entry point\n");
  fprintf(op_file, "C\n");
  fprintf(op_file, "      SUBROUTINE R_");
  write_name(&op_file, &unitname);
  fprintf(op_file, "(RPC_P_BUF)\n");
  fprintf(op_file, "      INTEGER RPC_P_BUF\n");
  fprintf(op_file, "      INTEGER*2 RPC_REQUEST\n");
  fprintf(op_file, "      INTEGER*4 STATUS\n");
  fprintf(op_file, "      PARAMETER(RPC_S_UNSUPPORTED_VERSION=139624458)\n");
  fprintf(op_file,
	  "      PARAMETER(RPC_S_BAD_PROCEDURE_NUMBER=139624466)\n\n");
  fprintf(op_file, "      CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)\n");
  fprintf(op_file,
	  "      IF ((RPC_REQUEST.NE.0).AND.(RPC_REQUEST.NE.%ld)) THEN\n",
	  version_num);
  fprintf(op_file,
	  "      CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_UNSUPPORTED_VERSION)\n");
  fprintf(op_file, "      ELSE\n");
  fprintf(op_file, "         CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)\n");
  fprintf(op_file,
	  "         IF ((RPC_REQUEST.LE.0).OR.(RPC_REQUEST.GT.%ld)) THEN\n",
	  proc_num);
  fprintf(op_file,
    "            CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_BAD_PROCEDURE_NUMBER)\n");

  fprintf(op_file, "         ELSE\n");
  fprintf(op_file, "            GOTO(10");
  for (i = 2; i <= proc_num; i++) {   /*for*/
    if (i % 10 == 0)   /*if*/
      fprintf(op_file, "\n     + ");
    fprintf(op_file, ",%ld", i * 10);
  }
  fprintf(op_file, "),RPC_REQUEST\n");

  V.scan = blockptr;   /* Make jump table: */
  for (i = 1; i <= proc_num; i++) {
    fprintf(op_file, "\n%5ld       CALL R_", i * 10);
    write_name(&op_file, &V.scan->name);
    fprintf(op_file, "(RPC_P_BUF)\n");
    fprintf(op_file, "            GOTO 888\n");
    V.scan = V.scan->next;
  }

  fprintf(op_file, "  888       CONTINUE\n\n");
  fprintf(op_file, "         END IF\n");   /* If good request */
  fprintf(op_file, "      END IF\n");   /* If good version */
  fprintf(op_file, "      END\n\n");   /* subroutine */

  /*       Generate Code to Attach stub to RPCRTS
           --------------------------------------
   */

  if (!runoptions[(long)noautoinit - (long)ccerncross].value)
    fprintf(op_file, "C     Call this procedure at initialisation time ***\n");
  fprintf(op_file, "      SUBROUTINE ATTACH_");
  write_name(&op_file, &unitname);
  putc('\n', op_file);

  gen_server_common();

  fprintf(op_file, "      EXTERNAL R_");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\n      INTEGER STATUS\n\n");


  fprintf(op_file, "      CALL RPC_ATTACH_STUB_FOR(STATUS,R_");
  write_name(&op_file, &unitname);
  putc(',', op_file);
  continuation();
  write_name_padded(&op_file, unitname, '\'');
  fprintf(op_file, ",P_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ")\n");

  fprintf(op_file, "      CALL RPC_REPORT_ERROR(STATUS)\n");
  fprintf(op_file, "      END\n\n");

  /*       Generate Code to Detach stub from RPCRTS
           ----------------------------------------
   */

  fprintf(op_file, "      SUBROUTINE DETACH_");
  write_name(&op_file, &unitname);
  putc('\n', op_file);

  gen_server_common();

  fprintf(op_file, "      CALL RPC_DETACH_STUB_FOR(P_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ")\n");

  fprintf(op_file, "      END\n");

}  /*SERVER_GEN_FOR*/


/*                                                                      CODEPILS
        Top-down RPC compiler:          Code generator for PILS
        ======================          =======================


History:
           Dec 88       PILS version made from FORTRAN versions (LTR)

Requirements of the run-time system:

    1.  rpc_BEGIN_CALL_PILS must
            o   Set up the 'procedure number' and 'version' fields;
            o   Leave the m_index pointer to call_header_length;
    2.  rpc_END_CALL_PILS must dispose of the message
    3.  rpc_CALL must leave m_index set to return_header_length
    4.  On entry into the server stub, m_index must be = call_header_length-4
    5.  The routine rpc_INIT_RETURN_PILS must set it to return_header_length
    6.  pck/upk_string_PILS must pack & unpack strings, and post-align.
    7.  pck/upk_substring_PILS must pack & unpack substrings, and post-align.
    8.  rpc_SET_ERROR must set the m_status field of the message as given.
    9.  rpc_ATTACH_STUB_PILS is a fortran callable rpc_attach_stub
   10.  rpc_OPEN_PILS is a fortran callable rpc_open
   11.  pck/upk_xxxx_PILS are the packing/unpacking routines Fortran callable.

Restrictions:

        No pointers
        No Records
{___________________________________________________________________________

        Write out one identifier
*/
Static Void write_name_pils(where, name)
FILE **where;
id_name *name;
{
  long a, FORLIM;

  FORLIM = name->len;
  for (a = 0; a < FORLIM; a++)
    putc(name->str[a], *where);
}


/*___________________________________________________________________________

        Write out component expression
        ------------------------------
*/
Static Void write_exp_pils(where, expr)
FILE **where;
expression *expr;
{
  long a, FORLIM;

  FORLIM = expr->len;
  for (a = 0; a < FORLIM; a++)
    putc(expr->str[a], *where);
}


/*___________________________________________________________________________

        Write a quoted string padded to 40 characters
*/
Static Void write_name_padded_pils(op_file, name, ch)
FILE **op_file;
id_name name;
Char ch;
{
  /*write_name_padded*/
  putc(ch, *op_file);
  write_name(op_file, &name);
  fprintf(*op_file, "%*c", (int)(rpc_name_length - name.len + 1), ch);
}


/*=============================================================================

                        PILS-sepcific procedures
*/
/*____________________________________________________________________________

        Code generator error
        --------------------

    Code generator errors are internal errors or target-dependent error.
*/
Static Void code_error_pils(why)
Char *why;
{
  printf(" RPCC: **** Error: %.*s\n", error_length, why);
  printf("       (Error detected at PILS code generator stage.)\n");
  _Escape(0);
}


/*___________________________________________________________________________

        Indenting algorithm
*/
Static long ind_pils(level)
long level;
{
  return (level * 3);
}


/*___________________________________________________________________________

        Append a PILS index to an array expression

    Level = 1       =>      rpc_a   used,
    Level = 2       =>      rpc_b   used etc...
*/
Static Void append_index_pils(expr, level)
expression *expr;
long level;
{
  format(expr, "$(rpc_    ");
  append_1(expr, (Char)(level - 1 + 'a'));
  append_1(expr, ')');

}


/*___________________________________________________________________________

      Generate procedure name to (un)pack a simple type or descriptor
      ---------------------------------------------------------------

    Used for the function return result.

|       generates:      upk/pck_ttt(rpc_p_buf,
*/
Static Void pack_simple_pils(where, what, topack)
FILE **where;
type_token what;
boolean topack;
{
  if (topack)
    fprintf(*where, "pck_");
  else
    fprintf(*where, "upk_");
  switch (what) {

  case chartok:
    fprintf(*where, "char");
    break;

  case bytetok:
    fprintf(*where, "byte");
    break;

  case shortok:
    fprintf(*where, "short");
    break;

  case integertok:
    fprintf(*where, "integer");
    break;

  case real32tok:
    fprintf(*where, "real32");
    break;

  case real48tok:
    fprintf(*where, "real48");
    break;

  case real64tok:
    fprintf(*where, "real64");
    break;

  case real128tok:
    fprintf(*where, "real128");
    break;

  case longtok:
    fprintf(*where, "long");
    break;
  }
  fprintf(*where, "(rpc_p_buf,");
}


/*___________________________________________________________________________

        Generate code to:       Align on a 2**power byte boundary

    Currently, only aligns on word boundaires, because that is all
    we need.
*/
Static Void gen_align_pils(power, level)
long power, level;
{
  /*gen_align_pils*/
  fprintf(op_file, "%*crpc_align(rpc_p_buf,%ld)\n",
	  (int)ind_pils(level), ' ', power);
  /* Extra runtime support needed here */
}


/*___________________________________________________________________________

        Generate code to:       (un)Pack a parameter of given type
        ----------------        ----------------------------------

    This recursive procedure uses the 'level' parameter to control the
    amount of indentation at each stage, and which rpc_<level> parameters
    may be accessed by any given stage.

    If the type is declared as 'EXTERNAL_MARSHALLING, then an external
    procedure pck_<typename> or Upck_<typename> is called to do the
    marshalling.

On entry,
    Output cursor at left margin.
On exit,
    Output cursor at left margin.
*/
Static Void gen_pack_type_pils(where, expr, typ, level, topack)
FILE **where;
expression expr;
defined_type *typ;
long level;
boolean topack;
{
  /* output file */
  /* Expression for variable */
  /* type descriptor */
  /* indentation & rpc_<level> */
  /* pack or unpack? */
  Char ch;
  defined_type *element;   /* Array element type */
  long depth;   /* Depth of nesting of array element */
  expression exp2, l_expr;   /* Expression for the length of a string, etc */
  expression s_expr;   /* Expression for the start of a substring */
  long i;   /* Loop index */
  id_name *WITH1;
  long FORLIM;
  defined_type *WITH2;

  /*_____________________________________________________________________________
                      Main block of gen_pack_type_pils
  */

  /*gen_pack_type_pils*/
  /*    Generate a few useful expressions: */

  ch = (Char)(level - 1 + 'a');   /*for rpc_a etc */
  l_expr = expr;   /*   x */
  prepend_1(&l_expr, '_');   /*  _x */
  s_expr = l_expr;   /*  _x */
  prepend_1(&l_expr, 'L');   /* L_x */
  prepend_1(&s_expr, 'S');   /* S_x */

  if (typ->typ_external) {
    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    if (topack)
      fprintf(*where, "pck_");
    else
      fprintf(*where, "upk_");
    write_name(&op_file, &typ->typ_name->nty_name);
    fprintf(*where, "(rpc_p_buf,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");

    return;
  }
  switch (typ->typ_basic_type) {   /*case*/

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          S I M P L E

  Here we assume that the names of the pck/upk routines are consistent
  with the names rpc_xxx of the basic types. The exception is the code
  for unpacking a character, which is going to be a bit weierd, because
  of the descriptor.

  */
  case chartok:   /*simple type */
    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    if (topack)
      fprintf(*where, "pck");
    else
      fprintf(*where, "upk");
    fprintf(*where, "_char_PILS(rpc_p_buf,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");
    break;

  case bytetok:   /*simple type */
    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    if (topack)
      fprintf(*where, "pck");
    else
      fprintf(*where, "upk");
    fprintf(*where, "_byte_PILS(rpc_p_buf,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");
    break;

  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /*simple type */
    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    if (topack)
      fprintf(*where, "pck");
    else
      fprintf(*where, "upk");
    WITH1 = &typ->typ_name->nty_name;
    FORLIM = WITH1->len;
    for (i = 3; i < FORLIM; i++)
      putc(WITH1->str[i], *where);
    fprintf(*where, "(rpc_p_buf,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

                                                          A R R A Y
  Example:    FOR rpc_a=1,12
                  FOR rpc_b=1,10
                          ...myvar(rpc_a,rpc_b)...
                  ENDFOR
              ENDFOR

  */
  case arraytok:   /*arraytok*/
    exp2 = expr;
    depth = level;
    ch = (Char)(depth + 'a' - 1);
    element = typ->typ_subtype;
    format(&exp2, "$(rpc_    ");
    append_1(&exp2, ch);
    fprintf(*where, "%*c", (int)ind_pils(depth), ' ');
    fprintf(*where, "FOR rpc_%c=1 TO %ld\n",
	    ch, typ->UU.U12.typ_high - typ->UU.U12.typ_low + 1);
    while ((long)element->typ_basic_type == (long)arraytok) {
      WITH2 = element;
      depth++;
      ch = (Char)(depth + 'a' - 1);
      fprintf(*where, "%*c", (int)ind_pils(depth), ' ');
      fprintf(*where, "FOR rpc_%c=1 TO %ld\n",
	      ch, WITH2->UU.U12.typ_high - WITH2->UU.U12.typ_low + 1);
      format(&exp2, "$,rpc_    ");
      append_1(&exp2, ch);
      element = element->typ_subtype;   /*while*/
    }
    append_1(&exp2, ')');

    gen_pack_type_pils(where, exp2, element, depth + 1, topack);

    while (depth >= level) {   /*while*/
      fprintf(*where, "%*cENDFOR\n", (int)ind_pils(depth), ' ');
      depth--;   /* Come back out of nesting */
    }
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case recordtok:   /*recordtok*/
    /* R E C O R D */
    code_error_pils("No RECORD (STRUCTURE) type exists in PILS!      ");
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          A C C E S S

  */
  case accesstok:   /*accesstok*/
    code_error_pils("No ACCESS (POINTER) type exists in PILS!        ");
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case sequence:   /*sequence*/
    /* S E Q U E N C E */
    if (level > 1)
      code_error_pils("SEQUENCE type not allowed within composite type.");

    gen_pack_type_pils(where, l_expr,
		       simple_descriptor[(long)integertok - (long)chartok],
		       level, topack);

    exp2 = expr;
    format(&exp2, "A_$       ");   /* Make an expression for the array*/
    append_index_pils(&exp2, level);   /* Make expression for an element */

    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    fprintf(*where, "FOR rpc_%c=1 TO L_", ch);
    write_exp(where, &expr);
    putc('\n', *where);

    gen_pack_type_pils(where, exp2, typ->typ_subtype, level + 1, topack);
    fprintf(*where, "%*cENDFOR\n", (int)ind_pils(level), ' ');
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case stringtok:   /*stringtok*/
    /* S T R I N G */
    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    if (topack)
      fprintf(*where, "pck_string");
    else
      fprintf(*where, "upk_string");
    fprintf(*where, "(rpc_p_buf,");
    write_exp(where, &expr);
    fprintf(*where, ")\n");

    break;


  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                            S U B S T R I N G

  */
  case substring:   /*substring*/
    fprintf(*where, "%*c", (int)ind_pils(level), ' ');
    if (topack)
      fprintf(*where, "pck_substring");
    else
      fprintf(*where, "upk_substring");
    fprintf(*where, "(rpc_p_buf,A_");
    write_exp(where, &expr);
    putc(',', *where);
    fprintf(*where, "S_");
    write_exp(where, &expr);
    fprintf(*where, ",L_");
    write_exp(where, &expr);
    fprintf(*where, ")\n");

    break;


  }
}


/*___________________________________________________________________________

        Generate code to:       (un)Pack all parameters necessary
        -----------------       ---------------------------------

The dirn parameter is INtok or OUTok, to specify which parameters to unpack.

A string descriptor needs to be initialised, including the creation of the
string, at the server side, and the string has to be disposed of afterwards.

*/
Static Void gen_pack_pils(where, head, dirn, topack)
FILE **where;
id_list *head;
type_token dirn;
boolean topack;
{
  /* Output file */
  /* Parameter list */
  /* Parameter filter */
  /* Pack, rather than unpack? */
  expression expr;
  defined_type *WITH1;

  do {
    WITH1 = head->id_type;


    /* generate an expression for the variable: */

    expr.len = 0;   /* Expression for the variable */
    append_name(&expr, head->name);   /* expr is the param. name */


    /*       Pack or unpack
             --------------
     */
    if ((long)head->attr == (long)inoutok || (long)head->attr == (long)dirn)
    {   /*if*/
      deref = (client && !(runoptions[(long)byvalue - (long)ccerncross].value &&
			   (long)head->attr == (long)intok));
	  /** not value param **/
      /* and in-only param */

      /*level*/
      gen_pack_type_pils(where, expr, head->id_type, 1L, topack);

    }

    /*with*/
    head = head->next;
  } while (head != NULL);
}  /*gen_pack_pils*/


/*               (end of packing/unpacking)
*****************************************************************************

            Generate:       A type declaration in PILS

    This recursive procedure generates a definition of a type, given
    a name and a type descriptor. It is impossible to generate a type
    itself, as the name is buried within it in PILS.

    Examples
            CHAR    MYSTR(10,2)
                for
                    mystr:  ARRAY[1..10, 1..2] OF STRING

On entry,
    Cursor is assumed to be at left margin.
On exit,
    Cursor is again at the left margin.
*/

Static Void gen_type_decl_pils(expr, pt, level)
expression expr;
defined_type *pt;
long level;
{
  /* for the variable */
  /* type structure */
  /* indentation */
  defined_type *scan;
  expression exp2;

  /*gen_type_decl_pils*/
  switch (pt->typ_basic_type) {   /*with, case*/

  case chartok:
  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /* First token, simple type, courier type */
    /* write(op_file, ' ':ind_pils(level)); */
    switch (pt->typ_basic_type) {   /*case*/

    case chartok:
      fprintf(op_file, "int16");
      break;

    case bytetok:
      fprintf(op_file, "int16");
      break;

    case integertok:
      fprintf(op_file, "INT");
      break;

    case real32tok:
      fprintf(op_file, "REAL");
      break;

    case real48tok:
      fprintf(op_file, "REAL");
      break;

    case real64tok:
      fprintf(op_file, "REAL");
      break;

    case real128tok:
      fprintf(op_file, "REAL");
      break;

    case shortok:
      fprintf(op_file, "INT16");
      break;

    case longtok:
      fprintf(op_file, "INT32");
      break;
    }
    putc(' ', op_file);
    write_exp(&op_file, &expr);   /* Example: rpc_char x */
    break;
    /*simple type*/

  case substring:
  case stringtok:   /*stringtok*/
    /* Example: rpc_char x[81] */
    fprintf(op_file, "CHAR ");
    write_exp(&op_file, &expr);
    break;
    /* write(op_file, ' ':ind_pils(level)); */

  case sequence:
  case arraytok:   /*arraytok*/
    /* example  INT MYARR(10,20) */
    exp2 = expr;
    append_1(&exp2, '(');
    append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
    scan = pt->typ_subtype;
    while ((long)scan->typ_basic_type == (long)arraytok) {   /*while*/
      append_1(&exp2, ',');
      append_decimal(&exp2, scan->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
      scan = scan->typ_subtype;
    }
    append_1(&exp2, ')');
    gen_type_decl_pils(exp2, scan, level);   /*non-array type*/
    break;

  case accesstok:
    code_error_pils("Package has pointers: Can't make PILS stubs.    ");
    break;

  case recordtok:
    code_error_pils("Package has records:  Can't make PILS stubs.    ");
    break;

  }
}


/*_____________________________________________________________________________

        Generate local variables (server) / parameter (client)
        ------------------------------------------------------

This subroutine will generate

    -  The parameters to the client subroutine,
    -  or the local variables in the server.

*/

Static Void gen_params_pils(head)
id_list *head;
{
  expression a_expr, l_expr, s_expr, expr;
  id_list *scan;
  boolean simple_ref;   /* Should simple variables be dereferenced? */
  boolean composite_ref;   /* what about composite variables? */
  defined_type *WITH;


  scan = head;

  if (client)
    putc('(', op_file);

  while (scan != NULL) {   /*while*/
    /** Write the parameter attribute **/

    if (client) {
      switch (scan->attr) {   /*CASE*/

      case intok:
	fprintf(op_file, "IN ");
	break;

      case outok:
	fprintf(op_file, "OUT ");
	break;

      case inoutok:
	fprintf(op_file, "INOUT ");
	break;
      }
    }

    WITH = scan->id_type;   /*with*/
    /** Write the type's name if any otherwise the full declaration **/
    /** Sequences and substrings MUST be expanded a little **/


    expr.len = 0;
    append_name(&expr, scan->name);
    l_expr = expr;   /*   x */
    prepend_1(&l_expr, '_');   /*  _x */
    s_expr = l_expr;   /*  _x */
    a_expr = l_expr;   /*  _x */
    prepend_1(&l_expr, 'L');   /* L_x */
    prepend_1(&s_expr, 'S');   /* S_x */
    prepend_1(&a_expr, 'A');   /* A_x */

    switch (WITH->typ_basic_type) {   /*case*/

    case chartok:
    case bytetok:
    case shortok:
    case integertok:
    case real32tok:
    case real48tok:
    case real64tok:
    case real128tok:
    case longtok:
    case stringtok:
    case recordtok:
    case arraytok:
      gen_type_decl_pils(expr, scan->id_type, 1L);
      break;

    case sequence:  /* a_xxx: tttt; */
      gen_type_decl_pils(a_expr, scan->id_type, 1L);
      /* l_xxx: rpc_integer */
      if (client)   /* PILS */
	putc(',', op_file);   /* PILS */
      else
	putc(';', op_file);

      gen_type_decl_pils(l_expr,
			 simple_descriptor[(long)integertok - (long)chartok],
			 1L);
      break;

    case substring:  /* a_xxx: tttt; */
      gen_type_decl_pils(a_expr, scan->id_type, 1L);

      if (client)   /* PILS */
	putc(',', op_file);   /* PILS */
      else
	putc(';', op_file);

      gen_type_decl_pils(s_expr,
			 simple_descriptor[(long)integertok - (long)chartok],
			 1L);

      if (client)   /* PILS */
	putc(',', op_file);   /* PILS */
      else
	putc(';', op_file);

      gen_type_decl_pils(l_expr,
			 simple_descriptor[(long)integertok - (long)chartok],
			 1L);
      break;
    }

    scan = scan->next;

    if (scan == NULL)   /* PILS */
      break;

    if (client)
      putc(',', op_file);   /* PILS */
    else
      putc(';', op_file);
  }


  if (client)   /* PILS */
    putc(')', op_file);

  putc('\n', op_file);

}  /*GEN_PARAMS_PILS*/


/*____________________________________________________________________________

            Generate Formal Parameter List
*/
Static Void gen_formals(head)
id_list *head;
{

  /* Generates the formal parameter list enclosed in brackets  (a,b,c,d)  */
  id_list *scan;


  if (head == NULL)   /*if list not NIL*/
    return;

  scan = head;
  putc('(', op_file);
  while (scan != NULL) {   /*while*/
    if (((1L << ((long)scan->id_type->typ_basic_type)) &
	 ((1L << ((long)sequence)) | (1 << ((long)substring)))) != 0)
      fprintf(op_file, "A_");
    write_name(&op_file, &scan->name);
    if ((long)scan->id_type->typ_basic_type == (long)substring) {
      fprintf(op_file, ", S_");
      write_name(&op_file, &scan->name);
    }
    if (((1L << ((long)scan->id_type->typ_basic_type)) &
	 ((1L << ((long)sequence)) | (1 << ((long)substring)))) != 0) {
      fprintf(op_file, ", L_");
      write_name(&op_file, &scan->name);
    }

    scan = scan->next;
    if (scan != NULL)
      putc(',', op_file);
  }
  putc(')', op_file);
}  /*gen_formals*/


/*_________________________________________________________________________

            Generate:   A structure declaration in PILS
            ==============================================

Example:    STRUCTURE /structurename/
                CHARACTER*80    fieldname
                INTEGER         fieldname2
            END STRUCTURE
*/
Static Void gen_struct_pils(pt, level)
defined_type *pt;
long level;
{
  /* type structure */
  /* indentation */
  /* writeln(op_file, '!-- Sorry, No PILS Structures !!!'); */

  /*gen_struct_pils*/
}


/*___________________________________________________________________________

        Generate type definitions for whole package
        ===========================================

Example:
            INT         P1
            INT         P2(3,3)
            CHAR        P3(10)
*/

Static Void generate_types_pils()
{  /*generate types*/
  /* writeln(op_file, '!-- Sorry, No PILS User Defined Types !!!'); */

}


/* Local variables for client_generator_pils: */
struct LOC_client_generator_pils {
  long proc_number;
} ;

Local Void gen_client_block_(ptr, LINK)
block_table *ptr;
struct LOC_client_generator_pils *LINK;
{

  /****
  * On each block, the client allocates 'rpc_integer' variables to pack or
  * unpack parameters.
  *****/
  long a;
  expression expr;   /* Expression for return value */
  long FORLIM;

  /*   Generate Header:
  */
  if ((long)ptr->b_type == (long)functok) {
    fprintf(op_file, "DEF ");
    switch (ptr->return_) {   /*case*/

    case chartok:
      fprintf(op_file, "int16");
      break;

    case bytetok:
      fprintf(op_file, "int16");
      break;

    case shortok:
    case integertok:
      fprintf(op_file, "INT16");
      break;

    case longtok:
      fprintf(op_file, "INT32");
      break;

    case real32tok:
    case real48tok:
    case real64tok:
    case real128tok:
      fprintf(op_file, "REAL");
      break;
    }
    putc(' ', op_file);
    write_name(&op_file, &ptr->name);
  } else {   /*if*/
    fprintf(op_file, "SUB ");
    write_name(&op_file, &ptr->name);
  }

  gen_params_pils(ptr->list);   /* Generate formal parameter list */

  fprintf(op_file, "\n   INT rpc_p_buf");

  /*   Local variables:
  */
  FORLIM = ptr->blk_nesting;
  for (a = 0; a < FORLIM; a++)
    fprintf(op_file, ",rpc_%c", (Char)(a + 0 + 97L));
  putc('\n', op_file);

  if ((long)ptr->b_type == (long)functok)   /*if*/
  {  /* Variable for return value */
    fprintf(op_file, "   INT rpc_ret\n");
    /*
    format(expr, 'rpc_ret   ');
    gen_type_decl_pils(expr, simple_descriptor[return], 1);
    */
  }
  fprintf(op_file, "\n   rpc_begin_call(rpc_p_buf,h_");

  /*   Code of routine starts here:
  */
  write_name(&op_file, &unitname);
  fprintf(op_file, ",%ld,%ld,%ld,%ld)\n",
	  ptr->blk_max_in, ptr->blk_max_out, version_num, LINK->proc_number);

  /** generate packing statements for IN & INOUT params **/
  if (ptr->list != NULL)
    gen_pack_pils(&op_file, ptr->list, intok, true);

  /** generate rpc_call and bookeeping **/
  if (ptr->blk_cast)
    fprintf(op_file, "   rpc_cast(h_");
  else
    fprintf(op_file, "   rpc_call(h_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ",rpc_p_buf");
  if (!ptr->blk_cast)
    fprintf(op_file, ",%ld", ptr->blk_timeout);
  fprintf(op_file, ")\n");

  /** if function: unpack return value **/
  if ((long)ptr->b_type == (long)functok) {   /*if*/
    fprintf(op_file, "   ");
    pack_simple_pils(&op_file, ptr->return_, false);
    fprintf(op_file, "rpc_ret)\n");
  }

  /** generate UNpacking statements for OUT and INOUT params **/
  if (ptr->list != NULL)
    gen_pack_pils(&op_file, ptr->list, outok, false);

  /** clear up everything and exit **/

  fprintf(op_file, "   rpc_end_call(rpc_p_buf)\n");

  if ((long)ptr->b_type == (long)functok) {   /*if*/
    fprintf(op_file, "   ");
    write_name(&op_file, &ptr->name);
    fprintf(op_file, "=rpc_ret\n");   /* Define function value */
  }
  fprintf(op_file, "END");
  if ((long)ptr->b_type == (long)functok)
    fprintf(op_file, "DEF");
  else
    fprintf(op_file, "SUB");
  fprintf(op_file, "\n\n");

  /*with*/
}  /*gen_client_block*/

Local Void gen_client_header(LINK)
struct LOC_client_generator_pils *LINK;
{

  /*
  Generates:      The CLIENT module header
                  The constant and type definitions
  */
  fprintf(op_file, "!---\n");
  fprintf(op_file, "!---  CLIENT STUB routines for package ");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\n!---\n");
  fprintf(op_file, "!---  Generated automatically by the RPC Compiler\n");
  fprintf(op_file, "!---\n\n");

  fprintf(op_file, "OPTION IMPLICIT OFF\n");
  fprintf(op_file, "OPTION BASE 1\n");

  fprintf(op_file, "MODULE CLI");
  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "\n\nGLOBAL INT h_");

  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "\n\n");

  /* generate_externals; */

}  /*GEN_CLIENT_HEADER*/

Local Void gen_open_(LINK)
struct LOC_client_generator_pils *LINK;
{
  fprintf(op_file, "SUB open_");
  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "()\n");
  fprintf(op_file, "   INT status\n");
  fprintf(op_file, "   CHAR service\n\n");

  fprintf(op_file, "   service = ");
  write_name_padded_pils(&op_file, unitname, '"');
  fprintf(op_file, "\n   rpc_open(status,h_");

  write_name_pils(&op_file, &unitname);
  fprintf(op_file, ",service)\n");

  fprintf(op_file, "   rpc_report_error(status)\n");
  fprintf(op_file, "ENDSUB\n\n");
  if (runoptions[(long)noautoinit - (long)ccerncross].value)
    return;

  fprintf(op_file,
	  "!---  This procedure will be called at initialisation time ***\n");
  fprintf(op_file, "open_");
  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "()\n\n");
}  /*GEN_OPEN*/


/*******************************************************************************

                Client code generator
                =====================

Generates one procedure or function for the client.
*/

Static Void client_generator_pils()
{
  struct LOC_client_generator_pils V;
  block_table *scan;


  gen_client_header(&V);

  /**      Generate procedures **/

  V.proc_number = 1;
  scan = blockptr;
  while (scan != NULL) {
    gen_client_block_(scan, &V);
    V.proc_number++;
    scan = scan->next;
  }

  gen_open_(&V);

  fprintf(op_file, "ENDMODULE\n");

}  /*CLIENT_GEN_pils*/


/* Local variables for server_generator_pils: */
struct LOC_server_generator_pils {
  block_table *scan;
} ;


/*_____________________________________________________________________________

        Generate server stub for one procedure
*/
Local Void gen_r_routine_(LINK)
struct LOC_server_generator_pils *LINK;
{
  long a, b;

  /*gen_r_routine*/
  fprintf(op_file, "SUB r_");
  write_name(&op_file, &LINK->scan->name);
  fprintf(op_file, "(INOUT INT rpc_p_buf)\n");

  generate_types_pils();   /* Declare structure types   */

  gen_params_pils(LINK->scan->list);   /* Declare types of parameters */
  putc('\n', op_file);

  b = LINK->scan->blk_nesting;
  if (b > 0)
    fprintf(op_file, "   INT rpc_a");
  for (a = 1; a < b; a++)
    fprintf(op_file, ",rpc_%c", (Char)(a + 97L - 1 + 1));
  fprintf(op_file, "\n\n");

  /*   Generate UNpacking statements for IN and INOUT params:
  */
  if (LINK->scan->list != NULL)
    gen_pack_pils(&op_file, LINK->scan->list, intok, false);

  /** generate call and bookeeping **/
  fprintf(op_file, "   rpc_init_return(rpc_p_buf)\n");

  if ((long)LINK->scan->b_type == (long)proctok && LINK->scan->in_only) {
    if (runoptions[(long)concurrent - (long)ccerncross].value ||
	LINK->scan->blk_concurrent)
      fprintf(op_file, "   rpc_early_return(rpc_p_buf)\n");
    else if (LINK->scan->blk_cast)
      fprintf(op_file, "   rpc_no_return(rpc_p_buf)\n");
  }

  /** if function: generate return variable, else just call subroutine.**/
  fprintf(op_file, "   ");
  if ((long)LINK->scan->b_type == (long)functok)
    pack_simple_pils(&op_file, LINK->scan->return_, true);
  write_name(&op_file, &LINK->scan->name);
  gen_formals(LINK->scan->list);
  if ((long)LINK->scan->b_type == (long)functok)
    putc(')', op_file);
  putc('\n', op_file);

  /** generate packing statements for OUT and INOUT params**/
  if (LINK->scan->list != NULL)
    gen_pack_pils(&op_file, LINK->scan->list, outok, true);

  fprintf(op_file, "ENDSUB\n\n");
  /* Blank line after each one */
}

/*_____________________________________________________________________________*/

/*       Generate Code to Attach stub to RPCRTS
         --------------------------------------
 */

Local Void gen_attach(LINK)
struct LOC_server_generator_pils *LINK;
{
  if (!runoptions[(long)noautoinit - (long)ccerncross].value)
    fprintf(op_file, "!---  Call this procedure at initialisation time ***\n");
  fprintf(op_file, "SUB attach_");
  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "()\n");

  fprintf(op_file, "   INT status\n");
  fprintf(op_file, "   CHAR service\n\n");
  fprintf(op_file, "   service = ");
  write_name_padded_pils(&op_file, unitname, '"');
  fprintf(op_file, "\n   rpc_attach_stub(status,address(r_");

  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "),service,program_number)\n");

  fprintf(op_file, "   rpc_report_error(status);\n");

  fprintf(op_file, "ENDSUB\n\n");

}  /*GEN_ATTACH*/

/*_____________________________________________________________________________

        Generate Code to Detach stub from RPCRTS
        ----------------------------------------
*/

Local Void gen_detach(LINK)
struct LOC_server_generator_pils *LINK;
{
  if (!runoptions[(long)noautoinit - (long)ccerncross].value)
    fprintf(op_file, "!---  Call this procedure at exit time ***\n");
  fprintf(op_file, "SUB detach_");
  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "()\n\n");

  fprintf(op_file, "   rpc_detach_stub(program_number)\n");

  fprintf(op_file, "ENDSUB\n\n");

}  /*GEN_DETACH*/



/******************************************************************************

        S E R V E R     C O D E         G E N E R A T O R
        *************************************************

*/
Static Void server_generator_pils()
{
  struct LOC_server_generator_pils V;
  long i;   /* Label counter for computed goto */
  long proc_num;

  /*       Generate Main Server Procedure
           ------------------------------
   */


  fprintf(op_file, "!---\n");
  fprintf(op_file, "!---  SERVER STUB routines for package ");
  write_name(&op_file, &unitname);
  fprintf(op_file, "\n!---\n");
  fprintf(op_file, "!---  Generated automatically by the RPC Compiler\n");
  fprintf(op_file, "!---\n\n");

  fprintf(op_file, "OPTION IMPLICIT OFF\n");
  fprintf(op_file, "OPTION BASE 1\n");

  fprintf(op_file, "MODULE SER");
  write_name_pils(&op_file, &unitname);
  fprintf(op_file, "\nHIDDEN INT program_number\n\n");

  /*       Generate individual routines for each procedure:
           -----------------------------------------------
   */
  V.scan = blockptr;
  proc_num = 0;
  while (V.scan != NULL) {   /*while*/
    proc_num++;   /* Count the procedures */
    gen_r_routine_(&V);   /* Generate the individual stub subroutines */
    V.scan = V.scan->next;
  }

  /*       Generate the main server stub subroutine:
           ----------------------------------------
   */
  fprintf(op_file, "!---\n");
  fprintf(op_file, "!---        Main stub entry point\n");
  fprintf(op_file, "!---\n");
  fprintf(op_file, "SUB r_");
  write_name(&op_file, &unitname);
  fprintf(op_file, "(INOUT INT rpc_p_buf)\n");
  fprintf(op_file, "   INT16 rpc_request\n\n");
  fprintf(op_file, "   upk_short(rpc_p_buf,rpc_request)\n");
  if (version_num != 0) {   /*if version number used */
    fprintf(op_file, "   IF (rpc_request # 0) AND (rpc_request # %ld) THEN\n",
	    version_num);
    fprintf(op_file,
	    "      rpc_set_error(rpc_p_buf,rpc_s_unsupported_version)\n");
    fprintf(op_file, "   ELSE\n");
  }
  fprintf(op_file, "      upk_short(rpc_p_buf,rpc_request)\n");

  fprintf(op_file, "      SELECT rpc_request\n");

  V.scan = blockptr;
  proc_num = 1;
  while (V.scan != NULL) {
    fprintf(op_file, "      CASE %2ld\n", proc_num);
    fprintf(op_file, "         r_");
    write_name_pils(&op_file, &V.scan->name);
    fprintf(op_file, "(rpc_p_buf)\n");
    proc_num++;
    V.scan = V.scan->next;
  }

  fprintf(op_file, "      CASE ELSE \n");
  fprintf(op_file, "         ");
  fprintf(op_file, "rpc_set_error(rpc_p_buf,rpc_s_bad_procedure_number)\n");
  fprintf(op_file, "      ENDSELECT\n");
  if (version_num != 0)
    fprintf(op_file, "   ENDIF\n");
  fprintf(op_file, "ENDSUB\n\n");

  /*       Generate Code to Attach stub to RPCRTS
           --------------------------------------
   */
  gen_attach(&V);
  gen_detach(&V);

  fprintf(op_file, "ENDMODULE\n");

}  /*SERVER_GEN_PILS*/


/*                                                                CODEGEN
        Top-down RPC compiler:          Code generator
        ======================          ==============


History:
        3 Jun 1986      Written, Antonio Pastore, Tec.Student 1986, DD/OC, CERN
        15 Aug 86       TBL  Bug fix in gen_loc_type
        18 Aug 86       length follows array param in sequence, like string.
        19 Aug 86       VAX strings take descriptor only. New & dispose in.
         2 Sep 86       CALL_MESSAGE bug fix -- should be CALL_HEADER_LENGTH
        15 Oct 86       CALL_HEADER_LENGTH -2 used, as c_h_l includes proc#.
        23 Oct 86       m_index used insted of _count: reentrant code.
                        Local variables preceded by underline.
                        Server procedures are all local to main jump procedure
        31 Oct 86       rpc_integer type introduced and used for substrings
         8 Nov 86       Bug fix in substring handling: packed l-s bytes! 61108
        17 Dec 86       M6809 addition
         6 Jan 87       Bug fix
        30 Jan 87       Fixes for M6809; externals inline in client now.
         9 Mar 87       Timeout parameter added to rpc_call
        20 Mar 87       Rename: pack_xxx -> pck_xxx, unpack_xxx -> upk_xxx
         4 Jun 87       handle for 6809 in external, not entry          70604
        14 Aug 87       Code reworked to include C stub generation - Nici.
        17 Aug 87       Option byvalue added - Nici.
        27 Aug 87       Options timeout and version added - Nici.
        31 Aug 87       C bug fix: added brackets for (un)packing arrays
                        and sequences (macro expansion!) - Nici.
         1 Sep 87       Added options types and <s,c>pcturbo - Nici.
         6 Oct 87       With clause does not extend round rpc_call (71006)
        17 Dec 87       C stub is passed **buffer, not *buffer. TBL (71217)
        23 Jun 88       C client with no args omitted the '()': fixed. TBL
                        C stubs #include with <brackets> now.
        26 Aug 88       Options <s,c>macturbo added.    (Roberto Bagnara, DD/OC)
                        PCTurbo client stubs now automatically initializes the
                        exit procedure mechanism even if NOAUTOINIT is required,
                        thus avoiding a system crash at program termination.
                        PCTurbo server stubs are now generated automatically,
                        Attach_XXX procedure included.
        30 Aug 88       Unused variables (ch : char) removed in gen_exit,   (RB)
                        gen_open and gen_attach. Modified also gen_attach to
                        declare prog_no of type program_pointer (MacTurbo and
                        PCTurbo) instead of program_index (all the other output
                        modes).
         1 Sep 88       Close_XXX procedure generated correctly also for    (RB)
                        MacTurbo client stubs. In PCTurbo and MacTurbo
                        stubs as well as in the .EXT file, the TYPE keyword
                        is not generated if there are no type declarations.
           Nov 88       Composite types and pointers; arrays of named types.
        21 Mar 89       VAX/VMS fortran compat. uses RPC_RTS_FOR for strings.
         8 May 89       close_xxx, attach_xxx, p_xxx in response to requests
         7 Jun 89       Substring start & length run 1..n in C now, not 0..n-1.
        13 Jun 89       In C, sequence size was one too big. (TBL, FC)
        10 Jul 89       String[] types restored for Turbopascal and M6809
        13 Oct 89       MAXLENGTH becomes RPC_BUFFER_SIZE (clash with PILS)
*/
/*____________________________________________________________________________

        Code generator error
        --------------------

    Code generator errors are internal errors or target-dependent error.
*/
Static Void codegen_error(why)
Char *why;
{
  printf(" RPCC: **** Error: %.*s\n", error_length, why);
  printf("       (Error detected at code generator stage.)\n");
  _Escape(0);
}


/*____________________________________________________________________________
*/
/*       Write language elements to file:
         -------------------------------
 */
Static Void writok(where, what)
FILE **where;
type_token what;
{
  switch (what) {

  case chartok:
    fprintf(*where, "rpc_char");
    break;

  case bytetok:
    fprintf(*where, "rpc_byte");
    break;

  case shortok:
    fprintf(*where, "rpc_short");
    break;

  case integertok:
    fprintf(*where, "rpc_integer");
    break;

  case real32tok:
    fprintf(*where, "rpc_real32");
    break;

  case real48tok:
    fprintf(*where, "rpc_real48");
    break;

  case real64tok:
    fprintf(*where, "rpc_real64");
    break;

  case real128tok:
    fprintf(*where, "rpc_real128");
    break;

  case longtok:
    fprintf(*where, "rpc_long");
    break;

  case arraytok:
  case sequence:
  case stringtok:
  case substring:
    if (((1L << ((long)omode)) & Cmode) != 0)
      putc('[', *where);
    else
      fprintf(*where, "ARRAY [1..");
    break;

  case proctok:
    if (((1L << ((long)omode)) & Cmode) == 0)
      fprintf(*where, "PROCEDURE ");
    break;

  case functok:
    if (((1L << ((long)omode)) & Cmode) == 0)
      fprintf(*where, "FUNCTION ");
    break;
  }
}


/*___________________________________________________________________________

        Indenting algorithm
*/
Static long LeftIn(level)
long level;
{
  return (level * 3);
}


/*___________________________________________________________________________
*/
Static Void write_declaration(where, prefix, ptr, ref)
FILE **where;
Char prefix;
id_list *ptr;
boolean ref;
{
  defined_type *WITH1;

  if (((1L << ((long)omode)) & Cmode) == 0) {
    if (ref)
      fprintf(*where, "VAR ");
    if (prefix != ' ')
      fprintf(*where, "%c_", prefix);
    write_name(where, &ptr->name);
    fprintf(*where, ": ");
  }

  WITH1 = ptr->id_type;

  if (WITH1->typ_name != NULL)
    write_name(where, &WITH1->typ_name->nty_name);
  else
    codegen_error("Internal error: Unnamed type when name needed!  ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    return;
  putc(' ', *where);
  if (ref)
    putc('*', *where);
  if (prefix != ' ')
    fprintf(*where, "%c_", prefix);
  write_name(where, &ptr->name);
}


/*___________________________________________________________________________

        Generate:   Declatation of an integer
*/
Static Void write_integer(where, prefix, name, ref)
FILE **where;
Char prefix;
id_name *name;
boolean ref;
{
  /* output file */
  /* Space, or l or s for example */
  /* Variable name */
  /* Pass by reference? */
  fprintf(*where, "    ");
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(*where, "rpc_integer ");
  if (ref) {
    if (((1L << ((long)omode)) & Cmode) != 0)
      putc('*', *where);
    else
      fprintf(*where, "VAR ");
  }
  if (prefix != ' ')
    fprintf(*where, "%c_", prefix);
  write_name(where, name);
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(*where, " : rpc_integer");
}


/*___________________________________________________________________________

        Find out whether type needs dynamic allocation
        ----------------------------------------------

  This function returns whether a type needs memory allocation performing.
  In general, pointer types are dynamic, and composite types are dynamic
  if they contain any dynamic types.

  The rules applied to pointers depend on the direction of the parameter
  and are summarised in the following table.

  IN parameters are straightforward, in that they are allocated by the
  client, and temporarily reconstructed on the server node by the stub.

  For INOUT parameters, the client must ensure that no other pointers are kept
 to items in the original tree, as it will be deallocated by the stub. The
 server must ensure that any items removed from the tree are returned to the
 heap, and any added to the tree are taken from the heap.

  For OUT parameters, the client's pointer is overwritten and its original
  value lost, without any deallocation of any items to which it may have
  pointed. The new tree is allocated by the stub from the heap, and the
  client is responsible for eventually deallocating it.


                CLIENT                      SERVER
    ______      _________________________   ______________________________
    IN          allocated by client
                MARSHALLED
                                            ALLOCATED DURING UNMARSHALLING
                                            untouched by server
                                            DEALLOCATED *

    IN OUT      allocated by client
                MARSHALLED
                DEALLOCATED
                                            ALLOCATED DURING UNMARSHALLING
                                            modified by server
                                            MARSHALLED
                                            DEALLOCATED
                ALLOCATED DURING UNMARSHALLING

    OUT         assumed unallocated
                                            set to NIL
                                            allocated by server
                                            MARSHALLED
                                            DEALLOCATED
                ALLOCATED DURING UNMARSHALLING

    Unmarshalling always implies allocation and vice-versa.
    Marshalling implies deallocation EXCEPT for in parameters,
    and deallocation has to be done (sometimes) on it's own.


 String descriptors contain pointers which are different in that they are
 allocated (normally statically) by the client in all cases:

String          CLIENT                      SERVER
 descriptors:   _________________________   ________________________________

                (MARSHALLED)
                                            ALLOCATED *
                                            (UNMARSHALLED)
                                            (MARSHALLED)
                                            DEALLOCATED *
                (UNMARSHALLED)

(De)Allocation has to be done independently of [un]marshalling,
in cases marked "*". In this case, a procedure is needed to check a composite
type to see whether it is going to need allocation or deallocation. This is
done by "contains"

____________________________________

    Check to see whether given types occur anywhere in a composite type:
*/
Static boolean contains(pt, typeset)
defined_type *pt;
long *typeset;
{
  boolean Result;
  named_type *scan, *WITH1;

  Result = P_inset(pt->typ_basic_type, typeset);
  switch (pt->typ_basic_type) {   /*case*/

  case chartok:
  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:
  case substring:
  case sequence:
  case stringtok:   /* ok */
    break;

  case accesstok:
  case arraytok:
    if (contains(pt->typ_subtype, typeset))
      Result = true;
    break;

  case recordtok:   /*recordtok*/
    scan = pt->UU.typ_fields;
    while (scan != NULL) {
      WITH1 = scan;
      if (contains(WITH1->nty_type, typeset))
	Result = true;
      scan = WITH1->nty_next;   /*while*/
    }
    break;

  }
  /*with*/
  return Result;
}  /*contains*/


/*_____________________________________________________________________________

        Generate external definitions of external marshalling routines
        --------------------------------------------------------------

    Should only be called if it is appropriate for the output mode
    (Not pcturbo, macturbo)

Example (vaxvms):
|
|               procedure upk_mytype(var rpc_p_buf: rpc_message_pointer;
|                   var param: mytype); external;
|               procedure pck_mytype(var rpc_p_buf: rpc_message_pointer;
|                   param: mytype); external;
*/
Static Void decl_ext_marshal()
{
  named_type *pnt;
  boolean topack;

  /*decl_ext_marshal*/
  pnt = typeptr;
  while (pnt != NULL) {   /*while*/
    if (pnt->nty_type->typ_external) {
      for (topack = false; topack <= true; topack = (boolean)(topack + 1))
      {   /*if for*/
	if (((1L << ((long)omode)) & Cmode) != 0) {
	  fprintf(op_file, "extern %.3s_", upkpck[topack]);
	  write_name(&op_file, &pnt->nty_name);
	  fprintf(op_file, "();\n");
	} else {
	  fprintf(op_file, "procedure %.3s_", upkpck[topack]);
	  write_name(&op_file, &pnt->nty_name);
	  fprintf(op_file, "(var rpc_p_buf: rpc_message_pointer;\n");
	  fprintf(op_file, "    ");
	  if (!topack)
	    fprintf(op_file, "var ");
	  fprintf(op_file, "param: ");
	  write_name(&op_file, &pnt->nty_name);
	  if (((1L << ((long)omode)) &
	       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)) |
		(1 << ((long)monolith)) | (1 << ((long)unixbsd)))) != 0)
	    fprintf(op_file, "); EXTERNAL; \n");
	  if (((1L << ((long)omode)) & (1 << ((long)m6809))) != 0)
	    fprintf(op_file, "); EXTERN; \n");
	}  /*if pascal*/
      }
    }
    pnt = pnt->nty_next;
  }
}


/*_____________________________________________________________________________

                Perform dynamic allocation/deallocation
                ---------------------------------------

    This procedure will allocate and deallocate VMS strings, and it will
    DEallocate pointers. It won't allocate pointers (this is done during
    unmarshalling);

    Note that in the case of an array, we look ahead to see whether the subtype
    is going to need allocation, before producing the code to do the loop.

Pascal:         new(p);                             dispose(p);

C:              [not handled]                       free(p);
            p = ( t * ) malloc(sizeof(t));
*/
Static Void gen_allocate(where, expr, pt, level, do_alloc, typeset)
FILE **where;
expression expr;
defined_type *pt;
long level;
boolean do_alloc;
long *typeset;
{
  /* ... for the variable */
  /* nesting so far */
  /* T: all, F: deallocate */
  /* types to allocate */
  named_type *scan;
  expression exp2;
  Char ch;
  named_type *WITH1;

  ch = (Char)(level + 'a' - 1);
  switch (pt->typ_basic_type) {   /*with, case*/

  case chartok:
  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:
  case substring:   /* First token, simple type, courier type */
    break;
    /* Last simple type */
    /* Do nothing */

  /*   Pointers are deallocated after having recursively deallocated anything
       they point to.
   */
  case accesstok:
    if (P_inset(pt->typ_basic_type, typeset)) {
      if (do_alloc)
	codegen_error("Internal:  Call GEN_ALLOCATE to allocate pointer");
      exp2 = expr;
      if (((1L << ((long)omode)) & Cmode) != 0) {
	fprintf(*where, "%*cif (", (int)LeftIn(level), ' ');
	write_exp(where, &expr);
	fprintf(*where, ") {");
	format(&exp2, "(*$)      ");
	gen_allocate(where, exp2, pt->typ_subtype, level + 1, do_alloc,
		     typeset);
	fprintf(*where, "%*cfree(", (int)LeftIn(level + 1), ' ');
	write_exp(where, &expr);
	fprintf(*where, ");\n");
	fprintf(*where, "%*c} /* end if */\n", (int)LeftIn(level), ' ');
      } else {   /*pascal*/
	fprintf(*where, "%*cif ", (int)LeftIn(level), ' ');
	write_exp(where, &expr);
	fprintf(*where, " <> NIL then begin\n");
	format(&exp2, "$^        ");
	gen_allocate(where, exp2, pt->typ_subtype, level + 1, do_alloc,
		     typeset);
	fprintf(*where, "%*cdispose(", (int)LeftIn(level + 1), ' ');
	write_exp(where, &expr);
	fprintf(*where, "%*c);\n", (int)LeftIn(level + 1), ' ');
	fprintf(*where, "%*cend {if};\n", (int)LeftIn(level), ' ');
      }
    }
    break;

  case stringtok:
    if (((long)omode == (long)vaxvms) & P_inset(stringtok, typeset))
    {   /*stringtok*/
      if (do_alloc) {
	fprintf(*where, "   with ");
	write_exp(where, &expr);
	fprintf(*where,
	  " do begin new(StrAdr); strlen :=%ld; { Init. string descriptor }\n",
	  pt->UU.U12.typ_high);
	fprintf(*where, "     DType := 0; Cont := 0; end;\n");   /*ok?@@@*/
      } else {
	fprintf(*where, "%*cdispose(", (int)LeftIn(level), ' ');
	write_exp(where, &expr);
	fprintf(*where, ".StrAdr);\n");
      }

    }
    break;

  case arraytok:
    if (contains(pt->typ_subtype, typeset)) {   /*arraytok*/
      exp2 = expr;
      append_index(&exp2, level);

      fprintf(*where, "%*c", (int)LeftIn(level), ' ');
      if (((1L << ((long)omode)) & Cmode) == 0)
	fprintf(*where, "FOR rpc_%c := %ld TO %ld DO BEGIN\n",
		ch, pt->UU.U12.typ_low, pt->UU.U12.typ_high);
      else   /*if*/
	fprintf(*where, "for (rpc_%c = 0; rpc_%c<%ld; rpc_%c++) {",
		ch, ch, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1, ch);

      gen_allocate(where, exp2, pt->typ_subtype, level + 1, do_alloc, typeset);

      if (((1L << ((long)omode)) & Cmode) != 0)
	fprintf(*where, "%*c      }\n", (int)LeftIn(level), ' ');
      else
	fprintf(*where, "%*cEND {FOR};\n", (int)LeftIn(level), ' ');
    }
    break;

  case recordtok:   /*recordtok*/
    scan = pt->UU.typ_fields;
    while (scan != NULL) {
      WITH1 = scan;
      exp2 = expr;
      append_1(&exp2, '.');
      append_name(&exp2, WITH1->nty_name);
      gen_allocate(where, exp2, WITH1->nty_type, level, do_alloc, typeset);
      scan = WITH1->nty_next;   /*while*/
    }
    break;

  }
}  /*gen_allocate*/


/*___________________________________________________________________________

      Generate procedure name to (un)pack a simple type or descriptor
      ---------------------------------------------------------------

    Used for the function return result.

|       generates:      upk/pck_ttt(rpc_p_buf,
*/
Static Void dopack_simple(where, what, topack)
FILE **where;
type_token what;
boolean topack;
{
  fprintf(*where, "%.3s_", upkpck[topack]);
  switch (what) {

  case chartok:
    fprintf(*where, "char(");
    break;

  case bytetok:
    fprintf(*where, "byte(");
    break;

  case shortok:
    fprintf(*where, "short(");
    break;

  case integertok:
    fprintf(*where, "integer(");
    break;

  case real32tok:
    fprintf(*where, "real32(");
    break;

  case real48tok:
    fprintf(*where, "real48(");
    break;

  case real64tok:
    fprintf(*where, "real64(");
    break;

  case real128tok:
    fprintf(*where, "real128(");
    break;

  case longtok:
    fprintf(*where, "long(");
    break;
  }
  fprintf(*where, "rpc_p_buf, ");
}


/*___________________________________________________________________________

        Generate code to:       Align on a 2**power byte boundary

    Currently, only aligns on word boundaires, because that is all
    we need.
*/
Static Void gen_align(where, power)
FILE **where;
long power;
{
  /*gen_align*/
  if (power != 1)
    codegen_error("Internal error: Gen_align on non-word boundary! ");

  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(*where, "    IF ODD(m_index) THEN m_index:=m_index+1;\n");
  else   /*if*/
    fprintf(*where, "    if (rpc_p_buf->m_index%%2) rpc_p_buf->m_index++;\n");
}


Static Void gen_pack_type PP((FILE **where, expression expr,
			      defined_type *typ, long level, int deref,
			      int topack));

/*___________________________________________________________________________

        Generate code to:       (Un)pack String
        -----------------       ---------------

This non-recursive procedure handles the differences between string
representations in all the various target environments. Complications are:

1.  Under TurboPascal & Omegasoft pascal, the length is in the zeroth element
    of the string, and so has type 'char'.

2.  Under VMS/Pascal, if one wants to be VMS FORTRAN compatible, one
    has to pad strings out with blanks to fit into the descriptors when they
    arrive. FORTRAN does not have the concept of a variable length string,
    only of a conformant one.

    However, on a server we coerce the length of the server string to
    the length of the string sent, but this is done by the support routine.

3.  When there is no specific string handling software available, the
    compiler generates references to an extra length parameter.
    Obviously, this cannot be used in a nested subtype.

    Example of the sort of code generated:

                upk/pck_integer(l_xxx);
                FOR rpc_a := 1 TO l_xxx DO
    either      upk_char(rpc_p_buf, a_xxx[rpc_a]);
    or              begin
                        a_xxx[rpc_a]:=rpc_ch[m_index];
                        m_index := m_index+1;
                    end;

4.  C is different in that the index starts at zero, not 1, and the string
    is zero_terminated. There is (can never be) any protection against overflow.
*/
Local Void gen_pack_string(where, expr, pt, level, topack)
FILE **where;
expression expr;
defined_type *pt;
long level;
boolean topack;
{
  /* string variable name */
  /* data type */
  /* indentation level */
  /* pack or unpack? */
  Char index_a, index_b;   /* last character of name of index */
  expression a_expr;   /* One element of the string */
  expression i_expr;   /* The integer value of the length */
  expression l_expr;   /* Expression for the length variable */


  /*gen_pack_string*/
  index_a = (Char)(level - 1 + 'a');   /* rpc_a etc */
  index_b = (Char)(level + 'a');   /* rpc_b etc */

  if (((1L << ((long)omode)) & Cmode) != 0) {
    a_expr = expr;
    append_index(&a_expr, level);   /* eg    x[rpc_a]            */

    format(&l_expr, "rpc_      ");   /* the length */
    append_1(&l_expr, index_b);   /* eg    rpc_b */

    /*   Find length of string: */

    if (topack) {
      fprintf(*where, "%*cfor (rpc_%c = 0; rpc_%c <= %ld; rpc_%c++)\n",
	      (int)LeftIn(level), ' ', index_b, index_b, pt->UU.U12.typ_high,
	      index_b);
      fprintf(*where, "%*cif (", (int)LeftIn(level), ' ');
      write_exp(where, &expr);
      fprintf(*where, "[rpc_%c] == '\\0') break;\n", index_b);
    }

    /*   (un)pack the length of the string :
    */
    gen_pack_type(where, l_expr,
		  simple_descriptor[(long)integertok - (long)chartok], level,
		  false, topack);
	/* Don't dereference locals */

    /*   Generate the for loop:
    */
    /* a := 0 to b */
    fprintf(*where, "%*cfor (rpc_%c = 0; rpc_%c < rpc_%c; rpc_%c++)\n",
	    (int)LeftIn(level), ' ', index_a, index_a, index_b, index_a);
	/*deref*/

    /*   Pack each character:
    */
    gen_pack_type(where, a_expr, simple_descriptor[0], level, false, topack);

    /*   Add the terminator in memory:
    */
    if (topack)
      return;

    fprintf(*where, "%*c", (int)LeftIn(level), ' ');
    write_exp(where, &expr);
    fprintf(*where, "[rpc_%c] = '\\0';\n", index_b);
    return;
  }


  /*   VAX/VMS descriptors are handled by a subroutine:
  */
  if ((long)omode == (long)vaxvms) {
    fprintf(*where, "%*c%.3s", (int)LeftIn(level), ' ', upkpck[topack]);
    if (!client && !topack)
      fprintf(*where, "_Vstring_for(rpc_p_buf, ");   /*server unpck */
    else
      fprintf(*where, "_string_for(rpc_p_buf, ");
    write_exp(where, &expr);
    fprintf(*where, "::rpc_string_descriptor");   /* Standard Descriptor */
    if (!client && !topack)   /* Max size */
      fprintf(*where, ", %ld", pt->UU.U12.typ_high);
    fprintf(*where, ");\n");

    /*   Generate expressions for the length of the string:
    */
    return;
  }

  l_expr = expr;   /* The name of the length variable */
  i_expr = expr;   /* The integer value of the length */
  a_expr = expr;   /* The array containing the string */
  if (((1L << ((long)omode)) & ((1L << ((long)m6809)) |
	 (1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0) {
    format(&l_expr, "$[0]      ");
    format(&i_expr, "ord($[0]) ");
  } else if ((long)omode == (long)vaxpas) {
    format(&l_expr, "$.length  ");
    i_expr = l_expr;   /* The expression already is an integer */
  } else {
    format(&l_expr, "l_$       ");
    format(&a_expr, "a_$       ");
    i_expr = l_expr;   /* The expression already is an integer */
    if (level != 1)
      codegen_error("String in composite type illegal for this target");
  }
  append_index(&a_expr, level);   /* a_expr now refers to one element */

  /*   (un)pack the length of the string :

          It's a little unusual for the M6809 etc as the length is of type
          character.
  */
  fprintf(*where, "    ");
  if (((1L << ((long)omode)) & ((1L << ((long)m6809)) |
	 (1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0) {
    if (topack)
      gen_pack_type(where, i_expr,
		    simple_descriptor[(long)integertok - (long)chartok],
		    level + 2, false, topack);
    else {
      fprintf(*where, "%*c", (int)LeftIn(level), ' ');
      write_exp(where, &l_expr);
      fprintf(*where, " := rpc_ch[m_index + 1];\n");
      fprintf(*where, "%*c", (int)LeftIn(level), ' ');
      fprintf(*where, "m_index := (m_index + 2);");
    }
  } else   /*deref*/
    gen_pack_type(where, l_expr,
		  simple_descriptor[(long)integertok - (long)chartok],
		  level + 2, false, topack);

  /*   Generate the FOR loop:
  */
  fprintf(*where, "%*cFOR rpc_%c := 1 TO ", (int)LeftIn(level), ' ', index_a);
  write_exp(where, &i_expr);
  fprintf(*where, " DO\n");   /*deref*/

  /*   Generate the code to (un)pack the character
  */
  gen_pack_type(where, a_expr, simple_descriptor[0], level + 2, false, topack);


  /*not C -- Pascal: - - - - - - - - - - - - - - - - - - - - -*/

  /*if*/


  /*if not VAXVMS pascal */
  /*if not C */
}


/*___________________________________________________________________________

        Generate code to:       (un)Pack a parameter of given type
        ----------------        ----------------------------------

    This recursive procedure uses the 'level' parameter to control the
    amount of indentation at each stage, and which rpc_<level> parameters
    may be accessed by any given stage.

On entry,
    Output cursor at left margin.
On exit,
    Output cursor at left margin.
*/
Static Void gen_pack_type(where, expr, typ, level, deref, topack)
FILE **where;
expression expr;
defined_type *typ;
long level;
boolean deref, topack;
{
  /* output file */
  /* Expression for variable */
  /* type descriptor */
  /* indentation & rpc_<level> */
  /* Dereference simple types? */
  /* pack or unpack? */
  Char ch;
  named_type *scan;
  expression exp2, l_expr;   /* Expression for the length of a string, etc */
  expression s_expr;   /* Expression for the start of a substring */
  long i;   /* Loop index */
  id_name *WITH1;
  long FORLIM;
  named_type *WITH2;

  /*_____________________________________________________________________________
                      Main block of gen_pack_type
  */

  /*gen_pack_type*/
  /*    Generate a few useful expressions: */

  ch = (Char)(level - 1 + 'a');   /*for rpc_a etc */
  l_expr = expr;   /*   x */
  prepend_1(&l_expr, '_');   /*  _x */
  s_expr = l_expr;   /*  _x */
  prepend_1(&l_expr, 'l');   /* l_x */
  prepend_1(&s_expr, 's');   /* s_x */

  if (typ->typ_external) {
    fprintf(*where, "%*c%.3s_", (int)LeftIn(level), ' ', upkpck[topack]);
    write_name(&op_file, &typ->typ_name->nty_name);
    fprintf(*where, "(rpc_p_buf,");
    write_exp(where, &expr);
    fprintf(*where, ");\n");

    return;
  }
  switch (typ->typ_basic_type) {   /*case*/

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          S I M P L E

  Here we assume that the names of the pck/upk routines are consistent
  with the names rpc_xxx of the basic types.

  Note that in Pascal, a character has to be unpacked with an assignment
  statement, because the expression can be for a component of a packed array,
  which cannot be passed by address. If the expression does not end with ']',
  we can go ahead and use upk_char, as it is not an array compenent at all.
  In general, we prefer to call upk_char as it may be faster, and is certainly
  shorter.

  */
  case chartok:
    if (((1L << ((long)omode)) & Cmode) != 0 || topack ||
	expr.str[expr.len - 1] != ']') {
      fprintf(*where, "%*c%.3s_char(rpc_p_buf, ",
	      (int)LeftIn(level), ' ', upkpck[topack]);
      if (level == 1 && deref && ((1L << ((long)omode)) & Cmode) != 0)
	putc('*', *where);
      write_exp(where, &expr);
      fprintf(*where, ");\n");
    } else {  /*pascal unpack*/
      fprintf(*where, "%*cBEGIN\n", (int)LeftIn(level), ' ');
      fprintf(*where, "%*c", (int)(LeftIn(level) + 4), ' ');
      write_exp(where, &expr);
      fprintf(*where, ":=rpc_ch[m_index];\n");
      fprintf(*where, "%*cm_index := m_index+1;\n",
	      (int)(LeftIn(level) + 4), ' ');
      fprintf(*where, "%*cEND;\n", (int)LeftIn(level), ' ');
    }
    break;

  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /*simple type */
    fprintf(*where, "%*c%.3s", (int)LeftIn(level), ' ', upkpck[topack]);
    WITH1 = &typ->typ_name->nty_name;   /* eg "_integer" */
    FORLIM = WITH1->len;
    for (i = 3; i < FORLIM; i++)
      putc(WITH1->str[i], *where);
    fprintf(*where, "(rpc_p_buf, ");
    if (level == 1 && deref && ((1L << ((long)omode)) & Cmode) != 0)
      putc('*', *where);
    write_exp(where, &expr);
    fprintf(*where, ");\n");
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case arraytok:   /*arraytok*/
    /* A R R A Y */
    exp2 = expr;
    append_index(&exp2, level);

    fprintf(*where, "%*c", (int)LeftIn(level), ' ');
    if (((1L << ((long)omode)) & Cmode) == 0)   /*deref*/
      fprintf(*where, "FOR rpc_%c := %ld TO %ld DO BEGIN\n",
	      ch, typ->UU.U12.typ_low, typ->UU.U12.typ_high);
    else   /*if*/
      fprintf(*where, "for (rpc_%c = 0; rpc_%c<%ld; rpc_%c++) {\n",
	      ch, ch, typ->UU.U12.typ_high - typ->UU.U12.typ_low + 1, ch);

    gen_pack_type(where, exp2, typ->typ_subtype, level + 1, false, topack);

    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(*where, "%*c}\n", (int)LeftIn(level), ' ');
    else
      fprintf(*where, "%*cEND {FOR};\n", (int)LeftIn(level), ' ');
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

                                                          R E C O R D

      In C, records must be passed by pointers, just like scalar variables, if
      they are OUT or INOUT, or the option /BYVALUE is not selected.
  */
  case recordtok:   /*recordtok*/
    scan = typ->UU.typ_fields;
    while (scan != NULL) {
      WITH2 = scan;
      exp2 = expr;
      if (level == 1 && deref && ((1L << ((long)omode)) & Cmode) != 0)
	format(&exp2, "$->       ");
      else
	format(&exp2, "$.        ");
      append_name(&exp2, WITH2->nty_name);
      gen_pack_type(where, exp2, WITH2->nty_type, level, false, topack);
      scan = WITH2->nty_next;   /*while*/
    }
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          A C C E S S

      A pointer is marshalled as a single byte (0 or 1) to say whether the
      original pointer was NIL (0) or valid (1). If and only if it was valid,
      the byte is followed by the marshalled data which the pointer pointed to.

      Allocation is always done on unmarshalling (if the pointer is not NIL).
      Deallocation is not done here, but by the gen_allocate routine.

      Examples:   PASCAL                          C           ([]should be curly)
  |
  |               if x = NIL then pck_byte(0)     if (x==NULL) pck_byte(0)
  |               else begin                      else [
  |                   pck_byte(1);                    pck_byte(1);
  |                   ...                             ...*/
/* p2c: ../rpcc.p, line 6071: Note: Changed "* /" to "% /" in comment
|               end;                            ] /* end if %/
  */
  case accesstok:   /*accesstok*/
    if (((1L << ((long)omode)) & Cmode) != 0) {
      exp2 = expr;
      format(&exp2, "*($)      ");
      if (!topack) {   /*if unpack*/
	fprintf(*where, "%*c", (int)LeftIn(level), ' ');
	fprintf(*where, "if (next_byte(rpc_p_buf)) {\n");

	/*                   Allocate space:
	*/
	fprintf(*where, "%*c", (int)LeftIn(level + 1), ' ');
	write_exp(where, &expr);
	if (typ->typ_subtype->typ_name == NULL)
	  codegen_error("Pointer to unnamed type - cannot allocate space!");
	fprintf(*where, " = (");
	write_name(where, &typ->typ_subtype->typ_name->nty_name);
	fprintf(*where, "*) malloc(sizeof(");
	write_name(where, &typ->typ_subtype->typ_name->nty_name);
	fprintf(*where, "));\n");

      } else {  /*pack*/
	fprintf(*where, "%*cif (", (int)LeftIn(level), ' ');
	write_exp(where, &expr);
	fprintf(*where, "==NULL) pck_byte(0);\n");
	fprintf(*where, "%*celse {\n", (int)LeftIn(level), ' ');
	fprintf(*where, "%*cpck_byte(1);\n", (int)LeftIn(level + 1), ' ');

      }

      /*                   If the pointer was NULL, skip the lot:
      */
      gen_pack_type(where, exp2, typ->typ_subtype, level, false, topack);

      fprintf(*where, "%*c} /* end if */\n", (int)LeftIn(level), ' ');

    } else {  /*Pascal*/
      exp2 = expr;
      append_1(&exp2, '^');   /* x^ */

      if (!topack) {
	fprintf(*where, "m_index:=m_index+1;\n");
	fprintf(*where, "%*cif b[m_index-1]<>0 then begin\n",
		(int)LeftIn(level), ' ');
	/*                    Allocate space:
	*/
	fprintf(*where, "%*cnew(", (int)LeftIn(level + 1), ' ');
	write_exp(where, &expr);
	fprintf(*where, ");\n");

      } else   /*if topack*/
      {  /*if topack*/
	fprintf(*where, "%*cif ", (int)LeftIn(level), ' ');
	write_exp(where, &expr);
	fprintf(*where, " = NIL then pck_byte(0)\n");
	fprintf(*where, "%*celse begin\n", (int)LeftIn(level), ' ');
	fprintf(*where, "%*cpck_byte(1);\n", (int)LeftIn(level + 1), ' ');

      }

      /*                   If the pointer was NIL, skip the lot:
      */
      gen_pack_type(where, exp2, typ->typ_subtype, level, false, topack);
      fprintf(*where, "%*cend {if};\n", (int)LeftIn(level), ' ');

    }  /*if Pascal*/
    break;


  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case sequence:   /*sequence*/
    /* S E Q U E N C E */
    if (level > 1)
      codegen_error("SEQUENCE type not allowed within composite type.");

    gen_pack_type(where, l_expr,
		  simple_descriptor[(long)integertok - (long)chartok], level,
		  deref, topack);

    exp2 = expr;
    format(&exp2, "a_$       ");   /* Make an expression for the array*/
    append_index(&exp2, level);   /* Make expression for an element */

    fprintf(*where, "%*c", (int)LeftIn(level), ' ');
    if (((1L << ((long)omode)) & Cmode) == 0) {   /*deref*/
      fprintf(*where, "FOR rpc_%c := 1 TO l_", ch);
      write_exp(where, &expr);
      fprintf(*where, " DO BEGIN\n");
    } else {   /*if*/
      fprintf(*where, "for (rpc_%c = 0; rpc_%c< ", ch, ch);
      if (deref && ((1L << ((long)omode)) & Cmode) != 0)
	putc('*', *where);
      write_exp(where, &l_expr);
      fprintf(*where, "; rpc_%c++) {\n", ch);
    }

    gen_pack_type(where, exp2, typ->typ_subtype, level + 1, false, topack);
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(*where, "%*c      }\n", (int)LeftIn(level), ' ');
    else
      fprintf(*where, "%*cEND {FOR};\n", (int)LeftIn(level), ' ');
    break;

  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */
  case stringtok:   /*stringtok*/
    /* S T R I N G */
    gen_pack_string(where, expr, typ, level, topack);
    gen_align(where, 1L);   /* Align on word boundary */

    break;


  /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  |                                                         S U B S T R I N G
  | Example:      upk/pck_integer(s_xxx);
  |               upk/pck_integer(l_xxx);
  |               FOR rpc_a := s_xxx TO s_xxx + l_xxx - 1 DO
  |                   upk/pck_integer(rpc_p_buf, a_xxx[rpc_a]);
  |
  | Note: in C, the start address in the string used to run in the range 0..n-1,
  | while is Pascal it runs in the range 1..n.  The cannonical form for
  | transmission involves it running from 1..n, so it was adjusted in the
  | C code.  This was changed (7-Jun-89) so that it is always passed 1..n.
  */
  case substring:   /*substring*/
    exp2 = s_expr;   /* Start Position In String */
    gen_pack_type(where, exp2,
		  simple_descriptor[(long)integertok - (long)chartok], level,
		  deref, topack);

    /* Subtract one */

    gen_pack_type(where, l_expr,
		  simple_descriptor[(long)integertok - (long)chartok], level,
		  deref, topack);

    /* in C:      for (rpc_a = *s_x-1; rpc_x < *l_x + *s_x-1; rpc_a++)           */
    /* in Pascal: FOR rpc_a := s_x to s_x + l_x - 1 DO                   */

    if (((1L << ((long)omode)) & Cmode) != 0) {
      fprintf(*where, "    for (rpc_%c = ", ch);
      if (deref)
	putc('*', *where);
      write_exp(where, &s_expr);
      fprintf(*where, "-1; rpc_%c < ", ch);
      if (deref)
	putc('*', *where);
      write_exp(where, &l_expr);
      fprintf(*where, " + ");
      if (deref)
	putc('*', *where);
      write_exp(where, &s_expr);
      fprintf(*where, "-1; rpc_%c++)\n", ch);

    } else {
      fprintf(*where, "    FOR rpc_%c := ", ch);
      write_exp(where, &s_expr);
      fprintf(*where, " TO ");
      write_exp(where, &l_expr);
      putc('+', *where);
      write_exp(where, &s_expr);
      fprintf(*where, " - 1 DO \n");
    }

    exp2 = expr;   /*   x */
    prepend_1(&exp2, '_');   /*  _x */
    prepend_1(&exp2, 'a');   /* a_x */
    append_index(&exp2, level);   /* a_x[rpc_a] */
    /*deref*/
    gen_pack_type(where, exp2, simple_descriptor[0], level + 1, false, topack);

    gen_align(where, 1L);   /* Align on word boundary */

    break;


  }




}


/*___________________________________________________________________________

        Generate code to:       (un)Pack all parameters necessary
        -----------------       ---------------------------------

The dirn parameter is INtok or OUTok, to specify which parameters to unpack.

A string descriptor needs to be initialised, including the creation of the
string, at the server side, and the string has to be disposed of afterwards.

*/
Static Void gen_pack(where, head, dirn, topack)
FILE **where;
id_list *head;
type_token dirn;
boolean topack;
{
  /* Output file */
  /* Parameter list */
  /* Parameter filter */
  /* Pack, rather than unpack? */
  expression expr;
  defined_type *WITH1;
  long SET[3], SET1[3];

  do {
    WITH1 = head->id_type;


    /* generate an expression for the variable: */

    expr.len = 0;   /* Expression for the variable */
    append_name(&expr, head->name);   /* expr is the param. name */


    /*       Initialise any VMS descriptors on server side
             ------------------------------------------
     */
    if (!client && !topack && (long)omode == (long)vaxvms) {
      if (contains(head->id_type, P_expset(SET, 1L << ((long)stringtok))))
	    /*allocate*/
	      gen_allocate(where, expr, head->id_type, 1L, true,
			   P_expset(SET1, 1L << ((long)stringtok)));
    }


    /*       Pack or unpack
             --------------
     */
    if ((long)head->attr == (long)inoutok || (long)head->attr == (long)dirn)
    {   /*if*/
      deref = (client && !(runoptions[(long)byvalue - (long)ccerncross].value &&
			   (long)head->attr == (long)intok));
	  /** not value param **/
      /* and in-only param */

      /*level*/
      gen_pack_type(where, expr, head->id_type, 1L, deref, topack);

    }

    /*       Deallocate Memory
             -----------------
     */
    if (!client && topack) {   /* ie end of server */
      if ((long)omode == (long)vaxvms) {
	if (contains(head->id_type, P_expset(SET,
		       (1L << ((long)stringtok)) | (1 << ((long)accesstok)))))
	      /*deallocate*/
		gen_allocate(where, expr, head->id_type, 1L, false,
		  P_expset(SET1,
		    (1L << ((long)stringtok)) | (1 << ((long)accesstok))));
/* p2c: ../rpcc.p, line 6329: Note: Line breaker spent 3.7+0.57 seconds, 4508 tries on line 7553 */

      } else {  /*not vms*/
	if (contains(head->id_type, P_expset(SET, 1L << ((long)accesstok))))
	      /*deallocate*/
		gen_allocate(where, expr, head->id_type, 1L, false,
			     P_expset(SET1, 1L << ((long)accesstok)));
      }
    }



    /* Remove client's tree for an IN OUT parameter */

    if (client && (long)head->attr == (long)inoutok && topack) {   /*with*/
      if (contains(head->id_type, P_expset(SET, 1L << ((long)accesstok))))
	    /*deallocate*/
	      gen_allocate(where, expr, head->id_type, 1L, false,
			   P_expset(SET1, 1L << ((long)accesstok)));
    }

    head = head->next;
  } while (head != NULL);
}  /*GEN_PACK*/


/* Local variables for gen_header: */
struct LOC_gen_header {
  FILE **where;
  boolean doing_externals;
} ;

Local Void gen_formals_c(head, LINK)
id_list *head;
struct LOC_gen_header *LINK;
{

  /* Generates the formal parameter list enclosed in brackets */
  long a;
  id_list *scan;


  /** We are sure that head is NOT nil **/

  a = 0;
  scan = head;
  putc('(', *LINK->where);
  while (scan != NULL) {   /*while*/
    if (((1L << ((long)scan->id_type->typ_basic_type)) &
	 ((1L << ((long)sequence)) | (1 << ((long)substring)))) != 0)
      fprintf(*LINK->where, "a_");
    write_name(LINK->where, &scan->name);
    if ((long)scan->id_type->typ_basic_type == (long)substring) {
      fprintf(*LINK->where, ", s_");
      write_name(LINK->where, &scan->name);
      a++;
    }
    if (((1L << ((long)scan->id_type->typ_basic_type)) &
	 ((1L << ((long)sequence)) | (1 << ((long)substring)))) != 0) {
      fprintf(*LINK->where, ", l_");
      write_name(LINK->where, &scan->name);
      a++;
    }

    scan = scan->next;
    if (scan == NULL)
      break;
    fprintf(*LINK->where, ", ");
    a++;
    if (a > 3) {
      a = 0;
      fprintf(*LINK->where, "\n        ");
    }
  }
  fprintf(*LINK->where, ")\n");
}  /*gen_formals_c*/

/*____________________________________
*/
Local Void gen_params(head, LINK)
id_list *head;
struct LOC_gen_header *LINK;
{

  /* Generates the parameter list enclosed in brackets,
     or VAR followed by list

   On entry,
       head    must not be NIL, must point to list of ids.
   */
  id_list *scan;
  boolean simple_ref;   /* Should simple variables be dereferenced? */
  boolean array_deref;   /* what about composite variables? */
  defined_type *WITH;

  /** We are sure that head is NOT nil **/


  scan = head;
  do {
    fprintf(*LINK->where, "    ");

    /** Write the type's name if any otherwise the full declaration **/
    /** Sequences and substrings MUST be expanded a little **/
    /** The var's name depends on its type, so be careful! **/


    /*   Array variables are not dereferenced in C because they are always
         passed by address anyway. In Pascal, the VAR is not needed in the
         server list, but needed everywhere else.
     */
    array_deref = ((client || LINK->doing_externals) &&
		   ((1L << ((long)omode)) & Cmode) == 0);

    /*   Simple types and structures  must be dereferenced unless /BYVALUE was
         specified and they are IN.
         The VAR is never needed for the list of variables in the server.
     */
    simple_ref = ((client || LINK->doing_externals) &&
		  !(runoptions[(long)byvalue - (long)ccerncross].value &&
		    (long)scan->attr == (long)intok));
/* p2c: ../rpcc.p, line 6603: Note: Line breaker spent 1.1+1.80 seconds, 445 tries on line 7674 */
	/* ie not server list */

    WITH = scan->id_type;

    switch (WITH->typ_basic_type) {

    case chartok:
    case bytetok:
    case shortok:
    case integertok:
    case real32tok:
    case real48tok:
    case real64tok:
    case real128tok:
    case longtok:
    case recordtok:
    case accesstok:   /* xxxx : tttt */
      write_declaration(LINK->where, ' ', scan, simple_ref);
      break;

    case arraytok:   /* xxxx : tttt */
      write_declaration(LINK->where, ' ', scan, array_deref);
      break;

    case stringtok:  /* (a_)xxx: tttt(;) */
      if (((1L << ((long)omode)) & (Cmode | (1L << ((long)vaxvms)) |
	     (1 << ((long)vaxpas)) | (1 << ((long)m6809)) |
	     (1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) == 0) {
/* p2c: ../rpcc.p, line 6603: Note: Line breaker spent 0.7+0.46 seconds, 1472 tries on line 7703 */
	write_declaration(LINK->where, 'a', scan, array_deref);
	fprintf(*LINK->where, ";\n");   /* (l_xxx: rpc_integer) */
	write_integer(LINK->where, 'l', &scan->name, simple_ref);
      } else
	write_declaration(LINK->where, ' ', scan, array_deref);
      break;

    case sequence:  /* a_xxx: tttt; */
      write_declaration(LINK->where, 'a', scan, array_deref);
      fprintf(*LINK->where, ";\n");
      /* l_xxx: rpc_integer */
      write_integer(LINK->where, 'l', &scan->name, simple_ref);
      break;

    case substring:  /* a_xxx: tttt; */
      write_declaration(LINK->where, 'a', scan, array_deref);
      fprintf(*LINK->where, ";\n");
      /* s_xxx: rpc_integer */
      write_integer(LINK->where, 's', &scan->name, simple_ref);
      fprintf(*LINK->where, ";\n");
      /* l_xxx: rpc_integer */
      write_integer(LINK->where, 'l', &scan->name, simple_ref);
      break;

    }/*with, case*/
    scan = scan->next;
    if (scan != NULL)
      fprintf(*LINK->where, ";\n");
  } while (scan != NULL);

}  /*GEN_PARAMS*/


/*               (end of packing/unpacking)
*****************************************************************************
*/
/*       Generate local variables (server) / parameter (client)
         ------------------------------------------------------

 This subroutine will generate

     -  The parameters to the client subroutine,
     -  or a procedure definition for a turbopascal INTERFACE
     -  or the local variables in the server.

 It is a bit of a mess at present, with the same routine trying to do
 many different things. It is currently called in eight different circumstances:

                                                             Params  C D P

 from Server                             Pascal              y       F F T

                                         C                   y       F F T

 from gen_external               )
      from gen_module            )       Pascal              y       F T T
       from gen_server_block     )
  or from gen_external           )       C                   y       F T T
      from extern_gen            )

 Client INTERFACE section                Turbopascal only    y       T F T

 Client routines definition              Pascal, except      y       T F T
                                         Turbopascal         n       T F F

                                         C                   y       T F T

 where C=client(global flag), D=doing_externals, P=Parameters_wanted.

 Unfortunately, any rearrangement of the code is likely to be just as messy.
 ______________________________________________________________________________
 */
Static Void gen_header(where_, ptr, doing_externals_, parameters_wanted)
FILE **where_;
block_table *ptr;
boolean doing_externals_, parameters_wanted;
{
  /* Making ext. declarations? */

  /*____________________________________
  */
  struct LOC_gen_header V;

  /*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  */

  V.where = where_;
  V.doing_externals = doing_externals_;

  if (((1L << ((long)omode)) & Cmode) != 0) {  /* C language */
    if (client) {
      if ((long)ptr->b_type == (long)functok) {   /*function*/
	writok(V.where, ptr->return_);   /* eg:    int xxx(a,b,c)  */
	putc(' ', *V.where);
      }
      write_name(V.where, &ptr->name);
      gen_formals_c(ptr->list, &V);   /* Generate formal parameter list */

    } else {  /* C server or externals */
      if (!V.doing_externals)
	fprintf(*V.where, "r_");
      write_name(V.where, &ptr->name);
      fprintf(*V.where, "()");
      if (V.doing_externals) {
	fprintf(*V.where, ";\n");
	fprintf(*V.where, "/*  Parameters: ");
	if (ptr->list == NULL)
	  fprintf(*V.where, "none");
      }
      putc('\n', *V.where);
      if (!V.doing_externals)
	fprintf(*V.where, "{\n");
    }  /*if not client*/
  } else   /*Pascal*/
  {  /* Pascal */
    if (client || V.doing_externals) {
      writok(V.where, ptr->b_type);
      write_name(V.where, &ptr->name);

    } else   /*server*/
    {  /* Pascal server */
      writok(V.where, proctok);
      if (!V.doing_externals)
	fprintf(*V.where, "r_");
      write_name(V.where, &ptr->name);
      if (!V.doing_externals)
	fprintf(*V.where, ";\n");
    }
  }

  /** PRINT PARAMETER LIST if necessary**/


  if (parameters_wanted) {
    if (ptr->list != NULL) {
      if (((1L << ((long)omode)) & Cmode) == 0) {
	if (client || V.doing_externals)
	  fprintf(*V.where, "(\n");
	else
	  fprintf(*V.where, "VAR\n");
      }
      gen_params(ptr->list, &V);
      if ((client || V.doing_externals) && ((1L << ((long)omode)) & Cmode) == 0)
	putc(')', *V.where);
    }
  }
  /** else
                  if client and (omode in Cmode) then write(where,'()'); **/

  /** PRINT RESULT only for client PASCAL functions **/

  if (((1L << ((long)omode)) & Cmode) == 0) {   /*if Pascal*/
    if (client || V.doing_externals) {
      if (parameters_wanted && (long)ptr->b_type == (long)functok) {
	fprintf(*V.where, ": ");
	writok(V.where, ptr->return_);
      }
    }  /*if client */
  }

  if ((client || V.doing_externals) && ((1L << ((long)omode)) & Cmode) == 0 ||
      ptr->list != NULL)
	/*end_with*/
	  fprintf(*V.where, ";\n");



}  /*GEN_HEADER*/


/*___________________________________________________________________________

        Generate externals
        ------------------

Generates the list of external declarations of each procedure
or function.
*/
Static Void generate_externals()
{
  block_table *scan;

  scan = blockptr;
  while (scan != NULL) {
    if (((1L << ((long)omode)) & Cmode) != 0) {
      fprintf(op_file, "extern ");
      if ((long)scan->b_type == (long)functok) {   /*externals*/
	writok(&op_file, scan->return_);
	putc(' ', op_file);
      }
      gen_header(&op_file, scan, true, true);
      fprintf(op_file, "    */\n");
    } else {   /*externals*/
      gen_header(&op_file, scan, true, true);
      if ((long)omode == (long)m6809)
	fprintf(op_file, "EXTERNAL;\n");
      else
	fprintf(op_file, "EXTERN;\n");
    }
    putc('\n', op_file);
    scan = scan->next;
  }  /*while*/
}


/*___________________________________________________________________________

            Generate:       A type declaration in C

    This recursive procedure generates a definition of a type, given
    a name and a type descriptor. It is impossible to generate a type
    itself, as the name is buried within it in C. This is one of the
    more trying aspects of C. For example

    One must be careful of the precedence of operators such as [] and *.

            char * mytype[80]
    for     mytype      is          ARRAY[0..79] OF ACCESS RPC_CHAR

On entry,
    Cursor is assumed to be at left margin.
On exit,
    Trailing semicolon and newline NOT done.
*/

Static Void gen_type_decl_C(where, expr, pt, level)
FILE **where;
expression expr;
defined_type *pt;
long level;
{
  /* output file */
  /* for the varaiable */
  /* type structure */
  /* indentation */
  named_type *scan;
  expression exp2;

  /*gen_type_decl_c*/
  switch (pt->typ_basic_type) {   /*with, case*/

  case chartok:
  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /* First token, simple type, courier type */
    fprintf(*where, "%*c", (int)LeftIn(level), ' ');
    write_name(where,
	       &simple_descriptor[(long)pt->typ_basic_type - (long)chartok]->
		typ_name->nty_name);
    putc(' ', *where);
    write_exp(where, &expr);   /* Example: rpc_char x */
    break;
    /*simple type*/

  case substring:
  case stringtok:   /*stringtok*/
    /* Example: rpc_char x[81] */
    fprintf(*where, "%*c", (int)LeftIn(level), ' ');
    fprintf(*where, "rpc_char ");
    write_exp(where, &expr);
    fprintf(*where, "[%ld]", pt->UU.U12.typ_high + 1);
    break;

  case arraytok:   /*arraytok*/
    /* example  int x[100] */
    exp2 = expr;
    append_1(&exp2, '[');
    append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
    append_1(&exp2, ']');
    gen_type_decl_C(where, exp2, pt->typ_subtype, level);
    break;

  case sequence:
    exp2 = expr;
    append_1(&exp2, '[');
    append_decimal(&exp2, pt->UU.U12.typ_high - pt->UU.U12.typ_low + 1);
	/* 90613 */
    append_1(&exp2, ']');
    gen_type_decl_C(where, exp2, pt->typ_subtype, level);
    break;
    /*sequence*/

  case accesstok:
    exp2 = expr;
    prepend_1(&exp2, '(');
    prepend_1(&exp2, '*');
    append_1(&exp2, ')');   /* Example:  int  (*x)   */
    gen_type_decl_C(where, exp2, pt->typ_subtype, level);
    break;

  case recordtok:
    fprintf(*where, "%*cstruct {\n", (int)LeftIn(level), ' ');
    scan = pt->UU.typ_fields;
    while (scan != NULL) {   /*while*/
      exp2.len = 0;
      append_name(&exp2, scan->nty_name);
      gen_type_decl_C(where, exp2, scan->nty_type, level + 1);
      fprintf(*where, ";\n");
      scan = scan->nty_next;
    }

    fprintf(*where, "%*c} ", (int)LeftIn(level), ' ');
    write_exp(where, &expr);
    break;

  }
}


/*___________________________________________________________________________

            Generate:       A type declaration in Pascal

    This recursive procedure generates an expression for a type, given
    a type descriptor.

    Example:
            ARRAY OF RECORD H: INTEGER; C: CHAR END

    If a subtype has a name, that name will be used instead of elaborating
    the subtype itself - For example, in Pascal pointers must be declared in
    terms of the base type name, not a type expression.

On entry,
    We assume any indentation required has been done for the 1st line.
On exit,
    The semicolon and Newline on the end are not done.
*/

Static Void gen_type_pas(where, pt, level)
FILE **where;
defined_type *pt;
long level;
{
  /* output file */
  /* type structure */
  /* indentation */
  named_type *scan;
  expression exp2;

  /*gen_type_pas*/
  if (level > 1 && pt->typ_name != NULL) {
    write_name(where, &pt->typ_name->nty_name);
    return;
  }
  switch (pt->typ_basic_type) {   /*with, case*/

  case chartok:
  case bytetok:
  case shortok:
  case integertok:
  case real32tok:
  case real48tok:
  case real64tok:
  case real128tok:
  case longtok:   /* First token, simple type, courier type */
    /* Example:  rpc_char */
    write_name(where,
	       &simple_descriptor[(long)pt->typ_basic_type - (long)chartok]->
		typ_name->nty_name);
    break;
    /*simple type*/

  case substring:
  case stringtok:   /*stringtok*/
    /* Example: rpc_char x[81] */
    if ((long)omode == (long)vaxvms &&
	(long)pt->typ_basic_type == (long)stringtok) {
      fprintf(*where, "RECORD strlen: rpc_short;\n");
      fprintf(*where, "%*cDType, Cont: rpc_byte;\n",
	      (int)(LeftIn(level) + 8), ' ');
      fprintf(*where, "%*cStrAdr: ^t_", (int)(LeftIn(level) + 8), ' ');
      write_name(where, &pt->typ_name->nty_name);
      fprintf(*where, "\n%*cEND", (int)(LeftIn(level) + 4), ' ');
    } else if ((long)omode == (long)vaxpas &&
	       (long)pt->typ_basic_type == (long)stringtok)
      fprintf(*where, "VARYING[%ld] OF CHAR", pt->UU.U12.typ_high);
    else if (((1L << ((long)omode)) & ((1L << ((long)m6809)) |
		(1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0 &&
	     (long)pt->typ_basic_type == (long)stringtok)
/* p2c: ../rpcc.p, line 6824: Note: Line breaker spent 0.9+0.38 seconds, 1488 tries on line 8089 */
      fprintf(*where, "STRING[%ld]", pt->UU.U12.typ_high);
    else
      fprintf(*where, "PACKED ARRAY [1..%ld] OF CHAR", pt->UU.U12.typ_high);
    break;

  case arraytok:   /*arraytok*/
    /* example  int x[100] */
    fprintf(*where, "ARRAY [%ld..%ld] OF ",
	    pt->UU.U12.typ_low, pt->UU.U12.typ_high);
    gen_type_pas(where, pt->typ_subtype, level + 1);
    break;

  case sequence:
    fprintf(*where, "ARRAY [1..%ld] OF ", pt->UU.U12.typ_high);
    gen_type_pas(where, pt->typ_subtype, level + 1);
    break;
    /*sequence*/

  case accesstok:
    putc('^', *where);
    gen_type_pas(where, pt->typ_subtype, level + 1);
    break;

  case recordtok:
    fprintf(*where, "RECORD\n");
    scan = pt->UU.typ_fields;
    while (scan != NULL) {   /*while*/
      exp2.len = 0;
      fprintf(*where, "%*c", (int)(LeftIn(level) + 4), ' ');
      write_name(where, &scan->nty_name);
      fprintf(*where, ": ");
      gen_type_pas(where, scan->nty_type, level + 1);
      fprintf(*where, ";\n");
      scan = scan->nty_next;
    }
    fprintf(*where, "%*cEND {RECORD}", (int)LeftIn(level), ' ');
    break;

  }

  /*if*/
}


/*___________________________________________________________________________

        Generate type definitions for whole package

Example:
                typedef rpc_char xxxxx;
                typedef rpc_integer my_array[80];
or:
                xxxxx = rpc_char;
                my_array = ARRAY[1..80] OF rpc_integer;
*/

Static Void generate_types(where)
FILE **where;
{  /*generate types*/
  named_type *scan;
  expression expr;
  named_type *WITH;

  scan = typeptr;
  while (scan != NULL) {   /*end_while*/
    WITH = scan;
    /*   Just specially for the VAX/VMS, define a basic array type for each
         length of string by descriptor:
     */
    if ((long)omode == (long)vaxvms) {
      if ((long)WITH->nty_type->typ_basic_type == (long)stringtok)
      {   /* Define char array: */
	fprintf(*where, "t_");   /* jammy! */
	write_name(where, &WITH->nty_name);
	fprintf(*where, " = ");
	fprintf(*where, "PACKED ARRAY [1..%ld] OF CHAR;\n",
		WITH->nty_type->UU.U12.typ_high);
      }  /*if*/
    }

    /*   Now make the main type definition:
    */
    expr.len = 0;
    append_name(&expr, WITH->nty_name);   /* expr is name of variable */
    if (((1L << ((long)omode)) & Cmode) != 0) {
      fprintf(*where, "typedef ");
      gen_type_decl_C(where, expr, WITH->nty_type, 1L);
    } else {   /*if*/
      write_name(where, &WITH->nty_name);
      fprintf(*where, " = ");
      gen_type_pas(where, WITH->nty_type, 1L);
    }
    fprintf(*where, ";\n");
    scan = WITH->nty_next;
  }

  putc('\n', *where);
}


/*_____________________________________________________________________________

        Generate External Definition File
        =================================

    PILS and FORTRAN do not get declaraction files generated, as they
    don't do enough type checking to merit it.
*/
Static Void ext_generator(ext_mode, ext_name)
output_mode ext_mode;
astring ext_name;
{
  if (((1L << ((long)omode)) & ((1L << ((long)pils)) | (1 << ((long)vaxfor)))) != 0)
    return;
  if (!file_open(&op_file, &ext_name, rewriting)) {
    error(cant_opn_ext);
    return;
  }
  client = false;
  omode = ext_mode;
  putc('\n', op_file);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "/*  ");
  else
    fprintf(op_file, "{*  ");
  fprintf(op_file, "Stub Version Number: ");
  if (version_num == 0)
    fprintf(op_file, "zero (no check)");
  else
    fprintf(op_file, "%ld", version_num);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "  */\n");
  else
    fprintf(op_file, "  *}\n");
  putc('\n', op_file);
  if (runoptions[(long)types - (long)ccerncross].value && typeptr != NULL) {
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(op_file, "TYPE\n");
    generate_types(&op_file);
  }
  generate_externals();
  if (!file_close(&op_file))
    error(cant_cls_ext);
}  /*EXT_GENERATOR*/


/* Local variables for gen_module: */
struct LOC_gen_module {
  FILE **where;
} ;

Local Void do_include(which, LINK)
Char *which;
struct LOC_gen_module *LINK;
{
  long i;

  fprintf(*LINK->where, "*INCLUDE rpc");
  for (i = 0; i <= 9; i++) {
    if (which[i] != ' ')
      putc(which[i], *LINK->where);
  }
  putc('\n', *LINK->where);
}


/*_____________________________________________________________________________


                Generate Module Declaration Code
                ================================

Generates the heading, CONST, TYPE and VAR sections of a stub module,
and the standard include files.
*/
Static Void gen_module(where_)
FILE **where_;
{

  /*       Invoke Include file
  |       -------------------
  |
  | On VMS, the file is referred to by a logical name (no . in it, and a $
  | to avoid conflict with real files).
  */
  struct LOC_gen_module V;

  /*               Main block for Gen_module
                   -------------------------

   Generates:      The module header
                   The constant and type definitions
   */
  /** Generate header according to xxx_mode **/

  V.where = where_;
  putc('\n', *V.where);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(*V.where, "#include <rpcheader.h>\n\n");
	/* <-- change to "<file>"? */
  else {
    if (((1L << ((long)omode)) & ((1L << ((long)monolith)) |
	   (1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) == 0) {
      fprintf(*V.where, "MODULE ");
      if (client)
	fprintf(*V.where, "CLI");
      else
	fprintf(*V.where, "SER");
      write_name(V.where, &unitname);
      fprintf(*V.where, ";\n");
    }

    if (((1L << ((long)omode)) &
	 ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0) {
      fprintf(*V.where, "UNIT ");
      if (client)
	fprintf(*V.where, "CLI");
      else
	fprintf(*V.where, "SER");
      write_name(V.where, &unitname);

      /* For MacTurbo, a unit number, in parenthesis, is required between
         the unit name and the semicolon terminating the unit header.
         This number (a positive 16-bit integer constant) should be
         different from any other unit number that the user program might
         use. The current allocation of unit numbers (MacTurbo version)
         is:

                   Module          Unit Number

                   RPCMacPas       1
                   RPCStub         2
                   TSTurbo         3
                   RPCRTS          4

         That's why we use the unit number 5 for stub modules. If more
         stubs have to be combined in a single program, the user will
         need to modify stub unit numbers in order to ensure their
         uniqueness.
       */

      if ((long)omode == (long)macturbo)
	fprintf(*V.where, "(5)");
      fprintf(*V.where, ";\n");
      fprintf(*V.where, "INTERFACE\n");
      if ((long)omode == (long)pcturbo) {
	fprintf(*V.where, "USES rpcpcpas,\n");
	fprintf(*V.where, "     rpcstub,\n");
	fprintf(*V.where, "     tsturbo,\n");
	if (external_marshalling)
	  fprintf(*V.where, "     extmarsh,\n");
	fprintf(*V.where, "     rpcrts");
      } else {
	fprintf(*V.where, "{$U RPCMacPas}\n");
	fprintf(*V.where, "{$U RPCStub}\n");
	fprintf(*V.where, "{$U TSTurbo}\n");
	if (external_marshalling)
	  fprintf(*V.where, "{$U extmarsh}\n");
	fprintf(*V.where, "{$U RPCRTS}\n");
	if (!client) {
	  fprintf(*V.where,
	    "{--> It is assumed, by default, that the name of the unit library file <--}\n");
	  fprintf(*V.where,
	    "{--> containing the server routines is the same as the package name.   <--}\n");
	  fprintf(*V.where,
	    "{--> If the assumption is wrong, just replace the following line.      <--}\n");
	  fprintf(*V.where, "{$U ");
	  write_name(V.where, &unitname);
	  fprintf(*V.where, "}\n");
	}
	fprintf(*V.where, "\nUSES MemTypes,\n");
	fprintf(*V.where, "     QuickDraw,\n");
	fprintf(*V.where, "     OSIntf,\n");
	fprintf(*V.where, "     ToolIntf,\n");
	fprintf(*V.where, "     RPCMacPas,\n");
	fprintf(*V.where, "     RPCStub,\n");
	fprintf(*V.where, "     TSTurbo,\n");
	if (external_marshalling)
	  fprintf(*V.where, "     extmarsh,\n");
	fprintf(*V.where, "     RPCRTS");
      }

      if (!client) {
	fprintf(*V.where, ",\n");
	fprintf(*V.where,
	  "{--> It is assumed, by default, that the name of the unit containing   <--}\n");
	fprintf(*V.where,
	  "{--> the server routines is the same as the package name. If the       <--}\n");
	fprintf(*V.where,
	  "{--> assumption is wrong, just replace the following line.             <--}\n");
	fprintf(*V.where, "     ");
	write_name(V.where, &unitname);
      }
      fprintf(*V.where, ";\n\n");

      if (!client && typeptr != NULL) {
	fprintf(*V.where,
	  "{--> Being this a server stub, the TYPE declarations should not be     <--}\n");
	fprintf(*V.where,
	  "{--> included here (they belong to the unit containing the server      <--}\n");
	fprintf(*V.where,
	  "{--> routines). However you will find them below (commented out), in   <--}\n");
	fprintf(*V.where,
	  "{--> case you need them for reference.                                 <--}\n");
	fprintf(*V.where, "{\n");
      }

      if (typeptr != NULL)
	fprintf(*V.where, "TYPE\n");

    } else {   /*if*/
      fprintf(*V.where, "\nCONST\n");
      do_include("const.h   ", &V);   /* Include rpc constants file */

      /** Generate types **/
      fprintf(*V.where, "\nTYPE\n");
      do_include("types.h   ", &V);   /* Include rpc types file */

    }
  }

  generate_types(V.where);   /* generate local types   */

  /* For MacTurbo and PCTurbo server stubs stop commenting. */

  if (!client && ((1L << ((long)omode)) & ((1L << ((long)pcturbo)) |
		    (1 << ((long)macturbo)))) != 0 && typeptr != NULL)
/* p2c: ../rpcc.p, line 7142: Note: Line breaker spent 0.6+0.43 seconds, 917 tries on line 8417 */
    fprintf(*V.where, "}\n");

  /*   Generate global variables  (handle for client, program index for server)
  */
  if (client) {
    if (((1L << ((long)omode)) & Cmode) != 0) {
      fprintf(*V.where, "int h_");
      write_name(V.where, &unitname);
      fprintf(*V.where, ";\n");
    } else {
      if ((long)omode == (long)cerncross)
	fprintf(*V.where, "EXPORT\n");
      else
	fprintf(*V.where, "VAR\n");
      fprintf(*V.where, "    h_");
      write_name(V.where, &unitname);
      if (((1L << ((long)omode)) &
	   ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0)
	fprintf(*V.where, ": [global] integer;\n");
      else if ((long)omode == (long)m6809)
	fprintf(*V.where, ": integer external;\n");   /*70604*/
      else if (((1L << ((long)omode)) &
		((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0)
	fprintf(*V.where, ": client_pointer;\n");   /*80429*/
      else
	fprintf(*V.where, ": integer;\n");
    }

  } else {  /*server*/
    if (((1L << ((long)omode)) & Cmode) != 0) {
      fprintf(*V.where, "program_index p_");
      write_name(V.where, &unitname);
      fprintf(*V.where, ";\n");
    } else   /*if pascal*/
    {  /*pascal*/
      if ((long)omode == (long)cerncross)
	fprintf(*V.where, "EXPORT\n");
      else
	fprintf(*V.where, "VAR\n");
      fprintf(*V.where, "    p_");
      write_name(V.where, &unitname);
      if (((1L << ((long)omode)) &
	   ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0) {
	fprintf(*V.where, ": [global] integer;\n");
	/****        else if (omode = m6809)
	                then writeln(where, ': program_index external ;')  ****/
      } else if (((1L << ((long)omode)) &
		  ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0)
	fprintf(*V.where, ": program_pointer;\n");
      else
	fprintf(*V.where, ": program_index;\n");
    }
  }
  putc('\n', *V.where);

  if (((1L << ((long)omode)) &
       (Cmode | (1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) == 0) {
    do_include("proc.h    ", &V);   /* External definitions of RTS */
    do_include("stub.h    ", &V);   /* Local stub procedures */
    putc('\n', *V.where);
  }

  /*   Declare external marshalling routines if needed:
  */
  if (external_marshalling) {
    if (((1L << ((long)omode)) &
	 (Cmode | (1L << ((long)vaxvms)) | (1 << ((long)vaxpas)) |
	  (1 << ((long)unixbsd)) | (1 << ((long)m6809)))) != 0)
/* p2c: ../rpcc.p, line 7142: Note: Line breaker spent 0.7+0.70 seconds, 951 tries on line 8486 */
      decl_ext_marshal();
  }

  /**    if omode in [pcturbo, macturbo] then writeln(where, 'IMPLEMENTATION'); **/

  if (!client && ((1L << ((long)omode)) &
		  ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) == 0)
    generate_externals();




  /* For MacTurbo things are more complicated. */


  /** Generate constants **/
}  /*GEN_MODULE*/


/* Local variables for client_generator: */
struct LOC_client_generator {
  long proc_number;
} ;

/*___________________________________________________
*/
Local Void gen_client_block_pas(ptr, LINK)
block_table *ptr;
struct LOC_client_generator *LINK;
{

  /****
  * On each block, the client allocates 'RPC_integer' variables to pack or
  * unpack parameters.
  *****/
  long a;
  expression return_value;   /* Expression for return value */
  long FORLIM;


  /** generate and print procedure header **/
  if (((1L << ((long)omode)) &
       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0)
    fprintf(op_file, "[GLOBAL]\n");

  /*  For MacTurbo we must generate the procedure heading
      formal parameter part ONLY in the INTERFACE section.
   */
  gen_header(&op_file, ptr, false, (long)omode != (long)macturbo);

  if ((long)omode == (long)m6809)
    fprintf(op_file, "    ENTRY;\n");

  /** print local vars and buffer allocation **/
  fprintf(op_file, "VAR rpc_p_buf: rpc_message_pointer;\n");
  FORLIM = ptr->blk_nesting;
  for (a = 0; a < FORLIM; a++)
    fprintf(op_file, "    rpc_%c : rpc_integer;\n", (Char)(a + 97L - 1 + 1));
  if ((long)ptr->b_type == (long)functok) {
    fprintf(op_file, "    rpc_ret : ");
    writok(&op_file, ptr->return_);
    fprintf(op_file, ";\n");
  }
  fprintf(op_file, "BEGIN\n");
  fprintf(op_file, "rpc_new(rpc_p_buf, RPC_BUFFER_SIZE);\n");
  fprintf(op_file, "  WITH rpc_p_buf^ DO BEGIN\n");
  fprintf(op_file, "    m_index := CALL_HEADER_LENGTH - 4;\n");

  /** pack version & procedure number **/
  fprintf(op_file, "    pck_short(rpc_p_buf, %ld);\n", version_num);
  fprintf(op_file, "    pck_short(rpc_p_buf, %ld);\n", LINK->proc_number);

  /** generate packing statements for IN & INOUT params **/
  if (ptr->list != NULL)
    gen_pack(&op_file, ptr->list, intok, true);

  fprintf(op_file, "  END  {WITH};\n");   /* 71006 */

  /** generate rpc_call and bookeeping **/

  fprintf(op_file, "    ");
  if (ptr->blk_status_param != NULL) {   /*if*/
    write_name(&op_file, &ptr->blk_status_param->name);
    fprintf(op_file, " := ");
  }

  if (ptr->blk_cast)
    fprintf(op_file, "rpc_cast");
  else
    fprintf(op_file, "rpc_call");
  if (ptr->blk_status_param != NULL)
    fprintf(op_file, "_status");
  fprintf(op_file, "(h_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ", rpc_p_buf");
  if (!ptr->blk_cast)
    fprintf(op_file, ",%ld", ptr->blk_timeout);
  fprintf(op_file, ");\n");

  if (ptr->blk_status_param != NULL) {   /*if*/
    fprintf(op_file, "  IF odd(");
    write_name(&op_file, &ptr->blk_status_param->name);
    fprintf(op_file, ") THEN ");
  }
  fprintf(op_file, "  WITH rpc_p_buf^ DO BEGIN\n");   /* 71006 */

  if (ptr->blk_max_out > 0) {   /*if*/
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(op_file, "    rpc_p_buf->m_index =");
    else
      fprintf(op_file, "    m_index :=");
    fprintf(op_file, " RETURN_HEADER_LENGTH;\n");
  }

  /** if function: unpack return value **/
  if ((long)ptr->b_type == (long)functok) {
    fprintf(op_file, "    ");
    dopack_simple(&op_file, ptr->return_, false);
    fprintf(op_file, "rpc_ret);\n");
  }

  /** generate UNpacking statements for OUT and INOUT params **/
  if (ptr->list != NULL)
    gen_pack(&op_file, ptr->list, outok, false);

  /** clear up everything and exit **/
  if (((1L << ((long)omode)) & Cmode) != 0) {
    fprintf(op_file, "    c_dispose(rpc_p_buf);\n");
    if ((long)ptr->b_type == (long)functok)
      fprintf(op_file, "    return(rpc_ret);\n");
    fprintf(op_file, "    }\n");
  } else {
    if ((long)ptr->b_type == (long)functok) {
      fprintf(op_file, "    ");
      write_name(&op_file, &ptr->name);
      fprintf(op_file, " := rpc_ret;\n");
    }
    fprintf(op_file, "  END  {WITH};\n");
    fprintf(op_file, "  rpc_dispose(rpc_p_buf);\n");
    fprintf(op_file, "END;\n");
  }
  putc('\n', op_file);
}  /*gen_client_block_pas*/

/*___________________________________________________
*/
Local Void gen_client_block_c(ptr, LINK)
block_table *ptr;
struct LOC_client_generator *LINK;
{

  /****
  * On each block, the client allocates 'RPC_integer' variables to pack or
  * unpack parameters.
  *****/
  long a;
  expression return_value;   /* Expression for return value */
  long FORLIM;


  /** generate and print procedure header **/

  gen_header(&op_file, ptr, false, true);

  /** print local vars and buffer allocation **/

  fprintf(op_file, "\n{   rpc_message *rpc_p_buf;\n");
  FORLIM = ptr->blk_nesting;
  for (a = 0; a < FORLIM; a++)
    fprintf(op_file, "    register rpc_integer rpc_%c;\n",
	    (Char)(a + 97L - 1 + 1));
  if ((long)ptr->b_type == (long)functok) {
    fprintf(op_file, "    ");
    writok(&op_file, ptr->return_);
    fprintf(op_file, " rpc_ret;\n");
  }
  fprintf(op_file, "\n    ");

  fprintf(op_file, "c_new(rpc_p_buf, RPC_BUFFER_SIZE);\n");

  fprintf(op_file, "    rpc_p_buf->m_index = CALL_HEADER_LENGTH - 4;\n");

  /** pack version & procedure number **/
  fprintf(op_file, "    pck_short(rpc_p_buf, %ld);\n", version_num);
  fprintf(op_file, "    pck_short(rpc_p_buf, %ld);\n", LINK->proc_number);

  /** generate packing statements for IN & INOUT params **/
  if (ptr->list != NULL)
    gen_pack(&op_file, ptr->list, intok, true);

  /** generate rpc_call and bookeeping **/
  fprintf(op_file, "    ");
  if (ptr->blk_status_param != NULL) {   /*if*/
    putc('*', op_file);
    write_name(&op_file, &ptr->blk_status_param->name);
    fprintf(op_file, " = ");
  }
  fprintf(op_file, "c_call");
  if (ptr->blk_status_param != NULL)
    fprintf(op_file, "_status");
  fprintf(op_file, "(h_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ", rpc_p_buf, %ld);\n", ptr->blk_timeout);

  if (ptr->blk_status_param != NULL) {   /*if*/
    fprintf(op_file, "  if (*");
    write_name(&op_file, &ptr->blk_status_param->name);
    fprintf(op_file, "&& 1) { /* If good call */ \n");
  }

  if (ptr->blk_max_out > 0)
    fprintf(op_file, "    rpc_p_buf->m_index = RETURN_HEADER_LENGTH;\n");

  /** if function: unpack return value **/
  if ((long)ptr->b_type == (long)functok) {
    fprintf(op_file, "    ");
    dopack_simple(&op_file, ptr->return_, false);
    fprintf(op_file, "rpc_ret);\n");
  }

  /** generate UNpacking statements for OUT and INOUT params **/
  if (ptr->list != NULL)
    gen_pack(&op_file, ptr->list, outok, false);

  if (ptr->blk_status_param != NULL)
    fprintf(op_file, "  } /* end if good call */\n");


  /** clear up everything and exit **/
  fprintf(op_file, "    c_dispose(rpc_p_buf);\n");
  if ((long)ptr->b_type == (long)functok)
    fprintf(op_file, "    return(rpc_ret);\n");
  fprintf(op_file, "    }\n\n");
}  /*gen_client_block_c*/

/*___________________________________________________
*/
Local Void gen_open__(LINK)
struct LOC_client_generator *LINK;
{
  if (((1L << ((long)omode)) &
       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0) {
    if (runoptions[(long)noautoinit - (long)ccerncross].value)
      fprintf(op_file, "[GLOBAL]\n");
    else
      fprintf(op_file, "[GLOBAL, INITIALIZE]\n");
  }
  writok(&op_file, proctok);
  fprintf(op_file, "open_");
  write_name(&op_file, &unitname);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "()\n");
  else
    fprintf(op_file, ";\n");
  if ((long)omode == (long)m6809)
    fprintf(op_file, "   ENTRY;\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "{   rpc_status       status;\n");
  else {
    fprintf(op_file, "VAR\n");
    fprintf(op_file, "    status : rpc_status;\n");
    fprintf(op_file, "    service : rpc_name;\n");
    fprintf(op_file, "BEGIN\n");
    fprintf(op_file, "    service := ");
    write_name_padded(&op_file, unitname, '\'');
    fprintf(op_file, ";\n");
  }

  if (((1L << ((long)omode)) & Cmode) != 0)
    putc('\n', op_file);
  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");
  fprintf(op_file, "c_open(status, h_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ", ");
  if (((1L << ((long)omode)) & Cmode) != 0)
    write_name_padded(&op_file, unitname, '"');
  else
    fprintf(op_file, "service");
  fprintf(op_file, ");\n");

  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");
  fprintf(op_file, "c_report_error(status);\n");
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "    }\n");
  else
    fprintf(op_file, "END;\n");
}  /*GEN_OPEN*/

/*______________________________________________

        Generate procedure to close stub:  close_xxx()

    In PCturbo, this is a valid exit procedure, which replaces the exit
    procedure pointer when it is done.
*/
Local Void gen_close_(LINK)
struct LOC_client_generator *LINK;
{
  if (((1L << ((long)omode)) &
       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0)
    fprintf(op_file, "[GLOBAL]\n");
  writok(&op_file, proctok);
  fprintf(op_file, "close_");
  write_name(&op_file, &unitname);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "()\n");
  else
    fprintf(op_file, ";\n");
  if ((long)omode == (long)m6809)
    fprintf(op_file, "   ENTRY;\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "{   rpc_status       status;\n\n");
  else {
    fprintf(op_file, "VAR\n");
    fprintf(op_file, "    status : rpc_status;\n");
    fprintf(op_file, "BEGIN\n");
  }

  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");
  fprintf(op_file, "c_close(status, h_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ");\n");

  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");
  fprintf(op_file, "c_report_error(status);\n");

  if ((long)omode == (long)pcturbo) {
    fprintf(op_file, "   ExitProc := e_");
    write_name(&op_file, &unitname);
    fprintf(op_file, ";\n");
  }

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "    }\n");
  else
    fprintf(op_file, "END;\n");
}  /*gen_close*/



/*******************************************************************************

                Client code generator
                =====================

Generates one procedure or function for the client.
*/

Static Void client_generator(client_mode, cli_name)
output_mode client_mode;
/* p2c: ../rpcc.p, line 7561: Note: Line breaker spent 0.0+2.73 seconds, 23 tries on line 8847 */
astring cli_name;
{
  struct LOC_client_generator V;
  block_table *scan;

  /*______________________________________________________
  */

  if (!file_open(&op_file, &cli_name, rewriting)) {
    error(cant_opn_client);
    return;
  }

  omode = client_mode;
  client = true;

  if ((long)omode == (long)pils)
    client_generator_pils();
  else if ((long)omode == (long)vaxfor)
    client_gen_for();
  else {
    /** Generate module name and type, var, procedure inclusion **/
    if ((long)omode != (long)monolith)
      gen_module(&op_file);

    /*       Special INTERFACE part for PCTurbo and MacTurbo:
    */

    /* For PCTurbo provide a variable to save the address of ExitProc */

    if ((long)omode == (long)pcturbo) {
      fprintf(op_file, "    e_");   /* Add a variable for close_x */
      write_name(&op_file, &unitname);
      fprintf(op_file, ":   pointer;\n");
    }

    if (((1L << ((long)omode)) &
	 ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0) {
      /* For MacTurbo and PCTurbo the global procedure headings
         must appearin the interface part.
         For MacTurbo we must generate the procedure heading
         formal parameter part ONLY in the INTERFACE section.
       */

      V.proc_number = 1;
      scan = blockptr;
      while (scan != NULL) {   /*while*/
	gen_header(&op_file, scan, false, true);
	V.proc_number++;
	scan = scan->next;
      }

      fprintf(op_file, "PROCEDURE open_");
      write_name(&op_file, &unitname);
      fprintf(op_file, ";\n");

      fprintf(op_file, "PROCEDURE close_");
      write_name(&op_file, &unitname);
      fprintf(op_file, ";\n\n");

      fprintf(op_file, "IMPLEMENTATION\n\n");
    }


    /**      Generate procedures **/

    V.proc_number = 1;
    scan = blockptr;
    while (scan != NULL) {
      if (((1L << ((long)omode)) & Cmode) != 0)
	gen_client_block_c(scan, &V);
      else
	gen_client_block_pas(scan, &V);
      V.proc_number++;
      scan = scan->next;
    }

    gen_open__(&V);
    gen_close_(&V);   /* Added for all versions now 8-May-1989 */

    /*       Specials for PCTurbo and MacTurbo :  Autoinit.
    */

    /* Exit handler only in PCTurbo version. */

    if (((1L << ((long)omode)) &
	 ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0)
    {   /*if*/
      if (!runoptions[(long)noautoinit - (long)ccerncross].value ||
	  (long)omode == (long)pcturbo)
	fprintf(op_file, "BEGIN\n");

      if ((long)omode == (long)pcturbo) {
	fprintf(op_file, "  e_");
	write_name(&op_file, &unitname);
	fprintf(op_file, " := ExitProc;\n");
	fprintf(op_file, "  ExitProc := @close_");
	write_name(&op_file, &unitname);
	fprintf(op_file, ";\n");
      }

      if (!runoptions[(long)noautoinit - (long)ccerncross].value) {
	fprintf(op_file, "  open_");
	write_name(&op_file, &unitname);
	fprintf(op_file, ";\n");
      }

      fprintf(op_file, "END.\n");
    }

    /**      Generate end of module **/

    if (((1L << ((long)omode)) &
	 ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0)
      fprintf(op_file, "END .\n");
    else if ((long)omode == (long)m6809)
      fprintf(op_file, "MODEND .\n");
    else if ((long)omode == (long)cerncross)
      fprintf(op_file, ".\n");

  }
  if (!file_close(&op_file))
    error(cant_cls_client);



  /*if not pils or FORTRAN*/
}  /*CLIENT_GENERATOR*/


/* Local variables for server_generator: */
struct LOC_server_generator {
  block_table *scan;
} ;

/* Local variables for gen_server_block: */
struct LOC_gen_server_block {
  struct LOC_server_generator *LINK;
  id_list *scanlist;
} ;

Local Void write_Camp(LINK)
struct LOC_gen_server_block *LINK;
{
  fprintf(op_file, ", ");
  if (((1L << ((long)omode)) & Cmode) != 0 &&
      !(runoptions[(long)byvalue - (long)ccerncross].value &&
	(long)LINK->scanlist->attr == (long)intok))
/* p2c: ../rpcc.p, line 8033: Note: Line breaker spent 1.2+1.06 seconds, 605 tries on line 8996 */
    putc('&', op_file);
}


/*       Generate server stub for one Procedure/function
         -----------------------------------------------
 */
Local Void gen_server_block(ptr, LINK)
block_table *ptr;
struct LOC_server_generator *LINK;
{
  /****
  * On each block, the server allocates 'RPC_integer' variables to pack or
  * unpack parameters, accoring to the maximum number (blk_nesting) needed
  * at any one time.
  *****/
  struct LOC_gen_server_block V;
  long a, par_count;   /* how far we are getting across line */
  long FORLIM;


  V.LINK = LINK;
  /** generate and print procedure header **/
  gen_header(&op_file, ptr, false, true);

  FORLIM = ptr->blk_nesting;
  /** print local vars and buffer allocation **/
  for (a = 0; a < FORLIM; a++) {
    fprintf(op_file, "    ");
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(op_file, "register rpc_integer ");
    fprintf(op_file, "rpc_%c", (Char)(a + 97L - 1 + 1));
    if (((1L << ((long)omode)) & Cmode) == 0)
      fprintf(op_file, " : rpc_integer");
    fprintf(op_file, ";\n");
  }

  if (((1L << ((long)omode)) & Cmode) != 0)
    putc('\n', op_file);
  else {
    fprintf(op_file, "BEGIN\n");
    fprintf(op_file, "  WITH rpc_p_buf^ DO BEGIN\n");
  }

  /** generate UNpacking statements for IN and INOUT params **/
  if (ptr->list != NULL)
    gen_pack(&op_file, ptr->list, intok, false);

  /* Generate call and bookeeping:
  */
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "    rpc_p_buf->m_index = RETURN_HEADER_LENGTH;\n");
  else
    fprintf(op_file, "    m_index := RETURN_HEADER_LENGTH;\n");

  if ((long)ptr->b_type == (long)proctok && ptr->in_only) {
    if (runoptions[(long)concurrent - (long)ccerncross].value ||
	ptr->blk_concurrent)
      fprintf(op_file, "    rpc_early_return(rpc_p_buf);\n");
    else if (ptr->blk_cast) {
      if (((1L << ((long)omode)) & Cmode) != 0)
	fprintf(op_file, "    rpc_p_buf->m_status=1;\n");
      else
	fprintf(op_file, "    m_status:=1;\n");
    }
  }
  fprintf(op_file, "    ");

  /*   If function: generate return variable **/
  if ((long)ptr->b_type == (long)functok)
    dopack_simple(&op_file, ptr->return_, true);

  /* Generate list of variables:
  */
  write_name(&op_file, &ptr->name);
  if (ptr->list != NULL) {
    putc('(', op_file);
    V.scanlist = ptr->list;
    par_count = 1;
    do {

      /*       Generate address of simple types and records in C if necessary:
      */
      if (((1L << ((long)omode)) & Cmode) != 0 &&
	  ((1L << ((long)V.scanlist->id_type->typ_basic_type)) &
	   (((1L << ((long)longtok + 1)) - (1 << ((long)chartok))) |
	    (1 << ((long)recordtok)))) !=
	  0 &&
	  !(runoptions[(long)byvalue - (long)ccerncross].value &&
	    (long)V.scanlist->attr == (long)intok))
/* p2c: ../rpcc.p, line 8033: Note: Line breaker spent 15.1+1.73 seconds, 5000 tries on line 9087 */
	putc('&', op_file);

      /* If var is SEQUENCE or SUBSTRING or STRING put all names
      */
      if ((long)V.scanlist->id_type->typ_basic_type == (long)sequence) {
	fprintf(op_file, "a_");
	write_name(&op_file, &V.scanlist->name);
	par_count++;
	write_Camp(&V);
	fprintf(op_file, "l_");
      } else if ((long)V.scanlist->id_type->typ_basic_type == (long)substring) {
	fprintf(op_file, "a_");
	write_name(&op_file, &V.scanlist->name);
	write_Camp(&V);
	fprintf(op_file, "s_");
	write_name(&op_file, &V.scanlist->name);
	par_count += 2;
	write_Camp(&V);
	fprintf(op_file, "l_");
      } else if ((long)V.scanlist->id_type->typ_basic_type == (long)stringtok &&
		 ((1L << ((long)omode)) & (Cmode | (1L << ((long)vaxvms)) |
		    (1 << ((long)vaxpas)) | (1 << ((long)m6809)) |
		    (1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) == 0) {
/* p2c: ../rpcc.p, line 8033: Note: Line breaker spent 4.3+2.22 seconds, 2581 tries on line 9111 */
	fprintf(op_file, "a_");
	write_name(&op_file, &V.scanlist->name);
	par_count++;
	fprintf(op_file, ", l_");
      }

      /*   Write the main parameter name:
      */
      write_name(&op_file, &V.scanlist->name);

      par_count++;
      V.scanlist = V.scanlist->next;
      if (V.scanlist != NULL) {   /*if*/
	fprintf(op_file, ", ");
	if (par_count > 3) {   /* Line wrap around */
	  fprintf(op_file, "\n        ");
	  par_count = 0;
	}
      }
    } while (V.scanlist != NULL);
    putc(')', op_file);
  } else if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "()");

  /** if function generates return variable **/
  if ((long)ptr->b_type == (long)functok)
    putc(')', op_file);

  fprintf(op_file, ";\n");

  /** generate packing statements for OUT and INOUT params**/
  if (ptr->list != NULL)
    gen_pack(&op_file, ptr->list, outok, true);

  /** writeln(op_file, '    rpc_early_return(rpc_p_buf, m_index);');   oct 86 **/

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "    }\n");
  else {
    fprintf(op_file, "  END {with};\n");
    fprintf(op_file, "END;\n");
  }
  putc('\n', op_file);
}  /*gen_server_block*/


/*       Generate Main Server Procedure
         ------------------------------
 */
Local Void gen_jump_proc(LINK)
struct LOC_server_generator *LINK;
{
  long proc_num;

  if (((1L << ((long)omode)) & Cmode) != 0) {
    fprintf(op_file, "static rpc_message *rpc_p_buf;\n\n");
    LINK->scan = blockptr;
    proc_num = 0;
    while (LINK->scan != NULL) {
      gen_server_block(LINK->scan, LINK);
      LINK->scan = LINK->scan->next;
      proc_num++;
    }
  }

  if (((1L << ((long)omode)) &
       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0)
    fprintf(op_file, "[GLOBAL]\n");
  writok(&op_file, proctok);
  fprintf(op_file, "r_");
  write_name(&op_file, &unitname);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "(rpc_a) rpc_message **rpc_a;\n");   /* 71217 */
  else
    fprintf(op_file, "(VAR rpc_p_buf : rpc_message_pointer);\n");
  if ((long)omode == (long)m6809)
    fprintf(op_file, "    ENTRY;\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "{   rpc_short request;\n");
  else {
    fprintf(op_file, "VAR\n");
    fprintf(op_file, "    request : rpc_short;\n");
  }

  /** writeln(op_file, '    status: rpc_status;'); **/

  /*       All the procedures to service each procedure/function are
           now declared as local to the jump procedure. In this way they
           can use the parameter rpc_p_buf (TBL Oct 86).

           EXCEPT in Cmode: here the service functions are declared static
           and beforehand; rpc_p_buf is a static global that is set on entry
           to this procedure (Nici Aug 87).
   */
  if (((1L << ((long)omode)) & Cmode) == 0) {
    LINK->scan = blockptr;
    proc_num = 0;
    while (LINK->scan != NULL) {
      gen_server_block(LINK->scan, LINK);
      LINK->scan = LINK->scan->next;
      proc_num++;
    }

    fprintf(op_file, "BEGIN\n");
    fprintf(op_file, "  WITH rpc_p_buf^ DO BEGIN\n");
    fprintf(op_file, "    m_index :");
  } else {
    fprintf(op_file, "\n    rpc_p_buf = *rpc_a;\n");
    /* 71217 */
    fprintf(op_file, "    rpc_p_buf->m_index ");
  }

  fprintf(op_file, "= CALL_HEADER_LENGTH - ");
  if (version_num == 0)
    fprintf(op_file, "2;\n");
  else {
    fprintf(op_file, "4;\n");
    fprintf(op_file, "    upk_short(rpc_p_buf, request);\n");
    if (((1L << ((long)omode)) & Cmode) != 0) {
      fprintf(op_file, "    if (request != 0 && request != %ld)\n",
	      version_num);
      fprintf(op_file,
	      "         rpc_p_buf->m_status = RPC_S_UNSUPPORTED_VERSION;\n");
      fprintf(op_file, "    else {\n");
    } else {
      fprintf(op_file, "    IF (request<>0) AND (request<>%ld)\n",
	      version_num);
      fprintf(op_file, "    THEN m_status := RPC_S_UNSUPPORTED_VERSION\n");
      fprintf(op_file, "    ELSE begin\n");
    }
  }
  fprintf(op_file, "     upk_short(rpc_p_buf, request);\n");

  if (((1L << ((long)omode)) & Cmode) != 0) {
    fprintf(op_file, "     switch (request)\n");
    fprintf(op_file, "     {   ");
  } else {
    fprintf(op_file, "     IF (request = 0) OR (request > %ld) THEN\n",
	    proc_num);
    fprintf(op_file, "         m_status := RPC_S_BAD_PROCEDURE_NUMBER\n");
    fprintf(op_file, "     ELSE CASE request OF\n");
    fprintf(op_file, "        ");
  }

  LINK->scan = blockptr;
  proc_num = 1;
  while (LINK->scan != NULL) {
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(op_file, "case ");
    fprintf(op_file, "%2ld : r_", proc_num);
    write_name(&op_file, &LINK->scan->name);
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(op_file, "()");
    fprintf(op_file, ";\n");
    proc_num++;
    LINK->scan = LINK->scan->next;
    if (((1L << ((long)omode)) & Cmode) != 0)
      fprintf(op_file, "                  break;\n");
    fprintf(op_file, "        ");
  }

  if (((1L << ((long)omode)) & Cmode) != 0) {
    fprintf(op_file,
	    "default : rpc_p_buf->m_status = RPC_S_BAD_PROCEDURE_NUMBER;\n");
    fprintf(op_file, "        }\n");
    if (version_num != 0)   /* switch */
      fprintf(op_file, "     }\n");
    fprintf(op_file, "    }\n");   /* if else */
  } else {
    fprintf(op_file, "END {case};\n");
    if (version_num != 0)
      fprintf(op_file, "    END {if};\n");
    fprintf(op_file, "  END {with};\n");
    fprintf(op_file, "END;\n");
  }
  putc('\n', op_file);
}  /*GEN_JUMP_PROC*/


/*       Generate Code to Attach stub to RPCRTS
         --------------------------------------
 */

Local Void gen_attach_(LINK)
struct LOC_server_generator *LINK;
{
  if (((1L << ((long)omode)) &
       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0) {
    if (runoptions[(long)noautoinit - (long)ccerncross].value)
      fprintf(op_file, "[GLOBAL]\n");
    else
      fprintf(op_file, "[GLOBAL, INITIALIZE]\n");
  }

  writok(&op_file, proctok);
  fprintf(op_file, "attach_");
  write_name(&op_file, &unitname);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "()\n");
  else
    fprintf(op_file, ";\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "{   rpc_status      status;\n\n");
  else {
    fprintf(op_file, "VAR\n");
    fprintf(op_file, "    status  : rpc_status;\n");
    fprintf(op_file, "    service : rpc_name;\n");
    fprintf(op_file, "BEGIN\n");
    fprintf(op_file, "    service := ");
    write_name_padded(&op_file, unitname, '\'');
    fprintf(op_file, ";\n");
  }

  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");

  /* For PCTurbo and MacTurbo use the @ operator to pass the stub pointer. */

  if (((1L << ((long)omode)) &
       ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0)
    fprintf(op_file, "c_attach_stub(status, @r_");
  else
    fprintf(op_file, "c_attach_stub(status, r_");

  write_name(&op_file, &unitname);
  fprintf(op_file, ", ");
  if (((1L << ((long)omode)) & Cmode) != 0) {
    fprintf(op_file, "\n        ");
    write_name_padded(&op_file, unitname, '"');
  } else
    fprintf(op_file, "service");
  fprintf(op_file, ", p_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ");\n");

  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");
  fprintf(op_file, "c_report_error(status);\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "    }\n");
  else
    fprintf(op_file, "END;\n");
}  /*GEN_ATTACH*/


/*       Generate Code to Detach stub from RPCRTS
         ----------------------------------------
 */

Local Void gen_detach_(LINK)
struct LOC_server_generator *LINK;
/* p2c: ../rpcc.p, line 8033: Note: Line breaker spent 0.0+2.66 seconds, 23 tries on line 9368 */
{
  if (((1L << ((long)omode)) &
       ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)))) != 0)
    fprintf(op_file, "[GLOBAL]\n");

  writok(&op_file, proctok);
  fprintf(op_file, "detach_");
  write_name(&op_file, &unitname);
  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "()\n");
  else
    fprintf(op_file, ";\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "{\n");
  else
    fprintf(op_file, "BEGIN\n");

  fprintf(op_file, "    ");
  if (((1L << ((long)omode)) & Cmode) == 0)
    fprintf(op_file, "rp");

  fprintf(op_file, "c_detach_stub(p_");
  write_name(&op_file, &unitname);
  fprintf(op_file, ");\n");

  if (((1L << ((long)omode)) & Cmode) != 0)
    fprintf(op_file, "    }\n");
  else
    fprintf(op_file, "END;\n");

}  /*gen_detach*/



/******************************************************************************

        S E R V E R     C O D E         G E N E R A T O R
        *************************************************

The server stub is produced according to

*/
Static Void server_generator(server_mode, ser_name)
output_mode server_mode;
astring ser_name;
{
  struct LOC_server_generator V;


  /*       MAIN BLOCK:     GENERATE SERVER FILE
           ==========      ====================
   */


  if (!file_open(&op_file, &ser_name, rewriting)) {
    error(cant_opn_server);
    return;
  }

  omode = server_mode;
  client = false;

  if ((long)omode == (long)pils)
    server_generator_pils();
  else if ((long)omode == (long)vaxfor)
    server_gen_for();
  else {
    /** Generate module name and type, var, procedure inclusion **/
    if (((1L << ((long)omode)) & (1 << ((long)monolith))) == 0)
      gen_module(&op_file);

    /*       Special INTERFACE part for PCTurbo and MacTurbo:
    */

    if (((1L << ((long)omode)) &
	 ((1L << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0) {
      fprintf(op_file, "PROCEDURE attach_");
      write_name(&op_file, &unitname);
      fprintf(op_file, ";\n");

      /* For PCTurbo we must declare the main server procedure in the
         INTERFACE part in order to force generation of FAR model code.
         This is necessary because it will be called FAR by
         Call_Local_Stub.
       */

      if ((long)omode == (long)pcturbo) {
	fprintf(op_file, "PROCEDURE r_");
	write_name(&op_file, &unitname);
	fprintf(op_file, "(VAR rpc_p_buf : rpc_message_pointer);\n");
      }

      fprintf(op_file, "\nIMPLEMENTATION\n\n");
    }

    /* For MacTurbo and PCTurbo the global procedure
       headings must appear in the interface part.
     */

    /* Declare the attach procedure. */


    /** Generate the jump table for the server **/
    gen_jump_proc(&V);

    /** Generate the attach procedure **/
    if (((1L << ((long)omode)) & (1 << ((long)m6809))) == 0)
      gen_attach_(&V);
    /** this can't handle procedure parameters **/

    /** Generate end of module **/
    if (((1L << ((long)omode)) & ((1L << ((long)vaxvms)) | (1 << ((long)vaxpas)) |
	   (1 << ((long)pcturbo)) | (1 << ((long)macturbo)))) != 0)
/* p2c: ../rpcc.p, line 8033: Note: Line breaker spent 2.0+1.30 seconds, 699 tries on line 9483 */
      fprintf(op_file, "END .\n");
    else if ((long)omode == (long)m6809)
      fprintf(op_file, "MODEND .\n");
    else if ((long)omode == (long)cerncross)
      fprintf(op_file, ".\n");

  }
  if (!file_close(&op_file))
    error(cant_cls_server);


  /*if not pils or vaxfor*/
}  /*SERVER_GENERATOR*/



/*               Main Program
                 ------------
 */
main(argc, argv)
int argc;
Char *argv[];
{  /*MAIN*/
  PASCAL_MAIN(argc, argv);
  op_file = NULL;
  inp_file = NULL;
  init_global();   /** Global initialization **/
  get_parameters();   /** Get command line parameters **/
  parser();   /** Parse input **/

  if (!file_close(&inp_file))   /** Close input file **/
    error(cant_cls_input);

  if (!runoptions[(long)version - (long)ccerncross].value)
  {   /** Generate stub version number **/
    version_num = checksum + 1000;
    printf("RPCC: generated stub version number is %ld.\n", version_num);
  }

  if (runoptions[(long)dtree - (long)ccerncross].value)
  {   /** Debugging : print trees **/
    print_tab_types();
    print_tab_blocks();
  } else if (!(ser_spec || cli_spec))
    printf("RPCC: no stubs specified - no code generated, hope that's okay.\n");

  if (errorfound > 0) {  /** Exit gracefully on error **/
    printf("RPCC: %3ld errors found, no code generated.\n", errorfound);
    _Escape(0);
  }

  /*       Generate client stubs and .ext files */

  if (cli_spec) {
    client_generator(cli_mode, cli_name);
    ext_generator(cli_mode, ext_name);
  }

  /*       Generate server stubs */

  if (ser_spec)
    server_generator(ser_mode, ser_name);

  if (inp_file != NULL)
    fclose(inp_file);
  if (op_file != NULL)
    fclose(op_file);
  exit(0);
}  /*MAIN*/



/* End. */
