{*******************************************************************
*               Top-down RPC compiler - Main program
*


        28 May 1986     Written Antonio Pastore CERN/DD
        27 Jun 86       Last update by Antonio
         2 Nov 86       One output file used at a time. New options.
                        Explicitly ask for each stub module.
        30 Jan 87       .ext file produced with CLIENT stub, not server.
        10 Aug 87       Use globals ser_mode & cli_mode - Nici.
         1 May 88       Directives under MSDOS conditional for Turbo version
           Nov 88       PILS and FORTRAN generation added

Include options for the environment in which the compiler will run:

        VAXVMS          VMS operting system
        UNIXBSD         Berkley Unix 4.2 or 4.3, or DEc Ultrix
        MSDOS           Microsoft pascal compiler or Turbo pascal
        PCTURBO         Turbo pascal (use with MSDOS option)

**********************************************************************
*               SOME TECHNICAL NOTES                            - AP
**********************************************************************
 This compiler is organized in two parts:

        1) the PARSER
        2) the OUTPUT GENERATOR

    The PARSER checks the input for SYNTACTICAL and LEXICAL errors and
 produces as output two trees, the TYPEs and BLOCKs trees.

    The TYPEs tree (pointed by TYPEPTR) is a linked list of record each
 describing a defined type. To each of these records is associated a 'NAME',
 as defined by USER, and a sub-tree describing the structure of this type.

    The BLOCKs tree (pointed by BLOCKPTR) is a linked list of record each
 describing a block, that is a PROCEDURE or FUNCTION. Each BLOCK owns a
 NAME, (as given by the user), and a list of PARAMETERS, pointed by '.LIST'.
 Each record of this list has a NAME, the parameter's name (as given by
 the user), and a TYPE associated to it. This is a pointer, 'type', to a
 TYPE, so that the BLOCKs list points to the TYPEs list if BLOCKs have
 parameters. The same routine as used to build a TYPE definition is used to
 analize a parameter declaration inside a BLOCK.

    The OUTPUT GENERATOR reads the BLOCKs tree and produces as output two
 files, the CLIENT and the SERVER stubs. These are ASCII files containing
 procedures/functions that pack and unpack parameters and call
 the RPC Run-Time System.

    One output generator will produce Pascal or C stubs; there is also
 one to produce FORTRAN, and one for PILS.

**********************************************************************}

program rpc_compiler(input,output);


{* 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
}
const
        rpc_name_length = 40;   { Must tally with RPC$CONST! }

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

        NON_FRAGMENTATION_LIMIT = 1488; { RPC_BUFFER_SIZE-CALL_HEADER_LENGTH
                                          in the worst case }

        FRAGMENTATION_THRESHOLD = 150;  { Can break up types over this size }

        rpc_default_timeout = -1;   { Must agree with include files }

{ The following constant should be set to take parameters from the
 command line.
}
        COMMANDLINE = true;


type

        longstring = packed array[1..MAXSTRING] of char;
        char_name  = packed array [1..MAXIDLEN] of char;
        char3      = packed array [1..3] of char;
        opt_name   = packed array [1..10] of char;
        template_type
                   = packed array [1..template_length] of char;
        error_string
                   = packed array [1..error_length] of char;
        astring = record
                        str : packed array [1..MAXSTRING] of char;
                        len : integer;
                  end;
        pilstring = record
                        str : packed array [1..MAXSTRING] of char;
                        start, len : integer;
                    end;
        id_name = record
                        str : char_name;
                        len : integer;
                  end;

        expression = record
                        str : packed array[1..expression_length] of char;
                        len : integer;
                  end;

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

        token_descriptor = record
                                case kind : type_token of
                                ident : (name : id_name);
                                number: (value: integer);
                           end;
        courier_type = chartok .. substring;

        simple_type  = chartok .. longtok;

        block_type   = proctok .. functok;

        attr_type    = intok .. inoutok;

        ptr_defined_type= ^defined_type;
        ptr_named_type  = ^named_type;
        ptr_idlist      = ^id_list;
        ptr_block_table = ^block_table;

{   Describes:  an abstract data type }

        defined_type = record
            typ_name:       ptr_named_type;     { The name if any }
            typ_min_size:   integer;            { the minimum size in bytes }
            typ_max_size:   integer;            { The maximum size in bytes }
            typ_nesting:    integer;            { Number of indeces needed }
            typ_subtype:    ptr_defined_type;   { Subtype for complex types }
            typ_external:   boolean;            { External marshalling }
            case typ_basic_type: courier_type   { The type represented by this }
            of
                chartok, bytetok,
                 shortok, integertok,
                 real32tok, real48tok,
                 real64tok, real128tok,
                 longtok,
                 accesstok:    ();

                sequence,           { low is always 1 }
                 stringtok,         { low is always 1 }
                 substring,         { low is always 1 }
                arraytok: (         { low and high can vary }
                    typ_low,
                    typ_high:   integer);               { array bounds }
                recordtok: (
                    typ_fields: ptr_named_type);        { List of subtypes }
        end {defined_type};

{   Descibes:   a Named type
}
        named_type = record
                        nty_next:   ptr_named_type;
                        nty_name:   id_name;
                        nty_type:   ptr_defined_type;
                      end;

{   Describes:   one parameter of a procedure/function
}
        id_list = record
                        next : ptr_idlist;
                        name : id_name;
                        attr : attr_type;
                        id_type : ptr_defined_type;
                  end;

{   Describes:  one procedure or function
}
        block_table = record
                        next   : ptr_block_table;
                        name   : id_name;
                        b_type : block_type;
                        return : simple_type;
                        list   : ptr_idlist;
                        in_only:        boolean;        { no data returned }
                        blk_nesting:    integer;        { Number of indeces }
                        blk_min_in,
                        blk_max_in:     integer;        { Tot Parameter size }
                        blk_min_out,
                        blk_max_out:    integer;        { Tot Parameter size }
                        blk_timeout:    integer;        { Overall timeout }
                        blk_status_param: ptr_idlist;   { Status parameter }
                        blk_concurrent,                 { Concurrent execution}
                        blk_cast:       boolean;        { CAST(one way message)}
                     end;

{   Error Codes:
}
        {* WARNING!
        * Do not change the first and the last element of the following list!
        *}
        err_type = (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);

        set_of_token = set of type_token;

        open_mode =     (rewriting, resetting);

{ *** 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
}

        output_mode =   (cerncross, m6809, monolith,    { ** SEE Note: }
                        vaxvms, vaxpas, unixbsd, pcturbo,
                        macturbo, pils, vaxfor, genericc);

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

        rangeoptions = ccerncross .. invalid;

        {* 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.
}

var
        {* This variable is the HEAD pointer to the TYPE's list table *}
        typeptr : ptr_named_type;

        {* This variable is the HEAD pointer to the BLOCK's list table *}
        blockptr : ptr_block_table;

        unitname : id_name; {* Name of the unit under analysis *}

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

                        end;

        upkpck :    array[boolean] of packed array[1..3] of char; {'upk','pck'}

        simple_descriptor: array[simple_type] of ptr_defined_type;
                                { Reference definitions of simple types }


{ Variables set by parser:
}
        external_marshalling:       boolean;    { has been invoked }

        number_of_invented_types:       integer;   { Used by ensure_named_type }

        {* General flag for errors *}
        errorfound : integer;

        {* File variables *}
        inp_file : text;        {* Input file *}
        inp_name : astring;     {* Input file name *}
        inp_line : pilstring;   {* Last line read *}

        op_file:        text;   {* Output file for stub &c *}

        cli_name : astring;     {* Client file name *}
        ser_name : astring;     {* Server file name *}
        ext_name : astring;     {* External declaration file *}

{   Variables for use by Code generator:
}
        next_label: integer;    {* Next label value for use in FORTRAN *}
        size_so_far: integer;   {* Number of bytes packed/unpacked so far *}
        fragmentation_used: boolean; {* have we resorted to fragmentation? *}

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

        {* Debugging variables *}
        runoptions : array [rangeoptions] of record
                                name : opt_name;
                                value: boolean;
                        end;



{* 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

**********************************************************************}

procedure getoken; forward;
procedure backtoken; forward;

procedure error(which : err_type);
begin
write('ERROR: ');
errorfound := errorfound + 1;
if not(which in [ill_basic_type..unexp_eof]) then
        writeln(
'RPCC: Panic: compiler internal error, notify the compiler''s Administrator.')
else
case which of
ill_basic_type  : writeln('Illegal basic type.');
invalid_range   : writeln('Upper bound must be greater then lower.');
number_req      : writeln('Number requested.');
oftok_miss      : writeln('Keyword "of" missing.');
simtype_req     : writeln('Simple type requested.');
positive_req    : writeln('Index must be positive.');
ident_req       : writeln('Identifier requested.');
blocks_req      : writeln('At least a procedure/function declaration requested.');
bad_proc_decl   : writeln('Parameter must be simple or already declared in type section.');
twice_declared  : writeln('Identifier already declared.');
semicol_miss    : writeln('Semicolon ";" missing.');
semic_round_miss: writeln('Semicolon ";" or round bracket ")" missing.');
comma_miss      : writeln('Comma "," missing.');
var_attr_req    : writeln('"in","out" or "in out" required.');
colon_miss      : writeln('Colon ":" missing.');
dot_miss        : writeln('Dot "." missing.');
id_not_declared : writeln('Identifier not declared.');
clsround_miss   : writeln('Round bracket ")" missing.');
opnround_miss   : writeln('Round bracket "(" missing.');
package_miss    : writeln('Keyword "package" missing.');
record_miss     : writeln('Keyword "record" missing.');
return_miss     : writeln('Keyword "return" missing.');
istok_miss      : writeln('Keyword "is" missing.');
endtok_miss     : writeln('Keyword "end" missing.');
type_miss       : writeln('Keyword "type", "procedure" or "function" missing.');
char_ignored    : writeln('Illegal character:"',lastcar,'", ignored.');
toomany_dig     : writeln('Too many digits in this number.');
toomany_dim     : writeln('Too many dimensions in this array.');
ident_reserved  : writeln('Identifier reserved for compiler use.');
bad_name        : writeln('Identifier does not match already declared package name.');
proc_exp        : writeln('Keyword "procedure" or "function" expected.');
params_miss     : writeln('Parameters missing.');
input_miss      : writeln('Input file missing, can''t go on.');
bad_input_name  : writeln('Bad input file name: ".ext" extension reserved.');
cant_opn_input  : writeln('Can''t open input file.');
cant_opn_ext    : writeln('Can''t open ".ext" file.');
cant_opn_client : writeln('Can''t open client file.');
cant_opn_server : writeln('Can''t open server file.');
cant_cls_input  : writeln('Can''t close input file.');
cant_cls_client : writeln('Can''t close client file.');
cant_cls_server : writeln('Can''t close server file.');
cant_cls_ext    : writeln('Can''t close ".ext" file.');
internal_error  : writeln('Sorry - Unexpected internal condition in compiler.');
unexp_eof       : writeln('Unexpected end of input file.');
end; {End_CASE}
end; {ERROR}

{       Write a token name
        ------------------
}
procedure write_token(what: type_token);
begin
    if not(what in[chartok..nultok]) then
        write('(Unknown token!)')
    else
    case what of
        chartok :       write('RPC_CHAR');
        bytetok :       write('RPC_BYTE');
        shortok :       write('RPC_SHORT');
        integertok:     write('RPC_INTEGER');
        real32tok:      write('RPC_REAL32');
        real48tok:      write('RPC_REAL48');
        real64tok:      write('RPC_REAL64');
        real128tok:     write('RPC_REAL128');
        longtok :       write('RPC_LONG');
        arraytok:       write('ARRAY');
        sequence:       write('SEQUENCE');
        stringtok:      write('STRING');
        substring:      write('SUBSTRING');
        package :       write('PACKAGE');
        semicolon:      write('SEMICOLON');
        typetok :       write('TYPE');
        endtok  :       write('END');
        colon   :       write('colon ":"');
        comma   :       write('comma ","');
        opnround:       write('"("');
        clsround:       write('")"');
        oftok   :       write('OF');
        intok   :       write('IN');
        outok   :       write('OUT');
        inoutok :       write('INOUT');
        istok   :       write('IS');
        return  :       write('RETURN');
        dot     :       write('"."');
        ident   :       write('identifier');
        number  :       write('number');
        proctok :       write('PROCEDURE');
        functok :       write('FUNCTION ');
        nultok  :       write('(Null Token!)');
    end;
end; {write_token}

{       Print last line read from declaration file
        ------------------------------------------
On entry:
    'lastindex' is the index of the last token read.
}
procedure print_last_line;
var
   a : integer;
begin
        write('INPUT:');
        for a := 1 to inp_line.len do
                write(inp_line.str[a]);
        writeln;
        for a := 1 to lastindex+4 do
                write('-');
        write('^');
        writeln;
end;

procedure linerror(which : err_type);
begin
    writeln('RPCC: Error found on line ',lineread:3,':');
    print_last_line;
    error(which);
    writeln;
end;

procedure find_tok(kind : set_of_token);
begin
{*    writeln('RPCC: Skipping ...');        *}
    while not(token.kind in kind) do
        getoken;
{*
    print_last_line;
    writeln('RPCC: Restarting analysis here.');
    writeln;
*}
end;

procedure errfind(which : err_type; kind : set_of_token);
begin
    linerror(which);
    find_tok(kind);
end;

procedure abort_pgm(which : err_type);
begin
    error(which);
    writeln('Fatal error, program aborted.');
    halt;
end;

{* 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.
*
**********************************************************************}

procedure debug_print_name(var where: text; name: id_name);
var i:  integer;
begin
  with name do
    for i := 1 to len do write(where, str[i]);
end;

procedure printok(what: type_token);
begin
    if not(what in[chartok..nultok]) then
        write('?????? (bad type token) ???')
    else
    case what of
        chartok :       write('RPC_CHAR');
        bytetok :       write('RPC_BYTE');
        shortok :       write('RPC_SHORT');
        integertok:     write('RPC_INTEGER');
        real32tok:      write('RPC_REAL32');
        real48tok:      write('RPC_REAL48');
        real64tok:      write('RPC_REAL64');
        real128tok:     write('RPC_REAL128');
        longtok :       write('RPC_LONG');
        arraytok:       write('ARRAY');
        sequence:       write('SEQUENCE');
        stringtok:      write('STRING');
        substring:      write('SUBSTRING');
        package :       write('PACKAGE');
        semicolon:      write('SEMICOLON');
        typetok :       write('TYPE');
        endtok  :       write('END');
        colon   :       write('COLON');
        comma   :       write('COMMA');
        opnround:       write('OPNROUND');
        clsround:       write('CLSROUND');
        oftok   :       write('OF');
        intok   :       write('IN     ');
        outok   :       write('OUT    ');
        inoutok :       write('IN OUT ');
        istok   :       write('IS');
        return  :       write('RETURN');
        dot     :       write('DOT');
        ident   :       write('IDENT');
        number  :       write('NUMBER');
        proctok :       write('PROCEDURE');
        functok :       write('FUNCTION ');
        nultok  :       write('NULTOKEN');
    end;
end; {PRINT}
{_____________________________________________________________________________

                Print out a type definition

Prints out whole lines.
}
{   indenting function }

function indent(level: integer): integer;
begin
    indent := level*4 + 16;
end;

procedure print_def_type(ptr: ptr_defined_type; level: integer);
var
    a : integer;
    scan:   ptr_named_type;
begin
    if ptr = NIL then write('???? NIL pointer ????')
    else if not(ptr^.typ_basic_type in[chartok..substring]) then
        write('???? Bad basic type ????')
    else with ptr^ do
    if ((level>1) or (typ_basic_type in [chartok..longtok]))
        and (typ_name <> NIL) then begin
        write(' ':indent(level));           { Use predefined name if possible }
        debug_print_name(output, typ_name^.nty_name);
        writeln(';');
    end else case typ_basic_type of
        chartok,
        bytetok,
        shortok,
        integertok,
        real32tok,
        real48tok,
        real64tok,
        real128tok,
        longtok:    begin
                        write(' ':indent(level));
                        printok(typ_basic_type);
                        writeln('; -- ??? unnamed basic type ???');
                    end;

        stringtok:  writeln(' ':indent(level), 'STRING (',typ_high:1,');');

        arraytok:   begin
                        writeln(' ':indent(level), 'ARRAY (', typ_low:1,
                                    '..',typ_high:1,') OF');
                        print_def_type(typ_subtype, level+1);
                    end;

        accesstok:  begin
                        writeln(' ':indent(level), 'ACCESS');
                        print_def_type(typ_subtype, level+1);
                    end;
        recordtok:  begin
                        writeln(' ':indent(level), 'RECORD');
                        scan := typ_fields;
                        while scan<> NIL do with scan^ do begin
                            write(' ':indent(level+1));
                            debug_print_name(output, nty_name);
                            writeln(': ');
                            print_def_type(nty_type, level+2);
                            scan := scan^.nty_next;
                        end {while};
                        writeln(' ':indent(level), 'END RECORD;');
                    end;

        sequence:   begin
                        writeln(' ':indent(level), 'SEQUENCE (',typ_high:1,
                                    ') OF ');
                        print_def_type(typ_subtype, level+1);
                    end;

        substring:  writeln(' ':indent(level), 'SUBSTRING (',typ_high:1,');');

    end; {end_case}
end; {PRINT_DEF_TYPE}

procedure print_tab_types;
{***
* This procedure prints on standard output the tree of the type's declaration.
***}
var
        scan : ptr_named_type;
        a : options;

begin
    writeln;
    writeln('--     Compiler options requested:');
    writeln;
    for a := ccerncross to invalid do
        if runoptions[a].value then
                writeln('-- Option ',runoptions[a].name,' is set.');
    writeln;

    writeln;
    writeln('--     Tree of types (alphabetical order)');
    writeln;
    scan := typeptr;
    while scan <> nil do begin
        write('TYPE ');
        debug_print_name(output,scan^.nty_name);
        writeln(output, ' IS ');
        print_def_type(scan^.nty_type, 1);
        with scan^.nty_type^ do
          if typ_max_size=typ_min_size
            then writeln(' -- Representation: ', typ_max_size:1, ' bytes.')
            else writeln(' -- Representation: ',
                        typ_min_size:1, ' bytes minimum, ',
                        typ_max_size:1, ' bytes maximum.');
        writeln;
        scan := scan^.nty_next;
    end; {end_while}
end; {PRINT_TAB_TYPES}

procedure print_tab_blocks;
{***
* This procedure prints on standard output the tree of the block's declaration.
***}
var
        scan : ptr_block_table;

procedure print_list(ptr: ptr_idlist);
begin
writeln('with parameters:');
repeat
        write('    ',ptr^.name.str,' : ');
        printok(ptr^.attr);
        if ptr^.id_type^.typ_name <> nil then
                write(ptr^.id_type^.typ_name^.nty_name.str)
        else
                print_def_type(ptr^.id_type, 1);
        writeln;
        ptr := ptr^.next;
until ptr = nil;
write('(end of parameters)');
end;

begin {PRINT_TAB_BLOCKS}
    writeln;
    writeln('################## TREE OF BLOCKS #######################');
    writeln;
    writeln('PACKAGE ',unitname.str, ' IS');
    scan := blockptr;
    while scan <> nil do begin
        writeln;
        printok(scan^.b_type);
        write(' ',scan^.name.str);
        if scan^.list <> nil then
                print_list(scan^.list);
        if scan^.b_type = functok then begin
                write(' RETURN ');
                printok(scan^.return);
        end;
        writeln;
        writeln('--  Minimum ', scan^.blk_min_in:1, ' bytes in, ',
                                scan^.blk_min_out:1,  ' out.');
        writeln('--  Maximum ', scan^.blk_max_in:1, ' bytes in, ',
                                scan^.blk_max_out:1,  ' out.');
        writeln('-- _______________________________________________________');
        scan := scan^.next;
    end; {end_while}
    writeln('END ',unitname.str, ';');
    writeln;
end;

procedure print_token;
begin
write('     Token read: ');
if token.kind = ident then
        write('IDENT:"',token.name.str,'"')
else
        if token.kind = number then
                write('NUMBER: ',token.value)
        else
                printok(token.kind);
writeln;
end; {PRINT_TOKEN}


{* 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)

**********************************************************************}

procedure getoken_init;

procedure put_keyword(name: char_name; tok: type_token);
begin
        maxkeyword := maxkeyword + 1;
        keyword[maxkeyword].name    := name;
        keyword[maxkeyword].symbol  := tok;
end;

begin {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);

        upkpck[false] := 'upk';     { Part of output of code generator }
        upkpck[true]  := 'pck';
end;

procedure inp_options;
var     opt: options;
begin
        for opt := ccerncross to invalid do
                runoptions[opt].value:= false;

        runoptions[cmonolith].name      := 'cmonolith ';
        runoptions[ccerncross].name     := 'ccerncross';
        runoptions[cm6809].name         := 'cm6809    ';
        runoptions[cvaxvms].name        := 'cvaxvms   ';
        runoptions[cvaxpas].name        := 'cvaxpas   ';
        runoptions[cunixbsd].name       := 'cunixbsd  ';
        runoptions[cpcturbo].name       := 'cpcturbo  ';
        runoptions[cmacturbo].name      := 'cmacturbo ';
        runoptions[cpils].name          := 'cpils     ';
        runoptions[cvaxfor].name        := 'cfortran  ';
        runoptions[cgenericc].name      := 'cgenericc ';
        runoptions[smonolith].name      := 'smonolith ';
        runoptions[scerncross].name     := 'scerncross';
        runoptions[sm6809].name         := 'sm6809    ';
        runoptions[svaxvms].name        := 'svaxvms   ';
        runoptions[svaxpas].name        := 'svaxpas   ';
        runoptions[sunixbsd].name       := 'sunixbsd  ';
        runoptions[spcturbo].name       := 'spcturbo  ';
        runoptions[smacturbo].name      := 'smacturbo ';
        runoptions[spils].name          := 'spils     ';
        runoptions[svaxfor].name        := 'sfortran  ';
        runoptions[sgenericc].name      := 'sgenericc ';
        runoptions[dlex].name           := 'dlex      ';
        runoptions[dlexhot].name        := 'dlexhot   ';
        runoptions[dtree].name          := 'dtree     ';
        runoptions[shortint].name       := 'shortint  ';
        runoptions[stdescr].name        := 'stdescr   ';
        runoptions[concurrent].name     := 'concurrent';
        runoptions[noautoinit].name     := 'noautoinit';
        runoptions[byvalue].name        := 'byvalue   ';
        runoptions[timeout].name        := 'timeout   ';
        runoptions[version].name        := 'version   ';
        runoptions[types].name          := 'types     ';

        Cmode := [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;
end;

procedure pointers_init;
begin
        typeptr  := nil;
        blockptr := nil;
end;

procedure init_global;
begin
        getoken_init;
        inp_options;
        pointers_init;
        errorfound := 0;
end;


{* 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
}


procedure get_argc(var count: integer);
begin
        count := argc - 1; {* Predefined identifier *}
end;

procedure get_argv(what: integer; var towhere: longstring; var len : integer);
var
        loop : boolean;
begin
        argv(what, towhere);
        {*
        * Remember:
        * command line parameters are truncated or padded with blanks!!
        *}
        len := 0;
        loop := true;
        while (loop) and  (len <= MAXSTRING) do
                if towhere[len+1] <> ' ' then
                        len := len + 1
                else
                        loop := false;
end;

function file_open(var  file_des: text;
                   var  name: astring;
                        mode: open_mode) : boolean;
{**
* Try to open a file with 'name' name, returns true if succesful,
* false otherwise.
**}
var
        a : integer;
        str : longstring;
begin
        for a := 1 to name.len do
                str[a] := name.str[a];

        a := name.len;                                          { 80320 }
        if a < MAXSTRING then
                a := a + 1;
        str[a] := chr(0);

        if mode = rewriting then
                rewrite(file_des, str)
        else
                reset(file_des, str);
        file_open := true;
end;

function file_close(var file_des : text): boolean;
begin
        flush(file_des);
        file_close := true;
end;



{       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.

}
procedure analize(var arg: longstring; len: integer; interactive: boolean);

const

        MAGIC1 = '-';   { ugly! This disallows magic charcter '-' for }

        MAGIC2 = '-';

var
        loc_arg :       opt_name;
        a, i :          integer;
        found :         boolean;
        scan :          options;
        present:        boolean;        { Parameter present }

begin {ANALIZE}

{ 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 (arg[1] = MAGIC1) or (arg[1] = MAGIC2) or (interactive)
    then begin {* Option *}
        loc_arg := '          ';
        a := 1;
        present := false;
        while (a <= 11) and (a < len) and not present do begin
            if arg[a+1] = '=' then present := true
            else if a<=10 then begin
                if arg[a+1] in['A'..'Z'] then
                        loc_arg[a] := chr(ord('a') + ord(arg[a+1]) - ord('A'))
                else
                        loc_arg[a] := arg[a+1];
            end;
            a := a + 1;
        end;

        {* Find options *}
        scan := ccerncross;
        found := false;
        {* if present then a := a + 1;   skip over "="    out 90926 *}
        repeat
            if loc_arg = runoptions[scan].name then
            begin
                found := true;
                if ord(scan) < NUMOMODES then
                begin            {client specification}
                    if cli_spec then
                    begin
                        write('RPCC: ');
                        for a := 1 to len do write(arg[a]);
                        writeln(': client already specified - option ignored.')
                    end
                    else begin
                        cli_spec := true;
                        for i := 1 to ord(scan) do cli_mode := succ(cli_mode);
                        if present then
                        begin
                            cli_name.len := len - a;
                            for i := 1 to len - a do
                                cli_name.str[i] := arg[a+i]
                        end
                    end
                end
                else if ord(scan) < 2*NUMOMODES then
                begin                 {server specification}
                    if ser_spec then
                    begin
                        write('RPCC: ');
                        for a := 1 to len do write(arg[a]);
                        writeln(': server already specified - option ignored.')
                    end
                    else begin
                        ser_spec := true;
                        for i := 1 to ord(scan) - NUMOMODES do
                            ser_mode := succ(ser_mode);
                        if present then
                        begin
                            ser_name.len := len - a;
                            for i := 1 to len - a do
                                ser_name.str[i] := arg[a+i]
                        end
                    end
                end
                else begin      {a REAL option}
                    runoptions[scan].value := true;
                    if scan = timeout then
                    begin
                        if a >= len then
                        begin
                            writeln('RPCC: timeout value missing, default will be used.');
                            runoptions[timeout].value := false;
                        end
                        else begin
                            timeout_val := 0;
                            for i := 1 to len - a do
                                if arg[a+i] in ['0'..'9']
                                    then timeout_val := 10*timeout_val + ord(arg[a+i]) - ord('0')
                                    else begin
                                        write('RPCC timeout option: ');
                                        abort_pgm(number_req);
                                    end;
                             if timeout_val = 0 then writeln('RPCC: timeout is zero, hope that''s okay.');
                        end;
                    end
                    else if scan = version then
                    begin
                        if a >= len then
                        begin
                            writeln('RPCC: supplying missing version number.');
                            runoptions[version].value := false;
                        end
                        else begin
                            version_num := 0;
                            for i := 1 to len - a do
                                if arg[a+i] in ['0'..'9']
                                    then version_num := 10*version_num + ord(arg[a+i]) - ord('0')
                                    else begin
                                        write('RPCC version option: ');
                                        abort_pgm(number_req);
                                    end;
                             if version_num = 0 then writeln('RPCC: stub version check disabled.');
                        end;
                    end;
                end
            end else
                scan := succ(scan)
        until found or (scan = invalid);

        if scan = invalid then begin
                write('RPCC: ');
                for a := 1 to len do
                        write(arg[a]);
                        writeln(': unrecognized option, ignored.')
        end;

    end {* Options *} else begin {* File name *}

        inp_name.len := len;
        for a := 1 to len do
                inp_name.str[a] := arg[a];
    end;

end; {ANALIZE}

{   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.

}
procedure make_filename(var filename: astring;
                            prefix:     char3);

var i, rdp:     integer;    { read pointer }
    done:       boolean;
begin
    rdp := inp_name.len;    { point to last char }
    done := false;  { Find start of name - a horrible Pascal loop }
    repeat          { Oh, to be programming in C at this point! }
        if (rdp>=1)
        then begin
            if (inp_name.str[rdp] in ['.', '0'..'9', 'A'..'Z', '_', 'a'..'z'])
            then rdp:=rdp-1
            else done := true;
        end else
            done := true;
    until done;

    { rdp is the number of characters of directory etc preceding the filename}

    filename.len := 0;
    for i := 1 to rdp do begin
        filename.len := filename.len + 1;
        filename.str[filename.len] := inp_name.str[i];
    end;

    for i := 1 to 3 do begin
        filename.len := filename.len + 1;
        filename.str[filename.len] := prefix[i];
    end;

    for i := rdp+1 to inp_name.len do begin
        filename.len := filename.len + 1;
        filename.str[filename.len] := inp_name.str[i];
    end;

end;


procedure 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')
******}
var
        a, b, count, p_argc, p_len : integer;
        p_argv : longstring;
        ext : packed array[1..3] of char;       { TBL 14-8-86 }

begin {GET_PARAMETERS}
inp_name.len := 0;

if COMMANDLINE then begin
        count := 1;
        get_argc(p_argc);
        while count <= p_argc do begin
                get_argv(count, p_argv, p_len);
                count := count + 1;
                {* Analize option *}
                analize(p_argv, p_len, false);
        end; {end_while}
end else begin
        {* Get file name *}
        write('Input file name: ');
        with inp_name do begin
        len := 0;
        while not(eoln(input))  and (len <= MAXSTRING) do begin
                len := len + 1;
                read(str[len]);
        end;
        {* Skip end of line *}
        readln;
        end;
        {* Get options *}
        repeat
                write('Debugging options: ');
                count := 1;
                while not(eoln(input)) and (count < MAXSTRING) do begin
                        count := count + 1;
                        read(p_argv[count]);
                end;
                readln;
                {* Analize option *}
                if count > 1 then
                        analize(p_argv, count, true);
        until count = 1;
end;

if inp_name.len = 0 then begin
        writeln('RPCC: usage: source_file [options]');
        abort_pgm(input_miss);
end;

{* Try to open input file *}
if not(file_open(inp_file, inp_name, resetting)) then
        abort_pgm(cant_opn_input);

{* Build client, server and external default file names *}

if cli_name.len = 0 then make_filename(cli_name, 'cli');

if ser_name.len = 0 then make_filename(ser_name, 'ser');

{   Make the external declaration file name:

    Th extension is changed to '.ext'
}
    b := inp_name.len;
    while (b>=1)
    and {then} (inp_name.str[b] in ['A'..'Z', 'a'..'z'])
        do b := b-1;
    if b=0 then b:= inp_name.len;   { No '.' found }
    if inp_name.str[b]<> '.' then b:= inp_name.len; { Found directory }

    for a := 1 to b  do begin
        if a <= MAXSTRING - 3 then
                ext_name.str[a] := inp_name.str[a];
    end;

    if (b <= inp_name.len - 3) then begin       { extension was specified }
        ext[1] := inp_name.str[b+1];
        ext[2] := inp_name.str[b+2];
        ext[3] := inp_name.str[b+3];
        if (ext = 'ext') or (ext = 'EXT') then
                abort_pgm(bad_input_name);
    end else begin
        b := b+1;                                { Add a '.' if it wasn't }
        ext_name.str[b] := '.';
    end{if};

    ext_name.str[b + 1] := 'e';
    ext_name.str[b + 2] := 'x';
    ext_name.str[b + 3] := 't';
    ext_name.len := b + 3;
end; {GET_PARAMETERS}

{* 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}

procedure getoken;
var
        i, j, k, sign : integer;

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

function AP_getchar : char;     {* renamed - Nici, 26 Aug 87 *}
const
        TAB = 9; {* ASCII TAB character *}
var
        a : integer;
        localcar : char;

begin {AP_GETCHAR}
if char_ready then begin
        AP_getchar := oldchar;
        char_ready := false;
end else begin

        with inp_line do begin

        while (start > len) or (len = 0) do begin
                len := 0;
                start := 1;
                lastindex := 1;
                if eof(inp_file) then
                        abort_pgm(unexp_eof)
                else begin
                        while not(eoln(inp_file)) do begin
                                len := len + 1;
                                read(inp_file,str[len]);
                                if ord(str[len]) = TAB then
                                        str[len] := ' ' {* Convert TAB to space *}
                                else
                                        if ord(str[len]) < 32 then
                                                len := len - 1;
                        end;
                        len := len + 1;
                        str[len] := ' ';
                        readln(inp_file); {* Skip END_OF_LINE *}
                        lineread := lineread + 1; {* Line counter *}
                        if runoptions[dlex].value then begin
                                write('LINE READ: ');
                                for a := 1 to len do
                                        write(str[a]);
                                writeln;
                        end;
                end;
        end;

        localcar := str[start];
        start := start + 1;

        end; {END_WITH}

        {* Make it lower *}
        if localcar in ['A'..'Z'] then
                localcar := chr(ord('a') + ord(localcar) - ord('A'));
        AP_getchar := localcar;

        {* Skip comment if any *}
        if (localcar = '-') and not(incomment) then begin
                incomment := true;
                oldchar := AP_getchar;
                incomment := false;
                if oldchar = '-' then begin
                        inp_line.len := 0; {* Force the reading of a new line *}
                        AP_getchar := ' '; {* Return space *}
                end else begin
                        AP_getchar := localcar;
                        char_ready := true;
                end;
        end;
end; {END_ELSE char_ready}
end; {AP_GETCHAR}


function getchar : char;              {* 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.  *}

    var ch : char;

    begin
        if ch_there <> ' ' then
        begin
            ch := ch_there;
            ch_there := ' ';
        end
        else begin
            ch := AP_getchar;
            if ch = ' ' then
            begin
                if not eof(inp_file) then
                        repeat ch := AP_getchar until ch <> ' ';
                if not ((ch in [':', '(', ')', ',', ';']) or is_blank) then
                begin
                    ch_there := ch;
                    ch := ' ';
                end;
            end;
        end;
        is_blank := ch in [' ', ':', '(', ')', ',', ';'];
        checksum := (3*checksum + ord(ch) - ord(' ')) mod 8999;
        if runoptions[dlexhot].value then
            if ch = ' ' then writeln(ch)
                        else write(ch);
        getchar := ch;
    end;
{
_____________________________________________________________________________
}
begin {GETOKEN}
    if tok_present then begin
        token := lastoken;
        tok_present := false;
    end else begin
        with token do begin

        repeat  {* Find a valid token *}

            if lastcar = ' ' then lastcar := getchar;       {* Skip blank *}
            lastindex := inp_line.start;       {* To print error messages *}

{* Check if identifier or keyword *}
            if lastcar in ['a'..'z', '_'] then begin
        {* Suppose to be an identifier or keyword *}
                kind := ident;
                name.len := 0;
                repeat
                    if name.len < MAXIDLEN then begin   { was <= 81116 TBL }
                        name.len := name.len + 1;
                        name.str[name.len] := lastcar;
                    end;
                    lastcar := getchar;
                until not(lastcar in['a'..'z','_','0'..'9']);
        {* Fill with blanks *}
                for i := name.len+1 to MAXIDLEN do
                    name.str[i] := ' ';

        {* Try to see if keyword *}
        {* The following is the famous binary search!!! *}
                i := 1; j := maxkeyword;
                repeat
                    k:= (i+j) div 2;
                    if name.str <= keyword[k].name then j:=k-1;
                    if name.str >= keyword[k].name then i:=k+1;
                until i>j;

                if i-1 > j then begin
                    kind := keyword[k].symbol;
                end else begin
             {* Check if illegal identifier, reserved for compiler use *}
                    with name do if
                    ((str[1]='r')and (str[2]='p')
                        and (str[3]='c') and (str[4]='_'))
                    or (name.str = 'b                        ')
                    or (name.str = 'header                   ')
                    or (name.str = 'ret                      ') then
                        linerror(ident_reserved);
                    kind := ident;
                end;
            end {identifier or keyword}

            else
{* Check if number *}
            if lastcar in ['0'..'9','-'] then begin
                kind := number;
                value := 0;
                if lastcar = '-' then begin
                    sign := -1;
                    lastcar := getchar;
                end else
                    sign := 1;
                repeat
                    if value < (MAXINT div 10) - (ord(lastcar) - ord('0')) then
                        value := value * 10 + ord(lastcar) - ord('0')
                    else begin
                        error(toomany_dig);
                        value := MAXINT;
                    end;
                    lastcar := getchar;
                until not(lastcar in ['0'..'9']);
                value := value * sign;
            end {if number} else begin

{* Then should be one of these symbols! *}
                if not(lastcar in[':', ';', '=', ',', '(', ')', '.']) then begin
                    kind:=nultok;
                    error(char_ignored);        {* Ignore this character *}
                    end else begin
                        case lastcar of
        ':' : kind := colon;
        ';' : kind := semicolon;
        ',' : kind := comma;
        '(' : kind := opnround;
        ')' : kind := clsround;
        '.' : kind := dot;
                        end; {end case}
                    end; {if}
                    lastcar := getchar; {* Read next char *}
                end {if};

            until kind <> nultok;

        end; {END_WITH}
    end; {end_token already present}

        if runoptions[dlex].value then
            print_token;
end; {getoken}
{
_____________________________________________________________________________
}

procedure backtoken;
{***
* This procedure save the value of 'tok' and uses it when next 'getoken' is
* called.
****}
begin
    lastoken := token;
    tok_present := true;
end;


{* Parser *}
{ Top-down RPC compiler                                                PARSE.PAS

                 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)
        10 Oct 89       Bug fix: Looped on PRAGMA CAST(<undefined procedure>);



                    General useful routines
                    -----------------------


    Check for a given token, otherwise skip                             expected
    ---------------------------------------
}

function expected(what: type_token; skip_until: set_of_token): boolean;
begin
  getoken;
  if token.kind=what then expected := true
  else begin
    expected := false;
    write  ('RPCC: Error: Found ');
    write_token(token.kind);
    write  (' where ');
    write_token(what);
    writeln(' was expected on line ',lineread:1,':');
    print_last_line;
    writeln;
    find_tok(skip_until);
  end {if};
end;

{_______________________________________________________________________________

                Expression handling                                     append_1
                ===================

   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:
        -------------------------------------
}
procedure append_1(var expr: expression; ch: char);
begin
   with expr do begin
        len := len+1;
        str[len] := ch;
   end;
end;

{       Format an expression according to a template                      format
        --------------------------------------------

    The template is a 10-character character array which contains a
    dollar sign wherever the original value of the expression is to be
    put.
}
procedure format(   var final:      expression;
                        template:   template_type);
{
On entry,
    template must not be blank.
On exit,
    expression copied from template with original expression inserted
        in place of "$" signs.
}
var initial:    expression;
    e:          integer;    { effective end of template string}
    i, j:       integer;    { loop index }
begin
    initial := final;
    final.len := 0;
    e := template_length;
    while template[e] = ' ' do e:=e-1;      { strip spaces }
    for i := 1 to e do begin
        if template[i] = '$' then
            for j := 1 to initial.len do append_1(final, initial.str[j])
        else
            append_1(final, template[i]);
    end {for};
end {format};

{       Put one character on the front of an expression                prepend_1
        -----------------------------------------------
}
procedure prepend_1(var expr: expression; ch: char);
var     a:  integer;
begin
   with expr do begin
        for a := len downto 1 do str[a+1]:=str[a];
        str[1] := ch;
        len := len+1;
   end;
end;


{       Append an identifier to an expression                        append_name
        -------------------------------------
}
procedure append_name(var expr: expression; name: id_name);
var     a: integer;
begin
  with name do
    for a := 1 to len do append_1(expr, str[a]);
end;

{       Append an index to an array expression                      append_index
        --------------------------------------

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

    1 -> rpc_a, 2 -> rpc_b etc.
}
procedure append_index(var expr: expression; level: integer);
var ch: char;
begin
            format(expr, '$[rpc_    ');
            append_1(expr, chr(ord('a')+level-1));
            append_1(expr, ']');

end;

{       Append a decimal number to an expression                  append_decimal
        ----------------------------------------
}
procedure append_decimal(var expr: expression; x: integer);
var     t, y, weight:  integer;
begin
    if x<0 then begin
        append_1(expr,'-');
        t := -x
    end else t := x;

    weight := 1;                { these are array bounds }
    while weight*10 <= t do weight := weight*10;
                { weight is largest power of 10 not greater than t }
    while weight>0 do begin
        append_1(expr, chr(ord('0')+t div weight));
        t := t mod weight;
        weight := weight div 10;
    end {while};
end;

{       Find Type in List                                              find_type
        -----------------

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.

}
function find_type(         head:       ptr_named_type; { head of list}
                        var name:       id_name;
                        var father: ptr_named_type;
                        var son   : ptr_named_type): boolean;

var
        found, doexit : boolean;
begin
found := false;
son := head;                            {* Head of the list *}
father := son;
while (son <> nil) and not(found) do begin
        if son^.nty_name.str = name.str then
                found := true
        else begin
                father := son;
                son := son^.nty_next;
        end;
end;
find_type := found;
end;


{       Insert Type Identifier into list                       insert_named_type
        --------------------------------

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.
}
procedure insert_named_type(    ptr:    ptr_named_type;
                            var head:   ptr_named_type);

var     son,father:    ptr_named_type;
begin
        if find_type(head, ptr^.nty_name, father, son)
        then begin
           linerror(twice_declared);    {* Identifier already declared *}
        end else begin
                if head = nil then begin {* List empty *}
                        head := ptr;
                        ptr^.nty_next := nil;
                end else
                        if head = son then begin {* Insert ahead *}
                                head := ptr;
                                ptr^.nty_next := son;
                        end else begin
                                father^.nty_next := ptr;
                                ptr^.nty_next := son;
                        end;
        end;

end {insert_named_type};

{       Find Procedure or Function name                               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 set 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.

}
function find_block(    var name: id_name;
                        var father: ptr_block_table;
                        var son: ptr_block_table): boolean;
var
        found : boolean;
begin
    found := false;
    son := blockptr; {* Head of the list *}
    father := son;
    while (son <> nil) and not(found) do begin
        if son^.name.str = name.str then
                found := true
        else begin
                father := son;
                son := son^.next;
        end;
    end {while};
    find_block := found;
end;


{       Find parameter                                                find_param
        --------------
On exit,
    son             pointer to param if found, else NIL
    return value    TRUE if found else FALSE
}
function find_param(    var name:   id_name;
                            head:   ptr_idlist;
                        var son:    ptr_idlist): boolean;
var found: boolean;
begin
    son := head;
    found := false;
    while (son<>NIL) and not found do begin
        if son^.name.str = name.str
            then found := true
            else son := son^.next;
    end {while};
    find_param := found;
end;

{               TYPE DECLARATION ANALIZER
                =========================

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


        Ensure Type Named                                      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.
}
procedure ensure_type_named(pt: ptr_defined_type);

var i:          integer;        { String index }
    expr:       expression;     { for building up the variable name }
    pnt:        ptr_named_type; { Pointer to the new named type if any }

begin
    if pt <> NIL then with pt^ do
     if typ_name = NIL then begin
        new(pnt);
        with pnt^ do begin

            format(expr, 'rpc_stype_');
            append_decimal(expr, number_of_invented_types);
            number_of_invented_types := number_of_invented_types + 1;

            for i := 1 to expr.len do nty_name.str[i] := expr.str[i];
            nty_name.len := expr.len;
            nty_type := pt;                     { Link name to type }
            typ_name := pnt;                    { Link type to name }
            insert_named_type(pnt, typeptr);    { Put into the type list }

        end {with};
     end {if with if};
end;

{       Parse 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
 Error recovery:
    If error found we exit with the offending token in 'backtoken'.
}

function parse_type: ptr_defined_type;
var
      pt:                       ptr_defined_type;
      pnt:                      ptr_named_type;
      loc_err:                  boolean;
      father, son:              ptr_named_type;


{       Parse:   ( <positive integer> )                                 get_size
        -----

    Error recovery:
        If error found we suppose token forgotten so we 'backtoken'.
}
    procedure get_size(pt: ptr_defined_type);
    begin
        with pt^ do begin
            getoken;
            if token.kind <> opnround then
                    linerror(opnround_miss)
            else
                    getoken;
            typ_low := 1;                               { implied lower bound }
            if token.kind <> number then begin
                    linerror(number_req); {* Assume zero *}
                    typ_high := 0;
            end else begin
                    typ_high := token.value;
                    getoken;
            end;
            if token.kind <> clsround then begin
                    errfind(clsround_miss, [oftok, semicolon]);
                    backtoken;
            end;

            if typ_high < 0 then
                    linerror(positive_req);
        end {with};
    end; {GET_SIZE}

{       Parse Sub-array                                          parse_sub_array
        ---------------

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

 Sub-array is not really a good word for this - it's the tail 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.
}
    function parse_subarray: ptr_defined_type;
    var pt:     ptr_defined_type;
    begin
        new(pt);
        with pt^ do begin
            typ_name := NIL;
            typ_external := False;
            typ_subtype := NIL;         { Until filled in with good value }
            typ_basic_type := arraytok; { The type is "array" }
            getoken;

            if token.kind <> number then begin
                    linerror(number_req); {* Assume zero *}
                    typ_low := 0;
            end else begin
                    typ_low := token.value;
                    getoken;
            end;
            {* Skip double point *}
            if token.kind = dot then begin
                    getoken;
                    if token.kind <> dot then
                            linerror(dot_miss)
                    else
                            getoken;
            end else
                    linerror(dot_miss);

            if token.kind <> number then begin
                    linerror(number_req); {* Assume low + 1 *}
                    typ_high := typ_low + 1;
            end else begin
                    typ_high := token.value;
                    getoken;
            end;
            if typ_high <=      typ_low then
                    linerror(invalid_range);


            if token.kind = comma then begin
                typ_subtype := parse_subarray;          { , <subarray> }
            end else if token.kind = clsround then begin
                getoken;
                if token.kind = oftok then begin
                    getoken;
                    typ_subtype := parse_type;          { ) of <type> }
                    {** ensure_type_named(typ_subtype); *NO* *}
                end else begin
                    errfind(clsround_miss, [semicolon]);        { ) garbage }
                    backtoken;
                end {if};
            end else begin
                    errfind(clsround_miss, [oftok, semicolon]);
                    backtoken;
            end {if};

            if typ_subtype = NIL then begin
                dispose(pt);    { Not essential -could waste it }
                parse_subarray := NIL;
            end else begin
                typ_min_size := (typ_high-typ_low+1) * typ_subtype^.typ_min_size;
                typ_max_size := (typ_high-typ_low+1) * typ_subtype^.typ_max_size;
                typ_nesting := typ_subtype^.typ_nesting + 1;
                parse_subarray := pt;
            end {if};
        end {with};
    end; {parse_subarray}

{       Parse Type definition (main block)                            parse_type
        ---------------------                                         main block

                <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
}
begin {parse_type}
    if token.kind = ident then begin        { <id> }
        if find_type(typeptr, token.name, father, son)
        then parse_type := son^.nty_type
        else linerror(id_not_declared);

    end else if token.kind in[chartok..longtok] then begin { Simple types }
        parse_type := simple_descriptor[token.kind];

    end else if token.kind = arraytok then begin            { ARRAY ( <subarray> }
        getoken;
        if token.kind <> opnround then begin
            linerror(opnround_miss);
            backtoken;
            parse_type := NIL;
        end else
            parse_type := parse_subarray;

    end else if token.kind = accesstok then begin        { ACCESS <type> }
        new(pt);
        with pt^ do begin
            typ_basic_type := token.kind;
            typ_external := false;
            getoken;
            typ_subtype := parse_type;
            ensure_type_named(typ_subtype);
            if typ_subtype <> NIL then begin
                typ_nesting := typ_subtype^.typ_nesting;  { No extra index }
                typ_min_size := 4;  { <tbd> }
                typ_max_size := typ_subtype^.typ_max_size+4;  { <tbd> }
            end {if};
        end;
        parse_type := pt;

    end else if token.kind = recordtok then begin       { R E C O R D }

        new(pt);
        parse_type := pt;
        with pt^ do begin
          typ_basic_type := token.kind;
          typ_external := false;
          typ_subtype := NIL;       { subtype is meaningless }
          typ_fields := NIL;        { List of fields currently empty }
          typ_nesting := 0;                 { Unless we find nesting in a subtype }
          typ_min_size := 0;        { Initialise total }
          typ_max_size := 0;        { Initialise total }

          getoken;
          while token.kind = ident do begin

            new(pnt);           {* It's ok, create an element *}
            pnt^.nty_name := token.name;
            getoken;

            if token.kind <> colon      then linerror(colon_miss)   { : (or ignore)}
                                    else getoken;

            pnt^.nty_type := parse_type;        { Analyse a type declaration}

            if pnt^.nty_type <> NIL then begin  { Unless serious error, }
                if pnt^.nty_type^.typ_nesting> typ_nesting      { Find max. nesting }
                    then typ_nesting := pnt^.nty_type^.typ_nesting;
                typ_min_size := typ_min_size + pnt^.nty_type^.typ_min_size;
                typ_max_size := typ_max_size + pnt^.nty_type^.typ_max_size;
                insert_named_type(pnt, typ_fields);
                ensure_type_named(pnt^.nty_type); { Needed for FORTRAN? }
            end {if ok};

            getoken; { Read next token: ";" }

            if token.kind <> semicolon then begin
                    {* Error recovery: Skip tokens until a good token is found *}
                    errfind(semicol_miss, [semicolon, endtok]);
                    if token.kind = semicolon then {* Skip it *}
                            getoken;
            end else {* Semicolon found *}
                    getoken;

          end {while token.kind=ident};
        end {with};

        if token.kind <> endtok
            then errfind(endtok_miss, [endtok]);
        getoken;                                    { skip the END };

        if token.kind <> recordtok then begin
            linerror(record_miss);
            if token.kind = semicolon then backtoken; { Assume he forgot RECORD }
        end;

    end else if token.kind = sequence then begin    { SEQUENCE (...) OF <type>}
        new(pt);
        pt^.typ_basic_type := token.kind;
        parse_type := pt;
        get_size(pt);

        getoken;
        if token.kind <> oftok then
            linerror(oftok_miss) {* But ignore it *}
        else with pt^ do begin
            getoken;
            typ_external := false;
            typ_subtype := parse_type;
            {* ensure_type_named(typ_subtype); *NO* not needed *}
            typ_nesting := typ_subtype^.typ_nesting+1;
            typ_min_size := 2;
            typ_max_size := (typ_subtype^.typ_max_size*(typ_high-typ_low+1))+2;
        end {if};

 end else if token.kind in [stringtok,substring]    { Substring }
 then begin
        new(pt);
        parse_type := pt;
        with pt^ do begin
            typ_basic_type := token.kind;
            get_size(pt);
            typ_subtype := simple_descriptor[chartok];
            typ_external := false;
            if typ_basic_type = stringtok then begin
                typ_nesting := 2;           { Can be 2 or 1 needed actually. }
                typ_max_size := typ_high + 2;
                typ_min_size := 2;
            end else begin
                typ_nesting := 1;
                typ_max_size := typ_high + 4;
                typ_min_size := 4;
            end;
        end {with};

 end else begin
        linerror(ill_basic_type);
        loc_err := true;
        backtoken;
        parse_type := NIL;

 end {if};

end; {parse_type}


{       Parse PRAGMA clause                                         parse_pragma
        -------------------
Parses:

    <pragma clause> ::  PRAGMA TIMEOUT ( <block_id>, <time value> ) ;
                    |   PRAGMA CAST ( <block_id> , ... ) ;
                    |   PRAGMA CONCURRENT ( <block_id> , ... ) ;
                    |   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.
}
procedure parse_pragma;

var pragma_name:    id_name;            { Name of pragma being invoked }
    blk,                                { Pointer to block refered to }
    block_father:   ptr_block_table;    { dummy }
    nty,                                { Pointer to named type referred to }
    type_father:    ptr_named_type;     { dummy }
    i:              integer;            { Loop index }
    typ:            ptr_defined_type;   { New type if needed for external }
    param:          ptr_idlist;         { Pointer to relevant parameter }

begin
    if expected(ident, [semicolon])
    then begin
        pragma_name := token.name;
        if expected(opnround, [semicolon])
        then if expected(ident, [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.
}
        then if pragma_name.str='timeout                  ' then begin
            if find_block(token.name, block_father, blk)
            then if expected(comma, [semicolon])
            then if expected(number, [semicolon])
            then begin
                blk^.blk_timeout := token.value;
                if expected(clsround, [semicolon])
                then if expected(semicolon, [semicolon])
                then {fine - no more to do. }
            end;

{   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.
}
        end else if (pragma_name.str='concurrent               ')
                 or (pragma_name.str='cast                     ') then begin
            while token.kind=ident do begin
                if find_block(token.name, block_father, blk)
                then begin
                    if pragma_name.str[2]='o'
                        then blk^.blk_concurrent := true
                        else blk^.blk_cast := true;
                end else begin {not found}
                    writeln(
  'RPCC: PRAGMA CAST or CONCURRENT must refer to previously defined procedure');
                    linerror(id_not_declared);
                end {if};
                getoken;                    { Get the comma or clsround }
                if token.kind=comma
                then if expected(ident, [clsround, semicolon])
                then {loop};
            end {while};
            if token.kind = clsround
                then begin  if expected(semicolon, [semicolon])
                            then {fine - no more to do. }
            end else begin
                linerror(clsround_miss);
                if token.kind<>semicolon
                    then if expected(semicolon, [semicolon]) then {dummy};
            end;

{   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.
}
        end else if pragma_name.str='external_marshalling     ' then begin
            if find_type(typeptr, token.name, type_father, nty)
            then begin
                if nty^.nty_type^.typ_name <> nty  { If type name is different }
                then begin
                    new(typ);               { 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. }
                end {if};
                nty^.nty_type^.typ_external := true;
                nty^.nty_type^.typ_nesting := 0;
                external_marshalling := true;
            end else begin
                writeln(
   'RPCC: PRAGMA EXTERNAL_MARSHALLING must refer to previously defined type');
                linerror(id_not_declared);
            end;
            if expected(clsround, [semicolon])
            then if expected(semicolon, [semicolon])
            then {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.
}
        end else if pragma_name.str='call_status              ' then begin
            if not find_block(token.name, block_father, blk)
            then begin
                writeln(
   'RPCC: PRAGMA CALL_STATUS: First arg (proc/func name) not (yet) declared');
                linerror(id_not_declared);
            end else if expected(comma, [semicolon])
            then if expected(ident, [semicolon])
            then if not find_param(token.name, blk^.list, param) then begin
                writeln(' RPCC: PRAGMA CALL_STATUS:');
                writeln(' Second argument must be formal param. of proc/func');
                linerror(id_not_declared);
            end else begin
                if blk^.blk_status_param <> NIL then begin
                    writeln(
                        'RPCC: Proc/func already has a CALL_STATUS parameter');
                    linerror(twice_declared);
                end else blk^.blk_status_param := param;
            end {if};
            if expected(clsround, [semicolon])
            then if expected(semicolon, [semicolon])
            then {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.
}
        end else begin
            write  ('RPCC: Ignoring unknown pragma "');
            with pragma_name do for i:=1 to len do write(str[i]);
            writeln('"');
            find_tok([semicolon])       { Ignore unknown pragma }
        end {if good PRAGMA <name> ( <id>  etc };
    end {if got pragma name};
    getoken;                            { skip semicolon }
end {parse_pragma};

{*********************************************************************
                        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.
}

procedure type_declare;
var
        elem:           named_type;
        pnt:            ptr_named_type;
begin {TYPE_DECLARE}

 while not(token.kind in[proctok, functok]) do begin
  if token.kind=pragmatok then parse_pragma
  else if token.kind <> typetok then begin
        {* Error recovery: Skip all token until a good token is found *}
        errfind(type_miss, [proctok, functok, typetok]);
  end else begin

{* We are sure that we found a TYPE declaration *}
   getoken;
   if token.kind <> ident then begin
        {* Error recovery: Skip all token until a good token is found *}
        errfind(ident_req, [proctok, functok, typetok]);
   end else begin

        new(pnt);
        pnt^.nty_name := token.name;                        { <id> }
        getoken;

        if token.kind <> istok  then linerror(istok_miss)   { IS }
                                else getoken;

        pnt^.nty_type := parse_type;                        { <type> }

        if pnt^.nty_type<>NIL then begin

            insert_named_type(pnt, typeptr);        { Put into the type list }

            if pnt^.nty_type^.typ_name=NIL          { Link type back to name }
                then pnt^.nty_type^.typ_name := pnt;
        end;


        getoken; { Read next token }                        {    ; }

        if token.kind <> semicolon then begin
                {* Error recovery: Skip tokens until a good token is found *}
                errfind(semicol_miss, [semicolon, proctok, functok]);
                if token.kind = semicolon then {* Skip it *}
                        getoken;
        end else {* Semicolon found *}
                getoken;
   end; {else_if, token <> ident }

  end; {else_if, token <> typetok }

 end; {end_while token = typetok}

end; {TYPE_DECLARE}

{*****************************************************************************
*
*               BLOCK DECLARATION ANALIZER
*
******************************************************************************}

{                       Parse a list of parameters
                        ==========================

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

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

                <direction> ::  <void>  |  IN | OUT | IN OUT
}
procedure parse_parameter_list(var block: block_table);
{
 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);
*
****}
var
        identlist, headlist, tailist, last : ptr_idlist;
        scan2type, junk : ptr_named_type;
        ptr2type : ptr_defined_type;
        direction : attr_type;
        got_error : boolean;

{____________________________________________________________________________

                        FND_IDLIST
}
function fnd_idlist(    var name: id_name;
                        var last: ptr_idlist;
                        head : ptr_idlist): ptr_idlist;
{***
* 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
****}
var
        scan : ptr_idlist;
        found : boolean;
begin
  scan := head; {* head pointer to the list to check *}
  last := head;
  found := false;
  while (scan <> nil) and not(found) do
        if scan^.name.str = name.str then
                found := true
        else begin
                last := scan;
                scan := scan^.next;
        end;

  fnd_idlist := scan; {* Returns element or nil *}
end; {FND_IDLIST}

{_____________________________________________________________________________

                        GET_IDLIST
}
function get_idlist : ptr_idlist;
{***
* This function builds a list of identifier and returns a pointer
* to the header. Returns NIL in case of error (No tokens are skipped!!)
****}
var
        localist, last, scan : ptr_idlist;
        junk1, junk2 : ptr_named_type;

begin {GET_IDLIST}
    localist := nil;
    repeat
        getoken;
        {* Get a parameter definition *}
        if token.kind <> ident then
                errfind(ident_req, [comma, ident, colon]);
        if token.kind = ident then begin
                {***************************
                * 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.name, junk1, junk2) or
                        (fnd_idlist(token.name, scan, headlist) <> nil) or
                        (fnd_idlist(token.name, last, localist) <> nil) then
                        linerror(twice_declared) {* But ignore it!!! *}
                else begin
                        {* Add 'name' to the list, this is done
                        * adding in QUEUE, do not change this! *}
                        new(scan);
                        scan^.name := token.name;
                        scan^.next := nil;
                        if last = nil then {* Empty list *}
                                localist := scan
                        else
                                last^.next := scan;
                end;
                getoken;
        end; {* kind = ident *}
    until token.kind <> comma;

    get_idlist := localist;
end; {GET_IDLIST}
{_____________________________________________________________________________

       main block of parse_parameter_list;
}
begin {parse_parameter_list}
    got_error := false;
    headlist := nil; {* Pointer to the head of the list to bulid *}
    repeat

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

        if token.kind <> colon then
                linerror(colon_miss) {* But ignore *}
        else
                getoken;

{ Get direction attribute }

        if not(token.kind in[intok, outok]) then begin
                direction := intok; {* Assume inout, perhaps forgotten *}
        end else begin
                direction := token.kind;
                getoken;
                if (direction = intok) and (token.kind = outok) then begin
                                direction := inoutok;
                                getoken;
                end;
        end;

{ 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 <> nil) and (ptr2type <> nil) then with block do begin

                { Find maximum nesting: }
                if ptr2type^.typ_nesting > blk_nesting
                    then blk_nesting := ptr2type^.typ_nesting;

                {* Add direction and type attributes *}
                if headlist = nil then {* Empty list *}
                        headlist := identlist
                else
                        tailist^.next := identlist;
                tailist := identlist;
                repeat
                        tailist^.attr := direction;
                        tailist^.id_type := ptr2type;
                        last := tailist;
                        tailist := tailist^.next;
                        { Accumulate total parameter size: }
                        if direction in [intok, inoutok] then begin
                            blk_max_in := blk_max_in+ptr2type^.typ_max_size;
                            blk_min_in := blk_min_in+ptr2type^.typ_min_size;
                        end;
                        if direction in [outok, inoutok] then begin
                            blk_max_out := blk_max_out+ptr2type^.typ_max_size;
                            blk_min_out := blk_min_out+ptr2type^.typ_min_size;
                        end;

                until tailist = nil;
                tailist := last;
        end; {* Else ignore this wrong definition *}
        getoken;
        if not(token.kind in [semicolon, clsround]) then begin
                {* Semicolon or clsround missed.
                * Error recovery: Skip this parameter's definition and
                * find a semicolon or a closed round bracket or
                * a proctok/functok declaration
                *}
                errfind(semic_round_miss, [semicolon, clsround, functok,
                         proctok, ident]);
                case token.kind of
                        semicolon, clsround: ;
                        ident: backtoken;{* Continue analisys *}
                        colon, functok, proctok: begin
                                        got_error := true;
                                        backtoken;
                                        end;
                end;
        end;
    until (token.kind = clsround) or (got_error);

    block.list := headlist;
end; {parse_parameter_list}

{*********************************************************************
                BLOCK_DECLARE
**********************************************************************}

procedure block_declare;
var
        block:          block_table;
        junk1, scan:    ptr_named_type;
        blk, junk2,
        lastblock:      ptr_block_table;
        localerr:       boolean;
        ascan:          ptr_idlist;

begin {BLOCK_DECLARE}
  repeat
    localerr := false;

    with block do begin
        blk_nesting := 0;   { Initialise indeces required }
        blk_min_in := 0;    { Initialize parameter size counts }
        blk_min_out := 0;
        blk_max_in := 0;
        blk_max_out := 0;
    end;

    if not(token.kind in[proctok, functok, pragmatok, endtok]) then
        errfind(proc_exp, [proctok, functok, endtok, pragmatok]);

    if token.kind=pragmatok then parse_pragma
    else if token.kind <> endtok then begin
        {* Save block type *}
        block.b_type := token.kind;
        block.in_only := (token.kind = proctok);        { could be in_only }

        getoken;                                                { <ident> }
        if token.kind <> ident then begin
                {* Error recovery: ignore, but do not build any block later *}
                linerror(ident_req);
                localerr := true;
        end else begin
                block.name := token.name;
                if find_type(typeptr, token.name, junk1, scan) or
                        find_block(token.name, lastblock, junk2) then begin
                        {* Error recovery: ignore, but do not build any block later *}
                        linerror(twice_declared);
                        localerr := true;
                end;
        end;

        getoken;                                                {  (    }
        if token.kind = opnround then begin
                parse_parameter_list(block);                    { ... ) }
                getoken;
        end else
                if token.kind in[inoutok, intok, outok] then begin
                        linerror(opnround_miss);
                        backtoken;
                        parse_parameter_list(block);            { ... ) }
                        getoken;
                end else
                        block.list := NIL;              { TBL 18.8.86 }



        if block.b_type = functok then begin
                if token.kind <> return then
                        linerror(return_miss) {* But ignore *}
                else
                        getoken;
                if token.kind = ident then begin
                        {* Scan the types' list *}
                        if find_type(typeptr, token.name, junk1, scan) then
                                block.return := scan^.nty_type^.typ_basic_type
                        else begin
                                linerror(id_not_declared);
                                localerr := true;
                        end;
                end else
                        block.return := token.kind;

                if block.return in[chartok..longtok] then begin
                        getoken;
                        block.blk_max_out := block.blk_max_out +
                            simple_descriptor[block.return]^.typ_max_size;
                        block.blk_min_out := block.blk_min_out +
                            simple_descriptor[block.return]^.typ_min_size;
                end else begin
                        localerr := true;
                        linerror(simtype_req)
                end;

        end {functok} else {proctok} begin

        { Check for OUT or INOUT parameters to a procedure }

                ascan := block.list;
                while ascan <> NIL do begin
                        if ascan^.attr <> intok then block.in_only := false;
                        ascan := ascan^.next;
                end; {while}

        end; {procok}

        if token.kind <> semicolon then begin
                errfind(semicol_miss, [semicolon, proctok, functok, endtok]);
                if token.kind = semicolon then
                        getoken;
        end else
                getoken;

        if not localerr then begin
                {* Create a new element and save the name *}
                new(blk);
                blk^ := block;
                blk^.next := NIL;
                blk^.blk_status_param := NIL;
                blk^.blk_cast := false;
                blk^.blk_concurrent := false;
                if runoptions[timeout].value
                 then blk^.blk_timeout := timeout_val       { default timout }
                 else blk^.blk_timeout := rpc_default_timeout;

                if lastblock = nil then
                        {* List empty, update blockptr *}
                        blockptr := blk
                else
                        lastblock^.next := blk;
        end;
    end; {if kind <> endtok}

  until token.kind = endtok;

end; {BLOCDECLARE}


{************************************************************************

        Parser Initialisation

On exit,
    The simple type descriptors are prepared for the more complex
    types and parameters to be linked to.
}
procedure initialise_parser;
var t:  type_token;
begin
  for t := chartok to longtok do begin
   new(simple_descriptor[t]);
   with simple_descriptor[t]^ do begin
     typ_basic_type := t;
     typ_nesting := 0;      { No indeces are necessary for this type }
     typ_subtype := NIL;
     new(typ_name);
     with typ_name^ do begin
        nty_name.len := MAXIDLEN;
        nty_type := simple_descriptor[t];
        nty_next := NIL;
     end;

     case t of
        chartok,
        bytetok:    typ_max_size := 1;
        shortok,
        integertok: typ_max_size := 2;
        real32tok,
        longtok:    typ_max_size := 4;
        real48tok,
        real64tok:  typ_max_size := 8;
        real128tok: typ_max_size := 16;
     end; {end_case}
     typ_min_size := typ_max_size;
   end {with};
  end {for};

  simple_descriptor[chartok]^.typ_name^.nty_name.str
        := 'rpc_char                 ';
  simple_descriptor[bytetok]^.typ_name^.nty_name.str
        := 'rpc_byte                 ';
  simple_descriptor[shortok]^.typ_name^.nty_name.str
        := 'rpc_short                ';
  simple_descriptor[integertok]^.typ_name^.nty_name.str
        := 'rpc_integer              ';
  simple_descriptor[real32tok]^.typ_name^.nty_name.str
        := 'rpc_real32               ';
  simple_descriptor[longtok]^.typ_name^.nty_name.str
        := 'rpc_long                 ';
  simple_descriptor[real48tok]^.typ_name^.nty_name.str
        := 'rpc_real48               ';
  simple_descriptor[real64tok]^.typ_name^.nty_name.str
        := 'rpc_real64               ';
  simple_descriptor[real128tok]^.typ_name^.nty_name.str
        := 'rpc_real128              ';

  for t := chartok to longtok do
    with simple_descriptor[t]^, typ_name^, nty_name do
        while str[len]=' ' do len := len-1;     { strip trailing spaces }

  number_of_invented_types := 0;
  external_marshalling := false;    { Not invoked yet }

end {initialise_parser};

{****************************************************************
*
*               PARSER, MAIN LOOP
*
*****************************************************************}

procedure parser;

begin {PARSER}
    initialise_parser;
{* Look for 'PACKAGE' *}
    getoken;
    if token.kind <> package then
        linerror(package_miss) {* Ignored if missed *}
    else
        getoken;
{* Look for 'unit - name' *}
    if token.kind <> ident then
        linerror(ident_req) {Ignore}
    else begin
        unitname := token.name;
        getoken;
    end {if};

{* Look for 'is' *}
    if token.kind <> istok then
        linerror(istok_miss) {Ignore}
    else
        getoken;

{* Look for 'type' *}
    type_declare;
{* Returns with the next token already read *}

    if token.kind = endtok then
        linerror(blocks_req)
    else begin
        block_declare;
        if token.kind <> endtok then
                linerror(endtok_miss)
        else
                getoken;
        if token.kind <> ident then
                linerror(ident_req)
        else
                if token.name.str <> unitname.str then
                        linerror(bad_name);
        getoken;
        if token.kind <> semicolon then
                linerror(semicol_miss);

    end {if};
end; {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
    24 Oct 1989 Records of strings now declared correctly in client.
     9 Feb 1990 External marshalling routines end in _FOR too. (TBL)
    16 Mar 1990 RPC_CALL_STATUS is now declared as INTEGER*4.
    17 Apr 1990 Error message numbers are now declared INTEGER

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;
            o   Set up m_socket etc. as for rpc_begin().
    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.
   15.  RPC_REPORT_ERROR_FOR is a fortran callable rpc_report_error

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
}
function upper_case(ch: char): char;
begin
    if (ch >= 'a') and (ch<='z')
        then upper_case := chr(ord(ch)-ord('a')+ord('A'))
        else upper_case := ch;
end;

{___________________________________________________________________________

        Write out one identifier (in uppercase if FORTRAN)
}
procedure write_name(var where: text; var name: id_name);
var
        a:  integer;
begin
    with name do
        for a := 1 to len do
            if omode=vaxfor
                then write(where, upper_case(str[a]))
                else write(where, str[a]);
end;
{___________________________________________________________________________

        Write out component expression  (in uppercase if FORTRAN)
        ------------------------------
}
procedure write_exp(var where: text; var expr: expression);
var a : integer;
begin
    with expr do
        for a := 1 to len do
            if omode=vaxfor
                then write(where, upper_case(str[a]))
                else write(where, str[a]);
end;
{___________________________________________________________________________

        Write a quoted string padded to 40 characters
}
procedure write_name_padded(var op_file:text; name: id_name; ch: char);
begin
  write(op_file, ch);
  write_name(op_file, name);
  write(op_file, ch:rpc_name_length + 1 - name.len);
end {write_name_padded};

{=============================================================================

                        FORTRAN-sepcific procedures
}
{____________________________________________________________________________

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

    Code generator errors are internal errors or target-dependent error.
}
procedure codefor_error(why: error_string);
begin
    writeln(' RPCC: **** Error: ', why);
    writeln('       (Error detected at FORTRAN code generator stage.)');
    halt;
end;
{___________________________________________________________________________

        Indenting algorithm
}
function IndFor(level: integer): integer;
begin
    IndFor := 3+level*3
end;


{___________________________________________________________________________

        Start a Continuation Line
}
procedure continuation;
begin
    writeln(op_file);
    write(op_file, '     +');
end;
{___________________________________________________________________________

        Append a FORTRAN index to an array expression

    Level = 1       =>      RPC_A   used,
    Level = 2       =>      RPC_B   used etc...
}
procedure append_index_for(var expr: expression; level: integer);
var ch: char;
begin
            format(expr, '$(RPC_    ');
            append_1(expr, chr(ord('A')+level-1));
            append_1(expr, ')');

end;

{___________________________________________________________________________

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

    Used for the function return result.

|       generates:      upk/pck_ttt(rpc_p_buf,
}
procedure pack_simple_for(var where: text; what : type_token; topack: boolean);
begin
    write(where, '      CALL ');
    if topack then write(where,'PCK_') else write(where, 'UPK_');
    case what of
        chartok:        write(where, 'CHAR');
        bytetok:        write(where, 'BYTE');
        shortok:        write(where, 'SHORT');
        integertok:     write(where, 'INTEGER');
        real32tok:      write(where, 'REAL32');
        real48tok:      write(where, 'REAL48');
        real64tok:      write(where, 'REAL64');
        real128tok:     write(where, 'REAL128');
        longtok:        write(where, 'LONG');
    end;
    write(where, '_FOR(RPC_P_BUF,');
end;

{___________________________________________________________________________

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

    Currently, only aligns on word boundaires, because that is all
    we need.
}
procedure gen_align_for(    power:  integer;
                            level:  integer);
begin
    writeln(op_file, ' ':IndFor(level),
                'CALL RPC_ALIGN(RPC_P_BUF,', power:1, ')' );
    { Extra runtime support needed here }
end {gen_align_for};
{___________________________________________________________________________

        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>_FOR or UPK_<typename>_FOR is called to do the
    marshalling.

On entry,
    Output cursor at left margin.
On exit,
    Output cursor at left margin.
}
procedure gen_pack_type_for(var where:  text;   { output file }
                            expr:    expression;{ Expression for variable }
                            typ:    ptr_defined_type;   { type descriptor }
                            level:  integer;    { indentation & rpc_<level> }
                            topack: boolean);   { pack or unpack? }
var ch:     char;
    scan:   ptr_named_type;
    element:ptr_defined_type;   { Array element type }
    depth:  integer;        { Depth of nesting of array element }
    exp2:   expression;
    l_expr,                 { Expression for the length of a string, etc }
    s_expr: expression;     { Expression for the start of a substring }
    i:      integer;        { Loop index }
    local_label: integer;   { Record of last label we used here }

{_____________________________________________________________________________
                    Main block of gen_pack_type_for
}
BEGIN {gen_pack_type_for}

   {    Generate a few useful expressions: }

    ch := chr(ord('A')+level-1); {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 }

    with typ^ do
    if typ_external then begin
            write(where, ' ':IndFor(level), 'CALL ');
            if topack then write(where,'PCK_') else write(where, 'UPK_');
            write_name(op_file, typ_name^.nty_name);
            write(where, '_FOR(RPC_P_BUF,');
            write_exp(where, expr);
            writeln(where, ')');

    end else case typ_basic_type of
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                        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 wierd, because
of the descriptor.

}
        chartok: begin
            write(where, ' ':IndFor(level), 'CALL ');
            if topack then write(where,'PCK') else write(where, 'UPK');
            write(where, '_CHAR_FOR(RPC_P_BUF,');
            write_exp(where, expr);
            writeln(where, ')');
        end {simple type };

        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin
            write(where, ' ':IndFor(level), 'CALL ');
            if topack then write(where,'PCK') else write(where, 'UPK');
            with typ_name^.nty_name do
             for i := 4 to len do
              write(where, upper_case(str[i]));  { eg "_INTEGER" }
            write(where, '_FOR(RPC_P_BUF,');
            write_exp(where, expr);
            writeln(where, ')');
        end {simple type };

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

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

}
        arraytok: begin
            exp2 := expr;
            depth := level;
            ch := chr(ord('A')+depth-1);
            element := typ_subtype;
            format(exp2, '$(RPC_    ');
            append_1(exp2, ch);
            writeln(where, ' ':IndFor(depth),
                    'DO ', next_label:1,
                    ', RPC_', ch, '=1,', typ_high-typ_low+1:1);
            next_label := next_label+1;         { Get a new labels }
            while element^.typ_basic_type=arraytok do with element^ do begin
                depth := depth +1;
                ch := chr(ord('A')+depth-1);
                writeln(where, ' ':IndFor(depth),
                    'DO ', next_label:1,
                    ', RPC_', ch, '=1,',typ_high-typ_low+1:1);
                next_label := next_label+1;             { Get a new labels }
                format(exp2, '$,RPC_    ');
                append_1(exp2, ch);
                element := element^.typ_subtype;
            end {while};
            append_1(exp2, ')');

            local_label := next_label;  { Save label }
            gen_pack_type_for(where, exp2, element, depth+1, topack);

            while depth>= level do begin
                local_label := local_label-1;  { recalculate original label }
                writeln(where, local_label:4,
                    ' ':IndFor(depth)-4, 'CONTINUE');   { Not END DO }
                depth := depth-1;       { Come back out of nesting }
            end {while};
        end {arraytok};
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        recordtok: begin                                { R E C O R D }
            scan := typ_fields;
            while scan <> NIL do with scan^ do begin
                exp2 := expr;
                append_1(exp2,'.');
                append_name(exp2, nty_name);
                gen_pack_type_for(where, exp2, nty_type, level, topack);
                scan := nty_next;
            end {while};
        end {recordtok};
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                        A C C E S S

}
        accesstok: begin
            codefor_error(
                'No ACCESS (POINTER) type exists in FORTRAN!     ');
        end {accesstok};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        sequence: begin                                 { S E Q U E N C E }
            If level>1 then codefor_error(
                'SEQUENCE type not allowed within composite type.');

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

            exp2 := expr;
            format(exp2, 'A_$       ');     { Make an expression for the array}
            append_index_for(exp2, level);  { Make expression for an element }

            write(where, ' ':IndFor(level));
                write(where,    'DO ', next_label:1, ', RPC_', ch, '=1, L_');
                write_exp(where, expr);
                writeln(where);
            local_label := next_label;
            next_label := next_label+1;
            gen_pack_type_for(where, exp2, typ_subtype, level+1, topack);
            writeln(where, local_label:4, ' ':IndFor(level)-4, 'CONTINUE');
        end {sequence};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

In the server, strings are unpacked and the lengths fudged in the descriptor
by the routine UPK_VSTRING_FOR(buffer, string, length).
}
        stringtok: begin                                { S T R I N G }

            write(where, ' ':IndFor(level));
            if topack
                then                write(where, 'CALL PCK_STRING_FOR')
                else if client then write(where, 'CALL UPK_STRING_FOR')
                else                write(where, 'CALL UPK_VSTRING_FOR');
            write(where, '(RPC_P_BUF,');
            write_exp(where, expr);
            if not topack and not client then write(where, ',', typ_high:1);
            writeln(where, ')');

        end {stringtok};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          S U B S T R I N G

}
        substring: begin

            write(where, ' ':IndFor(level));
            if topack
                then    write(where, 'CALL PCK_SUBSTRING_FOR')
                else    write(where, 'CALL UPK_SUBSTRING_FOR');
            write(where, '(RPC_P_BUF,A_');
            write_exp(where, expr);
            write(where, ',');
            continuation;               { Keep it in 72 characters };
            write(where,    'S_');
            write_exp(where, expr);
            write(where,    ',L_');
            write_exp(where, expr);
            writeln(where,    ')');

        end {substring};

    end {case};
END {gen_pack_type_for};

{___________________________________________________________________________

        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.

}
PROCEDURE Gen_Pack_For( var     where:  text;           { Output file }
                        head:   ptr_idlist;     { Parameter list }
                        dirn:   attr_type;      { Parameter filter }
                        topack: boolean);       { Pack, rather than unpack? }

VAR expr:    expression;
BEGIN {Gen_Pack_For}
  Repeat
    with head^, id_type^ do begin


        { 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 (attr = inoutok)
            or (attr = dirn)
        then begin
            deref := client
                    and not (runoptions[byvalue].value   {* not value param *}
                    and (attr = intok));            { and in-only param }

            gen_pack_type_for(where, expr, id_type, {level} 1, topack);

        end {if};

    end {with};
    head := head^.next;
  Until head = nil;
END; {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 parameter (though not a string element
    in a record parameter) has an undefined length: "CHARACTER * ( * )".
    [The spaces here are to avoid <*> <)> closing this Pascal comment!]
    In the server, a length must be specified explicitly.

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

procedure gen_type_decl_for(expr:   expression;         { for the varaiable }
                            pt:     ptr_defined_type;   { type structure }
                            level:  integer);           { indentation }
var     scan:   ptr_defined_type;
        exp2:   expression;
begin
    with pt^ do case typ_basic_type of

        chartok,                    { First token, simple type, courier type }
        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin
            write(op_file, ' ':IndFor(level));
            case typ_basic_type of
                chartok:        write(op_file, 'CHARACTER*1');
                bytetok:        write(op_file, 'BYTE');         { @@ VAX ONLY }
                integertok:     write(op_file, 'INTEGER');
                real32tok:      write(op_file, 'REAL');
                real48tok:      write(op_file, 'DOUBLE');
                real64tok:      write(op_file, 'DOUBLE');
                real128tok:     write(op_file, 'DOUBLE');
                shortok:        write(op_file, 'INTEGER*2');    { @@ VAX ONLY }
                longtok:        write(op_file, 'INTEGER*4');    { @@ VAX ONLY }
            end {case};
            write(op_file, ' ');
            write_exp(op_file, expr);   { Example: rpc_char x }
            writeln(op_file);
        end {simple type};

        substring,
        stringtok:  begin               { Example: rpc_char x[81] }
                write(op_file, ' ':IndFor(level));
                if client and (level=1) then                    { 91024 }
                    write(op_file, 'CHARACTER*(*) ')
                else
                    write(op_file, 'CHARACTER*', (typ_high):1, ' ');
                write_exp(op_file, expr);
                writeln(op_file);
        end {stringtok};

        sequence,
        arraytok:   begin               { example  INTEGER MYARR(10,20) }
                exp2 := expr;
                append_1(exp2,'(');
                append_decimal(exp2,typ_high-typ_low+1);
                scan := typ_subtype;
                while scan^.typ_basic_type = arraytok do begin
                    append_1(exp2,',');
                    append_decimal(exp2,scan^.typ_high-scan^.typ_low+1);
                    scan := scan^.typ_subtype;
                end {while};
                append_1(exp2,')');
                gen_type_decl_for(exp2, scan, level); {non-array type}
        end {arraytok};

        accesstok: begin
            codefor_error(
                'Package has pointers: Can''t make FORTRAN stubs. ');
        end;

        recordtok: begin                { VAX/FORTRAN ONLY! }
            write(op_file, ' ':IndFor(level), 'RECORD ');
            if typ_name = NIL then codefor_error(
                'Every structure must be named for VAX/FORTRAN.  ')
            else begin
                write(op_file,'/');
                write_name(op_file,typ_name^.nty_name);
                write(op_file,'/ ');
            end {if};
            write_exp(op_file, expr);
            writeln(op_file);
        end;

    end {with, case};
end {gen_type_decl_for};

{_____________________________________________________________________________

                Generate Common Block for this client

}
procedure gen_client_common;
begin
        write(op_file, '      COMMON /C_');
        write_name(op_file, unitname);

        write(op_file, '/ H_');
        write_name(op_file, unitname);
        writeln(op_file);

        write(op_file, '      INTEGER H_');
        write_name(op_file, unitname);
        writeln(op_file);

end {gen_client_common};

{_____________________________________________________________________________

                Generate Common Block for this server

}
procedure gen_server_common;
begin
        write(op_file, '      COMMON /S_');
        write_name(op_file, unitname);

        write(op_file, '/ P_');
        write_name(op_file, unitname);
        writeln(op_file);

        write(op_file, '      INTEGER P_');
        write_name(op_file, unitname);
        writeln(op_file);
end {gen_server_common};

{____________________________________________________________________________

            Generate Parameter list
}
procedure gen_dummies(head: ptr_idlist);

  { Generates the formal parameter list enclosed in brackets  (a,b,c,d)  }
var
        col:        integer;
        scan:       ptr_idlist;

    procedure comma_cont(name: id_name);
    begin
        write(op_file, ',');            { Separate two parameters }
        col := col + 1;                 { Count characters }
        if col + name.len > 65 then     { Allow 5 spare }
        begin
            continuation;
            col := 6;
        end;
    end;


begin {gen_dummies}

     if head <> NIL then begin

        scan := head;
        write(op_file, '(');
        col := 40; { upper limit to characters so far on line }
        while scan <> NIL do begin
            if scan^.id_type^.typ_basic_type in [sequence, substring]
                    then write(op_file, 'A_');
            write_name(op_file, scan^.name);
            col := col + scan^.name.len + 2;

            if scan^.id_type^.typ_basic_type = substring then
            begin
                comma_cont(scan^.name);
                write(op_file, 'S_');
                write_name(op_file, scan^.name);
                col := col + scan^.name.len + 2;
            end;

            if scan^.id_type^.typ_basic_type in [sequence, substring] then
            begin
                comma_cont(scan^.name);
                write(op_file, 'L_');
                write_name(op_file, scan^.name);
                col := col + scan^.name.len + 2;
            end;

            scan := scan^.next;
            if (scan<>NIL) then comma_cont(scan^.name);
        end {while};
        write(op_file, ')');
     end{if list not NIL};
end; {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.

}

procedure gen_params_for(head: ptr_idlist);
var
        a_expr,
        l_expr,
        s_expr,
        expr:       expression;
        a:          integer;
        scan:       ptr_idlist;
        ch:         char;
        simple_ref:  boolean;   { Should simple variables be dereferenced? }
        composite_ref: boolean; { what about composite variables? }
begin {gen_params_for}


    scan := head;
    while scan <> NIL do begin

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

        with scan^.id_type^ do begin

            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 }

            case typ_basic_type of

            chartok,
            bytetok,
            shortok, integertok,
            real32tok, real48tok,
            real64tok, real128tok,
            longtok,
            stringtok,
            recordtok,
            arraytok:
                gen_type_decl_for(expr, scan^.id_type, 1);

            sequence:
                begin                                      { a_xxx: tttt; }
                    gen_type_decl_for(a_expr, scan^.id_type, 1);
                                                     { l_xxx: rpc_integer }
                    gen_type_decl_for(l_expr,
                        simple_descriptor[integertok], 1);
                end;

            substring:
                begin                                      { a_xxx: tttt; }
                    gen_type_decl_for(a_expr, scan^.id_type, 1);

                    gen_type_decl_for(s_expr,
                        simple_descriptor[integertok], 1);

                    gen_type_decl_for(l_expr,
                        simple_descriptor[integertok], 1);
                end;
            end {case};

        end; {with}

        scan := scan^.next;
   end {while};
end; {GEN_PARAMS_for}

{_________________________________________________________________________

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

Example:    STRUCTURE /structurename/
                CHARACTER*80    fieldname
                INTEGER         fieldname2
            END STRUCTURE
}
procedure gen_struct_for(   pt:     ptr_defined_type;   { type structure }
                            level:  integer);           { indentation }

var     scan:   ptr_named_type;
        exp2:   expression;
begin

        with pt^ do if typ_basic_type = recordtok then begin
                                                { VAX/FORTRAN ONLY! }
            write(op_file, ' ':IndFor(level), 'STRUCTURE ');
            if typ_name = NIL then codefor_error(
                'Every structure must be named for VAX/FORTRAN.  ')
            else begin
                write(op_file,'/');
                write_name(op_file, typ_name^.nty_name);
                write(op_file,'/ ');
            end {if};
            writeln(op_file);

            scan := typ_fields;
            while scan <> NIL do begin
                exp2.len := 0;
                append_name(exp2, scan^.nty_name);
                gen_type_decl_for(exp2, scan^.nty_type, level+1);
                scan := scan^.nty_next;
            end {while};

            writeln(op_file, ' ':IndFor(level), 'END STRUCTURE');

    end {with..if};
end {gen_struct_for};
{___________________________________________________________________________

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

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

procedure generate_types_for;
var
        scan:   ptr_named_type;
        expr:   expression;

begin {generate types}
    scan := typeptr;
    while scan <> nil do with scan^, nty_type^ do begin
        if typ_basic_type = recordtok then begin

{   Now make the main type definition:
}
            gen_STRUCT_for(nty_type, 1);
            writeln(op_file);                       { Blank line }
        end {if};

        scan := nty_next;
    end; {while}
end;

{******************************************************************************

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

Generates one procedure or function for the client.
}

procedure client_gen_for;
var
        scan :          ptr_block_table;
        proc_number :   integer;

  procedure gen_client_block(ptr: ptr_block_table);

{***
* On each block, the client allocates 'RPC_integer' variables to pack or
* unpack parameters.
****}
  var
        a:              integer;
        expr:           expression;     { Expression for return value }

 begin {GEN_client_BLOCK}
    with ptr^ do begin
{   Generate Header:
}
        write(op_file, ' ':IndFor(1));
        if b_type = functok then begin

            case return of
                chartok:        write(op_file, 'CHARACTER*1');
                bytetok,
                shortok,
                longtok,
                integertok:     write(op_file, 'INTEGER');
                real32tok:      write(op_file, 'REAL');
                real48tok,
                real64tok,
                real128tok:     write(op_file, 'DOUBLE');
            end {case};
            write(op_file, ' FUNCTION ');
            write_name(op_file, name);
            case return of
                chartok:        ;
                bytetok:        write(op_file, '*1');           { @@ VAX ONLY }
                integertok,
                real32tok,
                real48tok,
                real64tok,
                real128tok:     { ok as it is};
                shortok:        write(op_file, '*2');       { @@ VAX ONLY }
                longtok:        write(op_file, '*4');       { @@ VAX ONLY }
            end {case};
        end else begin
            write(op_file, 'SUBROUTINE ');
            write_name(op_file, name);
        end {if};
        gen_dummies(list);      { Generate formal parameter list }
        writeln(op_file);
        gen_client_common;

        generate_types_for;              { generate local types   }

        gen_params_for(list);

{   Local variables:
}
        write(op_file,  '      INTEGER RPC_P_BUF');
        for a := 1 to blk_nesting do
            write(op_file, ',RPC_', chr(ord('A') - 1 + a));
        writeln(op_file);

        if b_type = functok then begin      { Variable for return value }
            format(expr, 'RPC_RET   ');
            gen_type_decl_for(expr, simple_descriptor[return], 1);
        end {if};

{   Declaration of RPC_CALL_STATUS function type
}
        if blk_status_param <> NIL then begin
            writeln(op_file, '      INTEGER*4 RPC_CALL_STATUS');
            writeln(op_file);
        end {if};

{   Code of routine starts here:
}
        write  (op_file, '      CALL RPC_BEGIN_CALL_FOR(RPC_P_BUF, H_');
        write_name(op_file, unitname);
        writeln(op_file,            ',',
                    blk_max_in:1,   ',',
                    blk_max_out:1,  ',',
                    version_num:1,  ',',
                    proc_number:1,  ')'     );

  {* generate packing statements for IN & INOUT params *}
        if list <> nil then Gen_Pack_For(op_file, list, intok, true);

  {* generate rpc_call and bookeeping *}
        if blk_status_param <> NIL then begin
            write(op_file,'      ');
            write_name(op_file, blk_status_param^.name);
            write(op_file,'=RPC_CALL_STATUS(H_');
        end else if blk_cast then begin
            write(op_file, '      CALL RPC_CAST(H_');
        end else begin
            write(op_file, '      CALL RPC_CALL(H_');
        end {if};
        write_name(op_file, unitname);
        write(op_file, ',RPC_P_BUF');
        if not blk_cast then write(op_file, ',', blk_timeout:1);
        writeln(op_file, ')');

        if blk_status_param <> NIL then begin
            write(op_file,'      IF (MOD(');
            write_name(op_file, blk_status_param^.name);
            writeln(op_file,',2).NE.0) THEN');
        end;

  {* if function: unpack return value *}
        if b_type = functok then begin
            pack_simple_for(op_file, return, false);
            writeln(op_file, 'RPC_RET)');
        end {if};

  {* generate UNpacking statements for OUT and INOUT params *}
        if list <> nil then Gen_Pack_For(op_file, list, outok, false);

        if blk_status_param <> NIL
        then writeln(op_file,'      END IF');

  {* clear up everything and exit *}

        writeln(op_file, '      CALL RPC_END_CALL_FOR(RPC_P_BUF)');

        if b_type = functok then begin
            write  (op_file, '      ');
            write_name(op_file, name);
            writeln(op_file,    '=RPC_RET');    { Define function value }
        end {if};
        writeln(op_file, '      RETURN');
        writeln(op_file, '      END');
        writeln(op_file);
    end {with}
 end; {gen_client_block}

 procedure gen_open;
 begin
    if not runoptions[noautoinit].value then writeln(op_file,
                'C     Call this procedure at initialisation time ***');
    write(op_file, '      SUBROUTINE OPEN_');
    write_name(op_file, unitname);
    writeln(op_file);

    gen_client_common;

    writeln(op_file,'      INTEGER STATUS');

    write  (op_file,'      CALL RPC_OPEN_FOR(STATUS,H_');
    write_name(op_file, unitname);
    write  (op_file, ',');
    continuation;
    write_name_padded(op_file, unitname, '''');
    writeln(op_file, ')');

    writeln(op_file, '      CALL RPC_REPORT_ERROR_FOR(STATUS)');
    writeln(op_file, '      END');
    writeln(op_file);
 end; {GEN_OPEN}

    procedure gen_close;
        begin
        write(op_file, '      SUBROUTINE CLOSE_');
        write_name(op_file, unitname);
        writeln(op_file);

        gen_client_common;

        writeln(op_file,'      INTEGER STATUS');

        write  (op_file,'      CALL RPC_CLOSE_FOR(STATUS,H_');
        write_name(op_file, unitname);
        writeln(op_file, ')');

        writeln(op_file, '      CALL RPC_REPORT_ERROR_FOR(STATUS)');
        writeln(op_file, '      END');
        writeln(op_file);
    end; {GEN_close}

begin {client_gen_for}

    next_label := 100;      { An arbitrary starting label }

    write  (op_file,'C     CLIENT STUB routines for package ');
    write_name(op_file, unitname);
    writeln(op_file);
    writeln(op_file,'C     ====================');
    writeln(op_file,'C');
    writeln(op_file,'C     Generated automatically by the RPC Compiler');
    writeln(op_file,'C     ');

{*      Generate procedures *}

    proc_number := 1;
    scan := blockptr;
    while scan <> nil do begin
        gen_client_block(scan);
        proc_number := proc_number + 1;
        scan := scan^.next;
    end;

    gen_open;
    gen_close;

end; {CLIENT_GEN_for}



{*****************************************************************************

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

}
PROCEDURE server_gen_for;

var     i,                      { Label counter for computed goto }
        proc_num :  integer;
        scan:       ptr_block_table;


{_____________________________________________________________________________

        Generate server stub for one procedure
}
 procedure gen_r_routine;
 var    a:  integer;        { Loop variable }
        expr:   expression; { Expression for the name of the function }
 begin

    write(op_file, '      SUBROUTINE R_');
    write_name(op_file, scan^.name);
    writeln(op_file, '(RPC_P_BUF)' );

    write(op_file,  '      INTEGER RPC_P_BUF');

    for a := 1 to scan^.blk_nesting do
            write(op_file, ',RPC_', chr(ord('A') - 1 + a));
    writeln(op_file);

    if scan^.b_type = functok then begin    { Declare function type }
        writeln(op_file);
        expr.len := 0;
        append_name(expr, scan^.name);
        gen_type_decl_for(expr, simple_descriptor[scan^.return], 1);
    end;

    generate_types_for;              { Declare structure types   }

    gen_params_for(scan^.list);      { Declare types of parameters }

{   Generate UNpacking statements for IN and INOUT params:
}
    if scan^.list <> nil then Gen_Pack_For(op_file, scan^.list, intok, false);

  {* generate call and bookeeping *}
    writeln(op_file,    '      CALL RPC_INIT_RETURN_FOR(RPC_P_BUF)');

    if (scan^.b_type = proctok)
    and scan^.in_only
    then
        if (runoptions[concurrent].value or scan^.blk_concurrent)
           then writeln(op_file, '      CALL RPC_EARLY_RETURN(RPC_P_BUF)')
        else if scan^.blk_cast
           then writeln(op_file, '      CALL RPC_NO_RETURN(RPC_P_BUF)');

    write(op_file, '      ');

  {* if function: generate return variable, else just call subroutine.*}
    if scan^.b_type = functok
        then pack_simple_for(op_file, scan^.return, true)
        else write(op_file, 'CALL ');
    write_name(op_file, scan^.name);
    gen_dummies(scan^.list);
    if scan^.b_type = functok then begin
        if (scan^.list=NIL) then write(op_file, '()');    { Mandatory }
        write(op_file, ')');
    end {if};
    writeln(op_file);

  {* generate packing statements for OUT and INOUT params*}
    if scan^.list <> nil then Gen_Pack_For(op_file, scan^.list, outok, true);

    writeln(op_file, '      END');
    writeln(op_file);                       { Blank line after each one }
 end {gen_r_routine};
{_____________________________________________________________________________}

{       Generate Main Server Procedure
        ------------------------------
}

begin {server_gen_for}

  next_label := 100;        { An arbitrary starting label }

  write  (op_file,'C     SERVER STUB routines for package ');
  write_name(op_file, unitname);
  writeln(op_file);
  writeln(op_file,'C     ====================');
  writeln(op_file,'C');
  writeln(op_file,'C     Generated automatically by the RPC Compiler');
  writeln(op_file,'C     ');

{       Generate individual routines for each procedure:
        -----------------------------------------------
}
  scan := blockptr;
  proc_num := 0;
  while scan <> nil do begin
          proc_num := proc_num + 1; { Count the procedures }
          gen_r_routine;            { Generate the individual stub subroutines }
          scan := scan^.next;
  end {while};

{       Generate the main server stub subroutine:
        ----------------------------------------
}
  writeln(op_file, 'C');
  writeln(op_file, 'C                         Main stub entry point');
  writeln(op_file, 'C');
  write  (op_file, '      SUBROUTINE R_');
  write_name(op_file, unitname);
  writeln(op_file, '(RPC_P_BUF)');
  writeln(op_file, '      INTEGER RPC_P_BUF');
  writeln(op_file, '      INTEGER*2 RPC_REQUEST');
  writeln(op_file, '      INTEGER*4 STATUS');
  writeln(op_file, '      INTEGER RPC_S_UNSUPPORTED_VERSION');
  writeln(op_file, '      PARAMETER(RPC_S_UNSUPPORTED_VERSION=139624458)');
  writeln(op_file, '      INTEGER RPC_S_BAD_PROCEDURE_NUMBER');
  writeln(op_file, '      PARAMETER(RPC_S_BAD_PROCEDURE_NUMBER=139624466)');
  writeln(op_file);
  writeln(op_file, '      CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)');
  writeln(op_file, '      IF ((RPC_REQUEST.NE.0).AND.(RPC_REQUEST.NE.',
                            version_num:1, ')) THEN');
  writeln(op_file,
          '      CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_UNSUPPORTED_VERSION)');
  writeln(op_file, '      ELSE');
  writeln(op_file, '         CALL UPK_SHORT_FOR(RPC_P_BUF, RPC_REQUEST)');
  writeln(op_file, '         IF ((RPC_REQUEST.LE.0).OR.(RPC_REQUEST.GT.',
                                    proc_num:1, ')) THEN');
  writeln(op_file,
        '            CALL RPC_SET_ERROR(RPC_P_BUF,RPC_S_BAD_PROCEDURE_NUMBER)');

  writeln(op_file, '         ELSE');
  write(op_file,   '            GOTO(10');
  for i := 2 to proc_num do begin
    if (i mod 10)=0 then begin
        writeln(op_file);
        write(op_file,'     + ');
    end {if};
    write(op_file, ',', i*10:1);
  end {for};
  writeln(op_file, '),RPC_REQUEST');

  scan := blockptr;                     { Make jump table: }
  for i := 1 to proc_num do begin
    writeln(op_file);
    write  (op_file,i*10:5, '       CALL R_');
    write_name(op_file, scan^.name);
    writeln(op_file, '(RPC_P_BUF)');
    writeln(op_file, '            GOTO 888');
    scan := scan^.next;
  end;

  writeln(op_file, '  888       CONTINUE');
  writeln(op_file);
  writeln(op_file, '         END IF');      { If good request }
  writeln(op_file, '      END IF');         { If good version }
  writeln(op_file, '      END');            { subroutine }
  writeln(op_file);

{       Generate Code to Attach stub to RPCRTS
        --------------------------------------
}

  if not runoptions[noautoinit].value then writeln(op_file,
                'C     Call this procedure at initialisation time ***');
  write  (op_file, '      SUBROUTINE ATTACH_');
  write_name(op_file, unitname);
  writeln(op_file);

  gen_server_common;

  write(op_file, '      EXTERNAL R_');
  write_name(op_file, unitname);
  writeln(op_file);

  writeln(op_file, '      INTEGER STATUS');
  writeln(op_file);

  write(op_file, '      CALL RPC_ATTACH_STUB_FOR(STATUS,R_');
  write_name(op_file, unitname);
  write  (op_file, ',');
  continuation;
  write_name_padded(op_file, unitname, '''');
  write  (op_file, ',P_');
  write_name(op_file, unitname);
  writeln(op_file, ')');

  writeln(op_file, '      CALL RPC_REPORT_ERROR_FOR(STATUS)');
  writeln(op_file, '      END');
  writeln(op_file);

{       Generate Code to Detach stub from RPCRTS
        ----------------------------------------
}

  write  (op_file, '      SUBROUTINE DETACH_');
  write_name(op_file, unitname);
  writeln(op_file);

  gen_server_common;

  write(op_file,   '      CALL RPC_DETACH_STUB_FOR(P_');
  write_name(op_file, unitname);
  writeln(op_file, ')');

  writeln(op_file, '      END');

end; {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
}
procedure write_name_pils(var where: text; var name: id_name);
var
        a:  integer;
begin
    with name do
        for a := 1 to len do
                write(where, str[a]);
end;
{___________________________________________________________________________

        Write out component expression
        ------------------------------
}
procedure write_exp_pils(var where: text; var expr: expression);
var a : integer;
begin
    with expr do
        for a := 1 to len do
                write(where, str[a]);
end;
{___________________________________________________________________________

        Write a quoted string padded to 40 characters
}
procedure write_name_padded_pils(var op_file:text; name: id_name; ch: char);
begin
  write(op_file, ch);
  write_name(op_file, name);
  write(op_file, ch:rpc_name_length + 1 - name.len);
end {write_name_padded};

{=============================================================================

                        PILS-sepcific procedures
}
{____________________________________________________________________________

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

    Code generator errors are internal errors or target-dependent error.
}
procedure code_error_pils(why: error_string);
begin
    writeln(' RPCC: **** Error: ', why);
    writeln('       (Error detected at PILS code generator stage.)');
    halt;
end;
{___________________________________________________________________________

        Indenting algorithm
}
function ind_pils(level: integer): integer;
begin
    ind_pils := (level)*3;
end;


{___________________________________________________________________________

        Append a PILS index to an array expression

    Level = 1       =>      rpc_a   used,
    Level = 2       =>      rpc_b   used etc...
}
procedure append_index_pils(var expr: expression; level: integer);
var ch: char;
begin
            format(expr, '$(rpc_    ');
            append_1(expr, chr(ord('a')+level-1));
            append_1(expr, ')');

end;

{___________________________________________________________________________

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

    Used for the function return result.

|       generates:      upk/pck_ttt(rpc_p_buf,
}
procedure pack_simple_pils(var where: text; what : type_token; topack: boolean);
begin
    if topack then write(where,'pck_') else write(where, 'upk_');
    case what of
        chartok:        write(where, 'char');
        bytetok:        write(where, 'byte');
        shortok:        write(where, 'short');
        integertok:     write(where, 'integer');
        real32tok:      write(where, 'real32');
        real48tok:      write(where, 'real48');
        real64tok:      write(where, 'real64');
        real128tok:     write(where, 'real128');
        longtok:        write(where, 'long');
    end;
    write(where, '(rpc_p_buf,');
end;

{___________________________________________________________________________

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

    Currently, only aligns on word boundaires, because that is all
    we need.
}
procedure gen_align_pils(    power:  integer;
                            level:  integer);
begin
    writeln(op_file, ' ':ind_pils(level),
                'rpc_align(rpc_p_buf,', power:1, ')' );
    { Extra runtime support needed here }
end {gen_align_pils};
{___________________________________________________________________________

        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.
}
procedure gen_pack_type_pils(var where:  text;   { output file }
                            expr:    expression;{ Expression for variable }
                            typ:    ptr_defined_type;   { type descriptor }
                            level:  integer;    { indentation & rpc_<level> }
                            topack: boolean);   { pack or unpack? }
var ch:     char;
    scan:   ptr_named_type;
    element:ptr_defined_type;   { Array element type }
    depth:  integer;        { Depth of nesting of array element }
    exp2:   expression;
    l_expr,                 { Expression for the length of a string, etc }
    s_expr: expression;     { Expression for the start of a substring }
    i:      integer;        { Loop index }

{_____________________________________________________________________________
                    Main block of gen_pack_type_pils
}
BEGIN {gen_pack_type_pils}

   {    Generate a few useful expressions: }

    ch := chr(ord('a')+level-1); {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 }

    with typ^ do
    if typ_external then begin
            write(where, ' ':ind_pils(level));
            if topack then write(where,'pck_') else write(where, 'upk_');
            write_name(op_file, typ_name^.nty_name);
            write(where, '(rpc_p_buf,');
            write_exp(where, expr);
            writeln(where, ')');

    end else case typ_basic_type of
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                        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.

}
        chartok: begin
            write(where, ' ':ind_pils(level));
            if topack then write(where,'pck') else write(where, 'upk');
            write(where, '_char_PILS(rpc_p_buf,');
            write_exp(where, expr);
            writeln(where, ')');
        end {simple type };

        bytetok: begin
            write(where, ' ':ind_pils(level));
            if topack then write(where,'pck') else write(where, 'upk');
            write(where, '_byte_PILS(rpc_p_buf,');
            write_exp(where, expr);
            writeln(where, ')');
        end {simple type };

        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin
            write(where, ' ':ind_pils(level));
            if topack then write(where,'pck') else write(where, 'upk');
            with typ_name^.nty_name do
             for i := 4 to len do
              write(where, str[i]);
            write(where, '(rpc_p_buf,');
            write_exp(where, expr);
            writeln(where, ')');
        end {simple type };

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

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

}
        arraytok: begin
            exp2 := expr;
            depth := level;
            ch := chr(ord('a')+depth-1);
            element := typ_subtype;
            format(exp2, '$(rpc_    ');
            append_1(exp2, ch);
            write(where, ' ':ind_pils(depth));
            writeln(where, 'FOR rpc_', ch, '=1 TO ', typ_high-typ_low+1:1);
            while element^.typ_basic_type=arraytok do with element^ do begin
                depth := depth +1;
                ch := chr(ord('a')+depth-1);
                write(where, ' ':ind_pils(depth));
                writeln(where, 'FOR rpc_', ch, '=1 TO ',typ_high-typ_low+1:1);
                format(exp2, '$,rpc_    ');
                append_1(exp2, ch);
                element := element^.typ_subtype;
            end {while};
            append_1(exp2, ')');

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

            while depth>= level do begin
                writeln(where, ' ':ind_pils(depth), 'ENDFOR');
                depth := depth-1;       { Come back out of nesting }
            end {while};
        end {arraytok};
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        recordtok: begin                                { R E C O R D }
            code_error_pils(
                'No RECORD (STRUCTURE) type exists in PILS!      ');
        end {recordtok};
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                        A C C E S S

}
        accesstok: begin
            code_error_pils(
                'No ACCESS (POINTER) type exists in PILS!        ');
        end {accesstok};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        sequence: begin                                 { S E Q U E N C E }
            If level>1 then code_error_pils(
                'SEQUENCE type not allowed within composite type.');

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

            exp2 := expr;
            format(exp2, 'A_$       ');     { Make an expression for the array}
            append_index_pils(exp2, level);          { Make expression for an element }

            write(where, ' ':ind_pils(level));
                write(where,    'FOR rpc_', ch, '=1 TO L_');
                write_exp(where, expr);
                writeln(where);

            gen_pack_type_pils(where, exp2, typ_subtype, level+1, topack);
            writeln(where, ' ':ind_pils(level), 'ENDFOR');
        end {sequence};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        stringtok: begin                                { S T R I N G }

            write(where, ' ':ind_pils(level));
            if topack
                then    write(where, 'pck_string')
                else    write(where, 'upk_string');
            write(where, '(rpc_p_buf,');
            write_exp(where, expr);
            writeln(where, ')');

        end {stringtok};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                          S U B S T R I N G

}
        substring: begin

            write(where, ' ':ind_pils(level));
            if topack
                then    write(where, 'pck_substring')
                else    write(where, 'upk_substring');
            write(where, '(rpc_p_buf,A_');
            write_exp(where, expr);
            write(where, ',');
            write(where,    'S_');
            write_exp(where, expr);
            write(where,    ',L_');
            write_exp(where, expr);
            writeln(where,    ')');

        end {substring};

    end {case};
END {gen_pack_type_pils};

{___________________________________________________________________________

        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.

}
PROCEDURE gen_pack_pils( var     where:  text;           { Output file }
                        head:   ptr_idlist;     { Parameter list }
                        dirn:   attr_type;      { Parameter filter }
                        topack: boolean);       { Pack, rather than unpack? }

VAR expr:    expression;
BEGIN {gen_pack_pils}
  Repeat
    with head^, id_type^ do begin


        { 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 (attr = inoutok)
            or (attr = dirn)
        then begin
            deref := client
                    and not (runoptions[byvalue].value   {* not value param *}
                    and (attr = intok));            { and in-only param }

            gen_pack_type_pils(where, expr, id_type, {level} 1, topack);

        end {if};

    end {with};
    head := head^.next;
  Until head = nil;
END; {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.
}

procedure gen_type_decl_pils(expr:   expression;        { for the variable }
                            pt:     ptr_defined_type;   { type structure }
                            level:  integer);           { indentation }
var     scan:   ptr_defined_type;
        exp2:   expression;
begin
    with pt^ do case typ_basic_type of

        chartok,                    { First token, simple type, courier type }
        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin
            { write(op_file, ' ':ind_pils(level)); }
            case typ_basic_type of
                chartok:        write(op_file, 'int16');
                bytetok:        write(op_file, 'int16');
                integertok:     write(op_file, 'INT');
                real32tok:      write(op_file, 'REAL');
                real48tok:      write(op_file, 'REAL');
                real64tok:      write(op_file, 'REAL');
                real128tok:     write(op_file, 'REAL');
                shortok:        write(op_file, 'INT16');
                longtok:        write(op_file, 'INT32');
            end {case};
            write(op_file, ' ');
            write_exp(op_file, expr);   { Example: rpc_char x }
        end {simple type};

        substring,
        stringtok:  begin               { Example: rpc_char x[81] }
                { write(op_file, ' ':ind_pils(level)); }
                write(op_file, 'CHAR ');
                write_exp(op_file, expr);
        end {stringtok};

        sequence,
        arraytok:   begin               { example  INT MYARR(10,20) }
                exp2 := expr;
                append_1(exp2,'(');
                append_decimal(exp2,typ_high-typ_low+1);
                scan := typ_subtype;
                while scan^.typ_basic_type = arraytok do begin
                    append_1(exp2,',');
                    append_decimal(exp2,scan^.typ_high-typ_low+1);
                    scan := scan^.typ_subtype;
                end {while};
                append_1(exp2,')');
                gen_type_decl_pils(exp2, scan, level); {non-array type}
        end {arraytok};

        accesstok: begin
            code_error_pils(
                'Package has pointers: Can''t make PILS stubs.    ');
        end;

        recordtok: begin
            code_error_pils(
                'Package has records:  Can''t make PILS stubs.    ');
        end;

    end {with, case};
end {gen_type_decl_pils};

{_____________________________________________________________________________

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

This subroutine will generate

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

}

procedure gen_params_pils(head: ptr_idlist);
var
        a_expr,
        l_expr,
        s_expr,
        expr:       expression;
        a:          integer;
        scan:       ptr_idlist;
        ch:         char;
        simple_ref:  boolean;   { Should simple variables be dereferenced? }
        composite_ref: boolean; { what about composite variables? }

begin {gen_params_pils}

    scan := head;

    IF client THEN
        write(op_file, '(');

    while scan <> NIL do begin

    {* Write the parameter attribute *}

    IF client THEN
        CASE scan^.attr OF
           intok: write(op_file, 'IN ');
           outok: write(op_file, 'OUT ');
           inoutok: write(op_file, 'INOUT ');
        END {CASE};

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

        with scan^.id_type^ do begin

            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 }

            case typ_basic_type of

            chartok,
            bytetok,
            shortok, integertok,
            real32tok, real48tok,
            real64tok, real128tok,
            longtok,
            stringtok,
            recordtok,
            arraytok:
                gen_type_decl_pils(expr, scan^.id_type, 1);

            sequence:
                begin                                      { a_xxx: tttt; }
                    gen_type_decl_pils(a_expr, scan^.id_type, 1);
                                                     { l_xxx: rpc_integer }
                    IF client THEN write(op_file, ',')          { PILS }
                         ELSE write(op_file, ';');              { PILS }

                    gen_type_decl_pils(l_expr,
                        simple_descriptor[integertok], 1);
                end;

            substring:
                begin                                      { a_xxx: tttt; }
                    gen_type_decl_pils(a_expr, scan^.id_type, 1);

                    IF client THEN write(op_file, ',')          { PILS }
                         ELSE write(op_file, ';');              { PILS }

                    gen_type_decl_pils(s_expr,
                        simple_descriptor[integertok], 1);

                    IF client THEN write(op_file, ',')          { PILS }
                         ELSE write(op_file, ';');              { PILS }

                    gen_type_decl_pils(l_expr,
                        simple_descriptor[integertok], 1);
                end;
            end {case};

        end; {with}
        scan := scan^.next;

       IF scan <> NIL THEN
            IF client THEN write(op_file, ',')          { PILS }
                 ELSE write(op_file, ';');              { PILS }

   end {while};

   IF client THEN write(op_file, ')');                  { PILS }

   writeln(op_file);

end; {GEN_PARAMS_PILS}

{____________________________________________________________________________

            Generate Formal Parameter List
}
procedure gen_formals(head: ptr_idlist);

  { Generates the formal parameter list enclosed in brackets  (a,b,c,d)  }
var
        scan:       ptr_idlist;

begin {gen_formals}

     if head <> NIL then begin

        scan := head;
        write(op_file, '(');
        while scan <> NIL do begin
            if scan^.id_type^.typ_basic_type in [sequence, substring]
                    then write(op_file, 'A_');
            write_name(op_file, scan^.name);
            if scan^.id_type^.typ_basic_type = substring then
            begin
                write(op_file, ', S_');
                write_name(op_file, scan^.name);
            end;
            if scan^.id_type^.typ_basic_type in [sequence, substring] then
            begin
                write(op_file, ', L_');
                write_name(op_file, scan^.name);
            end;

            scan := scan^.next;
            if scan <> nil then
                write(op_file, ',');
        end {while};
        write(op_file, ')');
     end {if list not NIL};
end; {gen_formals}

{_________________________________________________________________________

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

Example:    STRUCTURE /structurename/
                CHARACTER*80    fieldname
                INTEGER         fieldname2
            END STRUCTURE
}
procedure gen_struct_pils(   pt:     ptr_defined_type;   { type structure }
                            level:  integer);           { indentation }

var     scan:   ptr_named_type;
        exp2:   expression;
begin

      { writeln(op_file, '!-- Sorry, No PILS Structures !!!'); }

end {gen_struct_pils};
{___________________________________________________________________________

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

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

procedure generate_types_pils;

begin {generate types}

      { writeln(op_file, '!-- Sorry, No PILS User Defined Types !!!'); }

end;

{******************************************************************************

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

Generates one procedure or function for the client.
}

procedure client_generator_pils;
var
        scan :          ptr_block_table;
        proc_number :   integer;

  procedure gen_client_block(ptr: ptr_block_table);

{***
* On each block, the client allocates 'rpc_integer' variables to pack or
* unpack parameters.
****}
  var
        a:              integer;
        expr:           expression;     { Expression for return value }

 begin {GEN_client_BLOCK}
    with ptr^ do begin
{   Generate Header:
}
        if b_type = functok then begin
            write(op_file, 'DEF ');
            case return of
                chartok:        write(op_file, 'int16');
                bytetok:        write(op_file, 'int16');
                shortok,
                integertok:     write(op_file, 'INT16');
                longtok:        write(op_file, 'INT32');
                real32tok,
                real48tok,
                real64tok,
                real128tok:     write(op_file, 'REAL');
            end {case};
            write(op_file, ' ');
            write_name(op_file, name);
        end else begin
            write(op_file, 'SUB ');
            write_name(op_file, name);
        end {if};

        gen_params_pils(list);      { Generate formal parameter list }

        writeln(op_file);

{   Local variables:
}
        write(op_file,  '   INT rpc_p_buf');
        for a := 1 to blk_nesting do
            write(op_file, ',rpc_', chr(ord('a') - 1 + a));
        writeln(op_file);

        if b_type = functok then begin      { Variable for return value }
            writeln(op_file, '   INT rpc_ret');
            {
            format(expr, 'rpc_ret   ');
            gen_type_decl_pils(expr, simple_descriptor[return], 1);
            }
        end {if};
        writeln(op_file);

{   Code of routine starts here:
}
        write  (op_file, '   rpc_begin_call(rpc_p_buf,h_');
        write_name(op_file, unitname);
        writeln(op_file,            ',',
                    blk_max_in:1,   ',',
                    blk_max_out:1,  ',',
                    version_num:1,  ',',
                    proc_number:1,  ')'     );

  {* generate packing statements for IN & INOUT params *}
        if list <> nil then gen_pack_pils(op_file, list, intok, true);

  {* generate rpc_call and bookeeping *}
        if blk_cast then write(op_file, '   rpc_cast(h_')
                    else write(op_file, '   rpc_call(h_');
        write_name(op_file, unitname);
        write(op_file, ',rpc_p_buf');
        if not blk_cast then write(op_file, ',', blk_timeout:1);
        writeln(op_file, ')');

  {* if function: unpack return value *}
        if b_type = functok then begin
            write(op_file, '   ');
            pack_simple_pils(op_file, return, false);
            writeln(op_file, 'rpc_ret)');
        end {if};

  {* generate UNpacking statements for OUT and INOUT params *}
        if list <> nil then gen_pack_pils(op_file, list, outok, false);

  {* clear up everything and exit *}

        writeln(op_file, '   rpc_end_call(rpc_p_buf)');

        if b_type = functok then begin
            write  (op_file, '   ');
            write_name(op_file, name);
            writeln(op_file,    '=rpc_ret');    { Define function value }
        end {if};
        write(op_file, 'END');
        if b_type = functok then write(op_file, 'DEF')
            else write(op_file, 'SUB');
        writeln(op_file);

        writeln(op_file);
    end {with}
 end; {gen_client_block}

PROCEDURE gen_client_header;

{
Generates:      The CLIENT module header
                The constant and type definitions
}
begin {GEN_CLIENT_HEADER}

    writeln(op_file,'!---');
    write  (op_file,'!---  CLIENT STUB routines for package ');
    write_name(op_file, unitname);
    writeln(op_file);
    writeln(op_file,'!---');
    writeln(op_file,'!---  Generated automatically by the RPC Compiler');
    writeln(op_file,'!---');

    writeln(op_file);
    writeln(op_file, 'OPTION IMPLICIT OFF');
    writeln(op_file, 'OPTION BASE 1');

    write(op_file, 'MODULE CLI');
    write_name_pils(op_file, unitname);
    writeln(op_file);
    writeln(op_file);

    write(op_file, 'GLOBAL INT h_');
    write_name_pils(op_file, unitname);
    writeln(op_file);
    writeln(op_file);

    { generate_externals; }

end; {GEN_CLIENT_HEADER}

 procedure gen_open;
 begin
    write(op_file, 'SUB open_');
    write_name_pils(op_file, unitname);
    writeln(op_file, '()');
    writeln(op_file, '   INT status');
    writeln(op_file, '   CHAR service');
    writeln(op_file);

    write(op_file, '   service = ');
    write_name_padded_pils(op_file, unitname, '"');
    writeln(op_file);

    write(op_file, '   rpc_open(status,h_');
    write_name_pils(op_file, unitname);
    writeln(op_file, ',service)');

    writeln(op_file, '   rpc_report_error(status)');
    writeln(op_file, 'ENDSUB');
    writeln(op_file);
    IF NOT runoptions[noautoinit].value THEN
         BEGIN
         writeln(op_file,
         '!---  This procedure will be called at initialisation time ***');
         write(op_file, 'open_');
         write_name_pils(op_file, unitname);
         writeln(op_file, '()');
         writeln(op_file);
         END;

 end; {GEN_OPEN}

begin {client_generator_pils}

    gen_client_header;

{*      Generate procedures *}

    proc_number := 1;
    scan := blockptr;
    while scan <> nil do begin
        gen_client_block(scan);
        proc_number := proc_number + 1;
        scan := scan^.next;
    end;

    gen_open;

    writeln(op_file, 'ENDMODULE');

end; {CLIENT_GEN_pils}



{*****************************************************************************

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

}
PROCEDURE server_generator_pils;

var     i,                      { Label counter for computed goto }
        proc_num :  integer;
        scan:       ptr_block_table;


{_____________________________________________________________________________

        Generate server stub for one procedure
}
 procedure gen_r_routine;
 var a,b : integer;
 begin

    write(op_file, 'SUB r_');
    write_name(op_file, scan^.name);
    writeln(op_file, '(INOUT INT rpc_p_buf)' );

    generate_types_pils;              { Declare structure types   }

    gen_params_pils(scan^.list);      { Declare types of parameters }
    writeln(op_file);

    b := scan^.blk_nesting;
    IF b > 0 THEN write(op_file, '   INT rpc_a');
    for a := 2 to b do
            write(op_file, ',rpc_', chr(ord('a') - 1 + a));
    writeln(op_file);
    writeln(op_file);

{   Generate UNpacking statements for IN and INOUT params:
}
    if scan^.list <> nil then gen_pack_pils(op_file, scan^.list, intok, false);

  {* generate call and bookeeping *}
    writeln(op_file,'   rpc_init_return(rpc_p_buf)');

    if  (scan^.b_type = proctok)
        and scan^.in_only
    then if ((runoptions[concurrent].value) or scan^.blk_concurrent)
          then writeln(op_file, '   rpc_early_return(rpc_p_buf)')
         else if scan^.blk_cast
          then writeln(op_file, '   rpc_no_return(rpc_p_buf)');

  {* if function: generate return variable, else just call subroutine.*}
    write(op_file, '   ');
    if scan^.b_type = functok
        then pack_simple_pils(op_file, scan^.return, true);
    write_name(op_file, scan^.name);
    gen_formals(scan^.list);
    if scan^.b_type = functok then write(op_file, ')');
    writeln(op_file);

  {* generate packing statements for OUT and INOUT params*}
    if scan^.list <> nil then gen_pack_pils(op_file, scan^.list, outok, true);

    writeln(op_file, 'ENDSUB');
    writeln(op_file);                       { Blank line after each one }
 end {gen_r_routine};
{_____________________________________________________________________________}

{       Generate Code to Attach stub to RPCRTS
        --------------------------------------
}

procedure gen_attach;
begin

  if not runoptions[noautoinit].value then writeln(op_file,
                '!---  Call this procedure at initialisation time ***');
  write(op_file, 'SUB attach_');
  write_name_pils(op_file, unitname);
  writeln(op_file, '()');

  writeln(op_file, '   INT status');
  writeln(op_file, '   CHAR service');
  writeln(op_file);
  write (op_file,  '   service = ');
  write_name_padded_pils(op_file, unitname, '"');
  writeln(op_file);

  write(op_file, '   rpc_attach_stub(status,address(r_');
  write_name_pils(op_file, unitname);
  writeln(op_file, '),service,program_number)');

  writeln(op_file, '   rpc_report_error(status);');

  writeln(op_file, 'ENDSUB');
  writeln(op_file);

end; {GEN_ATTACH}

{_____________________________________________________________________________

        Generate Code to Detach stub from RPCRTS
        ----------------------------------------
}

procedure gen_detach;
begin

  if not runoptions[noautoinit].value then writeln(op_file,
                '!---  Call this procedure at exit time ***');
  write(op_file, 'SUB detach_');
  write_name_pils(op_file, unitname);
  writeln(op_file, '()');
  writeln(op_file);

  writeln(op_file, '   rpc_detach_stub(program_number)');

  writeln(op_file, 'ENDSUB');
  writeln(op_file);

end; {GEN_DETACH}

{       Generate Main Server Procedure
        ------------------------------
}

begin {server_generator_pils}

  writeln(op_file,'!---');
  write  (op_file,'!---  SERVER STUB routines for package ');
  write_name(op_file, unitname);
  writeln(op_file);
  writeln(op_file,'!---');
  writeln(op_file,'!---  Generated automatically by the RPC Compiler');
  writeln(op_file,'!---');

  writeln(op_file);
  writeln(op_file, 'OPTION IMPLICIT OFF');
  writeln(op_file, 'OPTION BASE 1');

  write(op_file, 'MODULE SER');
  write_name_pils(op_file, unitname);
  writeln(op_file);
  writeln(op_file,'HIDDEN INT program_number');
  writeln(op_file);

{       Generate individual routines for each procedure:
        -----------------------------------------------
}
  scan := blockptr;
  proc_num := 0;
  while scan <> nil do begin
          proc_num := proc_num + 1; { Count the procedures }
          gen_r_routine;            { Generate the individual stub subroutines }
          scan := scan^.next;
  end {while};

{       Generate the main server stub subroutine:
        ----------------------------------------
}
  writeln(op_file, '!---');
  writeln(op_file, '!---        Main stub entry point');
  writeln(op_file, '!---');
  write  (op_file, 'SUB r_');
  write_name(op_file, unitname);
  writeln(op_file, '(INOUT INT rpc_p_buf)');
  writeln(op_file, '   INT16 rpc_request');
  writeln(op_file);
  writeln(op_file, '   upk_short(rpc_p_buf,rpc_request)');
  if version_num <> 0 then begin
        writeln(op_file, '   IF (rpc_request # 0) AND (rpc_request # ',
                           version_num:1, ') THEN');
        writeln(op_file,
            '      rpc_set_error(rpc_p_buf,rpc_s_unsupported_version)');
        writeln(op_file, '   ELSE');
  end {if version number used };
  writeln(op_file, '      upk_short(rpc_p_buf,rpc_request)');

  writeln(op_file, '      SELECT rpc_request');

  scan := blockptr;
  proc_num := 1;
  while scan <> nil do
  begin
      writeln(op_file, '      CASE ',proc_num:2);
      write(op_file,   '         r_');
      write_name_pils(op_file, scan^.name);
      writeln(op_file, '(rpc_p_buf)');
      proc_num := proc_num + 1;
      scan := scan^.next;
  end;

  writeln(op_file, '      CASE ELSE ');
  write(  op_file, '         ');
  writeln(op_file, 'rpc_set_error(rpc_p_buf,rpc_s_bad_procedure_number)');
  writeln(op_file, '      ENDSELECT');
  if version_num <> 0 then writeln(op_file, '   ENDIF');
  writeln(op_file, 'ENDSUB');
  writeln(op_file);

{       Generate Code to Attach stub to RPCRTS
        --------------------------------------
}
  gen_attach;
  gen_detach;

  writeln(op_file, 'ENDMODULE');

end; {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
        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)
        30 Nov 89       Bug fix: string length in vaxpas is short, not int.
         6 Dec 89       Bug fix: handle was declared int in client.
         5 Feb 90       Change rpcheader.h to rpcrts.h for VM/CMS length limit.
        28 Mar 90       Buffer fragmentation code put in. rpc_begin() used.
        14 Nov 90       User data passed by REFERENCE to external marshalling
                        routine pck_tttt(buf, &data).
                        Bug out: "level+1" passed on by ACCESS marshalling
                        caused undeclared local variable to be used. TBL/CB
}
{____________________________________________________________________________

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

    Code generator errors are internal errors or target-dependent error.
}
procedure codegen_error(why: error_string);
begin
    writeln(' RPCC: **** Error: ', why);
    writeln('       (Error detected at code generator stage.)');
    halt;
end;
{____________________________________________________________________________
}
{       Write language elements to file:
        -------------------------------
}
procedure writok(var where: text; what: type_token);
begin
    case what of
        chartok :       write(where, 'rpc_char');
        bytetok :       write(where, 'rpc_byte');
        shortok :       write(where, 'rpc_short');
        integertok:     write(where, 'rpc_integer');
        real32tok:      write(where, 'rpc_real32');
        real48tok:      write(where, 'rpc_real48');
        real64tok:      write(where, 'rpc_real64');
        real128tok:     write(where, 'rpc_real128');
        longtok :       write(where, 'rpc_long');
        arraytok,
        sequence,
        stringtok,
        substring:      begin
                            if omode in Cmode then write(where, '[')
                                else write(where, 'ARRAY [1..');
                        end;
        proctok :       if not (omode in Cmode) then write(where, 'PROCEDURE ');
        functok :       if not (omode in Cmode) then write(where, 'FUNCTION ');
    end;
end;
{___________________________________________________________________________

        Indenting algorithm
}
function LeftIn(level: integer): integer;
begin
    LeftIn := level*3
end;

{___________________________________________________________________________
}
procedure write_declaration(var where: text; prefix: char;
                            ptr: ptr_idlist; ref: boolean);
begin
    with ptr^ do
    begin
        if not (omode in Cmode) then begin
            if ref then write(where, 'VAR ');
            if prefix <> ' ' then write(where, prefix, '_');
            write_name(where, name);
            write(where, ': ');
        end;

        with id_type^ do
            if typ_name <> nil then write_name(where, typ_name^.nty_name)
            else codegen_error(
                'Internal error: Unnamed type when name needed!  ');

        if omode in Cmode then begin
            write(where, ' ');
            if ref then write(where, '*');
            if prefix <> ' ' then write(where, prefix, '_');
            write_name(where, name);
        end
    end;
end;
{___________________________________________________________________________

        Generate:   Declatation of an integer
}
procedure write_integer(var where:  text;       { output file }
                            prefix: char;       { Space, or l or s for example }
                        var name:   id_name;    { Variable name }
                            ref : boolean);     { Pass by reference? }
begin
    write(where, '    ');
    if omode in Cmode then write(where, 'rpc_integer ');
    if ref then
        if omode in Cmode then write(where, '*')
            else write(where, 'VAR ');
    if prefix <> ' ' then write(where, prefix, '_');
    write_name(where, name);
    if not (omode in Cmode) then write(where, ' : rpc_integer');
end;

{___________________________________________________________________________

        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:
}
function contains(pt: ptr_defined_type; typeset: set_of_token): boolean;
var scan:   ptr_named_type;
begin
    with pt^ do begin
    contains := typ_basic_type in typeset;
    case typ_basic_type of

        chartok,
        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok,
        substring,
        sequence,
        stringtok:          { ok };

        accesstok,
        arraytok: if contains(typ_subtype, typeset) then contains := true;

        recordtok: begin
            scan := typ_fields;
            while scan <> NIL do with scan^ do begin
                if contains(nty_type, typeset) then contains := true;
                scan := nty_next;
            end {while};
        end {recordtok};

     end {case};
    end {with}
end; {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;
}
procedure decl_ext_marshal;
var pnt:    ptr_named_type;
    topack: boolean;
begin
    pnt := typeptr;
    while pnt <> NIL do begin
        if pnt^.nty_type^.typ_external then
        for topack := FALSE to TRUE do begin
            if omode in Cmode then begin
                write(op_file, 'extern ', upkpck[topack], '_');
                write_name(op_file, pnt^.nty_name);
                writeln(op_file, '();');
            end else begin
                write(op_file, 'procedure ', upkpck[topack], '_');
                write_name(op_file,  pnt^.nty_name);
                writeln(op_file, '(var rpc_p_buf: rpc_message_pointer;');
                write(op_file, '    ');
                if not topack then write(op_file, 'var ');
                write(op_file, 'param: ');
                write_name(op_file,  pnt^.nty_name);
                if (omode in [M6809])
                    then writeln(op_file, '); EXTERNAL; ')
                    else writeln(op_file, '); EXTERN; ');
            end {if pascal}
        end {if for};
        pnt := pnt^.nty_next;
    end {while};
end {decl_ext_marshal};


{_____________________________________________________________________________

                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));
}
procedure gen_allocate( var where:  text;
                        expr:   expression;         { ... for the variable }
                        pt:     ptr_defined_type;
                        level:  integer;            { nesting so far }
                        do_alloc: boolean;          { T: all, F: deallocate }
                        typeset:    set_of_token);   { types to allocate }

var scan:   ptr_named_type;
    exp2:   expression;
    ch:     char;

begin
    ch := chr(ord('a')+level-1);
    with pt^ do
     case typ_basic_type of

        chartok,                    { First token, simple type, courier type }
        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok,                    { Last simple type }
        substring:          { Do nothing };

{   Pointers are deallocated after having recursively deallocated anything
    they point to.
}
        accesstok: if typ_basic_type in typeset then begin
            if do_alloc then codegen_error(
                    'Internal:  Call GEN_ALLOCATE to allocate pointer');
            exp2 := expr;
            if omode in Cmode then begin
                write  (where, ' ':LeftIn(level),   'if ('              );
                write_exp(where,                    expr                );
                write(where,                        ') {'               );
                format(exp2, '(*$)      ');
                gen_allocate(where, exp2, typ_subtype,
                        level+1, do_alloc, typeset);
                write(where, ' ':LeftIn(level+1),   'free('             );
                write_exp(where,                    expr                );
                writeln(where,                      ');'                );
                writeln(where, ' ':LeftIn(level),   '} /* end if */'    );
            end else begin
                write  (where, ' ':LeftIn(level),   'if ');
                write_exp(where,                    expr                );
                writeln(where,                      ' <> NIL then begin');
                format(exp2, '$^        ');
                gen_allocate(where, exp2, typ_subtype,
                        level+1, do_alloc, typeset);
                write(where, ' ':LeftIn(level+1),   'dispose('          );
                write_exp(where,                    expr                );
                writeln(where, ' ':LeftIn(level+1), ');'                );
                writeln(where, ' ':LeftIn(level),   'end {if};'         );
            end {pascal};
        end;

        stringtok: if (omode=vaxvms) and (stringtok in typeset) then begin
            if do_alloc then begin
                  write  (where, '   with ');
                  write_exp(where, expr);
                  writeln(where, ' do begin new(StrAdr); strlen :=',
                          typ_high:1, '; { Init. string descriptor }');
                  writeln(where, '     DType := 0; Cont := 0; end;'); {ok?@@@}
            end else begin
                write(where, ' ':LeftIn(level), 'dispose(');
                write_exp(where, expr);
                writeln(where,  '.StrAdr);');
            end;

        end {stringtok};

        arraytok: if contains(typ_subtype, typeset) then begin
            exp2 := expr;
            append_index(exp2, level);

            write(where, ' ':LeftIn(level));
            if not (omode in Cmode)
            then begin
                writeln(where, 'FOR rpc_', ch, ' := ',
                        typ_low:1, ' TO ', typ_high:1, ' DO BEGIN')
            end else begin
                write(where, 'for (rpc_', ch, ' = 0; rpc_', ch, '<',
                         typ_high - typ_low + 1:1, '; rpc_', ch, '++) {');
            end {if};

            gen_allocate(where, exp2, typ_subtype, level+1, do_alloc, typeset);

            if omode in Cmode
            then writeln(where, ' ':LeftIn(level), '      }')
            else writeln(where, ' ':LeftIn(level), 'END {FOR};');
        end {arraytok};

        recordtok: begin
            scan := typ_fields;
            while scan <> NIL do with scan^ do begin
                exp2 := expr;
                append_1(exp2,'.');
                append_name(exp2, nty_name);
                gen_allocate(where, exp2, nty_type, level, do_alloc, typeset);
                scan := nty_next;
            end {while};
        end {recordtok};

     end {with, case};
end; {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,
}
procedure dopack_simple(var where: text; what : type_token; topack: boolean);
begin
    write(where, upkpck[topack], '_');
    case what of
        chartok:        write(where, 'char(');
        bytetok:        write(where, 'byte(');
        shortok:        write(where, 'short(');
        integertok:     write(where, 'integer(');
        real32tok:      write(where, 'real32(');
        real48tok:      write(where, 'real48(');
        real64tok:      write(where, 'real64(');
        real128tok:     write(where, 'real128(');
        longtok:        write(where, 'long(');
    end;
    write(where, 'rpc_p_buf, ');
end;

{___________________________________________________________________________

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

    Currently, only aligns on word boundaires, because that is all
    we need.
}
procedure gen_align(    var where:  text;
                            power:  integer);
begin
            if power <> 1 then codegen_error(
                'Internal error: Gen_align on non-word boundary! ');

            if odd(size_so_far) then size_so_far := size_so_far+1;

            if not (omode in Cmode) then begin
                writeln(where,
                        '    IF ODD(m_index) THEN m_index:=m_index+1;');
            end else begin
                writeln(where,
                    '    if (rpc_p_buf->m_index%2) rpc_p_buf->m_index++;');
            end {if};

end {gen_align};

{___________________________________________________________________________

        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.
}
procedure gen_pack_type(var where:  text;       { output file }
                            expr:    expression;{ Expression for variable }
                            typ:    ptr_defined_type;   { type descriptor }
                            level:  integer;    { indentation & rpc_<level> }
                            deref:  boolean;    { Dereference simple types? }
                            topack: boolean;    { pack or unpack? }
                            check_size: boolean);{ check for buffer overflow? }
var ch:     char;
    scan:   ptr_named_type;
    exp2:   expression;
    l_expr,                 { Expression for the length of a string, etc }
    s_expr: expression;     { Expression for the start of a substring }
    i:      integer;        { Loop index }
    original_size: integer;  { Max size packed before this call }
    check_subtypes: boolean; { Pass check_size down to subtypes? }

{___________________________________________________________________________

        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.
}
 PROCEDURE gen_pack_string(var  where: text;
                expr:   expression;         { string variable name }
                pt:     ptr_defined_type;   { data type }
                level:  integer;            { indentation level }
                topack: boolean);           { pack or unpack? }

 VAR
        index_a,
        index_b:        char;           { last character of name of index }
        a_expr,                         { One element of the string }
        i_expr,                         { The integer value of the length }
        l_expr:         expression;     { Expression for the length variable }

 BEGIN {gen_pack_string}

    index_a := chr( ord('a')+level-1);  { rpc_a etc }
    index_b := chr( ord('a')+level);    { rpc_b etc }

    with pt^ do
    if omode in Cmode then begin

        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 then begin
                writeln(where, ' ':LeftIn(level), 'for (rpc_',index_b,
                    ' = 0; rpc_',index_b,' <= ',
                     typ_high:1, '; rpc_',index_b,'++)');
                write(where, ' ':LeftIn(level), 'if (');
                write_exp(where, expr);
                writeln(where, '[rpc_',index_b,'] == ''\0'') break;');
        end;

{   (un)pack the length of the string :
}
        gen_pack_type(where, l_expr, simple_descriptor[integertok],
                level, FALSE, { Don't dereference locals }
                topack, check_subtypes);

{   Generate the for loop:
}
        writeln(where, ' ':LeftIn(level),           { a := 0 to b }
                'for (rpc_',index_a,' = 0; rpc_', index_a,
                ' < rpc_',index_b,'; rpc_',index_a,'++) {');

{   Pack each character:
}
        gen_pack_type(where, a_expr, simple_descriptor[chartok],
                level, false {deref}, topack, check_subtypes);

{   Terminate the for loop:
}
        writeln(where, ' ':LeftIn(level), '}');

{   Add the terminator in memory:
}
        if not topack then
        begin
                write(where,    ' ':LeftIn(level));
                write_exp(where, expr);
                writeln(where,  '[rpc_',index_b,'] = ''\0'';');
        end;

        size_so_far := original_size  + typ_max_size;

    end else begin {not C -- Pascal: - - - - - - - - - - - - - - - - - - - - -}

{   VAX/VMS descriptors are handled by a subroutine:
}
      if omode = vaxvms then begin

            write(where, ' ':LeftIn(level), upkpck[topack]);
            if (not client and not topack)
                then write (where, '_Vstring_for(rpc_p_buf, ') {server unpck }
                else write (where, '_string_for(rpc_p_buf, ');
            write_exp(where, expr);
            write(where, '::rpc_string_descriptor');           { Standard Descriptor }
            if (not client and not topack)
                then write(where, ', ',typ_high:1);    { Max size }
            writeln(where, ');');

{   Generate expressions for the length of the string:
}
      end else begin
        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 omode in [m6809, pcturbo, macturbo] then begin
            format(l_expr, '$[0]      ');
            format(i_expr, 'ord($[0]) ');
        end else if omode = vaxpas then begin
            format(l_expr, '$.length  ');
            i_expr := l_expr;           { The expression already is an integer }
        end else begin
            format(l_expr, 'l_$       ');
            format(a_expr, 'a_$       ');
            i_expr := l_expr;           { The expression already is an integer }
            if level <> 1 then codegen_error(
                    'String in composite type illegal for this target')
        end {if};
        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.
}
        write(where, '    ');
        if omode in [m6809, pcturbo, macturbo] then
                if topack then begin
                    gen_pack_type(where, i_expr,
                         simple_descriptor[integertok], level+2, false,
                         topack, check_subtypes);
                end else begin
                    write(where, ' ':LeftIn(level));
                    write_exp(where, l_expr);
                    writeln(where, ' := rpc_ch[m_index + 1];');
                    write(where, ' ':LeftIn(level));
                    write(where, 'm_index := (m_index + 2);');
                end

        else begin
            if (omode=vaxpas) then              { string length is short }
                gen_pack_type(where, l_expr,
                        simple_descriptor[shortok],
                        level+2, false {deref}, topack, check_subtypes)
            else
                gen_pack_type(where, l_expr,
                        simple_descriptor[integertok],
                        level+2, false {deref}, topack, check_subtypes);
        end;

{   Generate the FOR loop:
}
        write(where, ' ':LeftIn(level), 'FOR rpc_',index_a,' := 1 TO ');
        write_exp(where, i_expr);
        writeln(where, ' DO BEGIN');

{   Generate the code to (un)pack the character
}
        gen_pack_type(where, a_expr, simple_descriptor[chartok], level+2,
            false {deref}, topack, check_subtypes);

{   Terminate the FOR loop:
}
        writeln(where, ' ':LeftIn(level), 'END {for ');
        write_exp(where, i_expr);
        writeln(where, '};');

      end {if not VAXVMS pascal };
      size_so_far := original_size  + typ_max_size ;
    end {if not C };
 END {gen_pack_string};


{       Check Buffer Overflow if necessary
        ----------------------------------

    An attempt is made to optimise the tradeoff of the execution of checking
    code, against the efficiency of filling the buffers. Hence, small
    composite types are not allowed to cross buffer boundaries.
    There are three conditions for inserting the overflow check:

    1.  The parameter check_size indicates that this type is not a component
        of a larger type which has already been checked;

    2.  It is possible that, after marshalling this type, that the packet
        size (NON_FRAGMENTATION_LIMIT) might be exceeded.

    3.  The maximum size of this type must be less than or equal the
        FRAGMENTATION_THRESHOLD: If it is greater, then we check each of
        the subtypes individually. The threshold must be set so that all
        atomic types are checked.

    If the last test fails, then we have to turn on checking in the subtypes.
}
 PROCEDURE check_buffer_overflow(allowance: integer);
 BEGIN
     if check_size
     and ((size_so_far + allowance) > NON_FRAGMENTATION_LIMIT)
     then if (allowance <= FRAGMENTATION_THRESHOLD)
     then begin
        fragmentation_used := TRUE;
        if omode in Cmode then begin
              write(where, ' ':LeftIn(level)+4,
                'if (rpc_p_buf->m_index > RPC_BUFFER_SIZE - ',allowance:1,
                ') (void)rpc_');
              if topack then writeln(where, 'put(&rpc_p_buf);')
                        else writeln(where, 'get(&rpc_p_buf);');
        end else begin
              write(where, ' ':LeftIn(level)+4,
                'if (rpc_p_buf^.m_index > RPC_BUFFER_SIZE - ',allowance:1,
                ') then rpc_');
              if topack then writeln(where, 'put(rpc_p_buf);')
                        else writeln(where, 'get(rpc_p_buf);');
        end {pascal};
     end{ if};
 end;


{_____________________________________________________________________________
                    Main block of gen_pack_type
}
BEGIN {gen_pack_type}

   original_size := size_so_far;        { We will update it }

   {    Generate a few useful expressions: }

    ch := chr(ord('a')+level-1); {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 the type is marshalled by an external routine, just generate a call
    to that routine:
}
    with typ^ do
    if typ_external then begin
        write(where, ' ':LeftIn(level), upkpck[topack], '_');
        write_name(op_file, typ_name^.nty_name);
        write(where, '(rpc_p_buf,');
        if omode in Cmode then write(where, '&');
        write_exp(where, expr);
        writeln(where, ');');

    end else begin

     check_subtypes := check_size
         and (size_so_far + typ_max_size > NON_FRAGMENTATION_LIMIT)
         and (typ_max_size > FRAGMENTATION_THRESHOLD);

     check_buffer_overflow(typ_max_size);

     case typ_basic_type of
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                        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.

}
        chartok: begin
            if (omode in Cmode) or topack or (expr.str[expr.len]<>']')
            then begin
                write(where, ' ':LeftIn(level), upkpck[topack], '_char(rpc_p_buf, ');
                if (level=1) and deref and (omode in Cmode)
                    then write(where, '*');
                write_exp(where, expr);
                writeln(where, ');');
            end else begin {pascal unpack}
                writeln(where, ' ':LeftIn(level), 'BEGIN');
                write(where, ' ':LeftIn(level)+4);
                write_exp(where, expr);
                writeln(where, ':=rpc_ch[m_index];');
                writeln(where, ' ':LeftIn(level)+4, 'm_index := m_index+1;');
                writeln(where, ' ':LeftIn(level), 'END;');
            end;
            size_so_far := size_so_far+1;
        end;

        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin
            write(where, ' ':LeftIn(level), upkpck[topack]);
            with typ_name^.nty_name do
                for i := 4 to len do write(where, str[i]);  { eg "_integer" }
            write(where, '(rpc_p_buf, ');
            if (level=1) and deref and (omode in Cmode)
                then write(where, '*');
            write_exp(where, expr);
            writeln(where, ');');
            case typ_basic_type of
                bytetok:    size_so_far := size_so_far + 1;
                shortok,
                integertok: size_so_far := size_so_far + 2;
                real32tok,
                longtok:    size_so_far := size_so_far + 4;
                real48tok:  size_so_far := size_so_far + 6;
                real64tok:  size_so_far := size_so_far + 8;
                real128tok: size_so_far := size_so_far + 16;

            end;
        end {simple type };

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        arraytok: begin                                 { A R R A Y }
            exp2 := expr;
            append_index(exp2, level);

            write(where, ' ':LeftIn(level));
            if not (omode in Cmode)
            then begin
                writeln(where, 'FOR rpc_', ch, ' := ',
                        typ_low:1, ' TO ', typ_high:1, ' DO BEGIN')
            end else begin
                writeln(where, 'for (rpc_', ch, ' = 0; rpc_', ch, '<',
                         typ_high - typ_low + 1:1, '; rpc_', ch, '++) {');
            end {if};

{   When making the recursive call to the subtype packing, size_so_far must
    already be increased to the maximum size, so that the checking code will
    be put in if necessary. As size_so_far is corrupted by that call, it must
    be reset again afterward.
}
            size_so_far := original_size+typ_max_size;
            gen_pack_type(where, exp2, typ_subtype, level+1,
                                    false {deref}, topack, check_subtypes);
            size_so_far := original_size+typ_max_size;

            if omode in Cmode
            then writeln(where, ' ':LeftIn(level), '}')
            else writeln(where, ' ':LeftIn(level), 'END {FOR};');

        end {arraytok};
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

                                                        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.
}
        recordtok: begin
            scan := typ_fields;
            while scan <> NIL do with scan^ do begin
                exp2 := expr;
                if (level=1) and deref and (omode in Cmode)
                    then format(exp2, '$->       ')
                    else format(exp2, '$.        ');
                append_name(exp2, nty_name);
                gen_pack_type(where, exp2, nty_type, level, false,topack,
                                check_subtypes);
                scan := nty_next;
            end {while};
        end {recordtok};
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
                                                        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(rpc_p_buf,0)   if (!x) pck_byte(rpc_p_buf,0)
|       else begin                              else [
|           pck_byte(rpc_p_buf,1);               pck_byte(rpc_p_buf,1);
|           ...                                     ...
|       end;                                    ] /* end if */
}
        accesstok: begin

            if check_subtypes then
                check_buffer_overflow(1);       { Check we aren't on the end }
            size_so_far := size_so_far + 1;     { For flag }
            if omode in Cmode then begin
                if (level=1) and deref then begin
                    exp2 := expr;                       { The thing pointed to }
                    format(expr, '(*($))    ');         { Dereference }
                    format(exp2, '(**($))   ');
                end else begin
                    exp2 := expr;                       { The thing pointed to }
                    format(exp2, '(*($))    ');
                end;
                if not topack then begin

{                   If the pointer was NULL, set it to 0:
}
                    write(where,        ' ':LeftIn(level));
                    writeln(where,    'if (next_byte(rpc_p_buf)) {' );

{                   Allocate space:
}
                    write(where,        ' ':LeftIn(level+1));
                    write_exp(where, expr);
                    if typ_subtype^.typ_name=NIL then codegen_error(
                      'Pointer to unnamed type - cannot allocate space!');
                    write(where, ' = (');
                    write_name(where, typ_subtype^.typ_name^.nty_name);
                    write(where, '*) malloc(sizeof(' );
                    write_name(where, typ_subtype^.typ_name^.nty_name);
                    writeln(where, '));');

{                   The level must be passed on unaltered, as we do not
                    need an extra local variable. The indentation is less
                    neat, but that can't be helped.
}
                    gen_pack_type(where, exp2, typ_subtype,
                                        level, false, topack, check_subtypes);

                    writeln(where, ' ':LeftIn(level),   '} else {');
                    write(where,        ' ':LeftIn(level+1));
                    write_exp(where, expr);
                    if typ_subtype^.typ_name=NIL then codegen_error(
                      'Pointer to unnamed type - cannot allocate space!');
                    write(where, ' = (');
                    write_name(where, typ_subtype^.typ_name^.nty_name);
                    writeln(where, '*) 0;' );
                    writeln(where, ' ':LeftIn(level),   '} /* end if */');

                end {if unpack} else begin {pack}

                    write  (where, ' ':LeftIn(level),  'if (!');
                    write_exp(where,                   expr);
                    writeln(where, ') pck_byte(rpc_p_buf,0);');
                    writeln(where, ' ':LeftIn(level),  'else {');
                    writeln(where, ' ':LeftIn(level+1),
                        'pck_byte(rpc_p_buf,1);');

                    gen_pack_type(where, exp2, typ_subtype,
                                        level, false, topack, check_subtypes);

                    writeln(where, ' ':LeftIn(level),   '} /* end if */');

                end {packing};
            end else begin {Pascal}

                exp2 := expr;
                append_1(exp2, '^');            { x^ }

                if not topack then begin

{                   If the pointer was NIL, skip the lot:
}
                    writeln(where,      'm_index:=m_index+1;');
                    writeln(where, ' ':LeftIn(level),
                                        'if b[m_index-1]<>0 then begin');
{                    Allocate space:
}
                    write(where,' ':LeftIn(level+1),    'new('      );
                    write_exp(where,                    expr        );
                    writeln(where,                      ');'        );

                end else begin {if topack}
                    write  (where, ' ':LeftIn(level),   'if ');
                    write_exp(where,                    expr);
                    writeln(where, ' = NIL then pck_byte(rpc_p_buf,0)');
                    writeln(where, ' ':LeftIn(level),   'else begin');
                    writeln(where, ' ':LeftIn(level+1),
                        'pck_byte(rpc_p_buf,1);');

                end {if topack};
                gen_pack_type(where, exp2, typ_subtype, level, false, topack,
                    check_subtypes);
                writeln(where, ' ':LeftIn(level),   'end {if};');

            end {if Pascal}
        end {accesstok};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        sequence: begin                                 { S E Q U E N C E }
            If level>1 then codegen_error(
                'SEQUENCE type not allowed within composite type.');

            gen_pack_type(where, l_expr,
                    simple_descriptor[integertok],level, deref, topack,
                        check_subtypes);

            exp2 := expr;
            format(exp2, 'a_$       ');     { Make an expression for the array}
            append_index(exp2, level);      { Make expression for an element }

            write(where, ' ':LeftIn(level));
            if not (omode in Cmode)
            then begin
                write(where,    'FOR rpc_', ch, ' := 1 TO l_');
                write_exp(where, expr);
                writeln(where,  ' DO BEGIN')
            end else begin
                write(where, 'for (rpc_', ch, ' = 0; rpc_', ch, '< ');
                if deref and (omode in Cmode) then write(where, '*');
                write_exp(where, l_expr);
                writeln(where,'; rpc_', ch, '++) {');
            end {if};

            size_so_far := original_size + typ_max_size;{ See comment for array }
            gen_pack_type(where, exp2, typ_subtype, level+1, false {deref},
                                                topack, check_subtypes);
            size_so_far := original_size + typ_max_size;{ See comment for array }

            if omode in Cmode
            then writeln(where, ' ':LeftIn(level), '      }')
            else writeln(where, ' ':LeftIn(level), 'END {FOR};');
        end {sequence};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
        stringtok: begin                                { S T R I N G }

            gen_pack_string(where, expr, typ, level, topack);
            gen_align(where, 1);    { Align on word boundary }

        end {stringtok};

{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|                                                         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.
}
        substring: begin

            exp2 := s_expr;                     { Start Position In String }
            gen_pack_type(where, exp2,
                        simple_descriptor[integertok],level, deref, topack,
                        check_subtypes);

            gen_pack_type(where, l_expr, simple_descriptor[integertok],
                        level, deref, topack, check_subtypes);

{ 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 BEGIN             }

            if omode in Cmode then begin
                write(where, '    for (rpc_', ch, ' = ');
                if deref then write(where, '*');
                write_exp(where, s_expr);
                write(where,    '-1; rpc_', ch, ' < ');
                if deref then write(where, '*');
                write_exp(where, l_expr);
                write(where, ' + ');
                if deref then write(where, '*');
                write_exp(where, s_expr);
                writeln(where, '-1; rpc_', ch, '++) {')

            end else begin

                write(where,    '    FOR rpc_', ch, ' := ');
                write_exp(where, s_expr);
                write(where,    ' TO ');
                write_exp(where, l_expr);
                write(where, '+');
                write_exp(where, s_expr);
                writeln(where, ' - 1 DO BEGIN')
            end;

            exp2:= expr;                {   x }
            prepend_1(exp2, '_');       {  _x }
            prepend_1(exp2, 'a');       { a_x }
            append_index(exp2, level);  { a_x[rpc_a] }

            size_so_far := original_size + typ_max_size;
            gen_pack_type(where, exp2, simple_descriptor[chartok],
                         level+1, FALSE {deref}, topack, check_subtypes);
            size_so_far := original_size + typ_max_size;

            if omode in Cmode then begin        { Terminate the loop }
                writeln(where, '    }')
            end else begin
                writeln(where,  '    END;');
            end;

            gen_align(where,1 );                { Align on word boundary }

        end {substring};

     end {case};
    end {if not external type }

END {gen_pack_type};

{___________________________________________________________________________

        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.

}
PROCEDURE gen_pack( var where:  text;           { Output file }
                        head:   ptr_idlist;     { Parameter list }
                        dirn:   attr_type;      { Parameter filter }
                        topack: boolean);       { Pack, rather than unpack? }

VAR expr:    expression;
BEGIN {GEN_PACK}
  Repeat
    with head^, id_type^ do begin


        { 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 (not client) and (not topack)
            and (omode=vaxvms)
            then if contains(id_type, [stringtok])
            then gen_allocate(where, expr, id_type, 1, TRUE {allocate},
                            [stringtok]);


{       Pack or unpack
        --------------
}
        if (attr = inoutok)
            or (attr = dirn)
        then begin
            deref := client
                    and not (runoptions[byvalue].value   {* not value param *}
                             and (attr = intok));    { and in-only param }

            gen_pack_type(where, expr, id_type, {level} 1, deref,
                    topack, TRUE {check for overflow});

        end {if};

{       Deallocate Memory
        -----------------
}
        if (not client) and topack              { ie end of server }

            then if omode = vaxvms then begin
                if contains(id_type, [stringtok, accesstok])
                then gen_allocate(where, expr, id_type, 1,
                                FALSE {deallocate}, [stringtok, accesstok]);

            end else begin {not vms}
                if contains(id_type, [accesstok])
                then gen_allocate(where, expr, id_type, 1,
                                FALSE {deallocate}, [accesstok]);
            end;


        { Remove client's tree for an IN OUT parameter }

        if client and (attr=inoutok) and topack
        then if contains(id_type, [accesstok])
        then gen_allocate(where, expr, id_type, 1, FALSE {deallocate},
                                    [accesstok]);

    end {with};
    head := head^.next;
  Until head = nil;
END; {GEN_PACK}


{               (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.
______________________________________________________________________________
}
procedure gen_header(var where: text;
                        ptr: ptr_block_table;
                        doing_externals,        { Making ext. declarations? }
                        parameters_wanted: boolean);

{____________________________________
}
  procedure gen_formals_c(head: ptr_idlist);

  { Generates the formal parameter list enclosed in brackets }
  var
        a:          integer;
        scan:       ptr_idlist;

  begin {gen_formals_c}

        {* We are sure that head is NOT nil *}

        a := 0;
        scan := head;
        write(where, '(');
        while scan <> NIL do begin
            if scan^.id_type^.typ_basic_type in [sequence, substring]
                    then write(where, 'a_');
            write_name(where, scan^.name);
            if scan^.id_type^.typ_basic_type = substring then
            begin
                write(where, ', s_');
                write_name(where, scan^.name);
                a := a + 1;
            end;
            if scan^.id_type^.typ_basic_type in [sequence, substring] then
            begin
                write(where, ', l_');
                write_name(where, scan^.name);
                a := a + 1;
            end;

            scan := scan^.next;
            if scan <> nil then
            begin
                write(where, ', ');
                a := a + 1;
                if a > 3 then
                begin
                    a := 0;
                    writeln(where);
                    write(where, '        ');
                end;
            end;
        end {while};
        writeln(where, ')');
  end; {gen_formals_c}
{____________________________________
}
  procedure gen_params(head: ptr_idlist);

{ 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.
}

  var
        a:          integer;
        scan:       ptr_idlist;
        ch:         char;
        simple_ref:  boolean;   { Should simple variables be dereferenced? }
        array_deref: boolean;   { what about composite variables? }
  begin {gen_params}

        {* We are sure that head is NOT nil *}


    scan := head;
    repeat
        write(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 or doing_externals)
                        and not (omode in Cmode);

{   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 or doing_externals)      { ie not server list }
                        and not ((runoptions[byvalue].value)
                                    and (scan^.attr = intok));

        with scan^.id_type^ do
        case typ_basic_type of

            chartok,
            bytetok,
            shortok, integertok,
            real32tok, real48tok,
            real64tok, real128tok,
            longtok,
            recordtok,
            accesstok:
                write_declaration(where, ' ', scan, simple_ref);{ xxxx : tttt }

            arraytok:                                       { xxxx : tttt }
                write_declaration(where, ' ', scan, array_deref);

            stringtok:
                begin                                  { (a_)xxx: tttt(;) }
                    if not(omode in(Cmode+
                        [vaxvms, vaxpas, m6809, pcturbo, macturbo]))
                    then begin
                        write_declaration(where, 'a', scan, array_deref);
                        writeln(where, ';');       { (l_xxx: rpc_integer) }
                        write_integer(where, 'l', scan^.name, simple_ref);
                    end else begin
                        write_declaration(where, ' ', scan, array_deref);
                    end;
                end;

            sequence:
                begin                                      { a_xxx: tttt; }
                    write_declaration(where, 'a', scan, array_deref);
                    writeln(where, ';');
                                                     { l_xxx: rpc_integer }
                    write_integer(where, 'l', scan^.name, simple_ref);
                end;

            substring:
                begin                                      { a_xxx: tttt; }
                    write_declaration(where, 'a', scan, array_deref);
                    writeln(where, ';');
                                                     { s_xxx: rpc_integer }
                    write_integer(where, 's', scan^.name, simple_ref);
                    writeln(where, ';');
                                                     { l_xxx: rpc_integer }
                    write_integer(where, 'l', scan^.name, simple_ref);
                end;

        end; {with, case}

        scan := scan^.next;
        if scan <> nil then
                writeln(where, ';')
   until scan = nil;

  end; {GEN_PARAMS}

{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
}
BEGIN {GEN_HEADER}

 with ptr^ do begin

        if omode in Cmode then begin            { C language }
            if client then begin
                if b_type = functok then
                begin
                    writok(where, return);      { eg:    int xxx(a,b,c)  }
                    write(where, ' ')
                end {function};
                write_name(where, name);
                gen_formals_c(list);    { Generate formal parameter list }

            end else begin                      { C server or externals }
                if not doing_externals  then write(where, 'r_');
                write_name(where, name);
                write(where, '()');
                if doing_externals then
                begin
                    writeln(where, ';');
                    write(where, '/*  Parameters: ');
                    if list = nil then write(where, 'none');
                end;
                writeln(where);
                if not doing_externals then writeln(where, '{');
            end {if not client}

        end else begin                          { Pascal }
             if (client or doing_externals) then begin
                writok(where, b_type);
                write_name(where, name);

             end else begin                             { Pascal server }
                writok(where, proctok);
                if not doing_externals  then write(where, 'r_');
                write_name(where, name);
                if not doing_externals then writeln(where, ';');
            end {server};
        end {Pascal};

{* PRINT PARAMETER LIST if necessary*}


        if parameters_wanted then
            if (list <> nil) then begin
                if not (omode in Cmode) then
                    if client or doing_externals then writeln(where, '(')
                else writeln(where, 'VAR');
                gen_params(list);
                if (client or doing_externals) and not (omode in Cmode)
                    then write(where, ')');
            end;
{* else
                if client and (omode in Cmode) then write(where,'()'); *}

{* PRINT RESULT only for client PASCAL functions *}

        if  not (omode in Cmode) then begin
            if (client or doing_externals) then begin
                if parameters_wanted
                    and (b_type = functok)
                then begin
                    write(where, ': ');
                    writok(where, return);
                end;
            end {if client }
        end {if Pascal};

        if      ((client or doing_externals) and not (omode in Cmode))
                or (list <> nil)
         then writeln(where, ';');

 end; {end_with}
END; {GEN_HEADER}


{___________________________________________________________________________

        Generate externals
        ------------------

Generates the list of external declarations of each procedure
or function.
}
PROCEDURE generate_externals;
var
        scan : ptr_block_table;
BEGIN
        scan := blockptr;
        while scan <> nil do begin
            if omode in Cmode then
            begin
                write(op_file, 'extern ');
                if scan^.b_type = functok then
                begin
                    writok(op_file, scan^.return);
                    write(op_file, ' ');
                end;
                gen_header(op_file, scan, TRUE {externals}, true);
                writeln(op_file, '    */');
            end
            else begin
                gen_header(op_file, scan, TRUE {externals}, true);
                if omode = m6809 then writeln(op_file, 'EXTERNAL;')
                    else writeln(op_file, 'EXTERN;');
            end;
            writeln(op_file);
            scan := scan^.next;
        end; {while}
END;

{___________________________________________________________________________

            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.
}

procedure gen_type_decl_C(var where:  text;             { output file }
                            expr:   expression;         { for the varaiable }
                            pt:     ptr_defined_type;   { type structure }
                            level:  integer);           { indentation }
var     scan:   ptr_named_type;
        exp2:   expression;
begin
    with pt^ do case typ_basic_type of

        chartok,                    { First token, simple type, courier type }
        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin
            write(where, ' ':LeftIn(level));
            write_name(where,
                simple_descriptor[typ_basic_type]^.typ_name^.nty_name);
            write(where, ' ');
            write_exp(where, expr);     { Example: rpc_char x }
        end {simple type};

        substring,
        stringtok:  begin               { Example: rpc_char x[81] }
                write(where, ' ':LeftIn(level));
                write(where, 'rpc_char ');
                write_exp(where, expr);
                write(where, '[', (typ_high+1):1, ']');
        end {stringtok};

        arraytok:   begin               { example  int x[100] }
                exp2 := expr;
                append_1(exp2,'[');
                append_decimal(exp2,typ_high-typ_low+1);
                append_1(exp2,']');
                gen_type_decl_c(where, exp2, typ_subtype, level);
        end {arraytok};

        sequence:   begin
                exp2 := expr;
                append_1(exp2,'[');
                append_decimal(exp2,typ_high-typ_low+1);    { 90613 }
                append_1(exp2,']');
                gen_type_decl_c(where, exp2, typ_subtype, level);
        end; {sequence}

        accesstok: begin
                exp2 := expr;
                prepend_1(exp2, '(');
                prepend_1(exp2, '*');
                append_1 (exp2, ')');   { Example:  int  (*x)   }
                gen_type_decl_c(where, exp2, typ_subtype, level);
        end;

        recordtok: begin
            writeln(where, ' ':LeftIn(level), 'struct {');
            scan := typ_fields;
            while scan <> NIL do begin
                        exp2.len := 0;
                        append_name(exp2, scan^.nty_name);
                        gen_type_decl_c(where, exp2, scan^.nty_type, level+1);
                        writeln(where, ';');
                        scan := scan^.nty_next;
            end {while};

            write(where, ' ':LeftIn(level), '} ');
            write_exp(where, expr);
        end;

    end {with, case};
end {gen_type_decl_c};
{___________________________________________________________________________

            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.
}

procedure gen_type_pas( var where:  text;               { output file }
                            pt:     ptr_defined_type;   { type structure }
                            level:  integer);           { indentation }
var     scan:   ptr_named_type;
        exp2:   expression;
begin
    with pt^ do
    if (level>1) and (typ_name <> NIL) then begin
        write_name(where, typ_name^.nty_name);
    end else case typ_basic_type of
        chartok,                    { First token, simple type, courier type }
        bytetok,
        shortok, integertok,
        real32tok, real48tok,
        real64tok, real128tok,
        longtok: begin          { Example:  rpc_char }
            write_name(where,
                simple_descriptor[typ_basic_type]^.typ_name^.nty_name);
        end {simple type};

        substring,
        stringtok:  begin               { Example: rpc_char x[81] }
                if (omode=vaxvms) and (typ_basic_type=stringtok) then begin
                    writeln(where, 'RECORD strlen: rpc_short;');
                    writeln(where,  ' ':LeftIn(level)+8,
                                    'DType, Cont: rpc_byte;');
                    write  (where, ' ':LeftIn(level)+8, 'StrAdr: ^t_');
                    write_name(where, typ_name^.nty_name);
                    writeln(where);
                    write  (where, ' ':LeftIn(level)+4, 'END');
                end else if (omode=vaxpas)
                                and (typ_basic_type=stringtok) then begin
                    write(where, 'VARYING[',typ_high:1, '] OF CHAR');
                end else if (omode in [m6809, pcturbo, macturbo])
                                and (typ_basic_type=stringtok) then begin
                    write(where, 'STRING[',typ_high:1, ']');
                end else begin
                    write(where, 'PACKED ARRAY [1..',typ_high:1, '] OF CHAR');
                end {if};
        end {stringtok};

        arraytok:   begin               { example  int x[100] }
                write(where, 'ARRAY [', typ_low:1, '..', typ_high:1, '] OF ');
                gen_type_pas(where, typ_subtype, level+1);
        end {arraytok};

        sequence:   begin
                write(where, 'ARRAY [1..', typ_high:1, '] OF ');
                gen_type_pas(where, typ_subtype, level+1);
        end; {sequence}

        accesstok: begin
                write(where, '^');
                gen_type_pas(where, typ_subtype, level+1);
        end;

        recordtok: begin
                writeln(where, 'RECORD');
                    scan := typ_fields;
                    while scan <> NIL do begin
                        exp2.len := 0;
                        write(where, ' ':(LeftIn(level)+4));
                        write_name(where, scan^.nty_name);
                        write(where, ': ');
                        gen_type_pas(where, scan^.nty_type, level+1);
                        writeln(where, ';');
                        scan := scan^.nty_next;
                    end {while};
                write(where, ' ':LeftIn(level), 'END {RECORD}');
        end;

    end {with, case};
end {gen_type_pas};

{___________________________________________________________________________

        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;
}

procedure generate_types(var where : text);
var
        scan:   ptr_named_type;
        expr:   expression;

begin {generate types}
    scan := typeptr;
    while scan <> nil do with scan^ do
    begin

{   Just specially for the VAX/VMS, define a basic array type for each
    length of string by descriptor:
}
        if omode = vaxvms then
            if (nty_type^.typ_basic_type = stringtok)     { Define char array: }
            then begin
                write(where, 't_');             { jammy! }
                write_name(where, nty_name);
                write(where, ' = ');
                writeln(where,
                    'PACKED ARRAY [1..',nty_type^.typ_high:1, '] OF CHAR;');
            end; {if}

{   Now make the main type definition:
}
        expr.len := 0;
        append_name(expr, nty_name);        { expr is name of variable }
        if omode in Cmode then begin
            write(where, 'typedef ');
            gen_type_decl_c(where, expr, nty_type, 1);
        end else begin
            write_name(where, nty_name);
            write(where, ' = ');
            gen_type_pas(where, nty_type,1);
        end {if};
        writeln(where, ';');
        scan := nty_next;
    end; {end_while}
    writeln(where);
end;


{_____________________________________________________________________________

        Generate External Definition File
        =================================

    PILS and FORTRAN do not get declaraction files generated, as they
    don't do enough type checking to merit it.
}
procedure ext_generator( ext_mode: output_mode; ext_name: astring);

begin
if not(omode in [pils, vaxfor])
 then if file_open(op_file, ext_name, rewriting) then begin
        client := false;
        omode := ext_mode;
        writeln(op_file);
        if omode in Cmode
            then write(op_file, '/*  ')
            else write(op_file, '{*  ');
        write(op_file, 'Stub Version Number: ');
        if version_num = 0
            then write(op_file, 'zero (no check)')
            else write(op_file, version_num:1);
        if omode in Cmode
            then writeln(op_file, '  */')
            else writeln(op_file, '  *}');
        writeln(op_file);
        if (runoptions[types].value) and (typeptr <> NIL) then
        begin
            if not(omode in Cmode) then writeln(op_file, 'TYPE');
            generate_types(op_file);
        end;
        generate_externals;
        if not(file_close(op_file)) then
                error(cant_cls_ext);
end else
        error(cant_opn_ext);
end; {EXT_GENERATOR}

{_____________________________________________________________________________


                Generate Module Declaration Code
                ================================

Generates the heading, CONST, TYPE and VAR sections of a stub module,
and the standard include files.
}
PROCEDURE gen_module(var where: text);

{       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).
}
  procedure do_include(which: opt_name);
  Var i: integer;
  begin
        write(where, '*INCLUDE rpc');
        for i:=1 to 10 do if which[i]<>' ' then write(where,which[i]);
        writeln(where);
  end;

{               Main block for Gen_module
                -------------------------

Generates:      The module header
                The constant and type definitions
}
begin {GEN_MODULE}
        {* Generate header according to xxx_mode *}

    writeln(where);
    if omode in Cmode then
    begin
        writeln(where, '#include <rpcrts.h>');
        writeln(where);
    end
    else begin

        if not (omode in [monolith, pcturbo, macturbo]) then
        begin
            write(where, 'MODULE ');
            if client then write(where, 'CLI') else write(where, 'SER');
            write_name(where, unitname);
            writeln(where, ';');
        end;

        if (omode in [pcturbo, macturbo]) then begin
            write(where, 'UNIT ');
            if client then write(where, 'CLI') else write(where, 'SER');
            write_name(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 (omode = macturbo) then
                write(where, '(5)');
            writeln(where, ';');
            writeln(where, 'INTERFACE');
            if (omode = pcturbo) then begin
                writeln(where, 'USES rpcpcpas,');
                writeln(where, '     rpcstub,');
                writeln(where, '     tsturbo,');
                if external_marshalling then writeln(where, '     extmarsh,');
                write(  where, '     rpcrts');
            end
            else begin

                { For MacTurbo things are more complicated. }

                writeln(where, '{$U RPCMacPas}');
                writeln(where, '{$U RPCStub}');
                writeln(where, '{$U TSTurbo}');
                if external_marshalling then writeln(where, '{$U extmarsh}');
                writeln(where, '{$U RPCRTS}');
                if not client then begin
                    writeln(where, '{--> It is assumed, by default, that the name of the unit library file <--}');
                    writeln(where, '{--> containing the server routines is the same as the package name.   <--}');
                    writeln(where, '{--> If the assumption is wrong, just replace the following line.      <--}');
                    write(where, '{$U '); write_name(where, unitname); writeln(where, '}');
                end;
                writeln(where);
                writeln(where, 'USES MemTypes,');
                writeln(where, '     QuickDraw,');
                writeln(where, '     OSIntf,');
                writeln(where, '     ToolIntf,');
                writeln(where, '     RPCMacPas,');
                writeln(where, '     RPCStub,');
                writeln(where, '     TSTurbo,');
                if external_marshalling then writeln(where, '     extmarsh,');
                write(  where, '     RPCRTS');
            end;

            if not client then begin
                writeln(where, ',');
                writeln(where, '{--> It is assumed, by default, that the name of the unit containing   <--}');
                writeln(where, '{--> the server routines is the same as the package name. If the       <--}');
                writeln(where, '{--> assumption is wrong, just replace the following line.             <--}');
                write  (where, '     '); write_name(  where, unitname);
            end;
            writeln(where, ';');
            writeln(where);

            if (not client) and (typeptr <> NIL) then begin
                writeln(where, '{--> Being this a server stub, the TYPE declarations should not be     <--}');
                writeln(where, '{--> included here (they belong to the unit containing the server      <--}');
                writeln(where, '{--> routines). However you will find them below (commented out), in   <--}');
                writeln(where, '{--> case you need them for reference.                                 <--}');
                writeln(where, '{');
            end;

            if (typeptr <> NIL) then
                writeln(where, 'TYPE');

        end else begin

        {* Generate constants *}
            writeln(where);
            writeln(where, 'CONST');
            do_include('const.h   ');   { Include rpc constants file }

        {* Generate types *}
            writeln(where);
            writeln(where, 'TYPE');
            do_include('types.h   ');   { Include rpc types file }

        end{if};
    end;

    generate_types(where);              { generate local types   }

    { For MacTurbo and PCTurbo server stubs stop commenting. }

    if (not client) and (omode in [pcturbo, macturbo])
        and (typeptr <> NIL) then
        writeln(where, '}');

{   Generate global variables  (handle for client, program index for server)
}
    if client then begin
        if omode in Cmode then
        begin
            write(where, 'rpc_handle h_');              { 891206 }
            write_name(where, unitname);
            writeln(where, ';')
        end
        else begin
            if (omode = cerncross)
                then writeln(where, 'EXPORT')
                else writeln(where, 'VAR');
            write(where, '    h_');
            write_name(where, unitname);
            if (omode in [vaxvms, vaxpas])
                then writeln(where, ': [global] integer;')
            else if (omode = m6809)
                then writeln(where, ': integer external;') {70604}
            else if (omode in [pcturbo, macturbo])
                then writeln(where, ': client_pointer;')   {80429}
            else
                writeln(where, ': integer;');
        end;

    end else begin {server}
        if omode in Cmode then begin
            write(where, 'program_index p_');
            write_name(where, unitname);
            writeln(where, ';')
        end else begin {pascal}
            if (omode = cerncross)
                then writeln(where, 'EXPORT')
                else writeln(where, 'VAR');
            write(where, '    p_');
            write_name(where, unitname);
            if (omode in [vaxvms, vaxpas])
                then writeln(where, ': [global] integer;')
{***        else if (omode = m6809)
                then writeln(where, ': program_index external ;')  ***}
            else if (omode in [pcturbo, macturbo])
                then writeln(where, ': program_pointer;')
            else
                writeln(where, ': program_index;');
        end {if pascal};
    end;
    writeln(where);

    if not (omode in Cmode+[pcturbo, macturbo]) then
    begin
        do_include('proc.h    ');       { External definitions of RTS }
        do_include('stub.h    ');       { Local stub procedures }
        writeln(where);
    end;

{   Declare external marshalling routines if needed:
}
    if external_marshalling
     then if (omode in Cmode+[cerncross, vaxvms, vaxpas, unixbsd, m6809])
      then decl_ext_marshal;

{*    if omode in [pcturbo, macturbo] then writeln(where, 'IMPLEMENTATION'); *}

    if (not client) and (not (omode in [pcturbo, macturbo])) then
        generate_externals;

end; {GEN_MODULE}



{******************************************************************************

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

Generates one procedure or function for the client.
}

procedure client_generator(client_mode: output_mode; cli_name: astring);
var
        scan :          ptr_block_table;
        proc_number :   integer;
{___________________________________________________
}
  procedure gen_client_block_pas(ptr: ptr_block_table);

{***
* On each block, the client allocates 'RPC_integer' variables to pack or
* unpack parameters.
****}
  var
        a:              integer;
        return_value:   expression;     { Expression for return value }

 begin {gen_client_block_pas}

  {* generate and print procedure header *}
    if omode in [vaxvms, vaxpas] then writeln(op_file, '[GLOBAL]');

  {  For MacTurbo we must generate the procedure heading
     formal parameter part ONLY in the INTERFACE section.
  }
    size_so_far := 0;       { No marshalling code generated yet }
    gen_header(op_file, ptr, false, not(omode =macturbo));

    if omode = m6809 then writeln(op_file, '    ENTRY;');

  {* print local vars and buffer allocation *}
    writeln(op_file, 'VAR rpc_p_buf: rpc_message_pointer;');
    for a := 1 to ptr^.blk_nesting do
          writeln(op_file, '    rpc_',
                                     chr(ord('a') - 1 + a), ' : rpc_integer;');
    if ptr^.b_type = functok then begin
          write(op_file, '    rpc_ret : ');
          writok(op_file, ptr^.return);
          writeln(op_file, ';');
    end;
    writeln(op_file, 'BEGIN');
    write(op_file, '  rpc_begin(rpc_p_buf, h_');
    write_name(op_file, unitname);
    writeln(op_file, ', {vers=}', version_num:1,
                     ', {proc=}', proc_number:1, ');' );
    writeln(op_file, '  WITH rpc_p_buf^ DO BEGIN');

  {* generate packing statements for IN & INOUT params *}
    if ptr^.list <> nil then gen_pack(op_file, ptr^.list, intok, true);

    writeln(op_file, '  END  {WITH};'); { 71006 }

  {* generate rpc_call and bookeeping *}

    write(op_file, '    ');
    if ptr^.blk_status_param <> NIL then begin
        write_name(op_file, ptr^.blk_status_param^.name);
        write(op_file, ' := ');
    end {if};

    if ptr^.blk_cast then write(op_file, 'rpc_cast')
                     else write(op_file, 'rpc_call');
    if ptr^.blk_status_param <> NIL then write(op_file, '_status');
    write(op_file, '(h_');
    write_name(op_file, unitname);
    write(op_file, ', rpc_p_buf');
    if not ptr^.blk_cast then write(op_file, ',', ptr^.blk_timeout:1);
    writeln(op_file, ');');

    if ptr^.blk_status_param <> NIL then begin
        write(op_file, '  IF odd(');
        write_name(op_file, ptr^.blk_status_param^.name);
        write(op_file, ') THEN ');
    end {if};
    writeln(op_file, '  WITH rpc_p_buf^ DO BEGIN');     { 71006 }

    size_so_far := 0;       { No unmarshalling code generated yet }
    if ptr^.blk_max_out>0 then begin
      if omode in Cmode
        then write(op_file, '    rpc_p_buf->m_index =')
        else write(op_file, '    m_index :=');
      writeln(op_file, ' RETURN_HEADER_LENGTH;');
    end {if};

  {* if function: unpack return value *}
    if ptr^.b_type = functok then
    begin
      write(op_file, '    ');
      dopack_simple(op_file, ptr^.return, false);
      writeln(op_file, 'rpc_ret);');
    end;

  {* generate UNpacking statements for OUT and INOUT params *}
    if ptr^.list <> nil then gen_pack(op_file, ptr^.list, outok, false);

  {* clear up everything and exit *}
    if omode in cmode then
    begin
      writeln(op_file, '    c_dispose(rpc_p_buf);');
      if ptr^.b_type = functok then writeln(op_file, '    return(rpc_ret);');
      writeln(op_file, '    }');
    end
    else begin
      if ptr^.b_type = functok then
      begin
          write(op_file, '    ');
          write_name(op_file, ptr^.name);
          writeln(op_file, ' := rpc_ret;');
      end;
      writeln(op_file, '  END  {WITH};');
      writeln(op_file, '  rpc_dispose(rpc_p_buf);');
      writeln(op_file, 'END;');
    end;
    writeln(op_file);
 end; {gen_client_block_pas}
{___________________________________________________
}
  procedure gen_client_block_c(ptr: ptr_block_table);

{***
* On each block, the client allocates 'RPC_integer' variables to pack or
* unpack parameters.
****}
  var
        a:              integer;
        return_value:   expression;     { Expression for return value }

  begin {gen_client_block_c}

  {* generate and print procedure header *}

    size_so_far := 0;       { No marshalling code generated yet }
    gen_header(op_file, ptr, false, TRUE);

  {* print local vars and buffer allocation *}

    writeln(op_file);
    writeln(op_file, '{   rpc_message *rpc_p_buf;');
    for a := 1 to ptr^.blk_nesting do
          writeln(op_file, '    register rpc_integer rpc_',
                chr(ord('a') - 1 + a), ';');
    if ptr^.b_type = functok then
    begin
          write(op_file, '    ');
          writok(op_file, ptr^.return);
          writeln(op_file, ' rpc_ret;');
    end;
    writeln(op_file);
    write(op_file, '    ');

    write(op_file, 'c_begin(rpc_p_buf, h_');
    write_name(op_file, unitname);
    writeln(op_file, ', /*vers=*/', version_num:1,
                     ', /*proc=*/', proc_number:1, ');' );

  {* generate packing statements for IN & INOUT params *}
    if ptr^.list <> nil then gen_pack(op_file, ptr^.list, intok, true);

  {* generate rpc_call and bookeeping *}
    write(op_file, '    ');
    if ptr^.blk_status_param <> NIL then begin
        write(op_file, '*');
        write_name(op_file, ptr^.blk_status_param^.name);
        write(op_file, ' = ');
    end {if};
    write(op_file, 'c_call');
    if ptr^.blk_status_param <> NIL then write(op_file, '_status');
    write(op_file, '(h_');
    write_name(op_file, unitname);
    writeln(op_file, ', rpc_p_buf, ', ptr^.blk_timeout:1, ');');

    if ptr^.blk_status_param <> NIL then begin
        write(op_file, '  if (*');
        write_name(op_file, ptr^.blk_status_param^.name);
        writeln(op_file, ' & 1) { /* If good call */ ');
    end {if};

    size_so_far := 0;       { No unmarshalling code generated yet }
    if ptr^.blk_max_out>0 then
        writeln(op_file, '    rpc_p_buf->m_index = RETURN_HEADER_LENGTH;');

  {* if function: unpack return value *}
    if ptr^.b_type = functok then
    begin
      write(op_file, '    ');
      dopack_simple(op_file, ptr^.return, false);
      writeln(op_file, 'rpc_ret);');
    end;

  {* generate UNpacking statements for OUT and INOUT params *}
    if ptr^.list <> nil then gen_pack(op_file, ptr^.list, outok, false);

    if ptr^.blk_status_param <> NIL
    then writeln(op_file, '  } /* end if good call */');


  {* clear up everything and exit *}
    writeln(op_file, '    c_dispose(rpc_p_buf);');
    if ptr^.b_type = functok then writeln(op_file, '    return(rpc_ret);');
    writeln(op_file, '    }');
    writeln(op_file);
 end; {gen_client_block_c}

{___________________________________________________
}
 procedure gen_open;
 begin
  if omode in [vaxvms, vaxpas] then
      if runoptions[noautoinit].value
          then writeln(op_file, '[GLOBAL]')
          else writeln(op_file, '[GLOBAL, INITIALIZE]');
  writok(op_file, proctok);
  write(op_file, 'open_');
  write_name(op_file, unitname);
  if omode in Cmode then writeln(op_file, '()')
                    else writeln(op_file, ';');
  if omode = m6809 then writeln(op_file, '   ENTRY;');

  if omode in Cmode then
  begin
      writeln(op_file, '{   rpc_status       status;');
  end
  else begin
      writeln(op_file, 'VAR');
      writeln(op_file, '    status : rpc_status;');
      writeln(op_file, '    service : rpc_name;');
      writeln(op_file, 'BEGIN');
      write(op_file, '    service := ');
      write_name_padded(op_file, unitname, '''');
      writeln(op_file, ';');
  end;

  if omode in Cmode then writeln(op_file);
  write(op_file, '    ');
  if not (omode in Cmode) then write(op_file, 'rp');
  write(op_file, 'c_open(status, h_');
  write_name(op_file, unitname);
  write(op_file, ', ');
  if omode in Cmode then write_name_padded(op_file, unitname,'"')
        else write(op_file, 'service');
  writeln(op_file, ');');

  write(op_file, '    ');
  if not (omode in Cmode) then write(op_file, 'rp');
  writeln(op_file, 'c_report_error(status);');
  if omode in Cmode then writeln(op_file, '    }')
      else writeln(op_file, 'END;');
 end; {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.
}
    procedure gen_close;
    begin
        if omode in [vaxvms, vaxpas] then writeln(op_file, '[GLOBAL]');
        writok(op_file, proctok);
        write(op_file, 'close_');
        write_name(op_file, unitname);
        if omode in Cmode then writeln(op_file, '()')
                          else writeln(op_file, ';');
        if omode = m6809 then writeln(op_file, '   ENTRY;');

        if omode in Cmode then
        begin
            writeln(op_file, '{   rpc_status       status;');
            writeln(op_file);
        end else begin
          writeln(op_file, 'VAR');
          writeln(op_file, '    status : rpc_status;');
          writeln(op_file, 'BEGIN');
        end;

        write(op_file, '    ');
        if not (omode in Cmode) then write(op_file, 'rp');
        write(op_file, 'c_close(status, h_');
        write_name(op_file, unitname);
        writeln(op_file, ');');

        write(op_file, '    ');
        if not (omode in Cmode) then write(op_file, 'rp');
        writeln(op_file, 'c_report_error(status);');

        if (omode = pcturbo) then begin
            write(op_file, '   ExitProc := e_');
            write_name(op_file, unitname);
            writeln(op_file, ';');
        end;

        if omode in Cmode then writeln(op_file, '    }')
                          else writeln(op_file, 'END;');
    end; {gen_close}

{______________________________________________________
}
begin {CLIENT_GENERATOR}

if file_open(op_file, cli_name, rewriting) then begin

    omode := client_mode;
    client := true;
    fragmentation_used := false;

    if omode=pils then client_generator_pils
    else if omode=vaxfor then client_gen_for
    else begin


        {* Generate module name and type, var, procedure inclusion *}
        if not (omode=monolith) then gen_module(op_file);

{       Special INTERFACE part for PCTurbo and MacTurbo:
}

        { For PCTurbo provide a variable to save the address of ExitProc }

        if (omode = pcturbo) then begin
            write(op_file, '    e_');           { Add a variable for close_x }
            write_name(op_file, unitname);
            writeln(op_file, ':   pointer;');
        end;

        if (omode in [pcturbo, macturbo]) then begin

            { 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.
            }

            proc_number := 1;
            scan := blockptr;
            while scan <> nil do begin
                gen_header(op_file, scan, false, true);
                proc_number := proc_number + 1;
                scan := scan^.next;
            end {while};

            write       (op_file, 'PROCEDURE open_');
            write_name  (op_file, unitname);
            writeln     (op_file, ';');

            write       (op_file, 'PROCEDURE close_');
            write_name  (op_file, unitname);
            writeln     (op_file, ';');

            writeln     (op_file);
            writeln     (op_file, 'IMPLEMENTATION');
            writeln     (op_file);
        end;

{*      Generate procedures *}

        proc_number := 1;
        scan := blockptr;
        while scan <> nil do begin
                if omode in Cmode   then gen_client_block_c(scan)
                                    else gen_client_block_pas(scan);
                proc_number := proc_number + 1;
                scan := scan^.next;
        end;

        gen_open;
        gen_close;      { Added for all versions now 8-May-1989 }

{       Specials for PCTurbo and MacTurbo :  Autoinit.
}

        { Exit handler only in PCTurbo version. }

        if (omode in [pcturbo, macturbo]) then begin
            if (not runoptions[noautoinit].value) or (omode = pcturbo) then
                writeln(op_file,'BEGIN');

            if (omode = pcturbo) then begin
                write(op_file,'  e_');
                    write_name(op_file, unitname);
                    writeln(op_file, ' := ExitProc;');
                write(op_file,'  ExitProc := @close_');
                    write_name(op_file, unitname);
                    writeln(op_file, ';');
            end;

            if (not runoptions[noautoinit].value) then begin
                write(op_file,'  open_');
                    write_name(op_file, unitname);
                    writeln(op_file, ';');
            end;

            writeln(op_file,'END.');
        end {if};

{*      Generate end of module *}

        if (omode in [vaxvms, vaxpas]) then
                writeln(op_file, 'END .')
        else if (omode = m6809) then
                writeln(op_file, 'MODEND .')
        else if (omode = cerncross) then
                writeln(op_file, '.');

    end {if not pils or FORTRAN};
    if fragmentation_used
        then writeln('Buffer fragmentation may be used for large parameters.');
    if not(file_close(op_file)) then
                error(cant_cls_client);
end else
        error(cant_opn_client);
end; {CLIENT_GENERATOR}



{*****************************************************************************

        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

}
PROCEDURE server_generator( server_mode:        output_mode;
                                ser_name:       astring);
var
        scan : ptr_block_table;


{       Generate server stub for one Procedure/function
        -----------------------------------------------
}
procedure gen_server_block(ptr: ptr_block_table);
{***
* 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.
****}
var
        a:              integer;
        scanlist:       ptr_idlist;
        par_count:      integer;        { how far we are getting across line }

  procedure write_Camp;
  begin
      write(op_file, ', ');
      if (omode in Cmode)
              and not (runoptions[byvalue].value and (scanlist^.attr = intok))
          then write(op_file, '&');
  end;

begin {gen_server_block}

  size_so_far := 0;         { No unmarshalling code generated yet }

  {* generate and print procedure header *}
  gen_header(op_file, ptr, false, true);

  {* print local vars and buffer allocation *}
  for a := 1 to ptr^.blk_nesting do
  begin
      write(op_file, '    ');
      if omode in Cmode then write(op_file, 'register rpc_integer ');
      write(op_file, 'rpc_', chr(ord('a') - 1 + a));
      if not (omode in Cmode) then write(op_file, ' : rpc_integer');
      writeln(op_file, ';');
  end;

  if omode in Cmode then writeln(op_file)
  else begin
      writeln(op_file, 'BEGIN');
      writeln(op_file, '  WITH rpc_p_buf^ DO BEGIN');
  end;

  {* generate UNpacking statements for IN and INOUT params *}
  if ptr^.list <> nil then gen_pack(op_file, ptr^.list, intok, false);

{ Generate call and bookeeping:
}
  if omode in Cmode
    then writeln(op_file, '    c_turn(rpc_p_buf);')
    else begin {pascal}
        writeln(op_file, '    rpc_p_buf^.which := RETURN_MESSAGE;');
        writeln(op_file, '    rpc_p_buf^.m_index := RETURN_HEADER_LENGTH;');
    end; {if pascal}

  size_so_far := 0;         { No marshalling code generated yet }

  if (ptr^.b_type = proctok) and ptr^.in_only
  then if (runoptions[concurrent].value or ptr^.blk_concurrent)
         then begin
            if (omode in Cmode) then write(op_file, '    c')
                                else write(op_file, '    rpc');
            writeln(op_file, '_early_return(rpc_p_buf);')
         end else if ptr^.blk_cast
         then   if omode in Cmode
                then writeln(op_file, '    rpc_p_buf->m_status=1;')
                else writeln(op_file, '    m_status:=1;');
  write(op_file, '    ');

{   If function: generate return variable *}
  if ptr^.b_type = functok then dopack_simple(op_file, ptr^.return, true);

{ Generate list of variables:
}
  write_name(op_file, ptr^.name);
  if ptr^.list <> nil then
  begin
      write(op_file, '(');
      scanlist := ptr^.list;
      par_count := 1;
      repeat

{       Generate address of simple types and records in C if necessary:
}
          if (omode in Cmode)
             and (scanlist^.id_type^.typ_basic_type in
                                [chartok..longtok, recordtok])
             and not (runoptions[byvalue].value and (scanlist^.attr = intok))
          then write(op_file, '&');

{ If var is SEQUENCE or SUBSTRING or STRING put all names
}
          if (scanlist^.id_type^.typ_basic_type = sequence) then
          begin
              write(op_file, 'a_');
              write_name(op_file, scanlist^.name);
              par_count := par_count + 1;
              write_Camp;
              write(op_file, 'l_');
          end
          else if (scanlist^.id_type^.typ_basic_type = substring) then
          begin
              write(op_file, 'a_');
              write_name(op_file, scanlist^.name);
              write_Camp;
              write(op_file, 's_');
              write_name(op_file, scanlist^.name);
              par_count := par_count + 2;
              write_Camp;
              write(op_file, 'l_');
          end
          else if (scanlist^.id_type^.typ_basic_type = stringtok)
                 and not (omode in (Cmode +
                        [vaxvms, vaxpas, m6809, pcturbo, macturbo])) then
          begin
              write(op_file, 'a_');
              write_name(op_file, scanlist^.name);
              par_count := par_count + 1;
              write(op_file, ', l_');
          end;

{   Write the main parameter name:
}
          write_name(op_file, scanlist^.name);

          par_count := par_count + 1;
          scanlist := scanlist^.next;
          if scanlist <> nil then begin
              write(op_file, ', ');
              if par_count > 3 then     { Line wrap around }
              begin
                  writeln(op_file);
                  write(op_file, '        ');
                  par_count := 0;
              end;
          end {if};
      until scanlist = nil;
      write(op_file, ')');
  end
  else if omode in Cmode then write(op_file, '()');

  {* if function generates return variable *}
  if ptr^.b_type = functok then write(op_file, ')');

  writeln(op_file, ';');

  {* generate packing statements for OUT and INOUT params*}
  if ptr^.list <> nil then gen_pack(op_file, ptr^.list, outok, true);

{* writeln(op_file, '    rpc_early_return(rpc_p_buf, m_index);');   oct 86 *}

  if omode in Cmode then writeln(op_file, '    }')
  else begin
      writeln(op_file, '  END {with};');
      writeln(op_file, 'END;');
  end;
  writeln(op_file);
end; {gen_server_block}


{       Generate Main Server Procedure
        ------------------------------
}
procedure gen_jump_proc;
var
        proc_num : integer;

begin
  if omode in Cmode then
  begin
      writeln(op_file, 'static rpc_message *rpc_p_buf;');
      writeln(op_file);
      scan := blockptr;
      proc_num := 0;
      while scan <> nil do
      begin
          gen_server_block(scan);
          scan := scan^.next;
          proc_num := proc_num + 1;
      end;
  end;

  if omode in [vaxvms, vaxpas] then writeln(op_file, '[GLOBAL]');
  writok(op_file, proctok);
  write(op_file, 'r_');
  write_name(op_file, unitname);
  if omode in Cmode
      then writeln(op_file, '(rpc_a) rpc_message **rpc_a;')     { 71217 }
      else writeln(op_file, '(VAR rpc_p_buf : rpc_message_pointer);');
  if omode = m6809 then writeln(op_file, '    ENTRY;');

  if omode in Cmode then writeln(op_file, '{   rpc_short request;')
  else begin
      writeln(op_file, 'VAR');
      writeln(op_file, '    request : rpc_short;');
  end;

   {* 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 not (omode in Cmode) then
  begin
      scan := blockptr;
      proc_num := 0;
      while scan <> nil do
      begin
          gen_server_block(scan);
          scan := scan^.next;
          proc_num := proc_num + 1;
      end;

      writeln(op_file, 'BEGIN');
      writeln(op_file, '  WITH rpc_p_buf^ DO BEGIN');
      write(op_file, '    m_index :');
  end
  else begin
      writeln(op_file);
      writeln(op_file, '    rpc_p_buf = *rpc_a;');              { 71217 }
      write(op_file, '    rpc_p_buf->m_index ');
  end;

  write(op_file, '= CALL_HEADER_LENGTH - ');
  if version_num = 0 then writeln(op_file, '2;')
  else begin
      writeln(op_file, '4;');
      writeln(op_file, '    upk_short(rpc_p_buf, request);');
      if omode in Cmode then
      begin
          writeln(op_file,
                '    if (request != 0 && request != ', version_num:1, ')');
          writeln(op_file,
                '         rpc_p_buf->m_status = RPC_S_UNSUPPORTED_VERSION;');
          writeln(op_file,
                '    else {');
      end
      else begin
          writeln(op_file, '    IF (request<>0) AND (request<>', version_num:1, ')');
          writeln(op_file, '    THEN m_status := RPC_S_UNSUPPORTED_VERSION');
          writeln(op_file, '    ELSE begin');
      end;
  end;
  writeln(op_file, '     upk_short(rpc_p_buf, request);');

  if omode in Cmode then
  begin
      writeln(op_file, '     switch (request)');
      write(op_file, '     {   ');
  end
  else begin
      writeln(op_file, '     IF (request = 0) OR (request > ', proc_num:1, ') THEN');
      writeln(op_file, '         m_status := RPC_S_BAD_PROCEDURE_NUMBER');
      writeln(op_file, '     ELSE CASE request OF');
      write(op_file, '        ');
  end;

  scan := blockptr;
  proc_num := 1;
  while scan <> nil do
  begin
      if omode in Cmode then write(op_file, 'case ');
      write(op_file, proc_num:2, ' : r_');
      write_name(op_file, scan^.name);
      if omode in Cmode then write(op_file, '()');
      writeln(op_file, ';');
      proc_num := proc_num + 1;
      scan := scan^.next;
      if (omode in Cmode) then
              writeln(op_file, '                  break;');
      write(op_file, '        ');
  end;

  if omode in Cmode then
  begin
      writeln(op_file, 'default : rpc_p_buf->m_status = RPC_S_BAD_PROCEDURE_NUMBER;');
      writeln(op_file, '        }');
      if version_num <> 0 then writeln(op_file, '     }');      { switch }
      writeln(op_file, '    }');                { if else }
  end
  else begin
      writeln(op_file, 'END {case};');
      if version_num <> 0 then writeln(op_file, '    END {if};');
      writeln(op_file, '  END {with};');
      writeln(op_file, 'END;');
  end;
  writeln(op_file);
end; {GEN_JUMP_PROC}


{       Generate Code to Attach stub to RPCRTS
        --------------------------------------
}

procedure gen_attach;
begin
  if omode in [vaxvms, vaxpas] then
      if runoptions[noautoinit].value
          then writeln(op_file,   '[GLOBAL]')
          else writeln(op_file,   '[GLOBAL, INITIALIZE]');

  writok(op_file, proctok);
  write(op_file, 'attach_');
  write_name(op_file, unitname);
  if omode in Cmode then writeln(op_file, '()')
                    else writeln(op_file, ';');

  if omode in Cmode then
  begin
      writeln(op_file, '{   rpc_status      status;');
      writeln(op_file);
  end
  else begin
      writeln(op_file, 'VAR');
      writeln(op_file, '    status  : rpc_status;');
      writeln(op_file, '    service : rpc_name;');
      writeln(op_file, 'BEGIN');
      write(op_file, '    service := ');
      write_name_padded(op_file, unitname, '''');
      writeln(op_file, ';');
  end;

  write(op_file, '    ');
  if not (omode in Cmode) then write(op_file, 'rp');

  { For PCTurbo and MacTurbo use the @ operator to pass the stub pointer. }

  if (omode in [pcturbo, macturbo]) then
        write(op_file, 'c_attach_stub(status, @r_')
  else
        write(op_file, 'c_attach_stub(status, r_');

  write_name(op_file, unitname);
  write(op_file, ', ');
  if omode in Cmode then begin
                writeln(op_file); write(op_file, '        ');
                write_name_padded(op_file, unitname, '"')
        end else
                write (op_file, 'service');
  write  (op_file, ', p_');
  write_name(op_file, unitname);
  writeln(op_file, ');');

  write(op_file, '    ');
  if not (omode in Cmode) then write(op_file, 'rp');
  writeln(op_file, 'c_report_error(status);');

  if omode in Cmode
      then writeln(op_file, '    }')
      else writeln(op_file, 'END;');
end; {GEN_ATTACH}


{       Generate Code to Detach stub from RPCRTS
        ----------------------------------------
}

    procedure gen_detach;
    begin
      if omode in [vaxvms, vaxpas] then writeln(op_file,   '[GLOBAL]');

      writok(op_file, proctok);
      write(op_file, 'detach_');
      write_name(op_file, unitname);
      if omode in Cmode then writeln(op_file, '()')
                        else writeln(op_file, ';');

      if omode in Cmode then begin
          writeln(op_file, '{');
      end else begin
          writeln(op_file, 'BEGIN');
      end;

      write(op_file, '    ');
      if not (omode in Cmode) then write(op_file, 'rp');

      write(op_file, 'c_detach_stub(p_');
      write_name(op_file, unitname);
      writeln(op_file, ');');

      if omode in Cmode
          then writeln(op_file, '    }')
          else writeln(op_file, 'END;');

    end; {gen_detach}


{       MAIN BLOCK:     GENERATE SERVER FILE
        ==========      ====================
}

begin {SERVER_GENERATOR}

  if file_open(op_file, ser_name, rewriting) then begin

    omode := server_mode;
    client := false;
    fragmentation_used := false;

    if omode=pils then server_generator_pils
    else if omode=vaxfor then server_gen_for
    else begin

        {* Generate module name and type, var, procedure inclusion *}
        if not (omode in [monolith]) then gen_module(op_file);

{       Special INTERFACE part for PCTurbo and MacTurbo:
}

        if (omode in [pcturbo, macturbo]) then begin

            { For MacTurbo and PCTurbo the global procedure
              headings must appear in the interface part.
            }

            { Declare the attach procedure. }

            write       (op_file, 'PROCEDURE attach_');
            write_name  (op_file, unitname);
            writeln     (op_file, ';');

            { 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 (omode = pcturbo) then begin
                write   (op_file, 'PROCEDURE r_');
                write_name      (op_file, unitname);
                writeln (op_file, '(VAR rpc_p_buf : rpc_message_pointer);');
            end;

            writeln     (op_file);
            writeln     (op_file, 'IMPLEMENTATION');
            writeln     (op_file);
        end;

        {* Generate the jump table for the server *}
        gen_jump_proc;

        {* Generate the attach procedure *}
        if not (omode in [m6809]) then gen_attach;
                        {* this can't handle procedure parameters *}

        {* Generate end of module *}
        if (omode in [vaxvms, vaxpas, pcturbo, macturbo]) then
                writeln(op_file, 'END .')
        else if (omode = m6809) then
                writeln(op_file, 'MODEND .')
        else if (omode = cerncross) then
                writeln(op_file, '.');

    end {if not pils or vaxfor};
    if not(file_close(op_file)) then
                error(cant_cls_server);
    if fragmentation_used
        then writeln('Buffer fragmentation may be used for large parameters.');
  end else
        error(cant_opn_server);
end; {SERVER_GENERATOR}



{               Main Program
                ------------
}
begin {MAIN}

    init_global;                        {* Global initialization *}
    get_parameters;                     {* Get command line parameters *}
    parser;                             {* Parse input *}

    if not file_close(inp_file)         {* Close input file *}
        then error(cant_cls_input);

    if not runoptions[version].value    {* Generate stub version number *}
    then begin
        version_num := checksum + 1000;
        writeln('RPCC: generated stub version number is ', version_num:1, '.');
    end;

    if runoptions[dtree].value          {* Debugging : print trees *}
    then begin
        print_tab_types;
        print_tab_blocks;
    end
    else if not (ser_spec or cli_spec) then
        writeln('RPCC: no stubs specified - no code generated, hope that''s okay.');

    if errorfound > 0 then begin    {* Exit gracefully on error *}
           writeln('RPCC: ',errorfound:3,
                ' errors found, no code generated.');
           halt;
    end;

{       Generate client stubs and .ext files }

    if cli_spec then begin
        client_generator(cli_mode, cli_name);
        ext_generator(cli_mode, ext_name)
    end;

{       Generate server stubs }

    if ser_spec then begin
        server_generator(ser_mode, ser_name);
    end;

end. {MAIN}
